Changeset 10965 for NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DIA/diaptr.F90
- Timestamp:
- 2019-05-10T18:02:51+02:00 (5 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DIA/diaptr.F90
r10425 r10965 71 71 CONTAINS 72 72 73 SUBROUTINE dia_ptr( pvtr )73 SUBROUTINE dia_ptr( Kmm, pvtr ) 74 74 !!---------------------------------------------------------------------- 75 75 !! *** ROUTINE dia_ptr *** 76 76 !!---------------------------------------------------------------------- 77 INTEGER , INTENT(in) :: Kmm ! time level index 77 78 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport 78 79 ! … … 90 91 REAL(wp), DIMENSION(jpj,jpk,nptr) :: sjk , r1_sjk ! i-mean i-k-surface and its inverse 91 92 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) :: zv n! 3D workspace93 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zvv ! 3D workspace 93 94 94 95 … … 126 127 zmask(:,:,:) = 0._wp 127 128 zts(:,:,:,:) = 0._wp 128 zv n(:,:,:) = 0._wp129 zvv(:,:,:) = 0._wp 129 130 DO jk = 1, jpkm1 130 131 DO jj = 1, jpjm1 131 132 DO ji = 1, jpi 132 zvfc = e1v(ji,jj) * e3v _n(ji,jj,jk)133 zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 133 134 zmask(ji,jj,jk) = vmask(ji,jj,jk) * zvfc 134 zts(ji,jj,jk,jp_tem) = (ts n(ji,jj,jk,jp_tem)+tsn(ji,jj+1,jk,jp_tem)) * 0.5 * zvfc !Tracers averaged onto V grid135 zts(ji,jj,jk,jp_sal) = (ts n(ji,jj,jk,jp_sal)+tsn(ji,jj+1,jk,jp_sal)) * 0.5 * zvfc136 zv n(ji,jj,jk) = vn(ji,jj,jk) * zvfc135 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 136 zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc 137 zvv(ji,jj,jk) = vv(ji,jj,jk,Kmm) * zvfc 137 138 ENDDO 138 139 ENDDO … … 147 148 tn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_tem) ) * r1_sjk(:,:,1) 148 149 sn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_sal) ) * r1_sjk(:,:,1) 149 v_msf(:,:,1) = ptr_sjk( zv n(:,:,:) )150 v_msf(:,:,1) = ptr_sjk( zvv(:,:,:) ) 150 151 151 152 htr_ove(:,1) = SUM( v_msf(:,:,1)*tn_jk(:,:,1) ,2 ) … … 173 174 tn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 174 175 sn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 175 v_msf(:,:,jn) = ptr_sjk( zv n(:,:,:), btmsk(:,:,jn) )176 v_msf(:,:,jn) = ptr_sjk( zvv(:,:,:), btmsk(:,:,jn) ) 176 177 htr_ove(:,jn) = SUM( v_msf(:,:,jn)*tn_jk(:,:,jn) ,2 ) 177 178 str_ove(:,jn) = SUM( v_msf(:,:,jn)*sn_jk(:,:,jn) ,2 ) … … 198 199 WHERE( sjk(:,1,1) /= 0._wp ) r1_sjk(:,1,1) = 1._wp / sjk(:,1,1) 199 200 200 vsum = ptr_sj( zv n(:,:,:), btmsk(:,:,1))201 vsum = ptr_sj( zvv(:,:,:), btmsk(:,:,1)) 201 202 tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,1) ) 202 203 tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,1) ) … … 220 221 r1_sjk(:,1,jn) = 0._wp 221 222 WHERE( sjk(:,1,jn) /= 0._wp ) r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn) 222 vsum = ptr_sj( zv n(:,:,:), btmsk(:,:,jn))223 vsum = ptr_sj( zvv(:,:,:), btmsk(:,:,jn)) 223 224 tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 224 225 tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) … … 247 248 DO jj = 1, jpj 248 249 DO ji = 1, jpi 249 zsfc = e1t(ji,jj) * e3t _n(ji,jj,jk)250 zsfc = e1t(ji,jj) * e3t(ji,jj,jk,Kmm) 250 251 zmask(ji,jj,jk) = tmask(ji,jj,jk) * zsfc 251 zts(ji,jj,jk,jp_tem) = ts n(ji,jj,jk,jp_tem) * zsfc252 zts(ji,jj,jk,jp_sal) = ts n(ji,jj,jk,jp_sal) * zsfc252 zts(ji,jj,jk,jp_tem) = ts(ji,jj,jk,jp_tem,Kmm) * zsfc 253 zts(ji,jj,jk,jp_sal) = ts(ji,jj,jk,jp_sal,Kmm) * zsfc 253 254 END DO 254 255 END DO … … 459 460 460 461 461 SUBROUTINE dia_ptr_hst( ktra, cptr, pv a)462 SUBROUTINE dia_ptr_hst( ktra, cptr, pvflx ) 462 463 !!---------------------------------------------------------------------- 463 464 !! *** ROUTINE dia_ptr_hst *** … … 468 469 INTEGER , INTENT(in ) :: ktra ! tracer index 469 470 CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf'/'eiv' 470 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pv a! 3D input array of advection/diffusion471 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pvflx ! 3D input array of advection/diffusion 471 472 INTEGER :: jn ! 472 473 473 474 IF( cptr == 'adv' ) THEN 474 IF( ktra == jp_tem ) htr_adv(:,1) = ptr_sj( pv a(:,:,:))475 IF( ktra == jp_sal ) str_adv(:,1) = ptr_sj( pv a(:,:,:))475 IF( ktra == jp_tem ) htr_adv(:,1) = ptr_sj( pvflx ) 476 IF( ktra == jp_sal ) str_adv(:,1) = ptr_sj( pvflx ) 476 477 ENDIF 477 478 IF( cptr == 'ldf' ) THEN 478 IF( ktra == jp_tem ) htr_ldf(:,1) = ptr_sj( pv a(:,:,:))479 IF( ktra == jp_sal ) str_ldf(:,1) = ptr_sj( pv a(:,:,:))479 IF( ktra == jp_tem ) htr_ldf(:,1) = ptr_sj( pvflx ) 480 IF( ktra == jp_sal ) str_ldf(:,1) = ptr_sj( pvflx ) 480 481 ENDIF 481 482 IF( cptr == 'eiv' ) THEN 482 IF( ktra == jp_tem ) htr_eiv(:,1) = ptr_sj( pv a(:,:,:))483 IF( ktra == jp_sal ) str_eiv(:,1) = ptr_sj( pv a(:,:,:))483 IF( ktra == jp_tem ) htr_eiv(:,1) = ptr_sj( pvflx ) 484 IF( ktra == jp_sal ) str_eiv(:,1) = ptr_sj( pvflx ) 484 485 ENDIF 485 486 ! … … 489 490 IF( ktra == jp_tem ) THEN 490 491 DO jn = 2, nptr 491 htr_adv(:,jn) = ptr_sj( pv a(:,:,:), btmsk(:,:,jn) )492 htr_adv(:,jn) = ptr_sj( pvflx, btmsk(:,:,jn) ) 492 493 END DO 493 494 ENDIF 494 495 IF( ktra == jp_sal ) THEN 495 496 DO jn = 2, nptr 496 str_adv(:,jn) = ptr_sj( pv a(:,:,:), btmsk(:,:,jn) )497 str_adv(:,jn) = ptr_sj( pvflx, btmsk(:,:,jn) ) 497 498 END DO 498 499 ENDIF … … 501 502 IF( ktra == jp_tem ) THEN 502 503 DO jn = 2, nptr 503 htr_ldf(:,jn) = ptr_sj( pv a(:,:,:), btmsk(:,:,jn) )504 htr_ldf(:,jn) = ptr_sj( pvflx, btmsk(:,:,jn) ) 504 505 END DO 505 506 ENDIF 506 507 IF( ktra == jp_sal ) THEN 507 508 DO jn = 2, nptr 508 str_ldf(:,jn) = ptr_sj( pv a(:,:,:), btmsk(:,:,jn) )509 str_ldf(:,jn) = ptr_sj( pvflx, btmsk(:,:,jn) ) 509 510 END DO 510 511 ENDIF … … 513 514 IF( ktra == jp_tem ) THEN 514 515 DO jn = 2, nptr 515 htr_eiv(:,jn) = ptr_sj( pv a(:,:,:), btmsk(:,:,jn) )516 htr_eiv(:,jn) = ptr_sj( pvflx, btmsk(:,:,jn) ) 516 517 END DO 517 518 ENDIF 518 519 IF( ktra == jp_sal ) THEN 519 520 DO jn = 2, nptr 520 str_eiv(:,jn) = ptr_sj( pv a(:,:,:), btmsk(:,:,jn) )521 str_eiv(:,jn) = ptr_sj( pvflx, btmsk(:,:,jn) ) 521 522 END DO 522 523 ENDIF … … 554 555 555 556 556 FUNCTION ptr_sj_3d( pv a, pmsk ) RESULT ( p_fval )557 FUNCTION ptr_sj_3d( pvflx, pmsk ) RESULT ( p_fval ) 557 558 !!---------------------------------------------------------------------- 558 559 !! *** ROUTINE ptr_sj_3d *** … … 560 561 !! ** Purpose : i-k sum computation of a j-flux array 561 562 !! 562 !! ** Method : - i-k sum of pv ausing the interior 2D vmask (vmask_i).563 !! pv ais supposed to be a masked flux (i.e. * vmask*e1v*e3v)564 !! 565 !! ** Action : - p_fval: i-k-mean poleward flux of pv a566 !!---------------------------------------------------------------------- 567 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pv a! mask flux array at V-point563 !! ** Method : - i-k sum of pvflx using the interior 2D vmask (vmask_i). 564 !! pvflx is supposed to be a masked flux (i.e. * vmask*e1v*e3v) 565 !! 566 !! ** Action : - p_fval: i-k-mean poleward flux of pvflx 567 !!---------------------------------------------------------------------- 568 REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pvflx ! mask flux array at V-point 568 569 REAL(wp), INTENT(in), DIMENSION(jpi,jpj), OPTIONAL :: pmsk ! Optional 2D basin mask 569 570 ! … … 581 582 DO jj = 2, jpjm1 582 583 DO ji = fs_2, fs_jpim1 ! Vector opt. 583 p_fval(jj) = p_fval(jj) + pv a(ji,jj,jk) * tmask_i(ji,jj) * pmsk(ji,jj)584 p_fval(jj) = p_fval(jj) + pvflx(ji,jj,jk) * tmask_i(ji,jj) * pmsk(ji,jj) 584 585 END DO 585 586 END DO … … 589 590 DO jj = 2, jpjm1 590 591 DO ji = fs_2, fs_jpim1 ! Vector opt. 591 p_fval(jj) = p_fval(jj) + pv a(ji,jj,jk) * tmask_i(ji,jj)592 p_fval(jj) = p_fval(jj) + pvflx(ji,jj,jk) * tmask_i(ji,jj) 592 593 END DO 593 594 END DO … … 601 602 602 603 603 FUNCTION ptr_sj_2d( pv a, pmsk ) RESULT ( p_fval )604 FUNCTION ptr_sj_2d( pvflx, pmsk ) RESULT ( p_fval ) 604 605 !!---------------------------------------------------------------------- 605 606 !! *** ROUTINE ptr_sj_2d *** 606 607 !! 607 !! ** Purpose : "zonal" and vertical sum computation of a i-flux array608 !! 609 !! ** Method : - i-k sum of pv ausing the interior 2D vmask (vmask_i).610 !! pv ais supposed to be a masked flux (i.e. * vmask*e1v*e3v)611 !! 612 !! ** Action : - p_fval: i-k-mean poleward flux of pv a613 !!---------------------------------------------------------------------- 614 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pv a! mask flux array at V-point608 !! ** Purpose : "zonal" and vertical sum computation of a j-flux array 609 !! 610 !! ** Method : - i-k sum of pvflx using the interior 2D vmask (vmask_i). 611 !! pvflx is supposed to be a masked flux (i.e. * vmask*e1v*e3v) 612 !! 613 !! ** Action : - p_fval: i-k-mean poleward flux of pvflx 614 !!---------------------------------------------------------------------- 615 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pvflx ! mask flux array at V-point 615 616 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj), OPTIONAL :: pmsk ! Optional 2D basin mask 616 617 ! … … 627 628 DO jj = 2, jpjm1 628 629 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 629 p_fval(jj) = p_fval(jj) + pv a(ji,jj) * tmask_i(ji,jj) * pmsk(ji,jj)630 p_fval(jj) = p_fval(jj) + pvflx(ji,jj) * tmask_i(ji,jj) * pmsk(ji,jj) 630 631 END DO 631 632 END DO … … 633 634 DO jj = 2, jpjm1 634 635 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 635 p_fval(jj) = p_fval(jj) + pv a(ji,jj) * tmask_i(ji,jj)636 p_fval(jj) = p_fval(jj) + pvflx(ji,jj) * tmask_i(ji,jj) 636 637 END DO 637 638 END DO … … 644 645 645 646 646 FUNCTION ptr_sjk( p ta, pmsk ) RESULT ( p_fval )647 FUNCTION ptr_sjk( pfld, pmsk ) RESULT ( p_fval ) 647 648 !!---------------------------------------------------------------------- 648 649 !! *** ROUTINE ptr_sjk *** … … 650 651 !! ** Purpose : i-sum computation of an array 651 652 !! 652 !! ** Method : - i-sum of pva using the interior 2D vmask (vmask_i).653 !! 654 !! ** Action : - p_fval: i- mean poleward flux of pva653 !! ** Method : - i-sum of field using the interior 2D vmask (pmsk). 654 !! 655 !! ** Action : - p_fval: i-sum of masked field 655 656 !!---------------------------------------------------------------------- 656 657 !! 657 658 IMPLICIT none 658 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: p ta ! mask flux array at V-point659 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pfld ! input field to be summed 659 660 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) , OPTIONAL :: pmsk ! Optional 2D basin mask 660 661 !! … … 678 679 !!gm here, use of tmask_i ==> no need of loop over nldi, nlei.... 679 680 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 680 p_fval(jj,jk) = p_fval(jj,jk) + p ta(ji,jj,jk) * pmsk(ji,jj)681 p_fval(jj,jk) = p_fval(jj,jk) + pfld(ji,jj,jk) * pmsk(ji,jj) 681 682 END DO 682 683 END DO … … 686 687 DO jj = 2, jpjm1 687 688 DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ? 688 p_fval(jj,jk) = p_fval(jj,jk) + p ta(ji,jj,jk) * tmask_i(ji,jj)689 p_fval(jj,jk) = p_fval(jj,jk) + pfld(ji,jj,jk) * tmask_i(ji,jj) 689 690 END DO 690 691 END DO
Note: See TracChangeset
for help on using the changeset viewer.
