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 13982 – NEMO

Changeset 13982


Ignore:
Timestamp:
2020-12-02T11:57:05+01:00 (3 years ago)
Author:
smasson
Message:

trunk: merge dev_r13923_Tiling_Cleanup_MPI3_LoopFusion into the trunk

Location:
NEMO/trunk
Files:
60 edited
7 copied

Legend:

Unmodified
Added
Removed

  • NEMO/trunk/cfgs/SHARED/namelist_ref

    r13731 r13982  
    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/trunk/src/ICE/icedyn_rhg_evp.F90

    r13970 r13982  
    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/trunk/src/OCE/ASM/asminc.F90

    r13295 r13982  
    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/trunk/src/OCE/BDY/bdytra.F90

    r13527 r13982  
    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/trunk/src/OCE/DIA/diaar5.F90

    r13497 r13982  
    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/trunk/src/OCE/DIA/diaptr.F90

    r13557 r13982  
    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/trunk/src/OCE/DOM/dom_oce.F90

    r13557 r13982  
    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 
    … …  
    296310      ALLOCATE( e3t(jpi,jpj,jpk,jpt) , e3u (jpi,jpj,jpk,jpt) , e3v (jpi,jpj,jpk,jpt) , e3f(jpi,jpj,jpk) ,      & 
    297311         &      e3w(jpi,jpj,jpk,jpt) , e3uw(jpi,jpj,jpk,jpt) , e3vw(jpi,jpj,jpk,jpt)                    ,  STAT=ierr(ii) ) 
    298 #endif   
     312#endif 
    299313         ! 
    300314      ii = ii+1 
    301315      ALLOCATE( r3t  (jpi,jpj,jpt)   , r3u  (jpi,jpj,jpt)    , r3v  (jpi,jpj,jpt)    , r3f  (jpi,jpj) ,  & 
    302          &      r3t_f(jpi,jpj)       , r3u_f(jpi,jpj)        , r3v_f(jpi,jpj)                         ,  STAT=ierr(ii) )        
     316         &      r3t_f(jpi,jpj)       , r3u_f(jpi,jpj)        , r3v_f(jpi,jpj)                         ,  STAT=ierr(ii) ) 
    303317         ! 
    304318      ii = ii+1 
    … …  
    317331         ! 
    318332      ii = ii+1 
    319       ALLOCATE( risfdep(jpi,jpj) , bathy(jpi,jpj) , STAT=ierr(ii)  )  
     333      ALLOCATE( risfdep(jpi,jpj) , bathy(jpi,jpj) , STAT=ierr(ii)  ) 
    320334         ! 
    321335      ii = ii+1 
    … …  
    323337         ! 
    324338      ii = ii+1 
    325       ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) ,                        &  
     339      ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) ,                        & 
    326340         &      ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , ssfmask(jpi,jpj) ,     & 
    327341         &      mbkt   (jpi,jpj) , mbku   (jpi,jpj) , mbkv   (jpi,jpj) ,                    STAT=ierr(ii) ) 
    … …  
    331345         ! 
    332346      ii = ii+1 
    333       ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) ,     &  
     347      ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) ,     & 
    334348         &      vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk) , STAT=ierr(ii) ) 
    335349         ! 

  • NEMO/trunk/src/OCE/DOM/domain.F90

    r13970 r13982  
    4545   USE closea , ONLY : dom_clo ! closed seas 
    4646   ! 
     47   USE prtctl         ! Print control (prt_ctl_info routine) 
    4748   USE in_out_manager ! I/O manager 
    4849   USE iom            ! I/O library 
    … …  
    5556   PUBLIC   dom_init     ! called by nemogcm.F90 
    5657   PUBLIC   domain_cfg   ! called by nemogcm.F90 
     58   PUBLIC   dom_tile     ! called by step.F90 
    5759 
    5860   !!------------------------------------------------------------------------- 
    … …  
    124126      !           !==  Reference coordinate system  ==! 
    125127      ! 
    126       CALL dom_glo                     ! global domain versus local domain 
    127       CALL dom_nam                     ! read namelist ( namrun, namdom ) 
     128      CALL dom_glo                            ! global domain versus local domain 
     129      CALL dom_nam                            ! read namelist ( namrun, namdom ) 
     130      CALL dom_tile( ntsi, ntsj, ntei, ntej ) ! Tile domain 
     131 
    128132      ! 
    129133      CALL dom_hgr                      ! Horizontal mesh 
    … …  
    273277 
    274278 
     279   SUBROUTINE dom_tile( ktsi, ktsj, ktei, ktej, ktile ) 
     280      !!---------------------------------------------------------------------- 
     281      !!                     ***  ROUTINE dom_tile  *** 
     282      !! 
     283      !! ** Purpose :   Set tile domain variables 
     284      !! 
     285      !! ** Action  : - ktsi, ktsj     : start of internal part of domain 
     286      !!              - ktei, ktej     : end of internal part of domain 
     287      !!              - ntile          : current tile number 
     288      !!              - nijtile        : total number of tiles 
     289      !!---------------------------------------------------------------------- 
     290      INTEGER, INTENT(out) :: ktsi, ktsj, ktei, ktej      ! Tile domain indices 
     291      INTEGER, INTENT(in), OPTIONAL :: ktile              ! Tile number 
     292      INTEGER ::   jt                                     ! dummy loop argument 
     293      INTEGER ::   iitile, ijtile                         ! Local integers 
     294      CHARACTER (len=11) ::   charout 
     295      !!---------------------------------------------------------------------- 
     296      IF( PRESENT(ktile) .AND. ln_tile ) THEN 
     297         ntile = ktile                 ! Set domain indices for tile 
     298         ktsi = ntsi_a(ktile) 
     299         ktsj = ntsj_a(ktile) 
     300         ktei = ntei_a(ktile) 
     301         ktej = ntej_a(ktile) 
     302 
     303         IF(sn_cfctl%l_prtctl) THEN 
     304            WRITE(charout, FMT="('ntile =', I4)") ktile 
     305            CALL prt_ctl_info( charout ) 
     306         ENDIF 
     307      ELSE 
     308         ntile = 0                     ! Initialise to full domain 
     309         nijtile = 1 
     310         ktsi = Nis0 
     311         ktsj = Njs0 
     312         ktei = Nie0 
     313         ktej = Nje0 
     314 
     315         IF( ln_tile ) THEN            ! Calculate tile domain indices 
     316            iitile = Ni_0 / nn_ltile_i       ! Number of tiles 
     317            ijtile = Nj_0 / nn_ltile_j 
     318            IF( MOD( Ni_0, nn_ltile_i ) /= 0 ) iitile = iitile + 1 
     319            IF( MOD( Nj_0, nn_ltile_j ) /= 0 ) ijtile = ijtile + 1 
     320 
     321            nijtile = iitile * ijtile 
     322            ALLOCATE( ntsi_a(0:nijtile), ntsj_a(0:nijtile), ntei_a(0:nijtile), ntej_a(0:nijtile) ) 
     323 
     324            ntsi_a(0) = ktsi                 ! Full domain 
     325            ntsj_a(0) = ktsj 
     326            ntei_a(0) = ktei 
     327            ntej_a(0) = ktej 
     328 
     329            DO jt = 1, nijtile               ! Tile domains 
     330               ntsi_a(jt) = Nis0 + nn_ltile_i * MOD(jt - 1, iitile) 
     331               ntsj_a(jt) = Njs0 + nn_ltile_j * ((jt - 1) / iitile) 
     332               ntei_a(jt) = MIN(ntsi_a(jt) + nn_ltile_i - 1, Nie0) 
     333               ntej_a(jt) = MIN(ntsj_a(jt) + nn_ltile_j - 1, Nje0) 
     334            ENDDO 
     335         ENDIF 
     336 
     337         IF(lwp) THEN                  ! control print 
     338            WRITE(numout,*) 
     339            WRITE(numout,*) 'dom_tile : Domain tiling decomposition' 
     340            WRITE(numout,*) '~~~~~~~~' 
     341            IF( ln_tile ) THEN 
     342               WRITE(numout,*) iitile, 'tiles in i' 
     343               WRITE(numout,*) '    Starting indices' 
     344               WRITE(numout,*) '        ', (ntsi_a(jt), jt=1, iitile) 
     345               WRITE(numout,*) '    Ending indices' 
     346               WRITE(numout,*) '        ', (ntei_a(jt), jt=1, iitile) 
     347               WRITE(numout,*) ijtile, 'tiles in j' 
     348               WRITE(numout,*) '    Starting indices' 
     349               WRITE(numout,*) '        ', (ntsj_a(jt), jt=1, nijtile, iitile) 
     350               WRITE(numout,*) '    Ending indices' 
     351               WRITE(numout,*) '        ', (ntej_a(jt), jt=1, nijtile, iitile) 
     352            ELSE 
     353               WRITE(numout,*) 'No domain tiling' 
     354               WRITE(numout,*) '    i indices =', ktsi, ':', ktei 
     355               WRITE(numout,*) '    j indices =', ktsj, ':', ktej 
     356            ENDIF 
     357         ENDIF 
     358      ENDIF 
     359   END SUBROUTINE dom_tile 
     360 
     361 
    275362   SUBROUTINE dom_nam 
    276363      !!---------------------------------------------------------------------- 
    … …  
    281368      !! ** input   : - namrun namelist 
    282369      !!              - namdom namelist 
     370      !!              - namtile namelist 
    283371      !!              - namnc4 namelist   ! "key_netcdf4" only 
    284372      !!---------------------------------------------------------------------- 
    … …  
    293381         &             ln_cfmeta, ln_xios_read, nn_wxios 
    294382      NAMELIST/namdom/ ln_linssh, rn_Dt, rn_atfp, ln_crs, ln_meshmask 
     383      NAMELIST/namtile/ ln_tile, nn_ltile_i, nn_ltile_j 
    295384#if defined key_netcdf4 
    296385      NAMELIST/namnc4/ nn_nchunks_i, nn_nchunks_j, nn_nchunks_k, ln_nc4zip 
    … …  
    429518      r1_Dt = 1._wp / rDt 
    430519 
     520      READ  ( numnam_ref, namtile, IOSTAT = ios, ERR = 905 ) 
     521905   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtile in reference namelist' ) 
     522      READ  ( numnam_cfg, namtile, IOSTAT = ios, ERR = 906 ) 
     523906   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtile in configuration namelist' ) 
     524      IF(lwm) WRITE( numond, namtile ) 
     525 
     526      IF(lwp) THEN 
     527         WRITE(numout,*) 
     528         WRITE(numout,*)    '   Namelist : namtile   ---   Domain tiling decomposition' 
     529         WRITE(numout,*)    '      Tiling (T) or not (F)                ln_tile    = ', ln_tile 
     530         WRITE(numout,*)    '      Length of tile in i                  nn_ltile_i = ', nn_ltile_i 
     531         WRITE(numout,*)    '      Length of tile in j                  nn_ltile_j = ', nn_ltile_j 
     532         WRITE(numout,*) 
     533         IF( ln_tile ) THEN 
     534            WRITE(numout,*) '      The domain will be decomposed into tiles of size', nn_ltile_i, 'x', nn_ltile_j 
     535         ELSE 
     536            WRITE(numout,*) '      Domain tiling will NOT be used' 
     537         ENDIF 
     538      ENDIF 
     539 
    431540      IF( TRIM(Agrif_CFixed()) == '0' ) THEN 
    432541         lrxios = ln_xios_read.AND.ln_rstart 

  • NEMO/trunk/src/OCE/DOM/domutl.F90

    r13458 r13982  
    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/trunk/src/OCE/DOM/domvvl.F90

    r13970 r13982  
    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/trunk/src/OCE/DOM/dtatsd.F90

    r13497 r13982  
    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/trunk/src/OCE/DYN/dynhpg.F90

    r13295 r13982  
    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/trunk/src/OCE/IOM/iom.F90

    r13970 r13982  
    19601960      CHARACTER(LEN=*), INTENT(in) ::   cdname 
    19611961      REAL(sp)        , INTENT(in) ::   pfield0d 
    1962 !!      REAL(wp)        , DIMENSION(jpi,jpj) ::   zz     ! masson 
     1962      !!      REAL(wp)        , DIMENSION(jpi,jpj) ::   zz     ! masson 
    19631963#if defined key_iomput 
    19641964!!clem      zz(:,:)=pfield0d 

  • NEMO/trunk/src/OCE/IOM/prtctl.F90

    r13286 r13982  
    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/trunk/src/OCE/LBC/lbc_lnk_multi_generic.h90

    r13472 r13982  
    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/trunk/src/OCE/LBC/lbclnk.F90

    r13226 r13982  
    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/trunk/src/OCE/LBC/lib_mpp.F90

    r13636 r13982  
    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/trunk/src/OCE/LBC/mpp_lnk_generic.h90

    r13286 r13982  
    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/trunk/src/OCE/LBC/mppini.F90

    r13490 r13982  
    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/trunk/src/OCE/LDF/ldfc1d_c2d.F90

    r13497 r13982  
    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/trunk/src/OCE/LDF/ldftra.F90

    r13558 r13982  
    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/trunk/src/OCE/SBC/sbcflx.F90

    r13497 r13982  
    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/trunk/src/OCE/TRA/eosbn2.F90

    r13497 r13982  
    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/trunk/src/OCE/TRA/traadv.F90

    r13237 r13982  
    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/trunk/src/OCE/TRA/traadv_cen.F90

    r13497 r13982  
    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/trunk/src/OCE/TRA/traadv_fct.F90

    r13497 r13982  
    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/trunk/src/OCE/TRA/traadv_mus.F90

    r13497 r13982  
    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/trunk/src/OCE/TRA/traadv_qck.F90

    r13497 r13982  
    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/trunk/src/OCE/TRA/traadv_ubs.F90

    r13497 r13982  
    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/trunk/src/OCE/TRA/traatf.F90

    r13295 r13982  
    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      ! 
    … …  
    210208      DO jn = 1, kjpt 
    211209         ! 
    212          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     210         DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    213211            ztn = pt(ji,jj,jk,jn,Kmm)                                     
    214212            ztd = pt(ji,jj,jk,jn,Kaa) - 2._wp * ztn + pt(ji,jj,jk,jn,Kbb)  ! time laplacian on tracers 
    … …  
    275273      zfact2 = zfact1 * r1_rho0 
    276274      DO jn = 1, kjpt       
    277          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     275         DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    278276            ze3t_b = e3t(ji,jj,jk,Kbb) 
    279277            ze3t_n = e3t(ji,jj,jk,Kmm) 

  • NEMO/trunk/src/OCE/TRA/traatf_qco.F90

    r13295 r13982  
    149149         ENDIF 
    150150         ! 
    151          CALL lbc_lnk_multi( 'traatfqco', pts(:,:,:,jp_tem,Kbb) , 'T', 1., pts(:,:,:,jp_sal,Kbb) , 'T', 1., & 
    152                   &                    pts(:,:,:,jp_tem,Kmm) , 'T', 1., pts(:,:,:,jp_sal,Kmm) , 'T', 1., & 
    153                   &                    pts(:,:,:,jp_tem,Kaa), 'T', 1., pts(:,:,:,jp_sal,Kaa), 'T', 1.  ) 
    154          ! 
     151         CALL lbc_lnk_multi( 'traatfqco', pts(:,:,:,jp_tem,Kmm) , 'T', 1., pts(:,:,:,jp_sal,Kmm) , 'T', 1. ) 
     152 
    155153      ENDIF 
    156154      ! 
    … …  
    203201      DO jn = 1, kjpt 
    204202         ! 
    205          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     203         DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    206204            ztn = pt(ji,jj,jk,jn,Kmm) 
    207205            ztd = pt(ji,jj,jk,jn,Kaa) - 2._wp * ztn + pt(ji,jj,jk,jn,Kbb)  ! time laplacian on tracers 
    … …  
    268266      zfact2 = zfact1 * r1_rho0 
    269267      DO jn = 1, kjpt 
    270          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     268         DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    271269            ze3t_b = e3t(ji,jj,jk,Kbb) 
    272270            ze3t_n = e3t(ji,jj,jk,Kmm) 

  • NEMO/trunk/src/OCE/TRA/trabbc.F90

    r13295 r13982  
    8080      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts        ! active tracers and RHS of tracer equation 
    8181      ! 
    82       INTEGER  ::   ji, jj    ! dummy loop indices 
     82      INTEGER  ::   ji, jj, jk    ! dummy loop indices 
    8383      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdt   ! 3D workspace 
    8484      !!---------------------------------------------------------------------- 
    … …  
    8686      IF( ln_timing )   CALL timing_start('tra_bbc') 
    8787      ! 
    88       IF( l_trdtra )   THEN         ! Save the input temperature trend 
     88      IF( l_trdtra ) THEN           ! Save the input temperature trend 
    8989         ALLOCATE( ztrdt(jpi,jpj,jpk) ) 
    9090         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 
    … …  
    9696      END_2D 
    9797      ! 
    98       CALL lbc_lnk( 'trabbc', pts(:,:,:,jp_tem,Krhs) , 'T', 1.0_wp ) 
    99       ! 
    10098      IF( l_trdtra ) THEN        ! Send the trend for diagnostics 
    10199         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) 
    … …  
    104102      ENDIF 
    105103      ! 
    106       CALL iom_put ( "hfgeou" , rho0_rcp * qgh_trd0(:,:) ) 
     104      IF( ntile == 0 .OR. ntile == nijtile )  THEN                ! Do only for the full domain 
     105         CALL iom_put ( "hfgeou" , rho0_rcp * qgh_trd0(:,:) ) 
     106      ENDIF 
    107107      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbc  - Ta: ', mask1=tmask, clinfo3='tra-ta' ) 
    108108      ! 

  • NEMO/trunk/src/OCE/TRA/trabbl.F90

    r13532 r13982  
    106106      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts             ! active tracers and RHS of tracer equation 
    107107      ! 
     108      INTEGER  ::   ji, jj, jk   ! Dummy loop indices 
    108109      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdt, ztrds 
    109110      !!---------------------------------------------------------------------- 
    … …  
    112113      ! 
    113114      IF( l_trdtra )   THEN                         !* Save the T-S input trends 
    114          ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 
     115         ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 
    115116         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 
    116117         ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 
    … …  
    125126         CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbl_ldf  - Ta: ', mask1=tmask, & 
    126127            &          tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    127          ! lateral boundary conditions ; just need for outputs 
    128          CALL lbc_lnk_multi( 'trabbl', ahu_bbl, 'U', 1.0_wp , ahv_bbl, 'V', 1.0_wp ) 
    129          CALL iom_put( "ahu_bbl", ahu_bbl )   ! bbl diffusive flux i-coef 
    130          CALL iom_put( "ahv_bbl", ahv_bbl )   ! bbl diffusive flux j-coef 
     128         IF( ntile == 0 .OR. ntile == nijtile ) THEN                       ! Do only on the last tile 
     129            CALL iom_put( "ahu_bbl", ahu_bbl )   ! bbl diffusive flux i-coef 
     130            CALL iom_put( "ahv_bbl", ahv_bbl )   ! bbl diffusive flux j-coef 
     131         ENDIF 
    131132         ! 
    132133      ENDIF 
    … …  
    136137         CALL tra_bbl_adv( pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, Kmm ) 
    137138         IF(sn_cfctl%l_prtctl)   & 
    138          CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbl_adv  - Ta: ', mask1=tmask,   & 
     139         CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbl_adv  - Ta: ', mask1=tmask, & 
    139140            &          tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    140          ! lateral boundary conditions ; just need for outputs 
    141          CALL lbc_lnk_multi( 'trabbl', utr_bbl, 'U', 1.0_wp , vtr_bbl, 'V', 1.0_wp ) 
    142          CALL iom_put( "uoce_bbl", utr_bbl )  ! bbl i-transport 
    143          CALL iom_put( "voce_bbl", vtr_bbl )  ! bbl j-transport 
     141         IF( ntile == 0 .OR. ntile == nijtile ) THEN                       ! Do only on the last tile 
     142            ! lateral boundary conditions ; just need for outputs 
     143            ! NOTE: [tiling-comms-merge] The diagnostic results change along the north fold if this is removed 
     144            CALL lbc_lnk_multi( 'trabbl', utr_bbl, 'U', 1.0_wp , vtr_bbl, 'V', 1.0_wp ) 
     145            CALL iom_put( "uoce_bbl", utr_bbl )  ! bbl i-transport 
     146            CALL iom_put( "voce_bbl", vtr_bbl )  ! bbl j-transport 
     147         ENDIF 
    144148         ! 
    145149      ENDIF 
    … …  
    187191      INTEGER  ::   ik           ! local integers 
    188192      REAL(wp) ::   zbtr         ! local scalars 
    189       REAL(wp), DIMENSION(jpi,jpj) ::   zptb   ! workspace 
     193      REAL(wp), DIMENSION(A2D(nn_hls)) ::   zptb   ! workspace 
    190194      !!---------------------------------------------------------------------- 
    191195      ! 
    … …  
    235239      INTEGER  ::   iis , iid , ijs , ijd    ! local integers 
    236240      INTEGER  ::   ikus, ikud, ikvs, ikvd   !   -       - 
     241      INTEGER  ::   isi, isj                 !   -       - 
    237242      REAL(wp) ::   zbtr, ztra               ! local scalars 
    238243      REAL(wp) ::   zu_bbl, zv_bbl           !   -      - 
    239244      !!---------------------------------------------------------------------- 
    240245      ! 
     246      IF( ntsi == Nis0 ) THEN ; isi = 1 ; ELSE ; isi = 0 ; ENDIF    ! Avoid double-counting when using tiling 
     247      IF( ntsj == Njs0 ) THEN ; isj = 1 ; ELSE ; isj = 0 ; ENDIF 
    241248      !                                                          ! =========== 
    242249      DO jn = 1, kjpt                                            ! tracer loop 
    243250         !                                                       ! =========== 
    244          DO jj = 1, jpjm1 
    245             DO ji = 1, jpim1            ! CAUTION start from i=1 to update i=2 when cyclic east-west 
    246                IF( utr_bbl(ji,jj) /= 0.e0 ) THEN            ! non-zero i-direction bbl advection 
    247                   ! down-slope i/k-indices (deep)      &   up-slope i/k indices (shelf) 
    248                   iid  = ji + MAX( 0, mgrhu(ji,jj) )   ;   iis  = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 
    249                   ikud = mbku_d(ji,jj)                 ;   ikus = mbku(ji,jj) 
    250                   zu_bbl = ABS( utr_bbl(ji,jj) ) 
    251                   ! 
    252                   !                                               ! up  -slope T-point (shelf bottom point) 
    253                   zbtr = r1_e1e2t(iis,jj) / e3t(iis,jj,ikus,Kmm) 
    254                   ztra = zu_bbl * ( pt(iid,jj,ikus,jn) - pt(iis,jj,ikus,jn) ) * zbtr 
    255                   pt_rhs(iis,jj,ikus,jn) = pt_rhs(iis,jj,ikus,jn) + ztra 
    256                   ! 
    257                   DO jk = ikus, ikud-1                            ! down-slope upper to down T-point (deep column) 
    258                      zbtr = r1_e1e2t(iid,jj) / e3t(iid,jj,jk,Kmm) 
    259                      ztra = zu_bbl * ( pt(iid,jj,jk+1,jn) - pt(iid,jj,jk,jn) ) * zbtr 
    260                      pt_rhs(iid,jj,jk,jn) = pt_rhs(iid,jj,jk,jn) + ztra 
    261                   END DO 
    262                   ! 
    263                   zbtr = r1_e1e2t(iid,jj) / e3t(iid,jj,ikud,Kmm) 
    264                   ztra = zu_bbl * ( pt(iis,jj,ikus,jn) - pt(iid,jj,ikud,jn) ) * zbtr 
    265                   pt_rhs(iid,jj,ikud,jn) = pt_rhs(iid,jj,ikud,jn) + ztra 
    266                ENDIF 
    267                ! 
    268                IF( vtr_bbl(ji,jj) /= 0.e0 ) THEN            ! non-zero j-direction bbl advection 
    269                   ! down-slope j/k-indices (deep)        &   up-slope j/k indices (shelf) 
    270                   ijd  = jj + MAX( 0, mgrhv(ji,jj) )     ;   ijs  = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 
    271                   ikvd = mbkv_d(ji,jj)                   ;   ikvs = mbkv(ji,jj) 
    272                   zv_bbl = ABS( vtr_bbl(ji,jj) ) 
    273                   ! 
    274                   ! up  -slope T-point (shelf bottom point) 
    275                   zbtr = r1_e1e2t(ji,ijs) / e3t(ji,ijs,ikvs,Kmm) 
    276                   ztra = zv_bbl * ( pt(ji,ijd,ikvs,jn) - pt(ji,ijs,ikvs,jn) ) * zbtr 
    277                   pt_rhs(ji,ijs,ikvs,jn) = pt_rhs(ji,ijs,ikvs,jn) + ztra 
    278                   ! 
    279                   DO jk = ikvs, ikvd-1                            ! down-slope upper to down T-point (deep column) 
    280                      zbtr = r1_e1e2t(ji,ijd) / e3t(ji,ijd,jk,Kmm) 
    281                      ztra = zv_bbl * ( pt(ji,ijd,jk+1,jn) - pt(ji,ijd,jk,jn) ) * zbtr 
    282                      pt_rhs(ji,ijd,jk,jn) = pt_rhs(ji,ijd,jk,jn)  + ztra 
    283                   END DO 
    284                   !                                               ! down-slope T-point (deep bottom point) 
    285                   zbtr = r1_e1e2t(ji,ijd) / e3t(ji,ijd,ikvd,Kmm) 
    286                   ztra = zv_bbl * ( pt(ji,ijs,ikvs,jn) - pt(ji,ijd,ikvd,jn) ) * zbtr 
    287                   pt_rhs(ji,ijd,ikvd,jn) = pt_rhs(ji,ijd,ikvd,jn) + ztra 
    288                ENDIF 
    289             END DO 
     251         ! NOTE: [tiling-comms-merge] Bug fix- correct order of indices 
     252         DO_2D( isj, 0, isi, 0 )            ! CAUTION start from i=1 to update i=2 when cyclic east-west 
     253            IF( utr_bbl(ji,jj) /= 0.e0 ) THEN            ! non-zero i-direction bbl advection 
     254               ! down-slope i/k-indices (deep)      &   up-slope i/k indices (shelf) 
     255               iid  = ji + MAX( 0, mgrhu(ji,jj) )   ;   iis  = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 
     256               ikud = mbku_d(ji,jj)                 ;   ikus = mbku(ji,jj) 
     257               zu_bbl = ABS( utr_bbl(ji,jj) ) 
     258               ! 
     259               !                                               ! up  -slope T-point (shelf bottom point) 
     260               zbtr = r1_e1e2t(iis,jj) / e3t(iis,jj,ikus,Kmm) 
     261               ztra = zu_bbl * ( pt(iid,jj,ikus,jn) - pt(iis,jj,ikus,jn) ) * zbtr 
     262               pt_rhs(iis,jj,ikus,jn) = pt_rhs(iis,jj,ikus,jn) + ztra 
     263               ! 
     264               DO jk = ikus, ikud-1                            ! down-slope upper to down T-point (deep column) 
     265                  zbtr = r1_e1e2t(iid,jj) / e3t(iid,jj,jk,Kmm) 
     266                  ztra = zu_bbl * ( pt(iid,jj,jk+1,jn) - pt(iid,jj,jk,jn) ) * zbtr 
     267                  pt_rhs(iid,jj,jk,jn) = pt_rhs(iid,jj,jk,jn) + ztra 
     268               END DO 
     269               ! 
     270               zbtr = r1_e1e2t(iid,jj) / e3t(iid,jj,ikud,Kmm) 
     271               ztra = zu_bbl * ( pt(iis,jj,ikus,jn) - pt(iid,jj,ikud,jn) ) * zbtr 
     272               pt_rhs(iid,jj,ikud,jn) = pt_rhs(iid,jj,ikud,jn) + ztra 
     273            ENDIF 
    290274            ! 
    291          END DO 
    292          !                                                  ! =========== 
    293       END DO                                                ! end tracer 
    294       !                                                     ! =========== 
     275            IF( vtr_bbl(ji,jj) /= 0.e0 ) THEN            ! non-zero j-direction bbl advection 
     276               ! down-slope j/k-indices (deep)        &   up-slope j/k indices (shelf) 
     277               ijd  = jj + MAX( 0, mgrhv(ji,jj) )     ;   ijs  = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 
     278               ikvd = mbkv_d(ji,jj)                   ;   ikvs = mbkv(ji,jj) 
     279               zv_bbl = ABS( vtr_bbl(ji,jj) ) 
     280               ! 
     281               ! up  -slope T-point (shelf bottom point) 
     282               zbtr = r1_e1e2t(ji,ijs) / e3t(ji,ijs,ikvs,Kmm) 
     283               ztra = zv_bbl * ( pt(ji,ijd,ikvs,jn) - pt(ji,ijs,ikvs,jn) ) * zbtr 
     284               pt_rhs(ji,ijs,ikvs,jn) = pt_rhs(ji,ijs,ikvs,jn) + ztra 
     285               ! 
     286               DO jk = ikvs, ikvd-1                            ! down-slope upper to down T-point (deep column) 
     287                  zbtr = r1_e1e2t(ji,ijd) / e3t(ji,ijd,jk,Kmm) 
     288                  ztra = zv_bbl * ( pt(ji,ijd,jk+1,jn) - pt(ji,ijd,jk,jn) ) * zbtr 
     289                  pt_rhs(ji,ijd,jk,jn) = pt_rhs(ji,ijd,jk,jn)  + ztra 
     290               END DO 
     291               !                                               ! down-slope T-point (deep bottom point) 
     292               zbtr = r1_e1e2t(ji,ijd) / e3t(ji,ijd,ikvd,Kmm) 
     293               ztra = zv_bbl * ( pt(ji,ijs,ikvs,jn) - pt(ji,ijd,ikvd,jn) ) * zbtr 
     294               pt_rhs(ji,ijd,ikvd,jn) = pt_rhs(ji,ijd,ikvd,jn) + ztra 
     295            ENDIF 
     296         END_2D 
     297         !                                                       ! =========== 
     298      END DO                                                     ! end tracer 
     299      !                                                          ! =========== 
    295300   END SUBROUTINE tra_bbl_adv 
    296301 
    … …  
    333338      REAL(wp) ::   za, zb, zgdrho            ! local scalars 
    334339      REAL(wp) ::   zsign, zsigna, zgbbl      !   -      - 
    335       REAL(wp), DIMENSION(jpi,jpj,jpts)   :: zts, zab         ! 3D workspace 
    336       REAL(wp), DIMENSION(jpi,jpj)        :: zub, zvb, zdep   ! 2D workspace 
    337       !!---------------------------------------------------------------------- 
    338       ! 
    339       IF( kt == kit000 )  THEN 
    340          IF(lwp)  WRITE(numout,*) 
    341          IF(lwp)  WRITE(numout,*) 'trabbl:bbl : Compute bbl velocities and diffusive coefficients in ', cdtype 
    342          IF(lwp)  WRITE(numout,*) '~~~~~~~~~~' 
     340      REAL(wp), DIMENSION(A2D(nn_hls),jpts)   :: zts, zab         ! 3D workspace 
     341      REAL(wp), DIMENSION(A2D(nn_hls))        :: zub, zvb, zdep   ! 2D workspace 
     342      !!---------------------------------------------------------------------- 
     343      ! 
     344      IF( ntile == 0 .OR. ntile == 1 )  THEN                       ! Do only on the first tile 
     345         IF( kt == kit000 )  THEN 
     346            IF(lwp)  WRITE(numout,*) 
     347            IF(lwp)  WRITE(numout,*) 'trabbl:bbl : Compute bbl velocities and diffusive coefficients in ', cdtype 
     348            IF(lwp)  WRITE(numout,*) '~~~~~~~~~~' 
     349         ENDIF 
    343350      ENDIF 
    344351      !                                        !* bottom variables (T, S, alpha, beta, depth, velocity) 

  • NEMO/trunk/src/OCE/TRA/tradmp.F90

    r13295 r13982  
    9595      ! 
    9696      INTEGER ::   ji, jj, jk, jn   ! dummy loop indices 
    97       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts)     ::  zts_dta 
     97      REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts)     ::  zts_dta 
    9898      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::  ztrdts 
    9999      !!---------------------------------------------------------------------- 
    … …  
    102102      ! 
    103103      IF( l_trdtra )   THEN                    !* Save ta and sa trends 
    104          ALLOCATE( ztrdts(jpi,jpj,jpk,jpts) )  
    105          ztrdts(:,:,:,:) = pts(:,:,:,:,Krhs)  
     104         ALLOCATE( ztrdts(jpi,jpj,jpk,jpts) ) 
     105         ztrdts(:,:,:,:) = pts(:,:,:,:,Krhs) 
    106106      ENDIF 
    107107      !                           !==  input T-S data at kt  ==! 
    … …  
    144144         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_dmp, ztrdts(:,:,:,jp_tem) ) 
    145145         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_dmp, ztrdts(:,:,:,jp_sal) ) 
    146          DEALLOCATE( ztrdts )  
     146         DEALLOCATE( ztrdts ) 
    147147      ENDIF 
    148148      !                           ! Control print 

  • NEMO/trunk/src/OCE/TRA/traisf.F90

    r13295 r13982  
    1111   !!---------------------------------------------------------------------- 
    1212   USE isf_oce                                     ! Ice shelf variables 
     13   USE par_oce , ONLY : nijtile, ntile, ntsi, ntei, ntsj, ntej 
    1314   USE dom_oce                                     ! ocean space domain variables 
    1415   USE isfutils, ONLY : debug                      ! debug option 
    … …  
    4647      IF( ln_timing )   CALL timing_start('tra_isf') 
    4748      ! 
    48       IF( kt == nit000 ) THEN 
    49          IF(lwp) WRITE(numout,*) 
    50          IF(lwp) WRITE(numout,*) 'tra_isf : Ice shelf heat fluxes' 
    51          IF(lwp) WRITE(numout,*) '~~~~~~~ ' 
     49      IF( ntile == 0 .OR. ntile == 1 )  THEN                       ! Do only on the first tile 
     50         IF( kt == nit000 ) THEN 
     51            IF(lwp) WRITE(numout,*) 
     52            IF(lwp) WRITE(numout,*) 'tra_isf : Ice shelf heat fluxes' 
     53            IF(lwp) WRITE(numout,*) '~~~~~~~ ' 
     54         ENDIF 
    5255      ENDIF 
    5356      ! 
    … …  
    7679      ! 
    7780      IF ( ln_isfdebug ) THEN 
    78          CALL debug('tra_isf: pts(:,:,:,:,Krhs) T', pts(:,:,:,1,Krhs)) 
    79          CALL debug('tra_isf: pts(:,:,:,:,Krhs) S', pts(:,:,:,2,Krhs)) 
     81         IF( ntile == 0 .OR. ntile == nijtile ) THEN                       ! Do only for the full domain 
     82            CALL debug('tra_isf: pts(:,:,:,:,Krhs) T', pts(:,:,:,1,Krhs)) 
     83            CALL debug('tra_isf: pts(:,:,:,:,Krhs) S', pts(:,:,:,2,Krhs)) 
     84         ENDIF 
    8085      END IF 
    8186      ! 
    … …  
    101106      INTEGER                      :: ji,jj,jk  ! loop index    
    102107      INTEGER                      :: ikt, ikb  ! top and bottom level of the tbl 
    103       REAL(wp), DIMENSION(jpi,jpj) :: ztc       ! total ice shelf tracer trend 
     108      REAL(wp), DIMENSION(A2D(nn_hls))    :: ztc       ! total ice shelf tracer trend 
    104109      !!---------------------------------------------------------------------- 
    105110      ! 
    106111      ! compute 2d total trend due to isf 
    107       ztc(:,:) = 0.5_wp * ( ptsc(:,:,jp_tem) + ptsc_b(:,:,jp_tem) ) / phtbl(:,:) 
     112      DO_2D( 0, 0, 0, 0 ) 
     113         ztc(ji,jj) = 0.5_wp * ( ptsc(ji,jj,jp_tem) + ptsc_b(ji,jj,jp_tem) ) / phtbl(ji,jj) 
     114      END_2D 
    108115      ! 
    109116      ! update pts(:,:,:,:,Krhs) 
    110       DO_2D( 1, 1, 1, 1 ) 
     117      DO_2D( 0, 0, 0, 0 ) 
    111118         ! 
    112119         ikt = ktop(ji,jj) 
    … …  
    137144      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) :: ptsc 
    138145      !!---------------------------------------------------------------------- 
    139       INTEGER :: jk 
     146      INTEGER :: ji, jj, jk 
    140147      !!---------------------------------------------------------------------- 
    141148      ! 
    142       DO jk = 1,jpk 
    143          ptsa(:,:,jk,jp_tem) =   & 
    144             &  ptsa(:,:,jk,jp_tem) + ptsc(:,:,jk,jp_tem) * r1_e1e2t(:,:) / e3t(:,:,jk,Kmm) 
    145          ptsa(:,:,jk,jp_sal) =   & 
    146             &  ptsa(:,:,jk,jp_sal) + ptsc(:,:,jk,jp_sal) * r1_e1e2t(:,:) / e3t(:,:,jk,Kmm) 
    147       END DO 
     149      DO_3D( 0, 0, 0, 0, 1, jpk ) 
     150         ptsa(ji,jj,jk,jp_tem) = ptsa(ji,jj,jk,jp_tem) + ptsc(ji,jj,jk,jp_tem) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     151         ptsa(ji,jj,jk,jp_sal) = ptsa(ji,jj,jk,jp_sal) + ptsc(ji,jj,jk,jp_sal) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     152      END_3D 
    148153      ! 
    149154   END SUBROUTINE tra_isf_cpl 

  • NEMO/trunk/src/OCE/TRA/traldf.F90

    r12377 r13982  
    1717   USE oce            ! ocean dynamics and tracers 
    1818   USE dom_oce        ! ocean space and time domain 
     19   ! TEMP: [tiling] This change not necessary after extra haloes development (lbc_lnk removed from tra_ldf_blp, zps_hde*) 
     20   USE domain, ONLY : dom_tile 
    1921   USE phycst         ! physical constants 
    2022   USE ldftra         ! lateral diffusion: eddy diffusivity & EIV coeff. 
    … …  
    3739   PUBLIC   tra_ldf        ! called by step.F90  
    3840   PUBLIC   tra_ldf_init   ! called by nemogcm.F90  
    39     
     41 
    4042   !!---------------------------------------------------------------------- 
    4143   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    5658      !! 
    5759      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdt, ztrds 
     60      ! TEMP: [tiling] This change not necessary after extra haloes development (lbc_lnk removed from tra_ldf_blp, zps_hde*) 
     61      LOGICAL :: lskip 
    5862      !!---------------------------------------------------------------------- 
    5963      ! 
    6064      IF( ln_timing )   CALL timing_start('tra_ldf') 
    6165      ! 
     66      lskip = .FALSE. 
     67 
    6268      IF( l_trdtra )   THEN                    !* Save ta and sa trends 
    63          ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) )  
    64          ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs)  
     69         ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 
     70         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 
    6571         ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 
    6672      ENDIF 
    67       ! 
    68       SELECT CASE ( nldf_tra )                 !* compute lateral mixing trend and add it to the general trend 
    69       CASE ( np_lap   )                                  ! laplacian: iso-level operator 
    70          CALL tra_ldf_lap  ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs),                   jpts,  1 ) 
    71       CASE ( np_lap_i )                                  ! laplacian: standard iso-neutral operator (Madec) 
    72          CALL tra_ldf_iso  ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts,  1 ) 
    73       CASE ( np_lap_it )                                 ! laplacian: triad iso-neutral operator (griffies) 
    74          CALL tra_ldf_triad( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts,  1 ) 
    75       CASE ( np_blp , np_blp_i , np_blp_it )             ! bilaplacian: iso-level & iso-neutral operators 
    76          CALL tra_ldf_blp  ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs),             jpts, nldf_tra ) 
    77       END SELECT 
    78       ! 
    79       IF( l_trdtra )   THEN                    !* save the horizontal diffusive trends for further diagnostics 
    80          ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) 
    81          ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) - ztrds(:,:,:) 
    82          CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_ldf, ztrdt ) 
    83          CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_ldf, ztrds ) 
    84          DEALLOCATE( ztrdt, ztrds )  
     73 
     74      ! TEMP: [tiling] These changes not necessary after extra haloes development (lbc_lnk removed from tra_ldf_blp, zps_hde*) 
     75      IF( nldf_tra == np_blp .OR. nldf_tra == np_blp_i .OR. nldf_tra == np_blp_it )  THEN 
     76         IF( ln_tile ) THEN 
     77            IF( ntile == 1 ) THEN 
     78               CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) 
     79            ELSE 
     80               lskip = .TRUE. 
     81            ENDIF 
     82         ENDIF 
     83      ENDIF 
     84      IF( .NOT. lskip ) THEN 
     85         ! 
     86         SELECT CASE ( nldf_tra )                 !* compute lateral mixing trend and add it to the general trend 
     87         CASE ( np_lap   )                                  ! laplacian: iso-level operator 
     88            CALL tra_ldf_lap  ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs),                   jpts,  1 ) 
     89         CASE ( np_lap_i )                                  ! laplacian: standard iso-neutral operator (Madec) 
     90            CALL tra_ldf_iso  ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts,  1 ) 
     91         CASE ( np_lap_it )                                 ! laplacian: triad iso-neutral operator (griffies) 
     92            CALL tra_ldf_triad( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts,  1 ) 
     93         CASE ( np_blp , np_blp_i , np_blp_it )             ! bilaplacian: iso-level & iso-neutral operators 
     94            ! NOTE: [tiling-comms-merge] This lbc_lnk is still needed in the zco case, because zps_hde is not called in step 
     95            IF(nn_hls.EQ.2) CALL lbc_lnk( 'tra_ldf', pts(:,:,:,:,Kbb), 'T',1.) 
     96            CALL tra_ldf_blp  ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs),             jpts, nldf_tra ) 
     97         END SELECT 
     98         ! 
     99         IF( l_trdtra )   THEN                    !* save the horizontal diffusive trends for further diagnostics 
     100            ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) 
     101            ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) - ztrds(:,:,:) 
     102            CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_ldf, ztrdt ) 
     103            CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_ldf, ztrds ) 
     104            DEALLOCATE( ztrdt, ztrds ) 
     105         ENDIF 
     106 
     107         ! TEMP: [tiling] This change not necessary after extra haloes development (lbc_lnk removed from tra_ldf_blp, zps_hde*) 
     108         IF( ln_tile .AND. ntile == 0 ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 1 ) 
    85109      ENDIF 
    86110      !                                        !* print mean trends (used for debugging) 
    87       IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' ldf  - Ta: ', mask1=tmask,               & 
     111      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' ldf  - Ta: ', mask1=tmask, & 
    88112         &                                  tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    89113      ! 

  • NEMO/trunk/src/OCE/TRA/traldf_iso.F90

    r13497 r13982  
    1919   USE oce            ! ocean dynamics and active tracers 
    2020   USE dom_oce        ! ocean space and time domain 
     21   USE domutl, ONLY : is_tile 
    2122   USE trc_oce        ! share passive tracers/Ocean variables 
    2223   USE zdf_oce        ! ocean vertical physics 
    … …  
    4950CONTAINS 
    5051 
    51   SUBROUTINE tra_ldf_iso( kt, Kmm, kit000, cdtype, pahu, pahv,                    & 
    52       &                                            pgu , pgv    ,   pgui, pgvi,   & 
    53       &                                       pt , pt2 , pt_rhs , kjpt  , kpass ) 
     52   SUBROUTINE tra_ldf_iso( kt, Kmm, kit000, cdtype, pahu, pahv,             & 
     53      &                                             pgu , pgv , pgui, pgvi, & 
     54      &                                             pt, pt2, pt_rhs, kjpt, kpass ) 
     55      !! 
     56      INTEGER                     , INTENT(in   ) ::   kt         ! ocean time-step index 
     57      INTEGER                     , INTENT(in   ) ::   kit000     ! first time step index 
     58      CHARACTER(len=3)            , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator) 
     59      INTEGER                     , INTENT(in   ) ::   kjpt       ! number of tracers 
     60      INTEGER                     , INTENT(in   ) ::   kpass      ! =1/2 first or second passage 
     61      INTEGER                     , INTENT(in   ) ::   Kmm        ! ocean time level index 
     62      REAL(wp), DIMENSION(:,:,:)  , INTENT(in   ) ::   pahu, pahv ! eddy diffusivity at u- and v-points  [m2/s] 
     63      REAL(wp), DIMENSION(:,:,:)  , INTENT(in   ) ::   pgu, pgv   ! tracer gradient at pstep levels 
     64      REAL(wp), DIMENSION(:,:,:)  , INTENT(in   ) ::   pgui, pgvi ! tracer gradient at top   levels 
     65      REAL(wp), DIMENSION(:,:,:,:), INTENT(in   ) ::   pt         ! tracer (kpass=1) or laplacian of tracer (kpass=2) 
     66      REAL(wp), DIMENSION(:,:,:,:), INTENT(in   ) ::   pt2        ! tracer (only used in kpass=2) 
     67      REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) ::   pt_rhs     ! tracer trend 
     68      !! 
     69      CALL tra_ldf_iso_t( kt, Kmm, kit000, cdtype, pahu, pahv, is_tile(pahu),                             & 
     70         &                                         pgu , pgv , is_tile(pgu) , pgui, pgvi, is_tile(pgui),  & 
     71         &                                         pt, is_tile(pt), pt2, is_tile(pt2), pt_rhs, is_tile(pt_rhs), kjpt, kpass ) 
     72   END SUBROUTINE tra_ldf_iso 
     73 
     74 
     75  SUBROUTINE tra_ldf_iso_t( kt, Kmm, kit000, cdtype, pahu, pahv, ktah,                    & 
     76      &                                              pgu , pgv , ktg , pgui, pgvi, ktgi,  & 
     77      &                                              pt, ktt, pt2, ktt2, pt_rhs, ktt_rhs, kjpt, kpass ) 
    5478      !!---------------------------------------------------------------------- 
    5579      !!                  ***  ROUTINE tra_ldf_iso  *** 
    … …  
    92116      !! ** Action :   Update pt_rhs arrays with the before rotated diffusion 
    93117      !!---------------------------------------------------------------------- 
    94       INTEGER                              , INTENT(in   ) ::   kt         ! ocean time-step index 
    95       INTEGER                              , INTENT(in   ) ::   kit000     ! first time step index 
    96       CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator) 
    97       INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers 
    98       INTEGER                              , INTENT(in   ) ::   kpass      ! =1/2 first or second passage 
    99       INTEGER                              , INTENT(in   ) ::   Kmm        ! ocean time level index 
    100       REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(in   ) ::   pahu, pahv ! eddy diffusivity at u- and v-points  [m2/s] 
    101       REAL(wp), DIMENSION(jpi,jpj    ,kjpt), INTENT(in   ) ::   pgu, pgv   ! tracer gradient at pstep levels 
    102       REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(in   ) ::   pgui, pgvi ! tracer gradient at top   levels 
    103       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   pt         ! tracer (kpass=1) or laplacian of tracer (kpass=2) 
    104       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   pt2        ! tracer (only used in kpass=2) 
    105       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pt_rhs     ! tracer trend 
     118      INTEGER                                   , INTENT(in   ) ::   kt         ! ocean time-step index 
     119      INTEGER                                   , INTENT(in   ) ::   kit000     ! first time step index 
     120      CHARACTER(len=3)                          , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator) 
     121      INTEGER                                   , INTENT(in   ) ::   kjpt       ! number of tracers 
     122      INTEGER                                   , INTENT(in   ) ::   kpass      ! =1/2 first or second passage 
     123      INTEGER                                   , INTENT(in   ) ::   Kmm        ! ocean time level index 
     124      INTEGER                                   , INTENT(in   ) ::   ktah, ktg, ktgi, ktt, ktt2, ktt_rhs 
     125      REAL(wp), DIMENSION(A2D_T(ktah)   ,JPK)     , INTENT(in   ) ::   pahu, pahv ! eddy diffusivity at u- and v-points  [m2/s] 
     126      REAL(wp), DIMENSION(A2D_T(ktg)        ,KJPT), INTENT(in   ) ::   pgu, pgv   ! tracer gradient at pstep levels 
     127      REAL(wp), DIMENSION(A2D_T(ktgi)       ,KJPT), INTENT(in   ) ::   pgui, pgvi ! tracer gradient at top   levels 
     128      REAL(wp), DIMENSION(A2D_T(ktt)    ,JPK,KJPT), INTENT(in   ) ::   pt         ! tracer (kpass=1) or laplacian of tracer (kpass=2) 
     129      REAL(wp), DIMENSION(A2D_T(ktt2)   ,JPK,KJPT), INTENT(in   ) ::   pt2        ! tracer (only used in kpass=2) 
     130      REAL(wp), DIMENSION(A2D_T(ktt_rhs),JPK,KJPT), INTENT(inout) ::   pt_rhs     ! tracer trend 
    106131      ! 
    107132      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices 
    … …  
    111136      REAL(wp) ::  zmskv, zahv_w, zabe2, zcof2, zcoef4   !   -      - 
    112137      REAL(wp) ::  zcoef0, ze3w_2, zsign                 !   -      - 
    113       REAL(wp), DIMENSION(jpi,jpj)     ::   zdkt, zdk1t, z2d 
    114       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zdit, zdjt, zftu, zftv, ztfw  
     138      REAL(wp), DIMENSION(A2D(nn_hls))     ::   zdkt, zdk1t, z2d 
     139      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::   zdit, zdjt, zftu, zftv, ztfw 
    115140      !!---------------------------------------------------------------------- 
    116141      ! 
    117142      IF( kpass == 1 .AND. kt == kit000 )  THEN 
    118          IF(lwp) WRITE(numout,*) 
    119          IF(lwp) WRITE(numout,*) 'tra_ldf_iso : rotated laplacian diffusion operator on ', cdtype 
    120          IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
    121          ! 
    122          akz     (:,:,:) = 0._wp       
    123          ah_wslp2(:,:,:) = 0._wp 
     143         IF( ntile == 0 .OR. ntile == 1 )  THEN                       ! Do only on the first tile 
     144            IF(lwp) WRITE(numout,*) 
     145            IF(lwp) WRITE(numout,*) 'tra_ldf_iso : rotated laplacian diffusion operator on ', cdtype 
     146            IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
     147         ENDIF 
     148         ! 
     149         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     150            akz     (ji,jj,jk) = 0._wp 
     151            ah_wslp2(ji,jj,jk) = 0._wp 
     152         END_3D 
    124153      ENDIF 
    125       !    
    126       l_hst = .FALSE. 
    127       l_ptr = .FALSE. 
    128       IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) )     l_ptr = .TRUE.  
    129       IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 
    130          &                        iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) )   l_hst = .TRUE. 
     154      ! 
     155      IF( ntile == 0 .OR. ntile == 1 )  THEN                           ! Do only on the first tile 
     156         l_hst = .FALSE. 
     157         l_ptr = .FALSE. 
     158         IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) )     l_ptr = .TRUE. 
     159         IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 
     160            &                        iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) )   l_hst = .TRUE. 
     161      ENDIF 
    131162      ! 
    132163      ! 
    … …  
    167198            ! 
    168199            IF( ln_traldf_blp ) THEN                ! bilaplacian operator 
    169                DO_3D( 1, 0, 1, 0, 2, jpkm1 ) 
     200               DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
    170201                  akz(ji,jj,jk) = 16._wp   & 
    171202                     &   * ah_wslp2   (ji,jj,jk)   & 
    … …  
    175206               END_3D 
    176207            ELSEIF( ln_traldf_lap ) THEN              ! laplacian operator 
    177                DO_3D( 1, 0, 1, 0, 2, jpkm1 ) 
     208               DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
    178209                  ze3w_2 = e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) 
    179210                  zcoef0 = rDt * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2  ) 
    … …  
    183214           ! 
    184215         ELSE                                    ! 33 flux set to zero with akz=ah_wslp2 ==>> computed in full implicit 
    185             akz(:,:,:) = ah_wslp2(:,:,:)       
     216            DO_3D( 0, 0, 0, 0, 1, jpk ) 
     217               akz(ji,jj,jk) = ah_wslp2(ji,jj,jk) 
     218            END_3D 
    186219         ENDIF 
    187220      ENDIF 
    … …  
    195228         !!---------------------------------------------------------------------- 
    196229!!gm : bug.... why (x,:,:)?   (1,jpj,:) and (jpi,1,:) should be sufficient.... 
    197          zdit (1,:,:) = 0._wp     ;     zdit (jpi,:,:) = 0._wp 
    198          zdjt (1,:,:) = 0._wp     ;     zdjt (jpi,:,:) = 0._wp 
     230         zdit (ntsi-nn_hls,:,:) = 0._wp     ;     zdit (ntei+nn_hls,:,:) = 0._wp 
     231         zdjt (ntsi-nn_hls,:,:) = 0._wp     ;     zdjt (ntei+nn_hls,:,:) = 0._wp 
    199232         !!end 
    200233 
    … …  
    223256         DO jk = 1, jpkm1                                 ! Horizontal slab 
    224257            ! 
    225             !                             !== Vertical tracer gradient 
    226             zdk1t(:,:) = ( pt(:,:,jk,jn) - pt(:,:,jk+1,jn) ) * wmask(:,:,jk+1)     ! level jk+1 
    227             ! 
    228             IF( jk == 1 ) THEN   ;   zdkt(:,:) = zdk1t(:,:)                          ! surface: zdkt(jk=1)=zdkt(jk=2) 
    229             ELSE                 ;   zdkt(:,:) = ( pt(:,:,jk-1,jn) - pt(:,:,jk,jn) ) * wmask(:,:,jk) 
    230             ENDIF 
     258            DO_2D( 1, 1, 1, 1 ) 
     259               !                             !== Vertical tracer gradient 
     260               zdk1t(ji,jj) = ( pt(ji,jj,jk,jn) - pt(ji,jj,jk+1,jn) ) * wmask(ji,jj,jk+1)     ! level jk+1 
     261               ! 
     262               IF( jk == 1 ) THEN   ;   zdkt(ji,jj) = zdk1t(ji,jj)                            ! surface: zdkt(jk=1)=zdkt(jk=2) 
     263               ELSE                 ;   zdkt(ji,jj) = ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) * wmask(ji,jj,jk) 
     264               ENDIF 
     265            END_2D 
     266            ! 
    231267            DO_2D( 1, 0, 1, 0 )           !==  Horizontal fluxes 
    232268               zabe1 = pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) 
    … …  
    330366      END DO                                                      ! end tracer loop 
    331367      ! 
    332    END SUBROUTINE tra_ldf_iso 
     368   END SUBROUTINE tra_ldf_iso_t 
    333369 
    334370   !!============================================================================== 

  • NEMO/trunk/src/OCE/TRA/traldf_lap_blp.F90

    r13497 r13982  
    1313   USE oce            ! ocean dynamics and active tracers 
    1414   USE dom_oce        ! ocean space and time domain 
     15   USE domutl, ONLY : is_tile 
    1516   USE ldftra         ! lateral physics: eddy diffusivity 
    1617   USE traldf_iso     ! iso-neutral lateral diffusion (standard operator)     (tra_ldf_iso   routine) 
    … …  
    4647CONTAINS 
    4748 
    48    SUBROUTINE tra_ldf_lap( kt, Kmm, kit000, cdtype, pahu, pahv  ,               & 
    49       &                                             pgu , pgv   , pgui, pgvi,   & 
    50       &                                             pt  , pt_rhs, kjpt, kpass )  
     49   SUBROUTINE tra_ldf_lap( kt, Kmm, kit000, cdtype, pahu, pahv,             & 
     50      &                                             pgu , pgv , pgui, pgvi, & 
     51      &                                             pt, pt_rhs, kjpt, kpass ) 
     52      !! 
     53      INTEGER                     , INTENT(in   ) ::   kt         ! ocean time-step index 
     54      INTEGER                     , INTENT(in   ) ::   kit000     ! first time step index 
     55      CHARACTER(len=3)            , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator) 
     56      INTEGER                     , INTENT(in   ) ::   kjpt       ! number of tracers 
     57      INTEGER                     , INTENT(in   ) ::   kpass      ! =1/2 first or second passage 
     58      INTEGER                     , INTENT(in   ) ::   Kmm        ! ocean time level index 
     59      REAL(wp), DIMENSION(:,:,:)  , INTENT(in   ) ::   pahu, pahv ! eddy diffusivity at u- and v-points  [m2/s] 
     60      REAL(wp), DIMENSION(:,:,:)  , INTENT(in   ) ::   pgu, pgv   ! tracer gradient at pstep levels 
     61      REAL(wp), DIMENSION(:,:,:)  , INTENT(in   ) ::   pgui, pgvi ! tracer gradient at top   levels 
     62      REAL(wp), DIMENSION(:,:,:,:), INTENT(in   ) ::   pt         ! before tracer fields 
     63      REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) ::   pt_rhs     ! tracer trend 
     64      !! 
     65      CALL tra_ldf_lap_t( kt, Kmm, kit000, cdtype, pahu, pahv, is_tile(pahu),                            & 
     66      &                                            pgu , pgv , is_tile(pgu) , pgui, pgvi, is_tile(pgui), & 
     67      &                                            pt, is_tile(pt), pt_rhs, is_tile(pt_rhs), kjpt, kpass ) 
     68   END SUBROUTINE tra_ldf_lap 
     69 
     70 
     71   SUBROUTINE tra_ldf_lap_t( kt, Kmm, kit000, cdtype, pahu, pahv, ktah,                   & 
     72      &                                               pgu , pgv , ktg , pgui, pgvi, ktgi, & 
     73      &                                               pt, ktt, pt_rhs, ktt_rhs, kjpt, kpass ) 
    5174      !!---------------------------------------------------------------------- 
    5275      !!                  ***  ROUTINE tra_ldf_lap  *** 
    … …  
    7295      INTEGER                              , INTENT(in   ) ::   kpass      ! =1/2 first or second passage 
    7396      INTEGER                              , INTENT(in   ) ::   Kmm        ! ocean time level index 
    74       REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(in   ) ::   pahu, pahv ! eddy diffusivity at u- and v-points  [m2/s] 
    75       REAL(wp), DIMENSION(jpi,jpj    ,kjpt), INTENT(in   ) ::   pgu, pgv   ! tracer gradient at pstep levels 
    76       REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(in   ) ::   pgui, pgvi ! tracer gradient at top   levels 
    77       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   pt         ! before tracer fields 
    78       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pt_rhs     ! tracer trend  
    79       ! 
    80       INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    81       REAL(wp) ::   zsign            ! local scalars 
    82       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   ztu, ztv, zaheeu, zaheev 
    83       !!---------------------------------------------------------------------- 
    84       ! 
    85       IF( kt == nit000 .AND. lwp )  THEN 
    86          WRITE(numout,*) 
    87          WRITE(numout,*) 'tra_ldf_lap : iso-level laplacian diffusion on ', cdtype, ', pass=', kpass 
    88          WRITE(numout,*) '~~~~~~~~~~~ ' 
    89       ENDIF 
    90       ! 
    91       l_hst = .FALSE. 
    92       l_ptr = .FALSE. 
    93       IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) )     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. 
     97      INTEGER                              , INTENT(in   ) ::   ktah, ktg, ktgi, ktt, ktt_rhs 
     98      REAL(wp), DIMENSION(A2D_T(ktah),   JPK)     , INTENT(in   ) ::   pahu, pahv ! eddy diffusivity at u- and v-points  [m2/s] 
     99      REAL(wp), DIMENSION(A2D_T(ktg),        KJPT), INTENT(in   ) ::   pgu, pgv   ! tracer gradient at pstep levels 
     100      REAL(wp), DIMENSION(A2D_T(ktgi),       KJPT), INTENT(in   ) ::   pgui, pgvi ! tracer gradient at top   levels 
     101      REAL(wp), DIMENSION(A2D_T(ktt),    JPK,KJPT), INTENT(in   ) ::   pt         ! before tracer fields 
     102      REAL(wp), DIMENSION(A2D_T(ktt_rhs),JPK,KJPT), INTENT(inout) ::   pt_rhs     ! tracer trend 
     103      ! 
     104      INTEGER  ::   ji, jj, jk, jn      ! dummy loop indices 
     105      INTEGER  ::   isi, iei, isj, iej  ! local integers 
     106      REAL(wp) ::   zsign               ! local scalars 
     107      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::   ztu, ztv, zaheeu, zaheev 
     108      !!---------------------------------------------------------------------- 
     109      ! 
     110      IF( ntile == 0 .OR. ntile == 1 )  THEN                       ! Do only on the first tile 
     111         IF( kt == nit000 .AND. lwp )  THEN 
     112            WRITE(numout,*) 
     113            WRITE(numout,*) 'tra_ldf_lap : iso-level laplacian diffusion on ', cdtype, ', pass=', kpass 
     114            WRITE(numout,*) '~~~~~~~~~~~ ' 
     115         ENDIF 
     116         ! 
     117         l_hst = .FALSE. 
     118         l_ptr = .FALSE. 
     119         IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) )     l_ptr = .TRUE. 
     120         IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 
     121            &                        iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) )  l_hst = .TRUE. 
     122      ENDIF 
    96123      ! 
    97124      !                                !==  Initialization of metric arrays used for all tracers  ==! 
    … …  
    99126      ELSE                    ;   zsign = -1._wp 
    100127      ENDIF 
    101       DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 
     128 
     129      IF( ntsi == Nis0 ) THEN ; isi = nn_hls - 1 ; ELSE ; isi = 0 ; ENDIF    ! Avoid double-counting when using tiling 
     130      IF( ntsj == Njs0 ) THEN ; isj = nn_hls - 1 ; ELSE ; isj = 0 ; ENDIF 
     131      IF( ntei == Nie0 ) THEN ; iei = nn_hls - 1 ; ELSE ; iei = 0 ; ENDIF 
     132      IF( ntej == Nje0 ) THEN ; iej = nn_hls - 1 ; ELSE ; iej = 0 ; ENDIF 
     133 
     134      DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 )            !== First derivative (gradient)  ==! 
    102135         zaheeu(ji,jj,jk) = zsign * pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm)   !!gm   * umask(ji,jj,jk) pah masked! 
    103136         zaheev(ji,jj,jk) = zsign * pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm)   !!gm   * vmask(ji,jj,jk) 
    … …  
    108141         !                          ! =========== !     
    109142         !                                
    110          DO_3D( 1, 0, 1, 0, 1, jpkm1 )            !== First derivative (gradient)  ==! 
     143         DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 )            !== First derivative (gradient)  ==! 
    111144            ztu(ji,jj,jk) = zaheeu(ji,jj,jk) * ( pt(ji+1,jj  ,jk,jn) - pt(ji,jj,jk,jn) ) 
    112145            ztv(ji,jj,jk) = zaheev(ji,jj,jk) * ( pt(ji  ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) 
    113146         END_3D 
    114147         IF( ln_zps ) THEN                             ! set gradient at bottom/top ocean level 
    115             DO_2D( 1, 0, 1, 0 )                              ! bottom 
     148            DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 )                              ! bottom 
    116149               ztu(ji,jj,mbku(ji,jj)) = zaheeu(ji,jj,mbku(ji,jj)) * pgu(ji,jj,jn) 
    117150               ztv(ji,jj,mbkv(ji,jj)) = zaheev(ji,jj,mbkv(ji,jj)) * pgv(ji,jj,jn) 
    118151            END_2D 
    119152            IF( ln_isfcav ) THEN                             ! top in ocean cavities only 
    120                DO_2D( 1, 0, 1, 0 ) 
     153               DO_2D( nn_hls, nn_hls-1, nn_hls, nn_hls-1 ) 
    121154                  IF( miku(ji,jj) > 1 )   ztu(ji,jj,miku(ji,jj)) = zaheeu(ji,jj,miku(ji,jj)) * pgui(ji,jj,jn)  
    122155                  IF( mikv(ji,jj) > 1 )   ztv(ji,jj,mikv(ji,jj)) = zaheev(ji,jj,mikv(ji,jj)) * pgvi(ji,jj,jn)  
    … …  
    125158         ENDIF 
    126159         ! 
    127          DO_3D( 0, 0, 0, 0, 1, jpkm1 )            !== Second derivative (divergence) added to the general tracer trends  ==! 
     160         ! NOTE: [tiling-comms-merge] Bounds changed to avoid repeating this calculation for overlapping rows when using tiling 
     161         DO_3D( isj, iej, isi, iei, 1, jpkm1 )            !== Second derivative (divergence) added to the general tracer trends  ==! 
    128162            pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)     & 
    129163               &                                      +    ztv(ji,jj,jk) - ztv(ji,jj-1,jk) )   & 
    … …  
    142176      !                             ! ================== 
    143177      ! 
    144    END SUBROUTINE tra_ldf_lap 
     178   END SUBROUTINE tra_ldf_lap_t 
    145179    
    146180 
    … …  
    173207      ! 
    174208      INTEGER ::   ji, jj, jk, jn   ! dummy loop indices 
    175       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt) :: zlap         ! laplacian at t-point 
    176       REAL(wp), DIMENSION(jpi,jpj,    kjpt) :: zglu, zglv   ! bottom GRADh of the laplacian (u- and v-points) 
    177       REAL(wp), DIMENSION(jpi,jpj,    kjpt) :: zgui, zgvi   ! top    GRADh of the laplacian (u- and v-points) 
     209      REAL(wp), DIMENSION(A2D(nn_hls),jpk,kjpt) :: zlap         ! laplacian at t-point 
     210      REAL(wp), DIMENSION(A2D(nn_hls),    kjpt) :: zglu, zglv   ! bottom GRADh of the laplacian (u- and v-points) 
     211      REAL(wp), DIMENSION(A2D(nn_hls),    kjpt) :: zgui, zgvi   ! top    GRADh of the laplacian (u- and v-points) 
    178212      !!--------------------------------------------------------------------- 
    179213      ! 
    180       IF( kt == kit000 .AND. lwp )  THEN 
    181          WRITE(numout,*) 
    182          SELECT CASE ( kldf ) 
    183          CASE ( np_blp    )   ;   WRITE(numout,*) 'tra_ldf_blp : iso-level   bilaplacian operator on ', cdtype 
    184          CASE ( np_blp_i  )   ;   WRITE(numout,*) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (Standard)' 
    185          CASE ( np_blp_it )   ;   WRITE(numout,*) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (triad)' 
    186          END SELECT 
    187          WRITE(numout,*) '~~~~~~~~~~~' 
     214      IF( ntile == 0 .OR. ntile == 1 )  THEN                       ! Do only on the first tile 
     215         IF( kt == kit000 .AND. lwp )  THEN 
     216            WRITE(numout,*) 
     217            SELECT CASE ( kldf ) 
     218            CASE ( np_blp    )   ;   WRITE(numout,*) 'tra_ldf_blp : iso-level   bilaplacian operator on ', cdtype 
     219            CASE ( np_blp_i  )   ;   WRITE(numout,*) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (Standard)' 
     220            CASE ( np_blp_it )   ;   WRITE(numout,*) 'tra_ldf_blp : iso-neutral bilaplacian operator on ', cdtype, ' (triad)' 
     221            END SELECT 
     222            WRITE(numout,*) '~~~~~~~~~~~' 
     223         ENDIF 
    188224      ENDIF 
    189225 
    … …  
    200236      END SELECT 
    201237      ! 
     238      ! NOTE: [tiling-comms-merge] Needed for both nn_hls as tra_ldf_iso and tra_ldf_triad have not yet been adjusted to work with nn_hls = 2. In the zps case the lbc_lnk in zps_hde handles this, but in the zco case zlap always needs this lbc_lnk. I did try adjusting the bounds in tra_ldf_iso and tra_ldf_triad so this lbc_lnk was only needed for nn_hls = 1, but this was not correct and I did not have time to figure out why 
    202239      CALL lbc_lnk( 'traldf_lap_blp', zlap(:,:,:,:) , 'T', 1.0_wp )     ! Lateral boundary conditions (unchanged sign) 
    203240      !                                               ! Partial top/bottom cell: GRADh( zlap )   

  • NEMO/trunk/src/OCE/TRA/traldf_triad.F90

    r13497 r13982  
    1313   USE oce            ! ocean dynamics and active tracers 
    1414   USE dom_oce        ! ocean space and time domain 
     15   ! TEMP: [tiling] This change not necessary if XIOS has subdomain support 
     16   USE domain, ONLY : dom_tile 
     17   USE domutl, ONLY : is_tile 
    1518   USE phycst         ! physical constants 
    1619   USE trc_oce        ! share passive tracers/Ocean variables 
    … …  
    3336   PUBLIC   tra_ldf_triad   ! routine called by traldf.F90 
    3437 
    35    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE ::   zdkt3d   !: vertical tracer gradient at 2 levels 
    36  
    3738   LOGICAL  ::   l_ptr   ! flag to compute poleward transport 
    3839   LOGICAL  ::   l_hst   ! flag to compute heat transport 
    … …  
    4950CONTAINS 
    5051 
    51   SUBROUTINE tra_ldf_triad( kt, Kmm, kit000, cdtype, pahu, pahv,               & 
    52       &                                              pgu , pgv  , pgui, pgvi , & 
    53       &                                         pt , pt2, pt_rhs, kjpt, kpass ) 
     52   SUBROUTINE tra_ldf_triad( kt, Kmm, kit000, cdtype, pahu, pahv,             & 
     53      &                                               pgu , pgv , pgui, pgvi, & 
     54      &                                               pt, pt2, pt_rhs, kjpt, kpass ) 
     55      !! 
     56      INTEGER                     , INTENT(in   ) ::   kt         ! ocean time-step index 
     57      INTEGER                     , INTENT(in   ) ::   kit000     ! first time step index 
     58      CHARACTER(len=3)            , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator) 
     59      INTEGER                     , INTENT(in   ) ::   kjpt       ! number of tracers 
     60      INTEGER                     , INTENT(in   ) ::   kpass      ! =1/2 first or second passage 
     61      INTEGER                     , INTENT(in   ) ::   Kmm        ! ocean time level indices 
     62      REAL(wp), DIMENSION(:,:,:)  , INTENT(in   ) ::   pahu, pahv ! eddy diffusivity at u- and v-points  [m2/s] 
     63      REAL(wp), DIMENSION(:,:,:)  , INTENT(in   ) ::   pgu , pgv  ! tracer gradient at pstep levels 
     64      REAL(wp), DIMENSION(:,:,:)  , INTENT(in   ) ::   pgui, pgvi ! tracer gradient at top   levels 
     65      REAL(wp), DIMENSION(:,:,:,:), INTENT(in   ) ::   pt         ! tracer (kpass=1) or laplacian of tracer (kpass=2) 
     66      REAL(wp), DIMENSION(:,:,:,:), INTENT(in   ) ::   pt2        ! tracer (only used in kpass=2) 
     67      REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) ::   pt_rhs     ! tracer trend 
     68      !! 
     69      CALL tra_ldf_triad_t( kt, Kmm, kit000, cdtype, pahu, pahv, is_tile(pahu),                            & 
     70      &                                              pgu , pgv , is_tile(pgu) , pgui, pgvi, is_tile(pgui), & 
     71      &                                              pt, is_tile(pt), pt2, is_tile(pt2), pt_rhs, is_tile(pt_rhs), kjpt, kpass ) 
     72   END SUBROUTINE tra_ldf_triad 
     73 
     74 
     75  SUBROUTINE tra_ldf_triad_t( kt, Kmm, kit000, cdtype, pahu, pahv, ktah,                   & 
     76      &                                                pgu , pgv , ktg , pgui, pgvi, ktgi, & 
     77      &                                                pt, ktt, pt2, ktt2, pt_rhs, ktt_rhs, kjpt, kpass ) 
    5478      !!---------------------------------------------------------------------- 
    5579      !!                  ***  ROUTINE tra_ldf_triad  *** 
    … …  
    77101      INTEGER                              , INTENT(in   ) ::   kpass      ! =1/2 first or second passage 
    78102      INTEGER                              , INTENT(in)    ::   Kmm        ! ocean time level indices 
    79       REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(in   ) ::   pahu, pahv ! eddy diffusivity at u- and v-points  [m2/s] 
    80       REAL(wp), DIMENSION(jpi,jpj    ,kjpt), INTENT(in   ) ::   pgu , pgv  ! tracer gradient at pstep levels 
    81       REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(in   ) ::   pgui, pgvi ! tracer gradient at top   levels 
    82       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   pt         ! tracer (kpass=1) or laplacian of tracer (kpass=2) 
    83       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   pt2        ! tracer (only used in kpass=2) 
    84       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pt_rhs     ! tracer trend 
     103      INTEGER                              , INTENT(in   ) ::   ktah, ktg, ktgi, ktt, ktt2, ktt_rhs 
     104      REAL(wp), DIMENSION(A2D_T(ktah),   JPK)     , INTENT(in   ) ::   pahu, pahv ! eddy diffusivity at u- and v-points  [m2/s] 
     105      REAL(wp), DIMENSION(A2D_T(ktg),        KJPT), INTENT(in   ) ::   pgu , pgv  ! tracer gradient at pstep levels 
     106      REAL(wp), DIMENSION(A2D_T(ktgi),       KJPT), INTENT(in   ) ::   pgui, pgvi ! tracer gradient at top   levels 
     107      REAL(wp), DIMENSION(A2D_T(ktt),    JPK,KJPT), INTENT(in   ) ::   pt         ! tracer (kpass=1) or laplacian of tracer (kpass=2) 
     108      REAL(wp), DIMENSION(A2D_T(ktt2),   JPK,KJPT), INTENT(in   ) ::   pt2        ! tracer (only used in kpass=2) 
     109      REAL(wp), DIMENSION(A2D_T(ktt_rhs),JPK,KJPT), INTENT(inout) ::   pt_rhs     ! tracer trend 
    85110      ! 
    86111      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices 
    … …  
    94119      REAL(wp) ::   ze1ur, ze2vr, ze3wr, zdxt, zdyt, zdzt 
    95120      REAL(wp) ::   zah, zah_slp, zaei_slp 
    96       REAL(wp), DIMENSION(jpi,jpj    ) ::   z2d                                              ! 2D workspace 
    97       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zdit, zdjt, zftu, zftv, ztfw, zpsi_uw, zpsi_vw   ! 3D     - 
     121      REAL(wp), DIMENSION(A2D(nn_hls),0:1)     ::   zdkt3d                         ! vertical tracer gradient at 2 levels 
     122      REAL(wp), DIMENSION(A2D(nn_hls)        ) ::   z2d                            ! 2D workspace 
     123      REAL(wp), DIMENSION(A2D(nn_hls)    ,jpk) ::   zdit, zdjt, zftu, zftv, ztfw   ! 3D     - 
     124      ! TEMP: [tiling] This can be A2D(nn_hls) if XIOS has subdomain support 
     125      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zpsi_uw, zpsi_vw 
    98126      !!---------------------------------------------------------------------- 
    99127      ! 
    100       IF( .NOT.ALLOCATED(zdkt3d) )  THEN 
    101          ALLOCATE( zdkt3d(jpi,jpj,0:1) , STAT=ierr ) 
    102          CALL mpp_sum ( 'traldf_triad', ierr ) 
    103          IF( ierr > 0 )   CALL ctl_stop('STOP', 'tra_ldf_triad: unable to allocate arrays') 
    104       ENDIF 
    105      ! 
    106       IF( kpass == 1 .AND. kt == kit000 )  THEN 
    107          IF(lwp) WRITE(numout,*) 
    108          IF(lwp) WRITE(numout,*) 'tra_ldf_triad : rotated laplacian diffusion operator on ', cdtype 
    109          IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' 
    110       ENDIF 
    111       !    
    112       l_hst = .FALSE. 
    113       l_ptr = .FALSE. 
    114       IF( cdtype == 'TRA' ) THEN 
    115          IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf') )      l_ptr = .TRUE.  
    116          IF( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR.                   & 
    117          &   iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  )   l_hst = .TRUE. 
     128      IF( ntile == 0 .OR. ntile == 1 )  THEN                       ! Do only on the first tile 
     129         IF( kpass == 1 .AND. kt == kit000 )  THEN 
     130            IF(lwp) WRITE(numout,*) 
     131            IF(lwp) WRITE(numout,*) 'tra_ldf_triad : rotated laplacian diffusion operator on ', cdtype 
     132            IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~' 
     133         ENDIF 
     134         ! 
     135         l_hst = .FALSE. 
     136         l_ptr = .FALSE. 
     137         IF( cdtype == 'TRA' ) THEN 
     138            IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf') )      l_ptr = .TRUE. 
     139            IF( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR.                   & 
     140            &   iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  )   l_hst = .TRUE. 
     141         ENDIF 
    118142      ENDIF 
    119143      ! 
    … …  
    128152      IF( kpass == 1 ) THEN         !==  first pass only  and whatever the tracer is  ==! 
    129153         ! 
    130          akz     (:,:,:) = 0._wp       
    131          ah_wslp2(:,:,:) = 0._wp 
    132          IF( ln_ldfeiv_dia ) THEN 
    133             zpsi_uw(:,:,:) = 0._wp 
    134             zpsi_vw(:,:,:) = 0._wp 
    135          ENDIF 
     154         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     155            akz     (ji,jj,jk) = 0._wp 
     156            ah_wslp2(ji,jj,jk) = 0._wp 
     157         END_3D 
    136158         ! 
    137159         DO ip = 0, 1                            ! i-k triads 
    138160            DO kp = 0, 1 
    139                DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 
    140                   ze3wr = 1._wp / e3w(ji+ip,jj,jk+kp,Kmm) 
    141                   zbu   = e1e2u(ji,jj) * e3u(ji,jj,jk,Kmm) 
    142                   zah   = 0.25_wp * pahu(ji,jj,jk) 
    143                   zslope_skew = triadi_g(ji+ip,jj,jk,1-ip,kp) 
     161               DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     162                  ze3wr = 1._wp / e3w(ji,jj,jk+kp,Kmm) 
     163                  zbu   = e1e2u(ji-ip,jj) * e3u(ji-ip,jj,jk,Kmm) 
     164                  zah   = 0.25_wp * pahu(ji-ip,jj,jk) 
     165                  zslope_skew = triadi_g(ji,jj,jk,1-ip,kp) 
    144166                  ! Subtract s-coordinate slope at t-points to give slope rel to s-surfaces (do this by *adding* gradient of depth) 
    145                   zslope2 = zslope_skew + ( gdept(ji+1,jj,jk,Kmm) - gdept(ji,jj,jk,Kmm) ) * r1_e1u(ji,jj) * umask(ji,jj,jk+kp) 
     167                  zslope2 = zslope_skew + ( gdept(ji-ip+1,jj,jk,Kmm) - gdept(ji-ip,jj,jk,Kmm) ) * r1_e1u(ji-ip,jj) * umask(ji-ip,jj,jk+kp) 
    146168                  zslope2 = zslope2 *zslope2 
    147                   ah_wslp2(ji+ip,jj,jk+kp) = ah_wslp2(ji+ip,jj,jk+kp) + zah * zbu * ze3wr * r1_e1e2t(ji+ip,jj) * zslope2 
    148                   akz     (ji+ip,jj,jk+kp) = akz     (ji+ip,jj,jk+kp) + zah * r1_e1u(ji,jj)       & 
    149                      &                                                      * r1_e1u(ji,jj) * umask(ji,jj,jk+kp) 
     169                  ah_wslp2(ji,jj,jk+kp) = ah_wslp2(ji,jj,jk+kp) + zah * zbu * ze3wr * r1_e1e2t(ji,jj) * zslope2 
     170                  akz     (ji,jj,jk+kp) = akz     (ji,jj,jk+kp) + zah * r1_e1u(ji-ip,jj)       & 
     171                     &                                                      * r1_e1u(ji-ip,jj) * umask(ji-ip,jj,jk+kp) 
    150172                     ! 
    151                  IF( ln_ldfeiv_dia )   zpsi_uw(ji,jj,jk+kp) = zpsi_uw(ji,jj,jk+kp)   & 
    152                      &                                       + 0.25_wp * aeiu(ji,jj,jk) * e2u(ji,jj) * zslope_skew 
    153173               END_3D 
    154174            END DO 
    … …  
    157177         DO jp = 0, 1                            ! j-k triads  
    158178            DO kp = 0, 1 
    159                DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 
    160                   ze3wr = 1.0_wp / e3w(ji,jj+jp,jk+kp,Kmm) 
    161                   zbv   = e1e2v(ji,jj) * e3v(ji,jj,jk,Kmm) 
    162                   zah   = 0.25_wp * pahv(ji,jj,jk) 
    163                   zslope_skew = triadj_g(ji,jj+jp,jk,1-jp,kp) 
     179               DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     180                  ze3wr = 1.0_wp / e3w(ji,jj,jk+kp,Kmm) 
     181                  zbv   = e1e2v(ji,jj-jp) * e3v(ji,jj-jp,jk,Kmm) 
     182                  zah   = 0.25_wp * pahv(ji,jj-jp,jk) 
     183                  zslope_skew = triadj_g(ji,jj,jk,1-jp,kp) 
    164184                  ! Subtract s-coordinate slope at t-points to give slope rel to s surfaces 
    165185                  !    (do this by *adding* gradient of depth) 
    166                   zslope2 = zslope_skew + ( gdept(ji,jj+1,jk,Kmm) - gdept(ji,jj,jk,Kmm) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk+kp) 
     186                  zslope2 = zslope_skew + ( gdept(ji,jj-jp+1,jk,Kmm) - gdept(ji,jj-jp,jk,Kmm) ) * r1_e2v(ji,jj-jp) * vmask(ji,jj-jp,jk+kp) 
    167187                  zslope2 = zslope2 * zslope2 
    168                   ah_wslp2(ji,jj+jp,jk+kp) = ah_wslp2(ji,jj+jp,jk+kp) + zah * zbv * ze3wr * r1_e1e2t(ji,jj+jp) * zslope2 
    169                   akz     (ji,jj+jp,jk+kp) = akz     (ji,jj+jp,jk+kp) + zah * r1_e2v(ji,jj)     & 
    170                      &                                                      * r1_e2v(ji,jj) * vmask(ji,jj,jk+kp) 
     188                  ah_wslp2(ji,jj,jk+kp) = ah_wslp2(ji,jj,jk+kp) + zah * zbv * ze3wr * r1_e1e2t(ji,jj) * zslope2 
     189                  akz     (ji,jj,jk+kp) = akz     (ji,jj,jk+kp) + zah * r1_e2v(ji,jj-jp)     & 
     190                     &                                                      * r1_e2v(ji,jj-jp) * vmask(ji,jj-jp,jk+kp) 
    171191                  ! 
    172                   IF( ln_ldfeiv_dia )   zpsi_vw(ji,jj,jk+kp) = zpsi_vw(ji,jj,jk+kp)   & 
    173                      &                                       + 0.25 * aeiv(ji,jj,jk) * e1v(ji,jj) * zslope_skew 
    174192               END_3D 
    175193            END DO 
    … …  
    179197            ! 
    180198            IF( ln_traldf_blp ) THEN                ! bilaplacian operator 
    181                DO_3D( 1, 0, 1, 0, 2, jpkm1 ) 
     199               DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
    182200                  akz(ji,jj,jk) = 16._wp           & 
    183201                     &   * ah_wslp2   (ji,jj,jk)   & 
    … …  
    187205               END_3D 
    188206            ELSEIF( ln_traldf_lap ) THEN              ! laplacian operator 
    189                DO_3D( 1, 0, 1, 0, 2, jpkm1 ) 
     207               DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
    190208                  ze3w_2 = e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) 
    191209                  zcoef0 = rDt * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2  ) 
    … …  
    195213           ! 
    196214         ELSE                                    ! 33 flux set to zero with akz=ah_wslp2 ==>> computed in full implicit 
    197             akz(:,:,:) = ah_wslp2(:,:,:)       
    198          ENDIF 
    199          ! 
    200          IF( ln_ldfeiv_dia .AND. cdtype == 'TRA' )   CALL ldf_eiv_dia( zpsi_uw, zpsi_vw, Kmm ) 
     215            DO_3D( 0, 0, 0, 0, 1, jpk ) 
     216               akz(ji,jj,jk) = ah_wslp2(ji,jj,jk) 
     217            END_3D 
     218         ENDIF 
     219         ! 
     220         ! TEMP: [tiling] These changes not necessary if XIOS has subdomain support 
     221         IF( ntile == 0 .OR. ntile == nijtile )  THEN                ! Do only for the full domain 
     222            IF( ln_ldfeiv_dia .AND. cdtype == 'TRA' ) THEN 
     223               IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) 
     224 
     225               zpsi_uw(:,:,:) = 0._wp 
     226               zpsi_vw(:,:,:) = 0._wp 
     227 
     228               DO jp = 0, 1 
     229                  DO kp = 0, 1 
     230                     DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 
     231                        zpsi_uw(ji,jj,jk+kp) = zpsi_uw(ji,jj,jk+kp) & 
     232                           & + 0.25_wp * aeiu(ji,jj,jk) * e2u(ji,jj) * triadi_g(ji+jp,jj,jk,1-jp,kp) 
     233                        zpsi_vw(ji,jj,jk+kp) = zpsi_vw(ji,jj,jk+kp) & 
     234                           & + 0.25_wp * aeiv(ji,jj,jk) * e1v(ji,jj) * triadj_g(ji,jj+jp,jk,1-jp,kp) 
     235                     END_3D 
     236                  END DO 
     237               END DO 
     238               CALL ldf_eiv_dia( zpsi_uw, zpsi_vw, Kmm ) 
     239 
     240               IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = nijtile ) 
     241            ENDIF 
     242         ENDIF 
    201243         ! 
    202244      ENDIF                                  !==  end 1st pass only  ==! 
    … …  
    234276         DO jk = 1, jpkm1 
    235277            !                    !==  Vertical tracer gradient at level jk and jk+1 
    236             zdkt3d(:,:,1) = ( pt(:,:,jk,jn) - pt(:,:,jk+1,jn) ) * tmask(:,:,jk+1) 
     278            DO_2D( 1, 1, 1, 1 ) 
     279               zdkt3d(ji,jj,1) = ( pt(ji,jj,jk,jn) - pt(ji,jj,jk+1,jn) ) * tmask(ji,jj,jk+1) 
     280            END_2D 
    237281            ! 
    238282            !                    ! surface boundary condition: zdkt3d(jk=0)=zdkt3d(jk=1) 
    239283            IF( jk == 1 ) THEN   ;   zdkt3d(:,:,0) = zdkt3d(:,:,1) 
    240             ELSE                 ;   zdkt3d(:,:,0) = ( pt(:,:,jk-1,jn) - pt(:,:,jk,jn) ) * tmask(:,:,jk) 
     284            ELSE 
     285               DO_2D( 1, 1, 1, 1 ) 
     286                  zdkt3d(ji,jj,0) = ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
     287               END_2D 
    241288            ENDIF 
    242289            ! 
    … …  
    380427      END DO                                                      ! end tracer loop 
    381428      !                                                           ! =============== 
    382    END SUBROUTINE tra_ldf_triad 
     429   END SUBROUTINE tra_ldf_triad_t 
    383430 
    384431   !!============================================================================== 

  • NEMO/trunk/src/OCE/TRA/tramle.F90

    r13497 r13982  
    7979      !!             Fox-Kemper and Ferrari, JPO, 38, 1166-1179, 2008 
    8080      !!---------------------------------------------------------------------- 
    81       INTEGER                         , INTENT(in   ) ::   kt         ! ocean time-step index 
    82       INTEGER                         , INTENT(in   ) ::   kit000     ! first time step index 
    83       INTEGER                         , INTENT(in   ) ::   Kmm        ! ocean time level index 
    84       CHARACTER(len=3)                , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator) 
    85       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu         ! in : 3 ocean transport components 
    86       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pv         ! out: same 3  transport components 
    87       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pw         !   increased by the MLE induced transport 
     81      INTEGER                     , INTENT(in   ) ::   kt         ! ocean time-step index 
     82      INTEGER                     , INTENT(in   ) ::   kit000     ! first time step index 
     83      INTEGER                     , INTENT(in   ) ::   Kmm        ! ocean time level index 
     84      CHARACTER(len=3)            , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator) 
     85      REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) ::   pu         ! in : 3 ocean transport components 
     86      REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) ::   pv         ! out: same 3  transport components 
     87      REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) ::   pw         !   increased by the MLE induced transport 
    8888      ! 
    8989      INTEGER  ::   ji, jj, jk          ! dummy loop indices 
    … …  
    9191      REAL(wp) ::   zcuw, zmuw, zc      ! local scalar 
    9292      REAL(wp) ::   zcvw, zmvw          !   -      - 
    93       INTEGER , DIMENSION(jpi,jpj)     :: inml_mle 
    94       REAL(wp), DIMENSION(jpi,jpj)     :: zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_NH, zLf_MH 
    95       REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpsi_uw, zpsi_vw 
     93      INTEGER , DIMENSION(A2D(nn_hls))     :: inml_mle 
     94      REAL(wp), DIMENSION(A2D(nn_hls))     :: zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_MH 
     95      REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zpsi_uw, zpsi_vw 
     96      ! TEMP: [tiling] These changes not necessary if using XIOS (subdomain support) 
     97      REAL(wp), DIMENSION(:,:),   ALLOCATABLE, SAVE :: zLf_NH 
     98      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: zpsiu_mle, zpsiv_mle 
    9699      !!---------------------------------------------------------------------- 
    97100      ! 
    98101      !                                      !==  MLD used for MLE  ==! 
    99102      !                                                ! compute from the 10m density to deal with the diurnal cycle 
    100       inml_mle(:,:) = mbkt(:,:) + 1                    ! init. to number of ocean w-level (T-level + 1) 
     103      DO_2D( 1, 1, 1, 1 ) 
     104         inml_mle(ji,jj) = mbkt(ji,jj) + 1                    ! init. to number of ocean w-level (T-level + 1) 
     105      END_2D 
    101106      IF ( nla10 > 0 ) THEN                            ! avoid case where first level is thicker than 10m 
    102107         DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 )        ! from the bottom to nlb10 (10m) 
    … …  
    135140      END SELECT 
    136141      !                                                ! convert density into buoyancy 
    137       zbm(:,:) = + grav * zbm(:,:) / MAX( e3t(:,:,1,Kmm), zmld(:,:) ) 
     142      DO_2D( 1, 1, 1, 1 ) 
     143         zbm(ji,jj) = + grav * zbm(ji,jj) / MAX( e3t(ji,jj,1,Kmm), zmld(ji,jj) ) 
     144      END_2D 
    138145      ! 
    139146      ! 
    … …  
    206213      END DO 
    207214 
     215      ! TEMP: [tiling] These changes not necessary if using XIOS (subdomain support) 
    208216      IF( cdtype == 'TRA') THEN              !==  outputs  ==! 
    209          ! 
    210          zLf_NH(:,:) = SQRT( rb_c * zmld(:,:) ) * r1_ft(:,:)      ! Lf = N H / f 
    211          CALL iom_put( "Lf_NHpf" , zLf_NH  )    ! Lf = N H / f 
     217         IF( ntile == 0 .OR. ntile == 1 ) THEN                             ! Do only on the first tile 
     218            ALLOCATE( zLf_NH(jpi,jpj), zpsiu_mle(jpi,jpj,jpk), zpsiv_mle(jpi,jpj,jpk) ) 
     219            zpsiu_mle(:,:,:) = 0._wp ; zpsiv_mle(:,:,:) = 0._wp 
     220         ENDIF 
     221         ! 
     222         DO_2D( 0, 0, 0, 0 ) 
     223            zLf_NH(ji,jj) = SQRT( rb_c * zmld(ji,jj) ) * r1_ft(ji,jj)      ! Lf = N H / f 
     224         END_2D 
    212225         ! 
    213226         ! divide by cross distance to give streamfunction with dimensions m^2/s 
    214          DO jk = 1, ikmax+1 
    215             zpsi_uw(:,:,jk) = zpsi_uw(:,:,jk) * r1_e2u(:,:) 
    216             zpsi_vw(:,:,jk) = zpsi_vw(:,:,jk) * r1_e1v(:,:) 
    217          END DO 
    218          CALL iom_put( "psiu_mle", zpsi_uw )    ! i-mle streamfunction 
    219          CALL iom_put( "psiv_mle", zpsi_vw )    ! j-mle streamfunction 
     227         DO_3D( 0, 0, 0, 0, 1, ikmax+1 ) 
     228            zpsiu_mle(ji,jj,jk) = zpsi_uw(ji,jj,jk) * r1_e2u(ji,jj) 
     229            zpsiv_mle(ji,jj,jk) = zpsi_vw(ji,jj,jk) * r1_e1v(ji,jj) 
     230         END_3D 
     231 
     232         IF( ntile == 0 .OR. ntile == nijtile ) THEN                       ! Do only on the last tile 
     233            CALL iom_put( "Lf_NHpf" , zLf_NH  )    ! Lf = N H / f 
     234            CALL iom_put( "psiu_mle", zpsiu_mle )    ! i-mle streamfunction 
     235            CALL iom_put( "psiv_mle", zpsiv_mle )    ! j-mle streamfunction 
     236            DEALLOCATE( zLf_NH, zpsiu_mle, zpsiv_mle ) 
     237         ENDIF 
    220238      ENDIF 
    221239      ! 
    … …  
    283301            IF( ierr /= 0 )   CALL ctl_stop( 'tra_adv_mle_init: failed to allocate arrays' ) 
    284302            z1_t2 = 1._wp / ( rn_time * rn_time ) 
    285             DO_2D( 0, 1, 0, 1 )                      ! "coriolis+ time^-1" at u- & v-points 
     303            DO_2D( nn_hls-1, nn_hls, nn_hls-1, nn_hls )                      ! "coriolis+ time^-1" at u- & v-points 
    286304               zfu = ( ff_f(ji,jj) + ff_f(ji,jj-1) ) * 0.5_wp 
    287305               zfv = ( ff_f(ji,jj) + ff_f(ji-1,jj) ) * 0.5_wp 
    … …  
    289307               rfv(ji,jj) = SQRT(  zfv * zfv + z1_t2 ) 
    290308            END_2D 
    291             CALL lbc_lnk_multi( 'tramle', rfu, 'U', 1.0_wp , rfv, 'V', 1.0_wp ) 
     309            IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'tramle', rfu, 'U', 1.0_wp , rfv, 'V', 1.0_wp ) 
    292310            ! 
    293311         ELSEIF( nn_mle == 1 ) THEN           ! MLE array allocation & initialisation 

  • NEMO/trunk/src/OCE/TRA/tranpc.F90

    r13497 r13982  
    1717   USE oce            ! ocean dynamics and active tracers 
    1818   USE dom_oce        ! ocean space and time domain 
     19   ! TEMP: [tiling] This change not necessary after extra haloes development (lbc_lnk removed) 
     20   USE domain, ONLY : dom_tile 
    1921   USE phycst         ! physical constants 
    2022   USE zdf_oce        ! ocean vertical physics 
    … …  
    3234 
    3335   PUBLIC   tra_npc    ! routine called by step.F90 
     36 
     37   INTEGER  ::   nnpcc        ! number of statically instable water column 
    3438 
    3539   !! * Substitutions 
    … …  
    6468      ! 
    6569      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    66       INTEGER  ::   inpcc        ! number of statically instable water column 
    6770      INTEGER  ::   jiter, ikbot, ikp, ikup, ikdown, ilayer, ik_low   ! local integers 
    6871      LOGICAL  ::   l_bottom_reached, l_column_treated 
    … …  
    7073      REAL(wp) ::   zsa, zbeta, zsum_sali, zsum_beta, zbw, zrw, z1_rDt 
    7174      REAL(wp), PARAMETER ::   zn2_zero = 1.e-14_wp             ! acceptance criteria for neutrality (N2==0) 
    72       REAL(wp), DIMENSION(        jpk     )   ::   zvn2         ! vertical profile of N2 at 1 given point... 
    73       REAL(wp), DIMENSION(        jpk,jpts)   ::   zvts, zvab   ! vertical profile of T & S , and  alpha & betaat 1 given point 
    74       REAL(wp), DIMENSION(jpi,jpj,jpk     )   ::   zn2          ! N^2  
    75       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts)   ::   zab          ! alpha and beta 
     75      REAL(wp), DIMENSION(    jpk     )   ::   zvn2             ! vertical profile of N2 at 1 given point... 
     76      REAL(wp), DIMENSION(    jpk,jpts)   ::   zvts, zvab       ! vertical profile of T & S , and  alpha & betaat 1 given point 
     77      REAL(wp), DIMENSION(A2D(nn_hls),jpk     )   ::   zn2              ! N^2 
     78      REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts)   ::   zab              ! alpha and beta 
    7679      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdt, ztrds ! 3D workspace 
    7780      ! 
    7881      LOGICAL, PARAMETER :: l_LB_debug = .FALSE. ! set to true if you want to follow what is 
    7982      INTEGER :: ilc1, jlc1, klc1, nncpu         ! actually happening in a water column at point "ilc1, jlc1" 
     83      INTEGER :: isi, isj, iei, iej 
    8084      LOGICAL :: lp_monitor_point = .FALSE.      ! in CPU domain "nncpu" 
    8185      !!---------------------------------------------------------------------- 
    … …  
    8791         IF( l_trdtra )   THEN                    !* Save initial after fields 
    8892            ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 
    89             ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kaa)  
     93            ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kaa) 
    9094            ztrds(:,:,:) = pts(:,:,:,jp_sal,Kaa) 
    9195         ENDIF 
    … …  
    101105         CALL bn2    ( pts(:,:,:,:,Kaa), zab, zn2, Kmm )    ! after Brunt-Vaisala  (given on W-points) 
    102106         ! 
    103          inpcc = 0 
    104          ! 
    105          DO_2D( 0, 0, 0, 0 )                                ! interior column only 
     107         IF( ntile == 0 .OR. ntile == 1 ) nnpcc = 0         ! Do only on the first tile 
     108         ! 
     109         IF( ntsi == Nis0 ) THEN ; isi = nn_hls ; ELSE ; isi = 0 ; ENDIF    ! Avoid double-counting when using tiling 
     110         IF( ntsj == Njs0 ) THEN ; isj = nn_hls ; ELSE ; isj = 0 ; ENDIF 
     111         IF( ntei == Nie0 ) THEN ; iei = nn_hls ; ELSE ; iei = 0 ; ENDIF 
     112         IF( ntej == Nje0 ) THEN ; iej = nn_hls ; ELSE ; iej = 0 ; ENDIF 
     113         ! 
     114         ! NOTE: [tiling-comms-merge] Bounds changed to avoid repeating this calculation for overlapping rows when using tiling 
     115         DO_2D( isj, iej, isi, iei )                        ! interior column only 
    106116            ! 
    107117            IF( tmask(ji,jj,2) == 1 ) THEN      ! At least 2 ocean points 
    … …  
    160170                        ENDIF 
    161171                        ! 
    162                         IF( jiter == 1 )   inpcc = inpcc + 1  
     172                        IF( jiter == 1 )   nnpcc = nnpcc + 1 
    163173                        ! 
    164174                        IF( lp_monitor_point )   WRITE(numout, *) 'Negative N2 at ikp =',ikp,' for layer #', ilayer 
    … …  
    310320         ENDIF 
    311321         ! 
    312          CALL lbc_lnk_multi( 'tranpc', pts(:,:,:,jp_tem,Kaa), 'T', 1.0_wp, pts(:,:,:,jp_sal,Kaa), 'T', 1.0_wp ) 
    313          ! 
    314          IF( lwp .AND. l_LB_debug ) THEN 
    315             WRITE(numout,*) 'Exiting tra_npc , kt = ',kt,', => numb. of statically instable water-columns: ', inpcc 
    316             WRITE(numout,*) 
     322         IF( ntile == 0 .OR. ntile == nijtile )  THEN                ! Do only for the full domain 
     323            IF( lwp .AND. l_LB_debug ) THEN 
     324               WRITE(numout,*) 'Exiting tra_npc , kt = ',kt,', => numb. of statically instable water-columns: ', nnpcc 
     325               WRITE(numout,*) 
     326            ENDIF 
    317327         ENDIF 
    318328         ! 

  • NEMO/trunk/src/OCE/TRA/traqsr.F90

    r13970 r13982  
    2222   USE phycst         ! physical constants 
    2323   USE dom_oce        ! ocean space and time domain 
     24   USE domain, ONLY : dom_tile 
    2425   USE sbc_oce        ! surface boundary condition: ocean 
    2526   USE trc_oce        ! share SMS/Ocean variables 
    … …  
    107108      ! 
    108109      INTEGER  ::   ji, jj, jk               ! dummy loop indices 
    109       INTEGER  ::   irgb                    ! local integers 
     110      INTEGER  ::   irgb, isi, iei, isj, iej ! local integers 
    110111      REAL(wp) ::   zchl, zcoef, z1_2        ! local scalars 
    111112      REAL(wp) ::   zc0 , zc1 , zc2 , zc3    !    -         - 
    … …  
    120121      IF( ln_timing )   CALL timing_start('tra_qsr') 
    121122      ! 
    122       IF( kt == nit000 ) THEN 
    123          IF(lwp) WRITE(numout,*) 
    124          IF(lwp) WRITE(numout,*) 'tra_qsr : penetration of the surface solar radiation' 
    125          IF(lwp) WRITE(numout,*) '~~~~~~~' 
     123      IF( ntile == 0 .OR. ntile == 1 )  THEN                       ! Do only on the first tile 
     124         IF( kt == nit000 ) THEN 
     125            IF(lwp) WRITE(numout,*) 
     126            IF(lwp) WRITE(numout,*) 'tra_qsr : penetration of the surface solar radiation' 
     127            IF(lwp) WRITE(numout,*) '~~~~~~~' 
     128         ENDIF 
    126129      ENDIF 
    127130      ! 
    128131      IF( l_trdtra ) THEN      ! trends diagnostic: save the input temperature trend 
    129          ALLOCATE( ztrdt(jpi,jpj,jpk) )  
     132         ALLOCATE( ztrdt(jpi,jpj,jpk) ) 
    130133         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 
    131134      ENDIF 
    … …  
    134137      !                         !  before qsr induced heat content  ! 
    135138      !                         !-----------------------------------! 
     139      ! NOTE: [tiling-comms-merge] Many DO loop bounds changed (probably more than necessary) to avoid changing results when using tiling. Some bounds were also adjusted to account for those changed in tra_atf 
     140      IF( ntsi == Nis0 ) THEN ; isi = nn_hls ; ELSE ; isi = 0 ; ENDIF    ! Avoid double-counting when using tiling 
     141      IF( ntsj == Njs0 ) THEN ; isj = nn_hls ; ELSE ; isj = 0 ; ENDIF 
     142      IF( ntei == Nie0 ) THEN ; iei = nn_hls ; ELSE ; iei = 0 ; ENDIF 
     143      IF( ntej == Nje0 ) THEN ; iej = nn_hls ; ELSE ; iej = 0 ; ENDIF 
     144 
    136145      IF( kt == nit000 ) THEN          !==  1st time step  ==! 
    137146         IF( ln_rstart .AND. iom_varid( numror, 'qsr_hc_b', ldstop = .FALSE. ) > 0  .AND. .NOT.l_1st_euler ) THEN    ! read in restart 
    138             IF(lwp) WRITE(numout,*) '          nit000-1 qsr tracer content forcing field read in the restart file' 
    139147            z1_2 = 0.5_wp 
    140             CALL iom_get( numror, jpdom_auto, 'qsr_hc_b', qsr_hc_b )   ! before heat content trend due to Qsr flux 
     148            IF( ntile == 0 .OR. ntile == 1 )  THEN                        ! Do only on the first tile 
     149               IF(lwp) WRITE(numout,*) '          nit000-1 qsr tracer content forcing field read in the restart file' 
     150               CALL iom_get( numror, jpdom_auto, 'qsr_hc_b', qsr_hc_b )   ! before heat content trend due to Qsr flux 
     151            ENDIF 
    141152         ELSE                                           ! No restart or restart not found: Euler forward time stepping 
    142153            z1_2 = 1._wp 
    143             qsr_hc_b(:,:,:) = 0._wp 
     154            DO_3D( isj, iej, isi, iei, 1, jpk ) 
     155               qsr_hc_b(ji,jj,jk) = 0._wp 
     156            END_3D 
    144157         ENDIF 
    145158      ELSE                             !==  Swap of qsr heat content  ==! 
    146159         z1_2 = 0.5_wp 
    147          qsr_hc_b(:,:,:) = qsr_hc(:,:,:) 
     160         DO_3D( isj, iej, isi, iei, 1, jpk ) 
     161            qsr_hc_b(ji,jj,jk) = qsr_hc(ji,jj,jk) 
     162         END_3D 
    148163      ENDIF 
    149164      ! 
    … …  
    154169      CASE( np_BIO )                   !==  bio-model fluxes  ==! 
    155170         ! 
    156          DO jk = 1, nksr 
    157             qsr_hc(:,:,jk) = r1_rho0_rcp * ( etot3(:,:,jk) - etot3(:,:,jk+1) ) 
    158          END DO 
     171         DO_3D( isj, iej, isi, iei, 1, nksr ) 
     172            qsr_hc(ji,jj,jk) = r1_rho0_rcp * ( etot3(ji,jj,jk) - etot3(ji,jj,jk+1) ) 
     173         END_3D 
    159174         ! 
    160175      CASE( np_RGB , np_RGBc )         !==  R-G-B fluxes  ==! 
    161176         ! 
    162          ALLOCATE( ze0 (jpi,jpj)           , ze1 (jpi,jpj) ,   & 
    163             &      ze2 (jpi,jpj)           , ze3 (jpi,jpj) ,   & 
    164             &      ztmp3d(jpi,jpj,nksr + 1)                     ) 
     177         ALLOCATE( ze0 (A2D(nn_hls))           , ze1 (A2D(nn_hls)) ,   & 
     178            &      ze2 (A2D(nn_hls))           , ze3 (A2D(nn_hls)) ,   & 
     179            &      ztmp3d(A2D(nn_hls),nksr + 1)                     ) 
    165180         ! 
    166181         IF( nqsr == np_RGBc ) THEN          !*  Variable Chlorophyll 
    167             CALL fld_read( kt, 1, sf_chl )         ! Read Chl data and provides it at the current time step 
     182            IF( ntile == 0 .OR. ntile == 1 )  THEN                                         ! Do only for the full domain 
     183               IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 )            ! Use full domain 
     184               CALL fld_read( kt, 1, sf_chl )         ! Read Chl data and provides it at the current time step 
     185               IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 1 )            ! Revert to tile domain 
     186            ENDIF 
    168187            ! 
    169188            ! Separation in R-G-B depending on the surface Chl 
    … …  
    172191            ! most expensive calculations) 
    173192            ! 
    174             DO_2D( 0, 0, 0, 0 ) 
     193            DO_2D( isj, iej, isi, iei ) 
    175194                       ! zlogc = log(zchl) 
    176195               zlogc = LOG ( MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) )      
    … …  
    191210             
    192211! 
    193             DO_3D( 0, 0, 0, 0, 1, nksr + 1 ) 
     212            DO_3D( isj, iej, isi, iei, 1, nksr + 1 ) 
    194213               ! zchl    = ALOG( ze0(ji,jj) ) 
    195214               zlogc = ze0(ji,jj) 
    … …  
    216235            zlui = 41 + 20.*LOG10(zchl) + 1.e-15 
    217236            DO jk = 1, nksr + 1 
    218                ztmp3d(:,:,jk) = zlui  
     237               ztmp3d(:,:,jk) = zlui 
    219238            END DO 
    220239         ENDIF 
    221240         ! 
    222241         zcoef  = ( 1. - rn_abs ) / 3._wp    !* surface equi-partition in R-G-B 
    223          DO_2D( 0, 0, 0, 0 ) 
     242         DO_2D( isj, iej, isi, iei ) 
    224243            ze0(ji,jj) = rn_abs * qsr(ji,jj) 
    225244            ze1(ji,jj) = zcoef  * qsr(ji,jj) 
    … …  
    232251         ! 
    233252         !                                    !* interior equi-partition in R-G-B depending on vertical profile of Chl 
    234          DO_3D( 0, 0, 0, 0, 2, nksr + 1 ) 
     253         DO_3D( isj, iej, isi, iei, 2, nksr + 1 ) 
    235254            ze3t = e3t(ji,jj,jk-1,Kmm) 
    236255            irgb = NINT( ztmp3d(ji,jj,jk) ) 
    … …  
    246265         END_3D 
    247266         ! 
    248          DO_3D( 0, 0, 0, 0, 1, nksr )          !* now qsr induced heat content 
     267         DO_3D( isj, iej, isi, iei, 1, nksr )          !* now qsr induced heat content 
    249268            qsr_hc(ji,jj,jk) = r1_rho0_rcp * ( ztmp3d(ji,jj,jk) - ztmp3d(ji,jj,jk+1) ) 
    250269         END_3D 
    … …  
    256275         zz0 =        rn_abs   * r1_rho0_rcp      ! surface equi-partition in 2-bands 
    257276         zz1 = ( 1. - rn_abs ) * r1_rho0_rcp 
    258          DO_3D( 0, 0, 0, 0, 1, nksr )             ! solar heat absorbed at T-point in the top 400m  
     277         DO_3D( isj, iej, isi, iei, 1, nksr )          !* now qsr induced heat content 
    259278            zc0 = zz0 * EXP( -gdepw(ji,jj,jk  ,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk  ,Kmm)*xsi1r ) 
    260279            zc1 = zz0 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi1r ) 
    … …  
    274293      ! 
    275294      ! sea-ice: store the 1st ocean level attenuation coefficient 
    276       DO_2D( 0, 0, 0, 0 ) 
     295      DO_2D( isj, iej, isi, iei ) 
    277296         IF( qsr(ji,jj) /= 0._wp ) THEN   ;   fraqsr_1lev(ji,jj) = qsr_hc(ji,jj,1) / ( r1_rho0_rcp * qsr(ji,jj) ) 
    278297         ELSE                             ;   fraqsr_1lev(ji,jj) = 1._wp 
    279298         ENDIF 
    280299      END_2D 
    281       CALL lbc_lnk( 'traqsr', fraqsr_1lev(:,:), 'T', 1._wp ) 
    282       ! 
    283       IF( iom_use('qsr3d') ) THEN      ! output the shortwave Radiation distribution 
    284          ALLOCATE( zetot(jpi,jpj,jpk) ) 
    285          zetot(:,:,nksr+1:jpk) = 0._wp     ! below ~400m set to zero 
    286          DO jk = nksr, 1, -1 
    287             zetot(:,:,jk) = zetot(:,:,jk+1) + qsr_hc(:,:,jk) * rho0_rcp 
    288          END DO          
    289          CALL iom_put( 'qsr3d', zetot )   ! 3D distribution of shortwave Radiation 
    290          DEALLOCATE( zetot )  
    291       ENDIF 
    292       ! 
    293       IF( lrst_oce ) THEN     ! write in the ocean restart file 
    294          CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b'   , qsr_hc      ) 
    295          CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev )  
     300      ! 
     301      ! TEMP: [tiling] This change not necessary and working array can use A2D(nn_hls) if using XIOS (subdomain support) 
     302      IF( ntile == 0 .OR. ntile == nijtile )  THEN                ! Do only for the full domain 
     303         IF( iom_use('qsr3d') ) THEN      ! output the shortwave Radiation distribution 
     304            ALLOCATE( zetot(jpi,jpj,jpk) ) 
     305            zetot(:,:,nksr+1:jpk) = 0._wp     ! below ~400m set to zero 
     306            DO jk = nksr, 1, -1 
     307               zetot(:,:,jk) = zetot(:,:,jk+1) + qsr_hc(:,:,jk) * rho0_rcp 
     308            END DO 
     309            CALL iom_put( 'qsr3d', zetot )   ! 3D distribution of shortwave Radiation 
     310            DEALLOCATE( zetot ) 
     311         ENDIF 
     312      ENDIF 
     313      ! 
     314      IF( ntile == 0 .OR. ntile == nijtile )  THEN                ! Do only on the last tile 
     315         IF( lrst_oce ) THEN     ! write in the ocean restart file 
     316            CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b'   , qsr_hc      ) 
     317            CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev ) 
     318         ENDIF 
    296319      ENDIF 
    297320      ! 
    … …  
    299322         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) 
    300323         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_qsr, ztrdt ) 
    301          DEALLOCATE( ztrdt )  
     324         DEALLOCATE( ztrdt ) 
    302325      ENDIF 
    303326      !                       ! print mean trends (used for debugging) 

  • NEMO/trunk/src/OCE/TRA/trasbc.F90

    r13970 r13982  
    7676      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts        ! active tracers and RHS of tracer equation 
    7777      ! 
    78       INTEGER  ::   ji, jj, jk, jn              ! dummy loop indices   
    79       INTEGER  ::   ikt, ikb                    ! local integers 
    80       REAL(wp) ::   zfact, z1_e3t, zdep, ztim   ! local scalar 
     78      INTEGER  ::   ji, jj, jk, jn               ! dummy loop indices 
     79      INTEGER  ::   ikt, ikb, isi, iei, isj, iej ! local integers 
     80      REAL(wp) ::   zfact, z1_e3t, zdep, ztim    ! local scalar 
    8181      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::  ztrdt, ztrds 
    8282      !!---------------------------------------------------------------------- 
    … …  
    8484      IF( ln_timing )   CALL timing_start('tra_sbc') 
    8585      ! 
    86       IF( kt == nit000 ) THEN 
    87          IF(lwp) WRITE(numout,*) 
    88          IF(lwp) WRITE(numout,*) 'tra_sbc : TRAcer Surface Boundary Condition' 
    89          IF(lwp) WRITE(numout,*) '~~~~~~~ ' 
     86      IF( ntile == 0 .OR. ntile == 1 )  THEN                       ! Do only on the first tile 
     87         IF( kt == nit000 ) THEN 
     88            IF(lwp) WRITE(numout,*) 
     89            IF(lwp) WRITE(numout,*) 'tra_sbc : TRAcer Surface Boundary Condition' 
     90            IF(lwp) WRITE(numout,*) '~~~~~~~ ' 
     91         ENDIF 
    9092      ENDIF 
    9193      ! 
    9294      IF( l_trdtra ) THEN                    !* Save ta and sa trends 
    93          ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) )  
     95         ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 
    9496         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 
    9597         ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 
    9698      ENDIF 
    9799      ! 
     100      ! NOTE: [tiling-comms-merge] Many DO loop bounds changed to avoid changing results when using tiling. Some bounds were also adjusted to account for those changed in tra_atf 
     101      IF( ntsi == Nis0 ) THEN ; isi = nn_hls ; ELSE ; isi = 0 ; ENDIF    ! Avoid double-counting when using tiling 
     102      IF( ntsj == Njs0 ) THEN ; isj = nn_hls ; ELSE ; isj = 0 ; ENDIF 
     103      IF( ntei == Nie0 ) THEN ; iei = nn_hls ; ELSE ; iei = 0 ; ENDIF 
     104      IF( ntej == Nje0 ) THEN ; iej = nn_hls ; ELSE ; iej = 0 ; ENDIF 
     105 
    98106!!gm  This should be moved into sbcmod.F90 module ? (especially now that ln_traqsr is read in namsbc namelist) 
    99107      IF( .NOT.ln_traqsr ) THEN     ! no solar radiation penetration 
    100          qns(:,:) = qns(:,:) + qsr(:,:)      ! total heat flux in qns 
    101          qsr(:,:) = 0._wp                     ! qsr set to zero 
     108         DO_2D( isj, iej, isi, iei ) 
     109            qns(ji,jj) = qns(ji,jj) + qsr(ji,jj)      ! total heat flux in qns 
     110            qsr(ji,jj) = 0._wp                        ! qsr set to zero 
     111         END_2D 
    102112      ENDIF 
    103113 
    … …  
    109119         IF( ln_rstart .AND.    &               ! Restart: read in restart file 
    110120              & iom_varid( numror, 'sbc_hc_b', ldstop = .FALSE. ) > 0 ) THEN 
    111             IF(lwp) WRITE(numout,*) '          nit000-1 sbc tracer content field read in the restart file' 
    112121            zfact = 0.5_wp 
    113             sbc_tsc(:,:,:) = 0._wp 
    114             CALL iom_get( numror, jpdom_auto, 'sbc_hc_b', sbc_tsc_b(:,:,jp_tem) )   ! before heat content sbc trend 
    115             CALL iom_get( numror, jpdom_auto, 'sbc_sc_b', sbc_tsc_b(:,:,jp_sal) )   ! before salt content sbc trend 
     122            IF( ntile == 0 .OR. ntile == 1 )  THEN                       ! Do only on the first tile 
     123               IF(lwp) WRITE(numout,*) '          nit000-1 sbc tracer content field read in the restart file' 
     124               sbc_tsc(:,:,:) = 0._wp 
     125               CALL iom_get( numror, jpdom_auto, 'sbc_hc_b', sbc_tsc_b(:,:,jp_tem) )   ! before heat content sbc trend 
     126               CALL iom_get( numror, jpdom_auto, 'sbc_sc_b', sbc_tsc_b(:,:,jp_sal) )   ! before salt content sbc trend 
     127            ENDIF 
    116128         ELSE                                   ! No restart or restart not found: Euler forward time stepping 
    117129            zfact = 1._wp 
    118             sbc_tsc(:,:,:) = 0._wp 
    119             sbc_tsc_b(:,:,:) = 0._wp 
     130            DO_2D( isj, iej, isi, iei ) 
     131               sbc_tsc(ji,jj,:) = 0._wp 
     132               sbc_tsc_b(ji,jj,:) = 0._wp 
     133            END_2D 
    120134         ENDIF 
    121135      ELSE                                !* other time-steps: swap of forcing fields 
    122136         zfact = 0.5_wp 
    123          sbc_tsc_b(:,:,:) = sbc_tsc(:,:,:) 
     137         DO_2D( isj, iej, isi, iei ) 
     138            sbc_tsc_b(ji,jj,:) = sbc_tsc(ji,jj,:) 
     139         END_2D 
    124140      ENDIF 
    125141      !                             !==  Now sbc tracer content fields  ==! 
    126       DO_2D( 0, 1, 0, 0 ) 
     142      DO_2D( isj, iej, isi, iei ) 
    127143         sbc_tsc(ji,jj,jp_tem) = r1_rho0_rcp * qns(ji,jj)   ! non solar heat flux 
    128144         sbc_tsc(ji,jj,jp_sal) = r1_rho0     * sfx(ji,jj)   ! salt flux due to freezing/melting 
    129145      END_2D 
    130146      IF( ln_linssh ) THEN                !* linear free surface   
    131          DO_2D( 0, 1, 0, 0 )                    !==>> add concentration/dilution effect due to constant volume cell 
     147         DO_2D( isj, iej, isi, iei )                    !==>> add concentration/dilution effect due to constant volume cell 
    132148            sbc_tsc(ji,jj,jp_tem) = sbc_tsc(ji,jj,jp_tem) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_tem,Kmm) 
    133149            sbc_tsc(ji,jj,jp_sal) = sbc_tsc(ji,jj,jp_sal) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_sal,Kmm) 
    134150         END_2D                                 !==>> output c./d. term 
    135          IF( iom_use('emp_x_sst') )   CALL iom_put( "emp_x_sst", emp (:,:) * pts(:,:,1,jp_tem,Kmm) ) 
    136          IF( iom_use('emp_x_sss') )   CALL iom_put( "emp_x_sss", emp (:,:) * pts(:,:,1,jp_sal,Kmm) ) 
     151         IF( ntile == 0 .OR. ntile == nijtile )  THEN             ! Do only on the last tile 
     152            IF( iom_use('emp_x_sst') )   CALL iom_put( "emp_x_sst", emp (:,:) * pts(:,:,1,jp_tem,Kmm) ) 
     153            IF( iom_use('emp_x_sss') )   CALL iom_put( "emp_x_sss", emp (:,:) * pts(:,:,1,jp_sal,Kmm) ) 
     154         ENDIF 
    137155      ENDIF 
    138156      ! 
    139157      DO jn = 1, jpts               !==  update tracer trend  ==! 
    140          DO_2D( 0, 1, 0, 0 ) 
     158         ! NOTE: [tiling-comms-merge] This looped over nn_hls, which changes the results when using tiling 
     159         DO_2D( 0, 0, 0, 0 ) 
    141160            pts(ji,jj,1,jn,Krhs) = pts(ji,jj,1,jn,Krhs) + zfact * ( sbc_tsc_b(ji,jj,jn) + sbc_tsc(ji,jj,jn) )    & 
    142161               &                                                / e3t(ji,jj,1,Kmm) 
    … …  
    144163      END DO 
    145164      !                   
    146       IF( lrst_oce ) THEN           !==  write sbc_tsc in the ocean restart file  ==! 
    147          CALL iom_rstput( kt, nitrst, numrow, 'sbc_hc_b', sbc_tsc(:,:,jp_tem) ) 
    148          CALL iom_rstput( kt, nitrst, numrow, 'sbc_sc_b', sbc_tsc(:,:,jp_sal) ) 
     165      IF( ntile == 0 .OR. ntile == nijtile )  THEN                ! Do only on the last tile 
     166         IF( lrst_oce ) THEN           !==  write sbc_tsc in the ocean restart file  ==! 
     167            CALL iom_rstput( kt, nitrst, numrow, 'sbc_hc_b', sbc_tsc(:,:,jp_tem) ) 
     168            CALL iom_rstput( kt, nitrst, numrow, 'sbc_sc_b', sbc_tsc(:,:,jp_sal) ) 
     169         ENDIF 
    149170      ENDIF 
    150171      ! 
    … …  
    155176      IF( ln_rnf ) THEN         ! input of heat and salt due to river runoff  
    156177         zfact = 0.5_wp 
    157          DO_2D( 0, 1, 0, 0 ) 
     178         DO_2D( 0, 0, 0, 0 ) 
    158179            IF( rnf(ji,jj) /= 0._wp ) THEN 
    159180               zdep = zfact / h_rnf(ji,jj) 
    … …  
    168189      ENDIF 
    169190 
    170       IF( iom_use('rnf_x_sst') )   CALL iom_put( "rnf_x_sst", rnf*pts(:,:,1,jp_tem,Kmm) )   ! runoff term on sst 
    171       IF( iom_use('rnf_x_sss') )   CALL iom_put( "rnf_x_sss", rnf*pts(:,:,1,jp_sal,Kmm) )   ! runoff term on sss 
     191      IF( ntile == 0 .OR. ntile == nijtile )  THEN                ! Do only on the last tile 
     192         IF( iom_use('rnf_x_sst') )   CALL iom_put( "rnf_x_sst", rnf*pts(:,:,1,jp_tem,Kmm) )   ! runoff term on sst 
     193         IF( iom_use('rnf_x_sss') )   CALL iom_put( "rnf_x_sss", rnf*pts(:,:,1,jp_sal,Kmm) )   ! runoff term on sss 
     194      ENDIF 
    172195 
    173196#if defined key_asminc 
    … …  
    180203          ! 
    181204         IF( ln_linssh ) THEN  
    182             DO_2D( 0, 1, 0, 0 ) 
     205            DO_2D( 0, 0, 0, 0 ) 
    183206               ztim = ssh_iau(ji,jj) / e3t(ji,jj,1,Kmm) 
    184207               pts(ji,jj,1,jp_tem,Krhs) = pts(ji,jj,1,jp_tem,Krhs) + pts(ji,jj,1,jp_tem,Kmm) * ztim 
    … …  
    186209            END_2D 
    187210         ELSE 
    188             DO_2D( 0, 1, 0, 0 ) 
     211            DO_2D( 0, 0, 0, 0 ) 
    189212               ztim = ssh_iau(ji,jj) / ( ht(ji,jj) + 1. - ssmask(ji, jj) ) 
    190213               pts(ji,jj,:,jp_tem,Krhs) = pts(ji,jj,:,jp_tem,Krhs) + pts(ji,jj,:,jp_tem,Kmm) * ztim 
    … …  
    202225         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_nsr, ztrdt ) 
    203226         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_nsr, ztrds ) 
    204          DEALLOCATE( ztrdt , ztrds )  
     227         DEALLOCATE( ztrdt , ztrds ) 
    205228      ENDIF 
    206229      ! 

  • NEMO/trunk/src/OCE/TRA/trazdf.F90

    r13497 r13982  
    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 domvvl         ! variable volume 
    1717   USE phycst         ! physical constant 
    … …  
    5555      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts                 ! active tracers and RHS of tracer equation 
    5656      ! 
    57       INTEGER  ::   jk   ! Dummy loop indices 
     57      INTEGER  ::   ji, jj, jk   ! Dummy loop indices 
    5858      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztrdt, ztrds   ! 3D workspace 
    5959      !!--------------------------------------------------------------------- 
    … …  
    6262      ! 
    6363      IF( kt == nit000 )  THEN 
    64          IF(lwp)WRITE(numout,*) 
    65          IF(lwp)WRITE(numout,*) 'tra_zdf : implicit vertical mixing on T & S' 
    66          IF(lwp)WRITE(numout,*) '~~~~~~~ ' 
     64         IF( ntile == 0 .OR. ntile == 1 )  THEN                   ! Do only on the first tile 
     65            IF(lwp)WRITE(numout,*) 
     66            IF(lwp)WRITE(numout,*) 'tra_zdf : implicit vertical mixing on T & S' 
     67            IF(lwp)WRITE(numout,*) '~~~~~~~ ' 
     68         ENDIF 
    6769      ENDIF 
    6870      ! 
    6971      IF( l_trdtra )   THEN                  !* Save ta and sa trends 
    70          ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 
     72         ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 
    7173         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kaa) 
    7274         ztrds(:,:,:) = pts(:,:,:,jp_sal,Kaa) 
    … …  
    8082      ! JMM avoid negative salinities near river outlet ! Ugly fix 
    8183      ! JMM : restore negative salinities to small salinities: 
    82       WHERE( pts(:,:,:,jp_sal,Kaa) < 0._wp )   pts(:,:,:,jp_sal,Kaa) = 0.1_wp 
     84      WHERE( pts(A2D(0),:,jp_sal,Kaa) < 0._wp )   pts(A2D(0),:,jp_sal,Kaa) = 0.1_wp 
    8385!!gm 
    8486 
    8587      IF( l_trdtra )   THEN                      ! save the vertical diffusive trends for further diagnostics 
    86          DO jk = 1, jpkm1 
     88         DO jk = 1, jpk 
    8789            ztrdt(:,:,jk) = (   (  pts(:,:,jk,jp_tem,Kaa)*e3t(:,:,jk,Kaa)     & 
    8890               &                 - pts(:,:,jk,jp_tem,Kbb)*e3t(:,:,jk,Kbb)  )  & 
    … …  
    9496               &          - ztrds(:,:,jk) 
    9597         END DO 
     98         ! NOTE: [tiling-comms-merge] The diagnostic results change along the north fold if this is removed 
    9699!!gm this should be moved in trdtra.F90 and done on all trends 
    97100         CALL lbc_lnk_multi( 'trazdf', ztrdt, 'T', 1.0_wp , ztrds, 'T', 1.0_wp ) 
    … …  
    140143      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices 
    141144      REAL(wp) ::  zrhs, zzwi, zzws ! local scalars 
    142       REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zwi, zwt, zwd, zws 
     145      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::  zwi, zwt, zwd, zws 
    143146      !!--------------------------------------------------------------------- 
    144147      ! 
    … …  
    154157            ! 
    155158            ! vertical mixing coef.: avt for temperature, avs for salinity and passive tracers 
    156             IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN   ;   zwt(:,:,2:jpk) = avt(:,:,2:jpk) 
    157             ELSE                                            ;   zwt(:,:,2:jpk) = avs(:,:,2:jpk) 
     159            IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN 
     160               DO_3D( 1, 1, 1, 1, 2, jpk ) 
     161                  zwt(ji,jj,jk) = avt(ji,jj,jk) 
     162               END_3D 
     163            ELSE 
     164               DO_3D( 1, 1, 1, 1, 2, jpk ) 
     165                  zwt(ji,jj,jk) = avs(ji,jj,jk) 
     166               END_3D 
    158167            ENDIF 
    159168            zwt(:,:,1) = 0._wp 
    … …  
    222231         END_2D 
    223232         DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
    224             zrhs =        e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb)    &  
     233            zrhs =        e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb)    & 
    225234               & + p2dt * e3t(ji,jj,jk,Kmm) * pt(ji,jj,jk,jn,Krhs)   ! zrhs=right hand side 
    226235            pt(ji,jj,jk,jn,Kaa) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) * pt(ji,jj,jk-1,jn,Kaa) 

  • NEMO/trunk/src/OCE/TRA/zpshde.F90

    r13497 r13982  
    1717   USE oce             ! ocean: dynamics and tracers variables 
    1818   USE dom_oce         ! domain: ocean variables 
     19   USE domutl, ONLY : is_tile 
    1920   USE phycst          ! physical constants 
    2021   USE eosbn2          ! ocean equation of state 
    … …  
    4041CONTAINS 
    4142 
    42    SUBROUTINE zps_hde( kt, Kmm, kjpt, pta, pgtu, pgtv,   & 
    43       &                          prd, pgru, pgrv    ) 
     43   SUBROUTINE zps_hde( kt, Kmm, kjpt, pta, pgtu, pgtv,  & 
     44      &                               prd, pgru, pgrv ) 
     45      !! 
     46      INTEGER                     , INTENT(in   )           ::  kt          ! ocean time-step index 
     47      INTEGER                     , INTENT(in   )           ::  Kmm         ! ocean time level index 
     48      INTEGER                     , INTENT(in   )           ::  kjpt        ! number of tracers 
     49      REAL(wp), DIMENSION(:,:,:,:), INTENT(inout)           ::  pta         ! 4D tracers fields 
     50      REAL(wp), DIMENSION(:,:,:)  , INTENT(  out)           ::  pgtu, pgtv  ! hor. grad. of ptra at u- & v-pts 
     51      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout), OPTIONAL ::  prd         ! 3D density anomaly fields 
     52      REAL(wp), DIMENSION(:,:)    , INTENT(  out), OPTIONAL ::  pgru, pgrv  ! hor. grad of prd at u- & v-pts (bottom) 
     53      ! 
     54      INTEGER :: itrd, itgr 
     55      !! 
     56      IF( PRESENT(prd)  ) THEN ; itrd = is_tile(prd)  ; ELSE ; itrd = 0 ; ENDIF 
     57      IF( PRESENT(pgru) ) THEN ; itgr = is_tile(pgru) ; ELSE ; itgr = 0 ; ENDIF 
     58 
     59      CALL zps_hde_t( kt, Kmm, kjpt, pta, is_tile(pta), pgtu, pgtv, is_tile(pgtu), & 
     60         &                           prd, itrd,         pgru, pgrv, itgr ) 
     61   END SUBROUTINE zps_hde 
     62 
     63 
     64   SUBROUTINE zps_hde_t( kt, Kmm, kjpt, pta, ktta, pgtu, pgtv, ktgt,   & 
     65      &                                 prd, ktrd, pgru, pgrv, ktgr ) 
    4466      !!---------------------------------------------------------------------- 
    4567      !!                     ***  ROUTINE zps_hde  *** 
    … …  
    85107      !!              - pgru, pgrv: horizontal gradient of rho (if present) at u- & v-points 
    86108      !!---------------------------------------------------------------------- 
    87       INTEGER                              , INTENT(in   )           ::  kt          ! ocean time-step index 
    88       INTEGER                              , INTENT(in   )           ::  Kmm         ! ocean time level index 
    89       INTEGER                              , INTENT(in   )           ::  kjpt        ! number of tracers 
    90       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   )           ::  pta         ! 4D tracers fields 
    91       REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  pgtu, pgtv  ! hor. grad. of ptra at u- & v-pts  
    92       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ), OPTIONAL ::  prd         ! 3D density anomaly fields 
    93       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgru, pgrv  ! hor. grad of prd at u- & v-pts (bottom) 
     109      INTEGER                                , INTENT(in   )           ::  kt          ! ocean time-step index 
     110      INTEGER                                , INTENT(in   )           ::  Kmm         ! ocean time level index 
     111      INTEGER                                , INTENT(in   )           ::  kjpt        ! number of tracers 
     112      INTEGER                                , INTENT(in   )           ::  ktta, ktgt, ktrd, ktgr 
     113      REAL(wp), DIMENSION(A2D_T(ktta),JPK,KJPT), INTENT(inout)           ::  pta         ! 4D tracers fields 
     114      REAL(wp), DIMENSION(A2D_T(ktgt)    ,KJPT), INTENT(  out)           ::  pgtu, pgtv  ! hor. grad. of ptra at u- & v-pts 
     115      REAL(wp), DIMENSION(A2D_T(ktrd),JPK     ), INTENT(inout), OPTIONAL ::  prd         ! 3D density anomaly fields 
     116      REAL(wp), DIMENSION(A2D_T(ktgr)         ), INTENT(  out), OPTIONAL ::  pgru, pgrv  ! hor. grad of prd at u- & v-pts (bottom) 
    94117      ! 
    95118      INTEGER  ::   ji, jj, jn                  ! Dummy loop indices 
    96119      INTEGER  ::   iku, ikv, ikum1, ikvm1      ! partial step level (ocean bottom level) at u- and v-points 
    97120      REAL(wp) ::   ze3wu, ze3wv, zmaxu, zmaxv  ! local scalars 
    98       REAL(wp), DIMENSION(jpi,jpj)      ::   zri, zrj, zhi, zhj   ! NB: 3rd dim=1 to use eos 
    99       REAL(wp), DIMENSION(jpi,jpj,kjpt) ::   zti, ztj             !  
     121      REAL(wp), DIMENSION(A2D(nn_hls))      ::   zri, zrj, zhi, zhj   ! NB: 3rd dim=1 to use eos 
     122      REAL(wp), DIMENSION(A2D(nn_hls),kjpt) ::   zti, ztj             ! 
    100123      !!---------------------------------------------------------------------- 
    101124      ! 
    102125      IF( ln_timing )   CALL timing_start( 'zps_hde') 
     126      ! NOTE: [tiling-comms-merge] Some lbc_lnks in tra_adv and tra_ldf can be taken out in the zps case, because this lbc_lnk is called when zps_hde is called in the stp routine. In the zco case they are still needed. 
     127      IF (nn_hls.EQ.2) THEN 
     128         CALL lbc_lnk( 'zpshde', pta, 'T', 1.0_wp) 
     129         IF(PRESENT(prd)) CALL lbc_lnk( 'zpshde', prd, 'T', 1.0_wp) 
     130      END IF 
    103131      ! 
    104132      pgtu(:,:,:) = 0._wp   ;   zti (:,:,:) = 0._wp   ;   zhi (:,:) = 0._wp 
    … …  
    107135      DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==! 
    108136         ! 
    109          DO_2D( 1, 0, 1, 0 ) 
     137         DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )              ! Gradient of density at the last level 
    110138            iku = mbku(ji,jj)   ;   ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
    111139            ikv = mbkv(ji,jj)   ;   ikvm1 = MAX( ikv - 1 , 1 )    ! if level first is a p-step, ik.m1=1 
    … …  
    146174      END DO 
    147175      ! 
    148       CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp )   ! Lateral boundary cond. 
     176      IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp )   ! Lateral boundary cond. 
    149177      !                 
    150178      IF( PRESENT( prd ) ) THEN    !==  horizontal derivative of density anomalies (rd)  ==!    (optional part) 
    151179         pgru(:,:) = 0._wp 
    152180         pgrv(:,:) = 0._wp                ! depth of the partial step level 
    153          DO_2D( 1, 0, 1, 0 ) 
     181         DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 
    154182            iku = mbku(ji,jj) 
    155183            ikv = mbkv(ji,jj) 
    … …  
    167195         CALL eos( ztj, zhj, zrj )        ! at the partial step depth output in  zri, zrj  
    168196         ! 
    169          DO_2D( 1, 0, 1, 0 )              ! Gradient of density at the last level 
     197         DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 )              ! Gradient of density at the last level 
    170198            iku = mbku(ji,jj) 
    171199            ikv = mbkv(ji,jj) 
    … …  
    179207            ENDIF 
    180208         END_2D 
    181          CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp )   ! Lateral boundary conditions 
     209         IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp )   ! Lateral boundary conditions 
    182210         ! 
    183211      END IF 
    … …  
    185213      IF( ln_timing )   CALL timing_stop( 'zps_hde') 
    186214      ! 
    187    END SUBROUTINE zps_hde 
     215   END SUBROUTINE zps_hde_t 
    188216 
    189217 
    190218   SUBROUTINE zps_hde_isf( kt, Kmm, kjpt, pta, pgtu, pgtv, pgtui, pgtvi,  & 
    191       &                          prd, pgru, pgrv, pgrui, pgrvi ) 
     219      &                                   prd, pgru, pgrv, pgrui, pgrvi ) 
     220      !! 
     221      INTEGER                     , INTENT(in   )           ::  kt           ! ocean time-step index 
     222      INTEGER                     , INTENT(in   )           ::  Kmm          ! ocean time level index 
     223      INTEGER                     , INTENT(in   )           ::  kjpt         ! number of tracers 
     224      REAL(wp), DIMENSION(:,:,:,:), INTENT(inout)           ::  pta          ! 4D tracers fields 
     225      REAL(wp), DIMENSION(:,:,:)  , INTENT(  out)           ::  pgtu, pgtv   ! hor. grad. of ptra at u- & v-pts 
     226      REAL(wp), DIMENSION(:,:,:)  , INTENT(  out)           ::  pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF) 
     227      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout), OPTIONAL ::  prd          ! 3D density anomaly fields 
     228      REAL(wp), DIMENSION(:,:)    , INTENT(  out), OPTIONAL ::  pgru, pgrv   ! hor. grad of prd at u- & v-pts (bottom) 
     229      REAL(wp), DIMENSION(:,:)    , INTENT(  out), OPTIONAL ::  pgrui, pgrvi ! hor. grad of prd at u- & v-pts (top) 
     230      ! 
     231      INTEGER :: itrd, itgr, itgri 
     232      !! 
     233      IF( PRESENT(prd)   ) THEN ; itrd  = is_tile(prd)   ; ELSE ; itrd  = 0 ; ENDIF 
     234      IF( PRESENT(pgru)  ) THEN ; itgr  = is_tile(pgru)  ; ELSE ; itgr  = 0 ; ENDIF 
     235      IF( PRESENT(pgrui) ) THEN ; itgri = is_tile(pgrui) ; ELSE ; itgri = 0 ; ENDIF 
     236 
     237      CALL zps_hde_isf_t( kt, Kmm, kjpt, pta, is_tile(pta), pgtu, pgtv, is_tile(pgtu), pgtui, pgtvi, is_tile(pgtui),  & 
     238      &                                  prd, itrd,         pgru, pgrv, itgr,          pgrui, pgrvi, itgri ) 
     239   END SUBROUTINE zps_hde_isf 
     240 
     241 
     242   SUBROUTINE zps_hde_isf_t( kt, Kmm, kjpt, pta, ktta, pgtu, pgtv, ktgt, pgtui, pgtvi, ktgti,  & 
     243      &                                     prd, ktrd, pgru, pgrv, ktgr, pgrui, pgrvi, ktgri ) 
    192244      !!---------------------------------------------------------------------- 
    193245      !!                     ***  ROUTINE zps_hde_isf  *** 
    … …  
    236288      !!              - pgru, pgrv, pgrui, pgtvi: horizontal gradient of rho (if present) at u- & v-points 
    237289      !!---------------------------------------------------------------------- 
    238       INTEGER                              , INTENT(in   )           ::  kt           ! ocean time-step index 
    239       INTEGER                              , INTENT(in   )           ::  Kmm          ! ocean time level index 
    240       INTEGER                              , INTENT(in   )           ::  kjpt         ! number of tracers 
    241       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   )           ::  pta          ! 4D tracers fields 
    242       REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  pgtu, pgtv   ! hor. grad. of ptra at u- & v-pts  
    243       REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF) 
    244       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ), OPTIONAL ::  prd          ! 3D density anomaly fields 
    245       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgru, pgrv   ! hor. grad of prd at u- & v-pts (bottom) 
    246       REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgrui, pgrvi ! hor. grad of prd at u- & v-pts (top) 
     290      INTEGER                                , INTENT(in   )           ::  kt           ! ocean time-step index 
     291      INTEGER                                , INTENT(in   )           ::  Kmm          ! ocean time level index 
     292      INTEGER                                , INTENT(in   )           ::  kjpt         ! number of tracers 
     293      INTEGER                                , INTENT(in   )           ::  ktta, ktgt, ktgti, ktrd, ktgr, ktgri 
     294      REAL(wp), DIMENSION(A2D_T(ktta),JPK,KJPT), INTENT(inout)           ::  pta          ! 4D tracers fields 
     295      REAL(wp), DIMENSION(A2D_T(ktgt)    ,KJPT), INTENT(  out)           ::  pgtu, pgtv   ! hor. grad. of ptra at u- & v-pts 
     296      REAL(wp), DIMENSION(A2D_T(ktgti)   ,KJPT), INTENT(  out)           ::  pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF) 
     297      REAL(wp), DIMENSION(A2D_T(ktrd),JPK     ), INTENT(inout), OPTIONAL ::  prd          ! 3D density anomaly fields 
     298      REAL(wp), DIMENSION(A2D_T(ktgr)         ), INTENT(  out), OPTIONAL ::  pgru, pgrv   ! hor. grad of prd at u- & v-pts (bottom) 
     299      REAL(wp), DIMENSION(A2D_T(ktgri)        ), INTENT(  out), OPTIONAL ::  pgrui, pgrvi ! hor. grad of prd at u- & v-pts (top) 
    247300      ! 
    248301      INTEGER  ::   ji, jj, jn      ! Dummy loop indices 
    249302      INTEGER  ::   iku, ikv, ikum1, ikvm1,ikup1, ikvp1   ! partial step level (ocean bottom level) at u- and v-points 
    250303      REAL(wp) ::  ze3wu, ze3wv, zmaxu, zmaxv             ! temporary scalars 
    251       REAL(wp), DIMENSION(jpi,jpj)      ::  zri, zrj, zhi, zhj   ! NB: 3rd dim=1 to use eos 
    252       REAL(wp), DIMENSION(jpi,jpj,kjpt) ::  zti, ztj             !  
     304      REAL(wp), DIMENSION(A2D(nn_hls))      ::  zri, zrj, zhi, zhj   ! NB: 3rd dim=1 to use eos 
     305      REAL(wp), DIMENSION(A2D(nn_hls),kjpt) ::  zti, ztj             ! 
    253306      !!---------------------------------------------------------------------- 
    254307      ! 
    255308      IF( ln_timing )   CALL timing_start( 'zps_hde_isf') 
    256309      ! 
     310      IF (nn_hls.EQ.2) THEN 
     311         CALL lbc_lnk( 'zpshde', pta, 'T', 1.0_wp) 
     312         IF (PRESENT(prd)) CALL lbc_lnk( 'zpshde', prd, 'T', 1.0_wp) 
     313      END IF 
     314 
    257315      pgtu (:,:,:) = 0._wp   ;   pgtv (:,:,:) =0._wp 
    258316      pgtui(:,:,:) = 0._wp   ;   pgtvi(:,:,:) =0._wp 
    … …  
    262320      DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==! 
    263321         ! 
    264          DO_2D( 1, 0, 1, 0 ) 
     322         DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 
    265323 
    266324            iku = mbku(ji,jj); ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
    … …  
    302360      END DO 
    303361      ! 
    304       CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp )   ! Lateral boundary cond. 
     362      IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp )   ! Lateral boundary cond. 
    305363 
    306364      ! horizontal derivative of density anomalies (rd) 
    … …  
    308366         pgru(:,:)=0.0_wp   ; pgrv(:,:)=0.0_wp ;  
    309367         ! 
    310          DO_2D( 1, 0, 1, 0 ) 
     368         DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 
    311369 
    312370            iku = mbku(ji,jj) 
    … …  
    329387         CALL eos( ztj, zhj, zrj ) 
    330388 
    331          DO_2D( 1, 0, 1, 0 )            ! Gradient of density at the last level 
     389         DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 
    332390            iku = mbku(ji,jj) 
    333391            ikv = mbkv(ji,jj) 
    … …  
    344402         END_2D 
    345403 
    346          CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp )   ! Lateral boundary conditions 
     404         IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp )   ! Lateral boundary conditions 
    347405         ! 
    348406      END IF 
    … …  
    351409      ! 
    352410      DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==!            ! 
    353          DO_2D( 1, 0, 1, 0 ) 
     411         DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 
    354412            iku = miku(ji,jj); ikup1 = miku(ji,jj) + 1 
    355413            ikv = mikv(ji,jj); ikvp1 = mikv(ji,jj) + 1 
    … …  
    395453         ! 
    396454      END DO 
    397       CALL lbc_lnk_multi( 'zpshde', pgtui(:,:,:), 'U', -1.0_wp , pgtvi(:,:,:), 'V', -1.0_wp )   ! Lateral boundary cond. 
     455      IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgtui(:,:,:), 'U', -1.0_wp , pgtvi(:,:,:), 'V', -1.0_wp )   ! Lateral boundary cond. 
    398456 
    399457      IF( PRESENT( prd ) ) THEN    !==  horizontal derivative of density anomalies (rd)  ==!    (optional part) 
    400458         ! 
    401459         pgrui(:,:)  =0.0_wp; pgrvi(:,:)  =0.0_wp; 
    402          DO_2D( 1, 0, 1, 0 ) 
     460         DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 
    403461 
    404462            iku = miku(ji,jj) 
    … …  
    420478         CALL eos( ztj, zhj, zrj )        ! at the partial step depth output in  zri, zrj  
    421479         ! 
    422          DO_2D( 1, 0, 1, 0 )              ! Gradient of density at the last level 
     480         DO_2D( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1 ) 
    423481            iku = miku(ji,jj)  
    424482            ikv = mikv(ji,jj)  
    … …  
    434492 
    435493         END_2D 
    436          CALL lbc_lnk_multi( 'zpshde', pgrui, 'U', -1.0_wp , pgrvi, 'V', -1.0_wp )   ! Lateral boundary conditions 
     494         IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgrui, 'U', -1.0_wp , pgrvi, 'V', -1.0_wp )   ! Lateral boundary conditions 
    437495         ! 
    438496      END IF   
    … …  
    440498      IF( ln_timing )   CALL timing_stop( 'zps_hde_isf') 
    441499      ! 
    442    END SUBROUTINE zps_hde_isf 
     500   END SUBROUTINE zps_hde_isf_t 
    443501 
    444502   !!====================================================================== 

  • NEMO/trunk/src/OCE/TRD/trdini.F90

    r12377 r13982  
    1111   !!---------------------------------------------------------------------- 
    1212   USE dom_oce        ! ocean domain 
     13   USE domain, ONLY : dom_tile 
    1314   USE trd_oce        ! trends: ocean variables 
    1415   USE trdken         ! trends: 3D kinetic   energy 
    … …  
    8889      ! 
    8990!      IF( .NOT.ln_linssh .AND. ( l_trdtra .OR. l_trddyn ) )  CALL ctl_stop( 'trend diagnostics with variable volume not validated' ) 
    90        
     91 
     92      IF( ln_tile .AND. ( l_trdtra .OR. l_trddyn ) ) THEN 
     93         CALL ctl_warn('Tiling is not yet implemented for the trends diagnostics; ln_tile is forced to FALSE') 
     94         ln_tile = .FALSE. 
     95         CALL dom_tile( ntsi, ntsj, ntei, ntej ) 
     96      ENDIF 
     97 
    9198!!gm  : Potential BUG : 3D output only for vector invariant form!  add a ctl_stop or code the flux form case 
    9299!!gm  : bug/pb for vertical advection of tracer in vvl case: add T.dt[eta] in the output...  

  • NEMO/trunk/src/OCE/USR/usrdef_nam.F90

    r13286 r13982  
    7070      kk_cfg = nn_GYRE 
    7171      ! 
    72       kpi = 30 * nn_GYRE + 2       !                      
     72      kpi = 30 * nn_GYRE + 2       ! 
    7373      kpj = 20 * nn_GYRE + 2 
    7474#if defined key_agrif 

  • NEMO/trunk/src/OCE/ZDF/zdfosm.F90

    r13970 r13982  
    14911491     !!----------------------------------------------------------------------------- 
    14921492     IF( TRIM(cdrw) == 'WRITE') THEN     !* Write hbli into the restart file, then return 
     1493        IF( ntile /= 0 .AND. ntile /= nijtile ) RETURN        ! Do only on the last tile 
     1494 
    14931495        IF(lwp) WRITE(numout,*) '---- osm-rst ----' 
    14941496         CALL iom_rstput( kt, nitrst, numrow, 'wn'     , ww   ) 
    … …  
    15451547      ! 
    15461548      IF( kt == nit000 ) THEN 
    1547          IF(lwp) WRITE(numout,*) 
    1548          IF(lwp) WRITE(numout,*) 'tra_osm : OSM non-local tracer fluxes' 
    1549          IF(lwp) WRITE(numout,*) '~~~~~~~   ' 
     1549         IF( ntile == 0 .OR. ntile == 1 ) THEN                    ! Do only on the first tile 
     1550            IF(lwp) WRITE(numout,*) 
     1551            IF(lwp) WRITE(numout,*) 'tra_osm : OSM non-local tracer fluxes' 
     1552            IF(lwp) WRITE(numout,*) '~~~~~~~   ' 
     1553         ENDIF 
    15501554      ENDIF 
    15511555 

  • NEMO/trunk/src/OCE/do_loop_substitute.h90

    r13296 r13982  
    5959#endif 
    6060 
    61 #define DO_2D(B, T, L, R) DO jj = Njs0-(B), Nje0+(T)   ;   DO ji = Nis0-(L), Nie0+(R) 
     61#define DO_2D(B, T, L, R) DO jj = ntsj-(B), ntej+(T)   ;   DO ji = ntsi-(L), ntei+(R) 
     62#define A1Di(H) ntsi-H:ntei+H 
     63#define A1Dj(H) ntsj-H:ntej+H 
     64#define A2D(H) A1Di(H),A1Dj(H) 
     65#define A1Di_T(T) (ntsi-nn_hls-1)*T+1: 
     66#define A1Dj_T(T) (ntsj-nn_hls-1)*T+1: 
     67#define A2D_T(T) A1Di_T(T),A1Dj_T(T) 
     68#define JPK  : 
     69#define JPTS  : 
     70#define KJPT  : 
    6271 
    6372#define DO_3D(B, T, L, R, ks, ke) DO jk = ks, ke   ;   DO_2D(B, T, L, R) 

  • NEMO/trunk/src/OCE/par_oce.F90

    r13286 r13982  
    6565   INTEGER, PUBLIC ::   jpjmax! = ( Nj0glo + jpnj-1 ) / jpnj + 2*nn_hls            !: maximum jpj 
    6666 
     67   ! Domain tiling 
     68   INTEGER, PUBLIC ::   nijtile    !: number of tiles in total 
     69   INTEGER, PUBLIC ::   ntile      !: current tile number 
     70   INTEGER, PUBLIC ::   ntsi       !: start of internal part of tile domain 
     71   INTEGER, PUBLIC ::   ntsj       ! 
     72   INTEGER, PUBLIC ::   ntei       !: end of internal part of tile domain 
     73   INTEGER, PUBLIC ::   ntej       ! 
     74 
    6775   !!--------------------------------------------------------------------- 
    6876   !! Active tracer parameters 

  • NEMO/trunk/src/OCE/step.F90

    r13970 r13982  
    5555   INTEGER, PUBLIC :: Nbb, Nnn, Naa, Nrhs          !! used by nemo_init 
    5656 
     57   !! * Substitutions 
     58#  include "do_loop_substitute.h90" 
    5759   !!---------------------------------------------------------------------- 
    5860   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    8587      !!              -8- Outputs and diagnostics 
    8688      !!---------------------------------------------------------------------- 
    87       INTEGER ::   ji, jj, jk   ! dummy loop indice 
     89      INTEGER ::   ji, jj, jk, jtile   ! dummy loop indice 
    8890!!gm kcall can be removed, I guess 
    8991      INTEGER ::   kcall        ! optional integer argument (dom_vvl_sf_nxt) 
    … …  
    263265      ! Active tracers                               
    264266      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    265                          ts(:,:,:,:,Nrhs) = 0._wp         ! set tracer trends to zero 
    266  
    267       IF(  lk_asminc .AND. ln_asmiau .AND. & 
    268          & ln_trainc )   CALL tra_asm_inc( kstp, Nbb, Nnn, ts, Nrhs )  ! apply tracer assimilation increment 
    269                          CALL tra_sbc    ( kstp,      Nnn, ts, Nrhs )  ! surface boundary condition 
    270       IF( ln_traqsr  )   CALL tra_qsr    ( kstp,      Nnn, ts, Nrhs )  ! penetrative solar radiation qsr 
    271       IF( ln_isf     )   CALL tra_isf    ( kstp,      Nnn, ts, Nrhs )  ! ice shelf heat flux 
    272       IF( ln_trabbc  )   CALL tra_bbc    ( kstp,      Nnn, ts, Nrhs )  ! bottom heat flux 
    273       IF( ln_trabbl  )   CALL tra_bbl    ( kstp, Nbb, Nnn, ts, Nrhs )  ! advective (and/or diffusive) bottom boundary layer scheme 
    274       IF( ln_tradmp  )   CALL tra_dmp    ( kstp, Nbb, Nnn, ts, Nrhs )  ! internal damping trends 
    275       IF( ln_bdy     )   CALL bdy_tra_dmp( kstp, Nbb,      ts, Nrhs )  ! bdy damping trends 
    276 #if defined key_agrif 
    277       IF(.NOT. Agrif_Root())  &  
    278                &         CALL Agrif_Sponge_tra        ! tracers sponge 
    279 #endif 
    280                          CALL tra_adv    ( kstp, Nbb, Nnn, ts, Nrhs )  ! hor. + vert. advection ==> RHS 
    281       IF( ln_zdfosm  )   CALL tra_osm    ( kstp,      Nnn, ts, Nrhs )  ! OSMOSIS non-local tracer fluxes ==> RHS 
    282       IF( lrst_oce .AND. ln_zdfosm ) & 
    283            &             CALL osm_rst    ( kstp,      Nnn, 'WRITE'  )  ! write OSMOSIS outputs + ww (so must do here) to restarts 
    284                          CALL tra_ldf    ( kstp, Nbb, Nnn, ts, Nrhs )  ! lateral mixing 
    285  
    286                          CALL tra_zdf    ( kstp, Nbb, Nnn, Nrhs, ts, Naa  )  ! vertical mixing and after tracer fields 
    287       IF( ln_zdfnpc  )   CALL tra_npc    ( kstp,      Nnn, Nrhs, ts, Naa  )  ! update after fields by non-penetrative convection 
    288  
     267      ! Loop over tile domains 
     268      DO jtile = 1, nijtile 
     269         IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) 
     270 
     271         DO_3D( 0, 0, 0, 0, 1, jpk ) 
     272            ts(ji,jj,jk,:,Nrhs) = 0._wp                                         ! set tracer trends to zero 
     273         END_3D 
     274 
     275         IF(  lk_asminc .AND. ln_asmiau .AND. & 
     276            & ln_trainc )   CALL tra_asm_inc( kstp, Nbb, Nnn, ts, Nrhs )  ! apply tracer assimilation increment 
     277                            CALL tra_sbc    ( kstp,      Nnn, ts, Nrhs )  ! surface boundary condition 
     278         IF( ln_traqsr  )   CALL tra_qsr    ( kstp,      Nnn, ts, Nrhs )  ! penetrative solar radiation qsr 
     279         IF( ln_isf     )   CALL tra_isf    ( kstp,      Nnn, ts, Nrhs )  ! ice shelf heat flux 
     280         IF( ln_trabbc  )   CALL tra_bbc    ( kstp,      Nnn, ts, Nrhs )  ! bottom heat flux 
     281         IF( ln_trabbl  )   CALL tra_bbl    ( kstp, Nbb, Nnn, ts, Nrhs )  ! advective (and/or diffusive) bottom boundary layer scheme 
     282         IF( ln_tradmp  )   CALL tra_dmp    ( kstp, Nbb, Nnn, ts, Nrhs )  ! internal damping trends 
     283         IF( ln_bdy     )   CALL bdy_tra_dmp( kstp, Nbb,      ts, Nrhs )  ! bdy damping trends 
     284      END DO 
     285 
     286#if defined key_agrif 
     287         IF(.NOT. Agrif_Root()) THEN 
     288            IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) 
     289            CALL Agrif_Sponge_tra        ! tracers sponge 
     290         ENDIF 
     291#endif 
     292 
     293      ! TEMP: [tiling] Separate loop over tile domains (due to tra_adv workarounds for tiling) 
     294      DO jtile = 1, nijtile 
     295         IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = jtile ) 
     296 
     297                            CALL tra_adv    ( kstp, Nbb, Nnn, ts, Nrhs )  ! hor. + vert. advection ==> RHS 
     298         IF( ln_zdfosm  )   CALL tra_osm    ( kstp,      Nnn, ts, Nrhs )  ! OSMOSIS non-local tracer fluxes ==> RHS 
     299         IF( lrst_oce .AND. ln_zdfosm ) & 
     300              &             CALL osm_rst    ( kstp,      Nnn, 'WRITE'  )  ! write OSMOSIS outputs + ww (so must do here) to restarts 
     301                            CALL tra_ldf    ( kstp, Nbb, Nnn, ts, Nrhs )  ! lateral mixing 
     302 
     303                            CALL tra_zdf    ( kstp, Nbb, Nnn, Nrhs, ts, Naa  )  ! vertical mixing and after tracer fields 
     304         IF( ln_zdfnpc  )   CALL tra_npc    ( kstp,      Nnn, Nrhs, ts, Naa  )  ! update after fields by non-penetrative convection 
     305      END DO 
     306 
     307      IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) ! Revert to tile over full domain 
    289308      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    290309      ! Set boundary conditions, time filter and swap time levels 

  • NEMO/trunk/src/OCE/step_oce.F90

    r12377 r13982  
    99   USE oce             ! ocean dynamics and tracers variables 
    1010   USE dom_oce         ! ocean space and time domain variables 
     11   USE domain, ONLY : dom_tile 
    1112   USE zdf_oce         ! ocean vertical physics variables 
    1213   USE zdfdrg  ,  ONLY : ln_drgimp   ! implicit top/bottom friction 

  • NEMO/trunk/src/OCE/timing.F90

    r13558 r13982  
    109109 
    110110      s_timer%l_tdone = .FALSE. 
    111       s_timer%niter = s_timer%niter + 1 
     111      IF( ntile == 0 .OR. ntile == 1 ) s_timer%niter = s_timer%niter + 1      ! All tiles count as one iteration 
    112112      s_timer%t_cpu = 0. 
    113113      s_timer%t_clock = 0. 

  • NEMO/trunk/src/OFF/dtadyn.F90

    r13970 r13982  
    795795      !!--------------------------------------------------------------------- 
    796796      INTEGER ,                              INTENT(in ) :: kt       ! time step 
    797       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts      ! temperature/salinity 
     797      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(inout) :: pts      ! temperature/salinity 
    798798      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(out) :: puslp    ! zonal isopycnal slopes 
    799799      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(out) :: pvslp    ! meridional isopycnal slopes 

  • NEMO/trunk/src/TOP/TRP/trcadv.F90

    r13286 r13982  
    2222   USE traadv_cen     ! centered scheme           (tra_adv_cen  routine) 
    2323   USE traadv_fct     ! FCT      scheme           (tra_adv_fct  routine) 
     24   USE traadv_fct_lf  ! FCT      scheme           (tra_adv_fct  routine - loop fusion version) 
    2425   USE traadv_mus     ! MUSCL    scheme           (tra_adv_mus  routine) 
     26   USE traadv_mus_lf  ! MUSCL    scheme           (tra_adv_mus  routine - loop fusion version) 
    2527   USE traadv_ubs     ! UBS      scheme           (tra_adv_ubs  routine) 
    2628   USE traadv_qck     ! QUICKEST scheme           (tra_adv_qck  routine) 
    … …  
    124126      ! 
    125127      CASE ( np_CEN )                                 ! Centered : 2nd / 4th order 
     128         IF (nn_hls.EQ.2) CALL lbc_lnk( 'trcadv', ptr(:,:,:,:,Kmm), 'T', 1.) 
    126129         CALL tra_adv_cen( kt, nittrc000,'TRC',          zuu, zvv, zww,      Kmm, ptr, jptra, Krhs, nn_cen_h, nn_cen_v ) 
    127130      CASE ( np_FCT )                                 ! FCT      : 2nd / 4th order 
    128          CALL tra_adv_fct( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, nn_fct_h, nn_fct_v ) 
     131         IF (nn_hls.EQ.2) THEN 
     132            CALL lbc_lnk_multi( 'trcadv', ptr(:,:,:,:,Kbb), 'T', 1., ptr(:,:,:,:,Kmm), 'T', 1.) 
     133            CALL lbc_lnk_multi( 'traadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1., zww(:,:,:), 'W', 1.) 
     134#if defined key_loop_fusion 
     135            CALL tra_adv_fct_lf( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, nn_fct_h, nn_fct_v ) 
     136#else 
     137            CALL tra_adv_fct( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, nn_fct_h, nn_fct_v ) 
     138#endif 
     139         ELSE 
     140            CALL tra_adv_fct( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, nn_fct_h, nn_fct_v ) 
     141         END IF 
    129142      CASE ( np_MUS )                                 ! MUSCL 
    130          CALL tra_adv_mus( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, ln_mus_ups         )  
     143         IF (nn_hls.EQ.2) THEN 
     144            IF (nn_hls.EQ.2) CALL lbc_lnk( 'trcadv', ptr(:,:,:,:,Kbb), 'T', 1.) 
     145#if defined key_loop_fusion 
     146            CALL tra_adv_mus_lf( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, ln_mus_ups )  
     147#else 
     148            CALL tra_adv_mus( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, ln_mus_ups )  
     149#endif 
     150         ELSE 
     151            CALL tra_adv_mus( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, ln_mus_ups )  
     152         END IF 
    131153      CASE ( np_UBS )                                 ! UBS 
     154         IF (nn_hls.EQ.2) CALL lbc_lnk( 'trcadv', ptr(:,:,:,:,Kbb), 'T', 1.) 
    132155         CALL tra_adv_ubs( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, nn_ubs_v           ) 
    133156      CASE ( np_QCK )                                 ! QUICKEST 
     157         IF (nn_hls.EQ.2) THEN 
     158            CALL lbc_lnk_multi( 'trcadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1.) 
     159            CALL lbc_lnk( 'traadv', ptr(:,:,:,:,Kbb), 'T', 1.) 
     160         END IF 
    134161         CALL tra_adv_qck( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs                     ) 
    135162      ! 

  • NEMO/trunk/src/TOP/TRP/trcldf.F90

    r13295 r13982  
    101101           &                     ptr(:,:,:,:,Kbb), ptr(:,:,:,:,Kbb), ptr(:,:,:,:,Krhs), jptra, 1 ) 
    102102      CASE ( np_blp , np_blp_i , np_blp_it )                                                               ! bilaplacian: all operator (iso-level, -neutral) 
     103         IF(nn_hls.EQ.2) CALL lbc_lnk( 'trc_ldf', ptr(:,:,:,:,Kbb), 'T',1.) 
    103104         CALL tra_ldf_blp  ( kt, Kmm, nittrc000,'TRC', zahu, zahv, gtru, gtrv, gtrui, gtrvi,            & 
    104105           &                     ptr(:,:,:,:,Kbb) , ptr(:,:,:,:,Krhs),                 jptra, nldf_trc ) 

  • NEMO/trunk/tests/CANAL/MY_SRC/trazdf.F90

    r13295 r13982  
    5454      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts                 ! active tracers and RHS of tracer equation 
    5555      ! 
    56       INTEGER  ::   jk   ! Dummy loop indices 
     56      INTEGER  ::   ji, jj, jk   ! Dummy loop indices 
    5757      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztrdt, ztrds   ! 3D workspace 
    5858      !!--------------------------------------------------------------------- 
    … …  
    6161      ! 
    6262      IF( kt == nit000 )  THEN 
    63          IF(lwp)WRITE(numout,*) 
    64          IF(lwp)WRITE(numout,*) 'tra_zdf : implicit vertical mixing on T & S' 
    65          IF(lwp)WRITE(numout,*) '~~~~~~~ ' 
     63         IF( ntile == 0 .OR. ntile == 1 )  THEN                   ! Do only on the first tile 
     64            IF(lwp)WRITE(numout,*) 
     65            IF(lwp)WRITE(numout,*) 'tra_zdf : implicit vertical mixing on T & S' 
     66            IF(lwp)WRITE(numout,*) '~~~~~~~ ' 
     67         ENDIF 
    6668      ENDIF 
    6769      ! 
    … …  
    8385 
    8486      IF( l_trdtra )   THEN                      ! save the vertical diffusive trends for further diagnostics 
    85          DO jk = 1, jpkm1 
    86             ztrdt(:,:,jk) = ( ( pts(:,:,jk,jp_tem,Kaa)*e3t(:,:,jk,Kaa) - pts(:,:,jk,jp_tem,Kbb)*e3t(:,:,jk,Kbb) ) & 
    87                &          / (e3t(:,:,jk,Kmm)*rDt) ) - ztrdt(:,:,jk) 
    88             ztrds(:,:,jk) = ( ( pts(:,:,jk,jp_sal,Kaa)*e3t(:,:,jk,Kaa) - pts(:,:,jk,jp_sal,Kbb)*e3t(:,:,jk,Kbb) ) & 
    89               &           / (e3t(:,:,jk,Kmm)*rDt) ) - ztrds(:,:,jk) 
     87         DO jk = 1, jpk 
     88            ztrdt(:,:,jk) = (   (  pts(:,:,jk,jp_tem,Kaa)*e3t(:,:,jk,Kaa)     & 
     89               &                 - pts(:,:,jk,jp_tem,Kbb)*e3t(:,:,jk,Kbb)  )  & 
     90               &              / (  e3t(:,:,jk,Kmm)*rDt  )   )                 & 
     91               &          - ztrdt(:,:,jk) 
     92            ztrds(:,:,jk) = (   (  pts(:,:,jk,jp_sal,Kaa)*e3t(:,:,jk,Kaa)     & 
     93               &                 - pts(:,:,jk,jp_sal,Kbb)*e3t(:,:,jk,Kbb)  )  & 
     94               &             / (   e3t(:,:,jk,Kmm)*rDt  )   )                 & 
     95               &          - ztrds(:,:,jk) 
    9096         END DO 
    9197!!gm this should be moved in trdtra.F90 and done on all trends 
    … …  
    135141      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices 
    136142      REAL(wp) ::  zrhs, zzwi, zzws ! local scalars 
    137       REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zwi, zwt, zwd, zws 
     143      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::  zwi, zwt, zwd, zws 
    138144      !!--------------------------------------------------------------------- 
    139145      ! 
    … …  
    149155            ! 
    150156            ! vertical mixing coef.: avt for temperature, avs for salinity and passive tracers 
    151             IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN   ;   zwt(:,:,2:jpk) = avt(:,:,2:jpk) 
    152             ELSE                                            ;   zwt(:,:,2:jpk) = avs(:,:,2:jpk) 
     157            IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN 
     158               DO_3D( 1, 1, 1, 1, 2, jpk ) 
     159                  zwt(ji,jj,jk) = avt(ji,jj,jk) 
     160               END_3D 
     161            ELSE 
     162               DO_3D( 1, 1, 1, 1, 2, jpk ) 
     163                  zwt(ji,jj,jk) = avs(ji,jj,jk) 
     164               END_3D 
    153165            ENDIF 
    154166            zwt(:,:,1) = 0._wp 

  • NEMO/trunk/tests/ISOMIP+/MY_SRC/dtatsd.F90

    r13583 r13982  
    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   ! 
    … …  
    163164      INTEGER                              , INTENT(in   ) ::   kt     ! ocean time-step 
    164165      CHARACTER(LEN=3)                     , INTENT(in   ) ::   cddta  ! dmp or ini 
    165       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(  out) ::   ptsd   ! T & S data 
     166      REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts), INTENT(  out) ::   ptsd   ! T & S data 
    166167      ! 
    167168      INTEGER ::   ji, jj, jk, jl, jkk   ! dummy loop indicies 
    168169      INTEGER ::   ik, il0, il1, ii0, ii1, ij0, ij1   ! local integers 
     170      INTEGER ::   itile 
    169171      REAL(wp)::   zl, zi                             ! local scalars 
    170172      REAL(wp), DIMENSION(jpk) ::  ztp, zsp   ! 1D workspace 
    171173      !!---------------------------------------------------------------------- 
    172174      ! 
     175      IF( ntile == 0 .OR. ntile == 1 )  THEN                                         ! Do only for the full domain 
     176         itile = ntile 
     177         IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 )            ! Use full domain 
     178 
     179         SELECT CASE(cddta) 
     180         CASE('ini') 
     181            CALL fld_read( kt, 1, sf_tsdini ) !==   read T & S data at kt time step   ==! 
     182         CASE('dmp') 
     183            CALL fld_read( kt, 1, sf_tsddmp ) !==   read T & S data at kt time step   ==! 
     184         CASE DEFAULT 
     185            CALL ctl_stop('STOP', 'dta_tsd: cddta case unknown') 
     186         END SELECT 
     187 
     188         IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = itile )            ! Revert to tile domain 
     189      ENDIF 
     190      ! 
    173191      SELECT CASE(cddta) 
    174       CASE('ini')  
    175          CALL fld_read( kt, 1, sf_tsdini ) !==   read T & S data at kt time step   ==! 
    176          ptsd(:,:,:,jp_tem) = sf_tsdini(jp_tem)%fnow(:,:,:)    ! NO mask 
    177          ptsd(:,:,:,jp_sal) = sf_tsdini(jp_sal)%fnow(:,:,:)  
     192      CASE('ini') 
     193         DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) 
     194            ptsd(ji,jj,jk,jp_tem) = sf_tsdini(jp_tem)%fnow(ji,jj,jk)    ! NO mask 
     195            ptsd(ji,jj,jk,jp_sal) = sf_tsdini(jp_sal)%fnow(ji,jj,jk) 
     196         END_3D 
    178197      CASE('dmp') 
    179          CALL fld_read( kt, 1, sf_tsddmp ) !==   read T & S data at kt time step   ==! 
    180          ptsd(:,:,:,jp_tem) = sf_tsddmp(jp_tem)%fnow(:,:,:)    ! NO mask 
    181          ptsd(:,:,:,jp_sal) = sf_tsddmp(jp_sal)%fnow(:,:,:)  
     198         DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) 
     199            ptsd(ji,jj,jk,jp_tem) = sf_tsddmp(jp_tem)%fnow(ji,jj,jk)    ! NO mask 
     200            ptsd(ji,jj,jk,jp_sal) = sf_tsddmp(jp_sal)%fnow(ji,jj,jk) 
     201         END_3D 
    182202      CASE DEFAULT 
    183203         CALL ctl_stop('STOP', 'dta_tsd: cddta case unknown') 
    … …  
    186206      IF( ln_sco ) THEN                   !==   s- or mixed s-zps-coordinate   ==! 
    187207         ! 
    188          IF( kt == nit000 .AND. lwp )THEN 
    189             WRITE(numout,*) 
    190             WRITE(numout,*) 'dta_tsd: interpolates T & S data onto the s- or mixed s-z-coordinate mesh' 
     208         IF( ntile == 0 .OR. ntile == 1 )  THEN                       ! Do only on the first tile 
     209            IF( kt == nit000 .AND. lwp )THEN 
     210               WRITE(numout,*) 
     211               WRITE(numout,*) 'dta_tsd: interpolates T & S data onto the s- or mixed s-z-coordinate mesh' 
     212            ENDIF 
    191213         ENDIF 
    192214         ! 
    … …  
    220242      ELSE                                !==   z- or zps- coordinate   ==! 
    221243         !                              
    222          ptsd(:,:,:,jp_tem) = ptsd(:,:,:,jp_tem) * tmask(:,:,:)    ! Mask 
    223          ptsd(:,:,:,jp_sal) = ptsd(:,:,:,jp_sal) * tmask(:,:,:) 
     244         DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk ) 
     245            ptsd(ji,jj,jk,jp_tem) = ptsd(ji,jj,jk,jp_tem) * tmask(ji,jj,jk)    ! Mask 
     246            ptsd(ji,jj,jk,jp_sal) = ptsd(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) 
     247         END_3D 
    224248         ! 
    225249         IF( ln_zps ) THEN                      ! zps-coordinate (partial steps) interpolation at the last ocean level 

  • NEMO/trunk/tests/ISOMIP+/MY_SRC/eosbn2.F90

    r13583 r13982  
    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 
    … …  
    191192 
    192193   SUBROUTINE eos_insitu( pts, prd, pdep ) 
     194      !! 
     195      REAL(wp), DIMENSION(:,:,:,:), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celsius] 
     196      !                                                      ! 2 : salinity               [psu] 
     197      REAL(wp), DIMENSION(:,:,:)  , INTENT(  out) ::   prd   ! in situ density            [-] 
     198      REAL(wp), DIMENSION(:,:,:)  , INTENT(in   ) ::   pdep  ! depth                      [m] 
     199      !! 
     200      CALL eos_insitu_t( pts, is_tile(pts), prd, is_tile(prd), pdep, is_tile(pdep) ) 
     201   END SUBROUTINE eos_insitu 
     202 
     203   SUBROUTINE eos_insitu_t( pts, ktts, prd, ktrd, pdep, ktdep ) 
    193204      !!---------------------------------------------------------------------- 
    194205      !!                   ***  ROUTINE eos_insitu  *** 
    … …  
    228239      !!                TEOS-10 Manual, 2010 
    229240      !!---------------------------------------------------------------------- 
    230       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celsius] 
     241      INTEGER                                 , INTENT(in   ) ::   ktts, ktrd, ktdep 
     242      REAL(wp), DIMENSION(A2D_T(ktts) ,JPK,JPTS), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celsius] 
    231243      !                                                               ! 2 : salinity               [psu] 
    232       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prd   ! in situ density            [-] 
    233       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pdep  ! depth                      [m] 
     244      REAL(wp), DIMENSION(A2D_T(ktrd) ,JPK     ), INTENT(  out) ::   prd   ! in situ density            [-] 
     245      REAL(wp), DIMENSION(A2D_T(ktdep),JPK     ), INTENT(in   ) ::   pdep  ! depth                      [m] 
    234246      ! 
    235247      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
    … …  
    312324      IF( ln_timing )   CALL timing_stop('eos-insitu') 
    313325      ! 
    314    END SUBROUTINE eos_insitu 
     326   END SUBROUTINE eos_insitu_t 
    315327 
    316328 
    317329   SUBROUTINE eos_insitu_pot( pts, prd, prhop, pdep ) 
     330      !! 
     331      REAL(wp), DIMENSION(:,:,:,:), INTENT(in   ) ::   pts    ! 1 : potential temperature  [Celsius] 
     332      !                                                       ! 2 : salinity               [psu] 
     333      REAL(wp), DIMENSION(:,:,:)  , INTENT(  out) ::   prd    ! in situ density            [-] 
     334      REAL(wp), DIMENSION(:,:,:)  , INTENT(  out) ::   prhop  ! potential density (surface referenced) 
     335      REAL(wp), DIMENSION(:,:,:)  , INTENT(in   ) ::   pdep   ! depth                      [m] 
     336      !! 
     337      CALL eos_insitu_pot_t( pts, is_tile(pts), prd, is_tile(prd), prhop, is_tile(prhop), pdep, is_tile(pdep) ) 
     338   END SUBROUTINE eos_insitu_pot 
     339 
     340 
     341   SUBROUTINE eos_insitu_pot_t( pts, ktts, prd, ktrd, prhop, ktrhop, pdep, ktdep ) 
    318342      !!---------------------------------------------------------------------- 
    319343      !!                  ***  ROUTINE eos_insitu_pot  *** 
    … …  
    328352      !! 
    329353      !!---------------------------------------------------------------------- 
    330       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts    ! 1 : potential temperature  [Celsius] 
     354      INTEGER                                  , INTENT(in   ) ::   ktts, ktrd, ktrhop, ktdep 
     355      REAL(wp), DIMENSION(A2D_T(ktts)  ,JPK,JPTS), INTENT(in   ) ::   pts    ! 1 : potential temperature  [Celsius] 
    331356      !                                                                ! 2 : salinity               [psu] 
    332       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prd    ! in situ density            [-] 
    333       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prhop  ! potential density (surface referenced) 
    334       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pdep   ! depth                      [m] 
     357      REAL(wp), DIMENSION(A2D_T(ktrd)  ,JPK     ), INTENT(  out) ::   prd    ! in situ density            [-] 
     358      REAL(wp), DIMENSION(A2D_T(ktrhop),JPK     ), INTENT(  out) ::   prhop  ! potential density (surface referenced) 
     359      REAL(wp), DIMENSION(A2D_T(ktdep) ,JPK     ), INTENT(in   ) ::   pdep   ! depth                      [m] 
    335360      ! 
    336361      INTEGER  ::   ji, jj, jk, jsmp             ! dummy loop indices 
    … …  
    482507      IF( ln_timing )   CALL timing_stop('eos-pot') 
    483508      ! 
    484    END SUBROUTINE eos_insitu_pot 
     509   END SUBROUTINE eos_insitu_pot_t 
    485510 
    486511 
    487512   SUBROUTINE eos_insitu_2d( pts, pdep, prd ) 
     513      !! 
     514      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celsius] 
     515      !                                                    ! 2 : salinity               [psu] 
     516      REAL(wp), DIMENSION(:,:)  , INTENT(in   ) ::   pdep  ! depth                      [m] 
     517      REAL(wp), DIMENSION(:,:)  , INTENT(  out) ::   prd   ! in situ density 
     518      !! 
     519      CALL eos_insitu_2d_t( pts, is_tile(pts), pdep, is_tile(pdep), prd, is_tile(prd) ) 
     520   END SUBROUTINE eos_insitu_2d 
     521 
     522 
     523   SUBROUTINE eos_insitu_2d_t( pts, ktts, pdep, ktdep, prd, ktrd ) 
    488524      !!---------------------------------------------------------------------- 
    489525      !!                  ***  ROUTINE eos_insitu_2d  *** 
    … …  
    496532      !! 
    497533      !!---------------------------------------------------------------------- 
    498       REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celsius] 
     534      INTEGER                            , INTENT(in   ) ::   ktts, ktdep, ktrd 
     535      REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celsius] 
    499536      !                                                           ! 2 : salinity               [psu] 
    500       REAL(wp), DIMENSION(jpi,jpj)     , INTENT(in   ) ::   pdep  ! depth                      [m] 
    501       REAL(wp), DIMENSION(jpi,jpj)     , INTENT(  out) ::   prd   ! in situ density 
     537      REAL(wp), DIMENSION(A2D_T(ktdep)    ), INTENT(in   ) ::   pdep  ! depth                      [m] 
     538      REAL(wp), DIMENSION(A2D_T(ktrd)     ), INTENT(  out) ::   prd   ! in situ density 
    502539      ! 
    503540      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
    … …  
    584621      IF( ln_timing )   CALL timing_stop('eos2d') 
    585622      ! 
    586    END SUBROUTINE eos_insitu_2d 
     623   END SUBROUTINE eos_insitu_2d_t 
    587624 
    588625 
    589626   SUBROUTINE rab_3d( pts, pab, Kmm ) 
     627      !! 
     628      INTEGER                     , INTENT(in   ) ::   Kmm   ! time level index 
     629      REAL(wp), DIMENSION(:,:,:,:), INTENT(in   ) ::   pts   ! pot. temperature & salinity 
     630      REAL(wp), DIMENSION(:,:,:,:), INTENT(  out) ::   pab   ! thermal/haline expansion ratio 
     631      !! 
     632      CALL rab_3d_t( pts, is_tile(pts), pab, is_tile(pab), Kmm ) 
     633   END SUBROUTINE rab_3d 
     634 
     635 
     636   SUBROUTINE rab_3d_t( pts, ktts, pab, ktab, Kmm ) 
    590637      !!---------------------------------------------------------------------- 
    591638      !!                 ***  ROUTINE rab_3d  *** 
    … …  
    598645      !!---------------------------------------------------------------------- 
    599646      INTEGER                              , INTENT(in   ) ::   Kmm   ! time level index 
    600       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts   ! pot. temperature & salinity 
    601       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(  out) ::   pab   ! thermal/haline expansion ratio 
     647      INTEGER                                , INTENT(in   ) ::   ktts, ktab 
     648      REAL(wp), DIMENSION(A2D_T(ktts),JPK,JPTS), INTENT(in   ) ::   pts   ! pot. temperature & salinity 
     649      REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT(  out) ::   pab   ! thermal/haline expansion ratio 
    602650      ! 
    603651      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
    … …  
    706754      IF( ln_timing )   CALL timing_stop('rab_3d') 
    707755      ! 
    708    END SUBROUTINE rab_3d 
     756   END SUBROUTINE rab_3d_t 
    709757 
    710758 
    711759   SUBROUTINE rab_2d( pts, pdep, pab, Kmm ) 
     760      !! 
     761      INTEGER                   , INTENT(in   ) ::   Kmm   ! time level index 
     762      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pts    ! pot. temperature & salinity 
     763      REAL(wp), DIMENSION(:,:)  , INTENT(in   ) ::   pdep   ! depth                  [m] 
     764      REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   pab    ! thermal/haline expansion ratio 
     765      !! 
     766      CALL rab_2d_t(pts, is_tile(pts), pdep, is_tile(pdep), pab, is_tile(pab), Kmm) 
     767   END SUBROUTINE rab_2d 
     768 
     769 
     770   SUBROUTINE rab_2d_t( pts, ktts, pdep, ktdep, pab, ktab, Kmm ) 
    712771      !!---------------------------------------------------------------------- 
    713772      !!                 ***  ROUTINE rab_2d  *** 
    … …  
    718777      !!---------------------------------------------------------------------- 
    719778      INTEGER                              , INTENT(in   ) ::   Kmm   ! time level index 
    720       REAL(wp), DIMENSION(jpi,jpj,jpts)    , INTENT(in   ) ::   pts    ! pot. temperature & salinity 
    721       REAL(wp), DIMENSION(jpi,jpj)         , INTENT(in   ) ::   pdep   ! depth                  [m] 
    722       REAL(wp), DIMENSION(jpi,jpj,jpts)    , INTENT(  out) ::   pab    ! thermal/haline expansion ratio 
     779      INTEGER                            , INTENT(in   ) ::   ktts, ktdep, ktab 
     780      REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in   ) ::   pts    ! pot. temperature & salinity 
     781      REAL(wp), DIMENSION(A2D_T(ktdep)    ), INTENT(in   ) ::   pdep   ! depth                  [m] 
     782      REAL(wp), DIMENSION(A2D_T(ktab),JPTS), INTENT(  out) ::   pab    ! thermal/haline expansion ratio 
    723783      ! 
    724784      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
    … …  
    829889      IF( ln_timing )   CALL timing_stop('rab_2d') 
    830890      ! 
    831    END SUBROUTINE rab_2d 
     891   END SUBROUTINE rab_2d_t 
    832892 
    833893 
    … …  
    9421002 
    9431003   SUBROUTINE bn2( pts, pab, pn2, Kmm ) 
     1004      !! 
     1005      INTEGER                              , INTENT(in   ) ::  Kmm   ! time level index 
     1006      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::  pts   ! pot. temperature and salinity   [Celsius,psu] 
     1007      REAL(wp), DIMENSION(:,:,:,:)         , INTENT(in   ) ::  pab   ! thermal/haline expansion coef.  [Celsius-1,psu-1] 
     1008      REAL(wp), DIMENSION(:,:,:)           , INTENT(  out) ::  pn2   ! Brunt-Vaisala frequency squared [1/s^2] 
     1009      !! 
     1010      CALL bn2_t( pts, pab, is_tile(pab), pn2, is_tile(pn2), Kmm ) 
     1011   END SUBROUTINE bn2 
     1012 
     1013 
     1014   SUBROUTINE bn2_t( pts, pab, ktab, pn2, ktn2, Kmm ) 
    9441015      !!---------------------------------------------------------------------- 
    9451016      !!                  ***  ROUTINE bn2  *** 
    … …  
    9561027      !!---------------------------------------------------------------------- 
    9571028      INTEGER                              , INTENT(in   ) ::   Kmm   ! time level index 
     1029      INTEGER                                , INTENT(in   ) ::  ktab, ktn2 
    9581030      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::  pts   ! pot. temperature and salinity   [Celsius,psu] 
    959       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::  pab   ! thermal/haline expansion coef.  [Celsius-1,psu-1] 
    960       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::  pn2   ! Brunt-Vaisala frequency squared [1/s^2] 
     1031      REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT(in   ) ::  pab   ! thermal/haline expansion coef.  [Celsius-1,psu-1] 
     1032      REAL(wp), DIMENSION(A2D_T(ktn2),JPK     ), INTENT(  out) ::  pn2   ! Brunt-Vaisala frequency squared [1/s^2] 
    9611033      ! 
    9621034      INTEGER  ::   ji, jj, jk      ! dummy loop indices 
    … …  
    9821054      IF( ln_timing )   CALL timing_stop('bn2') 
    9831055      ! 
    984    END SUBROUTINE bn2 
     1056   END SUBROUTINE bn2_t 
    9851057 
    9861058 
    … …  
    10431115 
    10441116   SUBROUTINE  eos_fzp_2d( psal, ptf, pdep ) 
     1117      !! 
     1118      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   )           ::   psal   ! salinity   [psu] 
     1119      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ), OPTIONAL ::   pdep   ! depth      [m] 
     1120      REAL(wp), DIMENSION(:,:)    , INTENT(out  )           ::   ptf    ! freezing temperature [Celsius] 
     1121      !! 
     1122      CALL eos_fzp_2d_t( psal, ptf, is_tile(ptf), pdep ) 
     1123   END SUBROUTINE eos_fzp_2d 
     1124 
     1125 
     1126   SUBROUTINE  eos_fzp_2d_t( psal, ptf, kttf, pdep ) 
    10451127      !!---------------------------------------------------------------------- 
    10461128      !!                 ***  ROUTINE eos_fzp  *** 
    … …  
    10541136      !! Reference  :   UNESCO tech. papers in the marine science no. 28. 1978 
    10551137      !!---------------------------------------------------------------------- 
     1138      INTEGER                       , INTENT(in   )           ::   kttf 
    10561139      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   )           ::   psal   ! salinity   [psu] 
    10571140      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ), OPTIONAL ::   pdep   ! depth      [m] 
    1058       REAL(wp), DIMENSION(jpi,jpj), INTENT(out  )           ::   ptf    ! freezing temperature [Celsius] 
     1141      REAL(wp), DIMENSION(A2D_T(kttf)), INTENT(out  )           ::   ptf    ! freezing temperature [Celsius] 
    10591142      ! 
    10601143      INTEGER  ::   ji, jj          ! dummy loop indices 
    … …  
    10891172      END SELECT       
    10901173      ! 
    1091   END SUBROUTINE eos_fzp_2d 
     1174  END SUBROUTINE eos_fzp_2d_t 
    10921175 
    10931176 

  • NEMO/trunk/tests/ISOMIP+/MY_SRC/tradmp.F90

    r13295 r13982  
    9595      ! 
    9696      INTEGER ::   ji, jj, jk, jn   ! dummy loop indices 
    97       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts)     ::  zts_dta 
     97      REAL(wp), DIMENSION(A2D(nn_hls),jpk,jpts)     ::  zts_dta 
    9898      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::  ztrdts 
    9999      !!---------------------------------------------------------------------- 
Note: See TracChangeset for help on using the changeset viewer.