New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 14023 – NEMO

Changeset 14023


Ignore:
Timestamp:
2020-12-03T09:07:27+01:00 (4 years ago)
Author:
techene
Message:

#2385 problem : branch updated with trunk 13986

Location:
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3
Files:
61 edited
6 copied

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3

    • Property svn:externals

      •  

        old new  
        88 
        99# SETTE 
        10 ^/utils/CI/sette@13795        sette 
         10^/utils/CI/sette_MPI3_LoopFusion@13943         sette 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/cfgs/SHARED/namelist_ref

    r13998 r14023  
    9494   ln_use_jattr = .false.    !  use (T) the file attribute: open_ocean_jstart, if present 
    9595   !                         !  in netcdf input files, as the start j-row for reading 
     96/ 
     97!----------------------------------------------------------------------- 
     98&namtile        !   parameters of the tiling 
     99!----------------------------------------------------------------------- 
     100   ln_tile = .false.     !  Use tiling (T) or not (F) 
     101   nn_ltile_i = 10       !  Length of tiles in i 
     102   nn_ltile_j = 10       !  Length of tiles in j 
    96103/ 
    97104!----------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/ICE/icedyn_rhg_evp.F90

    r14018 r14023  
    199199         zfmask(ji,jj) = tmask(ji,jj,1) * tmask(ji+1,jj,1) * tmask(ji,jj+1,1) * tmask(ji+1,jj+1,1) 
    200200      END_2D 
    201       CALL lbc_lnk( 'icedyn_rhg_evp', zfmask, 'F', 1._wp ) 
     201      CALL lbc_lnk( 'icedyn_rhg_evp', zfmask, 'F', 1._wp) 
    202202 
    203203      ! Lateral boundary conditions on velocity (modify zfmask) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ASM/asminc.F90

    r13295 r14023  
    2626   USE par_oce         ! Ocean space and time domain variables 
    2727   USE dom_oce         ! Ocean space and time domain 
     28   USE domain, ONLY : dom_tile 
    2829   USE domvvl          ! domain: variable volume level 
    2930   USE ldfdyn          ! lateral diffusion: eddy viscosity coefficients 
    … …  
    518519      ! 
    519520      INTEGER  :: ji, jj, jk 
    520       INTEGER  :: it 
     521      INTEGER  :: it, itile 
    521522      REAL(wp) :: zincwgt  ! IAU weight for current time step 
    522       REAL (wp), DIMENSION(jpi,jpj,jpk) :: fzptnz ! 3d freezing point values 
     523      REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: fzptnz ! 3d freezing point values 
    523524      !!---------------------------------------------------------------------- 
    524525      ! 
    525526      ! freezing point calculation taken from oc_fz_pt (but calculated for all depths)  
    526527      ! used to prevent the applied increments taking the temperature below the local freezing point  
    527       DO jk = 1, jpkm1 
    528         CALL eos_fzp( pts(:,:,jk,jp_sal,Kmm), fzptnz(:,:,jk), gdept(:,:,jk,Kmm) ) 
    529       END DO 
     528      IF( ln_temnofreeze ) THEN 
     529         DO jk = 1, jpkm1 
     530           CALL eos_fzp( pts(:,:,jk,jp_sal,Kmm), fzptnz(:,:,jk), gdept(:,:,jk,Kmm) ) 
     531         END DO 
     532      ENDIF 
    530533         ! 
    531534         !                             !-------------------------------------- 
    … …  
    538541            zincwgt = wgtiau(it) / rn_Dt   ! IAU weight for the current time step 
    539542            ! 
    540             IF(lwp) THEN 
    541                WRITE(numout,*)  
    542                WRITE(numout,*) 'tra_asm_inc : Tracer IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) 
    543                WRITE(numout,*) '~~~~~~~~~~~~' 
     543            IF( ntile == 0 .OR. ntile == 1 )  THEN                       ! Do only on the first tile 
     544               IF(lwp) THEN 
     545                  WRITE(numout,*) 
     546                  WRITE(numout,*) 'tra_asm_inc : Tracer IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) 
     547                  WRITE(numout,*) '~~~~~~~~~~~~' 
     548               ENDIF 
    544549            ENDIF 
    545550            ! 
    … …  
    548553               IF (ln_temnofreeze) THEN 
    549554                  ! Do not apply negative increments if the temperature will fall below freezing 
    550                   WHERE(t_bkginc(:,:,jk) > 0.0_wp .OR. & 
    551                      &   pts(:,:,jk,jp_tem,Kmm) + pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * wgtiau(it) > fzptnz(:,:,jk) )  
    552                      pts(:,:,jk,jp_tem,Krhs) = pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * zincwgt   
     555                  WHERE(t_bkginc(A2D(0),jk) > 0.0_wp .OR. & 
     556                     &   pts(A2D(0),jk,jp_tem,Kmm) + pts(A2D(0),jk,jp_tem,Krhs) + t_bkginc(A2D(0),jk) * wgtiau(it) > fzptnz(:,:,jk) ) 
     557                     pts(A2D(0),jk,jp_tem,Krhs) = pts(A2D(0),jk,jp_tem,Krhs) + t_bkginc(A2D(0),jk) * zincwgt 
    553558                  END WHERE 
    554559               ELSE 
    555                   pts(:,:,jk,jp_tem,Krhs) = pts(:,:,jk,jp_tem,Krhs) + t_bkginc(:,:,jk) * zincwgt   
     560                  DO_2D( 0, 0, 0, 0 ) 
     561                     pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) + t_bkginc(ji,jj,jk) * zincwgt 
     562                  END_2D 
    556563               ENDIF 
    557564               IF (ln_salfix) THEN 
    558565                  ! Do not apply negative increments if the salinity will fall below a specified 
    559566                  ! minimum value salfixmin 
    560                   WHERE(s_bkginc(:,:,jk) > 0.0_wp .OR. & 
    561                      &   pts(:,:,jk,jp_sal,Kmm) + pts(:,:,jk,jp_sal,Krhs) + s_bkginc(:,:,jk) * wgtiau(it) > salfixmin )  
    562                      pts(:,:,jk,jp_sal,Krhs) = pts(:,:,jk,jp_sal,Krhs) + s_bkginc(:,:,jk) * zincwgt 
     567                  WHERE(s_bkginc(A2D(0),jk) > 0.0_wp .OR. & 
     568                     &   pts(A2D(0),jk,jp_sal,Kmm) + pts(A2D(0),jk,jp_sal,Krhs) + s_bkginc(A2D(0),jk) * wgtiau(it) > salfixmin ) 
     569                     pts(A2D(0),jk,jp_sal,Krhs) = pts(A2D(0),jk,jp_sal,Krhs) + s_bkginc(A2D(0),jk) * zincwgt 
    563570                  END WHERE 
    564571               ELSE 
    565                   pts(:,:,jk,jp_sal,Krhs) = pts(:,:,jk,jp_sal,Krhs) + s_bkginc(:,:,jk) * zincwgt 
     572                  DO_2D( 0, 0, 0, 0 ) 
     573                     pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs) + s_bkginc(ji,jj,jk) * zincwgt 
     574                  END_2D 
    566575               ENDIF 
    567576            END DO 
    … …  
    569578         ENDIF 
    570579         ! 
    571          IF ( kt == nitiaufin_r + 1  ) THEN   ! For bias crcn to work 
    572             DEALLOCATE( t_bkginc ) 
    573             DEALLOCATE( s_bkginc ) 
     580         IF( ntile == 0 .OR. ntile == nijtile )  THEN                ! Do only on the last tile 
     581            IF ( kt == nitiaufin_r + 1  ) THEN   ! For bias crcn to work 
     582               DEALLOCATE( t_bkginc ) 
     583               DEALLOCATE( s_bkginc ) 
     584            ENDIF 
    574585         ENDIF 
    575586         !                             !-------------------------------------- 
    … …  
    584595            IF (ln_temnofreeze) THEN 
    585596               ! Do not apply negative increments if the temperature will fall below freezing 
    586                WHERE( t_bkginc(:,:,:) > 0.0_wp .OR. pts(:,:,:,jp_tem,Kmm) + t_bkginc(:,:,:) > fzptnz(:,:,:) )  
    587                   pts(:,:,:,jp_tem,Kmm) = t_bkg(:,:,:) + t_bkginc(:,:,:)    
     597               WHERE( t_bkginc(A2D(0),:) > 0.0_wp .OR. pts(A2D(0),:,jp_tem,Kmm) + t_bkginc(A2D(0),:) > fzptnz(:,:,:) ) 
     598                  pts(A2D(0),:,jp_tem,Kmm) = t_bkg(A2D(0),:) + t_bkginc(A2D(0),:) 
    588599               END WHERE 
    589600            ELSE 
    590                pts(:,:,:,jp_tem,Kmm) = t_bkg(:,:,:) + t_bkginc(:,:,:)    
     601               DO_3D( 0, 0, 0, 0, 1, jpk ) 
     602                  pts(ji,jj,jk,jp_tem,Kmm) = t_bkg(ji,jj,jk) + t_bkginc(ji,jj,jk) 
     603               END_3D 
    591604            ENDIF 
    592605            IF (ln_salfix) THEN 
    593606               ! Do not apply negative increments if the salinity will fall below a specified 
    594607               ! minimum value salfixmin 
    595                WHERE( s_bkginc(:,:,:) > 0.0_wp .OR. pts(:,:,:,jp_sal,Kmm) + s_bkginc(:,:,:) > salfixmin )  
    596                   pts(:,:,:,jp_sal,Kmm) = s_bkg(:,:,:) + s_bkginc(:,:,:)    
     608               WHERE( s_bkginc(A2D(0),:) > 0.0_wp .OR. pts(A2D(0),:,jp_sal,Kmm) + s_bkginc(A2D(0),:) > salfixmin ) 
     609                  pts(A2D(0),:,jp_sal,Kmm) = s_bkg(A2D(0),:) + s_bkginc(A2D(0),:) 
    597610               END WHERE 
    598611            ELSE 
    599                pts(:,:,:,jp_sal,Kmm) = s_bkg(:,:,:) + s_bkginc(:,:,:)    
    600             ENDIF 
    601  
    602             pts(:,:,:,:,Kbb) = pts(:,:,:,:,Kmm)                 ! Update before fields 
     612               DO_3D( 0, 0, 0, 0, 1, jpk ) 
     613                  pts(ji,jj,jk,jp_sal,Kmm) = s_bkg(ji,jj,jk) + s_bkginc(ji,jj,jk) 
     614               END_3D 
     615            ENDIF 
     616 
     617            DO_3D( 0, 0, 0, 0, 1, jpk ) 
     618               pts(ji,jj,jk,:,Kbb) = pts(ji,jj,jk,:,Kmm)             ! Update before fields 
     619            END_3D 
    603620 
    604621            CALL eos( pts(:,:,:,:,Kbb), rhd, rhop, gdept_0(:,:,:) )  ! Before potential and in situ densities 
    … …  
    607624!!gm 
    608625 
    609             IF( ln_zps .AND. .NOT. lk_c1d .AND. .NOT. ln_isfcav)           & 
    610                &  CALL zps_hde    ( kt, Kmm, jpts, pts(:,:,:,:,Kbb), gtsu, gtsv,        &  ! Partial steps: before horizontal gradient 
    611                &                              rhd, gru , grv               )  ! of t, s, rd at the last ocean level 
    612             IF( ln_zps .AND. .NOT. lk_c1d .AND.       ln_isfcav)                       & 
    613                &  CALL zps_hde_isf( nit000, Kmm, jpts, pts(:,:,:,:,Kbb), gtsu, gtsv, gtui, gtvi,    &  ! Partial steps for top cell (ISF) 
    614                &                                  rhd, gru , grv , grui, grvi          )  ! of t, s, rd at the last ocean level 
    615  
    616             DEALLOCATE( t_bkginc ) 
    617             DEALLOCATE( s_bkginc ) 
    618             DEALLOCATE( t_bkg    ) 
    619             DEALLOCATE( s_bkg    ) 
     626            ! TEMP: [tiling] This change not necessary after extra haloes development (lbc_lnk removed from zps_hde*) 
     627            IF( ntile == 0 .OR. ntile == nijtile )  THEN                ! Do only for the full domain 
     628               itile = ntile 
     629               IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 )            ! Use full domain 
     630 
     631               IF( ln_zps .AND. .NOT. lk_c1d .AND. .NOT. ln_isfcav)           & 
     632                  &  CALL zps_hde    ( kt, Kmm, jpts, pts(:,:,:,:,Kbb), gtsu, gtsv,        &  ! Partial steps: before horizontal gradient 
     633                  &                              rhd, gru , grv               )  ! of t, s, rd at the last ocean level 
     634               IF( ln_zps .AND. .NOT. lk_c1d .AND.       ln_isfcav)                       & 
     635                  &  CALL zps_hde_isf( nit000, Kmm, jpts, pts(:,:,:,:,Kbb), gtsu, gtsv, gtui, gtvi,    &  ! Partial steps for top cell (ISF) 
     636                  &                                  rhd, gru , grv , grui, grvi          )  ! of t, s, rd at the last ocean level 
     637 
     638               IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = itile )            ! Revert to tile domain 
     639            ENDIF 
     640 
     641            IF( ntile == 0 .OR. ntile == nijtile )  THEN                ! Do only on the last tile 
     642               DEALLOCATE( t_bkginc ) 
     643               DEALLOCATE( s_bkginc ) 
     644               DEALLOCATE( t_bkg    ) 
     645               DEALLOCATE( s_bkg    ) 
     646            ENDIF 
     647         ! 
    620648         ENDIF 
    621649         !   
    … …  
    829857      INTEGER, INTENT(in), OPTIONAL ::   kindic   ! flag for disabling the deallocation 
    830858      ! 
     859      INTEGER  ::   ji, jj 
    831860      INTEGER  ::   it 
    832861      REAL(wp) ::   zincwgt   ! IAU weight for current time step 
    833862#if defined key_si3 
    834       REAL(wp), DIMENSION(jpi,jpj) ::   zofrld, zohicif, zseaicendg, zhicifinc 
     863      REAL(wp), DIMENSION(A2D(nn_hls)) ::   zofrld, zohicif, zseaicendg, zhicifinc 
    835864      REAL(wp) ::   zhicifmin = 0.5_wp      ! ice minimum depth in metres 
    836865#endif 
    … …  
    847876            ! note this is not a tendency so should not be divided by rn_Dt (as with the tracer and other increments) 
    848877            ! 
    849             IF(lwp) THEN 
    850                WRITE(numout,*)  
    851                WRITE(numout,*) 'seaice_asm_inc : sea ice conc IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) 
    852                WRITE(numout,*) '~~~~~~~~~~~~' 
     878            IF( ntile == 0 .OR. ntile == 1 )  THEN                       ! Do only on the first tile 
     879               IF(lwp) THEN 
     880                  WRITE(numout,*) 
     881                  WRITE(numout,*) 'seaice_asm_inc : sea ice conc IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) 
     882                  WRITE(numout,*) '~~~~~~~~~~~~' 
     883               ENDIF 
    853884            ENDIF 
    854885            ! 
    … …  
    856887            ! 
    857888#if defined key_si3 
    858             zofrld (:,:) = 1._wp - at_i(:,:) 
    859             zohicif(:,:) = hm_i(:,:) 
    860             ! 
    861             at_i  (:,:) = 1. - MIN( MAX( 1.-at_i  (:,:) - seaice_bkginc(:,:) * zincwgt, 0.0_wp), 1.0_wp) 
    862             at_i_b(:,:) = 1. - MIN( MAX( 1.-at_i_b(:,:) - seaice_bkginc(:,:) * zincwgt, 0.0_wp), 1.0_wp) 
    863             fr_i(:,:) = at_i(:,:)        ! adjust ice fraction 
    864             ! 
    865             zseaicendg(:,:) = zofrld(:,:) - (1. - at_i(:,:))   ! find out actual sea ice nudge applied 
     889            DO_2D( 0, 0, 0, 0 ) 
     890               zofrld (ji,jj) = 1._wp - at_i(ji,jj) 
     891               zohicif(ji,jj) = hm_i(ji,jj) 
     892               ! 
     893               at_i  (ji,jj) = 1. - MIN( MAX( 1.-at_i  (ji,jj) - seaice_bkginc(ji,jj) * zincwgt, 0.0_wp), 1.0_wp) 
     894               at_i_b(ji,jj) = 1. - MIN( MAX( 1.-at_i_b(ji,jj) - seaice_bkginc(ji,jj) * zincwgt, 0.0_wp), 1.0_wp) 
     895               fr_i(ji,jj) = at_i(ji,jj)        ! adjust ice fraction 
     896               ! 
     897               zseaicendg(ji,jj) = zofrld(ji,jj) - (1. - at_i(ji,jj))   ! find out actual sea ice nudge applied 
     898            END_2D 
    866899            ! 
    867900            ! Nudge sea ice depth to bring it up to a required minimum depth 
    868             WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(:,:) < zhicifmin )  
    869                zhicifinc(:,:) = (zhicifmin - hm_i(:,:)) * zincwgt     
     901            WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(A2D(0)) < zhicifmin ) 
     902               zhicifinc(:,:) = (zhicifmin - hm_i(A2D(0))) * zincwgt 
    870903            ELSEWHERE 
    871904               zhicifinc(:,:) = 0.0_wp 
    … …  
    873906            ! 
    874907            ! nudge ice depth 
    875             hm_i (:,:) = hm_i (:,:) + zhicifinc(:,:) 
     908            DO_2D( 0, 0, 0, 0 ) 
     909               hm_i (ji,jj) = hm_i (ji,jj) + zhicifinc(ji,jj) 
     910            END_2D 
    876911            ! 
    877912            ! seaice salinity balancing (to add) 
    … …  
    880915#if defined key_cice && defined key_asminc 
    881916            ! Sea-ice : CICE case. Pass ice increment tendency into CICE 
    882             ndaice_da(:,:) = seaice_bkginc(:,:) * zincwgt / rn_Dt 
    883 #endif 
    884             ! 
    885             IF ( kt == nitiaufin_r ) THEN 
    886                DEALLOCATE( seaice_bkginc ) 
     917            DO_2D( 0, 0, 0, 0 ) 
     918               ndaice_da(ji,jj) = seaice_bkginc(ji,jj) * zincwgt / rn_Dt 
     919            END_2D 
     920#endif 
     921            ! 
     922            IF( ntile == 0 .OR. ntile == nijtile )  THEN                ! Do only on the last tile 
     923               IF ( kt == nitiaufin_r ) THEN 
     924                  DEALLOCATE( seaice_bkginc ) 
     925               ENDIF 
    887926            ENDIF 
    888927            ! 
    … …  
    890929            ! 
    891930#if defined key_cice && defined key_asminc 
    892             ndaice_da(:,:) = 0._wp        ! Sea-ice : CICE case. Zero ice increment tendency into CICE 
     931            DO_2D( 0, 0, 0, 0 ) 
     932               ndaice_da(ji,jj) = 0._wp        ! Sea-ice : CICE case. Zero ice increment tendency into CICE 
     933            END_2D 
    893934#endif 
    894935            ! 
    … …  
    905946            ! 
    906947#if defined key_si3 
    907             zofrld (:,:) = 1._wp - at_i(:,:) 
    908             zohicif(:,:) = hm_i(:,:) 
    909             !  
    910             ! Initialize the now fields the background + increment 
    911             at_i(:,:) = 1. - MIN( MAX( 1.-at_i(:,:) - seaice_bkginc(:,:), 0.0_wp), 1.0_wp) 
    912             at_i_b(:,:) = at_i(:,:)  
    913             fr_i(:,:) = at_i(:,:)        ! adjust ice fraction 
    914             ! 
    915             zseaicendg(:,:) = zofrld(:,:) - (1. - at_i(:,:))   ! find out actual sea ice nudge applied 
     948            DO_2D( 0, 0, 0, 0 ) 
     949               zofrld (ji,jj) = 1._wp - at_i(ji,jj) 
     950               zohicif(ji,jj) = hm_i(ji,jj) 
     951               ! 
     952               ! Initialize the now fields the background + increment 
     953               at_i(ji,jj) = 1. - MIN( MAX( 1.-at_i(ji,jj) - seaice_bkginc(ji,jj), 0.0_wp), 1.0_wp) 
     954               at_i_b(ji,jj) = at_i(ji,jj) 
     955               fr_i(ji,jj) = at_i(ji,jj)        ! adjust ice fraction 
     956               ! 
     957               zseaicendg(ji,jj) = zofrld(ji,jj) - (1. - at_i(ji,jj))   ! find out actual sea ice nudge applied 
     958            END_2D 
    916959            ! 
    917960            ! Nudge sea ice depth to bring it up to a required minimum depth 
    918             WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(:,:) < zhicifmin )  
    919                zhicifinc(:,:) = zhicifmin - hm_i(:,:) 
     961            WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(A2D(0)) < zhicifmin ) 
     962               zhicifinc(:,:) = zhicifmin - hm_i(A2D(0)) 
    920963            ELSEWHERE 
    921964               zhicifinc(:,:) = 0.0_wp 
    … …  
    923966            ! 
    924967            ! nudge ice depth 
    925             hm_i (:,:) = hm_i (:,:) + zhicifinc(:,:) 
     968            DO_2D( 0, 0, 0, 0 ) 
     969               hm_i(ji,jj) = hm_i (ji,jj) + zhicifinc(ji,jj) 
     970            END_2D 
    926971            ! 
    927972            ! seaice salinity balancing (to add) 
    … …  
    930975#if defined key_cice && defined key_asminc 
    931976            ! Sea-ice : CICE case. Pass ice increment tendency into CICE 
    932            ndaice_da(:,:) = seaice_bkginc(:,:) / rn_Dt 
    933 #endif 
    934             IF ( .NOT. PRESENT(kindic) ) THEN 
    935                DEALLOCATE( seaice_bkginc ) 
    936             END IF 
     977            DO_2D( 0, 0, 0, 0 ) 
     978               ndaice_da(ji,jj) = seaice_bkginc(ji,jj) / rn_Dt 
     979            END_2D 
     980#endif 
     981            IF( ntile == 0 .OR. ntile == nijtile )  THEN                ! Do only on the last tile 
     982               IF ( .NOT. PRESENT(kindic) ) THEN 
     983                  DEALLOCATE( seaice_bkginc ) 
     984               END IF 
     985            ENDIF 
    937986            ! 
    938987         ELSE 
    939988            ! 
    940989#if defined key_cice && defined key_asminc 
    941             ndaice_da(:,:) = 0._wp     ! Sea-ice : CICE case. Zero ice increment tendency into CICE 
     990            DO_2D( 0, 0, 0, 0 ) 
     991               ndaice_da(ji,jj) = 0._wp     ! Sea-ice : CICE case. Zero ice increment tendency into CICE 
     992            END_2D 
    942993#endif 
    943994            ! 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/BDY/bdytra.F90

    r13998 r14023  
    1313   !!---------------------------------------------------------------------- 
    1414   USE oce            ! ocean dynamics and tracers variables 
    15    USE dom_oce        ! ocean space and time domain variables  
     15   USE dom_oce        ! ocean space and time domain variables 
    1616   USE bdy_oce        ! ocean open boundary conditions 
    1717   USE bdylib         ! for orlanski library routines 
    … …  
    157157      INTEGER  ::   ib_bdy         ! Loop index 
    158158      !!---------------------------------------------------------------------- 
     159      IF( ntile /= 0 .AND. ntile /= 1 ) RETURN                        ! Do only for the full domain 
    159160      ! 
    160161      IF( ln_timing )   CALL timing_start('bdy_tra_dmp') 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DIA/diaar5.F90

    r13998 r14023  
    3434   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:  ) ::   thick0       ! ocean thickness (interior domain) 
    3535   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   sn0          ! initial salinity 
     36   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   hstr_adv, hstr_ldf 
    3637 
    3738   LOGICAL  :: l_ar5 
    … …  
    5455      !!---------------------------------------------------------------------- 
    5556      ! 
    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 ) 
    5759      ! 
    5860      CALL mpp_sum ( 'diaar5', dia_ar5_alloc ) 
    … …  
    304306   END SUBROUTINE dia_ar5 
    305307 
    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 ) 
    308310      !!---------------------------------------------------------------------- 
    309311      !!                    ***  ROUTINE dia_ar5_htr *** 
    … …  
    314316      INTEGER                         , INTENT(in )  :: ktra  ! tracer index 
    315317      CHARACTER(len=3)                , INTENT(in)   :: cptr  ! transport type  'adv'/'ldf' 
    316       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)   :: puflx  ! u-flux of advection/diffusion 
    317       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)   :: pvflx  ! v-flux of advection/diffusion 
     318      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 
    318320      ! 
    319321      INTEGER    ::  ji, jj, jk 
    320       REAL(wp), DIMENSION(jpi,jpj)  :: z2d 
    321  
     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 
    322360     
    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            
    351361   END SUBROUTINE dia_ar5_hst 
    352362 
    … …  
    371381         &  iom_use( 'masstot' ) .OR. iom_use( 'temptot'   )  .OR. iom_use( 'saltot' ) .OR.  &     
    372382         &  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. & 
    373387         &  iom_use( 'rhop' )  ) L_ar5 = .TRUE. 
    374388   

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DIA/diaptr.F90

    r13998 r14023  
    2222   USE oce              ! ocean dynamics and active tracers 
    2323   USE dom_oce          ! ocean space and time domain 
     24   USE domain, ONLY : dom_tile 
    2425   USE phycst           ! physical constants 
    2526   ! 
    … …  
    3233   PRIVATE 
    3334 
     35   INTERFACE ptr_sum 
     36      MODULE PROCEDURE ptr_sum_3d, ptr_sum_2d 
     37   END INTERFACE 
     38 
    3439   INTERFACE ptr_sj 
    3540      MODULE PROCEDURE ptr_sj_3d, ptr_sj_2d 
    … …  
    3944   PUBLIC   dia_ptr_hst    ! called from tra_ldf/tra_adv routines 
    4045 
    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 
    4553 
    4654   REAL(wp) ::   rc_sv    = 1.e-6_wp   ! conversion from m3/s to Sverdrup 
    … …  
    5159   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk34 ! mask out Southern Ocean (=0 south of 34°S) 
    5260 
    53    REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:)   :: p_fval1d 
    54    REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:) :: p_fval2d 
    55  
    5661   LOGICAL ::   ll_init = .TRUE.        !: tracers  trend flag 
    57     
     62 
    5863   !! * Substitutions 
    5964#  include "do_loop_substitute.h90" 
    … …  
    7277      INTEGER                         , INTENT(in)           ::   kt     ! ocean time-step index      
    7378      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 
    75112      ! 
    76113      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    77       REAL(wp) ::   zsfc,zvfc               ! local scalar 
    78114      REAL(wp), DIMENSION(jpi,jpj)     ::  z2d   ! 2D workspace 
    79       REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zmask   ! 3D workspace 
    80       REAL(wp), DIMENSION(jpi,jpj,jpk) ::  z3d    ! 3D workspace 
    81       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) ::  zts   ! 3D workspace 
    82115      REAL(wp), DIMENSION(jpj)      ::  zvsum, ztsum, zssum   ! 1D workspace 
    83116      ! 
    … …  
    90123      !!---------------------------------------------------------------------- 
    91124      ! 
    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 nbasin 
    95       ! 
    96       IF( .NOT. l_diaptr ) THEN 
    97          IF( ln_timing ) CALL timing_stop('dia_ptr') 
    98          RETURN 
    99       ENDIF 
    100       ! 
    101125      ALLOCATE( z3dtr(jpi,jpj,nbasin) ) 
    102       ! 
     126 
    103127      IF( PRESENT( pvtr ) ) THEN 
    104128         IF( iom_use( 'zomsf' ) ) THEN    ! effective MSF 
    105129            ALLOCATE( z4d1(jpi,jpj,jpk,nbasin) ) 
     130            ! 
    106131            DO jn = 1, nbasin                                    ! by sub-basins 
    107                z4d1(1,:,:,jn) =  ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) )  ! zonal cumulative effective transport excluding closed seas 
    108                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 
    109134                  z4d1(1,:,jk,jn) = z4d1(1,:,jk+1,jn) - z4d1(1,:,jk,jn)    ! effective j-Stream-Function (MSF) 
    110135               END DO 
    111                DO ji = 1, jpi 
     136               DO ji = 2, jpi 
    112137                  z4d1(ji,:,:,jn) = z4d1(1,:,:,jn) 
    113138               ENDDO 
    114139            END DO 
    115140            CALL iom_put( 'zomsf', z4d1 * rc_sv ) 
     141            ! 
    116142            DEALLOCATE( z4d1 ) 
    117143         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 
    118375         IF(  iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR.   & 
    119376            & 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 
    121381            zmask(:,:,:) = 0._wp 
    122382            zts(:,:,:,:) = 0._wp 
     383 
    123384            DO_3D( 1, 0, 1, 1, 1, jpkm1 ) 
    124385               zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 
    125386               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  !Tracers averaged onto V grid 
     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 
    127388               zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc 
    128389            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 
    194403      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 
    200413            DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
    201414               zsfc = e1t(ji,jj) * e3t(ji,jj,jk,Kmm) 
    … …  
    204417               zts(ji,jj,jk,jp_sal) = ts(ji,jj,jk,jp_sal,Kmm) * zsfc 
    205418            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 
    292434         IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN 
     435            ALLOCATE( zts(A2D(nn_hls),jpk,jpts) ) 
     436 
    293437            zts(:,:,:,:) = 0._wp 
     438 
    294439            DO_3D( 1, 0, 1, 1, 1, jpkm1 ) 
    295440               zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 
    … …  
    297442               zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc 
    298443            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          ! 
     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 
    323450      ENDIF 
    324       ! 
    325       DEALLOCATE( z3dtr ) 
    326       ! 
    327       IF( ln_timing )   CALL timing_stop('dia_ptr') 
    328       ! 
    329    END SUBROUTINE dia_ptr 
     451   END SUBROUTINE dia_ptr_zint 
    330452 
    331453 
    … …  
    340462      REAL(wp), DIMENSION(jpi,jpj) :: zmsk 
    341463      !!---------------------------------------------------------------------- 
    342        
     464 
    343465      ! l_diaptr is defined with iom_use 
    344466      !   --> dia_ptr_init must be done after the call to iom_init 
    … …  
    347469         &       iom_use( 'zosrf'    ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR.  & 
    348470         &       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.  & 
    350472         &       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       
    353475      IF(lwp) THEN                     ! Control print 
    354476         WRITE(numout,*) 
    … …  
    398520         hstr_btr(:,:,:) = 0._wp           ! 
    399521         hstr_vtr(:,:,:) = 0._wp           ! 
     522         pvtr_int(:,:,:,:) = 0._wp 
     523         pzon_int(:,:,:,:) = 0._wp 
    400524         ! 
    401525         ll_init = .FALSE. 
    … …  
    415539      INTEGER                         , INTENT(in )  :: ktra  ! tracer index 
    416540      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   ! 
    418543      INTEGER                                        :: jn    ! 
    419544 
     545      DO jn = 1, nbasin 
     546         zsj(:,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 
     547      ENDDO 
    420548      ! 
    421549      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 
     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(:,:) ) 
    432561      ENDIF 
    433562      ! 
    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 
     563   END SUBROUTINE dia_ptr_hst 
     564 
     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 ) 
    445597      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 
     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 ) 
    458635      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 
    471       ENDIF 
    472       ! 
    473    END SUBROUTINE dia_ptr_hst 
     636#endif 
     637   END SUBROUTINE ptr_sum_3d 
    474638 
    475639 
    … …  
    479643      !!---------------------------------------------------------------------- 
    480644      INTEGER               ::   dia_ptr_alloc   ! return value 
    481       INTEGER, DIMENSION(3) ::   ierr 
     645      INTEGER, DIMENSION(2) ::   ierr 
    482646      !!---------------------------------------------------------------------- 
    483647      ierr(:) = 0 
    … …  
    491655            &      hstr_ldf(jpj,jpts,nbasin), hstr_vtr(jpj,jpts,nbasin), STAT=ierr(1)  ) 
    492656            ! 
    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) ) 
    494659         ! 
    495660         dia_ptr_alloc = MAXVAL( ierr ) 
    … …  
    511676      !! ** Action  : - p_fval: i-k-mean poleward flux of pvflx 
    512677      !!---------------------------------------------------------------------- 
    513       REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk)  ::   pvflx  ! mask flux array at V-point 
    514       REAL(wp), INTENT(in), DIMENSION(jpi,jpj)      ::   pmsk   ! Optional 2D basin mask 
     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 
    515680      ! 
    516681      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 
    519683      !!-------------------------------------------------------------------- 
    520684      ! 
    521       p_fval => p_fval1d 
    522  
    523       ijpj = jpj 
    524685      p_fval(:) = 0._wp 
    525686      DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
    526687         p_fval(jj) = p_fval(jj) + pvflx(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 
    527688      END_3D 
    528 #if defined key_mpp_mpi 
    529       CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl) 
    530 #endif 
    531       ! 
    532689   END FUNCTION ptr_sj_3d 
    533690 
    … …  
    544701      !! ** Action  : - p_fval: i-k-mean poleward flux of pvflx 
    545702      !!---------------------------------------------------------------------- 
    546       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) ::   pvflx  ! mask flux array at V-point 
     703      REAL(wp) , INTENT(in), DIMENSION(A2D(nn_hls))    ::   pvflx  ! mask flux array at V-point 
    547704      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) ::   pmsk   ! Optional 2D basin mask 
    548705      ! 
    549706      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 
    552708      !!-------------------------------------------------------------------- 
    553       !  
    554       p_fval => p_fval1d 
    555  
    556       ijpj = jpj 
     709      ! 
    557710      p_fval(:) = 0._wp 
    558711      DO_2D( 0, 0, 0, 0 ) 
    559712         p_fval(jj) = p_fval(jj) + pvflx(ji,jj) * pmsk(ji,jj) * tmask_i(ji,jj) 
    560713      END_2D 
    561 #if defined key_mpp_mpi 
    562       CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl ) 
    563 #endif 
    564       !  
    565714   END FUNCTION ptr_sj_2d 
    566715 
    … …  
    588737            p_fval(ji,jj) = p_fval(ji,jj-1) + pva(ji,jj) * tmask_i(ji,jj) 
    589738         END_2D 
    590          CALL lbc_lnk( 'diaptr', p_fval, 'U', -1.0_wp ) 
    591739      END DO 
    592740      !  
    … …  
    607755      !! 
    608756      IMPLICIT none 
    609       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pta    ! mask flux array at V-point 
    610       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)     ::   pmsk   ! Optional 2D basin mask 
     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 
    611759      !! 
    612760      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 
    620762      !!-------------------------------------------------------------------- 
    621763      ! 
    622       p_fval => p_fval2d 
    623  
    624764      p_fval(:,:) = 0._wp 
    625765      ! 
    … …  
    627767         p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 
    628768      END_3D 
    629       ! 
    630 #if defined key_mpp_mpi 
    631       ijpjjpk = jpj*jpk 
    632       ish(1) = ijpjjpk  ;   ish2(1) = jpj   ;   ish2(2) = jpk 
    633       zwork(1:ijpjjpk) = RESHAPE( p_fval, ish ) 
    634       CALL mpp_sum( 'diaptr', zwork, ijpjjpk, ncomm_znl ) 
    635       p_fval(:,:) = RESHAPE( zwork, ish2 ) 
    636 #endif 
    637       ! 
    638769   END FUNCTION ptr_sjk 
    639770 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/dom_oce.F90

    r13998 r14023  
    7474   LOGICAL, PUBLIC ::   l_Iperio, l_Jperio   !   should we explicitely take care I/J periodicity  
    7575 
     76   ! Tiling namelist 
     77   LOGICAL, PUBLIC ::   ln_tile 
     78   INTEGER         ::   nn_ltile_i, nn_ltile_j 
     79 
     80   ! Domain tiling (all tiles) 
     81   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   ntsi_a       !: start of internal part of tile domain 
     82   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   ntsj_a       ! 
     83   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   ntei_a       !: end of internal part of tile domain 
     84   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   ntej_a       ! 
     85 
    7686   !                             !: domain MPP decomposition parameters 
    7787   INTEGER             , PUBLIC ::   nimpp, njmpp     !: i- & j-indexes for mpp-subdomain left bottom 
    … …  
    8797   INTEGER, PUBLIC ::   noea, nowe        !: index of the local neighboring processors in 
    8898   INTEGER, PUBLIC ::   noso, nono        !: east, west, south and north directions 
     99   INTEGER, PUBLIC ::   nones, nonws        !: north-east, north-west directions for sending  
     100   INTEGER, PUBLIC ::   noses, nosws        !: south-east, south-west directions for sending 
     101   INTEGER, PUBLIC ::   noner, nonwr        !: north-east, north-west directions for receiving 
     102   INTEGER, PUBLIC ::   noser, noswr        !: south-east, south-west directions for receiving 
    89103   INTEGER, PUBLIC ::   nidom             !: ??? 
    90104 
    … …  
    302316      ALLOCATE( e3t(jpi,jpj,jpk,jpt) , e3u (jpi,jpj,jpk,jpt) , e3v (jpi,jpj,jpk,jpt) , e3f(jpi,jpj,jpk) ,      & 
    303317         &      e3w(jpi,jpj,jpk,jpt) , e3uw(jpi,jpj,jpk,jpt) , e3vw(jpi,jpj,jpk,jpt)                    ,  STAT=ierr(ii) ) 
    304 #endif   
     318#endif 
    305319         ! 
    306320      ii = ii+1 
    … …  
    315329         ! 
    316330      ii = ii+1 
    317       ALLOCATE( risfdep(jpi,jpj) , bathy(jpi,jpj) , STAT=ierr(ii)  )  
     331      ALLOCATE( risfdep(jpi,jpj) , bathy(jpi,jpj) , STAT=ierr(ii)  ) 
    318332         ! 
    319333      ii = ii+1 
    … …  
    321335         ! 
    322336      ii = ii+1 
    323       ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) ,                        &  
     337      ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) ,                        & 
    324338         &      ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , ssfmask(jpi,jpj) ,     & 
    325339         &      mbkt   (jpi,jpj) , mbku   (jpi,jpj) , mbkv   (jpi,jpj) ,                    STAT=ierr(ii) ) 
    … …  
    329343         ! 
    330344      ii = ii+1 
    331       ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) ,     &  
     345      ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) ,     & 
    332346         &      vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk) , STAT=ierr(ii) ) 
    333347         ! 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/domain.F90

    r14018 r14023  
    4646   USE closea  , ONLY : dom_clo   ! closed seas routine 
    4747   ! 
     48   USE prtctl         ! Print control (prt_ctl_info routine) 
    4849   USE in_out_manager ! I/O manager 
    4950   USE iom            ! I/O library 
    … …  
    5758   PUBLIC   dom_init     ! called by nemogcm.F90 
    5859   PUBLIC   domain_cfg   ! called by nemogcm.F90 
     60   PUBLIC   dom_tile     ! called by step.F90 
    5961 
    6062   !! * Substitutions 
    … …  
    128130      !           !==  Reference coordinate system  ==! 
    129131      ! 
    130       CALL dom_glo                      ! global domain versus local domain 
    131       CALL dom_nam                      ! read namelist ( namrun, namdom ) 
     132      CALL dom_glo                            ! global domain versus local domain 
     133      CALL dom_nam                            ! read namelist ( namrun, namdom ) 
     134      CALL dom_tile( ntsi, ntsj, ntei, ntej ) ! Tile domain 
     135 
    132136      ! 
    133137      CALL dom_hgr                      ! Horizontal mesh 
    … …  
    297301 
    298302 
     303   SUBROUTINE dom_tile( ktsi, ktsj, ktei, ktej, ktile ) 
     304      !!---------------------------------------------------------------------- 
     305      !!                     ***  ROUTINE dom_tile  *** 
     306      !! 
     307      !! ** Purpose :   Set tile domain variables 
     308      !! 
     309      !! ** Action  : - ktsi, ktsj     : start of internal part of domain 
     310      !!              - ktei, ktej     : end of internal part of domain 
     311      !!              - ntile          : current tile number 
     312      !!              - nijtile        : total number of tiles 
     313      !!---------------------------------------------------------------------- 
     314      INTEGER, INTENT(out) :: ktsi, ktsj, ktei, ktej      ! Tile domain indices 
     315      INTEGER, INTENT(in), OPTIONAL :: ktile              ! Tile number 
     316      INTEGER ::   jt                                     ! dummy loop argument 
     317      INTEGER ::   iitile, ijtile                         ! Local integers 
     318      CHARACTER (len=11) ::   charout 
     319      !!---------------------------------------------------------------------- 
     320      IF( PRESENT(ktile) .AND. ln_tile ) THEN 
     321         ntile = ktile                 ! Set domain indices for tile 
     322         ktsi = ntsi_a(ktile) 
     323         ktsj = ntsj_a(ktile) 
     324         ktei = ntei_a(ktile) 
     325         ktej = ntej_a(ktile) 
     326 
     327         IF(sn_cfctl%l_prtctl) THEN 
     328            WRITE(charout, FMT="('ntile =', I4)") ktile 
     329            CALL prt_ctl_info( charout ) 
     330         ENDIF 
     331      ELSE 
     332         ntile = 0                     ! Initialise to full domain 
     333         nijtile = 1 
     334         ktsi = Nis0 
     335         ktsj = Njs0 
     336         ktei = Nie0 
     337         ktej = Nje0 
     338 
     339         IF( ln_tile ) THEN            ! Calculate tile domain indices 
     340            iitile = Ni_0 / nn_ltile_i       ! Number of tiles 
     341            ijtile = Nj_0 / nn_ltile_j 
     342            IF( MOD( Ni_0, nn_ltile_i ) /= 0 ) iitile = iitile + 1 
     343            IF( MOD( Nj_0, nn_ltile_j ) /= 0 ) ijtile = ijtile + 1 
     344 
     345            nijtile = iitile * ijtile 
     346            ALLOCATE( ntsi_a(0:nijtile), ntsj_a(0:nijtile), ntei_a(0:nijtile), ntej_a(0:nijtile) ) 
     347 
     348            ntsi_a(0) = ktsi                 ! Full domain 
     349            ntsj_a(0) = ktsj 
     350            ntei_a(0) = ktei 
     351            ntej_a(0) = ktej 
     352 
     353            DO jt = 1, nijtile               ! Tile domains 
     354               ntsi_a(jt) = Nis0 + nn_ltile_i * MOD(jt - 1, iitile) 
     355               ntsj_a(jt) = Njs0 + nn_ltile_j * ((jt - 1) / iitile) 
     356               ntei_a(jt) = MIN(ntsi_a(jt) + nn_ltile_i - 1, Nie0) 
     357               ntej_a(jt) = MIN(ntsj_a(jt) + nn_ltile_j - 1, Nje0) 
     358            ENDDO 
     359         ENDIF 
     360 
     361         IF(lwp) THEN                  ! control print 
     362            WRITE(numout,*) 
     363            WRITE(numout,*) 'dom_tile : Domain tiling decomposition' 
     364            WRITE(numout,*) '~~~~~~~~' 
     365            IF( ln_tile ) THEN 
     366               WRITE(numout,*) iitile, 'tiles in i' 
     367               WRITE(numout,*) '    Starting indices' 
     368               WRITE(numout,*) '        ', (ntsi_a(jt), jt=1, iitile) 
     369               WRITE(numout,*) '    Ending indices' 
     370               WRITE(numout,*) '        ', (ntei_a(jt), jt=1, iitile) 
     371               WRITE(numout,*) ijtile, 'tiles in j' 
     372               WRITE(numout,*) '    Starting indices' 
     373               WRITE(numout,*) '        ', (ntsj_a(jt), jt=1, nijtile, iitile) 
     374               WRITE(numout,*) '    Ending indices' 
     375               WRITE(numout,*) '        ', (ntej_a(jt), jt=1, nijtile, iitile) 
     376            ELSE 
     377               WRITE(numout,*) 'No domain tiling' 
     378               WRITE(numout,*) '    i indices =', ktsi, ':', ktei 
     379               WRITE(numout,*) '    j indices =', ktsj, ':', ktej 
     380            ENDIF 
     381         ENDIF 
     382      ENDIF 
     383   END SUBROUTINE dom_tile 
     384 
     385 
    299386   SUBROUTINE dom_nam 
    300387      !!---------------------------------------------------------------------- 
    … …  
    305392      !! ** input   : - namrun namelist 
    306393      !!              - namdom namelist 
     394      !!              - namtile namelist 
    307395      !!              - namnc4 namelist   ! "key_netcdf4" only 
    308396      !!---------------------------------------------------------------------- 
    … …  
    319407         &             ln_cfmeta, ln_xios_read, nn_wxios 
    320408      NAMELIST/namdom/ ln_linssh, rn_Dt, rn_atfp, ln_crs, ln_meshmask 
     409      NAMELIST/namtile/ ln_tile, nn_ltile_i, nn_ltile_j 
    321410#if defined key_netcdf4 
    322411      NAMELIST/namnc4/ nn_nchunks_i, nn_nchunks_j, nn_nchunks_k, ln_nc4zip 
    … …  
    508597         END SELECT 
    509598      ENDIF 
    510        
    511        
     599      ! 
     600      !                       !========================! 
     601      !                       !==  namelist namtile  ==! 
     602      !                       !========================! 
     603      ! 
     604      READ  ( numnam_ref, namtile, IOSTAT = ios, ERR = 905 ) 
     605905   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtile in reference namelist' ) 
     606      READ  ( numnam_cfg, namtile, IOSTAT = ios, ERR = 906 ) 
     607906   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtile in configuration namelist' ) 
     608      IF(lwm) WRITE( numond, namtile ) 
     609 
     610      IF(lwp) THEN 
     611         WRITE(numout,*) 
     612         WRITE(numout,*)    '   Namelist : namtile   ---   Domain tiling decomposition' 
     613         WRITE(numout,*)    '      Tiling (T) or not (F)                ln_tile    = ', ln_tile 
     614         WRITE(numout,*)    '      Length of tile in i                  nn_ltile_i = ', nn_ltile_i 
     615         WRITE(numout,*)    '      Length of tile in j                  nn_ltile_j = ', nn_ltile_j 
     616         WRITE(numout,*) 
     617         IF( ln_tile ) THEN 
     618            WRITE(numout,*) '      The domain will be decomposed into tiles of size', nn_ltile_i, 'x', nn_ltile_j 
     619         ELSE 
     620            WRITE(numout,*) '      Domain tiling will NOT be used' 
     621         ENDIF 
     622      ENDIF 
     623      ! 
    512624#if defined key_netcdf4 
    513       ! 
    514625      !                       !=======================! 
    515626      !                       !==  namelist namnc4  ==!   NetCDF 4 case   ("key_netcdf4" defined) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/domutl.F90

    r13998 r14023  
    2121   PRIVATE 
    2222 
     23   INTERFACE is_tile 
     24      MODULE PROCEDURE is_tile_2d, is_tile_3d, is_tile_4d 
     25   END INTERFACE is_tile 
     26 
    2327   PUBLIC dom_ngb    ! routine called in iom.F90 module 
    2428   PUBLIC dom_uniq   ! Called by dommsk and domwri 
     29   PUBLIC is_tile 
    2530 
    2631   !!---------------------------------------------------------------------- 
    … …  
    109114      ! 
    110115   END SUBROUTINE dom_uniq 
    111     
     116 
     117 
     118   FUNCTION is_tile_2d( pt ) 
     119      !! 
     120      REAL(wp), DIMENSION(:,:), INTENT(in) ::   pt 
     121      INTEGER :: is_tile_2d 
     122      !! 
     123      IF( ln_tile .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN 
     124         is_tile_2d = 1 
     125      ELSE 
     126         is_tile_2d = 0 
     127      ENDIF 
     128   END FUNCTION is_tile_2d 
     129 
     130 
     131   FUNCTION is_tile_3d( pt ) 
     132      !! 
     133      REAL(wp), DIMENSION(:,:,:), INTENT(in) ::   pt 
     134      INTEGER :: is_tile_3d 
     135      !! 
     136      IF( ln_tile .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN 
     137         is_tile_3d = 1 
     138      ELSE 
     139         is_tile_3d = 0 
     140      ENDIF 
     141   END FUNCTION is_tile_3d 
     142 
     143 
     144   FUNCTION is_tile_4d( pt ) 
     145      !! 
     146      REAL(wp), DIMENSION(:,:,:,:), INTENT(in) ::   pt 
     147      INTEGER :: is_tile_4d 
     148      !! 
     149      IF( ln_tile .AND. (SIZE(pt, 1) < jpi .OR. SIZE(pt, 2) < jpj) ) THEN 
     150         is_tile_4d = 1 
     151      ELSE 
     152         is_tile_4d = 0 
     153      ENDIF 
     154   END FUNCTION is_tile_4d 
     155 
    112156   !!====================================================================== 
    113157END MODULE domutl 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/domvvl.F90

    r14018 r14023  
    422422         !                             (stored for tracer advction and continuity equation) 
    423423         CALL lbc_lnk_multi( 'domvvl', un_td , 'U' , -1._wp, vn_td , 'V' , -1._wp) 
    424  
    425424         ! 4 - Time stepping of baroclinic scale factors 
    426425         ! --------------------------------------------- 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/dtatsd.F90

    r13998 r14023  
    1818   USE phycst          ! physical constants 
    1919   USE dom_oce         ! ocean space and time domain 
     20   USE domain, ONLY : dom_tile 
    2021   USE fldread         ! read input fields 
    2122   ! 
    … …  
    135136      !! ** Action  :   ptsd   T-S data on medl mesh and interpolated at time-step kt 
    136137      !!---------------------------------------------------------------------- 
    137       INTEGER                              , INTENT(in   ) ::   kt     ! ocean time-step 
    138       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(  out) ::   ptsd   ! T & S data 
     138      INTEGER                          , INTENT(in   ) ::   kt     ! ocean time-step 
     139      REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts), INTENT(  out) ::   ptsd   ! T & S data 
    139140      ! 
    140141      INTEGER ::   ji, jj, jk, jl, jkk   ! dummy loop indicies 
    141142      INTEGER ::   ik, il0, il1, ii0, ii1, ij0, ij1   ! local integers 
     143      INTEGER ::   itile 
    142144      REAL(wp)::   zl, zi                             ! local scalars 
    143145      REAL(wp), DIMENSION(jpk) ::  ztp, zsp   ! 1D workspace 
    144146      !!---------------------------------------------------------------------- 
    145147      ! 
    146       CALL fld_read( kt, 1, sf_tsd )      !==   read T & S data at kt time step   ==! 
     148      IF( ntile == 0 .OR. ntile == 1 )  THEN                                         ! Do only for the full domain 
     149         itile = ntile 
     150         IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 )            ! Use full domain 
     151            CALL fld_read( kt, 1, sf_tsd )   !==   read T & S data at kt time step   ==! 
    147152      ! 
    148153      ! 
    149154!!gm  This should be removed from the code   ===>>>>  T & S files has to be changed 
    150       ! 
    151       !                                   !==   ORCA_R2 configuration and T & S damping   ==!  
    152       IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN 
    153          IF( nn_cfg == 2 .AND. ln_tsd_dmp ) THEN    ! some hand made alterations 
    154             ! 
    155             ij0 = 101 + nn_hls       ;   ij1 = 109 + nn_hls                       ! Reduced T & S in the Alboran Sea 
    156             ii0 = 141 + nn_hls - 1   ;   ii1 = 155 + nn_hls - 1 
    157             DO jj = mj0(ij0), mj1(ij1) 
    158                DO ji = mi0(ii0), mi1(ii1) 
    159                   sf_tsd(jp_tem)%fnow(ji,jj,13:13) = sf_tsd(jp_tem)%fnow(ji,jj,13:13) - 0.20_wp 
    160                   sf_tsd(jp_tem)%fnow(ji,jj,14:15) = sf_tsd(jp_tem)%fnow(ji,jj,14:15) - 0.35_wp 
    161                   sf_tsd(jp_tem)%fnow(ji,jj,16:25) = sf_tsd(jp_tem)%fnow(ji,jj,16:25) - 0.40_wp 
    162                   ! 
    163                   sf_tsd(jp_sal)%fnow(ji,jj,13:13) = sf_tsd(jp_sal)%fnow(ji,jj,13:13) - 0.15_wp 
    164                   sf_tsd(jp_sal)%fnow(ji,jj,14:15) = sf_tsd(jp_sal)%fnow(ji,jj,14:15) - 0.25_wp 
    165                   sf_tsd(jp_sal)%fnow(ji,jj,16:17) = sf_tsd(jp_sal)%fnow(ji,jj,16:17) - 0.30_wp 
    166                   sf_tsd(jp_sal)%fnow(ji,jj,18:25) = sf_tsd(jp_sal)%fnow(ji,jj,18:25) - 0.35_wp 
     155         ! 
     156         !                                   !==   ORCA_R2 configuration and T & S damping   ==! 
     157         IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN 
     158            IF( nn_cfg == 2 .AND. ln_tsd_dmp ) THEN    ! some hand made alterations 
     159               ! 
     160               ij0 = 101 + nn_hls       ;   ij1 = 109 + nn_hls                       ! Reduced T & S in the Alboran Sea 
     161               ii0 = 141 + nn_hls - 1   ;   ii1 = 155 + nn_hls - 1 
     162               DO jj = mj0(ij0), mj1(ij1) 
     163                  DO ji = mi0(ii0), mi1(ii1) 
     164                     sf_tsd(jp_tem)%fnow(ji,jj,13:13) = sf_tsd(jp_tem)%fnow(ji,jj,13:13) - 0.20_wp 
     165                     sf_tsd(jp_tem)%fnow(ji,jj,14:15) = sf_tsd(jp_tem)%fnow(ji,jj,14:15) - 0.35_wp 
     166                     sf_tsd(jp_tem)%fnow(ji,jj,16:25) = sf_tsd(jp_tem)%fnow(ji,jj,16:25) - 0.40_wp 
     167                     ! 
     168                     sf_tsd(jp_sal)%fnow(ji,jj,13:13) = sf_tsd(jp_sal)%fnow(ji,jj,13:13) - 0.15_wp 
     169                     sf_tsd(jp_sal)%fnow(ji,jj,14:15) = sf_tsd(jp_sal)%fnow(ji,jj,14:15) - 0.25_wp 
     170                     sf_tsd(jp_sal)%fnow(ji,jj,16:17) = sf_tsd(jp_sal)%fnow(ji,jj,16:17) - 0.30_wp 
     171                     sf_tsd(jp_sal)%fnow(ji,jj,18:25) = sf_tsd(jp_sal)%fnow(ji,jj,18:25) - 0.35_wp 
     172                  END DO 
    167173               END DO 
    168             END DO 
    169             ij0 =  87 + nn_hls       ;   ij1 =  96 + nn_hls                       ! Reduced temperature in Red Sea 
    170             ii0 = 148 + nn_hls - 1   ;   ii1 = 160 + nn_hls - 1 
    171             sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ,  4:10 ) = 7.0_wp 
    172             sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 11:13 ) = 6.5_wp 
    173             sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 14:20 ) = 6.0_wp 
    174          ENDIF 
    175       ENDIF 
     174               ij0 =  87 + nn_hls       ;   ij1 =  96 + nn_hls                       ! Reduced temperature in Red Sea 
     175               ii0 = 148 + nn_hls - 1   ;   ii1 = 160 + nn_hls - 1 
     176               sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ,  4:10 ) = 7.0_wp 
     177               sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 11:13 ) = 6.5_wp 
     178               sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 14:20 ) = 6.0_wp 
     179            ENDIF 
     180         ENDIF 
    176181!!gm end 
    177       ! 
    178       ptsd(:,:,:,jp_tem) = sf_tsd(jp_tem)%fnow(:,:,:)    ! NO mask 
    179       ptsd(:,:,:,jp_sal) = sf_tsd(jp_sal)%fnow(:,:,:)  
     182         IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = itile )            ! Revert to tile domain 
     183      ENDIF 
     184      ! 
     185      DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) 
     186         ptsd(ji,jj,jk,jp_tem) = sf_tsd(jp_tem)%fnow(ji,jj,jk)    ! NO mask 
     187         ptsd(ji,jj,jk,jp_sal) = sf_tsd(jp_sal)%fnow(ji,jj,jk) 
     188      END_3D 
    180189      ! 
    181190      IF( ln_sco ) THEN                   !==   s- or mixed s-zps-coordinate   ==! 
    182191         ! 
    183          IF( kt == nit000 .AND. lwp )THEN 
    184             WRITE(numout,*) 
    185             WRITE(numout,*) 'dta_tsd: interpolates T & S data onto the s- or mixed s-z-coordinate mesh' 
    186          ENDIF 
    187          ! 
    188          DO_2D( 1, 1, 1, 1 )                  ! vertical interpolation of T & S 
     192         IF( ntile == 0 .OR. ntile == 1 )  THEN                       ! Do only on the first tile 
     193            IF( kt == nit000 .AND. lwp )THEN 
     194               WRITE(numout,*) 
     195               WRITE(numout,*) 'dta_tsd: interpolates T & S data onto the s- or mixed s-z-coordinate mesh' 
     196            ENDIF 
     197         ENDIF 
     198         ! 
     199         ! NOTE: [tiling-comms-merge] This fix was necessary to take out tra_adv lbc_lnk statements in the zps case, but did not work in the zco case 
     200         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )                  ! vertical interpolation of T & S 
    189201            DO jk = 1, jpk                        ! determines the intepolated T-S profiles at each (i,j) points 
    190202               zl = gdept_0(ji,jj,jk) 
    … …  
    215227      ELSE                                !==   z- or zps- coordinate   ==! 
    216228         !                              
    217          ptsd(:,:,:,jp_tem) = ptsd(:,:,:,jp_tem) * tmask(:,:,:)    ! Mask 
    218          ptsd(:,:,:,jp_sal) = ptsd(:,:,:,jp_sal) * tmask(:,:,:) 
     229         DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) 
     230            ptsd(ji,jj,jk,jp_tem) = ptsd(ji,jj,jk,jp_tem) * tmask(ji,jj,jk)    ! Mask 
     231            ptsd(ji,jj,jk,jp_sal) = ptsd(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) 
     232         END_3D 
    219233         ! 
    220234         IF( ln_zps ) THEN                      ! zps-coordinate (partial steps) interpolation at the last ocean level 
    221             DO_2D( 1, 1, 1, 1 ) 
     235            ! NOTE: [tiling-comms-merge] This fix was necessary to take out tra_adv lbc_lnk statements in the zps case 
     236            DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    222237               ik = mbkt(ji,jj)  
    223238               IF( ik > 1 ) THEN 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynhpg.F90

    r13295 r14023  
    302302      INTEGER  ::   iku, ikv                         ! temporary integers 
    303303      REAL(wp) ::   zcoef0, zcoef1, zcoef2, zcoef3   ! temporary scalars 
    304       REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zhpi, zhpj 
    305       REAL(wp), DIMENSION(jpi,jpj) :: zgtsu, zgtsv, zgru, zgrv 
     304      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhpi, zhpj 
     305      REAL(wp), DIMENSION(jpi,jpj,jpts)   :: zgtsu, zgtsv 
     306      REAL(wp), DIMENSION(jpi,jpj)     :: zgru, zgrv 
    306307      !!---------------------------------------------------------------------- 
    307308      ! 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/IOM/iom.F90

    r14018 r14023  
    19651965      CHARACTER(LEN=*), INTENT(in) ::   cdname 
    19661966      REAL(sp)        , INTENT(in) ::   pfield0d 
    1967 !!      REAL(wp)        , DIMENSION(jpi,jpj) ::   zz     ! masson 
     1967      !!      REAL(wp)        , DIMENSION(jpi,jpj) ::   zz     ! masson 
    19681968#if defined key_iomput 
    19691969!!clem      zz(:,:)=pfield0d 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/IOM/prtctl.F90

    r13286 r14023  
    88   !!---------------------------------------------------------------------- 
    99   USE dom_oce          ! ocean space and time domain variables 
     10   USE domutl, ONLY : is_tile 
    1011   USE in_out_manager   ! I/O manager 
    1112   USE mppini           ! distributed memory computing 
    … …  
    2627   PUBLIC prt_ctl_init    ! called by nemogcm.F90 and prt_ctl_trc_init 
    2728 
     29   !! * Substitutions 
     30#  include "do_loop_substitute.h90" 
    2831   !!---------------------------------------------------------------------- 
    2932   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    3538   SUBROUTINE prt_ctl (tab2d_1, tab3d_1, tab4d_1, tab2d_2, tab3d_2, mask1, mask2,   & 
    3639      &                 clinfo, clinfo1, clinfo2, clinfo3, kdim ) 
     40      !! 
     41      REAL(wp),         DIMENSION(:,:)    , INTENT(in), OPTIONAL ::   tab2d_1 
     42      REAL(wp),         DIMENSION(:,:,:)  , INTENT(in), OPTIONAL ::   tab3d_1 
     43      REAL(wp),         DIMENSION(:,:,:,:), INTENT(in), OPTIONAL ::   tab4d_1 
     44      REAL(wp),         DIMENSION(:,:)    , INTENT(in), OPTIONAL ::   tab2d_2 
     45      REAL(wp),         DIMENSION(:,:,:)  , INTENT(in), OPTIONAL ::   tab3d_2 
     46      REAL(wp),         DIMENSION(:,:,:)  , INTENT(in), OPTIONAL ::   mask1 
     47      REAL(wp),         DIMENSION(:,:,:)  , INTENT(in), OPTIONAL ::   mask2 
     48      CHARACTER(len=*), DIMENSION(:)      , INTENT(in), OPTIONAL ::   clinfo    ! information about the tab3d array 
     49      CHARACTER(len=*)                    , INTENT(in), OPTIONAL ::   clinfo1 
     50      CHARACTER(len=*)                    , INTENT(in), OPTIONAL ::   clinfo2 
     51      CHARACTER(len=*)                    , INTENT(in), OPTIONAL ::   clinfo3 
     52      INTEGER                             , INTENT(in), OPTIONAL ::   kdim 
     53      ! 
     54      INTEGER :: itab2d_1, itab3d_1, itab4d_1, itab2d_2, itab3d_2 
     55      !! 
     56      IF( PRESENT(tab2d_1)  ) THEN ; itab2d_1 = is_tile(tab2d_1)  ; ELSE ; itab2d_1 = 0 ; ENDIF 
     57      IF( PRESENT(tab3d_1)  ) THEN ; itab3d_1 = is_tile(tab3d_1)  ; ELSE ; itab3d_1 = 0 ; ENDIF 
     58      IF( PRESENT(tab4d_1)  ) THEN ; itab4d_1 = is_tile(tab4d_1)  ; ELSE ; itab4d_1 = 0 ; ENDIF 
     59      IF( PRESENT(tab2d_2)  ) THEN ; itab2d_2 = is_tile(tab2d_2)  ; ELSE ; itab2d_2 = 0 ; ENDIF 
     60      IF( PRESENT(tab3d_2)  ) THEN ; itab3d_2 = is_tile(tab3d_2)  ; ELSE ; itab3d_2 = 0 ; ENDIF 
     61 
     62      CALL prt_ctl_t (tab2d_1, itab2d_1, tab3d_1, itab3d_1, tab4d_1, itab4d_1, tab2d_2, itab2d_2, tab3d_2, itab3d_2,  & 
     63      &               mask1, mask2, clinfo, clinfo1, clinfo2, clinfo3, kdim ) 
     64   END SUBROUTINE prt_ctl 
     65 
     66 
     67   SUBROUTINE prt_ctl_t (tab2d_1, ktab2d_1, tab3d_1, ktab3d_1, tab4d_1, ktab4d_1, tab2d_2, ktab2d_2, tab3d_2, ktab3d_2,  & 
     68      &                  mask1, mask2, clinfo, clinfo1, clinfo2, clinfo3, kdim ) 
    3769      !!---------------------------------------------------------------------- 
    3870      !!                     ***  ROUTINE prt_ctl  *** 
    … …  
    70102      !!                    clinfo3 : additional information  
    71103      !!---------------------------------------------------------------------- 
    72       REAL(wp),         DIMENSION(:,:)    , INTENT(in), OPTIONAL ::   tab2d_1 
    73       REAL(wp),         DIMENSION(:,:,:)  , INTENT(in), OPTIONAL ::   tab3d_1 
    74       REAL(wp),         DIMENSION(:,:,:,:), INTENT(in), OPTIONAL ::   tab4d_1 
    75       REAL(wp),         DIMENSION(:,:)    , INTENT(in), OPTIONAL ::   tab2d_2 
    76       REAL(wp),         DIMENSION(:,:,:)  , INTENT(in), OPTIONAL ::   tab3d_2 
     104      INTEGER                             , INTENT(in)           ::   ktab2d_1, ktab3d_1, ktab4d_1, ktab2d_2, ktab3d_2 
     105      REAL(wp),         DIMENSION(A2D_T(ktab2d_1))    , INTENT(in), OPTIONAL ::   tab2d_1 
     106      REAL(wp),         DIMENSION(A2D_T(ktab3d_1),:)  , INTENT(in), OPTIONAL ::   tab3d_1 
     107      REAL(wp),         DIMENSION(A2D_T(ktab4d_1),:,:), INTENT(in), OPTIONAL ::   tab4d_1 
     108      REAL(wp),         DIMENSION(A2D_T(ktab2d_2))    , INTENT(in), OPTIONAL ::   tab2d_2 
     109      REAL(wp),         DIMENSION(A2D_T(ktab3d_2),:)  , INTENT(in), OPTIONAL ::   tab3d_2 
    77110      REAL(wp),         DIMENSION(:,:,:)  , INTENT(in), OPTIONAL ::   mask1 
    78111      REAL(wp),         DIMENSION(:,:,:)  , INTENT(in), OPTIONAL ::   mask2 
    … …  
    106139 
    107140         ! define shoter names... 
    108          iis = nall_ictls(jl) 
    109          iie = nall_ictle(jl) 
    110          jjs = nall_jctls(jl) 
    111          jje = nall_jctle(jl) 
     141         iis = MAX( nall_ictls(jl), ntsi ) 
     142         iie = MIN( nall_ictle(jl), ntei ) 
     143         jjs = MAX( nall_jctls(jl), ntsj ) 
     144         jje = MIN( nall_jctle(jl), ntej ) 
    112145 
    113146         IF( PRESENT(clinfo) ) THEN   ;   inum = numprt_top(jl) 
    … …  
    115148         ENDIF 
    116149 
    117          DO jn = 1, itra 
    118  
    119             IF( PRESENT(clinfo3) ) THEN 
    120                IF    ( clinfo3 == 'tra-ta' )   THEN 
    121                   zvctl1 = t_ctl(jl) 
    122                ELSEIF( clinfo3 == 'tra'    )   THEN 
    123                   zvctl1 = t_ctl(jl) 
    124                   zvctl2 = s_ctl(jl) 
    125                ELSEIF( clinfo3 == 'dyn'    )   THEN 
    126                   zvctl1 = u_ctl(jl) 
    127                   zvctl2 = v_ctl(jl) 
     150         ! Compute the sum control only where the tile domain and control print area overlap 
     151         IF( iie >= iis .AND. jje >= jjs ) THEN 
     152            DO jn = 1, itra 
     153 
     154               IF( PRESENT(clinfo3) ) THEN 
     155                  IF    ( clinfo3 == 'tra-ta' )   THEN 
     156                     zvctl1 = t_ctl(jl) 
     157                  ELSEIF( clinfo3 == 'tra'    )   THEN 
     158                     zvctl1 = t_ctl(jl) 
     159                     zvctl2 = s_ctl(jl) 
     160                  ELSEIF( clinfo3 == 'dyn'    )   THEN 
     161                     zvctl1 = u_ctl(jl) 
     162                     zvctl2 = v_ctl(jl) 
     163                  ELSE 
     164                     zvctl1 = tra_ctl(jn,jl) 
     165                  ENDIF 
     166               ENDIF 
     167 
     168               ! 2D arrays 
     169               IF( PRESENT(tab2d_1) ) THEN 
     170                  IF( PRESENT(mask1) ) THEN   ;   zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) * mask1(iis:iie,jjs:jje,1) ) 
     171                  ELSE                        ;   zsum1 = SUM( tab2d_1(iis:iie,jjs:jje)                            ) 
     172                  ENDIF 
     173               ENDIF 
     174               IF( PRESENT(tab2d_2) ) THEN 
     175                  IF( PRESENT(mask2) ) THEN   ;   zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) * mask2(iis:iie,jjs:jje,1) ) 
     176                  ELSE                        ;   zsum2 = SUM( tab2d_2(iis:iie,jjs:jje)                            ) 
     177                  ENDIF 
     178               ENDIF 
     179 
     180               ! 3D arrays 
     181               IF( PRESENT(tab3d_1) ) THEN 
     182                  IF( PRESENT(mask1) ) THEN   ;   zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) * mask1(iis:iie,jjs:jje,1:kdir) ) 
     183                  ELSE                        ;   zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir)                                 ) 
     184                  ENDIF 
     185               ENDIF 
     186               IF( PRESENT(tab3d_2) ) THEN 
     187                  IF( PRESENT(mask2) ) THEN   ;   zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) * mask2(iis:iie,jjs:jje,1:kdir) ) 
     188                  ELSE                        ;   zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir)                                 ) 
     189                  ENDIF 
     190               ENDIF 
     191 
     192               ! 4D arrays 
     193               IF( PRESENT(tab4d_1) ) THEN 
     194                  IF( PRESENT(mask1) ) THEN   ;   zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) * mask1(iis:iie,jjs:jje,1:kdir) ) 
     195                  ELSE                        ;   zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn)                                 ) 
     196                  ENDIF 
     197               ENDIF 
     198 
     199               ! Print the result 
     200               IF( PRESENT(clinfo ) )   cl1  = clinfo(jn) 
     201               IF( PRESENT(clinfo3) )   THEN 
     202                  ! 
     203                  IF( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN 
     204                     WRITE(inum, "(3x,a,' : ',D23.16,3x,a,' : ',D23.16)") cl1, zsum1 - zvctl1, cl2, zsum2 - zvctl2 
     205                  ELSE 
     206                     WRITE(inum, "(3x,a,' : ',D23.16                  )") cl1, zsum1 - zvctl1 
     207                  ENDIF 
     208                  ! 
     209                  SELECT CASE( clinfo3 ) 
     210                  CASE ( 'tra-ta' ) 
     211                     t_ctl(jl) = zsum1 
     212                  CASE ( 'tra' ) 
     213                     t_ctl(jl) = zsum1 
     214                     s_ctl(jl) = zsum2 
     215                  CASE ( 'dyn' ) 
     216                     u_ctl(jl) = zsum1 
     217                     v_ctl(jl) = zsum2 
     218                  CASE default 
     219                     tra_ctl(jn,jl) = zsum1 
     220                  END SELECT 
     221               ELSEIF ( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) )   THEN 
     222                  WRITE(inum, "(3x,a,' : ',D23.16,3x,a,' : ',D23.16)") cl1, zsum1, cl2, zsum2 
    128223               ELSE 
    129                   zvctl1 = tra_ctl(jn,jl) 
    130                ENDIF 
    131             ENDIF 
    132  
    133             ! 2D arrays 
    134             IF( PRESENT(tab2d_1) ) THEN 
    135                IF( PRESENT(mask1) ) THEN   ;   zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) * mask1(iis:iie,jjs:jje,1) ) 
    136                ELSE                        ;   zsum1 = SUM( tab2d_1(iis:iie,jjs:jje)                            ) 
    137                ENDIF 
    138             ENDIF 
    139             IF( PRESENT(tab2d_2) ) THEN 
    140                IF( PRESENT(mask2) ) THEN   ;   zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) * mask2(iis:iie,jjs:jje,1) ) 
    141                ELSE                        ;   zsum2 = SUM( tab2d_2(iis:iie,jjs:jje)                            ) 
    142                ENDIF 
    143             ENDIF 
    144  
    145             ! 3D arrays 
    146             IF( PRESENT(tab3d_1) ) THEN 
    147                IF( PRESENT(mask1) ) THEN   ;   zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) * mask1(iis:iie,jjs:jje,1:kdir) ) 
    148                ELSE                        ;   zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir)                                 ) 
    149                ENDIF 
    150             ENDIF 
    151             IF( PRESENT(tab3d_2) ) THEN 
    152                IF( PRESENT(mask2) ) THEN   ;   zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) * mask2(iis:iie,jjs:jje,1:kdir) ) 
    153                ELSE                        ;   zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir)                                 ) 
    154                ENDIF 
    155             ENDIF 
    156  
    157             ! 4D arrays 
    158             IF( PRESENT(tab4d_1) ) THEN 
    159                IF( PRESENT(mask1) ) THEN   ;   zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) * mask1(iis:iie,jjs:jje,1:kdir) ) 
    160                ELSE                        ;   zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn)                                 ) 
    161                ENDIF 
    162             ENDIF 
    163  
    164             ! Print the result 
    165             IF( PRESENT(clinfo ) )   cl1  = clinfo(jn) 
    166             IF( PRESENT(clinfo3) )   THEN 
    167                ! 
    168                IF( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN 
    169                   WRITE(inum, "(3x,a,' : ',D23.16,3x,a,' : ',D23.16)") cl1, zsum1 - zvctl1, cl2, zsum2 - zvctl2 
    170                ELSE 
    171                   WRITE(inum, "(3x,a,' : ',D23.16                  )") cl1, zsum1 - zvctl1 
    172                ENDIF 
    173                ! 
    174                SELECT CASE( clinfo3 ) 
    175                CASE ( 'tra-ta' )  
    176                   t_ctl(jl) = zsum1 
    177                CASE ( 'tra' )  
    178                   t_ctl(jl) = zsum1 
    179                   s_ctl(jl) = zsum2 
    180                CASE ( 'dyn' )  
    181                   u_ctl(jl) = zsum1 
    182                   v_ctl(jl) = zsum2 
    183                CASE default 
    184                   tra_ctl(jn,jl) = zsum1 
    185                END SELECT 
    186             ELSEIF ( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) )   THEN 
    187                WRITE(inum, "(3x,a,' : ',D23.16,3x,a,' : ',D23.16)") cl1, zsum1, cl2, zsum2 
    188             ELSE 
    189                WRITE(inum, "(3x,a,' : ',D23.16                  )") cl1, zsum1 
    190             ENDIF 
    191  
    192          END DO 
     224                  WRITE(inum, "(3x,a,' : ',D23.16                  )") cl1, zsum1 
     225               ENDIF 
     226 
     227            END DO 
     228         ENDIF 
    193229      END DO 
    194230      ! 
    195    END SUBROUTINE prt_ctl 
     231   END SUBROUTINE prt_ctl_t 
    196232 
    197233 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LBC/lbc_lnk_multi_generic.h90

    r13998 r14023  
    4040      &                    , pt9 , cdna9 , psgn9 , pt10, cdna10, psgn10, pt11, cdna11, psgn11, pt12, cdna12, psgn12  & 
    4141      &                    , pt13, cdna13, psgn13, pt14, cdna14, psgn14, pt15, cdna15, psgn15, pt16, cdna16, psgn16  & 
    42       &                    , kfillmode, pfillval, lsend, lrecv ) 
     42      &                    , kfillmode, pfillval, lsend, lrecv, ncsten ) 
    4343      !!--------------------------------------------------------------------- 
    4444      CHARACTER(len=*)     ,                   INTENT(in   ) ::   cdname  ! name of the calling subroutine 
    … …  
    5555      REAL(wp)             , OPTIONAL        , INTENT(in   ) ::   pfillval    ! background value (used at closed boundaries) 
    5656      LOGICAL, DIMENSION(4), OPTIONAL        , INTENT(in   ) ::   lsend, lrecv   ! indicate how communications are to be carried out 
     57      LOGICAL              , OPTIONAL        , INTENT(in   ) ::   ncsten 
    5758      !! 
    5859      INTEGER                          ::   kfld        ! number of elements that will be attributed 
    … …  
    8485      IF( PRESENT(psgn16) )   CALL ROUTINE_LOAD( pt16, cdna16, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    8586      ! 
    86       CALL lbc_lnk_ptr( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv ) 
     87      CALL lbc_lnk_ptr( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv, ncsten ) 
    8788      ! 
    8889   END SUBROUTINE ROUTINE_MULTI 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LBC/lbclnk.F90

    r13226 r14023  
    3939      MODULE PROCEDURE   lbc_lnk_2d_multi_dp , lbc_lnk_3d_multi_dp, lbc_lnk_4d_multi_dp 
    4040   END INTERFACE 
     41   INTERFACE lbc_lnk_nc_multi 
     42      MODULE PROCEDURE   lbc_lnk_nc_2d_sp, lbc_lnk_nc_3d_sp, lbc_lnk_nc_4d_sp 
     43      MODULE PROCEDURE   lbc_lnk_nc_2d_dp, lbc_lnk_nc_3d_dp, lbc_lnk_nc_4d_dp 
     44   END INTERFACE 
     45   INTERFACE lbc_lnk_nc 
     46      MODULE PROCEDURE   mpp_lnk_nc_2d_sp, mpp_lnk_nc_3d_sp, mpp_lnk_nc_4d_sp 
     47      MODULE PROCEDURE   mpp_lnk_nc_2d_dp, mpp_lnk_nc_3d_dp, mpp_lnk_nc_4d_dp 
     48   END INTERFACE 
    4149   ! 
    4250   INTERFACE lbc_lnk_icb 
    … …  
    5260   END INTERFACE 
    5361 
    54    PUBLIC   lbc_lnk       ! ocean/ice lateral boundary conditions 
    55    PUBLIC   lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 
    56    PUBLIC   lbc_lnk_icb   ! iceberg lateral boundary conditions 
     62   PUBLIC   lbc_lnk            ! ocean/ice lateral boundary conditions 
     63   PUBLIC   lbc_lnk_multi      ! modified ocean/ice lateral boundary conditions 
     64   PUBLIC   lbc_lnk_icb        ! iceberg lateral boundary conditions 
     65   PUBLIC   lbc_lnk_nc         ! ocean/ice lateral boundary conditions (MPI3 version) 
     66   PUBLIC   lbc_lnk_nc_multi   ! modified ocean/ice lateral boundary conditions (MPI3 version) 
    5767 
    5868#if   defined key_mpp_mpi 
    … …  
    250260#  undef DIM_4d 
    251261 
     262   !!---------------------------------------------------------------------- 
     263   !!                   ***   load_ptr_(2,3,4)d   *** 
     264   !! 
     265   !!   * Dummy Argument : 
     266   !!       in    ==>   ptab       ! array to be loaded (2D, 3D or 4D) 
     267   !!                   cd_nat     ! nature of pt2d array grid-points 
     268   !!                   psgn       ! sign used across the north fold boundary 
     269   !!       inout <=>   ptab_ptr   ! array of 2D, 3D or 4D pointers 
     270   !!                   cdna_ptr   ! nature of ptab array grid-points 
     271   !!                   psgn_ptr   ! sign used across the north fold boundary 
     272   !!                   kfld       ! number of elements that has been attributed 
     273   !!---------------------------------------------------------------------- 
     274 
     275   !!---------------------------------------------------------------------- 
     276   !!                  ***   lbc_lnk_nc(2,3,4)d_multi   *** 
     277   !!                     ***   load_ptr_(2,3,4)d   *** 
     278   !! 
     279   !!   * Argument : dummy argument use in lbc_lnk_nc_multi_... routines 
     280   !! 
     281   !!---------------------------------------------------------------------- 
     282 
     283   !! 
     284   !!   ----   SINGLE PRECISION VERSIONS 
     285   !! 
     286#  define SINGLE_PRECISION 
     287#  define DIM_2d 
     288#     define ROUTINE_NC_LOAD           load_ptr_nc_2d_sp 
     289#     define ROUTINE_MULTI_NC          lbc_lnk_nc_2d_sp 
     290#     include "lbc_lnk_nc_generic.h90" 
     291#     undef ROUTINE_MULTI_NC 
     292#     undef ROUTINE_NC_LOAD 
     293#  undef DIM_2d 
     294 
     295#  define DIM_3d 
     296#     define ROUTINE_NC_LOAD           load_ptr_nc_3d_sp 
     297#     define ROUTINE_MULTI_NC          lbc_lnk_nc_3d_sp 
     298#     include "lbc_lnk_nc_generic.h90" 
     299#     undef ROUTINE_MULTI_NC 
     300#     undef ROUTINE_NC_LOAD 
     301#  undef DIM_3d 
     302 
     303#  define DIM_4d 
     304#     define ROUTINE_NC_LOAD           load_ptr_nc_4d_sp 
     305#     define ROUTINE_MULTI_NC          lbc_lnk_nc_4d_sp 
     306#     include "lbc_lnk_nc_generic.h90" 
     307#     undef ROUTINE_MULTI_NC 
     308#     undef ROUTINE_NC_LOAD 
     309#  undef DIM_4d 
     310#  undef SINGLE_PRECISION 
     311   !! 
     312   !!   ----   DOUBLE PRECISION VERSIONS 
     313   !! 
     314 
     315#  define DIM_2d 
     316#     define ROUTINE_NC_LOAD           load_ptr_nc_2d_dp 
     317#     define ROUTINE_MULTI_NC          lbc_lnk_nc_2d_dp 
     318#     include "lbc_lnk_nc_generic.h90" 
     319#     undef ROUTINE_MULTI_NC 
     320#     undef ROUTINE_NC_LOAD 
     321#  undef DIM_2d 
     322 
     323#  define DIM_3d 
     324#     define ROUTINE_NC_LOAD           load_ptr_nc_3d_dp 
     325#     define ROUTINE_MULTI_NC          lbc_lnk_nc_3d_dp 
     326#     include "lbc_lnk_nc_generic.h90" 
     327#     undef ROUTINE_MULTI_NC 
     328#     undef ROUTINE_NC_LOAD 
     329#  undef DIM_3d 
     330 
     331#  define DIM_4d 
     332#     define ROUTINE_NC_LOAD           load_ptr_nc_4d_dp 
     333#     define ROUTINE_MULTI_NC          lbc_lnk_nc_4d_dp 
     334#     include "lbc_lnk_nc_generic.h90" 
     335#     undef ROUTINE_MULTI_NC 
     336#     undef ROUTINE_NC_LOAD 
     337#  undef DIM_4d 
     338 
     339   !!---------------------------------------------------------------------- 
     340   !!                   ***  routine mpp_lnk_nc_(2,3,4)d  *** 
     341   !! 
     342   !!   * Argument : dummy argument use in mpp_lnk_... routines 
     343   !!                ptab      :   array or pointer of arrays on which the boundary condition is applied 
     344   !!                cd_nat    :   nature of array grid-points 
     345   !!                psgn      :   sign used across the north fold boundary 
     346   !!                kfld      :   optional, number of pt3d arrays 
     347   !!                kfillmode :   optional, method to be use to fill the halos (see jpfill* variables) 
     348   !!                pfillval  :   optional, background value (used with jpfillcopy) 
     349   !!---------------------------------------------------------------------- 
     350   ! 
     351   !                       !==  2D array and array of 2D pointer  ==! 
     352   ! 
     353   !! 
     354   !!   ----   SINGLE PRECISION VERSIONS 
     355   !! 
     356# define SINGLE_PRECISION 
     357#  define DIM_2d 
     358#     define ROUTINE_NC           mpp_lnk_nc_2d_sp 
     359#     include "mpp_nc_generic.h90" 
     360#     undef ROUTINE_NC 
     361#  undef DIM_2d 
     362   ! 
     363   !                       !==  3D array and array of 3D pointer  ==! 
     364   ! 
     365#  define DIM_3d 
     366#     define ROUTINE_NC           mpp_lnk_nc_3d_sp 
     367#     include "mpp_nc_generic.h90" 
     368#     undef ROUTINE_NC 
     369#  undef DIM_3d 
     370   ! 
     371   !                       !==  4D array and array of 4D pointer  ==! 
     372   ! 
     373#  define DIM_4d 
     374#     define ROUTINE_NC           mpp_lnk_nc_4d_sp 
     375#     include "mpp_nc_generic.h90" 
     376#     undef ROUTINE_NC 
     377#  undef DIM_4d 
     378# undef SINGLE_PRECISION 
     379 
     380   !! 
     381   !!   ----   DOUBLE PRECISION VERSIONS 
     382   !! 
     383#  define DIM_2d 
     384#     define ROUTINE_NC           mpp_lnk_nc_2d_dp 
     385#     include "mpp_nc_generic.h90" 
     386#     undef ROUTINE_NC 
     387#  undef DIM_2d 
     388   ! 
     389   !                       !==  3D array and array of 3D pointer  ==! 
     390   ! 
     391#  define DIM_3d 
     392#     define ROUTINE_NC           mpp_lnk_nc_3d_dp 
     393#     include "mpp_nc_generic.h90" 
     394#     undef ROUTINE_NC 
     395#  undef DIM_3d 
     396   ! 
     397   !                       !==  4D array and array of 4D pointer  ==! 
     398   ! 
     399#  define DIM_4d 
     400#     define ROUTINE_NC           mpp_lnk_nc_4d_dp 
     401#     include "mpp_nc_generic.h90" 
     402#     undef ROUTINE_NC 
     403#  undef DIM_4d 
    252404 
    253405   !!---------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LBC/lib_mpp.F90

    r13998 r14023  
    6666   PUBLIC   mppscatter, mppgather 
    6767   PUBLIC   mpp_ini_znl 
     68   PUBLIC   mpp_ini_nc 
    6869   PUBLIC   mppsend, mpprecv                          ! needed by TAM and ICB routines 
    6970   PUBLIC   mppsend_sp, mpprecv_sp                          ! needed by TAM and ICB routines 
    … …  
    137138   INTEGER         ::   ndim_rank_znl   !  number of processors on the same zonal average 
    138139   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_znl  ! dimension ndim_rank_znl, number of the procs into the same znl domain 
     140 
     141   ! variables used for MPI3 neighbourhood collectives 
     142   INTEGER, PUBLIC :: mpi_nc_com                   ! MPI3 neighbourhood collectives communicator 
     143   INTEGER, PUBLIC :: mpi_nc_all_com               ! MPI3 neighbourhood collectives communicator (with diagionals) 
    139144 
    140145   ! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM) 
    … …  
    10671072 
    10681073   END SUBROUTINE mpp_ini_znl 
     1074 
     1075   SUBROUTINE mpp_ini_nc 
     1076      !!---------------------------------------------------------------------- 
     1077      !!               ***  routine mpp_ini_nc  *** 
     1078      !! 
     1079      !! ** Purpose :   Initialize special communicators for MPI3 neighbourhood 
     1080      !!                collectives 
     1081      !! 
     1082      !! ** Method  : - Create graph communicators starting from the processes    
     1083      !!                distribution along i and j directions 
     1084      ! 
     1085      !! ** output 
     1086      !!         mpi_nc_com = MPI3 neighbourhood collectives communicator 
     1087      !!         mpi_nc_all_com = MPI3 neighbourhood collectives communicator 
     1088      !!                          (with diagonals) 
     1089      !! 
     1090      !!---------------------------------------------------------------------- 
     1091      INTEGER, DIMENSION(:), ALLOCATABLE :: ineigh, ineighalls, ineighallr 
     1092      INTEGER :: ideg, idegalls, idegallr, icont, icont1 
     1093      INTEGER :: ierr 
     1094      LOGICAL, PARAMETER :: ireord = .FALSE. 
     1095 
     1096#if defined key_mpp_mpi 
     1097 
     1098      ideg = 0 
     1099      idegalls = 0 
     1100      idegallr = 0 
     1101      icont = 0 
     1102      icont1 = 0 
     1103 
     1104      IF (nbondi .eq. 1) THEN 
     1105         ideg = ideg + 1 
     1106      ELSEIF (nbondi .eq. -1) THEN 
     1107         ideg = ideg + 1 
     1108      ELSEIF (nbondi .eq. 0) THEN 
     1109         ideg = ideg + 2 
     1110      ENDIF 
     1111 
     1112      IF (nbondj .eq. 1) THEN 
     1113         ideg = ideg + 1 
     1114      ELSEIF (nbondj .eq. -1) THEN 
     1115         ideg = ideg + 1 
     1116      ELSEIF (nbondj .eq. 0) THEN 
     1117         ideg = ideg + 2 
     1118      ENDIF 
     1119 
     1120      idegalls = ideg 
     1121      idegallr = ideg 
     1122 
     1123      IF (nones .ne. -1) idegalls = idegalls + 1 
     1124      IF (nonws .ne. -1) idegalls = idegalls + 1 
     1125      IF (noses .ne. -1) idegalls = idegalls + 1 
     1126      IF (nosws .ne. -1) idegalls = idegalls + 1 
     1127      IF (noner .ne. -1) idegallr = idegallr + 1 
     1128      IF (nonwr .ne. -1) idegallr = idegallr + 1 
     1129      IF (noser .ne. -1) idegallr = idegallr + 1 
     1130      IF (noswr .ne. -1) idegallr = idegallr + 1 
     1131 
     1132      ALLOCATE(ineigh(ideg)) 
     1133      ALLOCATE(ineighalls(idegalls)) 
     1134      ALLOCATE(ineighallr(idegallr)) 
     1135 
     1136      IF (nbondi .eq. 1) THEN 
     1137         icont = icont + 1 
     1138         ineigh(icont) = nowe 
     1139         ineighalls(icont) = nowe 
     1140         ineighallr(icont) = nowe 
     1141      ELSEIF (nbondi .eq. -1) THEN 
     1142         icont = icont + 1 
     1143         ineigh(icont) = noea 
     1144         ineighalls(icont) = noea 
     1145         ineighallr(icont) = noea 
     1146      ELSEIF (nbondi .eq. 0) THEN 
     1147         icont = icont + 1 
     1148         ineigh(icont) = nowe 
     1149         ineighalls(icont) = nowe 
     1150         ineighallr(icont) = nowe 
     1151         icont = icont + 1 
     1152         ineigh(icont) = noea 
     1153         ineighalls(icont) = noea 
     1154         ineighallr(icont) = noea 
     1155      ENDIF 
     1156 
     1157      IF (nbondj .eq. 1) THEN 
     1158         icont = icont + 1 
     1159         ineigh(icont) = noso 
     1160         ineighalls(icont) = noso 
     1161         ineighallr(icont) = noso 
     1162      ELSEIF (nbondj .eq. -1) THEN 
     1163         icont = icont + 1 
     1164         ineigh(icont) = nono 
     1165         ineighalls(icont) = nono 
     1166         ineighallr(icont) = nono 
     1167      ELSEIF (nbondj .eq. 0) THEN 
     1168         icont = icont + 1 
     1169         ineigh(icont) = noso 
     1170         ineighalls(icont) = noso 
     1171         ineighallr(icont) = noso 
     1172         icont = icont + 1 
     1173         ineigh(icont) = nono 
     1174         ineighalls(icont) = nono 
     1175         ineighallr(icont) = nono 
     1176      ENDIF 
     1177 
     1178      icont1 = icont 
     1179      IF (nosws .ne. -1) THEN 
     1180         icont = icont + 1 
     1181         ineighalls(icont) = nosws 
     1182      ENDIF 
     1183      IF (noses .ne. -1) THEN 
     1184         icont = icont + 1 
     1185         ineighalls(icont) = noses 
     1186      ENDIF 
     1187      IF (nonws .ne. -1) THEN 
     1188         icont = icont + 1 
     1189         ineighalls(icont) = nonws 
     1190      ENDIF 
     1191      IF (nones .ne. -1) THEN 
     1192         icont = icont + 1 
     1193         ineighalls(icont) = nones 
     1194      ENDIF 
     1195      IF (noswr .ne. -1) THEN 
     1196         icont1 = icont1 + 1 
     1197         ineighallr(icont1) = noswr 
     1198      ENDIF 
     1199      IF (noser .ne. -1) THEN 
     1200         icont1 = icont1 + 1 
     1201         ineighallr(icont1) = noser 
     1202      ENDIF 
     1203      IF (nonwr .ne. -1) THEN 
     1204         icont1 = icont1 + 1 
     1205         ineighallr(icont1) = nonwr 
     1206      ENDIF 
     1207      IF (noner .ne. -1) THEN 
     1208         icont1 = icont1 + 1 
     1209         ineighallr(icont1) = noner 
     1210      ENDIF 
     1211 
     1212      CALL MPI_Dist_graph_create_adjacent(mpi_comm_oce, ideg, ineigh, MPI_UNWEIGHTED, ideg, ineigh, MPI_UNWEIGHTED, MPI_INFO_NULL, ireord, mpi_nc_com, ierr) 
     1213      CALL MPI_Dist_graph_create_adjacent(mpi_comm_oce, idegallr, ineighallr, MPI_UNWEIGHTED, idegalls, ineighalls, MPI_UNWEIGHTED, MPI_INFO_NULL, ireord, mpi_nc_all_com, ierr) 
     1214 
     1215      DEALLOCATE (ineigh) 
     1216      DEALLOCATE (ineighalls) 
     1217      DEALLOCATE (ineighallr) 
     1218#endif 
     1219   END SUBROUTINE mpp_ini_nc 
     1220 
    10691221 
    10701222 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LBC/mpp_lnk_generic.h90

    r13286 r14023  
    7272 
    7373#if defined MULTI 
    74    SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv ) 
     74   SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ncsten ) 
    7575      INTEGER             , INTENT(in   ) ::   kfld        ! number of pt3d arrays 
    7676#else 
    77    SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn      , kfillmode, pfillval, lsend, lrecv ) 
     77   SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn      , kfillmode, pfillval, lsend, lrecv, ncsten ) 
    7878#endif 
    7979      ARRAY_TYPE(:,:,:,:,:)                                        ! array or pointer of arrays on which the boundary condition is applied 
    … …  
    8484      REAL(wp),             OPTIONAL, INTENT(in   ) ::   pfillval    ! background value (used at closed boundaries) 
    8585      LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in   ) ::   lsend, lrecv  ! communication with other 4 proc 
     86      LOGICAL,              OPTIONAL, INTENT(in   ) ::   ncsten      ! 5-point or 9-point stencil 
    8687      ! 
    8788      INTEGER  ::    ji,  jj,  jk,  jl,  jf      ! dummy loop indices 
    … …  
    100101      !!---------------------------------------------------------------------- 
    101102      ! 
     103#if defined key_mpi3 
     104#   if defined MULTI 
     105      CALL lbc_lnk_nc    ( cdname,  ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ncsten ) 
     106#   else 
     107      CALL lbc_lnk_nc_multi(cdname, ptab, cd_nat, psgn, kfillmode=kfillmode, pfillval=pfillval, lsend=lsend, lrecv=lrecv, ncsten=ncsten) 
     108#   endif 
     109#else 
     110 
    102111      ! ----------------------------------------- ! 
    103112      !     0. local variables initialization     ! 
    … …  
    387396      IF( llrecv_no )   DEALLOCATE( zrcv_no ) 
    388397      ! 
     398#endif 
    389399   END SUBROUTINE ROUTINE_LNK 
    390400#undef PRECISION 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LBC/mppini.F90

    r13998 r14023  
    542542      ij = ijn(narea) 
    543543      ! 
    544       ! set default neighbours 
    545       noso = ii_noso(narea) 
    546       nowe = ii_nowe(narea) 
    547       noea = ii_noea(narea) 
    548       nono = ii_nono(narea) 
    549544      jpi    = ijpi(ii,ij)   
    550545!!$      Nis0  = iis0(ii,ij) 
    … …  
    558553      njmpp = ijmppt(ii,ij) 
    559554      jpk = jpkglo                              ! third dim 
     555 
     556      ! set default neighbours 
     557      noso = ii_noso(narea) 
     558      nowe = ii_nowe(narea) 
     559      noea = ii_noea(narea) 
     560      nono = ii_nono(narea) 
     561 
     562      nones = -1 
     563      nonws = -1 
     564      noses = -1 
     565      nosws = -1 
     566       
     567      noner = -1 
     568      nonwr = -1 
     569      noser = -1 
     570      noswr = -1 
     571 
     572      IF((nbondi .eq. -1) .or. (nbondi .eq. 0)) THEN ! east neighbour exists 
     573         IF(ibondj(iin(noea+1),ijn(noea+1)) .eq. 0) THEN 
     574            nones = ii_nono(noea+1)                  ! east neighbour has north and south neighbours 
     575            noses = ii_noso(noea+1) 
     576         ELSEIF(ibondj(iin(noea+1),ijn(noea+1)) .eq. -1) THEN 
     577            nones = ii_nono(noea+1)                  ! east neighbour has north neighbour 
     578         ELSEIF(ibondj(iin(noea+1),ijn(noea+1)) .eq. 1) THEN 
     579            noses = ii_noso(noea+1)                  ! east neighbour has south neighbour 
     580         END IF 
     581      END IF 
     582      IF((nbondi .eq. 1) .or. (nbondi .eq. 0)) THEN  ! west neighbour exists 
     583         IF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. 0) THEN 
     584            nonws = ii_nono(nowe+1)                  ! west neighbour has north and south neighbours 
     585            nosws = ii_noso(nowe+1) 
     586         ELSEIF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. -1) THEN 
     587            nonws = ii_nono(nowe+1)                  ! west neighbour has north neighbour 
     588         ELSEIF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. 1)  THEN 
     589            nosws = ii_noso(nowe+1)                  ! west neighbour has north neighbour 
     590         END IF 
     591      END IF 
     592 
     593      IF((nbondj .eq. -1) .or. (nbondj .eq. 0)) THEN ! north neighbour exists 
     594         IF(ibondi(iin(nono+1),ijn(nono+1)) .eq. 0) THEN 
     595            noner = ii_noea(nono+1)                  ! north neighbour has east and west neighbours 
     596            nonwr = ii_nowe(nono+1) 
     597         ELSEIF(ibondi(iin(nono+1),ijn(nono+1)) .eq. -1) THEN 
     598            noner = ii_noea(nono+1)                  ! north neighbour has east neighbour 
     599         ELSEIF(ibondi(iin(nono+1),ijn(nono+1)) .eq. 1) THEN 
     600            nonwr = ii_nowe(nono+1)                  ! north neighbour has west neighbour 
     601         END IF 
     602      END IF 
     603      IF((nbondj .eq. 1) .or. (nbondj .eq. 0)) THEN  ! south neighbour exists 
     604         IF(ibondi(iin(noso+1),ijn(noso+1)) .eq. 0) THEN 
     605            noser = ii_noea(noso+1)                  ! south neighbour has east and west neighbours 
     606            noswr = ii_nowe(noso+1) 
     607         ELSEIF(ibondi(iin(noso+1),ijn(noso+1)) .eq. -1) THEN 
     608            noser = ii_noea(noso+1)                  ! south neighbour has east neighbour 
     609         ELSEIF(ibondi(iin(noso+1),ijn(noso+1)) .eq. 1) THEN 
     610            noswr = ii_nowe(noso+1)                  ! south neighbour has west neighbour 
     611         END IF 
     612      END IF 
     613 
    560614      ! 
    561615      CALL init_doloop                          ! set start/end indices of do-loop, depending on the halo width value (nn_hls)  
    … …  
    648702         ENDIF 
    649703      ENDIF 
     704 
     705      ! 
     706      CALL mpp_ini_nc        ! Initialize communicator for neighbourhood collective communications 
    650707      ! 
    651708      CALL init_ioipsl       ! Prepare NetCDF output file (if necessary) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LDF/ldfc1d_c2d.F90

    r13998 r14023  
    140140         END_2D 
    141141      CASE( 'TRA' )                       ! U- and V-points 
    142          DO_2D( 1, 1, 1, 1 ) 
     142         ! NOTE: [tiling-comms-merge] Change needed to preserve results with respect to the trunk 
     143         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    143144            pah1(ji,jj,1) = pUfac * MAX( e1u(ji,jj), e2u(ji,jj) )**knn 
    144145            pah2(ji,jj,1) = pUfac * MAX( e1v(ji,jj), e2v(ji,jj) )**knn 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LDF/ldftra.F90

    r13998 r14023  
    427427         zaht_min = 0.2_wp * aht0                                       ! minimum value for aht 
    428428         zDaht    = aht0 - zaht_min                                       
    429          DO_2D( 1, 1, 1, 1 ) 
     429         ! NOTE: [tiling-comms-merge] Change needed to preserve results with respect to the trunk 
     430         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    430431            !!gm CAUTION : here we assume lat/lon grid in 20deg N/S band (like all ORCA cfg) 
    431432            !!     ==>>>   The Coriolis value is identical for t- & u_points, and for v- and f-points 
    … …  
    725726      !! ** Action  : pu, pv increased by the eiv transport 
    726727      !!---------------------------------------------------------------------- 
    727       INTEGER                         , INTENT(in   ) ::   kt        ! ocean time-step index 
    728       INTEGER                         , INTENT(in   ) ::   kit000    ! first time step index 
    729       INTEGER                         , INTENT(in   ) ::   Kmm, Krhs ! ocean time level indices 
    730       CHARACTER(len=3)                , INTENT(in   ) ::   cdtype    ! =TRA or TRC (tracer indicator) 
    731       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu      ! in : 3 ocean transport components   [m3/s] 
    732       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pv      ! out: 3 ocean transport components   [m3/s] 
    733       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pw      ! increased by the eiv                [m3/s] 
     728      INTEGER                     , INTENT(in   ) ::   kt        ! ocean time-step index 
     729      INTEGER                     , INTENT(in   ) ::   kit000    ! first time step index 
     730      INTEGER                     , INTENT(in   ) ::   Kmm, Krhs ! ocean time level indices 
     731      CHARACTER(len=3)            , INTENT(in   ) ::   cdtype    ! =TRA or TRC (tracer indicator) 
     732      REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) ::   pu        ! in : 3 ocean transport components   [m3/s] 
     733      REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) ::   pv        ! out: 3 ocean transport components   [m3/s] 
     734      REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) ::   pw        ! increased by the eiv                [m3/s] 
    734735      !! 
    735736      INTEGER  ::   ji, jj, jk                 ! dummy loop indices 
    736737      REAL(wp) ::   zuwk, zuwk1, zuwi, zuwi1   ! local scalars 
    737738      REAL(wp) ::   zvwk, zvwk1, zvwj, zvwj1   !   -      - 
    738       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zpsi_uw, zpsi_vw 
    739       !!---------------------------------------------------------------------- 
    740       ! 
    741       IF( kt == kit000 )  THEN 
    742          IF(lwp) WRITE(numout,*) 
    743          IF(lwp) WRITE(numout,*) 'ldf_eiv_trp : eddy induced advection on ', cdtype,' :' 
    744          IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   add to velocity fields the eiv component' 
     739      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::   zpsi_uw, zpsi_vw 
     740      !!---------------------------------------------------------------------- 
     741      ! 
     742      IF( ntile == 0 .OR. ntile == 1 )  THEN                       ! Do only on the first tile 
     743         IF( kt == kit000 )  THEN 
     744            IF(lwp) WRITE(numout,*) 
     745            IF(lwp) WRITE(numout,*) 'ldf_eiv_trp : eddy induced advection on ', cdtype,' :' 
     746            IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   add to velocity fields the eiv component' 
     747         ENDIF 
    745748      ENDIF 
    746749 
    … …  
    781784      !! 
    782785      !!---------------------------------------------------------------------- 
    783       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   psi_uw, psi_vw   ! streamfunction   [m3/s] 
    784       INTEGER                         , INTENT(in   ) ::   Kmm   ! ocean time level indices 
     786      REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) ::   psi_uw, psi_vw   ! streamfunction   [m3/s] 
     787      INTEGER                     , INTENT(in   ) ::   Kmm   ! ocean time level indices 
    785788      ! 
    786789      INTEGER  ::   ji, jj, jk    ! dummy loop indices 
    787790      REAL(wp) ::   zztmp   ! local scalar 
    788       REAL(wp), DIMENSION(jpi,jpj)     ::   zw2d   ! 2D workspace 
    789       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zw3d   ! 3D workspace 
     791      REAL(wp), DIMENSION(A2D(nn_hls))     ::   zw2d   ! 2D workspace 
     792      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::   zw3d   ! 3D workspace 
    790793      !!---------------------------------------------------------------------- 
    791794      ! 
    … …  
    793796!!gm     to be redesigned....    
    794797      !                                                  !==  eiv stream function: output  ==! 
    795       CALL lbc_lnk_multi( 'ldftra', psi_uw, 'U', -1.0_wp , psi_vw, 'V', -1.0_wp ) 
    796       ! 
    797798!!gm      CALL iom_put( "psi_eiv_uw", psi_uw )                 ! output 
    798799!!gm      CALL iom_put( "psi_eiv_vw", psi_vw ) 
    … …  
    802803      zw3d(:,:,jpk) = 0._wp                                    ! bottom value always 0 
    803804      ! 
    804       DO jk = 1, jpkm1                                         ! e2u e3u u_eiv = -dk[psi_uw] 
    805          zw3d(:,:,jk) = ( psi_uw(:,:,jk+1) - psi_uw(:,:,jk) ) / ( e2u(:,:) * e3u(:,:,jk,Kmm) ) 
    806       END DO 
     805      DO_3D( 0, 0, 0, 0, 1, jpkm1 )                                  ! e2u e3u u_eiv = -dk[psi_uw] 
     806         zw3d(ji,jj,jk) = ( psi_uw(ji,jj,jk+1) - psi_uw(ji,jj,jk) ) / ( e2u(ji,jj) * e3u(ji,jj,jk,Kmm) ) 
     807      END_3D 
    807808      CALL iom_put( "uoce_eiv", zw3d ) 
    808809      ! 
    809       DO jk = 1, jpkm1                                         ! e1v e3v v_eiv = -dk[psi_vw] 
    810          zw3d(:,:,jk) = ( psi_vw(:,:,jk+1) - psi_vw(:,:,jk) ) / ( e1v(:,:) * e3v(:,:,jk,Kmm) ) 
    811       END DO 
     810      DO_3D( 0, 0, 0, 0, 1, jpkm1 )                                  ! e1v e3v v_eiv = -dk[psi_vw] 
     811         zw3d(ji,jj,jk) = ( psi_vw(ji,jj,jk+1) - psi_vw(ji,jj,jk) ) / ( e1v(ji,jj) * e3v(ji,jj,jk,Kmm) ) 
     812      END_3D 
    812813      CALL iom_put( "voce_eiv", zw3d ) 
    813814      ! 
    … …  
    816817            &              + psi_uw(ji,jj,jk) - psi_uw(ji-1,jj  ,jk)  ) / e1e2t(ji,jj) 
    817818      END_3D 
    818       CALL lbc_lnk( 'ldftra', zw3d, 'T', 1.0_wp )      ! lateral boundary condition 
    819819      CALL iom_put( "woce_eiv", zw3d ) 
    820820      ! 
    821821      IF( iom_use('weiv_masstr') ) THEN   ! vertical mass transport & its square value 
    822          zw2d(:,:) = rho0 * e1e2t(:,:) 
     822         DO_2D( 0, 0, 0, 0 ) 
     823            zw2d(ji,jj) = rho0 * e1e2t(ji,jj) 
     824         END_2D 
    823825         DO jk = 1, jpk 
    824826            zw3d(:,:,jk) = zw3d(:,:,jk) * zw2d(:,:) 
    … …  
    844846           zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 
    845847        END_3D 
    846         CALL lbc_lnk( 'ldftra', zw2d, 'U', -1.0_wp ) 
    847         CALL lbc_lnk( 'ldftra', zw3d, 'U', -1.0_wp ) 
    848848        CALL iom_put( "ueiv_heattr"  , zztmp * zw2d )                  ! heat transport in i-direction 
    849849        CALL iom_put( "ueiv_heattr3d", zztmp * zw3d )                  ! heat transport in i-direction 
    … …  
    865865         zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 
    866866      END_3D 
    867       CALL lbc_lnk( 'ldftra', zw2d, 'V', -1.0_wp ) 
    868       CALL iom_put( "veiv_heattr", zztmp * zw2d )                  !  heat transport in j-direction 
    869       CALL iom_put( "veiv_heattr", zztmp * zw3d )                  !  heat transport in j-direction 
     867      CALL iom_put( "veiv_heattr"  , zztmp * zw2d )                  !  heat transport in j-direction 
     868      CALL iom_put( "veiv_heattr3d", zztmp * zw3d )                  !  heat transport in j-direction 
    870869      ! 
    871870      IF( iom_use( 'sophteiv' ) )   CALL dia_ptr_hst( jp_tem, 'eiv', 0.5 * zw3d ) 
    … …  
    880879           zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 
    881880        END_3D 
    882         CALL lbc_lnk( 'ldftra', zw2d, 'U', -1.0_wp ) 
    883         CALL lbc_lnk( 'ldftra', zw3d, 'U', -1.0_wp ) 
    884881        CALL iom_put( "ueiv_salttr", zztmp * zw2d )                  ! salt transport in i-direction 
    885882        CALL iom_put( "ueiv_salttr3d", zztmp * zw3d )                ! salt transport in i-direction 
    … …  
    892889         zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) 
    893890      END_3D 
    894       CALL lbc_lnk( 'ldftra', zw2d, 'V', -1.0_wp ) 
    895       CALL iom_put( "veiv_salttr", zztmp * zw2d )                  !  salt transport in j-direction 
    896       CALL iom_put( "veiv_salttr", zztmp * zw3d )                  !  salt transport in j-direction 
     891      CALL iom_put( "veiv_salttr"  , zztmp * zw2d )                  !  salt transport in j-direction 
     892      CALL iom_put( "veiv_salttr3d", zztmp * zw3d )                  !  salt transport in j-direction 
    897893      ! 
    898894      IF( iom_use( 'sopsteiv' ) ) CALL dia_ptr_hst( jp_sal, 'eiv', 0.5 * zw3d ) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcflx.F90

    r13998 r14023  
    127127 
    128128         IF( ln_dm2dc ) THEN   ! modify now Qsr to include the diurnal cycle 
    129             qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * tmask(ji,jj,1) 
     129            qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * tmask(:,:,1) 
    130130         ELSE 
    131131            DO_2D( 0, 0, 0, 0 ) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/eosbn2.F90

    r13998 r14023  
    3939   !!---------------------------------------------------------------------- 
    4040   USE dom_oce        ! ocean space and time domain 
     41   USE domutl, ONLY : is_tile 
    4142   USE phycst         ! physical constants 
    4243   USE stopar         ! Stochastic T/S fluctuations 
    … …  
    189190 
    190191   SUBROUTINE eos_insitu( pts, prd, pdep ) 
     192      !! 
     193      REAL(wp), DIMENSION(:,:,:,:), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celsius] 
     194      !                                                      ! 2 : salinity               [psu] 
     195      REAL(wp), DIMENSION(:,:,:)  , INTENT(  out) ::   prd   ! in situ density            [-] 
     196      REAL(wp), DIMENSION(:,:,:)  , INTENT(in   ) ::   pdep  ! depth                      [m] 
     197      !! 
     198      CALL eos_insitu_t( pts, is_tile(pts), prd, is_tile(prd), pdep, is_tile(pdep) ) 
     199   END SUBROUTINE eos_insitu 
     200 
     201   SUBROUTINE eos_insitu_t( pts, ktts, prd, ktrd, pdep, ktdep ) 
    191202      !!---------------------------------------------------------------------- 
    192203      !!                   ***  ROUTINE eos_insitu  *** 
    … …  
    222233      !!                TEOS-10 Manual, 2010 
    223234      !!---------------------------------------------------------------------- 
    224       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celsius] 
    225       !                                                               ! 2 : salinity               [psu] 
    226       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prd   ! in situ density            [-] 
    227       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pdep  ! depth                      [m] 
     235      INTEGER                                 , INTENT(in   ) ::   ktts, ktrd, ktdep 
     236      REAL(wp), DIMENSION(A2D_T(ktts) ,JPK,JPTS), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celsius] 
     237      !                                                                  ! 2 : salinity               [psu] 
     238      REAL(wp), DIMENSION(A2D_T(ktrd) ,JPK     ), INTENT(  out) ::   prd   ! in situ density            [-] 
     239      REAL(wp), DIMENSION(A2D_T(ktdep),JPK     ), INTENT(in   ) ::   pdep  ! depth                      [m] 
    228240      ! 
    229241      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
    … …  
    238250      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    239251         ! 
    240          DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     252         DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    241253            ! 
    242254            zh  = pdep(ji,jj,jk) * r1_Z0                                  ! depth 
    … …  
    274286      CASE( np_seos )                !==  simplified EOS  ==! 
    275287         ! 
    276          DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     288         DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    277289            zt  = pts  (ji,jj,jk,jp_tem) - 10._wp 
    278290            zs  = pts  (ji,jj,jk,jp_sal) - 35._wp 
    … …  
    293305      IF( ln_timing )   CALL timing_stop('eos-insitu') 
    294306      ! 
    295    END SUBROUTINE eos_insitu 
     307   END SUBROUTINE eos_insitu_t 
    296308 
    297309 
    298310   SUBROUTINE eos_insitu_pot( pts, prd, prhop, pdep ) 
     311      !! 
     312      REAL(wp), DIMENSION(:,:,:,:), INTENT(in   ) ::   pts    ! 1 : potential temperature  [Celsius] 
     313      !                                                       ! 2 : salinity               [psu] 
     314      REAL(wp), DIMENSION(:,:,:)  , INTENT(  out) ::   prd    ! in situ density            [-] 
     315      REAL(wp), DIMENSION(:,:,:)  , INTENT(  out) ::   prhop  ! potential density (surface referenced) 
     316      REAL(wp), DIMENSION(:,:,:)  , INTENT(in   ) ::   pdep   ! depth                      [m] 
     317      !! 
     318      CALL eos_insitu_pot_t( pts, is_tile(pts), prd, is_tile(prd), prhop, is_tile(prhop), pdep, is_tile(pdep) ) 
     319   END SUBROUTINE eos_insitu_pot 
     320 
     321 
     322   SUBROUTINE eos_insitu_pot_t( pts, ktts, prd, ktrd, prhop, ktrhop, pdep, ktdep ) 
    299323      !!---------------------------------------------------------------------- 
    300324      !!                  ***  ROUTINE eos_insitu_pot  *** 
    … …  
    309333      !! 
    310334      !!---------------------------------------------------------------------- 
    311       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts    ! 1 : potential temperature  [Celsius] 
    312       !                                                                ! 2 : salinity               [psu] 
    313       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prd    ! in situ density            [-] 
    314       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prhop  ! potential density (surface referenced) 
    315       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pdep   ! depth                      [m] 
     335      INTEGER                                  , INTENT(in   ) ::   ktts, ktrd, ktrhop, ktdep 
     336      REAL(wp), DIMENSION(A2D_T(ktts)  ,JPK,JPTS), INTENT(in   ) ::   pts    ! 1 : potential temperature  [Celsius] 
     337      !                                                                    ! 2 : salinity               [psu] 
     338      REAL(wp), DIMENSION(A2D_T(ktrd)  ,JPK     ), INTENT(  out) ::   prd    ! in situ density            [-] 
     339      REAL(wp), DIMENSION(A2D_T(ktrhop),JPK     ), INTENT(  out) ::   prhop  ! potential density (surface referenced) 
     340      REAL(wp), DIMENSION(A2D_T(ktdep) ,JPK     ), INTENT(in   ) ::   pdep   ! depth                      [m] 
    316341      ! 
    317342      INTEGER  ::   ji, jj, jk, jsmp             ! dummy loop indices 
    … …  
    338363            END DO 
    339364            ! 
    340             DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     365            DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    341366               ! 
    342367               ! compute density (2*nn_sto_eos) times: 
    … …  
    388413         ! Non-stochastic equation of state 
    389414         ELSE 
    390             DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     415            DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    391416               ! 
    392417               zh  = pdep(ji,jj,jk) * r1_Z0                                  ! depth 
    … …  
    426451      CASE( np_seos )                !==  simplified EOS  ==! 
    427452         ! 
    428          DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     453         DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    429454            zt  = pts  (ji,jj,jk,jp_tem) - 10._wp 
    430455            zs  = pts  (ji,jj,jk,jp_sal) - 35._wp 
    … …  
    444469      END SELECT 
    445470      ! 
    446       IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', tab3d_2=prhop, clinfo2=' pot : ', kdim=jpk ) 
     471      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', & 
     472         &                                  tab3d_2=prhop, clinfo2=' pot : ', kdim=jpk ) 
    447473      ! 
    448474      IF( ln_timing )   CALL timing_stop('eos-pot') 
    449475      ! 
    450    END SUBROUTINE eos_insitu_pot 
     476   END SUBROUTINE eos_insitu_pot_t 
    451477 
    452478 
    453479   SUBROUTINE eos_insitu_2d( pts, pdep, prd ) 
     480      !! 
     481      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celsius] 
     482      !                                                    ! 2 : salinity               [psu] 
     483      REAL(wp), DIMENSION(:,:)  , INTENT(in   ) ::   pdep  ! depth                      [m] 
     484      REAL(wp), DIMENSION(:,:)  , INTENT(  out) ::   prd   ! in situ density 
     485      !! 
     486      CALL eos_insitu_2d_t( pts, is_tile(pts), pdep, is_tile(pdep), prd, is_tile(prd) ) 
     487   END SUBROUTINE eos_insitu_2d 
     488 
     489 
     490   SUBROUTINE eos_insitu_2d_t( pts, ktts, pdep, ktdep, prd, ktrd ) 
    454491      !!---------------------------------------------------------------------- 
    455492      !!                  ***  ROUTINE eos_insitu_2d  *** 
    … …  
    462499      !! 
    463500      !!---------------------------------------------------------------------- 
    464       REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celsius] 
    465       !                                                           ! 2 : salinity               [psu] 
    466       REAL(wp), DIMENSION(jpi,jpj)     , INTENT(in   ) ::   pdep  ! depth                      [m] 
    467       REAL(wp), DIMENSION(jpi,jpj)     , INTENT(  out) ::   prd   ! in situ density 
     501      INTEGER                            , INTENT(in   ) ::   ktts, ktdep, ktrd 
     502      REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celsius] 
     503      !                                                             ! 2 : salinity               [psu] 
     504      REAL(wp), DIMENSION(A2D_T(ktdep)    ), INTENT(in   ) ::   pdep  ! depth                      [m] 
     505      REAL(wp), DIMENSION(A2D_T(ktrd)     ), INTENT(  out) ::   prd   ! in situ density 
    468506      ! 
    469507      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
    … …  
    480518      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    481519         ! 
    482          DO_2D( 1, 1, 1, 1 ) 
     520         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    483521            ! 
    484522            zh  = pdep(ji,jj) * r1_Z0                                  ! depth 
    … …  
    515553      CASE( np_seos )                !==  simplified EOS  ==! 
    516554         ! 
    517          DO_2D( 1, 1, 1, 1 ) 
     555         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    518556            ! 
    519557            zt    = pts  (ji,jj,jp_tem)  - 10._wp 
    … …  
    535573      IF( ln_timing )   CALL timing_stop('eos2d') 
    536574      ! 
    537    END SUBROUTINE eos_insitu_2d 
     575   END SUBROUTINE eos_insitu_2d_t 
    538576 
    539577 
    540578   SUBROUTINE rab_3d( pts, pab, Kmm ) 
     579      !! 
     580      INTEGER                     , INTENT(in   ) ::   Kmm   ! time level index 
     581      REAL(wp), DIMENSION(:,:,:,:), INTENT(in   ) ::   pts   ! pot. temperature & salinity 
     582      REAL(wp), DIMENSION(:,:,:,:), INTENT(  out) ::   pab   ! thermal/haline expansion ratio 
     583      !! 
     584      CALL rab_3d_t( pts, is_tile(pts), pab, is_tile(pab), Kmm ) 
     585   END SUBROUTINE rab_3d 
     586 
     587 
     588   SUBROUTINE rab_3d_t( pts, ktts, pab, ktab, Kmm ) 
    541589      !!---------------------------------------------------------------------- 
    542590      !!                 ***  ROUTINE rab_3d  *** 
    … …  
    548596      !! ** Action  : - pab     : thermal/haline expansion ratio at T-points 
    549597      !!---------------------------------------------------------------------- 
    550       INTEGER                              , INTENT(in   ) ::   Kmm   ! time level index 
    551       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts   ! pot. temperature & salinity 
    552       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(  out) ::   pab   ! thermal/haline expansion ratio 
     598      INTEGER                                , INTENT(in   ) ::   Kmm   ! time level index 
     599      INTEGER                                , INTENT(in   ) ::   ktts, ktab 
     600      REAL(wp), DIMENSION(A2D_T(ktts),JPK,JPTS), INTENT(in   ) ::   pts   ! pot. temperature & salinity 
     601      REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT(  out) ::   pab   ! thermal/haline expansion ratio 
    553602      ! 
    554603      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
    … …  
    563612      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    564613         ! 
    565          DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     614         DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    566615            ! 
    567616            zh  = gdept(ji,jj,jk,Kmm) * r1_Z0                                ! depth 
    … …  
    616665      CASE( np_seos )                  !==  simplified EOS  ==! 
    617666         ! 
    618          DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     667         DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    619668            zt  = pts (ji,jj,jk,jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0) 
    620669            zs  = pts (ji,jj,jk,jp_sal) - 35._wp   ! abs. salinity anomaly (s-S0) 
    … …  
    641690      IF( ln_timing )   CALL timing_stop('rab_3d') 
    642691      ! 
    643    END SUBROUTINE rab_3d 
     692   END SUBROUTINE rab_3d_t 
    644693 
    645694 
    646695   SUBROUTINE rab_2d( pts, pdep, pab, Kmm ) 
     696      !! 
     697      INTEGER                   , INTENT(in   ) ::   Kmm   ! time level index 
     698      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pts    ! pot. temperature & salinity 
     699      REAL(wp), DIMENSION(:,:)  , INTENT(in   ) ::   pdep   ! depth                  [m] 
     700      REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   pab    ! thermal/haline expansion ratio 
     701      !! 
     702      CALL rab_2d_t(pts, is_tile(pts), pdep, is_tile(pdep), pab, is_tile(pab), Kmm) 
     703   END SUBROUTINE rab_2d 
     704 
     705 
     706   SUBROUTINE rab_2d_t( pts, ktts, pdep, ktdep, pab, ktab, Kmm ) 
    647707      !!---------------------------------------------------------------------- 
    648708      !!                 ***  ROUTINE rab_2d  *** 
    … …  
    652712      !! ** Action  : - pab     : thermal/haline expansion ratio at T-points 
    653713      !!---------------------------------------------------------------------- 
    654       INTEGER                              , INTENT(in   ) ::   Kmm   ! time level index 
    655       REAL(wp), DIMENSION(jpi,jpj,jpts)    , INTENT(in   ) ::   pts    ! pot. temperature & salinity 
    656       REAL(wp), DIMENSION(jpi,jpj)         , INTENT(in   ) ::   pdep   ! depth                  [m] 
    657       REAL(wp), DIMENSION(jpi,jpj,jpts)    , INTENT(  out) ::   pab    ! thermal/haline expansion ratio 
     714      INTEGER                            , INTENT(in   ) ::   Kmm   ! time level index 
     715      INTEGER                            , INTENT(in   ) ::   ktts, ktdep, ktab 
     716      REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in   ) ::   pts    ! pot. temperature & salinity 
     717      REAL(wp), DIMENSION(A2D_T(ktdep)    ), INTENT(in   ) ::   pdep   ! depth                  [m] 
     718      REAL(wp), DIMENSION(A2D_T(ktab),JPTS), INTENT(  out) ::   pab    ! thermal/haline expansion ratio 
    658719      ! 
    659720      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
    … …  
    670731      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    671732         ! 
    672          DO_2D( 1, 1, 1, 1 ) 
     733         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    673734            ! 
    674735            zh  = pdep(ji,jj) * r1_Z0                                  ! depth 
    … …  
    723784      CASE( np_seos )                  !==  simplified EOS  ==! 
    724785         ! 
    725          DO_2D( 1, 1, 1, 1 ) 
     786         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    726787            ! 
    727788            zt    = pts  (ji,jj,jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0) 
    … …  
    748809      IF( ln_timing )   CALL timing_stop('rab_2d') 
    749810      ! 
    750    END SUBROUTINE rab_2d 
     811   END SUBROUTINE rab_2d_t 
    751812 
    752813 
    … …  
    849910 
    850911   SUBROUTINE bn2( pts, pab, pn2, Kmm ) 
     912      !! 
     913      INTEGER                              , INTENT(in   ) ::  Kmm   ! time level index 
     914      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::  pts   ! pot. temperature and salinity   [Celsius,psu] 
     915      REAL(wp), DIMENSION(:,:,:,:)         , INTENT(in   ) ::  pab   ! thermal/haline expansion coef.  [Celsius-1,psu-1] 
     916      REAL(wp), DIMENSION(:,:,:)           , INTENT(  out) ::  pn2   ! Brunt-Vaisala frequency squared [1/s^2] 
     917      !! 
     918      CALL bn2_t( pts, pab, is_tile(pab), pn2, is_tile(pn2), Kmm ) 
     919   END SUBROUTINE bn2 
     920 
     921 
     922   SUBROUTINE bn2_t( pts, pab, ktab, pn2, ktn2, Kmm ) 
    851923      !!---------------------------------------------------------------------- 
    852924      !!                  ***  ROUTINE bn2  *** 
    … …  
    862934      !! 
    863935      !!---------------------------------------------------------------------- 
    864       INTEGER                              , INTENT(in   ) ::   Kmm   ! time level index 
    865       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::  pts   ! pot. temperature and salinity   [Celsius,psu] 
    866       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::  pab   ! thermal/haline expansion coef.  [Celsius-1,psu-1] 
    867       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::  pn2   ! Brunt-Vaisala frequency squared [1/s^2] 
     936      INTEGER                                , INTENT(in   ) ::  Kmm   ! time level index 
     937      INTEGER                                , INTENT(in   ) ::  ktab, ktn2 
     938      REAL(wp), DIMENSION(jpi,jpj,  jpk,jpts), INTENT(in   ) ::  pts   ! pot. temperature and salinity   [Celsius,psu] 
     939      REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT(in   ) ::  pab   ! thermal/haline expansion coef.  [Celsius-1,psu-1] 
     940      REAL(wp), DIMENSION(A2D_T(ktn2),JPK     ), INTENT(  out) ::  pn2   ! Brunt-Vaisala frequency squared [1/s^2] 
    868941      ! 
    869942      INTEGER  ::   ji, jj, jk      ! dummy loop indices 
    … …  
    873946      IF( ln_timing )   CALL timing_start('bn2') 
    874947      ! 
    875       DO_3D( 1, 1, 1, 1, 2, jpkm1 )      ! interior points only (2=< jk =< jpkm1 ); surface and bottom value set to zero one for all in istate.F90 
     948      DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 2, jpkm1 )      ! interior points only (2=< jk =< jpkm1 ); surface and bottom value set to zero one for all in istate.F90 
    876949         zrw =   ( gdepw(ji,jj,jk  ,Kmm) - gdept(ji,jj,jk,Kmm) )   & 
    877950            &  / ( gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm) )  
    … …  
    889962      IF( ln_timing )   CALL timing_stop('bn2') 
    890963      ! 
    891    END SUBROUTINE bn2 
     964   END SUBROUTINE bn2_t 
    892965 
    893966 
    … …  
    9491022 
    9501023 
    951    SUBROUTINE  eos_fzp_2d( psal, ptf, pdep ) 
     1024   SUBROUTINE eos_fzp_2d( psal, ptf, pdep ) 
     1025      !! 
     1026      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   )           ::   psal   ! salinity   [psu] 
     1027      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ), OPTIONAL ::   pdep   ! depth      [m] 
     1028      REAL(wp), DIMENSION(:,:)    , INTENT(out  )           ::   ptf    ! freezing temperature [Celsius] 
     1029      !! 
     1030      CALL eos_fzp_2d_t( psal, ptf, is_tile(ptf), pdep ) 
     1031   END SUBROUTINE eos_fzp_2d 
     1032 
     1033 
     1034   SUBROUTINE  eos_fzp_2d_t( psal, ptf, kttf, pdep ) 
    9521035      !!---------------------------------------------------------------------- 
    9531036      !!                 ***  ROUTINE eos_fzp  *** 
    … …  
    9611044      !! Reference  :   UNESCO tech. papers in the marine science no. 28. 1978 
    9621045      !!---------------------------------------------------------------------- 
    963       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   )           ::   psal   ! salinity   [psu] 
    964       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ), OPTIONAL ::   pdep   ! depth      [m] 
    965       REAL(wp), DIMENSION(jpi,jpj), INTENT(out  )           ::   ptf    ! freezing temperature [Celsius] 
     1046      INTEGER                       , INTENT(in   )           ::   kttf 
     1047      REAL(wp), DIMENSION(jpi,jpj)  , INTENT(in   )           ::   psal   ! salinity   [psu] 
     1048      REAL(wp), DIMENSION(jpi,jpj)  , INTENT(in   ), OPTIONAL ::   pdep   ! depth      [m] 
     1049      REAL(wp), DIMENSION(A2D_T(kttf)), INTENT(out  )           ::   ptf    ! freezing temperature [Celsius] 
    9661050      ! 
    9671051      INTEGER  ::   ji, jj          ! dummy loop indices 
    … …  
    9961080      END SELECT       
    9971081      ! 
    998   END SUBROUTINE eos_fzp_2d 
     1082  END SUBROUTINE eos_fzp_2d_t 
    9991083 
    10001084 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traadv.F90

    r13237 r14023  
    1818   USE oce            ! ocean dynamics and active tracers 
    1919   USE dom_oce        ! ocean space and time domain 
     20   ! TEMP: [tiling] This change not necessary after extended haloes development 
     21   USE domain, ONLY : dom_tile 
    2022   USE domvvl         ! variable vertical scale factors 
    2123   USE sbcwave        ! wave module 
    … …  
    2325   USE traadv_cen     ! centered scheme            (tra_adv_cen  routine) 
    2426   USE traadv_fct     ! FCT      scheme            (tra_adv_fct  routine) 
     27   USE traadv_fct_lf  ! FCT      scheme            (tra_adv_fct  routine - loop fusion version) 
    2528   USE traadv_mus     ! MUSCL    scheme            (tra_adv_mus  routine) 
     29   USE traadv_mus_lf  ! MUSCL    scheme            (tra_adv_mus  routine - loop fusion version) 
    2630   USE traadv_ubs     ! UBS      scheme            (tra_adv_ubs  routine) 
    2731   USE traadv_qck     ! QUICKEST scheme            (tra_adv_qck  routine) 
    … …  
    6569   INTEGER, PARAMETER ::   np_UBS     = 4   ! 3rd order Upstream Biased Scheme 
    6670   INTEGER, PARAMETER ::   np_QCK     = 5   ! QUICK scheme 
    67     
     71 
     72   !! * Substitutions 
     73#  include "do_loop_substitute.h90" 
    6874#  include "domzgr_substitute.h90" 
    6975   !!---------------------------------------------------------------------- 
    … …  
    8692      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts            ! active tracers and RHS of tracer equation 
    8793      ! 
    88       INTEGER ::   jk   ! dummy loop index 
    89       REAL(wp), DIMENSION(jpi,jpj,jpk)        :: zuu, zvv, zww   ! 3D workspace 
    90       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztrdt, ztrds 
     94      INTEGER ::   ji, jj, jk   ! dummy loop index 
     95      ! TEMP: [tiling] This change not necessary and can be A2D(nn_hls) if using XIOS (subdomain support) 
     96      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: zuu, zvv, zww   ! 3D workspace 
     97      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds 
     98      ! TEMP: [tiling] This change not necessary after extra haloes development 
     99      LOGICAL :: lskip 
    91100      !!---------------------------------------------------------------------- 
    92101      ! 
    93102      IF( ln_timing )   CALL timing_start('tra_adv') 
    94103      ! 
    95       !                                         !==  effective transport  ==! 
    96       zuu(:,:,jpk) = 0._wp 
    97       zvv(:,:,jpk) = 0._wp 
    98       zww(:,:,jpk) = 0._wp 
    99       IF( ln_wave .AND. ln_sdw )  THEN 
    100          DO jk = 1, jpkm1                                                       ! eulerian transport + Stokes Drift 
    101             zuu(:,:,jk) =   & 
    102                &  e2u  (:,:) * e3u(:,:,jk,Kmm) * ( uu(:,:,jk,Kmm) + usd(:,:,jk) ) 
    103             zvv(:,:,jk) =   &  
    104                &  e1v  (:,:) * e3v(:,:,jk,Kmm) * ( vv(:,:,jk,Kmm) + vsd(:,:,jk) ) 
    105             zww(:,:,jk) =   &  
    106                &  e1e2t(:,:)                 * ( ww(:,:,jk) + wsd(:,:,jk) ) 
    107          END DO 
    108       ELSE 
    109          DO jk = 1, jpkm1 
    110             zuu(:,:,jk) = e2u  (:,:) * e3u(:,:,jk,Kmm) * uu(:,:,jk,Kmm)               ! eulerian transport only 
    111             zvv(:,:,jk) = e1v  (:,:) * e3v(:,:,jk,Kmm) * vv(:,:,jk,Kmm) 
    112             zww(:,:,jk) = e1e2t(:,:)                 * ww(:,:,jk) 
    113          END DO 
    114       ENDIF 
    115       ! 
    116       IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN                                ! add z-tilde and/or vvl corrections 
    117          zuu(:,:,:) = zuu(:,:,:) + un_td(:,:,:) 
    118          zvv(:,:,:) = zvv(:,:,:) + vn_td(:,:,:) 
    119       ENDIF 
    120       ! 
    121       zuu(:,:,jpk) = 0._wp                                                      ! no transport trough the bottom 
    122       zvv(:,:,jpk) = 0._wp 
    123       zww(:,:,jpk) = 0._wp 
    124       ! 
    125       IF( ln_ldfeiv .AND. .NOT. ln_traldf_triad )   & 
    126          &              CALL ldf_eiv_trp( kt, nit000, zuu, zvv, zww, 'TRA', Kmm, Krhs )   ! add the eiv transport (if necessary) 
    127       ! 
    128       IF( ln_mle    )   CALL tra_mle_trp( kt, nit000, zuu, zvv, zww, 'TRA', Kmm       )   ! add the mle transport (if necessary) 
    129       ! 
    130       CALL iom_put( "uocetr_eff", zuu )                                        ! output effective transport       
    131       CALL iom_put( "vocetr_eff", zvv ) 
    132       CALL iom_put( "wocetr_eff", zww ) 
    133       ! 
    134 !!gm ??? 
    135       CALL dia_ptr( kt, Kmm, zvv )                                    ! diagnose the effective MSF  
    136 !!gm ??? 
    137       ! 
    138  
    139       IF( l_trdtra )   THEN                    !* Save ta and sa trends 
    140          ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 
    141          ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 
    142          ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 
    143       ENDIF 
    144       ! 
    145       SELECT CASE ( nadv )                      !==  compute advection trend and add it to general trend  ==! 
    146       ! 
    147       CASE ( np_CEN )                                 ! Centered scheme : 2nd / 4th order 
    148          CALL tra_adv_cen    ( kt, nit000, 'TRA',         zuu, zvv, zww, Kmm, pts, jpts, Krhs, nn_cen_h, nn_cen_v ) 
    149       CASE ( np_FCT )                                 ! FCT scheme      : 2nd / 4th order 
    150          CALL tra_adv_fct    ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) 
    151       CASE ( np_MUS )                                 ! MUSCL 
    152          CALL tra_adv_mus    ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups )  
    153       CASE ( np_UBS )                                 ! UBS 
    154          CALL tra_adv_ubs    ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_ubs_v   ) 
    155       CASE ( np_QCK )                                 ! QUICKEST 
    156          CALL tra_adv_qck    ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs ) 
    157       ! 
    158       END SELECT 
    159       ! 
    160       IF( l_trdtra )   THEN                      ! save the advective trends for further diagnostics 
    161          DO jk = 1, jpkm1 
    162             ztrdt(:,:,jk) = pts(:,:,jk,jp_tem,Krhs) - ztrdt(:,:,jk) 
    163             ztrds(:,:,jk) = pts(:,:,jk,jp_sal,Krhs) - ztrds(:,:,jk) 
    164          END DO 
    165          CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_totad, ztrdt ) 
    166          CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_totad, ztrds ) 
    167          DEALLOCATE( ztrdt, ztrds ) 
     104      lskip = .FALSE. 
     105 
     106      ! TEMP: [tiling] These changes not necessary if using XIOS (subdomain support) 
     107      IF( ntile == 0 .OR. ntile == 1 )  THEN                       ! Do only on the first tile 
     108         ALLOCATE( zuu(jpi,jpj,jpk), zvv(jpi,jpj,jpk), zww(jpi,jpj,jpk) ) 
     109      ENDIF 
     110 
     111      ! TEMP: [tiling] These changes not necessary after extra haloes development (lbc_lnk removed from tra_adv_*) and if XIOS has subdomain support (ldf_eiv_dia) 
     112      IF( nadv /= np_CEN .OR. (nadv == np_CEN .AND. nn_cen_h == 4) .OR. ln_ldfeiv_dia )  THEN 
     113         IF( ln_tile ) THEN 
     114            IF( ntile == 1 ) THEN 
     115               CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) 
     116            ELSE 
     117               lskip = .TRUE. 
     118            ENDIF 
     119         ENDIF 
     120      ENDIF 
     121      IF( .NOT. lskip ) THEN 
     122         !                                         !==  effective transport  ==! 
     123         IF( ln_wave .AND. ln_sdw )  THEN 
     124            DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
     125               zuu(ji,jj,jk) = e2u  (ji,jj) * e3u(ji,jj,jk,Kmm) * ( uu(ji,jj,jk,Kmm) + usd(ji,jj,jk) ) 
     126               zvv(ji,jj,jk) = e1v  (ji,jj) * e3v(ji,jj,jk,Kmm) * ( vv(ji,jj,jk,Kmm) + vsd(ji,jj,jk) ) 
     127               zww(ji,jj,jk) = e1e2t(ji,jj)                     * ( ww(ji,jj,jk)     + wsd(ji,jj,jk) ) 
     128            END_3D 
     129         ELSE 
     130            DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
     131               zuu(ji,jj,jk) = e2u  (ji,jj) * e3u(ji,jj,jk,Kmm) * uu(ji,jj,jk,Kmm)               ! eulerian transport only 
     132               zvv(ji,jj,jk) = e1v  (ji,jj) * e3v(ji,jj,jk,Kmm) * vv(ji,jj,jk,Kmm) 
     133               zww(ji,jj,jk) = e1e2t(ji,jj)                     * ww(ji,jj,jk) 
     134            END_3D 
     135         ENDIF 
     136         ! 
     137         IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN                                ! add z-tilde and/or vvl corrections 
     138            DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
     139               zuu(ji,jj,jk) = zuu(ji,jj,jk) + un_td(ji,jj,jk) 
     140               zvv(ji,jj,jk) = zvv(ji,jj,jk) + vn_td(ji,jj,jk) 
     141            END_3D 
     142         ENDIF 
     143         ! 
     144         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
     145            zuu(ji,jj,jpk) = 0._wp                                                      ! no transport trough the bottom 
     146            zvv(ji,jj,jpk) = 0._wp 
     147            zww(ji,jj,jpk) = 0._wp 
     148         END_2D 
     149         ! 
     150         ! TEMP: [tiling] These changes not necessary if using XIOS (subdomain support) 
     151         IF( ln_ldfeiv .AND. .NOT. ln_traldf_triad )   & 
     152            &              CALL ldf_eiv_trp( kt, nit000, zuu(A2D(nn_hls),:), zvv(A2D(nn_hls),:), zww(A2D(nn_hls),:), & 
     153            &                                'TRA', Kmm, Krhs )   ! add the eiv transport (if necessary) 
     154         ! 
     155         IF( ln_mle    )   CALL tra_mle_trp( kt, nit000, zuu(A2D(nn_hls),:), zvv(A2D(nn_hls),:), zww(A2D(nn_hls),:), & 
     156            &                                'TRA', Kmm       )   ! add the mle transport (if necessary) 
     157         ! 
     158         ! TEMP: [tiling] This change not necessary if using XIOS (subdomain support) 
     159         IF( ntile == 0 .OR. ntile == nijtile )  THEN                ! Do only on the last tile 
     160            CALL iom_put( "uocetr_eff", zuu )                                        ! output effective transport 
     161            CALL iom_put( "vocetr_eff", zvv ) 
     162            CALL iom_put( "wocetr_eff", zww ) 
     163         ENDIF 
     164         ! 
     165   !!gm ??? 
     166         ! TEMP: [tiling] This change not necessary if using XIOS (subdomain support) 
     167         CALL dia_ptr( kt, Kmm, zvv(A2D(nn_hls),:) )                                    ! diagnose the effective MSF 
     168   !!gm ??? 
     169         ! 
     170 
     171         IF( l_trdtra )   THEN                    !* Save ta and sa trends 
     172            ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 
     173            ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 
     174            ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 
     175         ENDIF 
     176         ! 
     177         ! NOTE: [tiling-comms-merge] These lbc_lnk calls are still needed (pts in the zco case because zps_hde is not called in step, zuu/zvv/zww in all cases, I think because DO loop bounds need to be updated in DYN as done in TRA) 
     178         SELECT CASE ( nadv )                      !==  compute advection trend and add it to general trend  ==! 
     179         ! 
     180         CASE ( np_CEN )                                 ! Centered scheme : 2nd / 4th order 
     181            IF (nn_hls.EQ.2) CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kmm), 'T', 1. ) 
     182            CALL tra_adv_cen    ( kt, nit000, 'TRA',         zuu, zvv, zww, Kmm, pts, jpts, Krhs, nn_cen_h, nn_cen_v ) 
     183         CASE ( np_FCT )                                 ! FCT scheme      : 2nd / 4th order 
     184            IF (nn_hls.EQ.2) THEN 
     185               CALL lbc_lnk_multi( 'traadv', pts(:,:,:,:,Kbb), 'T', 1., pts(:,:,:,:,Kmm), 'T', 1.) 
     186               CALL lbc_lnk_multi( 'traadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1., zww(:,:,:), 'W', 1.) 
     187#if defined key_loop_fusion 
     188               CALL tra_adv_fct_lf ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) 
     189#else 
     190               CALL tra_adv_fct    ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) 
     191#endif 
     192            ELSE 
     193               CALL tra_adv_fct    ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) 
     194            END IF 
     195         CASE ( np_MUS )                                 ! MUSCL 
     196            ! NOTE: [tiling-comms-merge] I added this lbc_lnk as it did not validate against the trunk when using ln_zco 
     197            IF (nn_hls.EQ.2) THEN  
     198                CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kbb), 'T', 1.) 
     199#if defined key_loop_fusion 
     200                CALL tra_adv_mus_lf ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups )  
     201#else 
     202                CALL tra_adv_mus    ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups )  
     203#endif 
     204            ELSE 
     205                CALL tra_adv_mus    ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups )  
     206            END IF 
     207         CASE ( np_UBS )                                 ! UBS 
     208            IF (nn_hls.EQ.2) CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kbb), 'T', 1.) 
     209            CALL tra_adv_ubs    ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_ubs_v   ) 
     210         CASE ( np_QCK )                                 ! QUICKEST 
     211            IF (nn_hls.EQ.2) THEN 
     212               CALL lbc_lnk_multi( 'traadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1.) 
     213               CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kbb), 'T', 1.) 
     214            END IF 
     215            CALL tra_adv_qck    ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs ) 
     216         ! 
     217         END SELECT 
     218         ! 
     219         IF( l_trdtra )   THEN                      ! save the advective trends for further diagnostics 
     220            DO jk = 1, jpkm1 
     221               ztrdt(:,:,jk) = pts(:,:,jk,jp_tem,Krhs) - ztrdt(:,:,jk) 
     222               ztrds(:,:,jk) = pts(:,:,jk,jp_sal,Krhs) - ztrds(:,:,jk) 
     223            END DO 
     224            CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_totad, ztrdt ) 
     225            CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_totad, ztrds ) 
     226            DEALLOCATE( ztrdt, ztrds ) 
     227         ENDIF 
     228 
     229         ! TEMP: [tiling] This change not necessary after extra haloes development (lbc_lnk removed from tra_adv_*) and if XIOS has subdomain support (ldf_eiv_dia) 
     230         IF( ln_tile .AND. ntile == 0 ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 1 ) 
     231 
    168232      ENDIF 
    169233      !                                              ! print mean trends (used for debugging) 
    170       IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' adv  - Ta: ', mask1=tmask,               & 
     234      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' adv  - Ta: ', mask1=tmask, & 
    171235         &                                  tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     236 
     237      ! TEMP: [tiling] This change not necessary if using XIOS (subdomain support) 
     238      IF( ntile == 0 .OR. ntile == nijtile )  THEN                ! Do only for the full domain 
     239         DEALLOCATE( zuu, zvv, zww ) 
     240      ENDIF 
    172241      ! 
    173242      IF( ln_timing )   CALL timing_stop( 'tra_adv' ) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traadv_cen.F90

    r13998 r14023  
    7171      INTEGER                                  , INTENT(in   ) ::   kn_cen_h        ! =2/4 (2nd or 4th order scheme) 
    7272      INTEGER                                  , INTENT(in   ) ::   kn_cen_v        ! =2/4 (2nd or 4th order scheme) 
     73      ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 
    7374      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pU, pV, pW      ! 3 ocean volume flux components 
    7475      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! tracers and RHS of tracer equation 
    … …  
    7879      REAL(wp) ::   zC2t_u, zC4t_u   ! local scalars 
    7980      REAL(wp) ::   zC2t_v, zC4t_v   !   -      - 
    80       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwx, zwy, zwz, ztu, ztv, ztw 
     81      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::   zwx, zwy, zwz, ztu, ztv, ztw 
    8182      !!---------------------------------------------------------------------- 
    8283      ! 
    83       IF( kt == kit000 )  THEN 
    84          IF(lwp) WRITE(numout,*) 
    85          IF(lwp) WRITE(numout,*) 'tra_adv_cen : centered advection scheme on ', cdtype, ' order h/v =', kn_cen_h,'/', kn_cen_v 
    86          IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~ ' 
     84      IF( ntile == 0 .OR. ntile == 1 )  THEN                       ! Do only on the first tile 
     85         IF( kt == kit000 )  THEN 
     86            IF(lwp) WRITE(numout,*) 
     87            IF(lwp) WRITE(numout,*) 'tra_adv_cen : centered advection scheme on ', cdtype, ' order h/v =', kn_cen_h,'/', kn_cen_v 
     88            IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~ ' 
     89         ENDIF 
     90         !                          ! set local switches 
     91         l_trd = .FALSE. 
     92         l_hst = .FALSE. 
     93         l_ptr = .FALSE. 
     94         IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )       l_trd = .TRUE. 
     95         IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) )  )    l_ptr = .TRUE. 
     96         IF(   cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 
     97            &                          iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) )  l_hst = .TRUE. 
    8798      ENDIF 
    88       !                          ! set local switches 
    89       l_trd = .FALSE. 
    90       l_hst = .FALSE. 
    91       l_ptr = .FALSE. 
    92       IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )       l_trd = .TRUE. 
    93       IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) )  )    l_ptr = .TRUE.  
    94       IF(   cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 
    95          &                          iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) )  l_hst = .TRUE. 
    9699      ! 
    97100      !                     
    … …  
    112115            ztu(:,:,jpk) = 0._wp                   ! Bottom value : flux set to zero 
    113116            ztv(:,:,jpk) = 0._wp 
    114             DO_3D( 0, 0, 0, 0, 1, jpkm1 )          ! masked gradient 
     117            DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 )          ! masked gradient 
    115118               ztu(ji,jj,jk) = ( pt(ji+1,jj  ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 
    116119               ztv(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 
    117120            END_3D 
    118             CALL lbc_lnk_multi( 'traadv_cen', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp )   ! Lateral boundary cond. 
     121            IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_cen', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp )   ! Lateral boundary cond. 
    119122            ! 
    120             DO_3D( 0, 0, 0, 0, 1, jpkm1 )           ! Horizontal advective fluxes 
     123            DO_3D( nn_hls-1, 0, nn_hls-1, 0, 1, jpkm1 )           ! Horizontal advective fluxes 
    121124               zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj  ,jk,jn,Kmm)   ! C2 interpolation of T at u- & v-points (x2) 
    122125               zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) 
    … …  
    128131               zwy(ji,jj,jk) =  0.5_wp * pV(ji,jj,jk) * zC4t_v 
    129132            END_3D 
    130             CALL lbc_lnk_multi( 'traadv_cen', zwx, 'U', -1. , zwy, 'V', -1. ) 
     133            IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_cen', zwx, 'U', -1. , zwy, 'V', -1. ) 
    131134            ! 
    132135         CASE DEFAULT 
    … …  
    155158               END_2D 
    156159            ELSE                                   ! no ice-shelf cavities (only ocean surface) 
    157                zwz(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kmm) 
     160               DO_2D( 1, 1, 1, 1 ) 
     161                  zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kmm) 
     162               END_2D 
    158163            ENDIF 
    159164         ENDIF 
    … …  
    171176            CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, pt(:,:,:,jn,Kmm) ) 
    172177            CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwz, pW, pt(:,:,:,jn,Kmm) ) 
    173          END IF 
    174          !                                 ! "Poleward" heat and salt transports  
     178         ENDIF 
     179         !                                 ! "Poleward" heat and salt transports 
    175180         IF( l_ptr )   CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) 
    176181         !                                 !  heat and salt transport 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traadv_fct.F90

    r13998 r14023  
    3434   PUBLIC   tra_adv_fct        ! called by traadv.F90 
    3535   PUBLIC   interp_4th_cpt     ! called by traadv_cen.F90 
     36   PUBLIC   tridia_solver      ! called by traadv_fct_lf.F90 
     37   PUBLIC   nonosc             ! called by traadv_fct_lf.F90 - key_agrif 
    3638 
    3739   LOGICAL  ::   l_trd   ! flag to compute trends 
    … …  
    7981      INTEGER                                  , INTENT(in   ) ::   kn_fct_v        ! order of the FCT scheme (=2 or 4) 
    8082      REAL(wp)                                 , INTENT(in   ) ::   p2dt            ! tracer time-step 
     83      ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 
     84      ! NOTE: [tiling-comms-merge] These were changed to INTENT(inout) but they are not modified, so it is reverted 
    8185      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pU, pV, pW      ! 3 ocean volume flux components 
    8286      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! tracers and RHS of tracer equation 
    8387      ! 
    84       INTEGER  ::   ji, jj, jk, jn                           ! dummy loop indices   
     88      INTEGER  ::   ji, jj, jk, jn                           ! dummy loop indices 
    8589      REAL(wp) ::   ztra                                     ! local scalar 
    8690      REAL(wp) ::   zfp_ui, zfp_vj, zfp_wk, zC2t_u, zC4t_u   !   -      - 
    8791      REAL(wp) ::   zfm_ui, zfm_vj, zfm_wk, zC2t_v, zC4t_v   !   -      - 
    88       REAL(wp), DIMENSION(jpi,jpj,jpk)        ::   zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw 
     92      REAL(wp), DIMENSION(A2D(nn_hls),jpk)        ::   zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw 
    8993      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztrdx, ztrdy, ztrdz, zptry 
    9094      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   zwinf, zwdia, zwsup 
    … …  
    9296      !!---------------------------------------------------------------------- 
    9397      ! 
    94       IF( kt == kit000 )  THEN 
    95          IF(lwp) WRITE(numout,*) 
    96          IF(lwp) WRITE(numout,*) 'tra_adv_fct : FCT advection scheme on ', cdtype 
    97          IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
     98      IF( ntile == 0 .OR. ntile == 1 )  THEN                       ! Do only on the first tile 
     99         IF( kt == kit000 )  THEN 
     100            IF(lwp) WRITE(numout,*) 
     101            IF(lwp) WRITE(numout,*) 'tra_adv_fct : FCT advection scheme on ', cdtype 
     102            IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
     103         ENDIF 
     104         ! NOTE: [tiling-comms-merge] Bug fix- move array zeroing out of this IF block 
     105         ! 
     106         l_trd = .FALSE.            ! set local switches 
     107         l_hst = .FALSE. 
     108         l_ptr = .FALSE. 
     109         ll_zAimp = .FALSE. 
     110         IF( ( cdtype == 'TRA' .AND. l_trdtra  ) .OR. ( cdtype =='TRC' .AND. l_trdtrc ) )      l_trd = .TRUE. 
     111         IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) )    l_ptr = .TRUE. 
     112         IF(   cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR.  & 
     113            &                         iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) )  l_hst = .TRUE. 
     114         ! 
    98115      ENDIF 
     116 
    99117      !! -- init to 0 
    100118      zwi(:,:,:) = 0._wp 
    … …  
    108126      ztw(:,:,:) = 0._wp 
    109127      ! 
    110       l_trd = .FALSE.            ! set local switches 
    111       l_hst = .FALSE. 
    112       l_ptr = .FALSE. 
    113       ll_zAimp = .FALSE. 
    114       IF( ( cdtype == 'TRA' .AND. l_trdtra  ) .OR. ( cdtype =='TRC' .AND. l_trdtrc ) )      l_trd = .TRUE. 
    115       IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) )    l_ptr = .TRUE.  
    116       IF(   cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR.  & 
    117          &                         iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) )  l_hst = .TRUE. 
    118       ! 
    119128      IF( l_trd .OR. l_hst )  THEN 
    120          ALLOCATE( ztrdx(jpi,jpj,jpk), ztrdy(jpi,jpj,jpk), ztrdz(jpi,jpj,jpk) ) 
     129         ALLOCATE( ztrdx(A2D(nn_hls),jpk), ztrdy(A2D(nn_hls),jpk), ztrdz(A2D(nn_hls),jpk) ) 
    121130         ztrdx(:,:,:) = 0._wp   ;    ztrdy(:,:,:) = 0._wp   ;   ztrdz(:,:,:) = 0._wp 
    122131      ENDIF 
    123132      ! 
    124       IF( l_ptr ) THEN   
    125          ALLOCATE( zptry(jpi,jpj,jpk) ) 
     133      IF( l_ptr ) THEN 
     134         ALLOCATE( zptry(A2D(nn_hls),jpk) ) 
    126135         zptry(:,:,:) = 0._wp 
    127136      ENDIF 
    128       !                          ! surface & bottom value : flux set to zero one for all 
    129       zwz(:,:, 1 ) = 0._wp             
    130       zwx(:,:,jpk) = 0._wp   ;   zwy(:,:,jpk) = 0._wp    ;    zwz(:,:,jpk) = 0._wp 
    131       ! 
    132       zwi(:,:,:) = 0._wp         
    133137      ! 
    134138      ! If adaptive vertical advection, check if it is needed on this PE at this time 
    135139      IF( ln_zad_Aimp ) THEN 
    136          IF( MAXVAL( ABS( wi(:,:,:) ) ) > 0._wp ) ll_zAimp = .TRUE. 
     140         IF( MAXVAL( ABS( wi(A2D(nn_hls),:) ) ) > 0._wp ) ll_zAimp = .TRUE. 
    137141      END IF 
    138142      ! If active adaptive vertical advection, build tridiagonal matrix 
    139143      IF( ll_zAimp ) THEN 
    140          ALLOCATE(zwdia(jpi,jpj,jpk), zwinf(jpi,jpj,jpk),zwsup(jpi,jpj,jpk)) 
    141          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     144         ALLOCATE(zwdia(A2D(nn_hls),jpk), zwinf(A2D(nn_hls),jpk), zwsup(A2D(nn_hls),jpk)) 
     145         DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 ) 
    142146            zwdia(ji,jj,jk) =  1._wp + p2dt * ( MAX( wi(ji,jj,jk) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) )   & 
    143147            &                               / e3t(ji,jj,jk,Krhs) 
    … …  
    151155         !        !==  upstream advection with initial mass fluxes & intermediate update  ==! 
    152156         !                    !* upstream tracer flux in the i and j direction  
    153          DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 
     157         DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) 
    154158            ! upstream scheme 
    155159            zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) ) 
    … …  
    178182         ENDIF 
    179183         !                
    180          DO_3D( 0, 0, 0, 0, 1, jpkm1 )   !* trend and after field with monotonic scheme 
     184         DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )   !* trend and after field with monotonic scheme 
    181185            !                               ! total intermediate advective trends 
    182186            ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
    … …  
    194198            ! 
    195199            ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp ; 
    196             DO_3D( 0, 0, 0, 0, 2, jpkm1 )       ! Interior value ( multiplied by wmask) 
     200            DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )       ! Interior value ( multiplied by wmask) 
    197201               zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 
    198202               zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 
    … …  
    206210            ! 
    207211         END IF 
    208          !                 
     212         ! 
    209213         IF( l_trd .OR. l_hst )  THEN             ! trend diagnostics (contribution of upstream fluxes) 
    210214            ztrdx(:,:,:) = zwx(:,:,:)   ;   ztrdy(:,:,:) = zwy(:,:,:)   ;   ztrdz(:,:,:) = zwz(:,:,:) 
    … …  
    218222         ! 
    219223         CASE(  2  )                   !- 2nd order centered 
    220             DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 
     224            DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) 
    221225               zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj,jk,jn,Kmm) ) - zwx(ji,jj,jk) 
    222226               zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj+1,jk,jn,Kmm) ) - zwy(ji,jj,jk) 
    … …  
    238242            CALL lbc_lnk_multi( 'traadv_fct', zltu, 'T', 1.0_wp , zltv, 'T', 1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
    239243            ! 
    240             DO_3D( 1, 0, 1, 0, 1, jpkm1 )    ! Horizontal advective fluxes 
     244            DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 
    241245               zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj  ,jk,jn,Kmm)   ! 2 x C2 interpolation of T at u- & v-points 
    242246               zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) 
    243                !                                                        ! C4 minus upstream advective fluxes  
     247               !                                                        ! C4 minus upstream advective fluxes 
    244248               zwx(ji,jj,jk) =  0.5_wp * pU(ji,jj,jk) * ( zC2t_u + zltu(ji,jj,jk) - zltu(ji+1,jj,jk) ) - zwx(ji,jj,jk) 
    245249               zwy(ji,jj,jk) =  0.5_wp * pV(ji,jj,jk) * ( zC2t_v + zltv(ji,jj,jk) - zltv(ji,jj+1,jk) ) - zwy(ji,jj,jk) 
    246250            END_3D 
     251            IF (nn_hls.EQ.2) CALL lbc_lnk_multi( 'traadv_fct', zwx, 'U', -1.0_wp, zwy, 'V', -1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
    247252            ! 
    248253         CASE(  41 )                   !- 4th order centered       ==>>   !!gm coding attempt   need to be tested 
    249254            ztu(:,:,jpk) = 0._wp             ! Bottom value : flux set to zero 
    250255            ztv(:,:,jpk) = 0._wp 
    251             DO_3D( 1, 0, 1, 0, 1, jpkm1 )    ! 1st derivative (gradient) 
     256            DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 )    ! 1st derivative (gradient) 
    252257               ztu(ji,jj,jk) = ( pt(ji+1,jj  ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 
    253258               ztv(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 
    254259            END_3D 
    255             CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
     260            IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
     261            ! 
     262            IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
    256263            ! 
    257264            DO_3D( 0, 0, 0, 0, 1, jpkm1 )    ! Horizontal advective fluxes 
    … …  
    265272               zwy(ji,jj,jk) =  0.5_wp * pV(ji,jj,jk) * zC4t_v - zwy(ji,jj,jk) 
    266273            END_3D 
     274            IF (nn_hls.EQ.2) CALL lbc_lnk_multi( 'traadv_fct', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
    267275            ! 
    268276         END SELECT 
    … …  
    271279         ! 
    272280         CASE(  2  )                   !- 2nd order centered 
    273             DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     281            DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) 
    274282               zwz(ji,jj,jk) =  (  pW(ji,jj,jk) * 0.5_wp * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) )   & 
    275283                  &              - zwz(ji,jj,jk)  ) * wmask(ji,jj,jk) 
    … …  
    278286         CASE(  4  )                   !- 4th order COMPACT 
    279287            CALL interp_4th_cpt( pt(:,:,:,jn,Kmm) , ztw )   ! zwt = COMPACT interpolation of T at w-point 
    280             DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     288            DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 ) 
    281289               zwz(ji,jj,jk) = ( pW(ji,jj,jk) * ztw(ji,jj,jk) - zwz(ji,jj,jk) ) * wmask(ji,jj,jk) 
    282290            END_3D 
    … …  
    286294            zwz(:,:,1) = 0._wp   ! only ocean surface as interior zwz values have been w-masked 
    287295         ENDIF 
    288          !          
     296         ! 
     297         IF (nn_hls.EQ.1) THEN 
     298            CALL lbc_lnk_multi( 'traadv_fct', zwi, 'T', 1.0_wp, zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp, zwz, 'T', 1.0_wp ) 
     299         ELSE 
     300            CALL lbc_lnk( 'traadv_fct', zwi, 'T', 1.0_wp) 
     301         END IF 
     302         ! 
     303         IF (nn_hls.EQ.1) THEN 
     304            CALL lbc_lnk_multi( 'traadv_fct', zwi, 'T', 1.0_wp, zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp, zwz, 'T', 1.0_wp ) 
     305         ELSE 
     306            CALL lbc_lnk( 'traadv_fct', zwi, 'T', 1.0_wp) 
     307         END IF 
     308         ! 
    289309         IF ( ll_zAimp ) THEN 
    290             DO_3D( 0, 0, 0, 0, 1, jpkm1 )    !* trend and after field with monotonic scheme 
     310            DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )    !* trend and after field with monotonic scheme 
    291311               !                                                ! total intermediate advective trends 
    292312               ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
    293313                  &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
    294314                  &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) * r1_e1e2t(ji,jj) 
    295                ztw(ji,jj,jk)  = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) 
     315               ztw(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) 
    296316            END_3D 
    297317            ! 
    298318            CALL tridia_solver( zwdia, zwsup, zwinf, ztw, ztw , 0 ) 
    299319            ! 
    300             DO_3D( 0, 0, 0, 0, 2, jpkm1 )       ! Interior value ( multiplied by wmask) 
     320            DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 2, jpkm1 )       ! Interior value ( multiplied by wmask) 
    301321               zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 
    302322               zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 
    303                zwz(ji,jj,jk) =  zwz(ji,jj,jk) + 0.5 * e1e2t(ji,jj) * ( zfp_wk * ztw(ji,jj,jk) + zfm_wk * ztw(ji,jj,jk-1) ) * wmask(ji,jj,jk) 
     323               zwz(ji,jj,jk) = zwz(ji,jj,jk) + 0.5 * e1e2t(ji,jj) * ( zfp_wk * ztw(ji,jj,jk) + zfm_wk * ztw(ji,jj,jk-1) ) * wmask(ji,jj,jk) 
    304324            END_3D 
    305325         END IF 
    306          ! 
    307          CALL lbc_lnk_multi( 'traadv_fct', zwi, 'T', 1.0_wp, zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp,  zwz, 'W',  1.0_wp ) 
    308326         ! 
    309327         !        !==  monotonicity algorithm  ==! 
    … …  
    334352                  &                                        * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    335353            END_3D 
    336          END IF          
    337          ! 
     354         END IF 
     355         ! NOTE: [tiling-comms-merge] I tested this 
     356         ! NOT TESTED - NEED l_trd OR l_hst TRUE 
    338357         IF( l_trd .OR. l_hst ) THEN   ! trend diagnostics // heat/salt transport 
    339             ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:)  ! <<< add anti-diffusive fluxes  
     358            ztrdx(:,:,:) = ztrdx(:,:,:) + zwx(:,:,:)  ! <<< add anti-diffusive fluxes 
    340359            ztrdy(:,:,:) = ztrdy(:,:,:) + zwy(:,:,:)  !     to upstream fluxes 
    341360            ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:)  ! 
    … …  
    350369            ! 
    351370         ENDIF 
     371         ! NOTE: [tiling-comms-merge] I tested this 
     372         ! NOT TESTED - NEED l_ptr TRUE 
    352373         IF( l_ptr ) THEN              ! "Poleward" transports 
    353374            zptry(:,:,:) = zptry(:,:,:) + zwy(:,:,:)  ! <<< add anti-diffusive fluxes 
    … …  
    360381         DEALLOCATE( zwdia, zwinf, zwsup ) 
    361382      ENDIF 
    362       IF( l_trd .OR. l_hst ) THEN  
     383      IF( l_trd .OR. l_hst ) THEN 
    363384         DEALLOCATE( ztrdx, ztrdy, ztrdz ) 
    364385      ENDIF 
    … …  
    383404      !!       in-space based differencing for fluid 
    384405      !!---------------------------------------------------------------------- 
    385       INTEGER                          , INTENT(in   ) ::   Kmm             ! time level index  
    386       REAL(wp)                         , INTENT(in   ) ::   p2dt            ! tracer time-step 
    387       REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pbef, paft      ! before & after field 
    388       REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(inout) ::   paa, pbb, pcc   ! monotonic fluxes in the 3 directions 
     406      INTEGER                         , INTENT(in   ) ::   Kmm             ! time level index 
     407      REAL(wp)                        , INTENT(in   ) ::   p2dt            ! tracer time-step 
     408      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pbef            ! before field 
     409      REAL(wp), DIMENSION(A2D(nn_hls)    ,jpk), INTENT(in   ) ::   paft            ! after field 
     410      REAL(wp), DIMENSION(A2D(nn_hls)    ,jpk), INTENT(inout) ::   paa, pbb, pcc   ! monotonic fluxes in the 3 directions 
    389411      ! 
    390412      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    … …  
    392414      REAL(dp) ::   zpos, zneg, zbt, za, zb, zc, zbig, zrtrn    ! local scalars 
    393415      REAL(dp) ::   zau, zbu, zcu, zav, zbv, zcv, zup, zdo            !   -      - 
    394       REAL(dp), DIMENSION(jpi,jpj,jpk) :: zbetup, zbetdo, zbup, zbdo 
     416      REAL(dp), DIMENSION(A2D(nn_hls),jpk) :: zbetup, zbetdo, zbup, zbdo 
    395417      !!---------------------------------------------------------------------- 
    396418      ! 
    … …  
    402424      ! -------------------- 
    403425      ! max/min of pbef & paft with large negative/positive value (-/+zbig) inside land 
    404       zbup = MAX( pbef * tmask - zbig * ( 1._wp - tmask ),   & 
    405          &        paft * tmask - zbig * ( 1._wp - tmask )  ) 
    406       zbdo = MIN( pbef * tmask + zbig * ( 1._wp - tmask ),   & 
    407          &        paft * tmask + zbig * ( 1._wp - tmask )  ) 
     426      DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) 
     427         zbup(ji,jj,jk) = MAX( pbef(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1._wp - tmask(ji,jj,jk) ),   & 
     428            &                  paft(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1._wp - tmask(ji,jj,jk) )  ) 
     429         zbdo(ji,jj,jk) = MIN( pbef(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1._wp - tmask(ji,jj,jk) ),   & 
     430            &                  paft(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1._wp - tmask(ji,jj,jk) )  ) 
     431      END_3D 
    408432 
    409433      DO jk = 1, jpkm1 
    410434         ikm1 = MAX(jk-1,1) 
    411          DO_2D( 0, 0, 0, 0 ) 
     435         DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 
    412436 
    413437            ! search maximum in neighbourhood 
    … …  
    439463         END_2D 
    440464      END DO 
    441       CALL lbc_lnk_multi( 'traadv_fct', zbetup, 'T', 1.0_wp , zbetdo, 'T', 1.0_wp )   ! lateral boundary cond. (unchanged sign) 
     465      IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_fct', zbetup, 'T', 1.0_wp , zbetdo, 'T', 1.0_wp )   ! lateral boundary cond. (unchanged sign) 
    442466 
    443467      ! 3. monotonic flux in the i & j direction (paa & pbb) 
    444468      ! ---------------------------------------- 
    445       DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     469      DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 
    446470         zau = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) ) 
    447471         zbu = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) ) 
    … …  
    461485         pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1._wp - zc) * zb ) 
    462486      END_3D 
    463       CALL lbc_lnk_multi( 'traadv_fct', paa, 'U', -1.0_wp , pbb, 'V', -1.0_wp )   ! lateral boundary condition (changed sign) 
    464487      ! 
    465488   END SUBROUTINE nonosc 
    … …  
    537560      !!---------------------------------------------------------------------- 
    538561      REAL(wp),DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pt_in    ! field at t-point 
    539       REAL(wp),DIMENSION(jpi,jpj,jpk), INTENT(  out) ::   pt_out   ! field interpolated at w-point 
     562      REAL(wp),DIMENSION(A2D(nn_hls)    ,jpk), INTENT(  out) ::   pt_out   ! field interpolated at w-point 
    540563      ! 
    541564      INTEGER ::   ji, jj, jk   ! dummy loop integers 
    542565      INTEGER ::   ikt, ikb     ! local integers 
    543       REAL(wp),DIMENSION(jpi,jpj,jpk) :: zwd, zwi, zws, zwrm, zwt 
     566      REAL(wp),DIMENSION(A2D(nn_hls),jpk) :: zwd, zwi, zws, zwrm, zwt 
    544567      !!---------------------------------------------------------------------- 
    545568      ! 
    546569      !                      !==  build the three diagonal matrix & the RHS  ==! 
    547570      ! 
    548       DO_3D( 0, 0, 0, 0, 3, jpkm1 )    ! interior (from jk=3 to jpk-1) 
     571      DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 3, jpkm1 )    ! interior (from jk=3 to jpk-1) 
    549572         zwd (ji,jj,jk) = 3._wp * wmask(ji,jj,jk) + 1._wp                 !       diagonal 
    550573         zwi (ji,jj,jk) =         wmask(ji,jj,jk)                         ! lower diagonal 
    … …  
    565588      END IF 
    566589      ! 
    567       DO_2D( 0, 0, 0, 0 )              ! 2nd order centered at top & bottom 
     590      DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )              ! 2nd order centered at top & bottom 
    568591         ikt = mikt(ji,jj) + 1            ! w-point below the 1st  wet point 
    569592         ikb = MAX(mbkt(ji,jj), 2)        !     -   above the last wet point 
    … …  
    582605      !                       !==  tridiagonal solver  ==! 
    583606      ! 
    584       DO_2D( 0, 0, 0, 0 )           !* 1st recurrence:   Tk = Dk - Ik Sk-1 / Tk-1 
     607      DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )           !* 1st recurrence:   Tk = Dk - Ik Sk-1 / Tk-1 
    585608         zwt(ji,jj,2) = zwd(ji,jj,2) 
    586609      END_2D 
    587       DO_3D( 0, 0, 0, 0, 3, jpkm1 ) 
     610      DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 3, jpkm1 ) 
    588611         zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) /zwt(ji,jj,jk-1) 
    589612      END_3D 
    590613      ! 
    591       DO_2D( 0, 0, 0, 0 )           !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
     614      DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )           !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    592615         pt_out(ji,jj,2) = zwrm(ji,jj,2) 
    593616      END_2D 
    594       DO_3D( 0, 0, 0, 0, 3, jpkm1 ) 
     617      DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 3, jpkm1 ) 
    595618         pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)              
    596619      END_3D 
    597620 
    598       DO_2D( 0, 0, 0, 0 )           !* 3d recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk 
     621      DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )           !* 3d recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk 
    599622         pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 
    600623      END_2D 
    601       DO_3DS( 0, 0, 0, 0, jpk-2, 2, -1 ) 
     624      DO_3DS( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpk-2, 2, -1 ) 
    602625         pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 
    603626      END_3D 
    … …  
    626649      !!        The 3d array zwt is used as a work space array. 
    627650      !!---------------------------------------------------------------------- 
    628       REAL(wp),DIMENSION(:,:,:), INTENT(in   ) ::   pD, pU, PL    ! 3-diagonal matrix 
    629       REAL(wp),DIMENSION(:,:,:), INTENT(in   ) ::   pRHS          ! Right-Hand-Side 
    630       REAL(wp),DIMENSION(:,:,:), INTENT(  out) ::   pt_out        !!gm field at level=F(klev) 
    631       INTEGER                  , INTENT(in   ) ::   klev          ! =1 pt_out at w-level  
    632       !                                                           ! =0 pt at t-level 
     651      REAL(wp),DIMENSION(A2D(nn_hls),jpk), INTENT(in   ) ::   pD, pU, PL    ! 3-diagonal matrix 
     652      REAL(wp),DIMENSION(A2D(nn_hls),jpk), INTENT(in   ) ::   pRHS          ! Right-Hand-Side 
     653      REAL(wp),DIMENSION(A2D(nn_hls),jpk), INTENT(  out) ::   pt_out        !!gm field at level=F(klev) 
     654      INTEGER                    , INTENT(in   ) ::   klev          ! =1 pt_out at w-level 
     655      !                                                             ! =0 pt at t-level 
    633656      INTEGER ::   ji, jj, jk   ! dummy loop integers 
    634657      INTEGER ::   kstart       ! local indices 
    635       REAL(wp),DIMENSION(jpi,jpj,jpk) ::   zwt   ! 3D work array 
     658      REAL(wp),DIMENSION(A2D(nn_hls),jpk) ::   zwt   ! 3D work array 
    636659      !!---------------------------------------------------------------------- 
    637660      ! 
    638661      kstart =  1  + klev 
    639662      ! 
    640       DO_2D( 0, 0, 0, 0 )                         !* 1st recurrence:   Tk = Dk - Ik Sk-1 / Tk-1 
     663      DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )                         !* 1st recurrence:   Tk = Dk - Ik Sk-1 / Tk-1 
    641664         zwt(ji,jj,kstart) = pD(ji,jj,kstart) 
    642665      END_2D 
    643       DO_3D( 0, 0, 0, 0, kstart+1, jpkm1 ) 
     666      DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, kstart+1, jpkm1 ) 
    644667         zwt(ji,jj,jk) = pD(ji,jj,jk) - pL(ji,jj,jk) * pU(ji,jj,jk-1) /zwt(ji,jj,jk-1) 
    645668      END_3D 
    646669      ! 
    647       DO_2D( 0, 0, 0, 0 )                        !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
     670      DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )                        !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    648671         pt_out(ji,jj,kstart) = pRHS(ji,jj,kstart) 
    649672      END_2D 
    650       DO_3D( 0, 0, 0, 0, kstart+1, jpkm1 ) 
     673      DO_3D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, kstart+1, jpkm1 ) 
    651674         pt_out(ji,jj,jk) = pRHS(ji,jj,jk) - pL(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)              
    652675      END_3D 
    653676 
    654       DO_2D( 0, 0, 0, 0 )                       !* 3d recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk 
     677      DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )                       !* 3d recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk 
    655678         pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 
    656679      END_2D 
    657       DO_3DS( 0, 0, 0, 0, jpk-2, kstart, -1 ) 
     680      DO_3DS( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, jpk-2, kstart, -1 ) 
    658681         pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - pU(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 
    659682      END_3D 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traadv_mus.F90

    r13998 r14023  
    8181      LOGICAL                                  , INTENT(in   ) ::   ld_msc_ups      ! use upstream scheme within muscl 
    8282      REAL(wp)                                 , INTENT(in   ) ::   p2dt            ! tracer time-step 
     83      ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 
    8384      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pU, pV, pW      ! 3 ocean volume flux components 
    8485      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! tracers and RHS of tracer equation 
    … …  
    8889      REAL(wp) ::   zu, z0u, zzwx, zw , zalpha   ! local scalars 
    8990      REAL(wp) ::   zv, z0v, zzwy, z0w           !   -      - 
    90       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwx, zslpx   ! 3D workspace 
    91       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwy, zslpy   ! -      -  
     91      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::   zwx, zslpx   ! 3D workspace 
     92      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::   zwy, zslpy   ! -      - 
    9293      !!---------------------------------------------------------------------- 
    9394      ! 
    94       IF( kt == kit000 )  THEN 
    95          IF(lwp) WRITE(numout,*) 
    96          IF(lwp) WRITE(numout,*) 'tra_adv : MUSCL advection scheme on ', cdtype 
    97          IF(lwp) WRITE(numout,*) '        : mixed up-stream           ', ld_msc_ups 
    98          IF(lwp) WRITE(numout,*) '~~~~~~~' 
    99          IF(lwp) WRITE(numout,*) 
    100          ! 
    101          ! Upstream / MUSCL scheme indicator 
    102          ! 
    103          ALLOCATE( xind(jpi,jpj,jpk), STAT=ierr ) 
    104          xind(:,:,:) = 1._wp              ! set equal to 1 where up-stream is not needed 
    105          ! 
    106          IF( ld_msc_ups ) THEN            ! define the upstream indicator (if asked) 
    107             ALLOCATE( upsmsk(jpi,jpj), STAT=ierr ) 
    108             upsmsk(:,:) = 0._wp                             ! not upstream by default 
    109             ! 
    110             DO jk = 1, jpkm1 
    111                xind(:,:,jk) = 1._wp                              &                 ! =>1 where up-stream is not needed 
    112                   &         - MAX ( rnfmsk(:,:) * rnfmsk_z(jk),  &                 ! =>0 near runoff mouths (& closed sea outflows) 
    113                   &                 upsmsk(:,:)                ) * tmask(:,:,jk)   ! =>0 in some user defined area 
    114             END DO 
    115          ENDIF  
    116          ! 
    117       ENDIF  
    118       !       
    119       l_trd = .FALSE. 
    120       l_hst = .FALSE. 
    121       l_ptr = .FALSE. 
    122       IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )      l_trd = .TRUE. 
    123       IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) )  )   l_ptr = .TRUE.  
    124       IF(   cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 
    125          &                          iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) ) l_hst = .TRUE. 
     95      IF( ntile == 0 .OR. ntile == 1 )  THEN                       ! Do only on the first tile 
     96         IF( kt == kit000 )  THEN 
     97            IF(lwp) WRITE(numout,*) 
     98            IF(lwp) WRITE(numout,*) 'tra_adv : MUSCL advection scheme on ', cdtype 
     99            IF(lwp) WRITE(numout,*) '        : mixed up-stream           ', ld_msc_ups 
     100            IF(lwp) WRITE(numout,*) '~~~~~~~' 
     101            IF(lwp) WRITE(numout,*) 
     102            ! 
     103            ! Upstream / MUSCL scheme indicator 
     104            ! 
     105            ALLOCATE( xind(jpi,jpj,jpk), STAT=ierr ) 
     106            xind(:,:,:) = 1._wp              ! set equal to 1 where up-stream is not needed 
     107            ! 
     108            IF( ld_msc_ups ) THEN            ! define the upstream indicator (if asked) 
     109               ALLOCATE( upsmsk(jpi,jpj), STAT=ierr ) 
     110               upsmsk(:,:) = 0._wp                             ! not upstream by default 
     111               ! 
     112               DO jk = 1, jpkm1 
     113                  xind(:,:,jk) = 1._wp                              &                 ! =>1 where up-stream is not needed 
     114                     &         - MAX ( rnfmsk(:,:) * rnfmsk_z(jk),  &                 ! =>0 near runoff mouths (& closed sea outflows) 
     115                     &                 upsmsk(:,:)                ) * tmask(:,:,jk)   ! =>0 in some user defined area 
     116               END DO 
     117            ENDIF 
     118            ! 
     119         ENDIF 
     120         ! 
     121         l_trd = .FALSE. 
     122         l_hst = .FALSE. 
     123         l_ptr = .FALSE. 
     124         IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )      l_trd = .TRUE. 
     125         IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) )  )   l_ptr = .TRUE. 
     126         IF(   cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 
     127            &                          iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) ) l_hst = .TRUE. 
     128      ENDIF 
    126129      ! 
    127130      DO jn = 1, kjpt            !==  loop over the tracers  ==! 
    … …  
    132135         zwx(:,:,jpk) = 0._wp                   ! bottom values 
    133136         zwy(:,:,jpk) = 0._wp   
    134          DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 
     137         DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) 
    135138            zwx(ji,jj,jk) = umask(ji,jj,jk) * ( pt(ji+1,jj,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 
    136139            zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( pt(ji,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 
    137140         END_3D 
    138141         ! lateral boundary conditions   (changed sign) 
    139          CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp ) 
     142         IF ( nn_hls.EQ.1 ) CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp ) 
    140143         !                                !-- Slopes of tracer 
    141144         zslpx(:,:,jpk) = 0._wp                 ! bottom values 
    142145         zslpy(:,:,jpk) = 0._wp 
    143          DO_3D( 0, 1, 0, 1, 1, jpkm1 ) 
     146         DO_3D( nn_hls-1, 1, nn_hls-1, 1, 1, jpkm1 ) 
    144147            zslpx(ji,jj,jk) =                       ( zwx(ji,jj,jk) + zwx(ji-1,jj  ,jk) )   & 
    145148               &            * ( 0.25 + SIGN( 0.25_wp, zwx(ji,jj,jk) * zwx(ji-1,jj  ,jk) ) ) 
    … …  
    148151         END_3D 
    149152         ! 
    150          DO_3D( 0, 1, 0, 1, 1, jpkm1 )    !-- Slopes limitation 
     153         DO_3D( nn_hls-1, 1, nn_hls-1, 1, 1, jpkm1 )    !-- Slopes limitation 
    151154            zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji  ,jj,jk) ),   & 
    152155               &                                                     2.*ABS( zwx  (ji-1,jj,jk) ),   & 
    … …  
    157160         END_3D 
    158161         ! 
    159          DO_3D( 0, 0, 0, 0, 1, jpkm1 )    !-- MUSCL horizontal advective fluxes 
     162         DO_3D( nn_hls-1, 0, nn_hls-1, 0, 1, jpkm1 )    !-- MUSCL horizontal advective fluxes 
    160163            ! MUSCL fluxes 
    161164            z0u = SIGN( 0.5_wp, pU(ji,jj,jk) ) 
    … …  
    173176            zwy(ji,jj,jk) = pV(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
    174177         END_3D 
    175          CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp )   ! lateral boundary conditions   (changed sign) 
     178         IF ( nn_hls.EQ.1 ) CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp )   ! lateral boundary conditions   (changed sign) 
    176179         ! 
    177180         DO_3D( 0, 0, 0, 0, 1, jpkm1 )    !-- Tracer advective trend 
    … …  
    195198         zwx(:,:, 1 ) = 0._wp                   ! surface & bottom boundary conditions 
    196199         zwx(:,:,jpk) = 0._wp 
    197          DO jk = 2, jpkm1                       ! interior values 
    198             zwx(:,:,jk) = tmask(:,:,jk) * ( pt(:,:,jk-1,jn,Kbb) - pt(:,:,jk,jn,Kbb) ) 
    199          END DO 
     200         DO_3D( 1, 1, 1, 1, 2, jpkm1 )                ! interior values 
     201            zwx(ji,jj,jk) = tmask(ji,jj,jk) * ( pt(ji,jj,jk-1,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 
     202         END_3D 
    200203         !                                !-- Slopes of tracer 
    201204         zslpx(:,:,1) = 0._wp                   ! surface values 
    … …  
    223226               END_2D 
    224227            ELSE                                      ! no cavities: only at the ocean surface 
    225                zwx(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kbb) 
     228               DO_2D( 1, 1, 1, 1 ) 
     229                  zwx(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) 
     230               END_2D 
    226231            ENDIF 
    227232         ENDIF 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traadv_qck.F90

    r13998 r14023  
    9191      INTEGER                                  , INTENT(in   ) ::   kjpt            ! number of tracers 
    9292      REAL(wp)                                 , INTENT(in   ) ::   p2dt            ! tracer time-step 
     93      ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 
     94      ! NOTE: [tiling-comms-merge] These were changed to INTENT(inout) but they are not modified, so it is reverted 
    9395      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pU, pV, pW      ! 3 ocean volume transport components 
    9496      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! tracers and RHS of tracer equation 
    9597      !!---------------------------------------------------------------------- 
    9698      ! 
    97       IF( kt == kit000 )  THEN 
    98          IF(lwp) WRITE(numout,*) 
    99          IF(lwp) WRITE(numout,*) 'tra_adv_qck : 3rd order quickest advection scheme on ', cdtype 
    100          IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 
    101          IF(lwp) WRITE(numout,*) 
     99      IF( ntile == 0 .OR. ntile == 1 )  THEN                       ! Do only on the first tile 
     100         IF( kt == kit000 )  THEN 
     101            IF(lwp) WRITE(numout,*) 
     102            IF(lwp) WRITE(numout,*) 'tra_adv_qck : 3rd order quickest advection scheme on ', cdtype 
     103            IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 
     104            IF(lwp) WRITE(numout,*) 
     105         ENDIF 
     106         ! 
     107         l_trd = .FALSE. 
     108         l_ptr = .FALSE. 
     109         IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )   l_trd = .TRUE. 
     110         IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE. 
    102111      ENDIF 
    103       ! 
    104       l_trd = .FALSE. 
    105       l_ptr = .FALSE. 
    106       IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )   l_trd = .TRUE. 
    107       IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE.  
    108       ! 
    109112      ! 
    110113      !        ! horizontal fluxes are computed with the QUICKEST + ULTIMATE scheme 
    … …  
    127130      INTEGER                                  , INTENT(in   ) ::   kjpt       ! number of tracers 
    128131      REAL(wp)                                 , INTENT(in   ) ::   p2dt       ! tracer time-step 
     132      ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 
    129133      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pU        ! i-velocity components 
    130134      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! active tracers and RHS of tracer equation 
    … …  
    132136      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    133137      REAL(wp) ::   ztra, zbtr, zdir, zdx, zmsk   ! local scalars 
    134       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwx, zfu, zfc, zfd 
     138      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::   zwx, zfu, zfc, zfd 
    135139      !---------------------------------------------------------------------- 
    136140      ! 
    … …  
    142146         ! 
    143147!!gm why not using a SHIFT instruction... 
    144          DO_3D( 0, 0, 0, 0, 1, jpkm1 )     !--- Computation of the ustream and downstream value of the tracer and the mask 
     148         DO_3D( 0, 0, nn_hls-1, nn_hls-1, 1, jpkm1 )     !--- Computation of the ustream and downstream value of the tracer and the mask 
    145149            zfc(ji,jj,jk) = pt(ji-1,jj,jk,jn,Kbb)        ! Upstream   in the x-direction for the tracer 
    146150            zfd(ji,jj,jk) = pt(ji+1,jj,jk,jn,Kbb)        ! Downstream in the x-direction for the tracer 
    147151         END_3D 
    148          CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp )   ! Lateral boundary conditions  
     152         IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp )   ! Lateral boundary conditions 
    149153          
    150154         ! 
    151155         ! Horizontal advective fluxes 
    152156         ! --------------------------- 
    153          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     157         DO_3D( 0, 0, nn_hls-1, 0, 1, jpkm1 ) 
    154158            zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
    155159            zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji+1,jj,jk)  ! FU in the x-direction for T  
    156160         END_3D 
    157161         ! 
    158          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     162         DO_3D( 0, 0, nn_hls-1, 0, 1, jpkm1 ) 
    159163            zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
    160164            zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) 
    … …  
    164168         END_3D 
    165169         !--- Lateral boundary conditions  
    166          CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp,  zwx(:,:,:), 'T', 1.0_wp ) 
     170         IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp,  zwx(:,:,:), 'T', 1.0_wp ) 
    167171 
    168172         !--- QUICKEST scheme 
    … …  
    170174         ! 
    171175         ! Mask at the T-points in the x-direction (mask=0 or mask=1) 
    172          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     176         DO_3D( 0, 0, nn_hls-1, nn_hls-1, 1, jpkm1 ) 
    173177            zfu(ji,jj,jk) = tmask(ji-1,jj,jk) + tmask(ji,jj,jk) + tmask(ji+1,jj,jk) - 2. 
    174178         END_3D 
    175          CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp )      ! Lateral boundary conditions  
     179         IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp )      ! Lateral boundary conditions 
    176180 
    177181         ! 
    178182         ! Tracer flux on the x-direction 
    179          DO jk = 1, jpkm1   
    180             ! 
    181             DO_2D( 0, 0, 0, 0 ) 
    182                zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
    183                !--- If the second ustream point is a land point 
    184                !--- the flux is computed by the 1st order UPWIND scheme 
    185                zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji+1,jj,jk) 
    186                zwx(ji,jj,jk) = zmsk * zwx(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 
    187                zwx(ji,jj,jk) = zwx(ji,jj,jk) * pU(ji,jj,jk) 
    188             END_2D 
    189          END DO 
    190          ! 
    191          CALL lbc_lnk( 'traadv_qck', zwx(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions 
     183         DO_3D( 0, 0, 1, 0, 1, jpkm1 ) 
     184            zdir = 0.5 + SIGN( 0.5_wp, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0 
     185            !--- If the second ustream point is a land point 
     186            !--- the flux is computed by the 1st order UPWIND scheme 
     187            zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji+1,jj,jk) 
     188            zwx(ji,jj,jk) = zmsk * zwx(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 
     189            zwx(ji,jj,jk) = zwx(ji,jj,jk) * pU(ji,jj,jk) 
     190         END_3D 
    192191         ! 
    193192         ! Computation of the trend 
    … …  
    216215      INTEGER                                  , INTENT(in   ) ::   kjpt       ! number of tracers 
    217216      REAL(wp)                                 , INTENT(in   ) ::   p2dt       ! tracer time-step 
     217      ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 
    218218      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pV        ! j-velocity components 
    219219      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! active tracers and RHS of tracer equation 
    … …  
    221221      INTEGER  :: ji, jj, jk, jn                ! dummy loop indices 
    222222      REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk   ! local scalars 
    223       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwy, zfu, zfc, zfd   ! 3D workspace 
     223      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::   zwy, zfu, zfc, zfd   ! 3D workspace 
    224224      !---------------------------------------------------------------------- 
    225225      ! 
    … …  
    233233            !                                              
    234234            !--- Computation of the ustream and downstream value of the tracer and the mask 
    235             DO_2D( 0, 0, 0, 0 ) 
     235            DO_2D( nn_hls-1, nn_hls-1, 0, 0 ) 
    236236               ! Upstream in the x-direction for the tracer 
    237237               zfc(ji,jj,jk) = pt(ji,jj-1,jk,jn,Kbb) 
    … …  
    240240            END_2D 
    241241         END DO 
    242          CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp )   ! Lateral boundary conditions  
    243  
     242         IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp )   ! Lateral boundary conditions 
    244243          
    245244         ! 
    … …  
    247246         ! --------------------------- 
    248247         ! 
    249          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     248         DO_3D( nn_hls-1, 0, 0, 0, 1, jpkm1 ) 
    250249            zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
    251250            zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji,jj+1,jk)  ! FU in the x-direction for T  
    252251         END_3D 
    253252         ! 
    254          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     253         DO_3D( nn_hls-1, 0, 0, 0, 1, jpkm1 ) 
    255254            zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
    256255            zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 
    … …  
    261260 
    262261         !--- Lateral boundary conditions  
    263          CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp, zwy(:,:,:), 'T', 1.0_wp ) 
     262         IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp, zwy(:,:,:), 'T', 1.0_wp ) 
    264263 
    265264         !--- QUICKEST scheme 
    … …  
    267266         ! 
    268267         ! Mask at the T-points in the x-direction (mask=0 or mask=1) 
    269          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     268         DO_3D( nn_hls-1, nn_hls-1, 0, 0, 1, jpkm1 ) 
    270269            zfu(ji,jj,jk) = tmask(ji,jj-1,jk) + tmask(ji,jj,jk) + tmask(ji,jj+1,jk) - 2. 
    271270         END_3D 
    272          CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp )    !--- Lateral boundary conditions  
     271         IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp )    !--- Lateral boundary conditions 
    273272         ! 
    274273         ! Tracer flux on the x-direction 
    275          DO jk = 1, jpkm1   
    276             ! 
    277             DO_2D( 0, 0, 0, 0 ) 
    278                zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
    279                !--- If the second ustream point is a land point 
    280                !--- the flux is computed by the 1st order UPWIND scheme 
    281                zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji,jj+1,jk) 
    282                zwy(ji,jj,jk) = zmsk * zwy(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 
    283                zwy(ji,jj,jk) = zwy(ji,jj,jk) * pV(ji,jj,jk) 
    284             END_2D 
    285          END DO 
    286          ! 
    287          CALL lbc_lnk( 'traadv_qck', zwy(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions 
     274         DO_3D( 1, 0, 0, 0, 1, jpkm1 ) 
     275            zdir = 0.5 + SIGN( 0.5_wp, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0 
     276            !--- If the second ustream point is a land point 
     277            !--- the flux is computed by the 1st order UPWIND scheme 
     278            zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji,jj+1,jk) 
     279            zwy(ji,jj,jk) = zmsk * zwy(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 
     280            zwy(ji,jj,jk) = zwy(ji,jj,jk) * pV(ji,jj,jk) 
     281         END_3D 
    288282         ! 
    289283         ! Computation of the trend 
    … …  
    313307      CHARACTER(len=3)                         , INTENT(in   ) ::   cdtype   ! =TRA or TRC (tracer indicator) 
    314308      INTEGER                                  , INTENT(in   ) ::   kjpt     ! number of tracers 
    315       REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pW      ! vertical velocity  
     309      ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 
     310      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pW      ! vertical velocity 
    316311      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! active tracers and RHS of tracer equation 
    317312      ! 
    318313      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    319       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwz   ! 3D workspace 
     314      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::   zwz   ! 3D workspace 
    320315      !!---------------------------------------------------------------------- 
    321316      ! 
    … …  
    332327         IF( ln_linssh ) THEN                !* top value   (only in linear free surf. as zwz is multiplied by wmask) 
    333328            IF( ln_isfcav ) THEN                  ! ice-shelf cavities (top of the ocean) 
    334                DO_2D( 1, 1, 1, 1 ) 
     329               DO_2D( 0, 0, 0, 0 ) 
    335330                  zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm)   ! linear free surface  
    336331               END_2D 
    337332            ELSE                                   ! no ocean cavities (only ocean surface) 
    338                zwz(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kmm) 
     333               DO_2D( 0, 0, 0, 0 ) 
     334                  zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kmm) 
     335               END_2D 
    339336            ENDIF 
    340337         ENDIF 
    … …  
    359356      !! ** Method :    
    360357      !!---------------------------------------------------------------------- 
    361       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pfu   ! second upwind point 
    362       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pfd   ! first douwning point 
    363       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pfc   ! the central point (or the first upwind point) 
    364       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   puc   ! input as Courant number ; output as flux 
     358      REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in   ) ::   pfu   ! second upwind point 
     359      REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in   ) ::   pfd   ! first douwning point 
     360      REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in   ) ::   pfc   ! the central point (or the first upwind point) 
     361      REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) ::   puc   ! input as Courant number ; output as flux 
    365362      !! 
    366363      INTEGER  ::  ji, jj, jk               ! dummy loop indices  
    … …  
    369366      !---------------------------------------------------------------------- 
    370367      ! 
    371       DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     368      DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    372369         zc     = puc(ji,jj,jk)                         ! Courant number 
    373370         zcurv  = pfd(ji,jj,jk) + pfu(ji,jj,jk) - 2. * pfc(ji,jj,jk) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traadv_ubs.F90

    r13998 r14023  
    9292      INTEGER                                  , INTENT(in   ) ::   kn_ubs_v        ! number of tracers 
    9393      REAL(wp)                                 , INTENT(in   ) ::   p2dt            ! tracer time-step 
     94      ! TEMP: [tiling] This can be A2D(nn_hls) if using XIOS (subdomain support) 
    9495      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pU, pV, pW      ! 3 ocean volume transport components 
    9596      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! tracers and RHS of tracer equation 
    … …  
    99100      REAL(wp) ::   zfp_ui, zfm_ui, zcenut, ztak, zfp_wk, zfm_wk   !   -      - 
    100101      REAL(wp) ::   zfp_vj, zfm_vj, zcenvt, zeeu, zeev, z_hdivn    !   -      - 
    101       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   ztu, ztv, zltu, zltv, zti, ztw   ! 3D workspace 
    102       !!---------------------------------------------------------------------- 
    103       ! 
    104       IF( kt == kit000 )  THEN 
    105          IF(lwp) WRITE(numout,*) 
    106          IF(lwp) WRITE(numout,*) 'tra_adv_ubs :  horizontal UBS advection scheme on ', cdtype 
    107          IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 
     102      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::   ztu, ztv, zltu, zltv, zti, ztw     ! 3D workspace 
     103      !!---------------------------------------------------------------------- 
     104      ! 
     105      IF( ntile == 0 .OR. ntile == 1 )  THEN                       ! Do only on the first tile 
     106         IF( kt == kit000 )  THEN 
     107            IF(lwp) WRITE(numout,*) 
     108            IF(lwp) WRITE(numout,*) 'tra_adv_ubs :  horizontal UBS advection scheme on ', cdtype 
     109            IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 
     110         ENDIF 
     111         ! 
     112         l_trd = .FALSE. 
     113         l_hst = .FALSE. 
     114         l_ptr = .FALSE. 
     115         IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )      l_trd = .TRUE. 
     116         IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) )  )   l_ptr = .TRUE. 
     117         IF(   cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 
     118            &                          iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) ) l_hst = .TRUE. 
    108119      ENDIF 
    109       ! 
    110       l_trd = .FALSE. 
    111       l_hst = .FALSE. 
    112       l_ptr = .FALSE. 
    113       IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )      l_trd = .TRUE. 
    114       IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) )  )   l_ptr = .TRUE.  
    115       IF(   cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 
    116          &                          iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) ) l_hst = .TRUE. 
    117120      ! 
    118121      ztw (:,:, 1 ) = 0._wp      ! surface & bottom value : set to zero for all tracers 
    119122      zltu(:,:,jpk) = 0._wp   ;   zltv(:,:,jpk) = 0._wp 
    120123      ztw (:,:,jpk) = 0._wp   ;   zti (:,:,jpk) = 0._wp 
    121       ! 
    122124      !                                                          ! =========== 
    123125      DO jn = 1, kjpt                                            ! tracer loop 
    … …  
    125127         !                                               
    126128         DO jk = 1, jpkm1                !==  horizontal laplacian of before tracer ==! 
    127             DO_2D( 1, 0, 1, 0 )                   ! First derivative (masked gradient) 
     129            DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 )                   ! First derivative (masked gradient) 
    128130               zeeu = e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) * umask(ji,jj,jk) 
    129131               zeev = e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) * vmask(ji,jj,jk) 
    … …  
    131133               ztv(ji,jj,jk) = zeev * ( pt(ji  ,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 
    132134            END_2D 
    133             DO_2D( 0, 0, 0, 0 )                   ! Second derivative (divergence) 
     135            DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )                   ! Second derivative (divergence) 
    134136               zcoef = 1._wp / ( 6._wp * e3t(ji,jj,jk,Kmm) ) 
    135137               zltu(ji,jj,jk) = (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)  ) * zcoef 
    … …  
    138140            !                                     
    139141         END DO          
    140          CALL lbc_lnk( 'traadv_ubs', zltu, 'T', 1.0_wp )   ;    CALL lbc_lnk( 'traadv_ubs', zltv, 'T', 1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
     142         IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_ubs', zltu, 'T', 1.0_wp, zltv, 'T', 1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
    141143         !     
    142144         DO_3D( 1, 0, 1, 0, 1, jpkm1 )   !==  Horizontal advective fluxes  ==!     (UBS) 
    … …  
    153155         END_3D 
    154156         ! 
    155          zltu(:,:,:) = pt(:,:,:,jn,Krhs)      ! store the initial trends before its update 
     157         DO_3D( 1, 1, 1, 1, 1, jpk ) 
     158            zltu(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs)      ! store the initial trends before its update 
     159         END_3D 
    156160         ! 
    157161         DO jk = 1, jpkm1        !==  add the horizontal advective trend  ==! 
    … …  
    165169         END DO 
    166170         ! 
    167          zltu(:,:,:) = pt(:,:,:,jn,Krhs) - zltu(:,:,:)    ! Horizontal advective trend used in vertical 2nd order FCT case 
    168          !                                                ! and/or in trend diagnostic (l_trd=T)  
    169          !                 
     171         DO_3D( 1, 1, 1, 1, 1, jpk ) 
     172            zltu(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) - zltu(ji,jj,jk)  ! Horizontal advective trend used in vertical 2nd order FCT case 
     173         END_3D                                                     ! and/or in trend diagnostic (l_trd=T) 
     174         ! 
    170175         IF( l_trd ) THEN                  ! trend diagnostics 
    171176             CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, ztu, pU, pt(:,:,:,jn,Kmm) ) 
    … …  
    185190         CASE(  2  )                   ! 2nd order FCT  
    186191            !          
    187             IF( l_trd )   zltv(:,:,:) = pt(:,:,:,jn,Krhs)          ! store pt(:,:,:,:,Krhs) if trend diag. 
     192            IF( l_trd ) THEN 
     193               DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     194                  zltv(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs)          ! store pt(:,:,:,:,Krhs) if trend diag. 
     195               END_3D 
     196            ENDIF 
    188197            ! 
    189198            !                               !*  upstream advection with initial mass fluxes & intermediate update  ==! 
    … …  
    199208                  END_2D 
    200209               ELSE                                   ! no cavities: only at the ocean surface 
    201                   ztw(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kbb) 
     210                  DO_2D( 1, 1, 1, 1 ) 
     211                     ztw(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) 
     212                  END_2D 
    202213               ENDIF 
    203214            ENDIF 
    … …  
    209220               zti(ji,jj,jk)    = ( pt(ji,jj,jk,jn,Kbb) + p2dt * ( ztak + zltu(ji,jj,jk) ) ) * tmask(ji,jj,jk) 
    210221            END_3D 
    211             CALL lbc_lnk( 'traadv_ubs', zti, 'T', 1.0_wp )      ! Lateral boundary conditions on zti, zsi   (unchanged sign) 
    212222            ! 
    213223            !                          !*  anti-diffusive flux : high order minus low order 
    … …  
    226236               ztw(ji,jj,jk) = pW(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) 
    227237            END_3D 
    228             IF( ln_linssh )   ztw(:,:, 1 ) = pW(:,:,1) * pt(:,:,1,jn,Kmm)     !!gm ISF & 4th COMPACT doesn't work 
     238            IF( ln_linssh ) THEN 
     239               DO_2D( 1, 1, 1, 1 ) 
     240                  ztw(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kmm)     !!gm ISF & 4th COMPACT doesn't work 
     241               END_2D 
     242            ENDIF 
    229243            ! 
    230244         END SELECT 
    … …  
    262276      !!       in-space based differencing for fluid 
    263277      !!---------------------------------------------------------------------- 
    264       INTEGER , INTENT(in   )                          ::   Kmm    ! time level index 
    265       REAL(wp), INTENT(in   )                          ::   p2dt   ! tracer time-step 
    266       REAL(wp),                DIMENSION (jpi,jpj,jpk) ::   pbef   ! before field 
    267       REAL(wp), INTENT(inout), DIMENSION (jpi,jpj,jpk) ::   paft   ! after field 
    268       REAL(wp), INTENT(inout), DIMENSION (jpi,jpj,jpk) ::   pcc    ! monotonic flux in the k direction 
     278      INTEGER , INTENT(in   )                         ::   Kmm    ! time level index 
     279      REAL(wp), INTENT(in   )                         ::   p2dt   ! tracer time-step 
     280      REAL(wp),                DIMENSION(jpi,jpj,jpk) ::   pbef   ! before field 
     281      REAL(wp), INTENT(inout), DIMENSION(A2D(nn_hls)    ,jpk) ::   paft   ! after field 
     282      REAL(wp), INTENT(inout), DIMENSION(A2D(nn_hls)    ,jpk) ::   pcc    ! monotonic flux in the k direction 
    269283      ! 
    270284      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    271285      INTEGER  ::   ikm1         ! local integer 
    272286      REAL(wp) ::   zpos, zneg, zbt, za, zb, zc, zbig, zrtrn   ! local scalars 
    273       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zbetup, zbetdo     ! 3D workspace 
     287      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::   zbetup, zbetdo         ! 3D workspace 
    274288      !!---------------------------------------------------------------------- 
    275289      ! 
    … …  
    281295      ! -------------------- 
    282296      !                    ! large negative value (-zbig) inside land 
    283       pbef(:,:,:) = pbef(:,:,:) * tmask(:,:,:) - zbig * ( 1.e0 - tmask(:,:,:) ) 
    284       paft(:,:,:) = paft(:,:,:) * tmask(:,:,:) - zbig * ( 1.e0 - tmask(:,:,:) ) 
     297      DO_3D( 0, 0, 0, 0, 1, jpk ) 
     298         pbef(ji,jj,jk) = pbef(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1.e0 - tmask(ji,jj,jk) ) 
     299         paft(ji,jj,jk) = paft(ji,jj,jk) * tmask(ji,jj,jk) - zbig * ( 1.e0 - tmask(ji,jj,jk) ) 
     300      END_3D 
    285301      ! 
    286302      DO jk = 1, jpkm1     ! search maximum in neighbourhood 
    … …  
    293309      END DO 
    294310      !                    ! large positive value (+zbig) inside land 
    295       pbef(:,:,:) = pbef(:,:,:) * tmask(:,:,:) + zbig * ( 1.e0 - tmask(:,:,:) ) 
    296       paft(:,:,:) = paft(:,:,:) * tmask(:,:,:) + zbig * ( 1.e0 - tmask(:,:,:) ) 
     311      DO_3D( 0, 0, 0, 0, 1, jpk ) 
     312         pbef(ji,jj,jk) = pbef(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1.e0 - tmask(ji,jj,jk) ) 
     313         paft(ji,jj,jk) = paft(ji,jj,jk) * tmask(ji,jj,jk) + zbig * ( 1.e0 - tmask(ji,jj,jk) ) 
     314      END_3D 
    297315      ! 
    298316      DO jk = 1, jpkm1     ! search minimum in neighbourhood 
    … …  
    305323      END DO 
    306324      !                    ! restore masked values to zero 
    307       pbef(:,:,:) = pbef(:,:,:) * tmask(:,:,:) 
    308       paft(:,:,:) = paft(:,:,:) * tmask(:,:,:) 
     325      DO_3D( 0, 0, 0, 0, 1, jpk ) 
     326         pbef(ji,jj,jk) = pbef(ji,jj,jk) * tmask(ji,jj,jk) 
     327         paft(ji,jj,jk) = paft(ji,jj,jk) * tmask(ji,jj,jk) 
     328      END_3D 
    309329      ! 
    310330      ! Positive and negative part of fluxes and beta terms 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traatf.F90

    r13295 r14023  
    156156         ENDIF 
    157157         ! 
    158          CALL lbc_lnk_multi( 'traatf', pts(:,:,:,jp_tem,Kbb) , 'T', 1.0_wp, pts(:,:,:,jp_sal,Kbb) , 'T', 1.0_wp, & 
    159                   &                    pts(:,:,:,jp_tem,Kmm) , 'T', 1.0_wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1.0_wp, & 
    160                   &                    pts(:,:,:,jp_tem,Kaa), 'T', 1.0_wp, pts(:,:,:,jp_sal,Kaa), 'T', 1.0_wp  ) 
    161          ! 
     158         CALL lbc_lnk_multi( 'traatf',  pts(:,:,:,jp_tem,Kmm) , 'T', 1.0_wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1.0_wp )  
     159 
    162160      ENDIF      
    163161      !