Changeset 7646 for trunk/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90
- Timestamp:
- 2017-02-06T10:25:03+01:00 (7 years ago)
- File:
-
- 1 edited
-
trunk/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90 (modified) (12 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90
r6140 r7646 9 9 !! 3.3 ! 2010-10 (G. Madec) dynamical allocation 10 10 !! 3.6 ! 2014-12 (C. Ethe) use of IOM 11 !! 3.6 ! 2016-06 (T. Graham) Addition of diagnostics for CMIP6 11 12 !!---------------------------------------------------------------------- 12 13 … … 38 39 PUBLIC dia_ptr_init ! call in step module 39 40 PUBLIC dia_ptr ! call in step module 41 PUBLIC dia_ptr_hst ! called from tra_ldf/tra_adv routines 40 42 41 43 ! !!** namelist namptr ** 42 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) :: htr_adv, htr_ldf !: Heat TRansports (adv, diff, overturn.) 43 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) :: str_adv, str_ldf !: Salt TRansports (adv, diff, overturn.) 44 44 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: htr_adv, htr_ldf, htr_eiv !: Heat TRansports (adv, diff, Bolus.) 45 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: str_adv, str_ldf, str_eiv !: Salt TRansports (adv, diff, Bolus.) 46 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: htr_ove, str_ove !: heat Salt TRansports ( overturn.) 47 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: htr_btr, str_btr !: heat Salt TRansports ( barotropic ) 45 48 46 49 LOGICAL, PUBLIC :: ln_diaptr ! Poleward transport flag (T) or not (F) 47 50 LOGICAL, PUBLIC :: ln_subbas ! Atlantic/Pacific/Indian basins calculation 48 INTEGER 51 INTEGER, PUBLIC :: nptr ! = 1 (l_subbas=F) or = 5 (glo, atl, pac, ind, ipc) (l_subbas=T) 49 52 50 53 REAL(wp) :: rc_sv = 1.e-6_wp ! conversion from m3/s to Sverdrup … … 75 78 ! 76 79 INTEGER :: ji, jj, jk, jn ! dummy loop indices 77 REAL(wp) :: z v, zsfc ! local scalar80 REAL(wp) :: zsfc,zvfc ! local scalar 78 81 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace 79 82 REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace 80 83 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask ! 3D workspace 81 84 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts ! 3D workspace 82 CHARACTER( len = 10 ) :: cl1 85 REAL(wp), DIMENSION(jpj) :: vsum ! 1D workspace 86 REAL(wp), DIMENSION(jpj,jpts) :: tssum ! 1D workspace 87 88 ! 89 !overturning calculation 90 REAL(wp), DIMENSION(jpj,jpk,nptr) :: sjk , r1_sjk ! i-mean i-k-surface and its inverse 91 REAL(wp), DIMENSION(jpj,jpk,nptr) :: v_msf, sn_jk , tn_jk ! i-mean T and S, j-Stream-Function 92 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zvn ! 3D workspace 93 94 95 CHARACTER( len = 12 ) :: cl1 83 96 !!---------------------------------------------------------------------- 84 97 ! … … 109 122 END DO 110 123 ENDIF 124 IF( iom_use("sopstove") .OR. iom_use("sophtove") .OR. iom_use("sopstbtr") .OR. iom_use("sophtbtr") ) THEN 125 ! define fields multiplied by scalar 126 zmask(:,:,:) = 0._wp 127 zts(:,:,:,:) = 0._wp 128 zvn(:,:,:) = 0._wp 129 DO jk = 1, jpkm1 130 DO jj = 1, jpjm1 131 DO ji = 1, jpi 132 zvfc = e1v(ji,jj) * e3v_n(ji,jj,jk) 133 zmask(ji,jj,jk) = vmask(ji,jj,jk) * zvfc 134 zts(ji,jj,jk,jp_tem) = (tsn(ji,jj,jk,jp_tem)+tsn(ji,jj+1,jk,jp_tem)) * 0.5 * zvfc !Tracers averaged onto V grid 135 zts(ji,jj,jk,jp_sal) = (tsn(ji,jj,jk,jp_sal)+tsn(ji,jj+1,jk,jp_sal)) * 0.5 * zvfc 136 zvn(ji,jj,jk) = vn(ji,jj,jk) * zvfc 137 ENDDO 138 ENDDO 139 ENDDO 140 ENDIF 141 IF( iom_use("sopstove") .OR. iom_use("sophtove") ) THEN 142 sjk(:,:,1) = ptr_sjk( zmask(:,:,:), btmsk(:,:,1) ) 143 r1_sjk(:,:,1) = 0._wp 144 WHERE( sjk(:,:,1) /= 0._wp ) r1_sjk(:,:,1) = 1._wp / sjk(:,:,1) 145 146 ! i-mean T and S, j-Stream-Function, global 147 tn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_tem) ) * r1_sjk(:,:,1) 148 sn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_sal) ) * r1_sjk(:,:,1) 149 v_msf(:,:,1) = ptr_sjk( zvn(:,:,:) ) 150 151 htr_ove(:,1) = SUM( v_msf(:,:,1)*tn_jk(:,:,1) ,2 ) 152 str_ove(:,1) = SUM( v_msf(:,:,1)*sn_jk(:,:,1) ,2 ) 153 154 z2d(1,:) = htr_ove(:,1) * rc_pwatt ! (conversion in PW) 155 DO ji = 1, jpi 156 z2d(ji,:) = z2d(1,:) 157 ENDDO 158 cl1 = 'sophtove' 159 CALL iom_put( TRIM(cl1), z2d ) 160 z2d(1,:) = str_ove(:,1) * rc_ggram ! (conversion in Gg) 161 DO ji = 1, jpi 162 z2d(ji,:) = z2d(1,:) 163 ENDDO 164 cl1 = 'sopstove' 165 CALL iom_put( TRIM(cl1), z2d ) 166 IF( ln_subbas ) THEN 167 DO jn = 2, nptr 168 sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 169 r1_sjk(:,:,jn) = 0._wp 170 WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 171 172 ! i-mean T and S, j-Stream-Function, basin 173 tn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 174 sn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 175 v_msf(:,:,jn) = ptr_sjk( zvn(:,:,:), btmsk(:,:,jn) ) 176 htr_ove(:,jn) = SUM( v_msf(:,:,jn)*tn_jk(:,:,jn) ,2 ) 177 str_ove(:,jn) = SUM( v_msf(:,:,jn)*sn_jk(:,:,jn) ,2 ) 178 179 z2d(1,:) = htr_ove(:,jn) * rc_pwatt ! (conversion in PW) 180 DO ji = 1, jpi 181 z2d(ji,:) = z2d(1,:) 182 ENDDO 183 cl1 = TRIM('sophtove_'//clsubb(jn)) 184 CALL iom_put( cl1, z2d ) 185 z2d(1,:) = str_ove(:,jn) * rc_ggram ! (conversion in Gg) 186 DO ji = 1, jpi 187 z2d(ji,:) = z2d(1,:) 188 ENDDO 189 cl1 = TRIM('sopstove_'//clsubb(jn)) 190 CALL iom_put( cl1, z2d ) 191 END DO 192 ENDIF 193 ENDIF 194 IF( iom_use("sopstbtr") .OR. iom_use("sophtbtr") ) THEN 195 ! Calculate barotropic heat and salt transport here 196 sjk(:,1,1) = ptr_sj( zmask(:,:,:), btmsk(:,:,1) ) 197 r1_sjk(:,1,1) = 0._wp 198 WHERE( sjk(:,1,1) /= 0._wp ) r1_sjk(:,1,1) = 1._wp / sjk(:,1,1) 199 200 vsum = ptr_sj( zvn(:,:,:), btmsk(:,:,1)) 201 tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,1) ) 202 tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,1) ) 203 htr_btr(:,1) = vsum * tssum(:,jp_tem) * r1_sjk(:,1,1) 204 str_btr(:,1) = vsum * tssum(:,jp_sal) * r1_sjk(:,1,1) 205 z2d(1,:) = htr_btr(:,1) * rc_pwatt ! (conversion in PW) 206 DO ji = 2, jpi 207 z2d(ji,:) = z2d(1,:) 208 ENDDO 209 cl1 = 'sophtbtr' 210 CALL iom_put( TRIM(cl1), z2d ) 211 z2d(1,:) = str_btr(:,1) * rc_ggram ! (conversion in Gg) 212 DO ji = 2, jpi 213 z2d(ji,:) = z2d(1,:) 214 ENDDO 215 cl1 = 'sopstbtr' 216 CALL iom_put( TRIM(cl1), z2d ) 217 IF( ln_subbas ) THEN 218 DO jn = 2, nptr 219 sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) ) 220 r1_sjk(:,1,jn) = 0._wp 221 WHERE( sjk(:,1,jn) /= 0._wp ) r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn) 222 vsum = ptr_sj( zvn(:,:,:), btmsk(:,:,jn)) 223 tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 224 tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 225 htr_btr(:,jn) = vsum * tssum(:,jp_tem) * r1_sjk(:,1,jn) 226 str_btr(:,jn) = vsum * tssum(:,jp_sal) * r1_sjk(:,1,jn) 227 z2d(1,:) = htr_btr(:,jn) * rc_pwatt ! (conversion in PW) 228 DO ji = 1, jpi 229 z2d(ji,:) = z2d(1,:) 230 ENDDO 231 cl1 = TRIM('sophtbtr_'//clsubb(jn)) 232 CALL iom_put( cl1, z2d ) 233 z2d(1,:) = str_btr(:,jn) * rc_ggram ! (conversion in Gg) 234 DO ji = 1, jpi 235 z2d(ji,:) = z2d(1,:) 236 ENDDO 237 cl1 = TRIM('sopstbtr_'//clsubb(jn)) 238 CALL iom_put( cl1, z2d ) 239 ENDDO 240 ENDIF !ln_subbas 241 ENDIF !iom_use("sopstbtr....) 111 242 ! 112 243 ELSE … … 148 279 ! ! Advective and diffusive heat and salt transport 149 280 IF( iom_use("sophtadv") .OR. iom_use("sopstadv") ) THEN 150 z2d(1,:) = htr_adv(: ) * rc_pwatt ! (conversion in PW)281 z2d(1,:) = htr_adv(:,1) * rc_pwatt ! (conversion in PW) 151 282 DO ji = 1, jpi 152 283 z2d(ji,:) = z2d(1,:) … … 154 285 cl1 = 'sophtadv' 155 286 CALL iom_put( TRIM(cl1), z2d ) 156 z2d(1,:) = str_adv(: ) * rc_ggram ! (conversion in Gg)287 z2d(1,:) = str_adv(:,1) * rc_ggram ! (conversion in Gg) 157 288 DO ji = 1, jpi 158 289 z2d(ji,:) = z2d(1,:) … … 160 291 cl1 = 'sopstadv' 161 292 CALL iom_put( TRIM(cl1), z2d ) 293 IF( ln_subbas ) THEN 294 DO jn=2,nptr 295 z2d(1,:) = htr_adv(:,jn) * rc_pwatt ! (conversion in PW) 296 DO ji = 1, jpi 297 z2d(ji,:) = z2d(1,:) 298 ENDDO 299 cl1 = TRIM('sophtadv_'//clsubb(jn)) 300 CALL iom_put( cl1, z2d ) 301 z2d(1,:) = str_adv(:,jn) * rc_ggram ! (conversion in Gg) 302 DO ji = 1, jpi 303 z2d(ji,:) = z2d(1,:) 304 ENDDO 305 cl1 = TRIM('sopstadv_'//clsubb(jn)) 306 CALL iom_put( cl1, z2d ) 307 ENDDO 308 ENDIF 162 309 ENDIF 163 310 ! 164 311 IF( iom_use("sophtldf") .OR. iom_use("sopstldf") ) THEN 165 z2d(1,:) = htr_ldf(: ) * rc_pwatt ! (conversion in PW)312 z2d(1,:) = htr_ldf(:,1) * rc_pwatt ! (conversion in PW) 166 313 DO ji = 1, jpi 167 314 z2d(ji,:) = z2d(1,:) … … 169 316 cl1 = 'sophtldf' 170 317 CALL iom_put( TRIM(cl1), z2d ) 171 z2d(1,:) = str_ldf(: ) * rc_ggram ! (conversion in Gg)318 z2d(1,:) = str_ldf(:,1) * rc_ggram ! (conversion in Gg) 172 319 DO ji = 1, jpi 173 320 z2d(ji,:) = z2d(1,:) … … 175 322 cl1 = 'sopstldf' 176 323 CALL iom_put( TRIM(cl1), z2d ) 324 IF( ln_subbas ) THEN 325 DO jn=2,nptr 326 z2d(1,:) = htr_ldf(:,jn) * rc_pwatt ! (conversion in PW) 327 DO ji = 1, jpi 328 z2d(ji,:) = z2d(1,:) 329 ENDDO 330 cl1 = TRIM('sophtldf_'//clsubb(jn)) 331 CALL iom_put( cl1, z2d ) 332 z2d(1,:) = str_ldf(:,jn) * rc_ggram ! (conversion in Gg) 333 DO ji = 1, jpi 334 z2d(ji,:) = z2d(1,:) 335 ENDDO 336 cl1 = TRIM('sopstldf_'//clsubb(jn)) 337 CALL iom_put( cl1, z2d ) 338 ENDDO 339 ENDIF 340 ENDIF 341 342 IF( iom_use("sophteiv") .OR. iom_use("sopsteiv") ) THEN 343 z2d(1,:) = htr_eiv(:,1) * rc_pwatt ! (conversion in PW) 344 DO ji = 1, jpi 345 z2d(ji,:) = z2d(1,:) 346 ENDDO 347 cl1 = 'sophteiv' 348 CALL iom_put( TRIM(cl1), z2d ) 349 z2d(1,:) = str_eiv(:,1) * rc_ggram ! (conversion in Gg) 350 DO ji = 1, jpi 351 z2d(ji,:) = z2d(1,:) 352 ENDDO 353 cl1 = 'sopsteiv' 354 CALL iom_put( TRIM(cl1), z2d ) 355 IF( ln_subbas ) THEN 356 DO jn=2,nptr 357 z2d(1,:) = htr_eiv(:,jn) * rc_pwatt ! (conversion in PW) 358 DO ji = 1, jpi 359 z2d(ji,:) = z2d(1,:) 360 ENDDO 361 cl1 = TRIM('sophteiv_'//clsubb(jn)) 362 CALL iom_put( cl1, z2d ) 363 z2d(1,:) = str_eiv(:,jn) * rc_ggram ! (conversion in Gg) 364 DO ji = 1, jpi 365 z2d(ji,:) = z2d(1,:) 366 ENDDO 367 cl1 = TRIM('sopsteiv_'//clsubb(jn)) 368 CALL iom_put( cl1, z2d ) 369 ENDDO 370 ENDIF 177 371 ENDIF 178 372 ! … … 254 448 ! Initialise arrays to zero because diatpr is called before they are first calculated 255 449 ! Note that this means diagnostics will not be exactly correct when model run is restarted. 256 htr_adv(:) = 0._wp ; str_adv(:) = 0._wp 257 htr_ldf(:) = 0._wp ; str_ldf(:) = 0._wp 450 htr_adv(:,:) = 0._wp ; str_adv(:,:) = 0._wp 451 htr_ldf(:,:) = 0._wp ; str_ldf(:,:) = 0._wp 452 htr_eiv(:,:) = 0._wp ; str_eiv(:,:) = 0._wp 453 htr_ove(:,:) = 0._wp ; str_ove(:,:) = 0._wp 454 htr_btr(:,:) = 0._wp ; str_btr(:,:) = 0._wp 258 455 ! 259 456 ENDIF … … 261 458 END SUBROUTINE dia_ptr_init 262 459 460 SUBROUTINE dia_ptr_hst( ktra, cptr, pva ) 461 !!---------------------------------------------------------------------- 462 !! *** ROUTINE dia_ptr_hst *** 463 !!---------------------------------------------------------------------- 464 !! Wrapper for heat and salt transport calculations to calculate them for each basin 465 !! Called from all advection and/or diffusion routines 466 !!---------------------------------------------------------------------- 467 INTEGER , INTENT(in ) :: ktra ! tracer index 468 CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf'/'eiv' 469 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pva ! 3D input array of advection/diffusion 470 INTEGER :: jn ! 471 472 IF( cptr == 'adv' ) THEN 473 IF( ktra == jp_tem ) htr_adv(:,1) = ptr_sj( pva(:,:,:) ) 474 IF( ktra == jp_sal ) str_adv(:,1) = ptr_sj( pva(:,:,:) ) 475 ENDIF 476 IF( cptr == 'ldf' ) THEN 477 IF( ktra == jp_tem ) htr_ldf(:,1) = ptr_sj( pva(:,:,:) ) 478 IF( ktra == jp_sal ) str_ldf(:,1) = ptr_sj( pva(:,:,:) ) 479 ENDIF 480 IF( cptr == 'eiv' ) THEN 481 IF( ktra == jp_tem ) htr_eiv(:,1) = ptr_sj( pva(:,:,:) ) 482 IF( ktra == jp_sal ) str_eiv(:,1) = ptr_sj( pva(:,:,:) ) 483 ENDIF 484 ! 485 IF( ln_subbas ) THEN 486 ! 487 IF( cptr == 'adv' ) THEN 488 IF( ktra == jp_tem ) THEN 489 DO jn = 2, nptr 490 htr_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 491 END DO 492 ENDIF 493 IF( ktra == jp_sal ) THEN 494 DO jn = 2, nptr 495 str_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 496 END DO 497 ENDIF 498 ENDIF 499 IF( cptr == 'ldf' ) THEN 500 IF( ktra == jp_tem ) THEN 501 DO jn = 2, nptr 502 htr_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 503 END DO 504 ENDIF 505 IF( ktra == jp_sal ) THEN 506 DO jn = 2, nptr 507 str_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 508 END DO 509 ENDIF 510 ENDIF 511 IF( cptr == 'eiv' ) THEN 512 IF( ktra == jp_tem ) THEN 513 DO jn = 2, nptr 514 htr_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 515 END DO 516 ENDIF 517 IF( ktra == jp_sal ) THEN 518 DO jn = 2, nptr 519 str_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) 520 END DO 521 ENDIF 522 ENDIF 523 ! 524 ENDIF 525 END SUBROUTINE dia_ptr_hst 526 263 527 264 528 FUNCTION dia_ptr_alloc() … … 271 535 ierr(:) = 0 272 536 ! 273 ALLOCATE( btmsk(jpi,jpj,nptr) , & 274 & htr_adv(jpj) , str_adv(jpj) , & 275 & htr_ldf(jpj) , str_ldf(jpj) , STAT=ierr(1) ) 537 ALLOCATE( btmsk(jpi,jpj,nptr) , & 538 & htr_adv(jpj,nptr) , str_adv(jpj,nptr) , & 539 & htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) , & 540 & htr_ove(jpj,nptr) , str_ove(jpj,nptr) , & 541 & htr_btr(jpj,nptr) , str_btr(jpj,nptr) , & 542 & htr_ldf(jpj,nptr) , str_ldf(jpj,nptr) , STAT=ierr(1) ) 276 543 ! 277 544 ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2))
Note: See TracChangeset
for help on using the changeset viewer.
