Changeset 12377 for NEMO/trunk/src/OCE/DIA/diaptr.F90
- Timestamp:
- 2020-02-12T15:39:06+01:00 (4 years ago)
- Location:
- NEMO/trunk
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/trunk
- Property svn:externals
-
old new 3 3 ^/utils/build/mk@HEAD mk 4 4 ^/utils/tools@HEAD tools 5 ^/vendors/AGRIF/dev @HEAD ext/AGRIF5 ^/vendors/AGRIF/dev_r11615_ENHANCE-04_namelists_as_internalfiles_agrif@HEAD ext/AGRIF 6 6 ^/vendors/FCM@HEAD ext/FCM 7 7 ^/vendors/IOIPSL@HEAD ext/IOIPSL
-
- Property svn:externals
-
NEMO/trunk/src/OCE/DIA/diaptr.F90
r12276 r12377 46 46 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_ove, hstr_btr, hstr_vtr !: heat Salt TRansports(overturn, baro, merional) 47 47 48 LOGICAL, PUBLIC :: ln_diaptr ! Poleward transport flag (T) or not (F) 49 LOGICAL, PUBLIC :: ln_subbas ! Atlantic/Pacific/Indian basins calculation 48 LOGICAL , PUBLIC :: l_diaptr !: tracers trend flag (set from namelist in trdini) 50 49 INTEGER, PARAMETER, PUBLIC :: nptr = 5 ! (glo, atl, pac, ind, ipc) 51 50 … … 60 59 REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:) :: p_fval2d 61 60 61 LOGICAL :: ll_init = .TRUE. !: tracers trend flag (set from namelist in trdini) 62 62 !! * Substitutions 63 # include " vectopt_loop_substitute.h90"63 # include "do_loop_substitute.h90" 64 64 !!---------------------------------------------------------------------- 65 65 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 69 69 CONTAINS 70 70 71 SUBROUTINE dia_ptr( pvtr )71 SUBROUTINE dia_ptr( kt, Kmm, pvtr ) 72 72 !!---------------------------------------------------------------------- 73 73 !! *** ROUTINE dia_ptr *** 74 74 !!---------------------------------------------------------------------- 75 INTEGER , INTENT(in) :: kt ! ocean time-step index 76 INTEGER , INTENT(in) :: Kmm ! time level index 75 77 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport 76 78 ! … … 92 94 ! 93 95 IF( ln_timing ) CALL timing_start('dia_ptr') 94 ! 96 97 IF( kt == nit000 .AND. ll_init ) CALL dia_ptr_init 98 ! 99 IF( .NOT. l_diaptr ) RETURN 100 95 101 IF( PRESENT( pvtr ) ) THEN 96 102 IF( iom_use( 'zomsf' ) ) THEN ! effective MSF … … 111 117 zmask(:,:,:) = 0._wp 112 118 zts(:,:,:,:) = 0._wp 113 DO jk = 1, jpkm1 114 DO jj = 1, jpjm1 115 DO ji = 1, jpi 116 zvfc = e1v(ji,jj) * e3v_n(ji,jj,jk) 117 zmask(ji,jj,jk) = vmask(ji,jj,jk) * zvfc 118 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 119 zts(ji,jj,jk,jp_sal) = (tsn(ji,jj,jk,jp_sal)+tsn(ji,jj+1,jk,jp_sal)) * 0.5 * zvfc 120 ENDDO 121 ENDDO 122 ENDDO 119 DO_3D_10_11( 1, jpkm1 ) 120 zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 121 zmask(ji,jj,jk) = vmask(ji,jj,jk) * zvfc 122 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 123 zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc 124 END_3D 123 125 ENDIF 124 126 IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN … … 186 188 zts(:,:,:,:) = 0._wp 187 189 IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN ! i-mean i-k-surface 188 DO jk = 1, jpkm1 189 DO jj = 1, jpj 190 DO ji = 1, jpi 191 zsfc = e1t(ji,jj) * e3t_n(ji,jj,jk) 192 zmask(ji,jj,jk) = tmask(ji,jj,jk) * zsfc 193 zts(ji,jj,jk,jp_tem) = tsn(ji,jj,jk,jp_tem) * zsfc 194 zts(ji,jj,jk,jp_sal) = tsn(ji,jj,jk,jp_sal) * zsfc 195 END DO 196 END DO 197 END DO 190 DO_3D_11_11( 1, jpkm1 ) 191 zsfc = e1t(ji,jj) * e3t(ji,jj,jk,Kmm) 192 zmask(ji,jj,jk) = tmask(ji,jj,jk) * zsfc 193 zts(ji,jj,jk,jp_tem) = ts(ji,jj,jk,jp_tem,Kmm) * zsfc 194 zts(ji,jj,jk,jp_sal) = ts(ji,jj,jk,jp_sal,Kmm) * zsfc 195 END_3D 198 196 ! 199 197 DO jn = 1, nptr … … 280 278 IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN 281 279 zts(:,:,:,:) = 0._wp 282 DO jk = 1, jpkm1 283 DO jj = 1, jpjm1 284 DO ji = 1, jpi 285 zvfc = e1v(ji,jj) * e3v_n(ji,jj,jk) 286 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 287 zts(ji,jj,jk,jp_sal) = (tsn(ji,jj,jk,jp_sal)+tsn(ji,jj+1,jk,jp_sal)) * 0.5 * zvfc 288 ENDDO 289 ENDDO 290 ENDDO 280 DO_3D_10_11( 1, jpkm1 ) 281 zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 282 zts(ji,jj,jk,jp_tem) = (ts(ji,jj,jk,jp_tem,Kmm)+ts(ji,jj+1,jk,jp_tem,Kmm)) * 0.5 * zvfc !Tracers averaged onto V grid 283 zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc 284 END_3D 291 285 CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) ) 292 286 CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) ) … … 326 320 !! ** Purpose : Initialization, namelist read 327 321 !!---------------------------------------------------------------------- 328 INTEGER :: inum, jn, ios, ierr ! local integers 329 !! 330 NAMELIST/namptr/ ln_diaptr, ln_subbas 322 INTEGER :: inum, jn ! local integers 323 !! 331 324 REAL(wp), DIMENSION(jpi,jpj) :: zmsk 332 325 !!---------------------------------------------------------------------- 333 326 334 335 REWIND( numnam_ref ) ! Namelist namptr in reference namelist : Poleward transport 336 READ ( numnam_ref, namptr, IOSTAT = ios, ERR = 901) 337 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in reference namelist' ) 338 339 REWIND( numnam_cfg ) ! Namelist namptr in configuration namelist : Poleward transport 340 READ ( numnam_cfg, namptr, IOSTAT = ios, ERR = 902 ) 341 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in configuration namelist' ) 342 IF(lwm) WRITE ( numond, namptr ) 343 327 l_diaptr = .FALSE. 328 IF( iom_use( 'zomsf' ) .OR. iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. & 329 & iom_use( 'zosrf' ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & 330 & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) .OR. iom_use( 'sophtadv' ) .OR. & 331 & iom_use( 'sopstadv' ) .OR. iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) .OR. & 332 & iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) .OR. iom_use( 'sopstvtr' ) .OR. & 333 & iom_use( 'sophtvtr' ) .OR. iom_use( 'uocetr_vsum_cumul' ) ) l_diaptr = .TRUE. 334 335 344 336 IF(lwp) THEN ! Control print 345 337 WRITE(numout,*) … … 347 339 WRITE(numout,*) '~~~~~~~~~~~~' 348 340 WRITE(numout,*) ' Namelist namptr : set ptr parameters' 349 WRITE(numout,*) ' Poleward heat & salt transport (T) or not (F) l n_diaptr = ', ln_diaptr341 WRITE(numout,*) ' Poleward heat & salt transport (T) or not (F) l_diaptr = ', l_diaptr 350 342 ENDIF 351 343 352 IF( l n_diaptr ) THEN344 IF( l_diaptr ) THEN 353 345 ! 354 346 IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' ) … … 389 381 hstr_vtr(:,:,:) = 0._wp ! 390 382 ! 383 ll_init = .FALSE. 384 ! 391 385 ENDIF 392 386 ! … … 394 388 395 389 396 SUBROUTINE dia_ptr_hst( ktra, cptr, pv a)390 SUBROUTINE dia_ptr_hst( ktra, cptr, pvflx ) 397 391 !!---------------------------------------------------------------------- 398 392 !! *** ROUTINE dia_ptr_hst *** … … 403 397 INTEGER , INTENT(in ) :: ktra ! tracer index 404 398 CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf'/'eiv' 405 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pv a! 3D input array of advection/diffusion399 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pvflx ! 3D input array of advection/diffusion 406 400 INTEGER :: jn ! 407 401 … … 410 404 IF( ktra == jp_tem ) THEN 411 405 DO jn = 1, nptr 412 hstr_adv(:,jp_tem,jn) = ptr_sj( pv a(:,:,:), btmsk(:,:,jn) )406 hstr_adv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 413 407 ENDDO 414 408 ENDIF 415 409 IF( ktra == jp_sal ) THEN 416 410 DO jn = 1, nptr 417 hstr_adv(:,jp_sal,jn) = ptr_sj( pv a(:,:,:), btmsk(:,:,jn) )411 hstr_adv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 418 412 ENDDO 419 413 ENDIF … … 423 417 IF( ktra == jp_tem ) THEN 424 418 DO jn = 1, nptr 425 hstr_ldf(:,jp_tem,jn) = ptr_sj( pv a(:,:,:), btmsk(:,:,jn) )419 hstr_ldf(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 426 420 ENDDO 427 421 ENDIF 428 422 IF( ktra == jp_sal ) THEN 429 423 DO jn = 1, nptr 430 hstr_ldf(:,jp_sal,jn) = ptr_sj( pv a(:,:,:), btmsk(:,:,jn) )424 hstr_ldf(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 431 425 ENDDO 432 426 ENDIF … … 436 430 IF( ktra == jp_tem ) THEN 437 431 DO jn = 1, nptr 438 hstr_eiv(:,jp_tem,jn) = ptr_sj( pv a(:,:,:), btmsk(:,:,jn) )432 hstr_eiv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 439 433 ENDDO 440 434 ENDIF 441 435 IF( ktra == jp_sal ) THEN 442 436 DO jn = 1, nptr 443 hstr_eiv(:,jp_sal,jn) = ptr_sj( pv a(:,:,:), btmsk(:,:,jn) )437 hstr_eiv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 444 438 ENDDO 445 439 ENDIF … … 449 443 IF( ktra == jp_tem ) THEN 450 444 DO jn = 1, nptr 451 hstr_vtr(:,jp_tem,jn) = ptr_sj( pv a(:,:,:), btmsk(:,:,jn) )445 hstr_vtr(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 452 446 ENDDO 453 447 ENDIF 454 448 IF( ktra == jp_sal ) THEN 455 449 DO jn = 1, nptr 456 hstr_vtr(:,jp_sal,jn) = ptr_sj( pv a(:,:,:), btmsk(:,:,jn) )450 hstr_vtr(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 457 451 ENDDO 458 452 ENDIF … … 486 480 487 481 488 FUNCTION ptr_sj_3d( pv a, pmsk ) RESULT ( p_fval )482 FUNCTION ptr_sj_3d( pvflx, pmsk ) RESULT ( p_fval ) 489 483 !!---------------------------------------------------------------------- 490 484 !! *** ROUTINE ptr_sj_3d *** … … 492 486 !! ** Purpose : i-k sum computation of a j-flux array 493 487 !! 494 !! ** Method : - i-k sum of pv ausing the interior 2D vmask (vmask_i).495 !! pv ais supposed to be a masked flux (i.e. * vmask*e1v*e3v)496 !! 497 !! ** Action : - p_fval: i-k-mean poleward flux of pv a498 !!---------------------------------------------------------------------- 499 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pv a! mask flux array at V-point488 !! ** Method : - i-k sum of pvflx using the interior 2D vmask (vmask_i). 489 !! pvflx is supposed to be a masked flux (i.e. * vmask*e1v*e3v) 490 !! 491 !! ** Action : - p_fval: i-k-mean poleward flux of pvflx 492 !!---------------------------------------------------------------------- 493 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pvflx ! mask flux array at V-point 500 494 REAL(wp), INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 501 495 ! … … 509 503 ijpj = jpj 510 504 p_fval(:) = 0._wp 511 DO jk = 1, jpkm1 512 DO jj = 2, jpjm1 513 DO ji = fs_2, fs_jpim1 ! Vector opt. 514 p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 515 END DO 516 END DO 517 END DO 505 DO_3D_00_00( 1, jpkm1 ) 506 p_fval(jj) = p_fval(jj) + pvflx(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 507 END_3D 518 508 #if defined key_mpp_mpi 519 509 CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl) … … 523 513 524 514 525 FUNCTION ptr_sj_2d( pv a, pmsk ) RESULT ( p_fval )515 FUNCTION ptr_sj_2d( pvflx, pmsk ) RESULT ( p_fval ) 526 516 !!---------------------------------------------------------------------- 527 517 !! *** ROUTINE ptr_sj_2d *** 528 518 !! 529 !! ** Purpose : "zonal" and vertical sum computation of a i-flux array530 !! 531 !! ** Method : - i-k sum of pv ausing the interior 2D vmask (vmask_i).532 !! pv ais supposed to be a masked flux (i.e. * vmask*e1v*e3v)533 !! 534 !! ** Action : - p_fval: i-k-mean poleward flux of pv a535 !!---------------------------------------------------------------------- 536 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pv a! mask flux array at V-point519 !! ** Purpose : "zonal" and vertical sum computation of a j-flux array 520 !! 521 !! ** Method : - i-k sum of pvflx using the interior 2D vmask (vmask_i). 522 !! pvflx is supposed to be a masked flux (i.e. * vmask*e1v*e3v) 523 !! 524 !! ** Action : - p_fval: i-k-mean poleward flux of pvflx 525 !!---------------------------------------------------------------------- 526 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pvflx ! mask flux array at V-point 537 527 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 538 528 ! … … 546 536 ijpj = jpj 547 537 p_fval(:) = 0._wp 548 DO jj = 2, jpjm1 549 DO ji = fs_2, fs_jpim1 ! Vector opt. 550 p_fval(jj) = p_fval(jj) + pva(ji,jj) * pmsk(ji,jj) * tmask_i(ji,jj) 551 END DO 552 END DO 538 DO_2D_00_00 539 p_fval(jj) = p_fval(jj) + pvflx(ji,jj) * pmsk(ji,jj) * tmask_i(ji,jj) 540 END_2D 553 541 #if defined key_mpp_mpi 554 542 CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl ) … … 577 565 p_fval(:,:) = 0._wp 578 566 DO jc = 1, jpnj ! looping over all processors in j axis 579 DO jj = 2, jpjm1 580 DO ji = fs_2, fs_jpim1 ! Vector opt. 581 p_fval(ji,jj) = p_fval(ji,jj-1) + pva(ji,jj) * tmask_i(ji,jj) 582 END DO 583 END DO 567 DO_2D_00_00 568 p_fval(ji,jj) = p_fval(ji,jj-1) + pva(ji,jj) * tmask_i(ji,jj) 569 END_2D 584 570 CALL lbc_lnk( 'diaptr', p_fval, 'U', -1. ) 585 571 END DO … … 595 581 !! ** Purpose : i-sum computation of an array 596 582 !! 597 !! ** Method : - i-sum of pva using the interior 2D vmask (vmask_i).598 !! 599 !! ** Action : - p_fval: i- mean poleward flux of pva583 !! ** Method : - i-sum of field using the interior 2D vmask (pmsk). 584 !! 585 !! ** Action : - p_fval: i-sum of masked field 600 586 !!---------------------------------------------------------------------- 601 587 !! … … 618 604 p_fval(:,:) = 0._wp 619 605 ! 620 DO jk = 1, jpkm1 621 DO jj = 2, jpjm1 622 DO ji = fs_2, fs_jpim1 ! Vector opt. 623 p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 624 END DO 625 END DO 626 END DO 606 DO_3D_00_00( 1, jpkm1 ) 607 p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 608 END_3D 627 609 ! 628 610 #if defined key_mpp_mpi
Note: See TracChangeset
for help on using the changeset viewer.