- Timestamp:
- 2010-11-17T10:09:35+01:00 (13 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/nemo_v3_3_beta/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90
r2364 r2399 6 6 !! History : 1.0 ! 2003-09 (C. Talandier, G. Madec) Original code 7 7 !! 2.0 ! 2006-01 (A. Biastoch) Allow sub-basins computation 8 !! 3.2 ! 2003-03 (O. Marti, S. Flavoni) Add fields 8 !! 3.2 ! 2010-03 (O. Marti, S. Flavoni) Add fields 9 !! 3.3 ! 2010-10 (G. Madec) dynamical allocation 9 10 !!---------------------------------------------------------------------- 10 11 … … 15 16 !! ptr_vjk : "zonal" sum computation of a "meridional" flux array 16 17 !! ptr_tjk : "zonal" mean computation of a tracer field 17 !! ptr_vj : "zonal" and vertical sum computation of a "meridional" 18 !! : flux array; Generic interface: ptr_vj_3d, ptr_vj_2d18 !! ptr_vj : "zonal" and vertical sum computation of a "meridional" flux array 19 !! (Generic interface to ptr_vj_3d, ptr_vj_2d) 19 20 !!---------------------------------------------------------------------- 20 USE oce ! ocean dynamics and active tracers21 USE dom_oce ! ocean space and time domain22 USE phycst ! physical constants23 USE ldftra_oce ! ocean active tracers: lateral physics24 USE dianam 25 USE iom 26 USE ioipsl 27 USE in_out_manager 28 USE lib_mpp 29 USE lbclnk 21 USE oce ! ocean dynamics and active tracers 22 USE dom_oce ! ocean space and time domain 23 USE phycst ! physical constants 24 USE ldftra_oce ! ocean active tracers: lateral physics 25 USE dianam ! 26 USE iom ! IOM library 27 USE ioipsl ! IO-IPSL library 28 USE in_out_manager ! I/O manager 29 USE lib_mpp ! MPP library 30 USE lbclnk ! lateral boundary condition - processor exchanges 30 31 31 32 IMPLICIT NONE … … 46 47 LOGICAL , PUBLIC :: ln_diaznl = .FALSE. !: Add zonal means and meridional stream functions 47 48 LOGICAL , PUBLIC :: ln_ptrcomp = .FALSE. !: Add decomposition : overturning (and gyre, soon ...) 48 INTEGER , PUBLIC :: nf_ptr = 15 !: frequency of ptr computation 49 INTEGER , PUBLIC :: nf_ptr_wri = 15 !: frequency of ptr outputs 50 51 REAL(wp), PUBLIC, DIMENSION(jpi,jpj) :: abasin, pbasin, ibasin, dbasin, sbasin !: Sub basin masks 52 53 ! !!! poleward heat and salt transport 54 REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_adv , pst_adv !: advection 55 REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_ldf , pst_ldf !: lateral diffusion 56 REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_ove_glo, pst_ove_glo !: global overturning 57 REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_ove_atl, pst_ove_atl !: Atlantic overturning 58 REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_ove_pac, pst_ove_pac !: Pacific overturning 59 REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_ove_ind, pst_ove_ind !: Indian overturning 60 REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_ove_ipc, pst_ove_ipc !: Indo-Pacific overturning 61 REAL(wp), PUBLIC, DIMENSION(jpj) :: ht_glo, ht_atl, ht_ind, ht_pac, ht_ipc !: heat 62 REAL(wp), PUBLIC, DIMENSION(jpj) :: st_glo, st_atl, st_ind, st_pac, st_ipc !: salt 63 64 INTEGER :: niter 65 INTEGER :: nidom_ptr 66 INTEGER :: numptr !: logical unit for Poleward TRansports 67 68 REAL(wp), DIMENSION(jpj,jpk) :: tn_jk_glo , sn_jk_glo ! global i-mean temperature and salinity 69 REAL(wp), DIMENSION(jpj,jpk) :: tn_jk_atl , sn_jk_atl ! Atlantic - - 70 REAL(wp), DIMENSION(jpj,jpk) :: tn_jk_pac , sn_jk_pac ! Pacific - - 71 REAL(wp), DIMENSION(jpj,jpk) :: tn_jk_ind , sn_jk_ind ! Indian - - 72 REAL(wp), DIMENSION(jpj,jpk) :: tn_jk_ipc , sn_jk_ipc ! Indo-Pacific - - 73 REAL(wp), DIMENSION(jpj,jpk) :: v_msf_glo ! global "meridional" Stream-Function 74 REAL(wp), DIMENSION(jpj,jpk) :: v_msf_atl ! Atlantic - - 75 REAL(wp), DIMENSION(jpj,jpk) :: v_msf_pac ! Pacific - - 76 REAL(wp), DIMENSION(jpj,jpk) :: v_msf_ind ! Indian - - 77 REAL(wp), DIMENSION(jpj,jpk) :: v_msf_ipc ! Indo-Pacific - - 78 REAL(wp), DIMENSION(jpj,jpk) :: surf_jk_glo, surf_jk_r_glo ! surface of global i-section and its inverse 79 REAL(wp), DIMENSION(jpj,jpk) :: surf_jk_atl, surf_jk_r_atl ! surface of Atlantic - - 80 REAL(wp), DIMENSION(jpj,jpk) :: surf_jk_pac, surf_jk_r_pac ! surface of Pacific - - 81 REAL(wp), DIMENSION(jpj,jpk) :: surf_jk_ind, surf_jk_r_ind ! surface of Indian - - 82 REAL(wp), DIMENSION(jpj,jpk) :: surf_jk_ipc, surf_jk_r_ipc ! surface of Indo-Pacific - - 83 #if defined key_diaeiv 84 ! !!! eddy induced velocity (bolus) 85 REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_eiv_glo, pst_eiv_glo !: global poleward heat and salt bolus advection 86 REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_eiv_atl, pst_eiv_atl !: Atlantic - - 87 REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_eiv_pac, pst_eiv_pac !: Pacific - - 88 REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_eiv_ind, pst_eiv_ind !: Indian - - 89 REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_eiv_ipc, pst_eiv_ipc !: Indo-Pacific - - 90 91 REAL(wp), DIMENSION(jpj,jpk) :: v_msf_eiv_glo ! global "meridional" bolus Stream-Function 92 REAL(wp), DIMENSION(jpj,jpk) :: v_msf_eiv_atl ! Atlantic - - 93 REAL(wp), DIMENSION(jpj,jpk) :: v_msf_eiv_pac ! Pacific - - 94 REAL(wp), DIMENSION(jpj,jpk) :: v_msf_eiv_ind ! Indian - - 95 REAL(wp), DIMENSION(jpj,jpk) :: v_msf_eiv_ipc ! Indo-Pacific - - 96 #endif 97 49 INTEGER , PUBLIC :: nn_fptr = 15 !: frequency of ptr computation [time step] 50 INTEGER , PUBLIC :: nn_fwri = 15 !: frequency of ptr outputs [time step] 51 52 REAL(wp), PUBLIC, DIMENSION(:), ALLOCATABLE :: htr_adv, htr_ldf, htr_ove !: Heat TRansports (adv, diff, overturn.) 53 REAL(wp), PUBLIC, DIMENSION(:), ALLOCATABLE :: str_adv, str_ldf, str_ove !: Salt TRansports (adv, diff, overturn.) 54 55 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: btmsk ! T-point basin interior masks 56 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: btm30 ! mask out Southern Ocean (=0 south of 30°S) 57 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: htr , str ! adv heat and salt transports (approx) 58 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: tn_jk, sn_jk , v_msf ! i-mean T and S, j-Stream-Function 59 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: sjk , r1_sjk ! i-mean i-k-surface and its inverse 60 #if defined key_diaeiv 61 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: htr_eiv, str_eiv ! bolus adv heat ans salt transports ('key_diaeiv') 62 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: v_msf_eiv ! bolus j-streamfuction ('key_diaeiv') 63 #endif 64 65 INTEGER :: niter ! 66 INTEGER :: nidom_ptr ! 67 INTEGER :: numptr ! logical unit for Poleward TRansports 68 INTEGER :: nptr ! = 1 (ln_subbas=F) or = 5 (glo, atl, pac, ind, ipc) (ln_subbas=T) 69 70 REAL(wp) :: rc_sv = 1.e-6_wp ! conversion from m3/s to Sverdrup 71 REAL(wp) :: rc_pwatt = 1.e-15_wp ! conversion from W to PW (further x rau0 x Cp) 72 REAL(wp) :: rc_ggram = 1.e-6_wp ! conversion from g to Pg 73 98 74 !! * Substitutions 99 75 # include "domzgr_substitute.h90" … … 102 78 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 103 79 !! $Id$ 104 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)80 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 105 81 !!---------------------------------------------------------------------- 106 107 82 CONTAINS 108 83 … … 111 86 !! *** ROUTINE ptr_vj_3d *** 112 87 !! 113 !! ** Purpose : "zonal" and vertical sum computation of a "meridional" 114 !! flux array 88 !! ** Purpose : i-k sum computation of a j-flux array 115 89 !! 116 90 !! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i). … … 127 101 ! 128 102 ijpj = jpj 129 p_fval(:) = 0. e0103 p_fval(:) = 0._wp 130 104 DO jk = 1, jpkm1 131 105 DO jj = 2, jpjm1 … … 137 111 ! 138 112 #if defined key_mpp_mpi 139 CALL mpp_sum( p_fval, ijpj, ncomm_znl) !!bug I presume113 CALL mpp_sum( p_fval, ijpj, ncomm_znl) 140 114 #endif 141 115 ! … … 147 121 !! *** ROUTINE ptr_vj_2d *** 148 122 !! 149 !! ** Purpose : "zonal" and vertical sum computation of a "meridional" 150 !! flux array 123 !! ** Purpose : "zonal" and vertical sum computation of a i-flux array 151 124 !! 152 125 !! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i). … … 163 136 ! 164 137 ijpj = jpj 165 p_fval(:) = 0. e0138 p_fval(:) = 0._wp 166 139 DO jj = 2, jpjm1 167 140 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? … … 171 144 ! 172 145 #if defined key_mpp_mpi 173 CALL mpp_sum( p_fval, ijpj, ncomm_znl ) !!bug I presume146 CALL mpp_sum( p_fval, ijpj, ncomm_znl ) 174 147 #endif 175 148 ! … … 177 150 178 151 179 FUNCTION ptr_vjk( pva, bmask ) RESULT ( p_fval )152 FUNCTION ptr_vjk( pva, pmsk ) RESULT ( p_fval ) 180 153 !!---------------------------------------------------------------------- 181 154 !! *** ROUTINE ptr_vjk *** 182 155 !! 183 !! ** Purpose : "zonal" sum computation of a "meridional" fluxarray156 !! ** Purpose : i-sum computation of a j-velocity array 184 157 !! 185 158 !! ** Method : - i-sum of pva using the interior 2D vmask (vmask_i). 186 !! pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v)187 !! 188 !! ** Action : - p_fval: i- k-mean poleward flux of pva189 !!---------------------------------------------------------------------- 190 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva 191 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) , OPTIONAL :: bmask ! Optional 2D basin mask159 !! pva is supposed to be a masked flux (i.e. * vmask) 160 !! 161 !! ** Action : - p_fval: i-mean poleward flux of pva 162 !!---------------------------------------------------------------------- 163 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! mask flux array at V-point 164 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) , OPTIONAL :: pmsk ! Optional 2D basin mask 192 165 !! 193 166 INTEGER :: ji, jj, jk ! dummy loop arguments … … 200 173 !!-------------------------------------------------------------------- 201 174 ! 202 p_fval(:,:) = 0. e0203 ! 204 IF( PRESENT( bmask ) ) THEN175 p_fval(:,:) = 0._wp 176 ! 177 IF( PRESENT( pmsk ) ) THEN 205 178 DO jk = 1, jpkm1 206 179 DO jj = 2, jpjm1 207 180 !!gm here, use of tmask_i ==> no need of loop over nldi, nlei.... 208 181 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 209 p_fval(jj,jk) = p_fval(jj,jk) + pva(ji,jj,jk) * e1v(ji,jj) * fse3v(ji,jj,jk) & 210 & * tmask_i(ji,jj) * bmask(ji,jj) 182 p_fval(jj,jk) = p_fval(jj,jk) + pva(ji,jj,jk) * e1v(ji,jj) * fse3v(ji,jj,jk) * pmsk(ji,jj) 211 183 END DO 212 184 END DO … … 216 188 DO jj = 2, jpjm1 217 189 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 218 p_fval(jj,jk) = p_fval(jj,jk) + pva(ji,jj,jk) * e1v(ji,jj) * fse3v(ji,jj,jk) & 219 & * tmask_i(ji,jj) 190 p_fval(jj,jk) = p_fval(jj,jk) + pva(ji,jj,jk) * e1v(ji,jj) * fse3v(ji,jj,jk) * tmask_i(ji,jj) 220 191 END DO 221 192 END DO … … 233 204 234 205 235 FUNCTION ptr_tjk( pta, bmask ) RESULT ( p_fval )206 FUNCTION ptr_tjk( pta, pmsk ) RESULT ( p_fval ) 236 207 !!---------------------------------------------------------------------- 237 208 !! *** ROUTINE ptr_tjk *** 238 209 !! 239 !! ** Purpose : "zonal" mean computation ofa tracer field210 !! ** Purpose : i-sum computation of e1t*e3t * a tracer field 240 211 !! 241 212 !! ** Method : - i-sum of mj(pta) using tmask 242 !! multiplied by the inverse of the surface of the "zonal" ocean 243 !! section 244 !! 245 !! ** Action : - p_fval: i-k-mean poleward flux of pta 213 !! 214 !! ** Action : - p_fval: i-sum of e1t*e3t*pta 246 215 !!---------------------------------------------------------------------- 247 216 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pta ! tracer flux array at T-point 248 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) , OPTIONAL :: bmask! Optional 2D basin mask217 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 249 218 !! 250 219 INTEGER :: ji, jj, jk ! dummy loop arguments … … 257 226 !!-------------------------------------------------------------------- 258 227 ! 259 p_fval(:,:) = 0.e0 260 IF (PRESENT (bmask)) THEN 261 DO jk = 1, jpkm1 262 DO jj = 2, jpjm1 263 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 264 p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) & 265 & * e1t(ji,jj) * fse3t(ji,jj,jk) & 266 & * tmask_i(ji,jj) & 267 & * bmask(ji,jj) 268 END DO 228 p_fval(:,:) = 0._wp 229 DO jk = 1, jpkm1 230 DO jj = 2, jpjm1 231 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 232 p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * e1t(ji,jj) * fse3t(ji,jj,jk) * pmsk(ji,jj) 269 233 END DO 270 234 END DO 271 ELSE 272 DO jk = 1, jpkm1 273 DO jj = 2, jpjm1 274 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 275 p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) & 276 & * e1t(ji,jj) * fse3t(ji,jj,jk) & 277 & * tmask_i(ji,jj) 278 END DO 279 END DO 280 END DO 281 END IF 282 p_fval(:,:) = p_fval(:,:) * 0.5 235 END DO 283 236 #if defined key_mpp_mpi 284 237 ish(1) = jpj*jpk ; ish2(1) = jpj ; ish2(2) = jpk 285 238 zwork(:)= RESHAPE( p_fval, ish ) 286 239 CALL mpp_sum( zwork, jpj*jpk, ncomm_znl ) 287 p_fval(:,:)= RESHAPE( zwork,ish2)240 p_fval(:,:)= RESHAPE( zwork, ish2 ) 288 241 #endif 289 242 ! … … 295 248 !! *** ROUTINE dia_ptr *** 296 249 !!---------------------------------------------------------------------- 250 USE oce, vt => ua ! use ua as workspace 251 USE oce, vs => ua ! use ua as workspace 252 !! 297 253 INTEGER, INTENT(in) :: kt ! ocean time step index 298 !! 299 INTEGER :: jk, jj, ji ! dummy loop 300 REAL(wp) :: zsverdrup ! conversion from m3/s to Sverdrup 301 REAL(wp) :: zpwatt ! conversion from W to PW 302 REAL(wp) :: zggram ! conversion from g to Pg 303 REAL(wp), DIMENSION(jpi,jpj,jpk) :: vt, vs ! 3D workspace 304 !!---------------------------------------------------------------------- 305 306 IF( kt == nit000 .OR. MOD( kt, nf_ptr ) == 0 ) THEN 307 308 IF ( MOD( kt, nf_ptr ) == 0 ) THEN 309 310 zsverdrup = 1.e-6 311 zpwatt = 1.e-15 312 zggram = 1.e-6 313 314 IF ( ln_diaznl ) THEN 315 ! "zonal" mean temperature and salinity at V-points 316 tn_jk_glo(:,:) = ptr_tjk( tn(:,:,:) ) * surf_jk_r_glo(:,:) 317 sn_jk_glo(:,:) = ptr_tjk( sn(:,:,:) ) * surf_jk_r_glo(:,:) 318 319 IF (ln_subbas) THEN 320 tn_jk_atl(:,:) = ptr_tjk( tn(:,:,:), abasin(:,:) ) * surf_jk_r_atl(:,:) 321 sn_jk_atl(:,:) = ptr_tjk( sn(:,:,:), abasin(:,:) ) * surf_jk_r_atl(:,:) 322 tn_jk_pac(:,:) = ptr_tjk( tn(:,:,:), pbasin(:,:) ) * surf_jk_r_pac(:,:) 323 sn_jk_pac(:,:) = ptr_tjk( sn(:,:,:), pbasin(:,:) ) * surf_jk_r_pac(:,:) 324 tn_jk_ind(:,:) = ptr_tjk( tn(:,:,:), ibasin(:,:) ) * surf_jk_r_ind(:,:) 325 sn_jk_ind(:,:) = ptr_tjk( sn(:,:,:), ibasin(:,:) ) * surf_jk_r_ind(:,:) 326 tn_jk_ipc(:,:) = ptr_tjk( tn(:,:,:), dbasin(:,:) ) * surf_jk_r_ipc(:,:) 327 sn_jk_ipc(:,:) = ptr_tjk( sn(:,:,:), dbasin(:,:) ) * surf_jk_r_ipc(:,:) 328 ENDIF 329 ENDIF 330 331 !-------------------------------------------------------- 332 ! overturning calculation: 333 334 ! horizontal integral and vertical dz 335 336 #if defined key_diaeiv 337 v_msf_glo(:,:) = ptr_vjk( vn(:,:,:)+v_eiv(:,:,:) ) 338 IF( ln_subbas .AND. ln_diaznl ) THEN 339 v_msf_atl(:,:) = ptr_vjk( vn(:,:,:)+v_eiv(:,:,:), abasin(:,:)*sbasin(:,:) ) 340 v_msf_pac(:,:) = ptr_vjk( vn(:,:,:)+v_eiv(:,:,:), pbasin(:,:)*sbasin(:,:) ) 341 v_msf_ind(:,:) = ptr_vjk( vn(:,:,:)+v_eiv(:,:,:), ibasin(:,:)*sbasin(:,:) ) 342 v_msf_ipc(:,:) = ptr_vjk( vn(:,:,:)+v_eiv(:,:,:), dbasin(:,:)*sbasin(:,:) ) 343 ENDIF 344 #else 345 v_msf_glo(:,:) = ptr_vjk( vn(:,:,:) ) 346 IF( ln_subbas .AND. ln_diaznl ) THEN 347 v_msf_atl(:,:) = ptr_vjk( vn(:,:,:), abasin(:,:)*sbasin(:,:) ) 348 v_msf_pac(:,:) = ptr_vjk( vn(:,:,:), pbasin(:,:)*sbasin(:,:) ) 349 v_msf_ind(:,:) = ptr_vjk( vn(:,:,:), ibasin(:,:)*sbasin(:,:) ) 350 v_msf_ipc(:,:) = ptr_vjk( vn(:,:,:), dbasin(:,:)*sbasin(:,:) ) 351 ENDIF 352 #endif 353 354 #if defined key_diaeiv 355 v_msf_eiv_glo(:,:) = ptr_vjk( v_eiv(:,:,:) ) 356 IF (ln_subbas ) THEN 357 v_msf_eiv_atl(:,:) = ptr_vjk( v_eiv(:,:,:), abasin(:,:)*sbasin(:,:) ) 358 v_msf_eiv_pac(:,:) = ptr_vjk( v_eiv(:,:,:), pbasin(:,:)*sbasin(:,:) ) 359 v_msf_eiv_ind(:,:) = ptr_vjk( v_eiv(:,:,:), ibasin(:,:)*sbasin(:,:) ) 360 v_msf_eiv_ipc(:,:) = ptr_vjk( v_eiv(:,:,:), dbasin(:,:)*sbasin(:,:) ) 361 END IF 362 #endif 363 364 ! Transports 365 ! T times V on T points (include bolus velocities) 366 #if defined key_diaeiv 367 DO jj = 2, jpj 368 DO ji = 1, jpi 369 vt(ji,jj,:) = tn(ji,jj,:) * ( vn(ji,jj,:) + vn(ji,jj-1,:) + u_eiv(ji,jj,:) + u_eiv(ji,jj-1,:) )*0.5 370 vs(ji,jj,:) = sn(ji,jj,:) * ( vn(ji,jj,:) + vn(ji,jj-1,:) + v_eiv(ji,jj,:) + v_eiv(ji,jj-1,:) )*0.5 371 END DO 372 END DO 373 #else 374 DO jj = 2, jpj 375 DO ji = 1, jpi 376 vt(ji,jj,:) = tn(ji,jj,:) * ( vn(ji,jj,:) + vn(ji,jj-1,:) )*0.5 377 vs(ji,jj,:) = sn(ji,jj,:) * ( vn(ji,jj,:) + vn(ji,jj-1,:) )*0.5 378 END DO 379 END DO 380 #endif 381 CALL lbc_lnk( vs, 'V', -1. ) ; CALL lbc_lnk( vt, 'V', -1. ) 382 383 ht_glo(:) = SUM( ptr_vjk( vt(:,:,:)), 2 ) 384 st_glo(:) = SUM( ptr_vjk( vs(:,:,:)), 2 ) 385 386 IF ( ln_subbas ) THEN 387 ht_atl(:) = SUM( ptr_vjk( vt (:,:,:), abasin(:,:)*sbasin(:,:)), 2 ) 388 ht_pac(:) = SUM( ptr_vjk( vt (:,:,:), pbasin(:,:)*sbasin(:,:)), 2 ) 389 ht_ind(:) = SUM( ptr_vjk( vt (:,:,:), ibasin(:,:)*sbasin(:,:)), 2 ) 390 ht_ipc(:) = SUM( ptr_vjk( vt (:,:,:), dbasin(:,:)*sbasin(:,:)), 2 ) 391 st_atl(:) = SUM( ptr_vjk( vs (:,:,:), abasin(:,:)*sbasin(:,:)), 2 ) 392 st_pac(:) = SUM( ptr_vjk( vs (:,:,:), pbasin(:,:)*sbasin(:,:)), 2 ) 393 st_ind(:) = SUM( ptr_vjk( vs (:,:,:), ibasin(:,:)*sbasin(:,:)), 2 ) 394 st_ipc(:) = SUM( ptr_vjk( vs (:,:,:), dbasin(:,:)*sbasin(:,:)), 2 ) 395 ENDIF 396 397 ! poleward tracer transports: 398 ! overturning components: 399 IF ( ln_ptrcomp ) THEN 400 pht_ove_glo(:) = SUM( v_msf_glo(:,:) * tn_jk_glo(:,:), 2 ) ! SUM over jk 401 pst_ove_glo(:) = SUM( v_msf_glo(:,:) * sn_jk_glo(:,:), 2 ) 402 IF ( ln_subbas ) THEN 403 pht_ove_atl(:) = SUM( v_msf_atl(:,:) * tn_jk_atl(:,:), 2 ) ! SUM over jk 404 pst_ove_atl(:) = SUM( v_msf_atl(:,:) * sn_jk_atl(:,:), 2 ) 405 pht_ove_pac(:) = SUM( v_msf_pac(:,:) * tn_jk_pac(:,:), 2 ) ! SUM over jk 406 pst_ove_pac(:) = SUM( v_msf_pac(:,:) * sn_jk_pac(:,:), 2 ) 407 pht_ove_ind(:) = SUM( v_msf_ind(:,:) * tn_jk_ind(:,:), 2 ) ! SUM over jk 408 pst_ove_ind(:) = SUM( v_msf_ind(:,:) * sn_jk_ind(:,:), 2 ) 409 pht_ove_ipc(:) = SUM( v_msf_ipc(:,:) * tn_jk_ipc(:,:), 2 ) ! SUM over jk 410 pst_ove_ipc(:) = SUM( v_msf_ipc(:,:) * sn_jk_ipc(:,:), 2 ) 411 END IF 412 END IF 413 414 ! Bolus component 415 #if defined key_diaeiv 416 pht_eiv_glo(:) = SUM( v_msf_eiv_glo(:,:) * tn_jk_glo(:,:), 2 ) ! SUM over jk 417 pst_eiv_glo(:) = SUM( v_msf_eiv_glo(:,:) * sn_jk_glo(:,:), 2 ) ! SUM over jk 418 IF ( ln_subbas ) THEN 419 pht_eiv_atl(:) = SUM( v_msf_eiv_glo(:,:) * tn_jk_atl(:,:), 2 ) ! SUM over jk 420 pst_eiv_atl(:) = SUM( v_msf_eiv_glo(:,:) * sn_jk_atl(:,:), 2 ) ! SUM over jk 421 pht_eiv_pac(:) = SUM( v_msf_eiv_pac(:,:) * tn_jk_pac(:,:), 2 ) ! SUM over jk 422 pst_eiv_pac(:) = SUM( v_msf_eiv_pac(:,:) * sn_jk_pac(:,:), 2 ) ! SUM over jk 423 pht_eiv_ind(:) = SUM( v_msf_eiv_ind(:,:) * tn_jk_ind(:,:), 2 ) ! SUM over jk 424 pst_eiv_ind(:) = SUM( v_msf_eiv_ind(:,:) * sn_jk_ind(:,:), 2 ) ! SUM over jk 425 pht_eiv_ipc(:) = SUM( v_msf_eiv_ipc(:,:) * tn_jk_ipc(:,:), 2 ) ! SUM over jk 426 pst_eiv_ipc(:) = SUM( v_msf_eiv_ipc(:,:) * sn_jk_ipc(:,:), 2 ) ! SUM over jk 427 ENDIF 428 #endif 429 430 ! conversion in PW and G g 431 zpwatt = zpwatt * rau0 * rcp 432 pht_adv(:) = pht_adv(:) * zpwatt 433 pht_ldf(:) = pht_ldf(:) * zpwatt 434 pst_adv(:) = pst_adv(:) * zggram 435 pst_ldf(:) = pst_ldf(:) * zggram 436 IF ( ln_ptrcomp ) THEN 437 pht_ove_glo(:) = pht_ove_glo(:) * zpwatt 438 pst_ove_glo(:) = pst_ove_glo(:) * zggram 439 END IF 440 #if defined key_diaeiv 441 pht_eiv_glo(:) = pht_eiv_glo(:) * zpwatt 442 pst_eiv_glo(:) = pst_eiv_glo(:) * zggram 443 #endif 444 IF( ln_subbas ) THEN 445 ht_atl(:) = ht_atl(:) * zpwatt 446 ht_pac(:) = ht_pac(:) * zpwatt 447 ht_ind(:) = ht_ind(:) * zpwatt 448 ht_ipc(:) = ht_ipc(:) * zpwatt 449 st_atl(:) = st_atl(:) * zggram 450 st_pac(:) = st_pac(:) * zggram 451 st_ind(:) = st_ind(:) * zggram 452 st_ipc(:) = st_ipc(:) * zggram 453 ENDIF 454 455 ! "Meridional" Stream-Function 456 DO jk = 2,jpk 457 v_msf_glo(:,jk) = v_msf_glo(:,jk-1) + v_msf_glo(:,jk) 458 END DO 459 v_msf_glo(:,:) = v_msf_glo(:,:) * zsverdrup 460 #if defined key_diaeiv 461 ! Bolus "Meridional" Stream-Function 462 DO jk = 2,jpk 463 v_msf_eiv_glo(:,jk) = v_msf_eiv_glo(:,jk-1) + v_msf_eiv_glo(:,jk) 464 END DO 465 v_msf_eiv_glo(:,:) = v_msf_eiv_glo(:,:) * zsverdrup 466 IF ( ln_subbas ) THEN 467 DO jk = 2,jpk 468 v_msf_eiv_atl(:,jk) = v_msf_eiv_atl(:,jk-1) + v_msf_eiv_atl(:,jk) 469 v_msf_eiv_pac(:,jk) = v_msf_eiv_pac(:,jk-1) + v_msf_eiv_pac(:,jk) 470 v_msf_eiv_ind(:,jk) = v_msf_eiv_ind(:,jk-1) + v_msf_eiv_ind(:,jk) 471 v_msf_eiv_ipc(:,jk) = v_msf_eiv_ipc(:,jk-1) + v_msf_eiv_ipc(:,jk) 254 ! 255 INTEGER :: ji, jj, jk, jn ! dummy loop indices 256 REAL(wp) :: zv ! local scalar 257 !!---------------------------------------------------------------------- 258 ! 259 IF( kt == nit000 .OR. MOD( kt, nn_fptr ) == 0 ) THEN 260 ! 261 IF( MOD( kt, nn_fptr ) == 0 ) THEN 262 ! 263 IF( ln_diaznl ) THEN ! i-mean temperature and salinity 264 DO jn = 1, nptr 265 tn_jk(:,:,jn) = ptr_tjk( tn(:,:,:), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 472 266 END DO 473 267 ENDIF 474 #endif475 268 ! 476 IF( ln_subbas .AND. ln_diaznl ) THEN 477 DO jk = 2,jpk 478 v_msf_atl(:,jk) = v_msf_atl(:,jk-1) + v_msf_atl(:,jk) 479 v_msf_pac(:,jk) = v_msf_pac(:,jk-1) + v_msf_pac(:,jk) 480 v_msf_ind(:,jk) = v_msf_ind(:,jk-1) + v_msf_ind(:,jk) 481 v_msf_ipc(:,jk) = v_msf_ipc(:,jk-1) + v_msf_ipc(:,jk) 269 ! ! horizontal integral and vertical dz 270 ! ! eulerian velocity 271 v_msf(:,:,1) = ptr_vjk( vn(:,:,:) ) 272 DO jn = 2, nptr 273 v_msf(:,:,jn) = ptr_vjk( vn(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) 274 END DO 275 #if defined key_diaeiv 276 DO jn = 1, nptr ! bolus velocity 277 v_msf_eiv(:,:,jn) = ptr_vjk( v_eiv(:,:,:), btmsk(:,:,jn) ) ! here no btm30 for MSFeiv 278 END DO 279 ! ! add bolus stream-function to the eulerian one 280 v_msf(:,:,:) = v_msf(:,:,:) + v_msf_eiv(:,:,:) 281 #endif 282 ! 283 ! ! Transports 284 ! ! local heat & salt transports at T-points ( tn*mj[vn+v_eiv] ) 285 vt(:,:,jpk) = 0._wp ; vs(:,:,jpk) = 0._wp 286 DO jk= 1, jpkm1 287 DO jj = 2, jpj 288 DO ji = 1, jpi 289 #if defined key_diaeiv 290 zv = ( vn(ji,jj,jk) + vn(ji,jj-1,jk) + u_eiv(ji,jj,jk) + u_eiv(ji,jj-1,jk) ) * 0.5_wp 291 #else 292 zv = ( vn(ji,jj,jk) + vn(ji,jj-1,jk) ) * 0.5_wp 293 #endif 294 vt(:,jj,jk) = zv * tn(:,jj,jk) 295 vs(:,jj,jk) = zv * sn(:,jj,jk) 296 END DO 482 297 END DO 483 v_msf_atl(:,:) = v_msf_atl(:,:) * zsverdrup 484 v_msf_pac(:,:) = v_msf_pac(:,:) * zsverdrup 485 v_msf_ind(:,:) = v_msf_ind(:,:) * zsverdrup 486 v_msf_ipc(:,:) = v_msf_ipc(:,:) * zsverdrup 487 ENDIF 298 END DO 299 !!gm useless as overlap areas are not used in ptr_vjk 300 CALL lbc_lnk( vs, 'V', -1. ) ; CALL lbc_lnk( vt, 'V', -1. ) 301 !!gm 302 ! ! heat & salt advective transports (approximation) 303 htr(:,1) = SUM( ptr_vjk( vt(:,:,:) ) , 2 ) * rc_pwatt ! SUM over jk + conversion 304 str(:,1) = SUM( ptr_vjk( vs(:,:,:) ) , 2 ) * rc_ggram 305 DO jn = 2, nptr 306 htr(:,jn) = SUM( ptr_vjk( vt(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) , 2 ) * rc_pwatt ! mask Southern Ocean 307 str(:,jn) = SUM( ptr_vjk( vs(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) , 2 ) * rc_ggram ! mask Southern Ocean 308 END DO 309 310 IF( ln_ptrcomp ) THEN ! overturning transport 311 htr_ove(:) = SUM( v_msf(:,:,1) * tn_jk(:,:,1), 2 ) * rc_pwatt ! SUM over jk + conversion 312 str_ove(:) = SUM( v_msf(:,:,1) * sn_jk(:,:,1), 2 ) * rc_ggram 313 END IF 314 ! ! Advective and diffusive transport 315 htr_adv(:) = htr_adv(:) * rc_pwatt ! these are computed in tra_adv... and tra_ldf... routines 316 htr_ldf(:) = htr_ldf(:) * rc_pwatt ! here just the conversion in PW and Gg 317 str_adv(:) = str_adv(:) * rc_ggram 318 str_ldf(:) = str_ldf(:) * rc_ggram 319 320 #if defined key_diaeiv 321 DO jn = 1, nptr ! Bolus component 322 htr_eiv(:,jn) = SUM( v_msf_eiv(:,:,jn) * tn_jk(:,:,jn), 2 ) * rc_pwatt ! SUM over jk 323 str_eiv(:,jn) = SUM( v_msf_eiv(:,:,jn) * sn_jk(:,:,jn), 2 ) * rc_ggram ! SUM over jk 324 END DO 325 #endif 326 ! ! "Meridional" Stream-Function 327 DO jn = 1, nptr 328 DO jk = 2, jpk 329 v_msf (:,jk,jn) = v_msf (:,jk-1,jn) + v_msf (:,jk,jn) ! Eulerian j-Stream-Function 330 #if defined key_diaeiv 331 v_msf_eiv(:,jk,jn) = v_msf_eiv(:,jk-1,jn) + v_msf_eiv(:,jk,jn) ! Bolus j-Stream-Function 332 333 #endif 334 END DO 335 END DO 336 v_msf (:,:,:) = v_msf (:,:,:) * rc_sv ! converte in Sverdrups 337 #if defined key_diaeiv 338 v_msf_eiv(:,:,:) = v_msf_eiv(:,:,:) * rc_sv 339 #endif 488 340 ENDIF 489 341 ! … … 503 355 !! ** Purpose : Initialization, namelist read 504 356 !!---------------------------------------------------------------------- 505 INTEGER :: inum ! temporary logical unit 357 INTEGER :: jn ! dummy loop indices 358 INTEGER :: inum, ierr ! local integers 506 359 #if defined key_mpp_mpi 507 360 INTEGER, DIMENSION(1) :: iglo, iloc, iabsf, iabsl, ihals, ihale, idid 508 361 #endif 509 362 !! 510 NAMELIST/namptr/ ln_diaptr, ln_diaznl, ln_subbas, ln_ptrcomp, n f_ptr, nf_ptr_wri511 !!---------------------------------------------------------------------- 512 513 REWIND ( numnam )! Read Namelist namptr : poleward transport parameters514 READ 515 516 IF(lwp) THEN ! Control print363 NAMELIST/namptr/ ln_diaptr, ln_diaznl, ln_subbas, ln_ptrcomp, nn_fptr, nn_fwri 364 !!---------------------------------------------------------------------- 365 366 REWIND( numnam ) ! Read Namelist namptr : poleward transport parameters 367 READ ( numnam, namptr ) 368 369 IF(lwp) THEN ! Control print 517 370 WRITE(numout,*) 518 371 WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization' 519 372 WRITE(numout,*) '~~~~~~~~~~~~' 520 373 WRITE(numout,*) ' Namelist namptr : set ptr parameters' 521 WRITE(numout,*) ' Switch for ptr diagnostic (T) or not (F) ln_diaptr = ', ln_diaptr 522 WRITE(numout,*) ' Atl/Pac/Ind basins computation ln_subbas = ', ln_subbas 523 WRITE(numout,*) ' Frequency of computation nf_ptr = ', nf_ptr 524 WRITE(numout,*) ' Frequency of outputs nf_ptr_wri = ', nf_ptr_wri 374 WRITE(numout,*) ' Poleward heat & salt transport (T) or not (F) ln_diaptr = ', ln_diaptr 375 WRITE(numout,*) ' Overturning heat & salt transport ln_ptrcomp = ', ln_ptrcomp 376 WRITE(numout,*) ' T & S zonal mean and meridional stream function ln_diaznl = ', ln_diaznl 377 WRITE(numout,*) ' Global (F) or glo/Atl/Pac/Ind/Indo-Pac basins ln_subbas = ', ln_subbas 378 WRITE(numout,*) ' Frequency of computation nn_fptr = ', nn_fptr 379 WRITE(numout,*) ' Frequency of outputs nn_fwri = ', nn_fwri 525 380 ENDIF 526 381 527 IF( .NOT. ln_diaptr ) RETURN 528 529 IF( lk_mpp ) CALL mpp_ini_znl ! Define MPI communicator for zonal sum 530 531 IF( ln_subbas ) THEN ! load sub-basin mask 532 CALL iom_open( 'subbasins', inum ) 533 CALL iom_get( inum, jpdom_data, 'atlmsk', abasin ) ! Atlantic basin 534 CALL iom_get( inum, jpdom_data, 'pacmsk', pbasin ) ! Pacific basin 535 CALL iom_get( inum, jpdom_data, 'indmsk', ibasin ) ! Indian basin 536 CALL iom_close( inum ) 537 dbasin(:,:) = MAX ( pbasin(:,:), ibasin(:,:) ) 538 sbasin(:,:) = tmask (:,:,1) 539 WHERE ( gphit (:,:) < -30.e0) sbasin(:,:) = 0.e0 382 IF( ln_subbas ) THEN ; nptr = 5 ! Global, Atlantic, Pacific, Indian, Indo-Pacific 383 ELSE ; nptr = 1 ! Global only 384 ENDIF 385 386 rc_pwatt = rc_pwatt * rau0 * rcp ! conversion from K.s-1 to PetaWatt 387 388 IF( .NOT. ln_diaptr ) THEN ! diaptr not used 389 RETURN 390 ELSE ! Allocate the diaptr arrays 391 ALLOCATE( btmsk(jpi,jpj,nptr) , & 392 & htr_adv(jpj) , str_adv(jpj) , htr_ldf(jpj) , str_ldf(jpj) , htr_ove(jpj) , str_ove(jpj), & 393 & htr(jpj,nptr) , str(jpj,nptr) , & 394 & tn_jk(jpj,jpk,nptr) , sn_jk (jpj,jpk,nptr) , v_msf(jpj,jpk,nptr) , & 395 & sjk (jpj,jpk,nptr) , r1_sjk(jpj,jpk,nptr) , STAT=ierr ) 396 ! 397 IF( ierr > 0 ) THEN 398 CALL ctl_stop( 'dia_ptr_init : unable to allocate standard arrays' ) ; RETURN 399 ENDIF 400 #if defined key_diaeiv 401 !! IF( lk_diaeiv ) & ! eddy induced velocity arrays 402 ALLOCATE( htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) , v_msf_eiv(jpj,jpk,nptr) , STAT=ierr ) 403 ! 404 IF( ierr > 0 ) THEN 405 CALL ctl_stop( 'dia_ptr_init : unable to allocate eiv arrays' ) ; RETURN 406 ENDIF 407 #endif 540 408 ENDIF 541 409 542 !!gm CAUTION : this is only valid in fixed volume case ! 543 544 ! inverse of the ocean "zonal" v-point section 545 surf_jk_glo(:,:) = ptr_tjk( tmask(:,:,:) ) 546 surf_jk_r_glo(:,:) = 0.e0 547 WHERE( surf_jk_glo(:,:) /= 0.e0 ) surf_jk_r_glo(:,:) = 1.e0 / surf_jk_glo(:,:) 410 IF( lk_mpp ) CALL mpp_ini_znl ! Define MPI communicator for zonal sum 411 412 IF( ln_subbas ) THEN ! load sub-basin mask 413 CALL iom_open( 'subbasins', inum ) 414 CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin 415 CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin 416 CALL iom_get( inum, jpdom_data, 'indmsk', btmsk(:,:,4) ) ! Indian basin 417 CALL iom_close( inum ) 418 btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin 419 WHERE( gphit(:,:) < -30._wp) ; btm30(:,:) = 0._wp ! mask out Southern Ocean 420 ELSE WHERE ; btm30(:,:) = tmask(:,:,1) 421 END WHERE 422 ENDIF 423 btmsk(:,:,1) = tmask_i(:,:) ! global ocean 548 424 549 IF (ln_subbas) THEN 550 surf_jk_atl(:,:) = ptr_tjk( tmask (:,:,:), abasin(:,:) ) 551 surf_jk_r_atl(:,:) = 0.e0 552 WHERE( surf_jk_atl(:,:) /= 0.e0 ) surf_jk_r_atl(:,:) = 1.e0 / surf_jk_atl(:,:) 553 ! 554 surf_jk_pac(:,:) = ptr_tjk( tmask (:,:,:), pbasin(:,:) ) 555 surf_jk_r_pac(:,:) = 0.e0 556 WHERE( surf_jk_pac(:,:) /= 0.e0 ) surf_jk_r_pac(:,:) = 1.e0 / surf_jk_pac(:,:) 557 ! 558 surf_jk_ind(:,:) = ptr_tjk( tmask (:,:,:), ibasin(:,:) ) 559 surf_jk_r_ind(:,:) = 0.e0 560 WHERE( surf_jk_ind(:,:) /= 0.e0 ) surf_jk_r_ind(:,:) = 1.e0 / surf_jk_ind(:,:) 561 ! 562 surf_jk_ipc(:,:) = ptr_tjk( tmask (:,:,:), dbasin(:,:) ) 563 surf_jk_r_ipc(:,:) = 0.e0 564 WHERE( surf_jk_ipc(:,:) /= 0.e0 ) surf_jk_r_ipc(:,:) = 1.e0 / surf_jk_ipc(:,:) 565 END IF 566 425 DO jn = 1, nptr 426 btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:) ! interior domain only 427 END DO 567 428 568 !!---------------------------------------------------------------------- 429 IF( lk_vvl ) CALL ctl_stop( 'diaptr: error in vvl case as constant i-mean surface is used' ) 430 431 ! ! i-sum of e1v*e3v surface and its inverse 432 DO jn = 1, nptr 433 sjk(:,:,jn) = ptr_tjk( tmask(:,:,:), btmsk(:,:,jn) ) 434 r1_sjk(:,:,jn) = 0._wp 435 WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 436 END DO 569 437 570 438 #if defined key_mpp_mpi 571 iglo (1) = jpjglo 439 iglo (1) = jpjglo ! MPP case using MPI ('key_mpp_mpi') 572 440 iloc (1) = nlcj 573 441 iabsf(1) = njmppt(narea) … … 576 444 ihale(1) = nlcj - nlej 577 445 idid (1) = 2 578 579 !-$$ IF(lwp) THEN 580 !-$$ WRITE(numout,*) 581 !-$$ WRITE(numout,*) 'dia_ptr_init : iloc = ', iloc 582 !-$$ WRITE(numout,*) '~~~~~~~~~~~~ iabsf = ', iabsf 583 !-$$ WRITE(numout,*) ' ihals = ', ihals 584 !-$$ WRITE(numout,*) ' ihale = ', ihale 585 !-$$ ENDIF 586 587 CALL flio_dom_set ( jpnj, nproc/jpni, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom_ptr) 446 CALL flio_dom_set( jpnj, nproc/jpni, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom_ptr ) 588 447 #else 589 448 nidom_ptr = FLIO_DOM_NONE … … 610 469 INTEGER, SAVE, DIMENSION (jpj*jpk) :: ndex_atl_30 , ndex_pac_30 , ndex_ind_30 , ndex_ipc_30 611 470 INTEGER, SAVE, DIMENSION (jpj) :: ndex_h, ndex_h_atl_30, ndex_h_pac_30, ndex_h_ind_30, ndex_h_ipc_30 612 471 !! 613 472 CHARACTER (len=40) :: clhstnam, clop, clop_once, cl_comment ! temporary names 614 473 INTEGER :: iline, it, itmod, ji, jj, jk ! … … 622 481 623 482 ! define time axis 624 it = kt / n f_ptr483 it = kt / nn_fptr 625 484 itmod = kt - nit000 + 1 626 485 627 !-$$ IF(lwp) THEN628 !-$$ WRITE(numout,*)629 !-$$ WRITE(numout,*) 'dia_ptr_wri : kt = ', kt, 'it = ', it, ' itmod = ', itmod, ' niter = ', niter630 !-$$ WRITE(numout,*) '~~~~~~~~~~~~'631 !-$$ ENDIF632 633 486 ! Initialization 634 487 ! -------------- 635 488 IF( kt == nit000 ) THEN 636 637 niter = (nit000 - 1) / nf_ptr 638 639 !-$$ IF(lwp) THEN 640 !-$$ WRITE(numout,*) 641 !-$$ WRITE(numout,*) 'dia_ptr_wri : poleward transport and msf writing: initialization , niter = ', niter 642 !-$$ WRITE(numout,*) '~~~~~~~~~~~~' 643 !-$$ ENDIF 644 489 niter = ( nit000 - 1 ) / nn_fptr 645 490 zdt = rdt 646 491 IF( nacc == 1 ) zdt = rdtmin 647 648 ! Reference latitude 492 ! 493 IF(lwp) THEN 494 WRITE(numout,*) 495 WRITE(numout,*) 'dia_ptr_wri : poleward transport and msf writing: initialization , niter = ', niter 496 WRITE(numout,*) '~~~~~~~~~~~~' 497 ENDIF 498 499 ! Reference latitude (used in plots) 649 500 ! ------------------ 650 501 ! ! ======================= 651 502 IF( cp_cfg == "orca" ) THEN ! ORCA configurations 652 503 ! ! ======================= 653 654 504 IF( jp_cfg == 05 ) iline = 192 ! i-line that passes near the North Pole 655 505 IF( jp_cfg == 025 ) iline = 384 ! i-line that passes near the North Pole … … 657 507 IF( jp_cfg == 2 ) iline = 48 ! i-line that passes near the North Pole 658 508 IF( jp_cfg == 4 ) iline = 24 ! i-line that passes near the North Pole 659 zphi(:) = 0. e0509 zphi(:) = 0._wp 660 510 DO ji = mi0(iline), mi1(iline) 661 511 zphi(:) = gphiv(ji,:) ! if iline is in the local domain … … 663 513 IF( jp_cfg == 05 ) THEN 664 514 DO jj = mj0(jpjdta), mj1(jpjdta) 665 zphi( jj ) = zphi(mj0(jpjdta-1)) + ( zphi(mj0(jpjdta-1))-zphi(mj0(jpjdta-2)))/2.666 zphi( jj ) = MIN( zphi(jj), 90. )515 zphi( jj ) = zphi(mj0(jpjdta-1)) + ( zphi(mj0(jpjdta-1))-zphi(mj0(jpjdta-2)) ) * 0.5_wp 516 zphi( jj ) = MIN( zphi(jj), 90._wp ) 667 517 END DO 668 518 END IF 669 519 IF( jp_cfg == 1 .OR. jp_cfg == 2 .OR. jp_cfg == 4 ) THEN 670 520 DO jj = mj0(jpjdta-1), mj1(jpjdta-1) 671 zphi( jj ) = 88.5 e0521 zphi( jj ) = 88.5_wp 672 522 END DO 673 523 DO jj = mj0(jpjdta ), mj1(jpjdta ) 674 zphi( jj ) = 89.5 e0524 zphi( jj ) = 89.5_wp 675 525 END DO 676 526 END IF … … 680 530 CALL mpp_sum( zphi, jpj, ncomm_znl ) 681 531 #endif 682 683 532 ! ! ======================= 684 533 ELSE ! OTHER configurations … … 690 539 ! Work only on westmost processor (will not work if mppini2 is used) 691 540 #if defined key_mpp_mpi 692 IF 541 IF( l_znl_root ) THEN 693 542 #endif 694 543 ! … … 696 545 ! ---------------- 697 546 ! Define frequency of output and means 698 zsto = n f_ptr * zdt547 zsto = nn_fptr * zdt 699 548 IF( ln_mskland ) THEN ! put 1.e+20 on land (very expensive!!) 700 549 clop = "ave(only(x))" … … 705 554 ENDIF 706 555 707 zout = n f_ptr_wri * zdt708 zfoo(:) = 0. e0556 zout = nn_fwri * zdt 557 zfoo(:) = 0._wp 709 558 710 559 ! Compute julian date from starting date of the run … … 716 565 ! Requested by IPSL people, use by their postpro... 717 566 IF(lwp) THEN 718 CALL dia_nam( clhstnam, n f_ptr_wri,' ' )567 CALL dia_nam( clhstnam, nn_fwri,' ' ) 719 568 CALL ctl_opn( inum, 'date.file', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 720 569 WRITE(inum,*) clhstnam … … 723 572 #endif 724 573 725 CALL dia_nam( clhstnam, n f_ptr_wri, 'diaptr' )574 CALL dia_nam( clhstnam, nn_fwri, 'diaptr' ) 726 575 IF(lwp)WRITE( numout,*)" Name of diaptr NETCDF file : ", clhstnam 727 576 728 577 ! Horizontal grid : zphi() 729 578 CALL histbeg(clhstnam, 1, zfoo, jpj, zphi, & 730 1, 1, 1, jpj, niter, zjulian, zdt*n f_ptr, nhoridz, numptr, domain_id=nidom_ptr, snc4chunks=snc4set)579 1, 1, 1, jpj, niter, zjulian, zdt*nn_fptr, nhoridz, numptr, domain_id=nidom_ptr) 731 580 ! Vertical grids : gdept_0, gdepw_0 732 581 CALL histvert( numptr, "deptht", "Vertical T levels", & 733 "m", jpk, gdept_0, ndepidzt, "down" )582 & "m", jpk, gdept_0, ndepidzt, "down" ) 734 583 CALL histvert( numptr, "depthw", "Vertical W levels", & 735 "m", jpk, gdepw_0, ndepidzw, "down" )584 & "m", jpk, gdepw_0, ndepidzw, "down" ) 736 585 737 586 ! 738 CALL wheneq ( jpj*jpk, MIN(s urf_jk_glo(:,:), 1.e0), 1, 1., ndex , ndim ) ! Lat-Depth739 CALL wheneq ( jpj , MIN(s urf_jk_glo(:,1), 1.e0), 1, 1., ndex_h, ndim_h ) ! Lat740 741 IF (ln_subbas) THEN742 z_1 (:,1) = 1.0e0743 WHERE ( gphit (jpi/2,:) .LT. -30 ) z_1 (:,1) = 0.e0587 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,1), 1._wp), 1, 1., ndex , ndim ) ! Lat-Depth 588 CALL wheneq ( jpj , MIN(sjk(:,1,1), 1._wp), 1, 1., ndex_h, ndim_h ) ! Lat 589 590 IF( ln_subbas ) THEN 591 z_1(:,1) = 1._wp 592 WHERE ( gphit(jpi/2,:) < -30._wp ) z_1(:,1) = 0._wp 744 593 DO jk = 2, jpk 745 z_1 (:,jk) = z_1(:,1)594 z_1(:,jk) = z_1(:,1) 746 595 END DO 747 748 CALL wheneq ( jpj*jpk, MIN(surf_jk_atl(:,:) , 1.e0), 1, 1., ndex_atl , ndim_atl ) ! Lat-Depth 749 CALL wheneq ( jpj*jpk, MIN(surf_jk_atl(:,:)*z_1(:,:), 1.e0), 1, 1., ndex_atl_30 , ndim_atl_30 ) ! Lat-Depth 750 CALL wheneq ( jpj , MIN(surf_jk_atl(:,1)*z_1(:,1), 1.e0), 1, 1., ndex_h_atl_30, ndim_h_atl_30 ) ! Lat 751 752 CALL wheneq ( jpj*jpk, MIN(surf_jk_pac(:,:) , 1.e0), 1, 1., ndex_pac , ndim_pac ) ! Lat-Depth 753 CALL wheneq ( jpj*jpk, MIN(surf_jk_pac(:,:)*z_1(:,:), 1.e0), 1, 1., ndex_pac_30 , ndim_pac_30 ) ! Lat-Depth 754 CALL wheneq ( jpj , MIN(surf_jk_pac(:,1)*z_1(:,1), 1.e0), 1, 1., ndex_h_pac_30, ndim_h_pac_30 ) ! Lat 755 756 CALL wheneq ( jpj*jpk, MIN(surf_jk_ind(:,:) , 1.e0), 1, 1., ndex_ind , ndim_ind ) ! Lat-Depth 757 CALL wheneq ( jpj*jpk, MIN(surf_jk_ind(:,:)*z_1(:,:), 1.e0), 1, 1., ndex_ind_30 , ndim_ind_30 ) ! Lat-Depth 758 CALL wheneq ( jpj , MIN(surf_jk_ind(:,1)*z_1(:,1), 1.e0), 1, 1., ndex_h_ind_30, ndim_h_ind_30 ) ! Lat 759 760 CALL wheneq ( jpj*jpk, MIN(surf_jk_ipc(:,:) , 1.e0), 1, 1., ndex_ipc , ndim_ipc ) ! Lat-Depth 761 CALL wheneq ( jpj*jpk, MIN(surf_jk_ipc(:,:)*z_1(:,:), 1.e0), 1, 1., ndex_ipc_30 , ndim_ipc_30 ) ! Lat-Depth 762 CALL wheneq ( jpj , MIN(surf_jk_ipc(:,1)*z_1(:,1), 1.e0), 1, 1., ndex_h_ipc_30, ndim_h_ipc_30 ) ! Lat 763 596 ! ! Atlantic (jn=2) 597 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,2) , 1._wp), 1, 1., ndex_atl , ndim_atl ) ! Lat-Depth 598 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,2)*z_1(:,:), 1._wp), 1, 1., ndex_atl_30 , ndim_atl_30 ) ! Lat-Depth 599 CALL wheneq ( jpj , MIN(sjk(:,1,2)*z_1(:,1), 1._wp), 1, 1., ndex_h_atl_30, ndim_h_atl_30 ) ! Lat 600 ! ! Pacific (jn=3) 601 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,3) , 1._wp), 1, 1., ndex_pac , ndim_pac ) ! Lat-Depth 602 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,3)*z_1(:,:), 1._wp), 1, 1., ndex_pac_30 , ndim_pac_30 ) ! Lat-Depth 603 CALL wheneq ( jpj , MIN(sjk(:,1,3)*z_1(:,1), 1._wp), 1, 1., ndex_h_pac_30, ndim_h_pac_30 ) ! Lat 604 ! ! Indian (jn=4) 605 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,4) , 1._wp), 1, 1., ndex_ind , ndim_ind ) ! Lat-Depth 606 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,4)*z_1(:,:), 1._wp), 1, 1., ndex_ind_30 , ndim_ind_30 ) ! Lat-Depth 607 CALL wheneq ( jpj , MIN(sjk(:,1,4)*z_1(:,1), 1._wp), 1, 1., ndex_h_ind_30, ndim_h_ind_30 ) ! Lat 608 ! ! Indo-Pacific (jn=5) 609 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,5) , 1._wp), 1, 1., ndex_ipc , ndim_ipc ) ! Lat-Depth 610 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,5)*z_1(:,:), 1._wp), 1, 1., ndex_ipc_30 , ndim_ipc_30 ) ! Lat-Depth 611 CALL wheneq ( jpj , MIN(sjk(:,1,5)*z_1(:,1), 1._wp), 1, 1., ndex_h_ipc_30, ndim_h_ipc_30 ) ! Lat 764 612 ENDIF 765 766 613 ! 767 614 #if defined key_diaeiv … … 772 619 ! Zonal mean T and S 773 620 774 IF 621 IF( ln_diaznl ) THEN 775 622 CALL histdef( numptr, "zotemglo", "Zonal Mean Temperature","C" , & 776 623 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) … … 880 727 ENDIF 881 728 882 CALL histend( numptr , snc4set)729 CALL histend( numptr ) 883 730 884 731 END IF … … 888 735 889 736 #if defined key_mpp_mpi 890 IF( MOD( itmod, n f_ptr ) == 0 .AND. l_znl_root ) THEN737 IF( MOD( itmod, nn_fptr ) == 0 .AND. l_znl_root ) THEN 891 738 #else 892 IF( MOD( itmod, n f_ptr ) == 0 ) THEN739 IF( MOD( itmod, nn_fptr ) == 0 ) THEN 893 740 #endif 894 741 niter = niter + 1 895 742 896 !-$$ IF(lwp) THEN 897 !-$$ WRITE(numout,*) 898 !-$$ WRITE(numout,*) 'dia_ptr_wri : write Poleward Transports at time-step : kt = ', kt, & 899 !-$$ & 'it = ', it, ' itmod = ', itmod, ' niter = ', niter 900 !-$$ WRITE(numout,*) '~~~~~~~~~~' 901 !-$$ WRITE(numout,*) 902 !-$$ ENDIF 903 904 IF (ln_diaznl ) THEN 905 CALL histwrite( numptr, "zosrfglo", niter, surf_jk_glo , ndim, ndex ) 906 CALL histwrite( numptr, "zotemglo", niter, tn_jk_glo , ndim, ndex ) 907 CALL histwrite( numptr, "zosalglo", niter, sn_jk_glo , ndim, ndex ) 743 IF( ln_diaznl ) THEN 744 CALL histwrite( numptr, "zosrfglo", niter, sjk (:,:,1) , ndim, ndex ) 745 CALL histwrite( numptr, "zotemglo", niter, tn_jk(:,:,1) , ndim, ndex ) 746 CALL histwrite( numptr, "zosalglo", niter, sn_jk(:,:,1) , ndim, ndex ) 908 747 909 748 IF (ln_subbas) THEN 910 CALL histwrite( numptr, "zosrfatl", niter, s urf_jk_atl, ndim_atl, ndex_atl )911 CALL histwrite( numptr, "zosrfpac", niter, s urf_jk_pac, ndim_pac, ndex_pac )912 CALL histwrite( numptr, "zosrfind", niter, s urf_jk_ind, ndim_ind, ndex_ind )913 CALL histwrite( numptr, "zosrfipc", niter, s urf_jk_ipc, ndim_ipc, ndex_ipc )914 915 CALL histwrite( numptr, "zotematl", niter, tn_jk _atl, ndim_atl, ndex_atl )916 CALL histwrite( numptr, "zosalatl", niter, sn_jk _atl, ndim_atl, ndex_atl )917 CALL histwrite( numptr, "zotempac", niter, tn_jk _pac, ndim_pac, ndex_pac )918 CALL histwrite( numptr, "zosalpac", niter, sn_jk _pac, ndim_pac, ndex_pac )919 CALL histwrite( numptr, "zotemind", niter, tn_jk _ind, ndim_ind, ndex_ind )920 CALL histwrite( numptr, "zosalind", niter, sn_jk _ind, ndim_ind, ndex_ind )921 CALL histwrite( numptr, "zotemipc", niter, tn_jk _ipc, ndim_ipc, ndex_ipc )922 CALL histwrite( numptr, "zosalipc", niter, sn_jk _ipc, ndim_ipc, ndex_ipc )749 CALL histwrite( numptr, "zosrfatl", niter, sjk(:,:,2), ndim_atl, ndex_atl ) 750 CALL histwrite( numptr, "zosrfpac", niter, sjk(:,:,3), ndim_pac, ndex_pac ) 751 CALL histwrite( numptr, "zosrfind", niter, sjk(:,:,4), ndim_ind, ndex_ind ) 752 CALL histwrite( numptr, "zosrfipc", niter, sjk(:,:,5), ndim_ipc, ndex_ipc ) 753 754 CALL histwrite( numptr, "zotematl", niter, tn_jk(:,:,2) , ndim_atl, ndex_atl ) 755 CALL histwrite( numptr, "zosalatl", niter, sn_jk(:,:,2) , ndim_atl, ndex_atl ) 756 CALL histwrite( numptr, "zotempac", niter, tn_jk(:,:,3) , ndim_pac, ndex_pac ) 757 CALL histwrite( numptr, "zosalpac", niter, sn_jk(:,:,3) , ndim_pac, ndex_pac ) 758 CALL histwrite( numptr, "zotemind", niter, tn_jk(:,:,4) , ndim_ind, ndex_ind ) 759 CALL histwrite( numptr, "zosalind", niter, sn_jk(:,:,4) , ndim_ind, ndex_ind ) 760 CALL histwrite( numptr, "zotemipc", niter, tn_jk(:,:,5) , ndim_ipc, ndex_ipc ) 761 CALL histwrite( numptr, "zosalipc", niter, sn_jk(:,:,5) , ndim_ipc, ndex_ipc ) 923 762 END IF 924 763 ENDIF 925 764 926 765 ! overturning outputs: 927 CALL histwrite( numptr, "zomsfglo", niter, v_msf _glo, ndim, ndex )766 CALL histwrite( numptr, "zomsfglo", niter, v_msf(:,:,1), ndim, ndex ) 928 767 IF( ln_subbas .AND. ln_diaznl ) THEN 929 CALL histwrite( numptr, "zomsfatl", niter, v_msf _atl, ndim_atl_30, ndex_atl_30 )930 CALL histwrite( numptr, "zomsfpac", niter, v_msf _pac, ndim_pac_30, ndex_pac_30 )931 CALL histwrite( numptr, "zomsfind", niter, v_msf _ind, ndim_ind_30, ndex_ind_30 )932 CALL histwrite( numptr, "zomsfipc", niter, v_msf _ipc, ndim_ipc_30, ndex_ipc_30 )768 CALL histwrite( numptr, "zomsfatl", niter, v_msf(:,:,2) , ndim_atl_30, ndex_atl_30 ) 769 CALL histwrite( numptr, "zomsfpac", niter, v_msf(:,:,3) , ndim_pac_30, ndex_pac_30 ) 770 CALL histwrite( numptr, "zomsfind", niter, v_msf(:,:,4) , ndim_ind_30, ndex_ind_30 ) 771 CALL histwrite( numptr, "zomsfipc", niter, v_msf(:,:,5) , ndim_ipc_30, ndex_ipc_30 ) 933 772 ENDIF 934 773 #if defined key_diaeiv 935 CALL histwrite( numptr, "zomsfeiv", niter, v_msf_eiv_glo, ndim , ndex ) 936 #endif 937 774 CALL histwrite( numptr, "zomsfeiv", niter, v_msf_eiv(:,:,1), ndim , ndex ) 775 #endif 938 776 939 777 ! heat transport outputs: 940 778 IF( ln_subbas ) THEN 941 CALL histwrite( numptr, "sohtatl", niter, ht _atl, ndim_h_atl_30, ndex_h_atl_30 )942 CALL histwrite( numptr, "sohtpac", niter, ht _pac, ndim_h_pac_30, ndex_h_pac_30 )943 CALL histwrite( numptr, "sohtind", niter, ht _ind, ndim_h_ind_30, ndex_h_ind_30 )944 CALL histwrite( numptr, "sohtipc", niter, ht _ipc, ndim_h_ipc_30, ndex_h_ipc_30 )945 CALL histwrite( numptr, "sostatl", niter, st _atl, ndim_h_atl_30, ndex_h_atl_30 )946 CALL histwrite( numptr, "sostpac", niter, st _pac, ndim_h_pac_30, ndex_h_pac_30 )947 CALL histwrite( numptr, "sostind", niter, st _ind, ndim_h_ind_30, ndex_h_ind_30 )948 CALL histwrite( numptr, "sostipc", niter, st _ipc, ndim_h_ipc_30, ndex_h_ipc_30 )779 CALL histwrite( numptr, "sohtatl", niter, htr(:,2) , ndim_h_atl_30, ndex_h_atl_30 ) 780 CALL histwrite( numptr, "sohtpac", niter, htr(:,3) , ndim_h_pac_30, ndex_h_pac_30 ) 781 CALL histwrite( numptr, "sohtind", niter, htr(:,4) , ndim_h_ind_30, ndex_h_ind_30 ) 782 CALL histwrite( numptr, "sohtipc", niter, htr(:,5) , ndim_h_ipc_30, ndex_h_ipc_30 ) 783 CALL histwrite( numptr, "sostatl", niter, str(:,2) , ndim_h_atl_30, ndex_h_atl_30 ) 784 CALL histwrite( numptr, "sostpac", niter, str(:,3) , ndim_h_pac_30, ndex_h_pac_30 ) 785 CALL histwrite( numptr, "sostind", niter, str(:,4) , ndim_h_ind_30, ndex_h_ind_30 ) 786 CALL histwrite( numptr, "sostipc", niter, str(:,5) , ndim_h_ipc_30, ndex_h_ipc_30 ) 949 787 ENDIF 950 788 951 CALL histwrite( numptr, "sophtadv", niter, pht_adv , ndim_h, ndex_h )952 CALL histwrite( numptr, "sophtldf", niter, pht_ldf , ndim_h, ndex_h )953 CALL histwrite( numptr, "sopstadv", niter, pst_adv , ndim_h, ndex_h )954 CALL histwrite( numptr, "sopstldf", niter, pst_ldf , ndim_h, ndex_h )955 IF 956 CALL histwrite( numptr, "sopstove", niter, pst_ove_glo, ndim_h, ndex_h )957 CALL histwrite( numptr, "sophtove", niter, pht_ove_glo, ndim_h, ndex_h )789 CALL histwrite( numptr, "sophtadv", niter, htr_adv , ndim_h, ndex_h ) 790 CALL histwrite( numptr, "sophtldf", niter, htr_ldf , ndim_h, ndex_h ) 791 CALL histwrite( numptr, "sopstadv", niter, str_adv , ndim_h, ndex_h ) 792 CALL histwrite( numptr, "sopstldf", niter, str_ldf , ndim_h, ndex_h ) 793 IF( ln_ptrcomp ) THEN 794 CALL histwrite( numptr, "sopstove", niter, str_ove(:) , ndim_h, ndex_h ) 795 CALL histwrite( numptr, "sophtove", niter, htr_ove(:) , ndim_h, ndex_h ) 958 796 ENDIF 959 797 #if defined key_diaeiv 960 CALL histwrite( numptr, "sophteiv", niter, pht_eiv_glo, ndim_h, ndex_h )961 CALL histwrite( numptr, "sopsteiv", niter, pst_eiv_glo, ndim_h, ndex_h )798 CALL histwrite( numptr, "sophteiv", niter, htr_eiv(:,1) , ndim_h, ndex_h ) 799 CALL histwrite( numptr, "sopsteiv", niter, str_eiv(:,1) , ndim_h, ndex_h ) 962 800 #endif 963 801 !
Note: See TracChangeset
for help on using the changeset viewer.
