- Timestamp:
- 2020-12-02T16:32:24+01:00 (3 years ago)
- Location:
- NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/src/OCE/DIA
- Files:
-
- 3 edited
-
diaar5.F90 (modified) (24 diffs)
-
diahsb.F90 (modified) (19 diffs)
-
diaptr.F90 (modified) (26 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/src/OCE/DIA/diaar5.F90
r13497 r14017 10 10 !! dia_ar5_init : initialisation of AR5 diagnostics 11 11 !!---------------------------------------------------------------------- 12 USE oce ! ocean dynamics and active tracers 12 USE oce ! ocean dynamics and active tracers 13 13 USE dom_oce ! ocean space and time domain 14 14 USE eosbn2 ! equation of state (eos_bn2 routine) … … 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 38 39 39 40 !! * Substitutions 40 41 # include "do_loop_substitute.h90" … … 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 ) … … 76 78 REAL(wp) :: zaw, zbw, zrw 77 79 ! 78 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zarea_ssh , zbotpres ! 2D workspace 79 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2d, zpe ! 2D workspace 80 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zarea_ssh , zbotpres ! 2D workspace 81 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2d, zpe ! 2D workspace 80 82 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z3d, zrhd, ztpot, zgdept ! 3D workspace (zgdept: needed to use the substitute) 81 83 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ztsn ! 4D workspace … … 83 85 !!-------------------------------------------------------------------- 84 86 IF( ln_timing ) CALL timing_start('dia_ar5') 85 87 86 88 IF( kt == nit000 ) CALL dia_ar5_init 87 89 88 IF( l_ar5 ) THEN 90 IF( l_ar5 ) THEN 89 91 ALLOCATE( zarea_ssh(jpi,jpj), zbotpres(jpi,jpj), z2d(jpi,jpj) ) 90 92 ALLOCATE( zrhd(jpi,jpj,jpk) ) … … 97 99 CALL iom_put( 'areacello', e1e2t(:,:) ) 98 100 ! 99 IF( iom_use( 'volcello' ) .OR. iom_use( 'masscello' ) ) THEN 101 IF( iom_use( 'volcello' ) .OR. iom_use( 'masscello' ) ) THEN 100 102 zrhd(:,:,jpk) = 0._wp ! ocean volume ; rhd is used as workspace 101 103 DO jk = 1, jpkm1 … … 104 106 DO jk = 1, jpk 105 107 z3d(:,:,jk) = rho0 * e3t(:,:,jk,Kmm) * tmask(:,:,jk) 106 END DO 108 END DO 107 109 CALL iom_put( 'volcello' , zrhd(:,:,:) ) ! WARNING not consistent with CMIP DR where volcello is at ca. 2000 108 110 CALL iom_put( 'masscello' , z3d (:,:,:) ) ! ocean mass 109 ENDIF 111 ENDIF 110 112 ! 111 113 IF( iom_use( 'e3tb' ) ) THEN ! bottom layer thickness … … 115 117 END_2D 116 118 CALL iom_put( 'e3tb', z2d ) 117 ENDIF 118 ! 119 IF( iom_use( 'voltot' ) .OR. iom_use( 'sshtot' ) .OR. iom_use( 'sshdyn' ) ) THEN 119 ENDIF 120 ! 121 IF( iom_use( 'voltot' ) .OR. iom_use( 'sshtot' ) .OR. iom_use( 'sshdyn' ) ) THEN 120 122 ! ! total volume of liquid seawater 121 zvolssh = glob_sum( 'diaar5', zarea_ssh(:,:) ) 123 zvolssh = glob_sum( 'diaar5', zarea_ssh(:,:) ) 122 124 zvol = vol0 + zvolssh 123 125 124 126 CALL iom_put( 'voltot', zvol ) 125 127 CALL iom_put( 'sshtot', zvolssh / area_tot ) … … 128 130 ENDIF 129 131 130 IF( iom_use( 'botpres' ) .OR. iom_use( 'sshthster' ) .OR. iom_use( 'sshsteric' ) ) THEN 131 ! 132 IF( iom_use( 'botpres' ) .OR. iom_use( 'sshthster' ) .OR. iom_use( 'sshsteric' ) ) THEN 133 ! 132 134 ztsn(:,:,:,jp_tem) = ts(:,:,:,jp_tem,Kmm) ! thermosteric ssh 133 135 ztsn(:,:,:,jp_sal) = sn0(:,:,:) … … 155 157 !!gm 156 158 END IF 157 ! 158 zarho = glob_sum( 'diaar5', e1e2t(:,:) * zbotpres(:,:) ) 159 ! 160 zarho = glob_sum( 'diaar5', e1e2t(:,:) * zbotpres(:,:) ) 159 161 zssh_steric = - zarho / area_tot 160 162 CALL iom_put( 'sshthster', zssh_steric ) 161 163 162 164 ! ! steric sea surface height 163 165 zbotpres(:,:) = 0._wp ! no atmospheric surface pressure, levitating sea-ice … … 177 179 END IF 178 180 END IF 179 ! 180 zarho = glob_sum( 'diaar5', e1e2t(:,:) * zbotpres(:,:) ) 181 ! 182 zarho = glob_sum( 'diaar5', e1e2t(:,:) * zbotpres(:,:) ) 181 183 zssh_steric = - zarho / area_tot 182 184 CALL iom_put( 'sshsteric', zssh_steric ) … … 190 192 ENDIF 191 193 192 IF( iom_use( 'masstot' ) .OR. iom_use( 'temptot' ) .OR. iom_use( 'saltot' ) ) THEN 194 IF( iom_use( 'masstot' ) .OR. iom_use( 'temptot' ) .OR. iom_use( 'saltot' ) ) THEN 193 195 ! ! Mean density anomalie, temperature and salinity 194 196 ztsn(:,:,:,:) = 0._wp ! ztsn(:,:,1,jp_tem/sal) is used here as 2D Workspace for temperature & salinity … … 204 206 DO jj = 1, jpj 205 207 iks = mikt(ji,jj) 206 ztsn(ji,jj,1,jp_tem) = ztsn(ji,jj,1,jp_tem) + zarea_ssh(ji,jj) * ts(ji,jj,iks,jp_tem,Kmm) 207 ztsn(ji,jj,1,jp_sal) = ztsn(ji,jj,1,jp_sal) + zarea_ssh(ji,jj) * ts(ji,jj,iks,jp_sal,Kmm) 208 ztsn(ji,jj,1,jp_tem) = ztsn(ji,jj,1,jp_tem) + zarea_ssh(ji,jj) * ts(ji,jj,iks,jp_tem,Kmm) 209 ztsn(ji,jj,1,jp_sal) = ztsn(ji,jj,1,jp_sal) + zarea_ssh(ji,jj) * ts(ji,jj,iks,jp_sal,Kmm) 208 210 END DO 209 211 END DO 210 212 ELSE 211 ztsn(:,:,1,jp_tem) = ztsn(:,:,1,jp_tem) + zarea_ssh(:,:) * ts(:,:,1,jp_tem,Kmm) 212 ztsn(:,:,1,jp_sal) = ztsn(:,:,1,jp_sal) + zarea_ssh(:,:) * ts(:,:,1,jp_sal,Kmm) 213 ztsn(:,:,1,jp_tem) = ztsn(:,:,1,jp_tem) + zarea_ssh(:,:) * ts(:,:,1,jp_tem,Kmm) 214 ztsn(:,:,1,jp_sal) = ztsn(:,:,1,jp_sal) + zarea_ssh(:,:) * ts(:,:,1,jp_sal,Kmm) 213 215 END IF 214 216 ENDIF … … 216 218 ztemp = glob_sum( 'diaar5', ztsn(:,:,1,jp_tem) ) 217 219 zsal = glob_sum( 'diaar5', ztsn(:,:,1,jp_sal) ) 218 zmass = rho0 * ( zarho + zvol ) 220 zmass = rho0 * ( zarho + zvol ) 219 221 ! 220 222 CALL iom_put( 'masstot', zmass ) … … 222 224 CALL iom_put( 'saltot' , zsal / zvol ) 223 225 ! 224 ENDIF 226 ENDIF 225 227 226 228 IF( ln_teos10 ) THEN ! ! potential temperature (TEOS-10 case) … … 242 244 z2d(:,:) = z2d(:,:) + e1e2t(:,:) * e3t(:,:,jk,Kmm) * ztpot(:,:,jk) 243 245 END DO 244 ztemp = glob_sum( 'diaar5', z2d(:,:) ) 246 ztemp = glob_sum( 'diaar5', z2d(:,:) ) 245 247 CALL iom_put( 'temptot_pot', ztemp / zvol ) 246 248 ENDIF 247 249 ! 248 250 IF( iom_use( 'ssttot' ) ) THEN ! Output potential temperature in case we use TEOS-10 249 zsst = glob_sum( 'diaar5', e1e2t(:,:) * ztpot(:,:,1) ) 251 zsst = glob_sum( 'diaar5', e1e2t(:,:) * ztpot(:,:,1) ) 250 252 CALL iom_put( 'ssttot', zsst / area_tot ) 251 253 ENDIF … … 256 258 z2d(ji,jj) = z2d(ji,jj) + rho0 * e3t(ji,jj,jk,Kmm) * ztpot(ji,jj,jk) 257 259 END_3D 258 CALL iom_put( 'tosmint_pot', z2d ) 260 CALL iom_put( 'tosmint_pot', z2d ) 259 261 ENDIF 260 262 DEALLOCATE( ztpot ) 261 263 ENDIF 262 ELSE 264 ELSE 263 265 IF( iom_use('ssttot') ) THEN ! Output sst in case we use EOS-80 264 266 zsst = glob_sum( 'diaar5', e1e2t(:,:) * ts(:,:,1,jp_tem,Kmm) ) … … 267 269 ENDIF 268 270 269 IF( iom_use( 'tnpeo' )) THEN 271 IF( iom_use( 'tnpeo' )) THEN 270 272 ! Work done against stratification by vertical mixing 271 273 ! Exclude points where rn2 is negative as convection kicks in here and … … 304 306 END SUBROUTINE dia_ar5 305 307 306 307 SUBROUTINE dia_ar5_hst( ktra, cptr, puflx, pvflx ) 308 ! TEMP: [tiling] These changes not necessary if using XIOS (subdomain support, will not output haloes) 309 SUBROUTINE dia_ar5_hst( ktra, cptr, puflx, pvflx ) 308 310 !!---------------------------------------------------------------------- 309 311 !! *** ROUTINE dia_ar5_htr *** … … 314 316 INTEGER , INTENT(in ) :: ktra ! tracer index 315 317 CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf' 316 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(in) :: puflx ! u-flux of advection/diffusion317 REAL(wp), DIMENSION( jpi,jpj,jpk), INTENT(in) :: pvflx ! v-flux of advection/diffusion318 REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in) :: puflx ! u-flux of advection/diffusion 319 REAL(wp), DIMENSION(A2D(nn_hls),jpk) , INTENT(in) :: pvflx ! v-flux of advection/diffusion 318 320 ! 319 321 INTEGER :: ji, jj, jk 320 REAL(wp), DIMENSION(jpi,jpj) :: z2d 321 322 323 z2d(:,:) = puflx(:,:,1) 324 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 325 z2d(ji,jj) = z2d(ji,jj) + puflx(ji,jj,jk) 326 END_3D 327 CALL lbc_lnk( 'diaar5', z2d, 'U', -1.0_wp ) 328 IF( cptr == 'adv' ) THEN 329 IF( ktra == jp_tem ) CALL iom_put( 'uadv_heattr' , rho0_rcp * z2d ) ! advective heat transport in i-direction 330 IF( ktra == jp_sal ) CALL iom_put( 'uadv_salttr' , rho0 * z2d ) ! advective salt transport in i-direction 331 ENDIF 332 IF( cptr == 'ldf' ) THEN 333 IF( ktra == jp_tem ) CALL iom_put( 'udiff_heattr' , rho0_rcp * z2d ) ! diffusive heat transport in i-direction 334 IF( ktra == jp_sal ) CALL iom_put( 'udiff_salttr' , rho0 * z2d ) ! diffusive salt transport in i-direction 335 ENDIF 336 ! 337 z2d(:,:) = pvflx(:,:,1) 338 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 339 z2d(ji,jj) = z2d(ji,jj) + pvflx(ji,jj,jk) 340 END_3D 341 CALL lbc_lnk( 'diaar5', z2d, 'V', -1.0_wp ) 342 IF( cptr == 'adv' ) THEN 343 IF( ktra == jp_tem ) CALL iom_put( 'vadv_heattr' , rho0_rcp * z2d ) ! advective heat transport in j-direction 344 IF( ktra == jp_sal ) CALL iom_put( 'vadv_salttr' , rho0 * z2d ) ! advective salt transport in j-direction 345 ENDIF 346 IF( cptr == 'ldf' ) THEN 347 IF( ktra == jp_tem ) CALL iom_put( 'vdiff_heattr' , rho0_rcp * z2d ) ! diffusive heat transport in j-direction 348 IF( ktra == jp_sal ) CALL iom_put( 'vdiff_salttr' , rho0 * z2d ) ! diffusive salt transport in j-direction 349 ENDIF 350 322 323 IF( cptr /= 'adv' .AND. cptr /= 'ldf' ) RETURN 324 IF( ktra /= jp_tem .AND. ktra /= jp_sal ) RETURN 325 326 IF( cptr == 'adv' ) THEN 327 DO_2D( 0, 0, 0, 0 ) 328 hstr_adv(ji,jj,ktra,1) = puflx(ji,jj,1) 329 hstr_adv(ji,jj,ktra,2) = pvflx(ji,jj,1) 330 END_2D 331 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 332 hstr_adv(ji,jj,ktra,1) = hstr_adv(ji,jj,ktra,1) + puflx(ji,jj,jk) 333 hstr_adv(ji,jj,ktra,2) = hstr_adv(ji,jj,ktra,2) + pvflx(ji,jj,jk) 334 END_3D 335 ELSE IF( cptr == 'ldf' ) THEN 336 DO_2D( 0, 0, 0, 0 ) 337 hstr_ldf(ji,jj,ktra,1) = puflx(ji,jj,1) 338 hstr_ldf(ji,jj,ktra,2) = pvflx(ji,jj,1) 339 END_2D 340 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 341 hstr_ldf(ji,jj,ktra,1) = hstr_ldf(ji,jj,ktra,1) + puflx(ji,jj,jk) 342 hstr_ldf(ji,jj,ktra,2) = hstr_ldf(ji,jj,ktra,2) + pvflx(ji,jj,jk) 343 END_3D 344 ENDIF 345 346 IF( ntile == 0 .OR. ntile == nijtile ) THEN 347 IF( cptr == 'adv' ) THEN 348 IF( ktra == jp_tem ) CALL iom_put( 'uadv_heattr' , rho0_rcp * hstr_adv(:,:,ktra,1) ) ! advective heat transport in i-direction 349 IF( ktra == jp_sal ) CALL iom_put( 'uadv_salttr' , rho0 * hstr_adv(:,:,ktra,1) ) ! advective salt transport in i-direction 350 IF( ktra == jp_tem ) CALL iom_put( 'vadv_heattr' , rho0_rcp * hstr_adv(:,:,ktra,2) ) ! advective heat transport in j-direction 351 IF( ktra == jp_sal ) CALL iom_put( 'vadv_salttr' , rho0 * hstr_adv(:,:,ktra,2) ) ! advective salt transport in j-direction 352 ENDIF 353 IF( cptr == 'ldf' ) THEN 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 IF( ktra == jp_tem ) CALL iom_put( 'vdiff_heattr' , rho0_rcp * hstr_ldf(:,:,ktra,2) ) ! diffusive heat transport in j-direction 357 IF( ktra == jp_sal ) CALL iom_put( 'vdiff_salttr' , rho0 * hstr_ldf(:,:,ktra,2) ) ! diffusive salt transport in j-direction 358 ENDIF 359 ENDIF 360 351 361 END SUBROUTINE dia_ar5_hst 352 362 … … 355 365 !!---------------------------------------------------------------------- 356 366 !! *** ROUTINE dia_ar5_init *** 357 !! 367 !! 358 368 !! ** Purpose : initialization for AR5 diagnostic computation 359 369 !!---------------------------------------------------------------------- … … 361 371 INTEGER :: ik, idep 362 372 INTEGER :: ji, jj, jk ! dummy loop indices 363 REAL(wp) :: zztmp 373 REAL(wp) :: zztmp 364 374 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: zsaldta ! Jan/Dec levitus salinity 365 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zvol0 375 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zvol0 366 376 ! 367 377 !!---------------------------------------------------------------------- 368 378 ! 369 379 l_ar5 = .FALSE. 370 IF( iom_use( 'voltot' ) .OR. iom_use( 'sshtot' ) .OR. iom_use( 'sshdyn' ) .OR. & 371 & iom_use( 'masstot' ) .OR. iom_use( 'temptot' ) .OR. iom_use( 'saltot' ) .OR. & 380 IF( iom_use( 'voltot' ) .OR. iom_use( 'sshtot' ) .OR. iom_use( 'sshdyn' ) .OR. & 381 & iom_use( 'masstot' ) .OR. iom_use( 'temptot' ) .OR. iom_use( 'saltot' ) .OR. & 372 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' ) .OR. & 373 387 & iom_use( 'rhop' ) ) L_ar5 = .TRUE. 374 388 375 389 IF( l_ar5 ) THEN 376 390 ! … … 386 400 idep = tmask(ji,jj,jk) * e3t_0(ji,jj,jk) 387 401 zvol0 (ji,jj) = zvol0 (ji,jj) + idep * e1e2t(ji,jj) 388 thick0(ji,jj) = thick0(ji,jj) + idep 402 thick0(ji,jj) = thick0(ji,jj) + idep 389 403 END_3D 390 404 vol0 = glob_sum( 'diaar5', zvol0 ) … … 398 412 CALL iom_close( inum ) 399 413 400 sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) ) 414 sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) ) 401 415 sn0(:,:,:) = sn0(:,:,:) * tmask(:,:,:) 402 416 IF( ln_zps ) THEN ! z-coord. partial steps -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/src/OCE/DIA/diahsb.F90
r13286 r14017 4 4 !! Ocean diagnostics: Heat, salt and volume budgets 5 5 !!====================================================================== 6 !! History : 3.3 ! 2010-09 (M. Leclair) Original code 6 !! History : 3.3 ! 2010-09 (M. Leclair) Original code 7 7 !! ! 2012-10 (C. Rousset) add iom_put 8 8 !!---------------------------------------------------------------------- … … 21 21 USE domvvl ! vertical scale factors 22 22 USE traqsr ! penetrative solar radiation 23 USE trabbc ! bottom boundary condition 23 USE trabbc ! bottom boundary condition 24 24 USE trabbc ! bottom boundary condition 25 25 USE restart ! ocean restart … … 44 44 REAL(wp) :: frc_wn_t, frc_wn_s ! global forcing trends 45 45 ! 46 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: surf 46 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: surf 47 47 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: surf_ini , ssh_ini ! 48 48 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ssh_hc_loc_ini, ssh_sc_loc_ini ! … … 62 62 !!--------------------------------------------------------------------------- 63 63 !! *** ROUTINE dia_hsb *** 64 !! 64 !! 65 65 !! ** Purpose: Compute the ocean global heat content, salt content and volume conservation 66 !! 66 !! 67 67 !! ** Method : - Compute the deviation of heat content, salt content and volume 68 68 !! at the current time step from their values at nit000 … … 75 75 INTEGER :: ji, jj, jk ! dummy loop indice 76 76 REAL(wp) :: zdiff_hc , zdiff_sc ! heat and salt content variations 77 REAL(wp) :: zdiff_hc1 , zdiff_sc1 ! - - - - 77 REAL(wp) :: zdiff_hc1 , zdiff_sc1 ! - - - - 78 78 REAL(wp) :: zdiff_v1 , zdiff_v2 ! volume variation 79 79 REAL(wp) :: zerr_hc1 , zerr_sc1 ! heat and salt content misfit … … 86 86 REAL(wp), DIMENSION(jpi,jpj,jpkm1) :: zwrk ! 3D workspace 87 87 !!--------------------------------------------------------------------------- 88 IF( ln_timing ) CALL timing_start('dia_hsb') 88 IF( ln_timing ) CALL timing_start('dia_hsb') 89 89 ! 90 90 ts(:,:,:,1,Kmm) = ts(:,:,:,1,Kmm) * tmask(:,:,:) ; ts(:,:,:,1,Kbb) = ts(:,:,:,1,Kbb) * tmask(:,:,:) ; … … 119 119 z2d1(:,:) = surf(:,:) * ww(:,:,1) * ts(:,:,1,jp_sal,Kbb) 120 120 END IF 121 z_wn_trd_t = - glob_sum( 'diahsb', z2d0 ) 121 z_wn_trd_t = - glob_sum( 'diahsb', z2d0 ) 122 122 z_wn_trd_s = - glob_sum( 'diahsb', z2d1 ) 123 123 ENDIF … … 145 145 DO ji = 1, jpi 146 146 DO jj = 1, jpj 147 z2d0(ji,jj) = surf(ji,jj) * ( ts(ji,jj,mikt(ji,jj),jp_tem,Kmm) * ssh(ji,jj,Kmm) - ssh_hc_loc_ini(ji,jj) ) 148 z2d1(ji,jj) = surf(ji,jj) * ( ts(ji,jj,mikt(ji,jj),jp_sal,Kmm) * ssh(ji,jj,Kmm) - ssh_sc_loc_ini(ji,jj) ) 147 z2d0(ji,jj) = surf(ji,jj) * ( ts(ji,jj,mikt(ji,jj),jp_tem,Kmm) * ssh(ji,jj,Kmm) - ssh_hc_loc_ini(ji,jj) ) 148 z2d1(ji,jj) = surf(ji,jj) * ( ts(ji,jj,mikt(ji,jj),jp_sal,Kmm) * ssh(ji,jj,Kmm) - ssh_sc_loc_ini(ji,jj) ) 149 149 END DO 150 150 END DO 151 151 ELSE ! no under ice-shelf seas 152 z2d0(:,:) = surf(:,:) * ( ts(:,:,1,jp_tem,Kmm) * ssh(:,:,Kmm) - ssh_hc_loc_ini(:,:) ) 153 z2d1(:,:) = surf(:,:) * ( ts(:,:,1,jp_sal,Kmm) * ssh(:,:,Kmm) - ssh_sc_loc_ini(:,:) ) 152 z2d0(:,:) = surf(:,:) * ( ts(:,:,1,jp_tem,Kmm) * ssh(:,:,Kmm) - ssh_hc_loc_ini(:,:) ) 153 z2d1(:,:) = surf(:,:) * ( ts(:,:,1,jp_sal,Kmm) * ssh(:,:,Kmm) - ssh_sc_loc_ini(:,:) ) 154 154 END IF 155 z_ssh_hc = glob_sum_full( 'diahsb', z2d0 ) 156 z_ssh_sc = glob_sum_full( 'diahsb', z2d1 ) 155 z_ssh_hc = glob_sum_full( 'diahsb', z2d0 ) 156 z_ssh_sc = glob_sum_full( 'diahsb', z2d1 ) 157 157 ENDIF 158 158 ! … … 181 181 zdiff_sc = zdiff_sc - frc_s 182 182 IF( ln_linssh ) THEN 183 zdiff_hc1 = zdiff_hc + z_ssh_hc 183 zdiff_hc1 = zdiff_hc + z_ssh_hc 184 184 zdiff_sc1 = zdiff_sc + z_ssh_sc 185 185 zerr_hc1 = z_ssh_hc - frc_wn_t … … 201 201 !!gm end 202 202 203 CALL iom_put( 'bgfrcvol' , frc_v * 1.e-9 ) ! vol - surface forcing (km3) 204 CALL iom_put( 'bgfrctem' , frc_t * rho0 * rcp * 1.e-20 ) ! hc - surface forcing (1.e20 J) 205 CALL iom_put( 'bgfrchfx' , frc_t * rho0 * rcp / & ! hc - surface forcing (W/m2) 203 CALL iom_put( 'bgfrcvol' , frc_v * 1.e-9 ) ! vol - surface forcing (km3) 204 CALL iom_put( 'bgfrctem' , frc_t * rho0 * rcp * 1.e-20 ) ! hc - surface forcing (1.e20 J) 205 CALL iom_put( 'bgfrchfx' , frc_t * rho0 * rcp / & ! hc - surface forcing (W/m2) 206 206 & ( surf_tot * kt * rn_Dt ) ) 207 CALL iom_put( 'bgfrcsal' , frc_s * 1.e-9 ) ! sc - surface forcing (psu*km3) 207 CALL iom_put( 'bgfrcsal' , frc_s * 1.e-9 ) ! sc - surface forcing (psu*km3) 208 208 209 209 IF( .NOT. ln_linssh ) THEN 210 CALL iom_put( 'bgtemper' , zdiff_hc / zvol_tot ) ! Temperature drift (C) 210 CALL iom_put( 'bgtemper' , zdiff_hc / zvol_tot ) ! Temperature drift (C) 211 211 CALL iom_put( 'bgsaline' , zdiff_sc / zvol_tot ) ! Salinity drift (PSU) 212 CALL iom_put( 'bgheatco' , zdiff_hc * 1.e-20 * rho0 * rcp ) ! Heat content drift (1.e20 J) 213 CALL iom_put( 'bgheatfx' , zdiff_hc * rho0 * rcp / & ! Heat flux drift (W/m2) 212 CALL iom_put( 'bgheatco' , zdiff_hc * 1.e-20 * rho0 * rcp ) ! Heat content drift (1.e20 J) 213 CALL iom_put( 'bgheatfx' , zdiff_hc * rho0 * rcp / & ! Heat flux drift (W/m2) 214 214 & ( surf_tot * kt * rn_Dt ) ) 215 215 CALL iom_put( 'bgsaltco' , zdiff_sc * 1.e-9 ) ! Salt content drift (psu*km3) 216 CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9 ) ! volume ssh drift (km3) 217 CALL iom_put( 'bgvole3t' , zdiff_v2 * 1.e-9 ) ! volume e3t drift (km3) 216 CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9 ) ! volume ssh drift (km3) 217 CALL iom_put( 'bgvole3t' , zdiff_v2 * 1.e-9 ) ! volume e3t drift (km3) 218 218 ! 219 219 IF( kt == nitend .AND. lwp ) THEN … … 228 228 ! 229 229 ELSE 230 CALL iom_put( 'bgtemper' , zdiff_hc1 / zvol_tot) ! Heat content drift (C) 230 CALL iom_put( 'bgtemper' , zdiff_hc1 / zvol_tot) ! Heat content drift (C) 231 231 CALL iom_put( 'bgsaline' , zdiff_sc1 / zvol_tot) ! Salt content drift (PSU) 232 CALL iom_put( 'bgheatco' , zdiff_hc1 * 1.e-20 * rho0 * rcp ) ! Heat content drift (1.e20 J) 233 CALL iom_put( 'bgheatfx' , zdiff_hc1 * rho0 * rcp / & ! Heat flux drift (W/m2) 232 CALL iom_put( 'bgheatco' , zdiff_hc1 * 1.e-20 * rho0 * rcp ) ! Heat content drift (1.e20 J) 233 CALL iom_put( 'bgheatfx' , zdiff_hc1 * rho0 * rcp / & ! Heat flux drift (W/m2) 234 234 & ( surf_tot * kt * rn_Dt ) ) 235 235 CALL iom_put( 'bgsaltco' , zdiff_sc1 * 1.e-9 ) ! Salt content drift (psu*km3) 236 CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9 ) ! volume ssh drift (km3) 236 CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9 ) ! volume ssh drift (km3) 237 237 CALL iom_put( 'bgmistem' , zerr_hc1 / zvol_tot ) ! hc - error due to free surface (C) 238 238 CALL iom_put( 'bgmissal' , zerr_sc1 / zvol_tot ) ! sc - error due to free surface (psu) … … 249 249 !!--------------------------------------------------------------------- 250 250 !! *** ROUTINE dia_hsb_rst *** 251 !! 251 !! 252 252 !! ** Purpose : Read or write DIA file in restart file 253 253 !! … … 261 261 !!---------------------------------------------------------------------- 262 262 ! 263 IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise 263 IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise 264 264 IF( ln_rstart ) THEN !* Read the restart file 265 265 ! … … 267 267 IF(lwp) WRITE(numout,*) ' dia_hsb_rst : read hsb restart at it= ', kt,' date= ', ndastp 268 268 IF(lwp) WRITE(numout,*) 269 CALL iom_get( numror, 'frc_v', frc_v , ldxios = lrxios)270 CALL iom_get( numror, 'frc_t', frc_t , ldxios = lrxios)271 CALL iom_get( numror, 'frc_s', frc_s , ldxios = lrxios)269 CALL iom_get( numror, 'frc_v', frc_v ) 270 CALL iom_get( numror, 'frc_t', frc_t ) 271 CALL iom_get( numror, 'frc_s', frc_s ) 272 272 IF( ln_linssh ) THEN 273 CALL iom_get( numror, 'frc_wn_t', frc_wn_t , ldxios = lrxios)274 CALL iom_get( numror, 'frc_wn_s', frc_wn_s , ldxios = lrxios)273 CALL iom_get( numror, 'frc_wn_t', frc_wn_t ) 274 CALL iom_get( numror, 'frc_wn_s', frc_wn_s ) 275 275 ENDIF 276 CALL iom_get( numror, jpdom_auto, 'surf_ini' , surf_ini , ldxios = lrxios) ! ice sheet coupling277 CALL iom_get( numror, jpdom_auto, 'ssh_ini' , ssh_ini , ldxios = lrxios)278 CALL iom_get( numror, jpdom_auto, 'e3t_ini' , e3t_ini , ldxios = lrxios)279 CALL iom_get( numror, jpdom_auto, 'tmask_ini' , tmask_ini , ldxios = lrxios)280 CALL iom_get( numror, jpdom_auto, 'hc_loc_ini', hc_loc_ini , ldxios = lrxios)281 CALL iom_get( numror, jpdom_auto, 'sc_loc_ini', sc_loc_ini , ldxios = lrxios)276 CALL iom_get( numror, jpdom_auto, 'surf_ini' , surf_ini ) ! ice sheet coupling 277 CALL iom_get( numror, jpdom_auto, 'ssh_ini' , ssh_ini ) 278 CALL iom_get( numror, jpdom_auto, 'e3t_ini' , e3t_ini ) 279 CALL iom_get( numror, jpdom_auto, 'tmask_ini' , tmask_ini ) 280 CALL iom_get( numror, jpdom_auto, 'hc_loc_ini', hc_loc_ini ) 281 CALL iom_get( numror, jpdom_auto, 'sc_loc_ini', sc_loc_ini ) 282 282 IF( ln_linssh ) THEN 283 CALL iom_get( numror, jpdom_auto, 'ssh_hc_loc_ini', ssh_hc_loc_ini , ldxios = lrxios)284 CALL iom_get( numror, jpdom_auto, 'ssh_sc_loc_ini', ssh_sc_loc_ini , ldxios = lrxios)283 CALL iom_get( numror, jpdom_auto, 'ssh_hc_loc_ini', ssh_hc_loc_ini ) 284 CALL iom_get( numror, jpdom_auto, 'ssh_sc_loc_ini', ssh_sc_loc_ini ) 285 285 ENDIF 286 286 ELSE … … 298 298 END DO 299 299 frc_v = 0._wp ! volume trend due to forcing 300 frc_t = 0._wp ! heat content - - - - 301 frc_s = 0._wp ! salt content - - - - 300 frc_t = 0._wp ! heat content - - - - 301 frc_s = 0._wp ! salt content - - - - 302 302 IF( ln_linssh ) THEN 303 303 IF( ln_isfcav ) THEN … … 323 323 IF(lwp) WRITE(numout,*) 324 324 ! 325 IF( lwxios ) CALL iom_swap( cwxios_context ) 326 CALL iom_rstput( kt, nitrst, numrow, 'frc_v', frc_v, ldxios = lwxios ) 327 CALL iom_rstput( kt, nitrst, numrow, 'frc_t', frc_t, ldxios = lwxios ) 328 CALL iom_rstput( kt, nitrst, numrow, 'frc_s', frc_s, ldxios = lwxios ) 325 CALL iom_rstput( kt, nitrst, numrow, 'frc_v', frc_v ) 326 CALL iom_rstput( kt, nitrst, numrow, 'frc_t', frc_t ) 327 CALL iom_rstput( kt, nitrst, numrow, 'frc_s', frc_s ) 329 328 IF( ln_linssh ) THEN 330 CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_t', frc_wn_t , ldxios = lwxios)331 CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_s', frc_wn_s , ldxios = lwxios)329 CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_t', frc_wn_t ) 330 CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_s', frc_wn_s ) 332 331 ENDIF 333 CALL iom_rstput( kt, nitrst, numrow, 'surf_ini' , surf_ini , ldxios = lwxios) ! ice sheet coupling334 CALL iom_rstput( kt, nitrst, numrow, 'ssh_ini' , ssh_ini , ldxios = lwxios)335 CALL iom_rstput( kt, nitrst, numrow, 'e3t_ini' , e3t_ini , ldxios = lwxios)336 CALL iom_rstput( kt, nitrst, numrow, 'tmask_ini' , tmask_ini , ldxios = lwxios)337 CALL iom_rstput( kt, nitrst, numrow, 'hc_loc_ini', hc_loc_ini , ldxios = lwxios)338 CALL iom_rstput( kt, nitrst, numrow, 'sc_loc_ini', sc_loc_ini , ldxios = lwxios)332 CALL iom_rstput( kt, nitrst, numrow, 'surf_ini' , surf_ini ) ! ice sheet coupling 333 CALL iom_rstput( kt, nitrst, numrow, 'ssh_ini' , ssh_ini ) 334 CALL iom_rstput( kt, nitrst, numrow, 'e3t_ini' , e3t_ini ) 335 CALL iom_rstput( kt, nitrst, numrow, 'tmask_ini' , tmask_ini ) 336 CALL iom_rstput( kt, nitrst, numrow, 'hc_loc_ini', hc_loc_ini ) 337 CALL iom_rstput( kt, nitrst, numrow, 'sc_loc_ini', sc_loc_ini ) 339 338 IF( ln_linssh ) THEN 340 CALL iom_rstput( kt, nitrst, numrow, 'ssh_hc_loc_ini', ssh_hc_loc_ini , ldxios = lwxios)341 CALL iom_rstput( kt, nitrst, numrow, 'ssh_sc_loc_ini', ssh_sc_loc_ini , ldxios = lwxios)339 CALL iom_rstput( kt, nitrst, numrow, 'ssh_hc_loc_ini', ssh_hc_loc_ini ) 340 CALL iom_rstput( kt, nitrst, numrow, 'ssh_sc_loc_ini', ssh_sc_loc_ini ) 342 341 ENDIF 343 IF( lwxios ) CALL iom_swap( cxios_context )344 342 ! 345 343 ENDIF … … 351 349 !!--------------------------------------------------------------------------- 352 350 !! *** ROUTINE dia_hsb *** 353 !! 351 !! 354 352 !! ** Purpose: Initialization for the heat salt volume budgets 355 !! 353 !! 356 354 !! ** Method : Compute initial heat content, salt content and volume 357 355 !! … … 385 383 IF( .NOT. ln_diahsb ) RETURN 386 384 387 IF(lwxios) THEN388 ! define variables in restart file when writing with XIOS389 CALL iom_set_rstw_var_active('frc_v')390 CALL iom_set_rstw_var_active('frc_t')391 CALL iom_set_rstw_var_active('frc_s')392 CALL iom_set_rstw_var_active('surf_ini')393 CALL iom_set_rstw_var_active('ssh_ini')394 CALL iom_set_rstw_var_active('e3t_ini')395 CALL iom_set_rstw_var_active('hc_loc_ini')396 CALL iom_set_rstw_var_active('sc_loc_ini')397 IF( ln_linssh ) THEN398 CALL iom_set_rstw_var_active('ssh_hc_loc_ini')399 CALL iom_set_rstw_var_active('ssh_sc_loc_ini')400 CALL iom_set_rstw_var_active('frc_wn_t')401 CALL iom_set_rstw_var_active('frc_wn_s')402 ENDIF403 ENDIF404 385 ! ------------------- ! 405 386 ! 1 - Allocate memory ! … … 422 403 surf_tot = glob_sum( 'diahsb', surf(:,:) ) ! total ocean surface area 423 404 424 IF( ln_bdy ) CALL ctl_warn( 'dia_hsb_init: heat/salt budget does not consider open boundary fluxes' ) 405 IF( ln_bdy ) CALL ctl_warn( 'dia_hsb_init: heat/salt budget does not consider open boundary fluxes' ) 425 406 ! 426 407 ! ---------------------------------- ! -
NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/src/OCE/DIA/diaptr.F90
r13557 r14017 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" … … 61 66 !!---------------------------------------------------------------------- 62 67 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 63 !! $Id$ 68 !! $Id$ 64 69 !! Software governed by the CeCILL license (see ./LICENSE) 65 70 !!---------------------------------------------------------------------- … … 70 75 !! *** ROUTINE dia_ptr *** 71 76 !!---------------------------------------------------------------------- 72 INTEGER , INTENT(in) :: kt ! ocean time-step index 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 ! 323 ENDIF 324 ! 325 DEALLOCATE( z3dtr ) 326 ! 327 IF( ln_timing ) CALL timing_stop('dia_ptr') 328 ! 329 END SUBROUTINE dia_ptr 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 450 ENDIF 451 END SUBROUTINE dia_ptr_zint 330 452 331 453 … … 333 455 !!---------------------------------------------------------------------- 334 456 !! *** ROUTINE dia_ptr_init *** 335 !! 457 !! 336 458 !! ** Purpose : Initialization 337 459 !!---------------------------------------------------------------------- … … 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,*) … … 358 480 ENDIF 359 481 360 IF( l_diaptr ) THEN 482 IF( l_diaptr ) THEN 361 483 ! 362 484 IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' ) … … 367 489 IF( lk_mpp ) CALL mpp_ini_znl( numout ) ! Define MPI communicator for zonal sum 368 490 369 btmsk(:,:,1) = tmask_i(:,:) 491 btmsk(:,:,1) = tmask_i(:,:) 370 492 IF( nbasin == 5 ) THEN ! nbasin has been initialized in iom_init to define the axis "basin" 371 493 CALL iom_open( 'subbasins', inum ) … … 382 504 WHERE( gphit(:,:)*tmask_i(:,:) < -34._wp) 383 505 zmsk(:,:) = 0._wp ! mask out Southern Ocean 384 ELSE WHERE 506 ELSE WHERE 385 507 zmsk(:,:) = ssmask(:,:) 386 508 END WHERE 387 btmsk34(:,:,1) = btmsk(:,:,1) 509 btmsk34(:,:,1) = btmsk(:,:,1) 388 510 DO jn = 2, nbasin 389 511 btmsk34(:,:,jn) = btmsk(:,:,jn) * zmsk(:,:) ! interior domain only … … 392 514 ! Initialise arrays to zero because diatpr is called before they are first calculated 393 515 ! Note that this means diagnostics will not be exactly correct when model run is restarted. 394 hstr_adv(:,:,:) = 0._wp 395 hstr_ldf(:,:,:) = 0._wp 396 hstr_eiv(:,:,:) = 0._wp 397 hstr_ove(:,:,:) = 0._wp 516 hstr_adv(:,:,:) = 0._wp 517 hstr_ldf(:,:,:) = 0._wp 518 hstr_eiv(:,:,:) = 0._wp 519 hstr_ove(:,:,:) = 0._wp 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. 402 526 ! 403 ENDIF 404 ! 527 ENDIF 528 ! 405 529 END SUBROUTINE dia_ptr_init 406 530 407 531 408 SUBROUTINE dia_ptr_hst( ktra, cptr, pvflx ) 532 SUBROUTINE dia_ptr_hst( ktra, cptr, pvflx ) 409 533 !!---------------------------------------------------------------------- 410 534 !! *** ROUTINE dia_ptr_hst *** … … 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 432 ENDIF 433 ! 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 445 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 458 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 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(:,:) ) 471 561 ENDIF 472 562 ! … … 474 564 475 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 ) 597 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 ) 635 ENDIF 636 #endif 637 END SUBROUTINE ptr_sum_3d 638 639 476 640 FUNCTION dia_ptr_alloc() 477 641 !!---------------------------------------------------------------------- … … 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 … … 578 727 ! 579 728 INTEGER :: ji,jj,jc ! dummy loop arguments 580 INTEGER :: ijpj ! ??? 729 INTEGER :: ijpj ! ??? 581 730 REAL(wp), DIMENSION(jpi,jpj) :: p_fval ! function value 582 731 !!-------------------------------------------------------------------- 583 ! 732 ! 584 733 ijpj = jpj ! ??? 585 734 p_fval(:,:) = 0._wp … … 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 ! 593 741 END FUNCTION ptr_ci_2d 594 742 … … 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.
