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 14012 for NEMO/branches/2020/tickets_icb_1900/src/OCE – NEMO

Ignore:
Timestamp:
2020-12-02T16:13:45+01:00 (4 years ago)
Author:
mathiot
Message:

ticket 1900: upgrade branch to 13991 before the next upgrade

Location:
NEMO/branches/2020/tickets_icb_1900
Files:
73 edited
4 copied

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2020/tickets_icb_1900

    • Property svn:externals

      •  

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

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/ASM/asminc.F90

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

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/BDY/bdytra.F90

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

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/C1D/step_c1d.F90

    r13237 r14012  
    122122                        CALL dyn_atf    ( kstp, Nbb, Nnn, Naa , uu, vv, e3t, e3u, e3v )  ! time filtering of "now" fields 
    123123      IF(.NOT.ln_linssh)CALL ssh_atf    ( kstp, Nbb, Nnn, Naa , ssh )                    ! time filtering of "now" sea surface height 
     124      IF( kstp == nit000 .AND. ln_linssh) THEN 
     125         ssh(:,:,Naa) = ssh(:,:,Nnn)  ! init ssh after in ln_linssh case 
     126      ENDIF 
    124127      ! 
    125128      ! Swap time levels 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/DIA/diaar5.F90

    r13899 r14012  
    3434   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:  ) ::   thick0       ! ocean thickness (interior domain) 
    3535   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   sn0          ! initial salinity 
     36   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   hstr_adv, hstr_ldf 
    3637 
    3738   LOGICAL  :: l_ar5 
    … …  
    5455      !!---------------------------------------------------------------------- 
    5556      ! 
    56       ALLOCATE( thick0(jpi,jpj) , sn0(jpi,jpj,jpk) , STAT=dia_ar5_alloc ) 
     57      ALLOCATE( thick0(jpi,jpj) , sn0(jpi,jpj,jpk) , & 
     58         &      hstr_adv(jpi,jpj,jpts,2), hstr_ldf(jpi,jpj,jpts,2), STAT=dia_ar5_alloc ) 
    5759      ! 
    5860      CALL mpp_sum ( 'diaar5', dia_ar5_alloc ) 
    … …  
    304306   END SUBROUTINE dia_ar5 
    305307 
    306  
    307    SUBROUTINE dia_ar5_hst( ktra, cptr, puflx, pvflx )  
     308   ! TEMP: [tiling] These changes not necessary if using XIOS (subdomain support, will not output haloes) 
     309   SUBROUTINE dia_ar5_hst( ktra, cptr, puflx, pvflx ) 
    308310      !!---------------------------------------------------------------------- 
    309311      !!                    ***  ROUTINE dia_ar5_htr *** 
    … …  
    314316      INTEGER                         , INTENT(in )  :: ktra  ! tracer index 
    315317      CHARACTER(len=3)                , INTENT(in)   :: cptr  ! transport type  'adv'/'ldf' 
    316       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)   :: puflx  ! u-flux of advection/diffusion 
    317       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)   :: pvflx  ! v-flux of advection/diffusion 
     318      REAL(wp), DIMENSION(A2D(nn_hls),jpk)    , INTENT(in)   :: puflx  ! u-flux of advection/diffusion 
     319      REAL(wp), DIMENSION(A2D(nn_hls),jpk)    , INTENT(in)   :: pvflx  ! v-flux of advection/diffusion 
    318320      ! 
    319321      INTEGER    ::  ji, jj, jk 
    320       REAL(wp), DIMENSION(jpi,jpj)  :: z2d 
    321  
     322 
     323      IF( cptr /= 'adv' .AND. cptr /= 'ldf' ) RETURN 
     324      IF( ktra /= jp_tem .AND. ktra /= jp_sal ) RETURN 
     325 
     326      IF( cptr == 'adv' ) THEN 
     327         DO_2D( 0, 0, 0, 0 ) 
     328            hstr_adv(ji,jj,ktra,1) = puflx(ji,jj,1) 
     329            hstr_adv(ji,jj,ktra,2) = pvflx(ji,jj,1) 
     330         END_2D 
     331         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     332            hstr_adv(ji,jj,ktra,1) = hstr_adv(ji,jj,ktra,1) + puflx(ji,jj,jk) 
     333            hstr_adv(ji,jj,ktra,2) = hstr_adv(ji,jj,ktra,2) + pvflx(ji,jj,jk) 
     334         END_3D 
     335      ELSE IF( cptr == 'ldf' ) THEN 
     336         DO_2D( 0, 0, 0, 0 ) 
     337            hstr_ldf(ji,jj,ktra,1) = puflx(ji,jj,1) 
     338            hstr_ldf(ji,jj,ktra,2) = pvflx(ji,jj,1) 
     339         END_2D 
     340         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     341            hstr_ldf(ji,jj,ktra,1) = hstr_ldf(ji,jj,ktra,1) + puflx(ji,jj,jk) 
     342            hstr_ldf(ji,jj,ktra,2) = hstr_ldf(ji,jj,ktra,2) + pvflx(ji,jj,jk) 
     343         END_3D 
     344      ENDIF 
     345 
     346      IF( ntile == 0 .OR. ntile == nijtile ) THEN 
     347         IF( cptr == 'adv' ) THEN 
     348            IF( ktra == jp_tem ) CALL iom_put( 'uadv_heattr' , rho0_rcp * hstr_adv(:,:,ktra,1) )  ! advective heat transport in i-direction 
     349            IF( ktra == jp_sal ) CALL iom_put( 'uadv_salttr' , rho0     * hstr_adv(:,:,ktra,1) )  ! advective salt transport in i-direction 
     350            IF( ktra == jp_tem ) CALL iom_put( 'vadv_heattr' , rho0_rcp * hstr_adv(:,:,ktra,2) )  ! advective heat transport in j-direction 
     351            IF( ktra == jp_sal ) CALL iom_put( 'vadv_salttr' , rho0     * hstr_adv(:,:,ktra,2) )  ! advective salt transport in j-direction 
     352         ENDIF 
     353         IF( cptr == 'ldf' ) THEN 
     354            IF( ktra == jp_tem ) CALL iom_put( 'udiff_heattr' , rho0_rcp * hstr_ldf(:,:,ktra,1) ) ! diffusive heat transport in i-direction 
     355            IF( ktra == jp_sal ) CALL iom_put( 'udiff_salttr' , rho0     * hstr_ldf(:,:,ktra,1) ) ! diffusive salt transport in i-direction 
     356            IF( ktra == jp_tem ) CALL iom_put( 'vdiff_heattr' , rho0_rcp * hstr_ldf(:,:,ktra,2) ) ! diffusive heat transport in j-direction 
     357            IF( ktra == jp_sal ) CALL iom_put( 'vdiff_salttr' , rho0     * hstr_ldf(:,:,ktra,2) ) ! diffusive salt transport in j-direction 
     358         ENDIF 
     359      ENDIF 
    322360     
    323       z2d(:,:) = puflx(:,:,1)  
    324       DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
    325          z2d(ji,jj) = z2d(ji,jj) + puflx(ji,jj,jk)  
    326       END_3D 
    327        CALL lbc_lnk( 'diaar5', z2d, 'U', -1.0_wp ) 
    328        IF( cptr == 'adv' ) THEN 
    329           IF( ktra == jp_tem ) CALL iom_put( 'uadv_heattr' , rho0_rcp * z2d )  ! advective heat transport in i-direction 
    330           IF( ktra == jp_sal ) CALL iom_put( 'uadv_salttr' , rho0     * z2d )  ! advective salt transport in i-direction 
    331        ENDIF 
    332        IF( cptr == 'ldf' ) THEN 
    333           IF( ktra == jp_tem ) CALL iom_put( 'udiff_heattr' , rho0_rcp * z2d ) ! diffusive heat transport in i-direction 
    334           IF( ktra == jp_sal ) CALL iom_put( 'udiff_salttr' , rho0     * z2d ) ! diffusive salt transport in i-direction 
    335        ENDIF 
    336        ! 
    337        z2d(:,:) = pvflx(:,:,1)  
    338        DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
    339           z2d(ji,jj) = z2d(ji,jj) + pvflx(ji,jj,jk)  
    340        END_3D 
    341        CALL lbc_lnk( 'diaar5', z2d, 'V', -1.0_wp ) 
    342        IF( cptr == 'adv' ) THEN 
    343           IF( ktra == jp_tem ) CALL iom_put( 'vadv_heattr' , rho0_rcp * z2d )  ! advective heat transport in j-direction 
    344           IF( ktra == jp_sal ) CALL iom_put( 'vadv_salttr' , rho0     * z2d )  ! advective salt transport in j-direction 
    345        ENDIF 
    346        IF( cptr == 'ldf' ) THEN 
    347           IF( ktra == jp_tem ) CALL iom_put( 'vdiff_heattr' , rho0_rcp * z2d ) ! diffusive heat transport in j-direction 
    348           IF( ktra == jp_sal ) CALL iom_put( 'vdiff_salttr' , rho0     * z2d ) ! diffusive salt transport in j-direction 
    349        ENDIF 
    350            
    351361   END SUBROUTINE dia_ar5_hst 
    352362 
    … …  
    371381         &  iom_use( 'masstot' ) .OR. iom_use( 'temptot'   )  .OR. iom_use( 'saltot' ) .OR.  &     
    372382         &  iom_use( 'botpres' ) .OR. iom_use( 'sshthster' )  .OR. iom_use( 'sshsteric' ) .OR. & 
     383         &  iom_use( 'uadv_heattr' ) .OR. iom_use( 'udiff_heattr' ) .OR. & 
     384         &  iom_use( 'uadv_salttr' ) .OR. iom_use( 'udiff_salttr' ) .OR. & 
     385         &  iom_use( 'vadv_heattr' ) .OR. iom_use( 'vdiff_heattr' ) .OR. & 
     386         &  iom_use( 'vadv_salttr' ) .OR. iom_use( 'vdiff_salttr' ) .OR. & 
    373387         &  iom_use( 'rhop' )  ) L_ar5 = .TRUE. 
    374388   

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/DIA/diahsb.F90

    r13899 r14012  
    267267            IF(lwp) WRITE(numout,*) '   dia_hsb_rst : read hsb restart at it= ', kt,' date= ', ndastp 
    268268            IF(lwp) WRITE(numout,*) 
    269             CALL iom_get( numror, 'frc_v', frc_v, ldxios = lrxios ) 
    270             CALL iom_get( numror, 'frc_t', frc_t, ldxios = lrxios ) 
    271             CALL iom_get( numror, 'frc_s', frc_s, ldxios = lrxios ) 
     269            CALL iom_get( numror, 'frc_v', frc_v ) 
     270            CALL iom_get( numror, 'frc_t', frc_t ) 
     271            CALL iom_get( numror, 'frc_s', frc_s ) 
    272272            IF( ln_linssh ) THEN 
    273                CALL iom_get( numror, 'frc_wn_t', frc_wn_t, ldxios = lrxios ) 
    274                CALL iom_get( numror, 'frc_wn_s', frc_wn_s, ldxios = lrxios ) 
     273               CALL iom_get( numror, 'frc_wn_t', frc_wn_t ) 
     274               CALL iom_get( numror, 'frc_wn_s', frc_wn_s ) 
    275275            ENDIF 
    276             CALL iom_get( numror, jpdom_auto, 'surf_ini'  , surf_ini  , ldxios = lrxios ) ! ice sheet coupling 
    277             CALL iom_get( numror, jpdom_auto, 'ssh_ini'   , ssh_ini   , ldxios = lrxios ) 
    278             CALL iom_get( numror, jpdom_auto, 'e3t_ini'   , e3t_ini   , ldxios = lrxios ) 
    279             CALL iom_get( numror, jpdom_auto, 'tmask_ini' , tmask_ini , ldxios = lrxios ) 
    280             CALL iom_get( numror, jpdom_auto, 'hc_loc_ini', hc_loc_ini, ldxios = lrxios ) 
    281             CALL iom_get( numror, jpdom_auto, 'sc_loc_ini', sc_loc_ini, ldxios = lrxios ) 
     276            CALL iom_get( numror, jpdom_auto, 'surf_ini'  , surf_ini  ) ! ice sheet coupling 
     277            CALL iom_get( numror, jpdom_auto, 'ssh_ini'   , ssh_ini    ) 
     278            CALL iom_get( numror, jpdom_auto, 'e3t_ini'   , e3t_ini    ) 
     279            CALL iom_get( numror, jpdom_auto, 'tmask_ini' , tmask_ini ) 
     280            CALL iom_get( numror, jpdom_auto, 'hc_loc_ini', hc_loc_ini ) 
     281            CALL iom_get( numror, jpdom_auto, 'sc_loc_ini', sc_loc_ini ) 
    282282            IF( ln_linssh ) THEN 
    283                CALL iom_get( numror, jpdom_auto, 'ssh_hc_loc_ini', ssh_hc_loc_ini, ldxios = lrxios ) 
    284                CALL iom_get( numror, jpdom_auto, 'ssh_sc_loc_ini', ssh_sc_loc_ini, ldxios = lrxios ) 
     283               CALL iom_get( numror, jpdom_auto, 'ssh_hc_loc_ini', ssh_hc_loc_ini ) 
     284               CALL iom_get( numror, jpdom_auto, 'ssh_sc_loc_ini', ssh_sc_loc_ini ) 
    285285            ENDIF 
    286286         ELSE 
    … …  
    323323         IF(lwp) WRITE(numout,*) 
    324324         ! 
    325          IF( lwxios ) CALL iom_swap(      cwxios_context          ) 
    326          CALL iom_rstput( kt, nitrst, numrow, 'frc_v', frc_v, ldxios = lwxios ) 
    327          CALL iom_rstput( kt, nitrst, numrow, 'frc_t', frc_t, ldxios = lwxios ) 
    328          CALL iom_rstput( kt, nitrst, numrow, 'frc_s', frc_s, ldxios = lwxios ) 
     325         CALL iom_rstput( kt, nitrst, numrow, 'frc_v', frc_v ) 
     326         CALL iom_rstput( kt, nitrst, numrow, 'frc_t', frc_t ) 
     327         CALL iom_rstput( kt, nitrst, numrow, 'frc_s', frc_s ) 
    329328         IF( ln_linssh ) THEN 
    330             CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_t', frc_wn_t, ldxios = lwxios ) 
    331             CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_s', frc_wn_s, ldxios = lwxios ) 
     329            CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_t', frc_wn_t ) 
     330            CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_s', frc_wn_s ) 
    332331         ENDIF 
    333          CALL iom_rstput( kt, nitrst, numrow, 'surf_ini'  , surf_ini  , ldxios = lwxios )      ! ice sheet coupling 
    334          CALL iom_rstput( kt, nitrst, numrow, 'ssh_ini'   , ssh_ini   , ldxios = lwxios ) 
    335          CALL iom_rstput( kt, nitrst, numrow, 'e3t_ini'   , e3t_ini   , ldxios = lwxios ) 
    336          CALL iom_rstput( kt, nitrst, numrow, 'tmask_ini' , tmask_ini , ldxios = lwxios ) 
    337          CALL iom_rstput( kt, nitrst, numrow, 'hc_loc_ini', hc_loc_ini, ldxios = lwxios ) 
    338          CALL iom_rstput( kt, nitrst, numrow, 'sc_loc_ini', sc_loc_ini, ldxios = lwxios ) 
     332         CALL iom_rstput( kt, nitrst, numrow, 'surf_ini'  , surf_ini  )      ! ice sheet coupling 
     333         CALL iom_rstput( kt, nitrst, numrow, 'ssh_ini'   , ssh_ini    ) 
     334         CALL iom_rstput( kt, nitrst, numrow, 'e3t_ini'   , e3t_ini    ) 
     335         CALL iom_rstput( kt, nitrst, numrow, 'tmask_ini' , tmask_ini ) 
     336         CALL iom_rstput( kt, nitrst, numrow, 'hc_loc_ini', hc_loc_ini ) 
     337         CALL iom_rstput( kt, nitrst, numrow, 'sc_loc_ini', sc_loc_ini ) 
    339338         IF( ln_linssh ) THEN 
    340             CALL iom_rstput( kt, nitrst, numrow, 'ssh_hc_loc_ini', ssh_hc_loc_ini, ldxios = lwxios ) 
    341             CALL iom_rstput( kt, nitrst, numrow, 'ssh_sc_loc_ini', ssh_sc_loc_ini, ldxios = lwxios ) 
     339            CALL iom_rstput( kt, nitrst, numrow, 'ssh_hc_loc_ini', ssh_hc_loc_ini ) 
     340            CALL iom_rstput( kt, nitrst, numrow, 'ssh_sc_loc_ini', ssh_sc_loc_ini ) 
    342341         ENDIF 
    343          IF( lwxios ) CALL iom_swap(      cxios_context          ) 
    344342         ! 
    345343      ENDIF 
    … …  
    385383      IF( .NOT. ln_diahsb )   RETURN 
    386384 
    387       IF(lwxios) THEN 
    388 ! define variables in restart file when writing with XIOS 
    389         CALL iom_set_rstw_var_active('frc_v') 
    390         CALL iom_set_rstw_var_active('frc_t') 
    391         CALL iom_set_rstw_var_active('frc_s') 
    392         CALL iom_set_rstw_var_active('surf_ini') 
    393         CALL iom_set_rstw_var_active('ssh_ini') 
    394         CALL iom_set_rstw_var_active('e3t_ini') 
    395         CALL iom_set_rstw_var_active('hc_loc_ini') 
    396         CALL iom_set_rstw_var_active('sc_loc_ini') 
    397         IF( ln_linssh ) THEN 
    398            CALL iom_set_rstw_var_active('ssh_hc_loc_ini') 
    399            CALL iom_set_rstw_var_active('ssh_sc_loc_ini') 
    400            CALL iom_set_rstw_var_active('frc_wn_t') 
    401            CALL iom_set_rstw_var_active('frc_wn_s') 
    402         ENDIF 
    403       ENDIF 
    404385      ! ------------------- ! 
    405386      ! 1 - Allocate memory ! 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/DIA/diaptr.F90

    r13899 r14012  
    2222   USE oce              ! ocean dynamics and active tracers 
    2323   USE dom_oce          ! ocean space and time domain 
     24   USE domain, ONLY : dom_tile 
    2425   USE phycst           ! physical constants 
    2526   ! 
    … …  
    3233   PRIVATE 
    3334 
     35   INTERFACE ptr_sum 
     36      MODULE PROCEDURE ptr_sum_3d, ptr_sum_2d 
     37   END INTERFACE 
     38 
    3439   INTERFACE ptr_sj 
    3540      MODULE PROCEDURE ptr_sj_3d, ptr_sj_2d 
    … …  
    3944   PUBLIC   dia_ptr_hst    ! called from tra_ldf/tra_adv routines 
    4045 
    41    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   hstr_adv, hstr_ldf, hstr_eiv   !: Heat/Salt TRansports(adv, diff, Bolus.) 
    42    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   hstr_ove, hstr_btr, hstr_vtr   !: heat Salt TRansports(overturn, baro, merional) 
    43  
    44    LOGICAL, PUBLIC ::   l_diaptr       !: tracers  trend flag 
     46   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   hstr_adv, hstr_ldf, hstr_eiv   !: Heat/Salt TRansports(adv, diff, Bolus.) 
     47   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   hstr_ove, hstr_btr, hstr_vtr   !: heat Salt TRansports(overturn, baro, merional) 
     48   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   pvtr_int, pzon_int             !: Other zonal integrals 
     49 
     50   LOGICAL, PUBLIC    ::   l_diaptr       !: tracers  trend flag 
     51   INTEGER, PARAMETER ::   jp_msk = 3 
     52   INTEGER, PARAMETER ::   jp_vtr = 4 
    4553 
    4654   REAL(wp) ::   rc_sv    = 1.e-6_wp   ! conversion from m3/s to Sverdrup 
    … …  
    5159   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk34 ! mask out Southern Ocean (=0 south of 34°S) 
    5260 
    53    REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:)   :: p_fval1d 
    54    REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:) :: p_fval2d 
    55  
    5661   LOGICAL ::   ll_init = .TRUE.        !: tracers  trend flag 
    57     
     62 
    5863   !! * Substitutions 
    5964#  include "do_loop_substitute.h90" 
    … …  
    7277      INTEGER                         , INTENT(in)           ::   kt     ! ocean time-step index      
    7378      INTEGER                         , INTENT(in)           ::   Kmm    ! time level index 
    74       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL ::   pvtr   ! j-effective transport 
     79      REAL(wp), DIMENSION(A2D(nn_hls),jpk)    , INTENT(in), OPTIONAL ::   pvtr   ! j-effective transport 
     80      !!---------------------------------------------------------------------- 
     81      ! 
     82      IF( ln_timing )   CALL timing_start('dia_ptr') 
     83 
     84      IF( kt == nit000 .AND. ll_init )   CALL dia_ptr_init    ! -> will define l_diaptr and nbasin 
     85      ! 
     86      IF( l_diaptr ) THEN 
     87         ! Calculate zonal integrals 
     88         IF( PRESENT( pvtr ) ) THEN 
     89            CALL dia_ptr_zint( Kmm, pvtr ) 
     90         ELSE 
     91            CALL dia_ptr_zint( Kmm ) 
     92         ENDIF 
     93 
     94         ! Calculate diagnostics only when zonal integrals have finished 
     95         IF( ntile == 0 .OR. ntile == nijtile ) CALL dia_ptr_iom(kt, Kmm, pvtr) 
     96      ENDIF 
     97 
     98      IF( ln_timing )   CALL timing_stop('dia_ptr') 
     99      ! 
     100   END SUBROUTINE dia_ptr 
     101 
     102 
     103   SUBROUTINE dia_ptr_iom( kt, Kmm, pvtr ) 
     104      !!---------------------------------------------------------------------- 
     105      !!                  ***  ROUTINE dia_ptr_iom  *** 
     106      !!---------------------------------------------------------------------- 
     107      !! ** Purpose : Calculate diagnostics and send to XIOS 
     108      !!---------------------------------------------------------------------- 
     109      INTEGER                         , INTENT(in)           ::   kt     ! ocean time-step index 
     110      INTEGER                         , INTENT(in)           ::   Kmm    ! time level index 
     111      REAL(wp), DIMENSION(A2D(nn_hls),jpk)    , INTENT(in), OPTIONAL ::   pvtr   ! j-effective transport 
    75112      ! 
    76113      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    77       REAL(wp) ::   zsfc,zvfc               ! local scalar 
    78114      REAL(wp), DIMENSION(jpi,jpj)     ::  z2d   ! 2D workspace 
    79       REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zmask   ! 3D workspace 
    80       REAL(wp), DIMENSION(jpi,jpj,jpk) ::  z3d    ! 3D workspace 
    81       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) ::  zts   ! 3D workspace 
    82115      REAL(wp), DIMENSION(jpj)      ::  zvsum, ztsum, zssum   ! 1D workspace 
    83116      ! 
    … …  
    90123      !!---------------------------------------------------------------------- 
    91124      ! 
    92       IF( ln_timing )   CALL timing_start('dia_ptr') 
    93  
    94       IF( kt == nit000 .AND. ll_init )   CALL dia_ptr_init   ! -> will define l_diaptr and nbasin 
    95       ! 
    96       IF( .NOT. l_diaptr ) THEN 
    97          IF( ln_timing ) CALL timing_stop('dia_ptr') 
    98          RETURN 
    99       ENDIF 
    100       ! 
    101125      ALLOCATE( z3dtr(jpi,jpj,nbasin) ) 
    102       ! 
     126 
    103127      IF( PRESENT( pvtr ) ) THEN 
    104128         IF( iom_use( 'zomsf' ) ) THEN    ! effective MSF 
    105129            ALLOCATE( z4d1(jpi,jpj,jpk,nbasin) ) 
     130            ! 
    106131            DO jn = 1, nbasin                                    ! by sub-basins 
    107                z4d1(1,:,:,jn) =  ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) )  ! zonal cumulative effective transport excluding closed seas 
    108                DO jk = jpkm1, 1, -1  
     132               z4d1(1,:,:,jn) =  pvtr_int(:,:,jp_vtr,jn)                  ! zonal cumulative effective transport excluding closed seas 
     133               DO jk = jpkm1, 1, -1 
    109134                  z4d1(1,:,jk,jn) = z4d1(1,:,jk+1,jn) - z4d1(1,:,jk,jn)    ! effective j-Stream-Function (MSF) 
    110135               END DO 
    111                DO ji = 1, jpi 
     136               DO ji = 2, jpi 
    112137                  z4d1(ji,:,:,jn) = z4d1(1,:,:,jn) 
    113138               ENDDO 
    114139            END DO 
    115140            CALL iom_put( 'zomsf', z4d1 * rc_sv ) 
     141            ! 
    116142            DEALLOCATE( z4d1 ) 
    117143         ENDIF 
     144         IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN 
     145            ALLOCATE( sjk(jpj,jpk,nbasin), r1_sjk(jpj,jpk,nbasin), v_msf(jpj,jpk,nbasin),   & 
     146               &      zt_jk(jpj,jpk,nbasin), zs_jk(jpj,jpk,nbasin) ) 
     147            ! 
     148            DO jn = 1, nbasin 
     149               sjk(:,:,jn) = pvtr_int(:,:,jp_msk,jn) 
     150               r1_sjk(:,:,jn) = 0._wp 
     151               WHERE( sjk(:,:,jn) /= 0._wp )   r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 
     152               ! i-mean T and S, j-Stream-Function, basin 
     153               zt_jk(:,:,jn) = pvtr_int(:,:,jp_tem,jn) * r1_sjk(:,:,jn) 
     154               zs_jk(:,:,jn) = pvtr_int(:,:,jp_sal,jn) * r1_sjk(:,:,jn) 
     155               v_msf(:,:,jn) = pvtr_int(:,:,jp_vtr,jn) 
     156               hstr_ove(:,jp_tem,jn) = SUM( v_msf(:,:,jn)*zt_jk(:,:,jn), 2 ) 
     157               hstr_ove(:,jp_sal,jn) = SUM( v_msf(:,:,jn)*zs_jk(:,:,jn), 2 ) 
     158               ! 
     159            ENDDO 
     160            DO jn = 1, nbasin 
     161               z3dtr(1,:,jn) = hstr_ove(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW) 
     162               DO ji = 2, jpi 
     163                  z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
     164               ENDDO 
     165            ENDDO 
     166            CALL iom_put( 'sophtove', z3dtr ) 
     167            DO jn = 1, nbasin 
     168               z3dtr(1,:,jn) = hstr_ove(:,jp_sal,jn) * rc_ggram !  (conversion in Gg) 
     169               DO ji = 2, jpi 
     170                  z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
     171               ENDDO 
     172            ENDDO 
     173            CALL iom_put( 'sopstove', z3dtr ) 
     174            ! 
     175            DEALLOCATE( sjk, r1_sjk, v_msf, zt_jk, zs_jk ) 
     176         ENDIF 
     177 
     178         IF( iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN 
     179            ! Calculate barotropic heat and salt transport here  
     180            ALLOCATE( sjk(jpj,1,nbasin), r1_sjk(jpj,1,nbasin) ) 
     181            ! 
     182            DO jn = 1, nbasin 
     183               sjk(:,1,jn) = SUM( pvtr_int(:,:,jp_msk,jn), 2 ) 
     184               r1_sjk(:,1,jn) = 0._wp 
     185               WHERE( sjk(:,1,jn) /= 0._wp )   r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn) 
     186               ! 
     187               zvsum(:) =    SUM( pvtr_int(:,:,jp_vtr,jn), 2 ) 
     188               ztsum(:) =    SUM( pvtr_int(:,:,jp_tem,jn), 2 ) 
     189               zssum(:) =    SUM( pvtr_int(:,:,jp_sal,jn), 2 ) 
     190               hstr_btr(:,jp_tem,jn) = zvsum(:) * ztsum(:) * r1_sjk(:,1,jn) 
     191               hstr_btr(:,jp_sal,jn) = zvsum(:) * zssum(:) * r1_sjk(:,1,jn) 
     192               ! 
     193            ENDDO 
     194            DO jn = 1, nbasin 
     195               z3dtr(1,:,jn) = hstr_btr(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW) 
     196               DO ji = 2, jpi 
     197                  z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
     198               ENDDO 
     199            ENDDO 
     200            CALL iom_put( 'sophtbtr', z3dtr ) 
     201            DO jn = 1, nbasin 
     202               z3dtr(1,:,jn) = hstr_btr(:,jp_sal,jn) * rc_ggram !  (conversion in Gg) 
     203               DO ji = 2, jpi 
     204                  z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
     205               ENDDO 
     206            ENDDO 
     207            CALL iom_put( 'sopstbtr', z3dtr ) 
     208            ! 
     209            DEALLOCATE( sjk, r1_sjk ) 
     210         ENDIF 
     211         ! 
     212         hstr_ove(:,:,:) = 0._wp       ! Zero before next timestep 
     213         hstr_btr(:,:,:) = 0._wp 
     214         pvtr_int(:,:,:,:) = 0._wp 
     215      ELSE 
     216         IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' )  ) THEN    ! i-mean i-k-surface 
     217            ALLOCATE( z4d1(jpi,jpj,jpk,nbasin), z4d2(jpi,jpj,jpk,nbasin) ) 
     218            ! 
     219            DO jn = 1, nbasin 
     220               z4d1(1,:,:,jn) = pzon_int(:,:,jp_msk,jn) 
     221               DO ji = 2, jpi 
     222                  z4d1(ji,:,:,jn) = z4d1(1,:,:,jn) 
     223               ENDDO 
     224            ENDDO 
     225            CALL iom_put( 'zosrf', z4d1 ) 
     226            ! 
     227            DO jn = 1, nbasin 
     228               z4d2(1,:,:,jn) = pzon_int(:,:,jp_tem,jn) / MAX( z4d1(1,:,:,jn), 10.e-15 ) 
     229               DO ji = 2, jpi 
     230                  z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 
     231               ENDDO 
     232            ENDDO 
     233            CALL iom_put( 'zotem', z4d2 ) 
     234            ! 
     235            DO jn = 1, nbasin 
     236               z4d2(1,:,:,jn) = pzon_int(:,:,jp_sal,jn) / MAX( z4d1(1,:,:,jn), 10.e-15 ) 
     237               DO ji = 2, jpi 
     238                  z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 
     239               ENDDO 
     240            ENDDO 
     241            CALL iom_put( 'zosal', z4d2 ) 
     242            ! 
     243            DEALLOCATE( z4d1, z4d2 ) 
     244         ENDIF 
     245         ! 
     246         !                                ! Advective and diffusive heat and salt transport 
     247         IF( iom_use( 'sophtadv' ) .OR. iom_use( 'sopstadv' ) ) THEN   
     248            !  
     249            DO jn = 1, nbasin 
     250               z3dtr(1,:,jn) = hstr_adv(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW) 
     251               DO ji = 2, jpi 
     252                  z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
     253               ENDDO 
     254            ENDDO 
     255            CALL iom_put( 'sophtadv', z3dtr ) 
     256            DO jn = 1, nbasin 
     257               z3dtr(1,:,jn) = hstr_adv(:,jp_sal,jn) * rc_ggram !  (conversion in Gg) 
     258               DO ji = 2, jpi 
     259                  z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
     260               ENDDO 
     261            ENDDO 
     262            CALL iom_put( 'sopstadv', z3dtr ) 
     263         ENDIF 
     264         ! 
     265         IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) THEN   
     266            !  
     267            DO jn = 1, nbasin 
     268               z3dtr(1,:,jn) = hstr_ldf(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW) 
     269               DO ji = 2, jpi 
     270                  z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
     271               ENDDO 
     272            ENDDO 
     273            CALL iom_put( 'sophtldf', z3dtr ) 
     274            DO jn = 1, nbasin 
     275               z3dtr(1,:,jn) = hstr_ldf(:,jp_sal,jn) * rc_ggram !  (conversion in Gg) 
     276               DO ji = 2, jpi 
     277                  z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
     278               ENDDO 
     279            ENDDO 
     280            CALL iom_put( 'sopstldf', z3dtr ) 
     281         ENDIF 
     282         ! 
     283         IF( iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) ) THEN   
     284            !  
     285            DO jn = 1, nbasin 
     286               z3dtr(1,:,jn) = hstr_eiv(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW) 
     287               DO ji = 2, jpi 
     288                  z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
     289               ENDDO 
     290            ENDDO 
     291            CALL iom_put( 'sophteiv', z3dtr ) 
     292            DO jn = 1, nbasin 
     293               z3dtr(1,:,jn) = hstr_eiv(:,jp_sal,jn) * rc_ggram !  (conversion in Gg) 
     294               DO ji = 2, jpi 
     295                  z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
     296               ENDDO 
     297            ENDDO 
     298            CALL iom_put( 'sopsteiv', z3dtr ) 
     299         ENDIF 
     300         ! 
     301         IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN 
     302             DO jn = 1, nbasin 
     303                z3dtr(1,:,jn) = hstr_vtr(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW) 
     304                DO ji = 2, jpi 
     305                   z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
     306                ENDDO 
     307             ENDDO 
     308             CALL iom_put( 'sophtvtr', z3dtr ) 
     309             DO jn = 1, nbasin 
     310               z3dtr(1,:,jn) = hstr_vtr(:,jp_sal,jn) * rc_ggram !  (conversion in Gg) 
     311               DO ji = 2, jpi 
     312                  z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
     313               ENDDO 
     314            ENDDO 
     315            CALL iom_put( 'sopstvtr', z3dtr ) 
     316         ENDIF 
     317         ! 
     318         IF( iom_use( 'uocetr_vsum_cumul' ) ) THEN 
     319            IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 )         ! Use full domain 
     320            CALL iom_get_var(  'uocetr_vsum_op', z2d ) ! get uocetr_vsum_op from xml 
     321            z2d(:,:) = ptr_ci_2d( z2d(:,:) )   
     322            CALL iom_put( 'uocetr_vsum_cumul', z2d ) 
     323            IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = nijtile )   ! Revert to tile domain 
     324         ENDIF 
     325         ! 
     326         hstr_adv(:,:,:) = 0._wp       ! Zero before next timestep 
     327         hstr_ldf(:,:,:) = 0._wp 
     328         hstr_eiv(:,:,:) = 0._wp 
     329         hstr_vtr(:,:,:) = 0._wp 
     330         pzon_int(:,:,:,:) = 0._wp 
     331      ENDIF 
     332      ! 
     333      DEALLOCATE( z3dtr ) 
     334      ! 
     335   END SUBROUTINE dia_ptr_iom 
     336 
     337 
     338   SUBROUTINE dia_ptr_zint( Kmm, pvtr ) 
     339      !!---------------------------------------------------------------------- 
     340      !!                    ***  ROUTINE dia_ptr_zint *** 
     341      !!---------------------------------------------------------------------- 
     342      !! ** Purpose : i and i-k sum operations on arrays 
     343      !! 
     344      !! ** Method  : - Call ptr_sjk (i sum) or ptr_sj (i-k sum) to perform the sum operation 
     345      !!              - Call ptr_sum to add this result to the sum over tiles 
     346      !! 
     347      !! ** Action  : pvtr_int - terms for volume streamfunction, heat/salt transport barotropic/overturning terms 
     348      !!              pzon_int - terms for i mean temperature/salinity 
     349      !!---------------------------------------------------------------------- 
     350      INTEGER                     , INTENT(in)           :: Kmm          ! time level index 
     351      REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(in), OPTIONAL :: pvtr         ! j-effective transport 
     352      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE            :: zmask        ! 3D workspace 
     353      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE          :: zts          ! 4D workspace 
     354      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE            :: sjk, v_msf   ! Zonal sum: i-k surface area, j-effective transport 
     355      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE            :: zt_jk, zs_jk ! Zonal sum: i-k surface area * (T, S) 
     356      REAL(wp)                                           :: zsfc, zvfc   ! i-k surface area 
     357      INTEGER  ::   ji, jj, jk, jn                                       ! dummy loop indices 
     358      !!---------------------------------------------------------------------- 
     359 
     360      IF( PRESENT( pvtr ) ) THEN 
     361         ! i sum of effective j transport excluding closed seas 
     362         IF( iom_use( 'zomsf' ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN 
     363            ALLOCATE( v_msf(A1Dj(nn_hls),jpk,nbasin) ) 
     364 
     365            DO jn = 1, nbasin 
     366               v_msf(:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) ) 
     367            ENDDO 
     368 
     369            CALL ptr_sum( pvtr_int(:,:,jp_vtr,:), v_msf(:,:,:) ) 
     370 
     371            DEALLOCATE( v_msf ) 
     372         ENDIF 
     373 
     374         ! i sum of j surface area, j surface area - temperature/salinity product on V grid 
    118375         IF(  iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR.   & 
    119376            & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN 
    120             ! define fields multiplied by scalar 
     377            ALLOCATE( zmask(A2D(nn_hls),jpk), zts(A2D(nn_hls),jpk,jpts), & 
     378               &      sjk(A1Dj(nn_hls),jpk,nbasin), & 
     379               &      zt_jk(A1Dj(nn_hls),jpk,nbasin), zs_jk(A1Dj(nn_hls),jpk,nbasin) ) 
     380 
    121381            zmask(:,:,:) = 0._wp 
    122382            zts(:,:,:,:) = 0._wp 
     383 
    123384            DO_3D( 1, 0, 1, 1, 1, jpkm1 ) 
    124385               zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 
    125386               zmask(ji,jj,jk)      = vmask(ji,jj,jk)      * zvfc 
    126                zts(ji,jj,jk,jp_tem) = (ts(ji,jj,jk,jp_tem,Kmm)+ts(ji,jj+1,jk,jp_tem,Kmm)) * 0.5 * zvfc  !Tracers averaged onto V grid 
     387               zts(ji,jj,jk,jp_tem) = (ts(ji,jj,jk,jp_tem,Kmm)+ts(ji,jj+1,jk,jp_tem,Kmm)) * 0.5 * zvfc !Tracers averaged onto V grid 
    127388               zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc 
    128389            END_3D 
    129          ENDIF 
    130          IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN 
    131             DO jn = 1, nbasin 
    132                ALLOCATE( sjk(jpj,jpk,nbasin), r1_sjk(jpj,jpk,nbasin), v_msf(jpj,jpk,nbasin),   & 
    133                   &                          zt_jk(jpj,jpk,nbasin), zs_jk(jpj,jpk,nbasin) ) 
    134                sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 
    135                r1_sjk(:,:,jn) = 0._wp 
    136                WHERE( sjk(:,:,jn) /= 0._wp )   r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn) 
    137                ! i-mean T and S, j-Stream-Function, basin 
    138                zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 
    139                zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) 
    140                v_msf(:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) )  
    141                hstr_ove(:,jp_tem,jn) = SUM( v_msf(:,:,jn)*zt_jk(:,:,jn), 2 ) 
    142                hstr_ove(:,jp_sal,jn) = SUM( v_msf(:,:,jn)*zs_jk(:,:,jn), 2 ) 
    143                DEALLOCATE( sjk, r1_sjk, v_msf, zt_jk, zs_jk ) 
    144                ! 
    145             ENDDO 
    146             DO jn = 1, nbasin 
    147                z3dtr(1,:,jn) = hstr_ove(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW) 
    148                DO ji = 1, jpi 
    149                   z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
    150                ENDDO 
    151             ENDDO 
    152             CALL iom_put( 'sophtove', z3dtr ) 
    153             DO jn = 1, nbasin 
    154                z3dtr(1,:,jn) = hstr_ove(:,jp_sal,jn) * rc_ggram !  (conversion in Gg) 
    155                DO ji = 1, jpi 
    156                   z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
    157                ENDDO 
    158             ENDDO 
    159             CALL iom_put( 'sopstove', z3dtr ) 
    160          ENDIF 
    161  
    162          IF( iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN 
    163             ! Calculate barotropic heat and salt transport here  
    164             DO jn = 1, nbasin 
    165                ALLOCATE( sjk(jpj,1,nbasin), r1_sjk(jpj,1,nbasin) ) 
    166                sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) ) 
    167                r1_sjk(:,1,jn) = 0._wp 
    168                WHERE( sjk(:,1,jn) /= 0._wp )   r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn) 
    169                ! 
    170                zvsum(:) = ptr_sj( pvtr(:,:,:), btmsk34(:,:,jn) ) 
    171                ztsum(:) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 
    172                zssum(:) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 
    173                hstr_btr(:,jp_tem,jn) = zvsum(:) * ztsum(:) * r1_sjk(:,1,jn) 
    174                hstr_btr(:,jp_sal,jn) = zvsum(:) * zssum(:) * r1_sjk(:,1,jn) 
    175                DEALLOCATE( sjk, r1_sjk ) 
    176                ! 
    177             ENDDO 
    178             DO jn = 1, nbasin 
    179                z3dtr(1,:,jn) = hstr_btr(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW) 
    180                DO ji = 1, jpi 
    181                   z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
    182                ENDDO 
    183             ENDDO 
    184             CALL iom_put( 'sophtbtr', z3dtr ) 
    185             DO jn = 1, nbasin 
    186                z3dtr(1,:,jn) = hstr_btr(:,jp_sal,jn) * rc_ggram !  (conversion in Gg) 
    187                DO ji = 1, jpi 
    188                   z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
    189                ENDDO 
    190             ENDDO 
    191             CALL iom_put( 'sopstbtr', z3dtr ) 
    192          ENDIF  
    193          ! 
     390 
     391            DO jn = 1, nbasin 
     392               sjk(:,:,jn)   = ptr_sjk( zmask(:,:,:)     , btmsk(:,:,jn) ) 
     393               zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 
     394               zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 
     395            ENDDO 
     396 
     397            CALL ptr_sum( pvtr_int(:,:,jp_msk,:), sjk(:,:,:)   ) 
     398            CALL ptr_sum( pvtr_int(:,:,jp_tem,:), zt_jk(:,:,:) ) 
     399            CALL ptr_sum( pvtr_int(:,:,jp_sal,:), zs_jk(:,:,:) ) 
     400 
     401            DEALLOCATE( zmask, zts, sjk, zt_jk, zs_jk ) 
     402         ENDIF 
    194403      ELSE 
    195          ! 
    196          zmask(:,:,:) = 0._wp 
    197          zts(:,:,:,:) = 0._wp 
    198          IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' )  ) THEN    ! i-mean i-k-surface  
    199             ALLOCATE( z4d1(jpi,jpj,jpk,nbasin), z4d2(jpi,jpj,jpk,nbasin) ) 
     404         ! i sum of j surface area - temperature/salinity product on T grid 
     405         IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' )  ) THEN 
     406            ALLOCATE( zmask(A2D(nn_hls),jpk), zts(A2D(nn_hls),jpk,jpts), & 
     407               &      sjk(A1Dj(nn_hls),jpk,nbasin), & 
     408               &      zt_jk(A1Dj(nn_hls),jpk,nbasin), zs_jk(A1Dj(nn_hls),jpk,nbasin) ) 
     409 
     410            zmask(:,:,:) = 0._wp 
     411            zts(:,:,:,:) = 0._wp 
     412 
    200413            DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
    201414               zsfc = e1t(ji,jj) * e3t(ji,jj,jk,Kmm) 
    … …  
    204417               zts(ji,jj,jk,jp_sal) = ts(ji,jj,jk,jp_sal,Kmm) * zsfc 
    205418            END_3D 
    206             ! 
    207             DO jn = 1, nbasin 
    208                zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 
    209                DO ji = 1, jpi 
    210                   zmask(ji,:,:) = zmask(1,:,:) 
    211                ENDDO 
    212                z4d1(:,:,:,jn) = zmask(:,:,:) 
    213             ENDDO 
    214             CALL iom_put( 'zosrf', z4d1 ) 
    215             ! 
    216             DO jn = 1, nbasin 
    217                z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) & 
    218                   &            / MAX( z4d1(1,:,:,jn), 10.e-15 ) 
    219                DO ji = 1, jpi 
    220                   z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 
    221                ENDDO 
    222             ENDDO 
    223             CALL iom_put( 'zotem', z4d2 ) 
    224             ! 
    225             DO jn = 1, nbasin 
    226                z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) & 
    227                   &            / MAX( z4d1(1,:,:,jn), 10.e-15 ) 
    228                DO ji = 1, jpi 
    229                   z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) 
    230                ENDDO 
    231             ENDDO 
    232             CALL iom_put( 'zosal', z4d2 ) 
    233             DEALLOCATE( z4d1, z4d2 ) 
    234             ! 
    235          ENDIF 
    236          ! 
    237          !                                ! Advective and diffusive heat and salt transport 
    238          IF( iom_use( 'sophtadv' ) .OR. iom_use( 'sopstadv' ) ) THEN   
    239             !  
    240             DO jn = 1, nbasin 
    241                z3dtr(1,:,jn) = hstr_adv(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW) 
    242                DO ji = 1, jpi 
    243                   z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
    244                ENDDO 
    245             ENDDO 
    246             CALL iom_put( 'sophtadv', z3dtr ) 
    247             DO jn = 1, nbasin 
    248                z3dtr(1,:,jn) = hstr_adv(:,jp_sal,jn) * rc_ggram !  (conversion in Gg) 
    249                DO ji = 1, jpi 
    250                   z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
    251                ENDDO 
    252             ENDDO 
    253             CALL iom_put( 'sopstadv', z3dtr ) 
    254          ENDIF 
    255          ! 
    256          IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) THEN   
    257             !  
    258             DO jn = 1, nbasin 
    259                z3dtr(1,:,jn) = hstr_ldf(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW) 
    260                DO ji = 1, jpi 
    261                   z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
    262                ENDDO 
    263             ENDDO 
    264             CALL iom_put( 'sophtldf', z3dtr ) 
    265             DO jn = 1, nbasin 
    266                z3dtr(1,:,jn) = hstr_ldf(:,jp_sal,jn) * rc_ggram !  (conversion in Gg) 
    267                DO ji = 1, jpi 
    268                   z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
    269                ENDDO 
    270             ENDDO 
    271             CALL iom_put( 'sopstldf', z3dtr ) 
    272          ENDIF 
    273          ! 
    274          IF( iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) ) THEN   
    275             !  
    276             DO jn = 1, nbasin 
    277                z3dtr(1,:,jn) = hstr_eiv(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW) 
    278                DO ji = 1, jpi 
    279                   z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
    280                ENDDO 
    281             ENDDO 
    282             CALL iom_put( 'sophteiv', z3dtr ) 
    283             DO jn = 1, nbasin 
    284                z3dtr(1,:,jn) = hstr_eiv(:,jp_sal,jn) * rc_ggram !  (conversion in Gg) 
    285                DO ji = 1, jpi 
    286                   z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
    287                ENDDO 
    288             ENDDO 
    289             CALL iom_put( 'sopsteiv', z3dtr ) 
    290          ENDIF 
    291          ! 
     419 
     420            DO jn = 1, nbasin 
     421               sjk(:,:,jn)   = ptr_sjk( zmask(:,:,:)     , btmsk(:,:,jn) ) 
     422               zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) 
     423               zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) 
     424            ENDDO 
     425 
     426            CALL ptr_sum( pzon_int(:,:,jp_msk,:), sjk(:,:,:)   ) 
     427            CALL ptr_sum( pzon_int(:,:,jp_tem,:), zt_jk(:,:,:) ) 
     428            CALL ptr_sum( pzon_int(:,:,jp_sal,:), zs_jk(:,:,:) ) 
     429 
     430            DEALLOCATE( zmask, zts, sjk, zt_jk, zs_jk ) 
     431         ENDIF 
     432 
     433         ! i-k sum of j surface area - temperature/salinity product on V grid 
    292434         IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN 
     435            ALLOCATE( zts(A2D(nn_hls),jpk,jpts) ) 
     436 
    293437            zts(:,:,:,:) = 0._wp 
     438 
    294439            DO_3D( 1, 0, 1, 1, 1, jpkm1 ) 
    295440               zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 
    … …  
    297442               zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc 
    298443            END_3D 
    299              CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) ) 
    300              CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) ) 
    301              DO jn = 1, nbasin 
    302                 z3dtr(1,:,jn) = hstr_vtr(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW) 
    303                 DO ji = 1, jpi 
    304                    z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
    305                 ENDDO 
    306              ENDDO 
    307              CALL iom_put( 'sophtvtr', z3dtr ) 
    308              DO jn = 1, nbasin 
    309                z3dtr(1,:,jn) = hstr_vtr(:,jp_sal,jn) * rc_ggram !  (conversion in Gg) 
    310                DO ji = 1, jpi 
    311                   z3dtr(ji,:,jn) = z3dtr(1,:,jn) 
    312                ENDDO 
    313             ENDDO 
    314             CALL iom_put( 'sopstvtr', z3dtr ) 
    315          ENDIF 
    316          ! 
    317          IF( iom_use( 'uocetr_vsum_cumul' ) ) THEN 
    318             CALL iom_get_var(  'uocetr_vsum_op', z2d ) ! get uocetr_vsum_op from xml 
    319             z2d(:,:) = ptr_ci_2d( z2d(:,:) )   
    320             CALL iom_put( 'uocetr_vsum_cumul', z2d ) 
    321          ENDIF 
    322          ! 
     444 
     445            CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) ) 
     446            CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) ) 
     447 
     448            DEALLOCATE( zts ) 
     449         ENDIF 
    323450      ENDIF 
    324       ! 
    325       DEALLOCATE( z3dtr ) 
    326       ! 
    327       IF( ln_timing )   CALL timing_stop('dia_ptr') 
    328       ! 
    329    END SUBROUTINE dia_ptr 
     451   END SUBROUTINE dia_ptr_zint 
    330452 
    331453 
    … …  
    340462      REAL(wp), DIMENSION(jpi,jpj) :: zmsk 
    341463      !!---------------------------------------------------------------------- 
    342        
     464 
    343465      ! l_diaptr is defined with iom_use 
    344466      !   --> dia_ptr_init must be done after the call to iom_init 
    … …  
    347469         &       iom_use( 'zosrf'    ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR.  & 
    348470         &       iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) .OR. iom_use( 'sophtadv' ) .OR.  & 
    349          &       iom_use( 'sopstadv' ) .OR. iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) .OR.  &  
     471         &       iom_use( 'sopstadv' ) .OR. iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) .OR.  & 
    350472         &       iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) .OR. iom_use( 'sopstvtr' ) .OR.  & 
    351          &       iom_use( 'sophtvtr' ) .OR. iom_use( 'uocetr_vsum_cumul' )  
    352   
     473         &       iom_use( 'sophtvtr' ) .OR. iom_use( 'uocetr_vsum_cumul' ) 
     474       
    353475      IF(lwp) THEN                     ! Control print 
    354476         WRITE(numout,*) 
    … …  
    398520         hstr_btr(:,:,:) = 0._wp           ! 
    399521         hstr_vtr(:,:,:) = 0._wp           ! 
     522         pvtr_int(:,:,:,:) = 0._wp 
     523         pzon_int(:,:,:,:) = 0._wp 
    400524         ! 
    401525         ll_init = .FALSE. 
    … …  
    415539      INTEGER                         , INTENT(in )  :: ktra  ! tracer index 
    416540      CHARACTER(len=3)                , INTENT(in)   :: cptr  ! transport type  'adv'/'ldf'/'eiv' 
    417       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)   :: pvflx   ! 3D input array of advection/diffusion 
     541      REAL(wp), DIMENSION(A2D(nn_hls),jpk)    , INTENT(in)   :: pvflx ! 3D input array of advection/diffusion 
     542      REAL(wp), DIMENSION(A1Dj(nn_hls),nbasin)                 :: zsj   ! 
    418543      INTEGER                                        :: jn    ! 
    419544 
     545      DO jn = 1, nbasin 
     546         zsj(:,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 
     547      ENDDO 
    420548      ! 
    421549      IF( cptr == 'adv' ) THEN 
    422          IF( ktra == jp_tem )  THEN 
    423              DO jn = 1, nbasin 
    424                 hstr_adv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 
    425              ENDDO 
    426          ENDIF 
    427          IF( ktra == jp_sal )  THEN 
    428              DO jn = 1, nbasin 
    429                 hstr_adv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 
    430              ENDDO 
    431          ENDIF 
     550         IF( ktra == jp_tem )  CALL ptr_sum( hstr_adv(:,jp_tem,:), zsj(:,:) ) 
     551         IF( ktra == jp_sal )  CALL ptr_sum( hstr_adv(:,jp_sal,:), zsj(:,:) ) 
     552      ELSE IF( cptr == 'ldf' ) THEN 
     553         IF( ktra == jp_tem )  CALL ptr_sum( hstr_ldf(:,jp_tem,:), zsj(:,:) ) 
     554         IF( ktra == jp_sal )  CALL ptr_sum( hstr_ldf(:,jp_sal,:), zsj(:,:) ) 
     555      ELSE IF( cptr == 'eiv' ) THEN 
     556         IF( ktra == jp_tem )  CALL ptr_sum( hstr_eiv(:,jp_tem,:), zsj(:,:) ) 
     557         IF( ktra == jp_sal )  CALL ptr_sum( hstr_eiv(:,jp_sal,:), zsj(:,:) ) 
     558      ELSE IF( cptr == 'vtr' ) THEN 
     559         IF( ktra == jp_tem )  CALL ptr_sum( hstr_vtr(:,jp_tem,:), zsj(:,:) ) 
     560         IF( ktra == jp_sal )  CALL ptr_sum( hstr_vtr(:,jp_sal,:), zsj(:,:) ) 
    432561      ENDIF 
    433562      ! 
    434       IF( cptr == 'ldf' ) THEN 
    435          IF( ktra == jp_tem )  THEN 
    436              DO jn = 1, nbasin 
    437                 hstr_ldf(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 
    438              ENDDO 
    439          ENDIF 
    440          IF( ktra == jp_sal )  THEN 
    441              DO jn = 1, nbasin 
    442                 hstr_ldf(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 
    443              ENDDO 
    444          ENDIF 
     563   END SUBROUTINE dia_ptr_hst 
     564 
     565 
     566   SUBROUTINE ptr_sum_2d( phstr, pva ) 
     567      !!---------------------------------------------------------------------- 
     568      !!                    ***  ROUTINE ptr_sum_2d *** 
     569      !!---------------------------------------------------------------------- 
     570      !! ** Purpose : Add two 2D arrays with (j,nbasin) dimensions 
     571      !! 
     572      !! ** Method  : - phstr = phstr + pva 
     573      !!              - Call mpp_sum if the final tile 
     574      !! 
     575      !! ** Action  : phstr 
     576      !!---------------------------------------------------------------------- 
     577      REAL(wp), DIMENSION(jpj,nbasin) , INTENT(inout)         ::  phstr  ! 
     578      REAL(wp), DIMENSION(A1Dj(nn_hls),nbasin), INTENT(in)            ::  pva    ! 
     579      INTEGER                                               ::  jj 
     580#if defined key_mpp_mpi 
     581      INTEGER, DIMENSION(1)           ::  ish1d 
     582      INTEGER, DIMENSION(2)           ::  ish2d 
     583      REAL(wp), DIMENSION(jpj*nbasin) ::  zwork 
     584#endif 
     585 
     586      DO jj = ntsj, ntej 
     587         phstr(jj,:) = phstr(jj,:)  + pva(jj,:) 
     588      END DO 
     589 
     590#if defined key_mpp_mpi 
     591      IF( ntile == 0 .OR. ntile == nijtile ) THEN 
     592         ish1d(1) = jpj*nbasin 
     593         ish2d(1) = jpj ; ish2d(2) = nbasin 
     594         zwork(:) = RESHAPE( phstr(:,:), ish1d ) 
     595         CALL mpp_sum( 'diaptr', zwork, ish1d(1), ncomm_znl ) 
     596         phstr(:,:) = RESHAPE( zwork, ish2d ) 
    445597      ENDIF 
    446       ! 
    447       IF( cptr == 'eiv' ) THEN 
    448          IF( ktra == jp_tem )  THEN 
    449              DO jn = 1, nbasin 
    450                 hstr_eiv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 
    451              ENDDO 
    452          ENDIF 
    453          IF( ktra == jp_sal )  THEN 
    454              DO jn = 1, nbasin 
    455                 hstr_eiv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 
    456              ENDDO 
    457          ENDIF 
     598#endif 
     599   END SUBROUTINE ptr_sum_2d 
     600 
     601 
     602   SUBROUTINE ptr_sum_3d( phstr, pva ) 
     603      !!---------------------------------------------------------------------- 
     604      !!                    ***  ROUTINE ptr_sum_3d *** 
     605      !!---------------------------------------------------------------------- 
     606      !! ** Purpose : Add two 3D arrays with (j,k,nbasin) dimensions 
     607      !! 
     608      !! ** Method  : - phstr = phstr + pva 
     609      !!              - Call mpp_sum if the final tile 
     610      !! 
     611      !! ** Action  : phstr 
     612      !!---------------------------------------------------------------------- 
     613      REAL(wp), DIMENSION(jpj,jpk,nbasin) , INTENT(inout)     ::  phstr  ! 
     614      REAL(wp), DIMENSION(A1Dj(nn_hls),jpk,nbasin), INTENT(in)        ::  pva    ! 
     615      INTEGER                                               ::  jj, jk 
     616#if defined key_mpp_mpi 
     617      INTEGER, DIMENSION(1)              ::  ish1d 
     618      INTEGER, DIMENSION(3)              ::  ish3d 
     619      REAL(wp), DIMENSION(jpj*jpk*nbasin)  ::  zwork 
     620#endif 
     621 
     622      DO jk = 1, jpk 
     623         DO jj = ntsj, ntej 
     624            phstr(jj,jk,:) = phstr(jj,jk,:)  + pva(jj,jk,:) 
     625         END DO 
     626      END DO 
     627 
     628#if defined key_mpp_mpi 
     629      IF( ntile == 0 .OR. ntile == nijtile ) THEN 
     630         ish1d(1) = jpj*jpk*nbasin 
     631         ish3d(1) = jpj ; ish3d(2) = jpk ; ish3d(3) = nbasin 
     632         zwork(:) = RESHAPE( phstr(:,:,:), ish1d ) 
     633         CALL mpp_sum( 'diaptr', zwork, ish1d(1), ncomm_znl ) 
     634         phstr(:,:,:) = RESHAPE( zwork, ish3d ) 
    458635      ENDIF 
    459       ! 
    460       IF( cptr == 'vtr' ) THEN 
    461          IF( ktra == jp_tem )  THEN 
    462              DO jn = 1, nbasin 
    463                 hstr_vtr(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 
    464              ENDDO 
    465          ENDIF 
    466          IF( ktra == jp_sal )  THEN 
    467              DO jn = 1, nbasin 
    468                 hstr_vtr(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 
    469              ENDDO 
    470          ENDIF 
    471       ENDIF 
    472       ! 
    473    END SUBROUTINE dia_ptr_hst 
     636#endif 
     637   END SUBROUTINE ptr_sum_3d 
    474638 
    475639 
    … …  
    479643      !!---------------------------------------------------------------------- 
    480644      INTEGER               ::   dia_ptr_alloc   ! return value 
    481       INTEGER, DIMENSION(3) ::   ierr 
     645      INTEGER, DIMENSION(2) ::   ierr 
    482646      !!---------------------------------------------------------------------- 
    483647      ierr(:) = 0 
    … …  
    491655            &      hstr_ldf(jpj,jpts,nbasin), hstr_vtr(jpj,jpts,nbasin), STAT=ierr(1)  ) 
    492656            ! 
    493          ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2)) 
     657         ALLOCATE( pvtr_int(jpj,jpk,jpts+2,nbasin), & 
     658            &      pzon_int(jpj,jpk,jpts+1,nbasin), STAT=ierr(2) ) 
    494659         ! 
    495660         dia_ptr_alloc = MAXVAL( ierr ) 
    … …  
    511676      !! ** Action  : - p_fval: i-k-mean poleward flux of pvflx 
    512677      !!---------------------------------------------------------------------- 
    513       REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk)  ::   pvflx  ! mask flux array at V-point 
    514       REAL(wp), INTENT(in), DIMENSION(jpi,jpj)      ::   pmsk   ! Optional 2D basin mask 
     678      REAL(wp), INTENT(in), DIMENSION(A2D(nn_hls),jpk)  ::   pvflx  ! mask flux array at V-point 
     679      REAL(wp), INTENT(in), DIMENSION(jpi,jpj)  ::   pmsk   ! Optional 2D basin mask 
    515680      ! 
    516681      INTEGER                  ::   ji, jj, jk   ! dummy loop arguments 
    517       INTEGER                  ::   ijpj         ! ??? 
    518       REAL(wp), POINTER, DIMENSION(:) :: p_fval  ! function value 
     682      REAL(wp), DIMENSION(A1Dj(nn_hls)) :: p_fval  ! function value 
    519683      !!-------------------------------------------------------------------- 
    520684      ! 
    521       p_fval => p_fval1d 
    522  
    523       ijpj = jpj 
    524685      p_fval(:) = 0._wp 
    525686      DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
    526687         p_fval(jj) = p_fval(jj) + pvflx(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 
    527688      END_3D 
    528 #if defined key_mpp_mpi 
    529       CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl) 
    530 #endif 
    531       ! 
    532689   END FUNCTION ptr_sj_3d 
    533690 
    … …  
    544701      !! ** Action  : - p_fval: i-k-mean poleward flux of pvflx 
    545702      !!---------------------------------------------------------------------- 
    546       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) ::   pvflx  ! mask flux array at V-point 
     703      REAL(wp) , INTENT(in), DIMENSION(A2D(nn_hls))    ::   pvflx  ! mask flux array at V-point 
    547704      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) ::   pmsk   ! Optional 2D basin mask 
    548705      ! 
    549706      INTEGER                  ::   ji,jj       ! dummy loop arguments 
    550       INTEGER                  ::   ijpj        ! ??? 
    551       REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 
     707      REAL(wp), DIMENSION(A1Dj(nn_hls)) :: p_fval ! function value 
    552708      !!-------------------------------------------------------------------- 
    553       !  
    554       p_fval => p_fval1d 
    555  
    556       ijpj = jpj 
     709      ! 
    557710      p_fval(:) = 0._wp 
    558711      DO_2D( 0, 0, 0, 0 ) 
    559712         p_fval(jj) = p_fval(jj) + pvflx(ji,jj) * pmsk(ji,jj) * tmask_i(ji,jj) 
    560713      END_2D 
    561 #if defined key_mpp_mpi 
    562       CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl ) 
    563 #endif 
    564       !  
    565714   END FUNCTION ptr_sj_2d 
    566715 
    … …  
    588737            p_fval(ji,jj) = p_fval(ji,jj-1) + pva(ji,jj) * tmask_i(ji,jj) 
    589738         END_2D 
    590          CALL lbc_lnk( 'diaptr', p_fval, 'U', -1.0_wp ) 
    591739      END DO 
    592740      !  
    … …  
    607755      !! 
    608756      IMPLICIT none 
    609       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pta    ! mask flux array at V-point 
    610       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)     ::   pmsk   ! Optional 2D basin mask 
     757      REAL(wp) , INTENT(in), DIMENSION(A2D(nn_hls),jpk) ::   pta    ! mask flux array at V-point 
     758      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) ::   pmsk   ! Optional 2D basin mask 
    611759      !! 
    612760      INTEGER                           :: ji, jj, jk ! dummy loop arguments 
    613       REAL(wp), POINTER, DIMENSION(:,:) :: p_fval     ! return function value 
    614 #if defined key_mpp_mpi 
    615       INTEGER, DIMENSION(1) ::   ish 
    616       INTEGER, DIMENSION(2) ::   ish2 
    617       INTEGER               ::   ijpjjpk 
    618       REAL(wp), DIMENSION(jpj*jpk) ::   zwork    ! mask flux array at V-point 
    619 #endif 
     761      REAL(wp), DIMENSION(A1Dj(nn_hls),jpk) :: p_fval     ! return function value 
    620762      !!-------------------------------------------------------------------- 
    621763      ! 
    622       p_fval => p_fval2d 
    623  
    624764      p_fval(:,:) = 0._wp 
    625765      ! 
    … …  
    627767         p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) 
    628768      END_3D 
    629       ! 
    630 #if defined key_mpp_mpi 
    631       ijpjjpk = jpj*jpk 
    632       ish(1) = ijpjjpk  ;   ish2(1) = jpj   ;   ish2(2) = jpk 
    633       zwork(1:ijpjjpk) = RESHAPE( p_fval, ish ) 
    634       CALL mpp_sum( 'diaptr', zwork, ijpjjpk, ncomm_znl ) 
    635       p_fval(:,:) = RESHAPE( zwork, ish2 ) 
    636 #endif 
    637       ! 
    638769   END FUNCTION ptr_sjk 
    639770 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/DOM/daymod.F90

    r13899 r14012  
    149149      CALL day( nit000 ) 
    150150      ! 
    151       IF( lwxios ) THEN 
    152 ! define variables in restart file when writing with XIOS 
    153           CALL iom_set_rstw_var_active('kt') 
    154           CALL iom_set_rstw_var_active('ndastp') 
    155           CALL iom_set_rstw_var_active('adatrj') 
    156           CALL iom_set_rstw_var_active('ntime') 
    157       ENDIF 
    158  
    159151   END SUBROUTINE day_init 
    160152 
    … …  
    324316 
    325317      IF( TRIM(cdrw) == 'READ' ) THEN 
    326  
    327318         IF( iom_varid( numror, 'kt', ldstop = .FALSE. ) > 0 ) THEN 
    328319            ! Get Calendar informations 
    329             CALL iom_get( numror, 'kt', zkt, ldxios = lrxios )   ! last time-step of previous run 
     320            CALL iom_get( numror, 'kt', zkt )   ! last time-step of previous run 
    330321            IF(lwp) THEN 
    331322               WRITE(numout,*) ' *** Info read in restart : ' 
    … …  
    346337            IF ( nrstdt == 2 ) THEN 
    347338               ! read the parameters corresponding to nit000 - 1 (last time step of previous run) 
    348                CALL iom_get( numror, 'ndastp', zndastp, ldxios = lrxios ) 
     339               CALL iom_get( numror, 'ndastp', zndastp ) 
    349340               ndastp = NINT( zndastp ) 
    350                CALL iom_get( numror, 'adatrj', adatrj , ldxios = lrxios ) 
    351           CALL iom_get( numror, 'ntime' , ktime  , ldxios = lrxios ) 
     341               CALL iom_get( numror, 'adatrj', adatrj ) 
     342          CALL iom_get( numror, 'ntime' , ktime  ) 
    352343               nn_time0 = NINT(ktime) 
    353344               ! calculate start time in hours and minutes 
    … …  
    410401         ENDIF 
    411402         ! calendar control 
    412          IF( lwxios ) CALL iom_swap(      cwxios_context          ) 
    413          CALL iom_rstput( kt, nitrst, numrow, 'kt'     , REAL( kt    , wp)  , ldxios = lwxios )   ! time-step 
    414          CALL iom_rstput( kt, nitrst, numrow, 'ndastp' , REAL( ndastp, wp)  , ldxios = lwxios )   ! date 
    415          CALL iom_rstput( kt, nitrst, numrow, 'adatrj' , adatrj             , ldxios = lwxios            )   ! number of elapsed days since 
     403         CALL iom_rstput( kt, nitrst, numrow, 'kt'     , REAL( kt    , wp)   )   ! time-step 
     404         CALL iom_rstput( kt, nitrst, numrow, 'ndastp' , REAL( ndastp, wp)   )   ! date 
     405         CALL iom_rstput( kt, nitrst, numrow, 'adatrj' , adatrj              )   ! number of elapsed days since 
    416406         !                                                                                                   ! the begining of the run [s] 
    417          CALL iom_rstput( kt, nitrst, numrow, 'ntime'  , REAL( nn_time0, wp), ldxios = lwxios ) ! time 
    418          IF( lwxios ) CALL iom_swap(      cxios_context          ) 
     407         CALL iom_rstput( kt, nitrst, numrow, 'ntime'  , REAL( nn_time0, wp) ) ! time 
    419408      ENDIF 
    420409      ! 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/DOM/dom_oce.F90

    r13899 r14012  
    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/branches/2020/tickets_icb_1900/src/OCE/DOM/domain.F90

    r13899 r14012  
    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   !!------------------------------------------------------------------------- 
    … …  
    6365CONTAINS 
    6466 
    65    SUBROUTINE dom_init( Kbb, Kmm, Kaa, cdstr ) 
     67   SUBROUTINE dom_init( Kbb, Kmm, Kaa ) 
    6668      !!---------------------------------------------------------------------- 
    6769      !!                  ***  ROUTINE dom_init  *** 
    … …  
    7981      !!---------------------------------------------------------------------- 
    8082      INTEGER          , INTENT(in) :: Kbb, Kmm, Kaa          ! ocean time level indices 
    81       CHARACTER (len=*), INTENT(in) :: cdstr                  ! model: NEMO or SAS. Determines core restart variables 
    8283      ! 
    8384      INTEGER ::   ji, jj, jk, jt   ! dummy loop indices 
    … …  
    120121         WRITE(numout,*)     '         cn_cfg = ', TRIM( cn_cfg ), '   nn_cfg = ', nn_cfg 
    121122      ENDIF 
     123      nn_wxios = 0 
     124      ln_xios_read = .FALSE. 
    122125      ! 
    123126      !           !==  Reference coordinate system  ==! 
    124127      ! 
    125       CALL dom_glo                     ! global domain versus local domain 
    126       CALL dom_nam                     ! read namelist ( namrun, namdom ) 
    127       ! 
    128       IF( lwxios ) THEN 
    129 !define names for restart write and set core output (restart.F90) 
    130          CALL iom_set_rst_vars(rst_wfields) 
    131          CALL iom_set_rstw_core(cdstr) 
    132       ENDIF 
    133 !reset namelist for SAS 
    134       IF(cdstr == 'SAS') THEN 
    135          IF(lrxios) THEN 
    136                IF(lwp) write(numout,*) 'Disable reading restart file using XIOS for SAS' 
    137                lrxios = .FALSE. 
    138          ENDIF 
    139       ENDIF 
     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 
    140132      ! 
    141133      CALL dom_hgr                      ! Horizontal mesh 
    … …  
    285277 
    286278 
     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 
    287362   SUBROUTINE dom_nam 
    288363      !!---------------------------------------------------------------------- 
    … …  
    293368      !! ** input   : - namrun namelist 
    294369      !!              - namdom namelist 
     370      !!              - namtile namelist 
    295371      !!              - namnc4 namelist   ! "key_netcdf4" only 
    296372      !!---------------------------------------------------------------------- 
    … …  
    305381         &             ln_cfmeta, ln_xios_read, nn_wxios 
    306382      NAMELIST/namdom/ ln_linssh, rn_Dt, rn_atfp, ln_crs, ln_meshmask 
     383      NAMELIST/namtile/ ln_tile, nn_ltile_i, nn_ltile_j 
    307384#if defined key_netcdf4 
    308385      NAMELIST/namnc4/ nn_nchunks_i, nn_nchunks_j, nn_nchunks_k, ln_nc4zip 
    … …  
    441518      r1_Dt = 1._wp / rDt 
    442519 
     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 
    443540      IF( TRIM(Agrif_CFixed()) == '0' ) THEN 
    444541         lrxios = ln_xios_read.AND.ln_rstart 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/DOM/domqco.F90

    r13899 r14012  
    9191      ! 
    9292      CALL dom_qco_zgr(Kbb, Kmm, Kaa) ! interpolation scale factor, depth and water column 
    93       ! 
    94       ! IF(lwxios) THEN   ! define variables in restart file when writing with XIOS 
    95       !    CALL iom_set_rstw_var_active('e3t_b') 
    96       !    CALL iom_set_rstw_var_active('e3t_n') 
    97       ! ENDIF 
    9893      ! 
    9994   END SUBROUTINE dom_qco_init 
    … …  
    217212            ! 
    218213            IF( MIN( id1, id2 ) > 0 ) THEN       ! all required arrays exist 
    219                CALL iom_get( numror, jpdom_auto, 'sshb'   , ssh(:,:,Kbb), ldxios = lrxios    ) 
    220                CALL iom_get( numror, jpdom_auto, 'sshn'   , ssh(:,:,Kmm), ldxios = lrxios    ) 
     214               CALL iom_get( numror, jpdom_auto, 'sshb'   , ssh(:,:,Kbb)    ) 
     215               CALL iom_get( numror, jpdom_auto, 'sshn'   , ssh(:,:,Kmm)    ) 
    221216               ! needed to restart if land processor not computed 
    222217               IF(lwp) write(numout,*) 'qe_rst_read : ssh(:,:,Kbb) and ssh(:,:,Kmm) found in restart files' 
    … …  
    232227               IF(lwp) write(numout,*) 'sshn set equal to sshb.' 
    233228               IF(lwp) write(numout,*) 'neuler is forced to 0' 
    234                CALL iom_get( numror, jpdom_auto, 'sshb', ssh(:,:,Kbb), ldxios = lrxios ) 
     229               CALL iom_get( numror, jpdom_auto, 'sshb', ssh(:,:,Kbb) ) 
    235230               ssh(:,:,Kmm) = ssh(:,:,Kbb) 
    236231               l_1st_euler = .TRUE. 
    … …  
    239234               IF(lwp) write(numout,*) 'sshb set equal to sshn.' 
    240235               IF(lwp) write(numout,*) 'neuler is forced to 0' 
    241                CALL iom_get( numror, jpdom_auto, 'sshn', ssh(:,:,Kmm), ldxios = lrxios ) 
     236               CALL iom_get( numror, jpdom_auto, 'sshn', ssh(:,:,Kmm) ) 
    242237               ssh(:,:,Kbb) = ssh(:,:,Kmm) 
    243238               l_1st_euler = .TRUE. 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/DOM/domutl.F90

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

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/DOM/domvvl.F90

    r13899 r14012  
    282282      ENDIF 
    283283      ! 
    284       IF(lwxios) THEN 
    285 ! define variables in restart file when writing with XIOS 
    286          CALL iom_set_rstw_var_active('e3t_b') 
    287          CALL iom_set_rstw_var_active('e3t_n') 
    288          !                                           ! ----------------------- ! 
    289          IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN  ! z_tilde and layer cases ! 
    290             !                                        ! ----------------------- ! 
    291             CALL iom_set_rstw_var_active('tilde_e3t_b') 
    292             CALL iom_set_rstw_var_active('tilde_e3t_n') 
    293          END IF 
    294          !                                           ! -------------!     
    295          IF( ln_vvl_ztilde ) THEN                    ! z_tilde case ! 
    296             !                                        ! ------------ ! 
    297             CALL iom_set_rstw_var_active('hdiv_lf') 
    298          ENDIF 
    299          ! 
    300       ENDIF 
    301       ! 
    302284   END SUBROUTINE dom_vvl_zgr 
    303285 
    … …  
    440422         !                             (stored for tracer advction and continuity equation) 
    441423         CALL lbc_lnk_multi( 'domvvl', un_td , 'U' , -1._wp, vn_td , 'V' , -1._wp) 
    442  
    443424         ! 4 - Time stepping of baroclinic scale factors 
    444425         ! --------------------------------------------- 
    … …  
    803784         IF( ln_rstart ) THEN                   !* Read the restart file 
    804785            CALL rst_read_open                  !  open the restart file if necessary 
    805             CALL iom_get( numror, jpdom_auto, 'sshn'   , ssh(:,:,Kmm), ldxios = lrxios    ) 
     786            CALL iom_get( numror, jpdom_auto, 'sshn'   , ssh(:,:,Kmm)    ) 
    806787            ! 
    807788            id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. ) 
    … …  
    816797            ! 
    817798            IF( MIN( id1, id2 ) > 0 ) THEN       ! all required arrays exist 
    818                CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios ) 
    819                CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios ) 
     799               CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) ) 
     800               CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) 
    820801               ! needed to restart if land processor not computed  
    821802               IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files' 
    … …  
    831812               IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.' 
    832813               IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 
    833                CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios ) 
     814               CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) ) 
    834815               e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 
    835816               l_1st_euler = .true. 
    … …  
    838819               IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.' 
    839820               IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 
    840                CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios ) 
     821               CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) 
    841822               e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 
    842823               l_1st_euler = .true. 
    … …  
    863844               !                          ! ----------------------- ! 
    864845               IF( MIN( id3, id4 ) > 0 ) THEN  ! all required arrays exist 
    865                   CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lrxios ) 
    866                   CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lrxios ) 
     846                  CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) ) 
     847                  CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:) ) 
    867848               ELSE                            ! one at least array is missing 
    868849                  tilde_e3t_b(:,:,:) = 0.0_wp 
    … …  
    873854                  !                       ! ------------ ! 
    874855                  IF( id5 > 0 ) THEN  ! required array exists 
    875                      CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lrxios ) 
     856                     CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:) ) 
    876857                  ELSE                ! array is missing 
    877858                     hdiv_lf(:,:,:) = 0.0_wp 
    … …  
    946927         !                                   ! =================== 
    947928         IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----' 
    948          IF( lwxios ) CALL iom_swap(      cwxios_context          ) 
    949929         !                                           ! --------- ! 
    950930         !                                           ! all cases ! 
    951931         !                                           ! --------- ! 
    952          CALL iom_rstput( kt, nitrst, numrow, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lwxios ) 
    953          CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lwxios ) 
     932         CALL iom_rstput( kt, nitrst, numrow, 'e3t_b', e3t(:,:,:,Kbb) ) 
     933         CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t(:,:,:,Kmm) ) 
    954934         !                                           ! ----------------------- ! 
    955935         IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN  ! z_tilde and layer cases ! 
    956936            !                                        ! ----------------------- ! 
    957             CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lwxios) 
    958             CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lwxios) 
     937            CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_b', tilde_e3t_b(:,:,:)) 
     938            CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:)) 
    959939         END IF 
    960940         !                                           ! -------------!     
    961941         IF( ln_vvl_ztilde ) THEN                    ! z_tilde case ! 
    962942            !                                        ! ------------ ! 
    963             CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lwxios) 
     943            CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:)) 
    964944         ENDIF 
    965945         ! 
    966          IF( lwxios ) CALL iom_swap(      cxios_context          ) 
    967946      ENDIF 
    968947      ! 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/DOM/dtatsd.F90

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

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/DYN/dynhpg.F90

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

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/DYN/dynspg_ts.F90

    r13899 r14012  
    900900         !                                   ! --------------- 
    901901         IF( ln_rstart .AND. ln_bt_fw .AND. (.NOT.l_1st_euler) ) THEN    !* Read the restart file 
    902             CALL iom_get( numror, jpdom_auto, 'ub2_b'  , ub2_b  (:,:), cd_type = 'U', psgn = -1._wp, ldxios = lrxios )    
    903             CALL iom_get( numror, jpdom_auto, 'vb2_b'  , vb2_b  (:,:), cd_type = 'V', psgn = -1._wp, ldxios = lrxios )  
    904             CALL iom_get( numror, jpdom_auto, 'un_bf'  , un_bf  (:,:), cd_type = 'U', psgn = -1._wp, ldxios = lrxios )    
    905             CALL iom_get( numror, jpdom_auto, 'vn_bf'  , vn_bf  (:,:), cd_type = 'V', psgn = -1._wp, ldxios = lrxios )  
     902            CALL iom_get( numror, jpdom_auto, 'ub2_b'  , ub2_b  (:,:), cd_type = 'U', psgn = -1._wp )    
     903            CALL iom_get( numror, jpdom_auto, 'vb2_b'  , vb2_b  (:,:), cd_type = 'V', psgn = -1._wp )  
     904            CALL iom_get( numror, jpdom_auto, 'un_bf'  , un_bf  (:,:), cd_type = 'U', psgn = -1._wp )    
     905            CALL iom_get( numror, jpdom_auto, 'vn_bf'  , vn_bf  (:,:), cd_type = 'V', psgn = -1._wp )  
    906906            IF( .NOT.ln_bt_av ) THEN 
    907                CALL iom_get( numror, jpdom_auto, 'sshbb_e'  , sshbb_e(:,:), cd_type = 'T', psgn =  1._wp, ldxios = lrxios )    
    908                CALL iom_get( numror, jpdom_auto, 'ubb_e'    ,   ubb_e(:,:), cd_type = 'U', psgn = -1._wp, ldxios = lrxios )    
    909                CALL iom_get( numror, jpdom_auto, 'vbb_e'    ,   vbb_e(:,:), cd_type = 'V', psgn = -1._wp, ldxios = lrxios ) 
    910                CALL iom_get( numror, jpdom_auto, 'sshb_e'   ,  sshb_e(:,:), cd_type = 'T', psgn =  1._wp, ldxios = lrxios )  
    911                CALL iom_get( numror, jpdom_auto, 'ub_e'     ,    ub_e(:,:), cd_type = 'U', psgn = -1._wp, ldxios = lrxios )    
    912                CALL iom_get( numror, jpdom_auto, 'vb_e'     ,    vb_e(:,:), cd_type = 'V', psgn = -1._wp, ldxios = lrxios ) 
     907               CALL iom_get( numror, jpdom_auto, 'sshbb_e'  , sshbb_e(:,:), cd_type = 'T', psgn =  1._wp )    
     908               CALL iom_get( numror, jpdom_auto, 'ubb_e'    ,   ubb_e(:,:), cd_type = 'U', psgn = -1._wp )    
     909               CALL iom_get( numror, jpdom_auto, 'vbb_e'    ,   vbb_e(:,:), cd_type = 'V', psgn = -1._wp ) 
     910               CALL iom_get( numror, jpdom_auto, 'sshb_e'   ,  sshb_e(:,:), cd_type = 'T', psgn =  1._wp )  
     911               CALL iom_get( numror, jpdom_auto, 'ub_e'     ,    ub_e(:,:), cd_type = 'U', psgn = -1._wp )    
     912               CALL iom_get( numror, jpdom_auto, 'vb_e'     ,    vb_e(:,:), cd_type = 'V', psgn = -1._wp ) 
    913913            ENDIF 
    914914#if defined key_agrif 
    915915            ! Read time integrated fluxes 
    916916            IF ( .NOT.Agrif_Root() ) THEN 
    917                CALL iom_get( numror, jpdom_auto, 'ub2_i_b'  , ub2_i_b(:,:), cd_type = 'U', psgn = -1._wp, ldxios = lrxios )    
    918                CALL iom_get( numror, jpdom_auto, 'vb2_i_b'  , vb2_i_b(:,:), cd_type = 'V', psgn = -1._wp, ldxios = lrxios ) 
     917               CALL iom_get( numror, jpdom_auto, 'ub2_i_b'  , ub2_i_b(:,:), cd_type = 'U', psgn = -1._wp )    
     918               CALL iom_get( numror, jpdom_auto, 'vb2_i_b'  , vb2_i_b(:,:), cd_type = 'V', psgn = -1._wp ) 
    919919            ELSE 
    920920               ub2_i_b(:,:) = 0._wp   ;   vb2_i_b(:,:) = 0._wp   ! used in the 1st update of agrif 
    … …  
    935935         !                                   ! ------------------- 
    936936         IF(lwp) WRITE(numout,*) '---- ts_rst ----' 
    937          IF( lwxios ) CALL iom_swap(      cwxios_context          ) 
    938          CALL iom_rstput( kt, nitrst, numrow, 'ub2_b'   , ub2_b  (:,:), ldxios = lwxios ) 
    939          CALL iom_rstput( kt, nitrst, numrow, 'vb2_b'   , vb2_b  (:,:), ldxios = lwxios ) 
    940          CALL iom_rstput( kt, nitrst, numrow, 'un_bf'   , un_bf  (:,:), ldxios = lwxios ) 
    941          CALL iom_rstput( kt, nitrst, numrow, 'vn_bf'   , vn_bf  (:,:), ldxios = lwxios ) 
     937         CALL iom_rstput( kt, nitrst, numrow, 'ub2_b'   , ub2_b  (:,:) ) 
     938         CALL iom_rstput( kt, nitrst, numrow, 'vb2_b'   , vb2_b  (:,:) ) 
     939         CALL iom_rstput( kt, nitrst, numrow, 'un_bf'   , un_bf  (:,:) ) 
     940         CALL iom_rstput( kt, nitrst, numrow, 'vn_bf'   , vn_bf  (:,:) ) 
    942941         ! 
    943942         IF (.NOT.ln_bt_av) THEN 
    944             CALL iom_rstput( kt, nitrst, numrow, 'sshbb_e'  , sshbb_e(:,:), ldxios = lwxios )  
    945             CALL iom_rstput( kt, nitrst, numrow, 'ubb_e'    ,   ubb_e(:,:), ldxios = lwxios ) 
    946             CALL iom_rstput( kt, nitrst, numrow, 'vbb_e'    ,   vbb_e(:,:), ldxios = lwxios ) 
    947             CALL iom_rstput( kt, nitrst, numrow, 'sshb_e'   ,  sshb_e(:,:), ldxios = lwxios ) 
    948             CALL iom_rstput( kt, nitrst, numrow, 'ub_e'     ,    ub_e(:,:), ldxios = lwxios ) 
    949             CALL iom_rstput( kt, nitrst, numrow, 'vb_e'     ,    vb_e(:,:), ldxios = lwxios ) 
     943            CALL iom_rstput( kt, nitrst, numrow, 'sshbb_e'  , sshbb_e(:,:) )  
     944            CALL iom_rstput( kt, nitrst, numrow, 'ubb_e'    ,   ubb_e(:,:) ) 
     945            CALL iom_rstput( kt, nitrst, numrow, 'vbb_e'    ,   vbb_e(:,:) ) 
     946            CALL iom_rstput( kt, nitrst, numrow, 'sshb_e'   ,  sshb_e(:,:) ) 
     947            CALL iom_rstput( kt, nitrst, numrow, 'ub_e'     ,    ub_e(:,:) ) 
     948            CALL iom_rstput( kt, nitrst, numrow, 'vb_e'     ,    vb_e(:,:) ) 
    950949         ENDIF 
    951950#if defined key_agrif 
    952951         ! Save time integrated fluxes 
    953952         IF ( .NOT.Agrif_Root() ) THEN 
    954             CALL iom_rstput( kt, nitrst, numrow, 'ub2_i_b'  , ub2_i_b(:,:), ldxios = lwxios ) 
    955             CALL iom_rstput( kt, nitrst, numrow, 'vb2_i_b'  , vb2_i_b(:,:), ldxios = lwxios ) 
     953            CALL iom_rstput( kt, nitrst, numrow, 'ub2_i_b'  , ub2_i_b(:,:) ) 
     954            CALL iom_rstput( kt, nitrst, numrow, 'vb2_i_b'  , vb2_i_b(:,:) ) 
    956955         ENDIF 
    957956#endif 
    958          IF( lwxios ) CALL iom_swap(      cxios_context          ) 
    959957      ENDIF 
    960958      ! 
    … …  
    10481046      !                             ! read restart when needed 
    10491047      CALL ts_rst( nit000, 'READ' ) 
    1050       ! 
    1051       IF( lwxios ) THEN 
    1052 ! define variables in restart file when writing with XIOS 
    1053          CALL iom_set_rstw_var_active('ub2_b') 
    1054          CALL iom_set_rstw_var_active('vb2_b') 
    1055          CALL iom_set_rstw_var_active('un_bf') 
    1056          CALL iom_set_rstw_var_active('vn_bf') 
    1057          ! 
    1058          IF (.NOT.ln_bt_av) THEN 
    1059             CALL iom_set_rstw_var_active('sshbb_e') 
    1060             CALL iom_set_rstw_var_active('ubb_e') 
    1061             CALL iom_set_rstw_var_active('vbb_e') 
    1062             CALL iom_set_rstw_var_active('sshb_e') 
    1063             CALL iom_set_rstw_var_active('ub_e') 
    1064             CALL iom_set_rstw_var_active('vb_e') 
    1065          ENDIF 
    1066 #if defined key_agrif 
    1067          ! Save time integrated fluxes 
    1068          IF ( .NOT.Agrif_Root() ) THEN 
    1069             CALL iom_set_rstw_var_active('ub2_i_b') 
    1070             CALL iom_set_rstw_var_active('vb2_i_b') 
    1071          ENDIF 
    1072 #endif 
    1073       ENDIF 
    10741048      ! 
    10751049   END SUBROUTINE dyn_spg_ts_init 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/IOM/in_out_manager.F90

    r13899 r14012  
    8989   LOGICAL ::   lrst_abl              !: logical to control the abl restart write  
    9090   INTEGER ::   numror = 0            !: logical unit for ocean restart (read). Init to 0 is needed for SAS (in daymod.F90) 
    91    INTEGER ::   numrir                !: logical unit for ice   restart (read) 
    92    INTEGER ::   numrar                !: logical unit for abl   restart (read) 
    93    INTEGER ::   numrow                !: logical unit for ocean restart (write) 
    94    INTEGER ::   numriw                !: logical unit for ice   restart (write) 
    95    INTEGER ::   numraw                !: logical unit for abl   restart (write) 
     91   INTEGER ::   numrir = 0            !: logical unit for ice   restart (read) 
     92   INTEGER ::   numrar = 0            !: logical unit for abl   restart (read) 
     93   INTEGER ::   numrow = 0            !: logical unit for ocean restart (write) 
     94   INTEGER ::   numriw = 0            !: logical unit for ice   restart (write) 
     95   INTEGER ::   numraw = 0            !: logical unit for abl   restart (write) 
     96   INTEGER ::   numrtr = 0            !: trc restart (read ) 
     97   INTEGER ::   numrtw = 0            !: trc restart (write ) 
     98   INTEGER ::   numrsr = 0            !: logical unit for sed restart (read) 
     99   INTEGER ::   numrsw = 0            !: logical unit for sed restart (write) 
     100 
    96101   INTEGER ::   nrst_lst              !: number of restart to output next 
    97102 
    … …  
    165170   LOGICAL       ::   lwp      = .FALSE.    !: boolean : true on the 1st processor only .OR. sn_cfctl%l_oceout=T 
    166171   LOGICAL       ::   lsp_area = .TRUE.     !: to make a control print over a specific area 
    167    CHARACTER(lc) ::   cxios_context         !: context name used in xios 
    168    CHARACTER(lc) ::   crxios_context         !: context name used in xios to read restart 
    169    CHARACTER(lc) ::   cwxios_context        !: context name used in xios to write restart file 
     172   CHARACTER(LEN=lc) ::   cxios_context     !: context name used in xios 
     173   CHARACTER(LEN=lc) ::   cr_ocerst_cxt     !: context name used in xios to read OCE restart 
     174   CHARACTER(LEN=lc) ::   cw_ocerst_cxt     !: context name used in xios to write OCE restart file 
     175   CHARACTER(LEN=lc) ::   cr_icerst_cxt     !: context name used in xios to read SI3 restart 
     176   CHARACTER(LEN=lc) ::   cw_icerst_cxt     !: context name used in xios to write SI3 restart file 
     177   CHARACTER(LEN=lc) ::   cr_toprst_cxt     !: context name used in xios to read TOP restart 
     178   CHARACTER(LEN=lc) ::   cw_toprst_cxt     !: context name used in xios to write TOP restart file 
     179   CHARACTER(LEN=lc) ::   cr_sedrst_cxt     !: context name used in xios to read SEDIMENT restart 
     180   CHARACTER(LEN=lc) ::   cw_sedrst_cxt     !: context name used in xios to write SEDIMENT restart file 
     181 
     182 
     183 
    170184 
    171185   !! * Substitutions 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/IOM/iom.F90

    r13899 r14012  
    4646   USE lib_fortran  
    4747   USE diu_bulk, ONLY : ln_diurnal_only, ln_diurnal 
     48   USE iom_nf90 
     49   USE netcdf 
    4850 
    4951   IMPLICIT NONE 
    … …  
    5860   PUBLIC iom_chkatt, iom_getatt, iom_putatt, iom_getszuld, iom_rstput, iom_delay_rst, iom_put 
    5961   PUBLIC iom_use, iom_context_finalize, iom_update_file_name, iom_miss_val 
     62   PUBLIC iom_xios_setid 
    6063 
    6164   PRIVATE iom_rp0d_sp, iom_rp1d_sp, iom_rp2d_sp, iom_rp3d_sp 
    … …  
    6972   PRIVATE iom_set_domain_attr, iom_set_axis_attr, iom_set_field_attr, iom_set_file_attr, iom_get_file_attr, iom_set_grid_attr 
    7073   PRIVATE set_grid, set_grid_bounds, set_scalar, set_xmlatt, set_mooring, iom_sdate 
    71    PRIVATE iom_set_rst_context, iom_set_rstw_active, iom_set_rstr_active 
     74   PRIVATE iom_set_rst_context, iom_set_vars_active 
    7275# endif 
    73    PUBLIC iom_set_rstw_var_active, iom_set_rstw_core, iom_set_rst_vars 
     76   PRIVATE set_xios_context 
     77   PRIVATE iom_set_rstw_active 
    7478 
    7579   INTERFACE iom_get 
    … …  
    101105CONTAINS 
    102106 
    103    SUBROUTINE iom_init( cdname, fname, ld_closedef )  
     107   SUBROUTINE iom_init( cdname, kdid, ld_closedef )  
    104108      !!---------------------------------------------------------------------- 
    105109      !!                     ***  ROUTINE   *** 
    … …  
    109113      !!---------------------------------------------------------------------- 
    110114      CHARACTER(len=*),           INTENT(in)  :: cdname 
    111       CHARACTER(len=*), OPTIONAL, INTENT(in)  :: fname 
     115      INTEGER         , OPTIONAL, INTENT(in)  :: kdid           
    112116      LOGICAL         , OPTIONAL, INTENT(in)  :: ld_closedef 
    113117#if defined key_iomput 
    … …  
    118122      INTEGER             :: irefyear, irefmonth, irefday 
    119123      INTEGER           :: ji 
    120       LOGICAL :: llrst_context              ! is context related to restart 
     124      LOGICAL           :: llrst_context              ! is context related to restart 
     125      LOGICAL           :: llrstr, llrstw  
     126      INTEGER           :: inum 
    121127      ! 
    122128      REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zt_bnds, zw_bnds 
    123129      REAL(wp), DIMENSION(2,jpkam1)         :: za_bnds   ! ABL vertical boundaries 
    124       LOGICAL ::   ll_closedef = .TRUE. 
     130      LOGICAL ::   ll_closedef 
    125131      LOGICAL ::   ll_exist 
    126132      !!---------------------------------------------------------------------- 
    127133      ! 
     134      ll_closedef = .TRUE. 
    128135      IF ( PRESENT(ld_closedef) ) ll_closedef = ld_closedef 
    129136      ! 
    … …  
    134141      CALL xios_context_initialize(TRIM(clname), mpi_comm_oce) 
    135142      CALL iom_swap( cdname ) 
    136       llrst_context =  (TRIM(cdname) == TRIM(crxios_context) .OR. TRIM(cdname) == TRIM(cwxios_context)) 
     143 
     144      llrstr = (cdname == cr_ocerst_cxt) .OR. (cdname == cr_icerst_cxt) 
     145      llrstr = llrstr .OR. (cdname == cr_toprst_cxt) 
     146      llrstr = llrstr .OR. (cdname == cr_sedrst_cxt) 
     147 
     148      llrstw = (cdname == cw_ocerst_cxt) .OR. (cdname == cw_icerst_cxt) 
     149      llrstw = llrstw .OR. (cdname == cw_toprst_cxt) 
     150      llrstw = llrstw .OR. (cdname == cw_sedrst_cxt) 
     151 
     152      llrst_context = llrstr .OR. llrstw 
    137153 
    138154      ! Calendar type is now defined in xml file  
    … …  
    153169      IF(.NOT.llrst_context) CALL set_scalar 
    154170      ! 
    155       IF( TRIM(cdname) == TRIM(cxios_context) ) THEN   
     171      IF( cdname == cxios_context ) THEN   
    156172         CALL set_grid( "T", glamt, gphit, .FALSE., .FALSE. )  
    157173         CALL set_grid( "U", glamu, gphiu, .FALSE., .FALSE. ) 
    … …  
    197213      ! vertical grid definition 
    198214      IF(.NOT.llrst_context) THEN 
    199           CALL iom_set_axis_attr(  "deptht", paxis = gdept_1d ) 
    200           CALL iom_set_axis_attr(  "depthu", paxis = gdept_1d ) 
    201           CALL iom_set_axis_attr(  "depthv", paxis = gdept_1d ) 
    202           CALL iom_set_axis_attr(  "depthw", paxis = gdepw_1d ) 
     215         CALL iom_set_axis_attr(  "deptht", paxis = gdept_1d ) 
     216         CALL iom_set_axis_attr(  "depthu", paxis = gdept_1d ) 
     217         CALL iom_set_axis_attr(  "depthv", paxis = gdept_1d ) 
     218         CALL iom_set_axis_attr(  "depthw", paxis = gdepw_1d ) 
    203219 
    204220          ! ABL 
    205           IF( .NOT. ALLOCATED(ght_abl) ) THEN   ! force definition for xml files (xios)  
    206              ALLOCATE( ght_abl(jpka), ghw_abl(jpka), e3t_abl(jpka), e3w_abl(jpka) )   ! default allocation needed by iom 
    207              ght_abl(:) = -1._wp   ;   ghw_abl(:) = -1._wp 
    208              e3t_abl(:) = -1._wp   ;   e3w_abl(:) = -1._wp 
    209           ENDIF 
    210           CALL iom_set_axis_attr( "ght_abl", ght_abl(2:jpka) ) 
    211           CALL iom_set_axis_attr( "ghw_abl", ghw_abl(2:jpka) ) 
     221         IF( .NOT. ALLOCATED(ght_abl) ) THEN   ! force definition for xml files (xios)  
     222            ALLOCATE( ght_abl(jpka), ghw_abl(jpka), e3t_abl(jpka), e3w_abl(jpka) )   ! default allocation needed by iom 
     223            ght_abl(:) = -1._wp   ;   ghw_abl(:) = -1._wp 
     224            e3t_abl(:) = -1._wp   ;   e3w_abl(:) = -1._wp 
     225         ENDIF 
     226         CALL iom_set_axis_attr( "ght_abl", ght_abl(2:jpka) ) 
     227         CALL iom_set_axis_attr( "ghw_abl", ghw_abl(2:jpka) ) 
    212228           
    213           ! Add vertical grid bounds 
    214           zt_bnds(2,:      ) = gdept_1d(:) 
    215           zt_bnds(1,2:jpk  ) = gdept_1d(1:jpkm1) 
    216           zt_bnds(1,1      ) = gdept_1d(1) - e3w_1d(1) 
    217           zw_bnds(1,:      ) = gdepw_1d(:) 
    218           zw_bnds(2,1:jpkm1) = gdepw_1d(2:jpk) 
    219           zw_bnds(2,jpk:   ) = gdepw_1d(jpk) + e3t_1d(jpk) 
    220           CALL iom_set_axis_attr(  "deptht", bounds=zw_bnds ) 
    221           CALL iom_set_axis_attr(  "depthu", bounds=zw_bnds ) 
    222           CALL iom_set_axis_attr(  "depthv", bounds=zw_bnds ) 
    223           CALL iom_set_axis_attr(  "depthw", bounds=zt_bnds ) 
    224  
    225           ! ABL 
    226           za_bnds(1,:) = ghw_abl(1:jpkam1) 
    227           za_bnds(2,:) = ghw_abl(2:jpka  ) 
    228           CALL iom_set_axis_attr( "ght_abl", bounds=za_bnds ) 
    229           za_bnds(1,:) = ght_abl(2:jpka  ) 
    230           za_bnds(2,:) = ght_abl(2:jpka  ) + e3w_abl(2:jpka) 
    231           CALL iom_set_axis_attr( "ghw_abl", bounds=za_bnds ) 
    232  
    233           CALL iom_set_axis_attr(  "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) ) 
     229         ! Add vertical grid bounds 
     230         zt_bnds(2,:      ) = gdept_1d(:) 
     231         zt_bnds(1,2:jpk  ) = gdept_1d(1:jpkm1) 
     232         zt_bnds(1,1      ) = gdept_1d(1) - e3w_1d(1) 
     233         zw_bnds(1,:      ) = gdepw_1d(:) 
     234         zw_bnds(2,1:jpkm1) = gdepw_1d(2:jpk) 
     235         zw_bnds(2,jpk:   ) = gdepw_1d(jpk) + e3t_1d(jpk) 
     236         CALL iom_set_axis_attr(  "deptht", bounds=zw_bnds ) 
     237         CALL iom_set_axis_attr(  "depthu", bounds=zw_bnds ) 
     238         CALL iom_set_axis_attr(  "depthv", bounds=zw_bnds ) 
     239         CALL iom_set_axis_attr(  "depthw", bounds=zt_bnds ) 
     240 
     241         ! ABL 
     242         za_bnds(1,:) = ghw_abl(1:jpkam1) 
     243         za_bnds(2,:) = ghw_abl(2:jpka  ) 
     244         CALL iom_set_axis_attr( "ght_abl", bounds=za_bnds ) 
     245         za_bnds(1,:) = ght_abl(2:jpka  ) 
     246         za_bnds(2,:) = ght_abl(2:jpka  ) + e3w_abl(2:jpka) 
     247         CALL iom_set_axis_attr( "ghw_abl", bounds=za_bnds ) 
     248 
     249         CALL iom_set_axis_attr(  "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) ) 
    234250# if defined key_si3 
    235           CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) 
    236           ! SIMIP diagnostics (4 main arctic straits) 
    237           CALL iom_set_axis_attr( "nstrait", (/ (REAL(ji,wp), ji=1,4) /) ) 
     251         CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) 
     252         ! SIMIP diagnostics (4 main arctic straits) 
     253         CALL iom_set_axis_attr( "nstrait", (/ (REAL(ji,wp), ji=1,4) /) ) 
    238254# endif 
    239255#if defined key_top 
    240           IF( ALLOCATED(profsed) ) CALL iom_set_axis_attr( "profsed", paxis = profsed ) 
    241 #endif 
    242           CALL iom_set_axis_attr( "icbcla", class_num ) 
    243           CALL iom_set_axis_attr( "iax_20C", (/ REAL(20,wp) /) )   ! strange syntaxe and idea... 
    244           CALL iom_set_axis_attr( "iax_26C", (/ REAL(26,wp) /) )   ! strange syntaxe and idea... 
    245           CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) )   ! strange syntaxe and idea... 
    246           ! for diaprt, we need to define an axis which size can be 1 (default) or 5 (if the file subbasins.nc exists) 
    247           INQUIRE( FILE = 'subbasins.nc', EXIST = ll_exist ) 
    248           nbasin = 1 + 4 * COUNT( (/ll_exist/) ) 
    249           CALL iom_set_axis_attr( "basin"  , (/ (REAL(ji,wp), ji=1,nbasin) /) ) 
     256         IF( ALLOCATED(profsed) ) CALL iom_set_axis_attr( "profsed", paxis = profsed ) 
     257#endif 
     258         CALL iom_set_axis_attr( "icbcla", class_num ) 
     259         CALL iom_set_axis_attr( "iax_20C", (/ REAL(20,wp) /) )   ! strange syntaxe and idea... 
     260         CALL iom_set_axis_attr( "iax_26C", (/ REAL(26,wp) /) )   ! strange syntaxe and idea... 
     261         CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) )   ! strange syntaxe and idea... 
     262         ! for diaprt, we need to define an axis which size can be 1 (default) or 5 (if the file subbasins.nc exists) 
     263         INQUIRE( FILE = 'subbasins.nc', EXIST = ll_exist ) 
     264         nbasin = 1 + 4 * COUNT( (/ll_exist/) ) 
     265         CALL iom_set_axis_attr( "basin"  , (/ (REAL(ji,wp), ji=1,nbasin) /) ) 
    250266      ENDIF 
    251267      ! 
    252268      ! automatic definitions of some of the xml attributs 
    253       IF( TRIM(cdname) == TRIM(crxios_context) ) THEN 
    254 !set names of the fields in restart file IF using XIOS to read data 
    255           CALL iom_set_rst_context(.TRUE.) 
    256           CALL iom_set_rst_vars(rst_rfields) 
    257 !set which fields are to be read from restart file 
    258           CALL iom_set_rstr_active() 
    259       ELSE IF( TRIM(cdname) == TRIM(cwxios_context) ) THEN 
    260 !set names of the fields in restart file IF using XIOS to write data 
    261           CALL iom_set_rst_context(.FALSE.) 
    262           CALL iom_set_rst_vars(rst_wfields) 
    263 !set which fields are to be written to a restart file 
    264           CALL iom_set_rstw_active(fname) 
     269      IF(llrstr) THEN 
     270         IF(PRESENT(kdid)) THEN 
     271            CALL iom_set_rst_context(.TRUE.) 
     272!set which fields will be read from restart file 
     273            CALL iom_set_vars_active(kdid) 
     274         ELSE 
     275            CALL ctl_stop( 'iom_init:', 'restart read with XIOS: missing pointer to NETCDF file' ) 
     276         ENDIF 
     277      ELSE IF(llrstw) THEN 
     278         CALL iom_set_rstw_file(iom_file(kdid)%name) 
    265279      ELSE 
    266           CALL set_xmlatt 
     280         CALL set_xmlatt 
    267281      ENDIF 
    268282      ! 
    … …  
    280294   END SUBROUTINE iom_init 
    281295 
    282    SUBROUTINE iom_init_closedef 
     296   SUBROUTINE iom_init_closedef(cdname) 
    283297      !!---------------------------------------------------------------------- 
    284298      !!            ***  SUBROUTINE iom_init_closedef  *** 
    … …  
    288302      !! 
    289303      !!---------------------------------------------------------------------- 
    290  
     304      CHARACTER(len=*), OPTIONAL, INTENT(IN) :: cdname 
    291305#if defined key_iomput 
    292       CALL xios_close_context_definition() 
    293       CALL xios_update_calendar( 0 ) 
     306      LOGICAL :: llrstw 
     307 
     308      llrstw = .FALSE. 
     309      IF(PRESENT(cdname)) THEN 
     310         llrstw = (cdname == cw_ocerst_cxt) 
     311         llrstw = llrstw .OR. (cdname == cw_icerst_cxt) 
     312         llrstw = llrstw .OR. (cdname == cw_toprst_cxt) 
     313         llrstw = llrstw .OR. (cdname == cw_sedrst_cxt) 
     314      ENDIF 
     315 
     316      IF( llrstw ) THEN 
     317!set names of the fields in restart file IF using XIOS to write data 
     318         CALL iom_set_rst_context(.FALSE.) 
     319         CALL xios_close_context_definition() 
     320      ELSE 
     321         CALL xios_close_context_definition() 
     322         CALL xios_update_calendar( 0 ) 
     323      ENDIF 
    294324#else 
    295325      IF( .FALSE. )   WRITE(numout,*) 'iom_init_closedef: should not see this'   ! useless statement to avoid compilation warnings 
    … …  
    298328   END SUBROUTINE iom_init_closedef 
    299329 
    300    SUBROUTINE iom_set_rstw_var_active(field) 
     330   SUBROUTINE iom_set_vars_active(idnum) 
    301331      !!--------------------------------------------------------------------- 
    302       !!                   ***  SUBROUTINE  iom_set_rstw_var_active  *** 
    303       !! 
    304       !! ** Purpose :  enable variable in restart file when writing with XIOS  
     332      !!                   ***  SUBROUTINE  iom_set_vars_active  *** 
     333      !! 
     334      !! ** Purpose :  define filename in XIOS context for reading file, 
     335      !!               enable variables present in a file for reading with XIOS  
     336      !!               id of the file is assumed to be rrestart. 
    305337      !!--------------------------------------------------------------------- 
    306    CHARACTER(len = *), INTENT(IN) :: field 
    307    INTEGER :: i 
    308    LOGICAL :: llis_set 
    309    CHARACTER(LEN=256) :: clinfo    ! info character 
    310  
     338      INTEGER, INTENT(IN) :: idnum  
     339       
    311340#if defined key_iomput 
    312    llis_set = .FALSE. 
    313  
    314    DO i = 1, max_rst_fields 
    315        IF(TRIM(rst_wfields(i)%vname) == field) THEN  
    316           rst_wfields(i)%active = .TRUE. 
    317           llis_set = .TRUE. 
    318           EXIT 
    319        ENDIF 
    320    ENDDO 
    321 !Warn if variable is not in defined in rst_wfields 
    322    IF(.NOT.llis_set) THEN 
    323       WRITE(ctmp1,*) 'iom_set_rstw_var_active: variable ', field ,' is available for writing but not defined'  
    324       CALL ctl_stop( 'iom_set_rstw_var_active:', ctmp1 ) 
    325    ENDIF 
    326 #else 
    327         clinfo = 'iom_set_rstw_var_active: key_iomput is needed to use XIOS restart read/write functionality' 
    328         CALL ctl_stop('STOP', TRIM(clinfo)) 
    329 #endif 
    330  
    331    END SUBROUTINE iom_set_rstw_var_active 
    332  
    333    SUBROUTINE iom_set_rstr_active() 
     341      INTEGER                                    :: ndims, nvars, natts, unlimitedDimId, dimlen, xtype,mdims 
     342      TYPE(xios_field)                           :: field_hdl 
     343      TYPE(xios_file)                            :: file_hdl 
     344      TYPE(xios_filegroup)                       :: filegroup_hdl 
     345      INTEGER                                    :: dimids(4), jv,i, idim 
     346      CHARACTER(LEN=256)                         :: clinfo               ! info character 
     347      INTEGER, ALLOCATABLE                       :: indimlens(:) 
     348      CHARACTER(LEN=nf90_max_name), ALLOCATABLE  :: indimnames(:) 
     349      CHARACTER(LEN=nf90_max_name)               :: dimname, varname 
     350      INTEGER                                    :: iln 
     351      CHARACTER(LEN=lc)                          :: fname 
     352      LOGICAL                                    :: lmeta 
     353!metadata in restart file for restart read with XIOS 
     354      INTEGER, PARAMETER                         :: NMETA = 10 
     355      CHARACTER(LEN=lc)                          :: meta(NMETA) 
     356 
     357 
     358      meta(1) = "nav_lat" 
     359      meta(2) = "nav_lon" 
     360      meta(3) = "nav_lev" 
     361      meta(4) = "time_instant" 
     362      meta(5) = "time_instant_bounds" 
     363      meta(6) = "time_counter" 
     364      meta(7) = "time_counter_bounds" 
     365      meta(8) = "x" 
     366      meta(9) = "y" 
     367      meta(10) = "numcat" 
     368 
     369      clinfo = '          iom_set_vars_active, file: '//TRIM(iom_file(idnum)%name) 
     370 
     371      iln = INDEX( iom_file(idnum)%name, '.nc' ) 
     372!XIOS doee not need .nc 
     373      IF(iln > 0) THEN 
     374        fname =  iom_file(idnum)%name(1:iln-1) 
     375      ELSE 
     376        fname =  iom_file(idnum)%name 
     377      ENDIF 
     378 
     379!set name of the restart file and enable available fields 
     380      CALL xios_get_handle("file_definition", filegroup_hdl ) 
     381      CALL xios_add_child(filegroup_hdl, file_hdl, 'rrestart') 
     382      CALL xios_set_file_attr( "rrestart", name=fname, type="one_file",      & 
     383           par_access="collective", enabled=.TRUE., mode="read",              & 
     384                                                    output_freq=xios_timestep ) 
     385 
     386      CALL iom_nf90_check( nf90_inquire(iom_file(idnum)%nfid, ndims, nvars, natts ), clinfo ) 
     387      ALLOCATE(indimlens(ndims), indimnames(ndims)) 
     388      CALL iom_nf90_check( nf90_inquire(iom_file(idnum)%nfid, unlimitedDimId = unlimitedDimId ), clinfo ) 
     389 
     390      DO idim = 1, ndims 
     391         CALL iom_nf90_check( nf90_inquire_dimension(iom_file(idnum)%nfid, idim, dimname, dimlen ), clinfo ) 
     392         indimlens(idim) = dimlen 
     393         indimnames(idim) = dimname 
     394      ENDDO 
     395 
     396      DO jv =1, nvars 
     397         lmeta = .FALSE. 
     398         CALL iom_nf90_check( nf90_inquire_variable(iom_file(idnum)%nfid, jv, varname, xtype, ndims, dimids, natts ), clinfo ) 
     399         DO i = 1, NMETA 
     400           IF(varname == meta(i)) THEN 
     401             lmeta = .TRUE. 
     402           ENDIF 
     403         ENDDO 
     404         IF(.NOT.lmeta) THEN 
     405            CALL xios_add_child(file_hdl, field_hdl, varname) 
     406            mdims = ndims 
     407 
     408            IF(ANY(dimids(1:ndims) == unlimitedDimId)) THEN 
     409               mdims = mdims - 1 
     410            ENDIF 
     411 
     412            IF(mdims == 3) THEN 
     413               CALL xios_set_attr (field_hdl, enabled = .TRUE., name = varname,   & 
     414                                   domain_ref="grid_N",                           & 
     415                                   axis_ref=iom_axis(indimlens(dimids(mdims))),   & 
     416                                   prec = 8, operation = "instant"                ) 
     417            ELSEIF(mdims == 2) THEN 
     418               CALL xios_set_attr (field_hdl, enabled = .TRUE., name = varname,  & 
     419                                   domain_ref="grid_N", prec = 8,                & 
     420                                   operation = "instant"                         )  
     421            ELSEIF(mdims == 1) THEN 
     422               CALL xios_set_attr (field_hdl, enabled = .TRUE., name = varname, & 
     423                                   axis_ref=iom_axis(indimlens(dimids(mdims))), & 
     424                                   prec = 8, operation = "instant"              ) 
     425            ELSEIF(mdims == 0) THEN 
     426               CALL xios_set_attr (field_hdl, enabled = .TRUE., name = varname, & 
     427                                   scalar_ref = "grid_scalar", prec = 8,        & 
     428                                   operation = "instant"                        ) 
     429            ELSE 
     430               WRITE(ctmp1,*) 'iom_set_vars_active: variable ', TRIM(varname) ,' incorrect number of dimensions'  
     431               CALL ctl_stop( 'iom_set_vars_active:', ctmp1 ) 
     432            ENDIF 
     433         ENDIF 
     434      ENDDO 
     435      DEALLOCATE(indimlens, indimnames) 
     436#endif 
     437   END SUBROUTINE iom_set_vars_active 
     438 
     439   SUBROUTINE iom_set_rstw_file(cdrst_file) 
    334440      !!--------------------------------------------------------------------- 
    335       !!                   ***  SUBROUTINE  iom_set_rstr_active  *** 
    336       !! 
    337       !! ** Purpose :  define file name in XIOS context for reading restart file, 
    338       !!               enable variables present in restart file for reading with XIOS  
     441      !!                   ***  SUBROUTINE iom_set_rstw_file   *** 
     442      !! 
     443      !! ** Purpose :  define file name in XIOS context for writing restart 
    339444      !!--------------------------------------------------------------------- 
    340  
    341 !sets enabled = .TRUE. for each field in restart file 
    342    CHARACTER(len=256) :: rst_file 
    343  
     445      CHARACTER(len=*) :: cdrst_file 
    344446#if defined key_iomput 
    345    TYPE(xios_field) :: field_hdl 
    346    TYPE(xios_file) :: file_hdl 
    347    TYPE(xios_filegroup) :: filegroup_hdl 
    348    INTEGER :: i 
    349    CHARACTER(lc)  ::   clpath 
    350  
    351         clpath = TRIM(cn_ocerst_indir) 
    352         IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' 
    353         IF( TRIM(Agrif_CFixed()) == '0' ) THEN 
    354            rst_file = TRIM(clpath)//TRIM(cn_ocerst_in) 
    355         ELSE 
    356            rst_file = TRIM(clpath)//TRIM(Agrif_CFixed())//'_'//TRIM(cn_ocerst_in) 
    357         ENDIF 
     447      TYPE(xios_file) :: file_hdl 
     448      TYPE(xios_filegroup) :: filegroup_hdl 
     449 
    358450!set name of the restart file and enable available fields 
    359         if(lwp) WRITE(numout,*) 'Setting restart filename (for XIOS) to: ',rst_file 
    360         CALL xios_get_handle("file_definition", filegroup_hdl ) 
    361         CALL xios_add_child(filegroup_hdl, file_hdl, 'rrestart') 
    362         CALL xios_set_file_attr( "rrestart", name=trim(rst_file), type="one_file", & 
    363              par_access="collective", enabled=.TRUE., mode="read",                 & 
    364              output_freq=xios_timestep) 
    365 !define variables for restart context 
    366         DO i = 1, max_rst_fields 
    367          IF( TRIM(rst_rfields(i)%vname) /= "NO_NAME") THEN 
    368            IF( iom_varid( numror, TRIM(rst_rfields(i)%vname), ldstop = .FALSE. ) > 0 ) THEN 
    369                 CALL xios_add_child(file_hdl, field_hdl, TRIM(rst_rfields(i)%vname)) 
    370                 SELECT CASE (TRIM(rst_rfields(i)%grid)) 
    371                  CASE ("grid_N_3D") 
    372                     CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_rfields(i)%vname), & 
    373                         domain_ref="grid_N", axis_ref="nav_lev", operation = "instant") 
    374                  CASE ("grid_N") 
    375                     CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_rfields(i)%vname), & 
    376                         domain_ref="grid_N", operation = "instant")  
    377                 CASE ("grid_vector") 
    378                     CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_rfields(i)%vname), & 
    379                          axis_ref="nav_lev", operation = "instant") 
    380                  CASE ("grid_scalar") 
    381                     CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_rfields(i)%vname), & 
    382                         scalar_ref = "grid_scalar", operation = "instant") 
    383                 END SELECT 
    384                 IF(lwp) WRITE(numout,*) 'XIOS read: ', TRIM(rst_rfields(i)%vname), ' enabled in ', TRIM(rst_file) 
    385            ENDIF 
    386          ENDIF 
    387         END DO 
    388 #endif 
    389    END SUBROUTINE iom_set_rstr_active 
    390  
    391    SUBROUTINE iom_set_rstw_core(cdmdl) 
    392       !!--------------------------------------------------------------------- 
    393       !!                   ***  SUBROUTINE  iom_set_rstw_core  *** 
    394       !! 
    395       !! ** Purpose :  set variables which are always in restart file  
    396       !!--------------------------------------------------------------------- 
    397    CHARACTER (len=*), INTENT (IN) :: cdmdl ! model OPA or SAS 
    398    CHARACTER(LEN=256)             :: clinfo    ! info character 
    399 #if defined key_iomput 
    400    IF(cdmdl == "OPA") THEN 
    401 !from restart.F90 
    402    CALL iom_set_rstw_var_active("rn_Dt") 
    403    IF ( .NOT. ln_diurnal_only ) THEN 
    404         CALL iom_set_rstw_var_active('ub'  ) 
    405         CALL iom_set_rstw_var_active('vb'  ) 
    406         CALL iom_set_rstw_var_active('tb'  ) 
    407         CALL iom_set_rstw_var_active('sb'  ) 
    408         CALL iom_set_rstw_var_active('sshb') 
    409         ! 
    410         CALL iom_set_rstw_var_active('un'  ) 
    411         CALL iom_set_rstw_var_active('vn'  ) 
    412         CALL iom_set_rstw_var_active('tn'  ) 
    413         CALL iom_set_rstw_var_active('sn'  ) 
    414         CALL iom_set_rstw_var_active('sshn') 
    415         CALL iom_set_rstw_var_active('rhop') 
    416       ENDIF 
    417       IF(ln_diurnal) CALL iom_set_rstw_var_active('Dsst') 
    418 !from trasbc.F90 
    419          CALL iom_set_rstw_var_active('sbc_hc_b') 
    420          CALL iom_set_rstw_var_active('sbc_sc_b') 
    421    ENDIF 
    422 #else 
    423         clinfo = 'iom_set_rstw_core: key_iomput is needed to use XIOS restart read/write functionality' 
    424         CALL ctl_stop('STOP', TRIM(clinfo)) 
    425 #endif 
    426    END SUBROUTINE iom_set_rstw_core 
    427  
    428    SUBROUTINE iom_set_rst_vars(fields) 
    429       !!--------------------------------------------------------------------- 
    430       !!                   ***  SUBROUTINE iom_set_rst_vars   *** 
    431       !! 
    432       !! ** Purpose :  Fill array fields with the information about all  
    433       !!               possible variables and corresponding grids definition  
    434       !!               for reading/writing restart with XIOS 
    435       !!--------------------------------------------------------------------- 
    436    TYPE(RST_FIELD), INTENT(INOUT) :: fields(max_rst_fields) 
    437    INTEGER :: i 
    438  
    439         i = 0 
    440         i = i + 1; fields(i)%vname="rn_Dt";            fields(i)%grid="grid_scalar" 
    441         i = i + 1; fields(i)%vname="un";             fields(i)%grid="grid_N_3D" 
    442         i = i + 1; fields(i)%vname="ub";             fields(i)%grid="grid_N_3D" 
    443         i = i + 1; fields(i)%vname="vn";             fields(i)%grid="grid_N_3D" 
    444         i = i + 1; fields(i)%vname="vb";             fields(i)%grid="grid_N_3D"   
    445         i = i + 1; fields(i)%vname="tn";             fields(i)%grid="grid_N_3D" 
    446         i = i + 1; fields(i)%vname="tb";             fields(i)%grid="grid_N_3D" 
    447         i = i + 1; fields(i)%vname="sn";             fields(i)%grid="grid_N_3D" 
    448         i = i + 1; fields(i)%vname="sb";             fields(i)%grid="grid_N_3D" 
    449         i = i + 1; fields(i)%vname="sshn";           fields(i)%grid="grid_N" 
    450         i = i + 1; fields(i)%vname="sshb";           fields(i)%grid="grid_N" 
    451         i = i + 1; fields(i)%vname="rhop";           fields(i)%grid="grid_N_3D" 
    452         i = i + 1; fields(i)%vname="kt";             fields(i)%grid="grid_scalar" 
    453         i = i + 1; fields(i)%vname="ndastp";         fields(i)%grid="grid_scalar" 
    454         i = i + 1; fields(i)%vname="adatrj";         fields(i)%grid="grid_scalar" 
    455         i = i + 1; fields(i)%vname="utau_b";         fields(i)%grid="grid_N" 
    456         i = i + 1; fields(i)%vname="vtau_b";         fields(i)%grid="grid_N" 
    457         i = i + 1; fields(i)%vname="qns_b";          fields(i)%grid="grid_N" 
    458         i = i + 1; fields(i)%vname="emp_b";          fields(i)%grid="grid_N" 
    459         i = i + 1; fields(i)%vname="sfx_b";          fields(i)%grid="grid_N" 
    460         i = i + 1; fields(i)%vname="en" ;            fields(i)%grid="grid_N_3D"  
    461         i = i + 1; fields(i)%vname="avt_k";            fields(i)%grid="grid_N_3D" 
    462         i = i + 1; fields(i)%vname="avm_k";            fields(i)%grid="grid_N_3D" 
    463         i = i + 1; fields(i)%vname="dissl";          fields(i)%grid="grid_N_3D" 
    464         i = i + 1; fields(i)%vname="sbc_hc_b";       fields(i)%grid="grid_N" 
    465         i = i + 1; fields(i)%vname="sbc_sc_b";       fields(i)%grid="grid_N" 
    466         i = i + 1; fields(i)%vname="qsr_hc_b";       fields(i)%grid="grid_N_3D" 
    467         i = i + 1; fields(i)%vname="fraqsr_1lev";    fields(i)%grid="grid_N" 
    468         i = i + 1; fields(i)%vname="greenland_icesheet_mass" 
    469                                                fields(i)%grid="grid_scalar" 
    470         i = i + 1; fields(i)%vname="greenland_icesheet_timelapsed" 
    471                                                fields(i)%grid="grid_scalar" 
    472         i = i + 1; fields(i)%vname="greenland_icesheet_mass_roc" 
    473                                                fields(i)%grid="grid_scalar" 
    474         i = i + 1; fields(i)%vname="antarctica_icesheet_mass" 
    475                                                fields(i)%grid="grid_scalar" 
    476         i = i + 1; fields(i)%vname="antarctica_icesheet_timelapsed" 
    477                                                fields(i)%grid="grid_scalar" 
    478         i = i + 1; fields(i)%vname="antarctica_icesheet_mass_roc" 
    479                                                fields(i)%grid="grid_scalar" 
    480         i = i + 1; fields(i)%vname="frc_v";          fields(i)%grid="grid_scalar" 
    481         i = i + 1; fields(i)%vname="frc_t";          fields(i)%grid="grid_scalar" 
    482         i = i + 1; fields(i)%vname="frc_s";          fields(i)%grid="grid_scalar" 
    483         i = i + 1; fields(i)%vname="frc_wn_t";       fields(i)%grid="grid_scalar" 
    484         i = i + 1; fields(i)%vname="frc_wn_s";       fields(i)%grid="grid_scalar" 
    485         i = i + 1; fields(i)%vname="ssh_ini";        fields(i)%grid="grid_N" 
    486         i = i + 1; fields(i)%vname="e3t_ini";        fields(i)%grid="grid_N_3D" 
    487         i = i + 1; fields(i)%vname="hc_loc_ini";     fields(i)%grid="grid_N_3D" 
    488         i = i + 1; fields(i)%vname="sc_loc_ini";     fields(i)%grid="grid_N_3D" 
    489         i = i + 1; fields(i)%vname="ssh_hc_loc_ini"; fields(i)%grid="grid_N" 
    490         i = i + 1; fields(i)%vname="ssh_sc_loc_ini"; fields(i)%grid="grid_N" 
    491         i = i + 1; fields(i)%vname="tilde_e3t_b";    fields(i)%grid="grid_N" 
    492         i = i + 1; fields(i)%vname="tilde_e3t_n";    fields(i)%grid="grid_N" 
    493         i = i + 1; fields(i)%vname="hdiv_lf";        fields(i)%grid="grid_N" 
    494         i = i + 1; fields(i)%vname="ub2_b";          fields(i)%grid="grid_N" 
    495         i = i + 1; fields(i)%vname="vb2_b";          fields(i)%grid="grid_N" 
    496         i = i + 1; fields(i)%vname="sshbb_e";        fields(i)%grid="grid_N" 
    497         i = i + 1; fields(i)%vname="ubb_e";          fields(i)%grid="grid_N" 
    498         i = i + 1; fields(i)%vname="vbb_e";          fields(i)%grid="grid_N" 
    499         i = i + 1; fields(i)%vname="sshb_e";         fields(i)%grid="grid_N" 
    500         i = i + 1; fields(i)%vname="ub_e";           fields(i)%grid="grid_N" 
    501         i = i + 1; fields(i)%vname="vb_e";           fields(i)%grid="grid_N" 
    502         i = i + 1; fields(i)%vname="fwf_isf_b";      fields(i)%grid="grid_N" 
    503         i = i + 1; fields(i)%vname="isf_sc_b";       fields(i)%grid="grid_N" 
    504         i = i + 1; fields(i)%vname="isf_hc_b";       fields(i)%grid="grid_N" 
    505         i = i + 1; fields(i)%vname="ssh_ibb";        fields(i)%grid="grid_N" 
    506         i = i + 1; fields(i)%vname="rnf_b";          fields(i)%grid="grid_N" 
    507         i = i + 1; fields(i)%vname="rnf_hc_b";       fields(i)%grid="grid_N" 
    508         i = i + 1; fields(i)%vname="rnf_sc_b";       fields(i)%grid="grid_N" 
    509         i = i + 1; fields(i)%vname="nn_fsbc";        fields(i)%grid="grid_scalar" 
    510         i = i + 1; fields(i)%vname="ssu_m";          fields(i)%grid="grid_N" 
    511         i = i + 1; fields(i)%vname="ssv_m";          fields(i)%grid="grid_N" 
    512         i = i + 1; fields(i)%vname="sst_m";          fields(i)%grid="grid_N" 
    513         i = i + 1; fields(i)%vname="sss_m";          fields(i)%grid="grid_N" 
    514         i = i + 1; fields(i)%vname="ssh_m";          fields(i)%grid="grid_N" 
    515         i = i + 1; fields(i)%vname="e3t_m";          fields(i)%grid="grid_N" 
    516         i = i + 1; fields(i)%vname="frq_m";          fields(i)%grid="grid_N" 
    517         i = i + 1; fields(i)%vname="avmb";           fields(i)%grid="grid_vector" 
    518         i = i + 1; fields(i)%vname="avtb";           fields(i)%grid="grid_vector" 
    519         i = i + 1; fields(i)%vname="ub2_i_b";        fields(i)%grid="grid_N" 
    520         i = i + 1; fields(i)%vname="vb2_i_b";        fields(i)%grid="grid_N" 
    521         i = i + 1; fields(i)%vname="ntime";          fields(i)%grid="grid_scalar" 
    522         i = i + 1; fields(i)%vname="Dsst";           fields(i)%grid="grid_scalar" 
    523         i = i + 1; fields(i)%vname="tmask";          fields(i)%grid="grid_N_3D" 
    524         i = i + 1; fields(i)%vname="umask";          fields(i)%grid="grid_N_3D" 
    525         i = i + 1; fields(i)%vname="vmask";          fields(i)%grid="grid_N_3D" 
    526         i = i + 1; fields(i)%vname="smask";          fields(i)%grid="grid_N_3D" 
    527         i = i + 1; fields(i)%vname="gdepw_n";        fields(i)%grid="grid_N_3D" 
    528         i = i + 1; fields(i)%vname="e3t_n";          fields(i)%grid="grid_N_3D" 
    529         i = i + 1; fields(i)%vname="e3u_n";          fields(i)%grid="grid_N_3D" 
    530         i = i + 1; fields(i)%vname="e3v_n";          fields(i)%grid="grid_N_3D" 
    531         i = i + 1; fields(i)%vname="surf_ini";       fields(i)%grid="grid_N" 
    532         i = i + 1; fields(i)%vname="e3t_b";          fields(i)%grid="grid_N_3D" 
    533         i = i + 1; fields(i)%vname="hmxl_n";         fields(i)%grid="grid_N_3D" 
    534         i = i + 1; fields(i)%vname="un_bf";          fields(i)%grid="grid_N" 
    535         i = i + 1; fields(i)%vname="vn_bf";          fields(i)%grid="grid_N" 
    536         i = i + 1; fields(i)%vname="hbl";            fields(i)%grid="grid_N" 
    537         i = i + 1; fields(i)%vname="hbli";           fields(i)%grid="grid_N" 
    538         i = i + 1; fields(i)%vname="wn";             fields(i)%grid="grid_N_3D" 
    539  
    540         IF( i-1 > max_rst_fields) THEN 
    541            WRITE(ctmp1,*) 'E R R O R : iom_set_rst_vars SIZE of RST_FIELD array is too small' 
    542            CALL ctl_stop( 'iom_set_rst_vars:', ctmp1 ) 
    543         ENDIF 
    544    END SUBROUTINE iom_set_rst_vars 
    545  
    546  
    547    SUBROUTINE iom_set_rstw_active(cdrst_file) 
     451      IF(lwp) WRITE(numout,*) 'Setting restart filename (for XIOS write) to: ', TRIM(cdrst_file) 
     452      CALL xios_get_handle("file_definition", filegroup_hdl ) 
     453      CALL xios_add_child(filegroup_hdl, file_hdl, 'wrestart') 
     454      IF(nxioso.eq.1) THEN  
     455         CALL xios_set_file_attr( "wrestart", type="one_file", enabled=.TRUE.,&  
     456                                       mode="write", output_freq=xios_timestep)  
     457         IF(lwp) write(numout,*) 'OPEN ', trim(cdrst_file), ' in one_file mode'  
     458      ELSE   
     459         CALL xios_set_file_attr( "wrestart", type="multiple_file", enabled=.TRUE.,&  
     460                                            mode="write", output_freq=xios_timestep)  
     461         IF(lwp) write(numout,*) 'OPEN ', trim(cdrst_file), ' in multiple_file mode'  
     462      ENDIF  
     463      CALL xios_set_file_attr( "wrestart", name=trim(cdrst_file)) 
     464#endif 
     465   END SUBROUTINE iom_set_rstw_file 
     466 
     467 
     468   SUBROUTINE iom_set_rstw_active(sdfield, rd0, rs0, rd1, rs1, rd2, rs2, rd3, rs3) 
    548469      !!--------------------------------------------------------------------- 
    549470      !!                   ***  SUBROUTINE iom_set_rstw_active   *** 
    … …  
    553474      !!--------------------------------------------------------------------- 
    554475!sets enabled = .TRUE. for each field in restart file 
    555    CHARACTER(len=*) :: cdrst_file 
     476      CHARACTER(len = *), INTENT(IN)                     :: sdfield 
     477      REAL(dp), OPTIONAL, INTENT(IN)                     :: rd0 
     478      REAL(sp), OPTIONAL, INTENT(IN)                     :: rs0 
     479      REAL(dp), OPTIONAL, INTENT(IN), DIMENSION(:)       :: rd1 
     480      REAL(sp), OPTIONAL, INTENT(IN), DIMENSION(:)       :: rs1 
     481      REAL(dp), OPTIONAL, INTENT(IN), DIMENSION(:, :)    :: rd2 
     482      REAL(sp), OPTIONAL, INTENT(IN), DIMENSION(:, :)    :: rs2 
     483      REAL(dp), OPTIONAL, INTENT(IN), DIMENSION(:, :, :) :: rd3   
     484      REAL(sp), OPTIONAL, INTENT(IN), DIMENSION(:, :, :) :: rs3 
    556485#if defined key_iomput 
    557    TYPE(xios_field) :: field_hdl 
    558    TYPE(xios_file) :: file_hdl 
    559    TYPE(xios_filegroup) :: filegroup_hdl 
    560    INTEGER :: i 
    561    CHARACTER(lc)  ::   clpath 
    562  
    563 !set name of the restart file and enable available fields 
    564         IF(lwp) WRITE(numout,*) 'Setting restart filename (for XIOS write) to: ',cdrst_file 
    565         CALL xios_get_handle("file_definition", filegroup_hdl ) 
    566         CALL xios_add_child(filegroup_hdl, file_hdl, 'wrestart') 
    567         IF(nxioso.eq.1) THEN  
    568            CALL xios_set_file_attr( "wrestart", type="one_file", enabled=.TRUE.,&  
    569                                     mode="write", output_freq=xios_timestep)  
    570            if(lwp) write(numout,*) 'OPEN ', trim(cdrst_file), ' in one_file mode'  
    571         ELSE   
    572            CALL xios_set_file_attr( "wrestart", type="multiple_file", enabled=.TRUE.,&  
    573                                     mode="write", output_freq=xios_timestep)  
    574            if(lwp) write(numout,*) 'OPEN ', trim(cdrst_file), ' in multiple_file mode'  
    575         ENDIF  
    576         CALL xios_set_file_attr( "wrestart", name=trim(cdrst_file)) 
     486      TYPE(xios_field) :: field_hdl 
     487      TYPE(xios_file) :: file_hdl 
     488 
     489      CALL xios_get_handle("wrestart", file_hdl) 
    577490!define fields for restart context 
    578         DO i = 1, max_rst_fields 
    579          IF( rst_wfields(i)%active ) THEN 
    580                 CALL xios_add_child(file_hdl, field_hdl, TRIM(rst_wfields(i)%vname)) 
    581                 SELECT CASE (TRIM(rst_wfields(i)%grid)) 
    582                  CASE ("grid_N_3D") 
    583                     CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_wfields(i)%vname), & 
    584                         domain_ref="grid_N", axis_ref="nav_lev", prec = 8, operation = "instant") 
    585                  CASE ("grid_N") 
    586                     CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_wfields(i)%vname), & 
    587                         domain_ref="grid_N", prec = 8, operation = "instant")  
    588                  CASE ("grid_vector") 
    589                     CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_wfields(i)%vname), & 
    590                          axis_ref="nav_lev", prec = 8, operation = "instant") 
    591                  CASE ("grid_scalar") 
    592                     CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_wfields(i)%vname), & 
    593                         scalar_ref = "grid_scalar", prec = 8, operation = "instant") 
    594                 END SELECT 
    595          ENDIF 
    596         END DO 
     491      CALL xios_add_child(file_hdl, field_hdl, sdfield) 
     492 
     493      IF(PRESENT(rd3)) THEN 
     494         CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 
     495                             domain_ref = "grid_N",                       & 
     496                             axis_ref = iom_axis(size(rd3, 3)),           & 
     497                             prec = 8, operation = "instant"              ) 
     498      ELSEIF(PRESENT(rs3)) THEN 
     499         CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 
     500                             domain_ref = "grid_N",                       & 
     501                             axis_ref = iom_axis(size(rd3, 3)),           & 
     502                             prec = 4, operation = "instant"              ) 
     503      ELSEIF(PRESENT(rd2)) THEN 
     504         CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 
     505                             domain_ref = "grid_N", prec = 8,             & 
     506                             operation = "instant"                        )  
     507      ELSEIF(PRESENT(rs2)) THEN 
     508         CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 
     509                             domain_ref = "grid_N", prec = 4,             & 
     510                             operation = "instant"                        ) 
     511      ELSEIF(PRESENT(rd1)) THEN 
     512         CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 
     513                             axis_ref = iom_axis(size(rd1, 1)),           & 
     514                             prec = 8, operation = "instant"              ) 
     515      ELSEIF(PRESENT(rs1)) THEN 
     516         CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 
     517                             axis_ref = iom_axis(size(rd1, 1)),           & 
     518                             prec = 4, operation = "instant"              ) 
     519      ELSEIF(PRESENT(rd0)) THEN 
     520         CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 
     521                             scalar_ref = "grid_scalar", prec = 8,        & 
     522                             operation = "instant"                        ) 
     523      ELSEIF(PRESENT(rs0)) THEN 
     524         CALL xios_set_attr (field_hdl, enabled = .TRUE., name = sdfield, & 
     525                             scalar_ref = "grid_scalar", prec = 4,        & 
     526                             operation = "instant"                        ) 
     527      ENDIF 
    597528#endif 
    598529   END SUBROUTINE iom_set_rstw_active 
    599530 
     531   FUNCTION iom_axis(idlev) result(axis_ref) 
     532      !!--------------------------------------------------------------------- 
     533      !!                   ***  FUNCTION  iom_axis  *** 
     534      !! 
     535      !! ** Purpose : Used for grid definition when XIOS is used to read/write 
     536      !!              restart. Returns axis corresponding to the number of levels 
     537      !!              given as an input variable. Axes are defined in routine  
     538      !!              iom_set_rst_context 
     539      !!--------------------------------------------------------------------- 
     540      INTEGER, INTENT(IN) :: idlev 
     541      CHARACTER(len=lc)   :: axis_ref 
     542      CHARACTER(len=12)   :: str 
     543      IF(idlev == jpk) THEN 
     544         axis_ref="nav_lev" 
     545#if defined key_si3 
     546      ELSEIF(idlev == jpl) THEN 
     547         axis_ref="numcat" 
     548#endif          
     549      ELSE 
     550         write(str, *) idlev 
     551         CALL ctl_stop( 'iom_axis', 'Definition for axis with '//TRIM(ADJUSTL(str))//' levels missing') 
     552      ENDIF 
     553   END FUNCTION iom_axis 
     554 
     555   FUNCTION iom_xios_setid(cdname) result(kid) 
     556     !!--------------------------------------------------------------------- 
     557      !!                   ***  FUNCTION    *** 
     558      !! 
     559      !! ** Purpose : this function returns first available id to keep information about file  
     560      !!              sets filename in iom_file structure and sets name 
     561      !!              of XIOS context depending on cdcomp 
     562      !!              corresponds to iom_nf90_open 
     563      !!--------------------------------------------------------------------- 
     564      CHARACTER(len=*), INTENT(in   ) :: cdname      ! File name 
     565      INTEGER                         :: kid      ! identifier of the opened file 
     566      INTEGER                         :: jl 
     567 
     568      kid = 0 
     569      DO jl = jpmax_files, 1, -1 
     570         IF( iom_file(jl)%nfid == 0 )   kid = jl 
     571      ENDDO 
     572 
     573      iom_file(kid)%name   = TRIM(cdname) 
     574      iom_file(kid)%nfid   = 1 
     575      iom_file(kid)%nvars  = 0 
     576      iom_file(kid)%irec   = -1 
     577 
     578   END FUNCTION iom_xios_setid 
     579 
    600580   SUBROUTINE iom_set_rst_context(ld_rstr)  
    601      !!--------------------------------------------------------------------- 
     581      !!--------------------------------------------------------------------- 
    602582      !!                   ***  SUBROUTINE  iom_set_rst_context  *** 
    603583      !! 
    … …  
    606586      !!                
    607587      !!--------------------------------------------------------------------- 
    608    LOGICAL, INTENT(IN)               :: ld_rstr 
    609 !ld_rstr is true for restart context. There is no need to define grid for  
    610 !restart read, because it's read from file 
     588      LOGICAL, INTENT(IN)               :: ld_rstr 
     589      INTEGER :: ji 
    611590#if defined key_iomput 
    612    TYPE(xios_domaingroup)            :: domaingroup_hdl  
    613    TYPE(xios_domain)                 :: domain_hdl  
    614    TYPE(xios_axisgroup)              :: axisgroup_hdl  
    615    TYPE(xios_axis)                   :: axis_hdl  
    616    TYPE(xios_scalar)                 :: scalar_hdl  
    617    TYPE(xios_scalargroup)            :: scalargroup_hdl  
    618  
    619      CALL xios_get_handle("domain_definition",domaingroup_hdl)  
    620      CALL xios_add_child(domaingroup_hdl, domain_hdl, "grid_N")  
    621      CALL set_grid("N", glamt, gphit, .TRUE., ld_rstr)  
     591      TYPE(xios_domaingroup)            :: domaingroup_hdl  
     592      TYPE(xios_domain)                 :: domain_hdl  
     593      TYPE(xios_axisgroup)              :: axisgroup_hdl  
     594      TYPE(xios_axis)                   :: axis_hdl  
     595      TYPE(xios_scalar)                 :: scalar_hdl  
     596      TYPE(xios_scalargroup)            :: scalargroup_hdl  
     597 
     598      CALL xios_get_handle("domain_definition",domaingroup_hdl)  
     599      CALL xios_add_child(domaingroup_hdl, domain_hdl, "grid_N")  
     600      CALL set_grid("N", glamt, gphit, .TRUE., ld_rstr)  
    622601  
    623      CALL xios_get_handle("axis_definition",axisgroup_hdl)  
    624      CALL xios_add_child(axisgroup_hdl, axis_hdl, "nav_lev")  
     602      CALL xios_get_handle("axis_definition",axisgroup_hdl)  
     603      CALL xios_add_child(axisgroup_hdl, axis_hdl, "nav_lev")  
    625604!AGRIF fails to compile when unit= is in call to xios_set_axis_attr 
    626 !    CALL xios_set_axis_attr( "nav_lev", long_name="Vertical levels",  unit="m", positive="down")  
    627      CALL xios_set_axis_attr( "nav_lev", long_name="Vertical levels in meters", positive="down") 
    628      CALL iom_set_axis_attr( "nav_lev", paxis = gdept_1d )  
    629  
    630      CALL xios_get_handle("scalar_definition", scalargroup_hdl)  
    631      CALL xios_add_child(scalargroup_hdl, scalar_hdl, "grid_scalar")  
     605!     CALL xios_set_axis_attr( "nav_lev", long_name="Vertical levels",  unit="m", positive="down")  
     606      CALL xios_set_axis_attr( "nav_lev", long_name = "Vertical levels in meters", positive = "down") 
     607      CALL iom_set_axis_attr( "nav_lev", paxis = gdept_1d )  
     608#if defined key_si3 
     609      CALL xios_add_child(axisgroup_hdl, axis_hdl, "numcat") 
     610      CALL iom_set_axis_attr( "numcat", (/ (REAL(ji,wp), ji=1,jpl) /) ) 
     611#endif 
     612      CALL xios_get_handle("scalar_definition", scalargroup_hdl)  
     613      CALL xios_add_child(scalargroup_hdl, scalar_hdl, "grid_scalar")  
    632614#endif 
    633615   END SUBROUTINE iom_set_rst_context 
     616 
     617 
     618   SUBROUTINE set_xios_context(kdid, cdcont)  
     619      !!--------------------------------------------------------------------- 
     620      !!                   ***  SUBROUTINE  iom_set_rst_context  *** 
     621      !! 
     622      !! ** Purpose : set correct XIOS context based on kdid 
     623      !!                
     624      !!--------------------------------------------------------------------- 
     625      INTEGER,           INTENT(IN)     :: kdid           ! Identifier of the file 
     626      CHARACTER(LEN=lc), INTENT(OUT)    :: cdcont         ! name of the context for XIOS read/write 
     627       
     628      cdcont = "NONE" 
     629 
     630      IF(lrxios) THEN 
     631         IF(kdid == numror) THEN 
     632            cdcont = cr_ocerst_cxt 
     633         ELSEIF(kdid == numrir) THEN 
     634            cdcont = cr_icerst_cxt  
     635         ELSEIF(kdid == numrtr) THEN 
     636            cdcont = cr_toprst_cxt 
     637         ELSEIF(kdid == numrsr) THEN 
     638            cdcont = cr_sedrst_cxt 
     639         ENDIF 
     640      ENDIF 
     641 
     642      IF(lwxios) THEN 
     643         IF(kdid == numrow) THEN 
     644            cdcont = cw_ocerst_cxt 
     645         ELSEIF(kdid == numriw) THEN 
     646            cdcont = cw_icerst_cxt 
     647         ELSEIF(kdid == numrtw) THEN 
     648            cdcont = cw_toprst_cxt 
     649         ELSEIF(kdid == numrsw) THEN 
     650            cdcont = cw_sedrst_cxt 
     651         ENDIF 
     652      ENDIF 
     653   END SUBROUTINE set_xios_context 
     654 
    634655 
    635656   SUBROUTINE iom_swap( cdname ) 
    … …  
    642663#if defined key_iomput 
    643664      TYPE(xios_context) :: nemo_hdl 
    644  
    645665      IF( TRIM(Agrif_CFixed()) == '0' ) THEN 
    646666        CALL xios_get_handle(TRIM(cdname),nemo_hdl) 
    … …  
    892912   !!                   INTERFACE iom_get 
    893913   !!---------------------------------------------------------------------- 
    894    SUBROUTINE iom_g0d_sp( kiomid, cdvar, pvar, ktime, ldxios ) 
     914   SUBROUTINE iom_g0d_sp( kiomid, cdvar, pvar, ktime ) 
    895915      INTEGER         , INTENT(in   )                 ::   kiomid    ! Identifier of the file 
    896916      CHARACTER(len=*), INTENT(in   )                 ::   cdvar     ! Name of the variable 
    … …  
    898918      REAL(dp)                                        ::   ztmp_pvar ! tmp var to read field 
    899919      INTEGER         , INTENT(in   ),     OPTIONAL   ::   ktime     ! record number 
    900       LOGICAL         , INTENT(in   ),     OPTIONAL   ::   ldxios    ! use xios to read restart 
    901920      ! 
    902921      INTEGER                                         ::   idvar     ! variable id 
    … …  
    906925      CHARACTER(LEN=100)                              ::   clname    ! file name 
    907926      CHARACTER(LEN=1)                                ::   cldmspc   ! 
    908       LOGICAL                                         ::   llxios 
    909       ! 
    910       llxios = .FALSE. 
    911       IF( PRESENT(ldxios) ) llxios = ldxios 
    912  
    913       IF(.NOT.llxios) THEN  ! read data using default library 
     927      CHARACTER(LEN=lc)                               ::   context 
     928      ! 
     929      CALL set_xios_context(kiomid, context) 
     930 
     931      IF(context == "NONE") THEN  ! read data using default library 
    914932         itime = 1 
    915933         IF( PRESENT(ktime) ) itime = ktime 
    … …  
    934952#if defined key_iomput 
    935953         IF(lwp) WRITE(numout,*) 'XIOS RST READ (0D): ', trim(cdvar) 
    936          CALL iom_swap( TRIM(crxios_context) ) 
     954         CALL iom_swap(context) 
    937955         CALL xios_recv_field( trim(cdvar), pvar) 
    938          CALL iom_swap( TRIM(cxios_context) ) 
     956         CALL iom_swap(cxios_context) 
    939957#else 
    940958         WRITE(ctmp1,*) 'Can not use XIOS in iom_g0d, file: '//trim(clname)//', var:'//trim(cdvar) 
    … …  
    944962   END SUBROUTINE iom_g0d_sp 
    945963 
    946    SUBROUTINE iom_g0d_dp( kiomid, cdvar, pvar, ktime, ldxios ) 
     964   SUBROUTINE iom_g0d_dp( kiomid, cdvar, pvar, ktime ) 
    947965      INTEGER         , INTENT(in   )                 ::   kiomid    ! Identifier of the file 
    948966      CHARACTER(len=*), INTENT(in   )                 ::   cdvar     ! Name of the variable 
    949967      REAL(dp)        , INTENT(  out)                 ::   pvar      ! read field 
    950968      INTEGER         , INTENT(in   ),     OPTIONAL   ::   ktime     ! record number 
    951       LOGICAL         , INTENT(in   ),     OPTIONAL   ::   ldxios    ! use xios to read restart 
    952969      ! 
    953970      INTEGER                                         ::   idvar     ! variable id 
    … …  
    957974      CHARACTER(LEN=100)                              ::   clname    ! file name 
    958975      CHARACTER(LEN=1)                                ::   cldmspc   ! 
    959       LOGICAL                                         ::   llxios 
    960       ! 
    961       llxios = .FALSE. 
    962       IF( PRESENT(ldxios) ) llxios = ldxios 
    963  
    964       IF(.NOT.llxios) THEN  ! read data using default library 
     976      CHARACTER(LEN=lc)                               ::   context 
     977      ! 
     978      CALL set_xios_context(kiomid, context) 
     979 
     980      IF(context == "NONE") THEN  ! read data using default library 
    965981         itime = 1 
    966982         IF( PRESENT(ktime) ) itime = ktime 
    … …  
    9841000#if defined key_iomput 
    9851001         IF(lwp) WRITE(numout,*) 'XIOS RST READ (0D): ', trim(cdvar) 
    986          CALL iom_swap( TRIM(crxios_context) ) 
     1002         CALL iom_swap(context) 
    9871003         CALL xios_recv_field( trim(cdvar), pvar) 
    988          CALL iom_swap( TRIM(cxios_context) ) 
     1004         CALL iom_swap(cxios_context) 
    9891005#else 
    9901006         WRITE(ctmp1,*) 'Can not use XIOS in iom_g0d, file: '//trim(clname)//', var:'//trim(cdvar) 
    … …  
    9941010   END SUBROUTINE iom_g0d_dp 
    9951011 
    996    SUBROUTINE iom_g1d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios ) 
     1012   SUBROUTINE iom_g1d_sp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount ) 
    9971013      INTEGER         , INTENT(in   )                         ::   kiomid    ! Identifier of the file 
    9981014      INTEGER         , INTENT(in   )                         ::   kdom      ! Type of domain to be read 
    … …  
    10031019      INTEGER         , INTENT(in   ), DIMENSION(1), OPTIONAL ::   kstart    ! start axis position of the reading  
    10041020      INTEGER         , INTENT(in   ), DIMENSION(1), OPTIONAL ::   kcount    ! number of points in each axis 
    1005       LOGICAL         , INTENT(in   ),               OPTIONAL ::   ldxios    ! read data using XIOS 
    10061021      ! 
    10071022      IF( kiomid > 0 ) THEN 
    … …  
    10091024            ALLOCATE(ztmp_pvar(size(pvar,1))) 
    10101025            CALL iom_get_123d( kiomid, kdom       , cdvar        , pv_r1d=ztmp_pvar,   & 
    1011               &                                                     ktime=ktime, kstart=kstart, kcount=kcount, & 
    1012               &                                                     ldxios=ldxios ) 
     1026              &                                                     ktime=ktime, kstart=kstart, kcount=kcount ) 
    10131027            pvar = ztmp_pvar 
    10141028            DEALLOCATE(ztmp_pvar) 
    … …  
    10181032 
    10191033 
    1020    SUBROUTINE iom_g1d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios ) 
     1034   SUBROUTINE iom_g1d_dp( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount ) 
    10211035      INTEGER         , INTENT(in   )                         ::   kiomid    ! Identifier of the file 
    10221036      INTEGER         , INTENT(in   )                         ::   kdom      ! Type of domain to be read 
    … …  
    10261040      INTEGER         , INTENT(in   ), DIMENSION(1), OPTIONAL ::   kstart    ! start axis position of the reading  
    10271041      INTEGER         , INTENT(in   ), DIMENSION(1), OPTIONAL ::   kcount    ! number of points in each axis 
    1028       LOGICAL         , INTENT(in   ),               OPTIONAL ::   ldxios    ! read data using XIOS 
    10291042      ! 
    10301043      IF( kiomid > 0 ) THEN 
    10311044         IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom       , cdvar        , pv_r1d=pvar,   & 
    1032               &                                                     ktime=ktime, kstart=kstart, kcount=kcount, & 
    1033               &                                                     ldxios=ldxios ) 
     1045              &                                                     ktime=ktime, kstart=kstart, kcount=kcount) 
    10341046      ENDIF 
    10351047   END SUBROUTINE iom_g1d_dp 
    10361048 
    1037    SUBROUTINE iom_g2d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios) 
     1049   SUBROUTINE iom_g2d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount) 
    10381050      INTEGER         , INTENT(in   )                         ::   kiomid    ! Identifier of the file 
    10391051      INTEGER         , INTENT(in   )                         ::   kdom      ! Type of domain to be read 
    … …  
    10471059      INTEGER         , INTENT(in   ), DIMENSION(2), OPTIONAL ::   kstart    ! start axis position of the reading  
    10481060      INTEGER         , INTENT(in   ), DIMENSION(2), OPTIONAL ::   kcount    ! number of points in each axis 
    1049       LOGICAL         , INTENT(in   ),               OPTIONAL ::   ldxios    ! read data using XIOS 
    10501061      ! 
    10511062      IF( kiomid > 0 ) THEN 
    … …  
    10541065            CALL iom_get_123d( kiomid, kdom, cdvar      , pv_r2d = ztmp_pvar  , ktime = ktime,   & 
    10551066             &                                                      cd_type = cd_type, psgn   = psgn  , kfill = kfill,   & 
    1056              &                                                      kstart  = kstart , kcount = kcount, ldxios=ldxios  ) 
     1067             &                                                      kstart  = kstart , kcount = kcount  ) 
    10571068            pvar = ztmp_pvar 
    10581069            DEALLOCATE(ztmp_pvar) 
    … …  
    10611072   END SUBROUTINE iom_g2d_sp 
    10621073 
    1063    SUBROUTINE iom_g2d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios) 
     1074   SUBROUTINE iom_g2d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount) 
    10641075      INTEGER         , INTENT(in   )                         ::   kiomid    ! Identifier of the file 
    10651076      INTEGER         , INTENT(in   )                         ::   kdom      ! Type of domain to be read 
    … …  
    10721083      INTEGER         , INTENT(in   ), DIMENSION(2), OPTIONAL ::   kstart    ! start axis position of the reading  
    10731084      INTEGER         , INTENT(in   ), DIMENSION(2), OPTIONAL ::   kcount    ! number of points in each axis 
    1074       LOGICAL         , INTENT(in   ),               OPTIONAL ::   ldxios    ! read data using XIOS 
    10751085      ! 
    10761086      IF( kiomid > 0 ) THEN 
    10771087         IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom, cdvar      , pv_r2d = pvar  , ktime = ktime,   & 
    10781088            &                                                       cd_type = cd_type, psgn   = psgn  , kfill = kfill,   & 
    1079             &                                                       kstart  = kstart , kcount = kcount, ldxios=ldxios  ) 
     1089            &                                                       kstart  = kstart , kcount = kcount                ) 
    10801090      ENDIF 
    10811091   END SUBROUTINE iom_g2d_dp 
    10821092 
    1083    SUBROUTINE iom_g3d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios ) 
     1093   SUBROUTINE iom_g3d_sp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount ) 
    10841094      INTEGER         , INTENT(in   )                         ::   kiomid    ! Identifier of the file 
    10851095      INTEGER         , INTENT(in   )                         ::   kdom      ! Type of domain to be read 
    … …  
    10931103      INTEGER         , INTENT(in   ), DIMENSION(3), OPTIONAL ::   kstart    ! start axis position of the reading  
    10941104      INTEGER         , INTENT(in   ), DIMENSION(3), OPTIONAL ::   kcount    ! number of points in each axis 
    1095       LOGICAL         , INTENT(in   ),               OPTIONAL ::   ldxios    ! read data using XIOS 
    10961105      ! 
    10971106      IF( kiomid > 0 ) THEN 
    … …  
    11001109            CALL iom_get_123d( kiomid, kdom, cdvar      , pv_r3d = ztmp_pvar  , ktime = ktime,   & 
    11011110            &                                                       cd_type = cd_type, psgn   = psgn  , kfill = kfill,   & 
    1102             &                                                       kstart  = kstart , kcount = kcount, ldxios=ldxios  ) 
     1111            &                                                       kstart  = kstart , kcount = kcount                ) 
    11031112            pvar = ztmp_pvar 
    11041113            DEALLOCATE(ztmp_pvar) 
    … …  
    11071116   END SUBROUTINE iom_g3d_sp 
    11081117 
    1109    SUBROUTINE iom_g3d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount, ldxios ) 
     1118   SUBROUTINE iom_g3d_dp( kiomid, kdom, cdvar, pvar, ktime, cd_type, psgn, kfill, kstart, kcount ) 
    11101119      INTEGER         , INTENT(in   )                         ::   kiomid    ! Identifier of the file 
    11111120      INTEGER         , INTENT(in   )                         ::   kdom      ! Type of domain to be read 
    … …  
    11181127      INTEGER         , INTENT(in   ), DIMENSION(3), OPTIONAL ::   kstart    ! start axis position of the reading  
    11191128      INTEGER         , INTENT(in   ), DIMENSION(3), OPTIONAL ::   kcount    ! number of points in each axis 
    1120       LOGICAL         , INTENT(in   ),               OPTIONAL ::   ldxios    ! read data using XIOS 
    11211129      ! 
    11221130      IF( kiomid > 0 ) THEN 
    … …  
    11241132            CALL iom_get_123d( kiomid, kdom, cdvar      , pv_r3d = pvar  , ktime = ktime,   & 
    11251133            &                                                       cd_type = cd_type, psgn   = psgn  , kfill = kfill,   & 
    1126             &                                                       kstart  = kstart , kcount = kcount, ldxios=ldxios  ) 
     1134            &                                                       kstart  = kstart , kcount = kcount                ) 
    11271135         END IF 
    11281136      ENDIF 
    … …  
    11321140 
    11331141   SUBROUTINE iom_get_123d( kiomid , kdom, cdvar, pv_r1d, pv_r2d, pv_r3d, ktime ,   & 
    1134          &                  cd_type, psgn, kfill, kstart, kcount, ldxios ) 
     1142         &                  cd_type, psgn, kfill, kstart, kcount ) 
    11351143      !!----------------------------------------------------------------------- 
    11361144      !!                  ***  ROUTINE  iom_get_123d  *** 
    … …  
    11521160      INTEGER , DIMENSION(:)     , INTENT(in   ), OPTIONAL ::   kstart    ! start position of the reading in each axis  
    11531161      INTEGER , DIMENSION(:)     , INTENT(in   ), OPTIONAL ::   kcount    ! number of points to be read in each axis 
    1154       LOGICAL                    , INTENT(in   ), OPTIONAL ::   ldxios    ! use XIOS to read restart 
    11551162      ! 
    11561163      LOGICAL                        ::   llok        ! true if ok! 
    1157       LOGICAL                        ::   llxios      ! local definition for XIOS read 
    11581164      INTEGER                        ::   jl          ! loop on number of dimension  
    11591165      INTEGER                        ::   idom        ! type of domain 
    … …  
    11821188      REAL(dp)                       ::   gma, gmi 
    11831189      !--------------------------------------------------------------------- 
    1184       ! 
     1190      CHARACTER(LEN=lc)                               ::   context 
     1191      ! 
     1192      CALL set_xios_context(kiomid, context) 
    11851193      inlev = -1 
    11861194      IF( PRESENT(pv_r3d) )   inlev = SIZE(pv_r3d, 3) 
    11871195      ! 
    1188       llxios = .FALSE. 
    1189       IF( PRESENT(ldxios) )   llxios = ldxios 
    1190       ! 
    11911196      idom = kdom 
    11921197      istop = nstop 
    11931198      ! 
    1194       IF(.NOT.llxios) THEN 
     1199      IF(context == "NONE") THEN 
    11951200         clname = iom_file(kiomid)%name   !   esier to read 
    11961201         clinfo = '          iom_get_123d, file: '//trim(clname)//', var: '//trim(cdvar) 
    … …  
    13591364#if defined key_iomput 
    13601365!would be good to be able to check which context is active and swap only if current is not restart 
    1361          CALL iom_swap( TRIM(crxios_context) )  
     1366         idvar = iom_varid( kiomid, cdvar ) 
     1367         CALL iom_swap(context) 
     1368         zsgn = 1._wp 
     1369         IF( PRESENT(psgn   ) )   zsgn    = psgn 
     1370         cl_type = 'T' 
     1371         IF( PRESENT(cd_type) )   cl_type = cd_type 
     1372 
    13621373         IF( PRESENT(pv_r3d) ) THEN 
    13631374            IF(lwp) WRITE(numout,*) 'XIOS RST READ (3D): ',TRIM(cdvar) 
    1364             CALL xios_recv_field( trim(cdvar), pv_r3d) 
    1365             IF(idom /= jpdom_unknown )   CALL lbc_lnk( 'iom', pv_r3d,'Z', -999., kfillmode = jpfillnothing) 
     1375            CALL xios_recv_field( trim(cdvar), pv_r3d(:, :, :)) 
     1376            IF(idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN 
     1377               CALL lbc_lnk( 'iom', pv_r3d, cl_type, zsgn, kfillmode = kfill) 
     1378            ENDIF 
    13661379         ELSEIF( PRESENT(pv_r2d) ) THEN 
    13671380            IF(lwp) WRITE(numout,*) 'XIOS RST READ (2D): ', TRIM(cdvar) 
    1368             CALL xios_recv_field( trim(cdvar), pv_r2d) 
    1369             IF(idom /= jpdom_unknown )   CALL lbc_lnk('iom', pv_r2d,'Z',-999., kfillmode = jpfillnothing) 
     1381            CALL xios_recv_field( trim(cdvar), pv_r2d(:, :)) 
     1382            IF(idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN 
     1383               CALL lbc_lnk('iom', pv_r2d, cl_type, zsgn, kfillmode = kfill) 
     1384            ENDIF 
    13701385         ELSEIF( PRESENT(pv_r1d) ) THEN 
    13711386            IF(lwp) WRITE(numout,*) 'XIOS RST READ (1D): ', TRIM(cdvar) 
    13721387            CALL xios_recv_field( trim(cdvar), pv_r1d) 
    13731388         ENDIF 
    1374          CALL iom_swap( TRIM(cxios_context) ) 
     1389         CALL iom_swap(cxios_context) 
    13751390#else 
    13761391         istop = istop + 1  
    … …  
    13871402      zofs = iom_file(kiomid)%ofs(idvar)      ! offset 
    13881403      IF(     PRESENT(pv_r1d) ) THEN 
    1389          IF( zscf /= 1. )   pv_r1d(:) = pv_r1d(:) * zscf  
    1390          IF( zofs /= 0. )   pv_r1d(:) = pv_r1d(:) + zofs 
     1404         IF( zscf /= 1._wp )   pv_r1d(:) = pv_r1d(:) * zscf  
     1405         IF( zofs /= 0._wp )   pv_r1d(:) = pv_r1d(:) + zofs 
    13911406      ELSEIF( PRESENT(pv_r2d) ) THEN 
    1392          IF( zscf /= 1.)   pv_r2d(:,:) = pv_r2d(:,:) * zscf 
    1393          IF( zofs /= 0.)   pv_r2d(:,:) = pv_r2d(:,:) + zofs 
     1407         IF( zscf /= 1._wp)   pv_r2d(:,:) = pv_r2d(:,:) * zscf 
     1408         IF( zofs /= 0._wp)   pv_r2d(:,:) = pv_r2d(:,:) + zofs 
    13941409      ELSEIF( PRESENT(pv_r3d) ) THEN 
    1395          IF( zscf /= 1.)   pv_r3d(:,:,:) = pv_r3d(:,:,:) * zscf 
    1396          IF( zofs /= 0.)   pv_r3d(:,:,:) = pv_r3d(:,:,:) + zofs 
     1410         IF( zscf /= 1._wp)   pv_r3d(:,:,:) = pv_r3d(:,:,:) * zscf 
     1411         IF( zofs /= 0._wp)   pv_r3d(:,:,:) = pv_r3d(:,:,:) + zofs 
    13971412      ENDIF 
    13981413      ! 
    … …  
    15681583   !!                   INTERFACE iom_rstput 
    15691584   !!---------------------------------------------------------------------- 
    1570    SUBROUTINE iom_rp0d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1585   SUBROUTINE iom_rp0d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 
    15711586      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    15721587      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    … …  
    15751590      REAL(sp)        , INTENT(in)                         ::   pvar     ! written field 
    15761591      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
    1577       LOGICAL, OPTIONAL :: ldxios   ! xios write flag 
    1578       LOGICAL :: llx                ! local xios write flag 
    1579       INTEGER :: ivid   ! variable id 
    1580  
    1581       llx = .FALSE. 
    1582       IF(PRESENT(ldxios)) llx = ldxios 
     1592      ! 
     1593      LOGICAL           :: llx                ! local xios write flag 
     1594      INTEGER           :: ivid   ! variable id 
     1595      CHARACTER(LEN=lc) :: context 
     1596      ! 
     1597      CALL set_xios_context(kiomid, context) 
     1598 
     1599      llx = .NOT. (context == "NONE") 
     1600 
    15831601      IF( llx ) THEN 
    15841602#ifdef key_iomput 
    1585       IF( kt == kwrite ) THEN 
    1586           IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) 
    1587           CALL xios_send_field(trim(cdvar), pvar) 
    1588       ENDIF 
     1603         IF( kt == kwrite ) THEN 
     1604            IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) 
     1605            CALL iom_swap(context) 
     1606            CALL iom_put(trim(cdvar), pvar) 
     1607            CALL iom_swap(cxios_context) 
     1608         ELSE 
     1609            IF(lwp) write(numout,*) 'RESTART: define (XIOS 0D) ',trim(cdvar) 
     1610            CALL iom_swap(context) 
     1611            CALL iom_set_rstw_active( trim(cdvar), rs0 = pvar )  
     1612            CALL iom_swap(cxios_context) 
     1613         ENDIF 
    15891614#endif 
    15901615      ELSE 
    … …  
    15981623   END SUBROUTINE iom_rp0d_sp 
    15991624 
    1600    SUBROUTINE iom_rp0d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1625   SUBROUTINE iom_rp0d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 
    16011626      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    16021627      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    … …  
    16051630      REAL(dp)        , INTENT(in)                         ::   pvar     ! written field 
    16061631      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
    1607       LOGICAL, OPTIONAL :: ldxios   ! xios write flag 
    1608       LOGICAL :: llx                ! local xios write flag 
    1609       INTEGER :: ivid   ! variable id 
    1610  
    1611       llx = .FALSE. 
    1612       IF(PRESENT(ldxios)) llx = ldxios 
     1632      ! 
     1633      LOGICAL           :: llx                ! local xios write flag 
     1634      INTEGER           :: ivid   ! variable id 
     1635      CHARACTER(LEN=lc) :: context 
     1636      ! 
     1637      CALL set_xios_context(kiomid, context) 
     1638 
     1639      llx = .NOT. (context == "NONE") 
     1640 
    16131641      IF( llx ) THEN 
    16141642#ifdef key_iomput 
    1615       IF( kt == kwrite ) THEN 
    1616           IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) 
    1617           CALL xios_send_field(trim(cdvar), pvar) 
    1618       ENDIF 
     1643         IF( kt == kwrite ) THEN 
     1644            IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) 
     1645            CALL iom_swap(context) 
     1646            CALL iom_put(trim(cdvar), pvar) 
     1647            CALL iom_swap(cxios_context) 
     1648         ELSE 
     1649            IF(lwp) write(numout,*) 'RESTART: define (XIOS 0D) ',trim(cdvar) 
     1650            CALL iom_swap(context) 
     1651            CALL iom_set_rstw_active( trim(cdvar), rd0 = pvar )  
     1652            CALL iom_swap(cxios_context) 
     1653         ENDIF 
    16191654#endif 
    16201655      ELSE 
    … …  
    16291664 
    16301665 
    1631    SUBROUTINE iom_rp1d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1666   SUBROUTINE iom_rp1d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 
    16321667      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    16331668      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    … …  
    16361671      REAL(sp)        , INTENT(in), DIMENSION(          :) ::   pvar     ! written field 
    16371672      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
    1638       LOGICAL, OPTIONAL                                    ::   ldxios   ! xios write flag 
    1639       LOGICAL :: llx                ! local xios write flag 
    1640       INTEGER :: ivid   ! variable id 
    1641  
    1642       llx = .FALSE. 
    1643       IF(PRESENT(ldxios)) llx = ldxios 
     1673      ! 
     1674      LOGICAL           :: llx                ! local xios write flag 
     1675      INTEGER           :: ivid   ! variable id 
     1676      CHARACTER(LEN=lc) :: context 
     1677      ! 
     1678      CALL set_xios_context(kiomid, context) 
     1679 
     1680      llx = .NOT. (context == "NONE") 
     1681 
    16441682      IF( llx ) THEN 
    16451683#ifdef key_iomput 
    1646       IF( kt == kwrite ) THEN 
    1647          IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) 
    1648          CALL xios_send_field(trim(cdvar), pvar) 
    1649       ENDIF 
     1684         IF( kt == kwrite ) THEN 
     1685            IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) 
     1686            CALL iom_swap(context) 
     1687            CALL iom_put(trim(cdvar), pvar) 
     1688            CALL iom_swap(cxios_context) 
     1689         ELSE 
     1690            IF(lwp) write(numout,*) 'RESTART: define (XIOS 1D)',trim(cdvar) 
     1691            CALL iom_swap(context) 
     1692            CALL iom_set_rstw_active( trim(cdvar), rs1 = pvar ) 
     1693            CALL iom_swap(cxios_context) 
     1694         ENDIF 
    16501695#endif 
    16511696      ELSE 
    … …  
    16591704   END SUBROUTINE iom_rp1d_sp 
    16601705 
    1661    SUBROUTINE iom_rp1d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1706   SUBROUTINE iom_rp1d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 
    16621707      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    16631708      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    … …  
    16661711      REAL(dp)        , INTENT(in), DIMENSION(          :) ::   pvar     ! written field 
    16671712      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
    1668       LOGICAL, OPTIONAL                                    ::   ldxios   ! xios write flag 
    1669       LOGICAL :: llx                ! local xios write flag 
    1670       INTEGER :: ivid   ! variable id 
    1671  
    1672       llx = .FALSE. 
    1673       IF(PRESENT(ldxios)) llx = ldxios 
     1713      ! 
     1714      LOGICAL           :: llx                ! local xios write flag 
     1715      INTEGER           :: ivid   ! variable id 
     1716      CHARACTER(LEN=lc) :: context 
     1717      ! 
     1718      CALL set_xios_context(kiomid, context) 
     1719 
     1720      llx = .NOT. (context == "NONE") 
     1721 
    16741722      IF( llx ) THEN 
    16751723#ifdef key_iomput 
    1676       IF( kt == kwrite ) THEN 
    1677          IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) 
    1678          CALL xios_send_field(trim(cdvar), pvar) 
    1679       ENDIF 
     1724         IF( kt == kwrite ) THEN 
     1725            IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) 
     1726            CALL iom_swap(context) 
     1727            CALL iom_put(trim(cdvar), pvar) 
     1728            CALL iom_swap(cxios_context) 
     1729         ELSE 
     1730            IF(lwp) write(numout,*) 'RESTART: define (XIOS 1D)',trim(cdvar) 
     1731            CALL iom_swap(context) 
     1732            CALL iom_set_rstw_active( trim(cdvar), rd1 = pvar ) 
     1733            CALL iom_swap(cxios_context) 
     1734         ENDIF 
    16801735#endif 
    16811736      ELSE 
    … …  
    16901745 
    16911746 
    1692    SUBROUTINE iom_rp2d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1747   SUBROUTINE iom_rp2d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 
    16931748      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    16941749      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    … …  
    16971752      REAL(sp)        , INTENT(in), DIMENSION(:,    :    ) ::   pvar     ! written field 
    16981753      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
    1699       LOGICAL, OPTIONAL :: ldxios   ! xios write flag 
    1700       LOGICAL :: llx 
    1701       INTEGER :: ivid   ! variable id 
    1702  
    1703       llx = .FALSE. 
    1704       IF(PRESENT(ldxios)) llx = ldxios 
     1754      ! 
     1755      LOGICAL            :: llx 
     1756      INTEGER            :: ivid   ! variable id 
     1757      CHARACTER(LEN=lc)  :: context 
     1758      ! 
     1759      CALL set_xios_context(kiomid, context) 
     1760 
     1761      llx = .NOT. (context == "NONE") 
     1762 
    17051763      IF( llx ) THEN 
    17061764#ifdef key_iomput 
    1707       IF( kt == kwrite ) THEN 
    1708          IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) 
    1709          CALL xios_send_field(trim(cdvar), pvar) 
    1710       ENDIF 
     1765         IF( kt == kwrite ) THEN 
     1766            IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) 
     1767            CALL iom_swap(context) 
     1768            CALL iom_put(trim(cdvar), pvar) 
     1769            CALL iom_swap(cxios_context) 
     1770         ELSE 
     1771            IF(lwp) write(numout,*) 'RESTART: define (XIOS 2D)',trim(cdvar) 
     1772            CALL iom_swap(context) 
     1773            CALL iom_set_rstw_active( trim(cdvar), rs2 = pvar ) 
     1774            CALL iom_swap(cxios_context) 
     1775         ENDIF 
    17111776#endif 
    17121777      ELSE 
    … …  
    17201785   END SUBROUTINE iom_rp2d_sp 
    17211786 
    1722    SUBROUTINE iom_rp2d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1787   SUBROUTINE iom_rp2d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 
    17231788      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    17241789      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    … …  
    17271792      REAL(dp)        , INTENT(in), DIMENSION(:,    :    ) ::   pvar     ! written field 
    17281793      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
    1729       LOGICAL, OPTIONAL :: ldxios   ! xios write flag 
    1730       LOGICAL :: llx 
    1731       INTEGER :: ivid   ! variable id 
    1732  
    1733       llx = .FALSE. 
    1734       IF(PRESENT(ldxios)) llx = ldxios 
     1794      ! 
     1795      LOGICAL           :: llx 
     1796      INTEGER           :: ivid   ! variable id 
     1797      CHARACTER(LEN=lc) :: context 
     1798      ! 
     1799      CALL set_xios_context(kiomid, context) 
     1800 
     1801      llx = .NOT. (context == "NONE") 
     1802 
    17351803      IF( llx ) THEN 
    17361804#ifdef key_iomput 
    1737       IF( kt == kwrite ) THEN 
    1738          IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) 
    1739          CALL xios_send_field(trim(cdvar), pvar) 
    1740       ENDIF 
     1805         IF( kt == kwrite ) THEN 
     1806            IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) 
     1807            CALL iom_swap(context) 
     1808            CALL iom_put(trim(cdvar), pvar) 
     1809            CALL iom_swap(cxios_context) 
     1810         ELSE 
     1811            IF(lwp) write(numout,*) 'RESTART: define (XIOS 2D)',trim(cdvar) 
     1812            CALL iom_swap(context) 
     1813            CALL iom_set_rstw_active( trim(cdvar), rd2 = pvar ) 
     1814            CALL iom_swap(cxios_context) 
     1815         ENDIF 
    17411816#endif 
    17421817      ELSE 
    … …  
    17511826 
    17521827 
    1753    SUBROUTINE iom_rp3d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1828   SUBROUTINE iom_rp3d_sp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 
    17541829      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    17551830      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    … …  
    17581833      REAL(sp)        , INTENT(in),       DIMENSION(:,:,:) ::   pvar     ! written field 
    17591834      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
    1760       LOGICAL, OPTIONAL :: ldxios   ! xios write flag 
    1761       LOGICAL :: llx                 ! local xios write flag 
    1762       INTEGER :: ivid   ! variable id 
    1763  
    1764       llx = .FALSE. 
    1765       IF(PRESENT(ldxios)) llx = ldxios 
     1835      ! 
     1836      LOGICAL           :: llx                 ! local xios write flag 
     1837      INTEGER           :: ivid   ! variable id 
     1838      CHARACTER(LEN=lc) :: context 
     1839      ! 
     1840      CALL set_xios_context(kiomid, context) 
     1841 
     1842      llx = .NOT. (context == "NONE") 
     1843 
    17661844      IF( llx ) THEN 
    17671845#ifdef key_iomput 
    1768       IF( kt == kwrite ) THEN 
    1769          IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) 
    1770          CALL xios_send_field(trim(cdvar), pvar) 
    1771       ENDIF 
     1846         IF( kt == kwrite ) THEN 
     1847            IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) 
     1848            CALL iom_swap(context) 
     1849            CALL iom_put(trim(cdvar), pvar) 
     1850            CALL iom_swap(cxios_context) 
     1851         ELSE 
     1852            IF(lwp) write(numout,*) 'RESTART: define (XIOS 3D)',trim(cdvar) 
     1853            CALL iom_swap(context) 
     1854            CALL iom_set_rstw_active( trim(cdvar), rs3 = pvar ) 
     1855            CALL iom_swap(cxios_context) 
     1856         ENDIF 
    17721857#endif 
    17731858      ELSE 
    … …  
    17811866   END SUBROUTINE iom_rp3d_sp 
    17821867 
    1783    SUBROUTINE iom_rp3d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) 
     1868   SUBROUTINE iom_rp3d_dp( kt, kwrite, kiomid, cdvar, pvar, ktype ) 
    17841869      INTEGER         , INTENT(in)                         ::   kt       ! ocean time-step 
    17851870      INTEGER         , INTENT(in)                         ::   kwrite   ! writing time-step 
    … …  
    17881873      REAL(dp)        , INTENT(in),       DIMENSION(:,:,:) ::   pvar     ! written field 
    17891874      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
    1790       LOGICAL, OPTIONAL :: ldxios   ! xios write flag 
    1791       LOGICAL :: llx                 ! local xios write flag 
    1792       INTEGER :: ivid   ! variable id 
    1793  
    1794       llx = .FALSE. 
    1795       IF(PRESENT(ldxios)) llx = ldxios 
     1875      ! 
     1876      LOGICAL           :: llx                 ! local xios write flag 
     1877      INTEGER           :: ivid   ! variable id 
     1878      CHARACTER(LEN=lc) :: context 
     1879      ! 
     1880      CALL set_xios_context(kiomid, context) 
     1881 
     1882      llx = .NOT. (context == "NONE") 
     1883 
    17961884      IF( llx ) THEN 
    17971885#ifdef key_iomput 
    1798       IF( kt == kwrite ) THEN 
    1799          IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) 
    1800          CALL xios_send_field(trim(cdvar), pvar) 
    1801       ENDIF 
     1886         IF( kt == kwrite ) THEN 
     1887            IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) 
     1888            CALL iom_swap(context) 
     1889            CALL iom_put(trim(cdvar), pvar) 
     1890            CALL iom_swap(cxios_context) 
     1891         ELSE 
     1892            IF(lwp) write(numout,*) 'RESTART: define (XIOS 3D)',trim(cdvar) 
     1893            CALL iom_swap(context) 
     1894            CALL iom_set_rstw_active( trim(cdvar), rd3 = pvar ) 
     1895            CALL iom_swap(cxios_context) 
     1896         ENDIF 
    18021897#endif 
    18031898      ELSE 
    … …  
    18651960      CHARACTER(LEN=*), INTENT(in) ::   cdname 
    18661961      REAL(sp)        , INTENT(in) ::   pfield0d 
    1867 !!      REAL(wp)        , DIMENSION(jpi,jpj) ::   zz     ! masson 
     1962      !!      REAL(wp)        , DIMENSION(jpi,jpj) ::   zz     ! masson 
    18681963#if defined key_iomput 
    18691964!!clem      zz(:,:)=pfield0d 
    … …  
    21452240      CALL iom_swap( cdname )   ! swap to cdname context 
    21462241      CALL xios_update_calendar(kt) 
    2147       IF( cdname /= TRIM(cxios_context) )   CALL iom_swap( TRIM(cxios_context) )   ! return back to nemo context 
     2242      IF( cdname /= TRIM(cxios_context) )   CALL iom_swap( cxios_context )   ! return back to nemo context 
    21482243   END SUBROUTINE iom_setkt 
    21492244 
    … …  
    21592254         CALL iom_swap( cdname )   ! swap to cdname context 
    21602255         CALL xios_context_finalize() ! finalize the context 
    2161          IF( cdname /= TRIM(cxios_context) ) CALL iom_swap( TRIM(cxios_context) )   ! return back to nemo context 
     2256         IF( cdname /= cxios_context ) CALL iom_swap( cxios_context )   ! return back to nemo context 
    21622257      ENDIF 
    21632258      ! 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/IOM/iom_def.F90

    r13899 r14012  
    99   !!---------------------------------------------------------------------- 
    1010   USE par_kind 
     11   USE netcdf 
    1112 
    1213   IMPLICIT NONE 
    … …  
    3637   INTEGER, PUBLIC            ::   nxioso = 0          !: type of restart file when writing using XIOS 1 - single, 2 - multiple 
    3738!XIOS read restart    
    38    LOGICAL, PUBLIC            ::   lrxios = .FALSE.     !: read single file restart using XIOS 
     39   LOGICAL, PUBLIC            ::   lrxios = .FALSE.     !: read single file restart using XIOS main switch 
    3940   LOGICAL, PUBLIC            ::   lxios_sini = .FALSE. ! is restart in a single file 
    40    LOGICAL, PUBLIC            ::   lxios_set  = .FALSE.  
     41 
     42 
    4143 
    4244   TYPE, PUBLIC ::   file_descriptor 
    … …  
    5961   END TYPE file_descriptor 
    6062   TYPE(file_descriptor), DIMENSION(jpmax_files), PUBLIC ::   iom_file !: array containing the info for all opened files 
    61    INTEGER, PARAMETER, PUBLIC                   :: max_rst_fields = 95 !: maximum number of restart variables defined in iom_set_rst_vars 
    62    TYPE, PUBLIC :: RST_FIELD   
    63     CHARACTER(len=30) :: vname = "NO_NAME" ! names of variables in restart file 
    64     CHARACTER(len=30) :: grid = "NO_GRID" 
    65     LOGICAL           :: active =.FALSE. ! for restart write only: true - write field, false do not write field 
    66    END TYPE RST_FIELD 
    6763!$AGRIF_END_DO_NOT_TREAT 
    68    ! 
    69    TYPE(RST_FIELD), PUBLIC, SAVE :: rst_wfields(max_rst_fields), rst_rfields(max_rst_fields) 
    7064   ! 
    7165   !! * Substitutions 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/IOM/iom_nf90.F90

    r13899 r14012  
    3131   PUBLIC iom_nf90_open  , iom_nf90_close, iom_nf90_varid, iom_nf90_get, iom_nf90_rstput 
    3232   PUBLIC iom_nf90_chkatt, iom_nf90_getatt, iom_nf90_putatt 
     33   PUBLIC iom_nf90_check 
    3334 
    3435   INTERFACE iom_nf90_get 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/IOM/prtctl.F90

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

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/IOM/restart.F90

    r13899 r14012  
    110110            ELSE 
    111111#if defined key_iomput 
    112                cwxios_context = "rstw_"//TRIM(ADJUSTL(clkt)) 
     112               cw_ocerst_cxt = "rstw_"//TRIM(ADJUSTL(clkt)) 
    113113               IF( TRIM(Agrif_CFixed()) == '0' ) THEN 
    114114                  clpname = clname 
    … …  
    116116                  clpname = TRIM(Agrif_CFixed())//"_"//clname    
    117117               ENDIF 
    118                CALL iom_init( cwxios_context, TRIM(clpath)//TRIM(clpname), .false. ) 
    119                CALL xios_update_calendar(nitrst) 
     118               numrow = iom_xios_setid(TRIM(clpath)//TRIM(clpname)) 
     119               CALL iom_init( cw_ocerst_cxt, kdid = numrow, ld_closedef = .false. ) 
    120120               CALL iom_swap(      cxios_context          ) 
    121121#else 
    … …  
    143143      INTEGER, INTENT(in) ::   Kbb, Kmm   ! ocean time level indices 
    144144      !!---------------------------------------------------------------------- 
    145                      IF(lwxios) CALL iom_swap(      cwxios_context          ) 
    146                      CALL iom_rstput( kt, nitrst, numrow, 'rdt'    , rn_Dt       , ldxios = lwxios)   ! dynamics time step 
    147                      CALL iom_delay_rst( 'WRITE', 'OCE', numrow )   ! save only ocean delayed global communication variables 
     145                     CALL iom_rstput( kt, nitrst, numrow, 'rdt'    , rn_Dt       )   ! dynamics time step 
     146                     IF(.NOT.lwxios) CALL iom_delay_rst( 'WRITE', 'OCE', numrow )   ! save only ocean delayed global communication variables 
    148147 
    149148      IF ( .NOT. ln_diurnal_only ) THEN 
    150                      CALL iom_rstput( kt, nitrst, numrow, 'ub'     , uu(:,:,:       ,Kbb), ldxios = lwxios        )     ! before fields 
    151                      CALL iom_rstput( kt, nitrst, numrow, 'vb'     , vv(:,:,:       ,Kbb), ldxios = lwxios        ) 
    152                      CALL iom_rstput( kt, nitrst, numrow, 'tb'     , ts(:,:,:,jp_tem,Kbb), ldxios = lwxios ) 
    153                      CALL iom_rstput( kt, nitrst, numrow, 'sb'     , ts(:,:,:,jp_sal,Kbb), ldxios = lwxios ) 
    154                      CALL iom_rstput( kt, nitrst, numrow, 'sshb'   ,ssh(:,:         ,Kbb), ldxios = lwxios      ) 
     149                     CALL iom_rstput( kt, nitrst, numrow, 'ub'     , uu(:,:,:       ,Kbb) )     ! before fields 
     150                     CALL iom_rstput( kt, nitrst, numrow, 'vb'     , vv(:,:,:       ,Kbb) ) 
     151                     CALL iom_rstput( kt, nitrst, numrow, 'tb'     , ts(:,:,:,jp_tem,Kbb) ) 
     152                     CALL iom_rstput( kt, nitrst, numrow, 'sb'     , ts(:,:,:,jp_sal,Kbb) ) 
     153                     CALL iom_rstput( kt, nitrst, numrow, 'sshb'   , ssh(:,:         ,Kbb)) 
    155154                     ! 
    156                      CALL iom_rstput( kt, nitrst, numrow, 'un'     , uu(:,:,:       ,Kmm), ldxios = lwxios        )     ! now fields 
    157                      CALL iom_rstput( kt, nitrst, numrow, 'vn'     , vv(:,:,:       ,Kmm), ldxios = lwxios        ) 
    158                      CALL iom_rstput( kt, nitrst, numrow, 'tn'     , ts(:,:,:,jp_tem,Kmm), ldxios = lwxios ) 
    159                      CALL iom_rstput( kt, nitrst, numrow, 'sn'     , ts(:,:,:,jp_sal,Kmm), ldxios = lwxios ) 
    160                      CALL iom_rstput( kt, nitrst, numrow, 'sshn'   ,ssh(:,:         ,Kmm), ldxios = lwxios      ) 
    161                      CALL iom_rstput( kt, nitrst, numrow, 'rhop'   , rhop, ldxios = lwxios      ) 
     155                     CALL iom_rstput( kt, nitrst, numrow, 'un'     , uu(:,:,:       ,Kmm) )     ! now fields 
     156                     CALL iom_rstput( kt, nitrst, numrow, 'vn'     , vv(:,:,:       ,Kmm) ) 
     157                     CALL iom_rstput( kt, nitrst, numrow, 'tn'     , ts(:,:,:,jp_tem,Kmm) ) 
     158                     CALL iom_rstput( kt, nitrst, numrow, 'sn'     , ts(:,:,:,jp_sal,Kmm) ) 
     159                     CALL iom_rstput( kt, nitrst, numrow, 'sshn'   , ssh(:,:         ,Kmm)) 
     160                     CALL iom_rstput( kt, nitrst, numrow, 'rhop'   , rhop      ) 
    162161      ENDIF 
    163162       
    164       IF (ln_diurnal) CALL iom_rstput( kt, nitrst, numrow, 'Dsst', x_dsst, ldxios = lwxios )   
    165       IF(lwxios) CALL iom_swap(      cxios_context          ) 
     163      IF (ln_diurnal) CALL iom_rstput( kt, nitrst, numrow, 'Dsst', x_dsst )   
    166164      IF( kt == nitrst ) THEN 
    167165         IF(.NOT.lwxios) THEN 
    168166            CALL iom_close( numrow )     ! close the restart file (only at last time step) 
    169167         ELSE 
    170             CALL iom_context_finalize(      cwxios_context          ) 
     168            CALL iom_context_finalize(      cw_ocerst_cxt          ) 
     169            iom_file(numrow)%nfid       = 0 
     170            numrow = 0 
    171171         ENDIF 
    172172!!gm         IF( .NOT. lk_trdmld )   lrst_oce = .FALSE. 
    … …  
    191191      !!                the file has already been opened 
    192192      !!---------------------------------------------------------------------- 
    193       LOGICAL        ::   llok 
    194       CHARACTER(lc)  ::   clpath   ! full path to ocean output restart file 
     193      LOGICAL             ::   llok 
     194      CHARACTER(len=lc)   ::   clpath   ! full path to ocean output restart file 
     195      CHARACTER(len=lc+2) ::   clpname  ! file name including agrif prefix 
    195196      !!---------------------------------------------------------------------- 
    196197      ! 
    … …  
    209210! can handle checking if variable is in the restart file (there will be no need to open 
    210211! restart) 
    211          IF(.NOT.lxios_set) lrxios = lrxios.AND.lxios_sini 
     212         lrxios = lrxios.AND.lxios_sini 
     213 
    212214         IF( lrxios) THEN 
    213              crxios_context = 'nemo_rst' 
    214              IF( .NOT.lxios_set ) THEN 
    215                  IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS' 
    216                  CALL iom_init( crxios_context ) 
    217                  lxios_set = .TRUE. 
    218              ENDIF 
    219          ENDIF 
    220          IF( TRIM(Agrif_CFixed()) /= '0' .AND. lrxios) THEN 
    221              CALL iom_init( crxios_context ) 
    222              IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS for AGRIF' 
    223              lxios_set = .TRUE. 
    224          ENDIF  
     215             cr_ocerst_cxt = 'oce_rst' 
     216             IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS' 
     217!            IF( TRIM(Agrif_CFixed()) == '0' ) THEN 
     218!               clpname = cn_ocerst_in 
     219!            ELSE 
     220!               clpname = TRIM(Agrif_CFixed())//"_"//cn_ocerst_in    
     221!            ENDIF 
     222             CALL iom_init( cr_ocerst_cxt, kdid = numror, ld_closedef = .TRUE. ) 
     223             CALL iom_swap(      cxios_context          ) 
     224         ENDIF 
     225 
    225226      ENDIF 
    226227 
    … …  
    246247      ! Check dynamics and tracer time-step consistency and force Euler restart if changed 
    247248      IF( iom_varid( numror, 'rdt', ldstop = .FALSE. ) > 0 )   THEN 
    248          CALL iom_get( numror, 'rdt', zrdt, ldxios = lrxios ) 
     249         CALL iom_get( numror, 'rdt', zrdt ) 
    249250         IF( zrdt /= rn_Dt ) THEN 
    250251            IF(lwp) WRITE( numout,*) 
    … …  
    256257      ENDIF 
    257258 
    258       CALL iom_delay_rst( 'READ', 'OCE', numror )   ! read only ocean delayed global communication variables 
     259      IF(.NOT.lrxios ) CALL iom_delay_rst( 'READ', 'OCE', numror )   ! read only ocean delayed global communication variables 
    259260       
    260261      ! Diurnal DSST  
    261       IF( ln_diurnal ) CALL iom_get( numror, jpdom_auto, 'Dsst' , x_dsst, ldxios = lrxios )  
     262      IF( ln_diurnal ) CALL iom_get( numror, jpdom_auto, 'Dsst' , x_dsst )  
    262263      IF ( ln_diurnal_only ) THEN  
    263264         IF(lwp) WRITE( numout, * ) & 
    264265         &   "rst_read:- ln_diurnal_only set, setting rhop=rho0"  
    265266         rhop = rho0 
    266          CALL iom_get( numror, jpdom_auto, 'tn'     , w3d, ldxios = lrxios )  
     267         CALL iom_get( numror, jpdom_auto, 'tn'     , w3d )  
    267268         ts(:,:,1,jp_tem,Kmm) = w3d(:,:,1) 
    268269         RETURN  
    269270      ENDIF   
    270        
     271 
    271272      IF( iom_varid( numror, 'ub', ldstop = .FALSE. ) > 0 ) THEN 
    272273         ! before fields 
    273          CALL iom_get( numror, jpdom_auto, 'ub'     , uu(:,:,:       ,Kbb), ldxios = lrxios, cd_type = 'U', psgn = -1._wp ) 
    274          CALL iom_get( numror, jpdom_auto, 'vb'     , vv(:,:,:       ,Kbb), ldxios = lrxios, cd_type = 'V', psgn = -1._wp ) 
    275          CALL iom_get( numror, jpdom_auto, 'tb'     , ts(:,:,:,jp_tem,Kbb), ldxios = lrxios ) 
    276          CALL iom_get( numror, jpdom_auto, 'sb'     , ts(:,:,:,jp_sal,Kbb), ldxios = lrxios ) 
    277          CALL iom_get( numror, jpdom_auto, 'sshb'   ,ssh(:,:         ,Kbb), ldxios = lrxios ) 
     274         CALL iom_get( numror, jpdom_auto, 'ub'     , uu(:,:,:       ,Kbb), cd_type = 'U', psgn = -1._wp ) 
     275         CALL iom_get( numror, jpdom_auto, 'vb'     , vv(:,:,:       ,Kbb), cd_type = 'V', psgn = -1._wp ) 
     276         CALL iom_get( numror, jpdom_auto, 'tb'     , ts(:,:,:,jp_tem,Kbb) ) 
     277         CALL iom_get( numror, jpdom_auto, 'sb'     , ts(:,:,:,jp_sal,Kbb) ) 
     278         CALL iom_get( numror, jpdom_auto, 'sshb'   ,ssh(:,:         ,Kbb) ) 
    278279      ELSE 
    279280         l_1st_euler =  .TRUE.      ! before field not found, forced euler 1st time-step 
    … …  
    281282      ! 
    282283      ! now fields 
    283       CALL iom_get( numror, jpdom_auto, 'un'     , uu(:,:,:       ,Kmm), ldxios = lrxios, cd_type = 'U', psgn = -1._wp ) 
    284       CALL iom_get( numror, jpdom_auto, 'vn'     , vv(:,:,:       ,Kmm), ldxios = lrxios, cd_type = 'V', psgn = -1._wp ) 
    285       CALL iom_get( numror, jpdom_auto, 'tn'     , ts(:,:,:,jp_tem,Kmm), ldxios = lrxios ) 
    286       CALL iom_get( numror, jpdom_auto, 'sn'     , ts(:,:,:,jp_sal,Kmm), ldxios = lrxios ) 
    287       CALL iom_get( numror, jpdom_auto, 'sshn'   ,ssh(:,:         ,Kmm), ldxios = lrxios ) 
     284      CALL iom_get( numror, jpdom_auto, 'un'     , uu(:,:,:       ,Kmm), cd_type = 'U', psgn = -1._wp ) 
     285      CALL iom_get( numror, jpdom_auto, 'vn'     , vv(:,:,:       ,Kmm), cd_type = 'V', psgn = -1._wp ) 
     286      CALL iom_get( numror, jpdom_auto, 'tn'     , ts(:,:,:,jp_tem,Kmm) ) 
     287      CALL iom_get( numror, jpdom_auto, 'sn'     , ts(:,:,:,jp_sal,Kmm) ) 
     288      CALL iom_get( numror, jpdom_auto, 'sshn'   ,ssh(:,:         ,Kmm) ) 
    288289      IF( iom_varid( numror, 'rhop', ldstop = .FALSE. ) > 0 ) THEN 
    289          CALL iom_get( numror, jpdom_auto, 'rhop'   , rhop, ldxios = lrxios )   ! now    potential density 
     290         CALL iom_get( numror, jpdom_auto, 'rhop'   , rhop )   ! now    potential density 
    290291      ELSE 
    291292         CALL eos( ts(:,:,:,:,Kmm), rhd, rhop, gdept(:,:,:,Kmm) )    

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/ISF/isfcav.F90

    r13226 r14012  
    183183      ! cavity mask 
    184184      mskisf_cav(:,:)    = (1._wp - tmask(:,:,1)) * ssmask(:,:) 
    185       ! 
    186       !================ 
    187       ! 2: read restart 
     185      !================ 
     186      ! 2: activate restart 
     187      !================ 
     188      ! 
     189      !================ 
     190      ! 3: read restart 
    188191      !================ 
    189192      ! 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/ISF/isfcpl.F90

    r13899 r14012  
    120120      e3t(:,:,:,Kbb)   = e3t(:,:,:,Kmm) 
    121121#endif  
    122       ! prepare writing restart 
    123       IF( lwxios ) THEN 
    124          CALL iom_set_rstw_var_active('ssmask') 
    125          CALL iom_set_rstw_var_active('tmask') 
    126          CALL iom_set_rstw_var_active('e3t_n') 
    127          CALL iom_set_rstw_var_active('e3u_n') 
    128          CALL iom_set_rstw_var_active('e3v_n') 
    129       END IF 
    130       ! 
    131122   END SUBROUTINE isfcpl_init 
    132123   !  
    … …  
    153144      END DO  
    154145      ! 
    155       IF( lwxios ) CALL iom_swap( cwxios_context ) 
    156       CALL iom_rstput( kt, nitrst, numrow, 'tmask'  , tmask , ldxios = lwxios ) 
    157       CALL iom_rstput( kt, nitrst, numrow, 'ssmask' , ssmask, ldxios = lwxios ) 
    158       CALL iom_rstput( kt, nitrst, numrow, 'e3t_n'  , ze3t , ldxios = lwxios ) 
    159       CALL iom_rstput( kt, nitrst, numrow, 'e3u_n'  , ze3u , ldxios = lwxios ) 
    160       CALL iom_rstput( kt, nitrst, numrow, 'e3v_n'  , ze3v , ldxios = lwxios ) 
    161       CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', zgdepw , ldxios = lwxios ) 
    162       IF( lwxios ) CALL iom_swap( cxios_context ) 
     146      CALL iom_rstput( kt, nitrst, numrow, 'tmask'  , tmask  ) 
     147      CALL iom_rstput( kt, nitrst, numrow, 'ssmask' , ssmask ) 
     148      CALL iom_rstput( kt, nitrst, numrow, 'e3t_n'  , ze3t   ) 
     149      CALL iom_rstput( kt, nitrst, numrow, 'e3u_n'  , ze3u   ) 
     150      CALL iom_rstput( kt, nitrst, numrow, 'e3v_n'  , ze3v   ) 
     151      CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', zgdepw ) 
    163152      ! 
    164153   END SUBROUTINE isfcpl_rst_write 
    … …  
    183172      !!---------------------------------------------------------------------- 
    184173      ! 
    185       CALL iom_get( numror, jpdom_auto, 'ssmask'  , zssmask_b, ldxios = lrxios   ) ! need to extrapolate T/S 
     174      CALL iom_get( numror, jpdom_auto, 'ssmask'  , zssmask_b   ) ! need to extrapolate T/S 
    186175 
    187176      ! compute new ssh if we open a full water column  
    … …  
    264253      !!---------------------------------------------------------------------- 
    265254      !  
    266       CALL iom_get( numror, jpdom_auto, 'tmask'  , ztmask_b, ldxios = lrxios   ) ! need to extrapolate T/S 
    267       !CALL iom_get( numror, jpdom_auto, 'wmask'  , zwmask_b, ldxios = lrxios   ) ! need to extrapolate T/S 
    268       !CALL iom_get( numror, jpdom_auto, 'gdepw_n', zdepw_b(:,:,:), ldxios = lrxios ) ! need to interpol vertical profile (vvl) 
     255      CALL iom_get( numror, jpdom_auto, 'tmask'  , ztmask_b   ) ! need to extrapolate T/S 
     256      !CALL iom_get( numror, jpdom_auto, 'wmask'  , zwmask_b  ) ! need to extrapolate T/S 
     257      !CALL iom_get( numror, jpdom_auto, 'gdepw_n', zdepw_b(:,:,:) ) ! need to interpol vertical profile (vvl) 
    269258      ! 
    270259      !  
    … …  
    410399      !!---------------------------------------------------------------------- 
    411400      ! 
    412       CALL iom_get( numror, jpdom_auto, 'tmask'  , ztmask_b, ldxios = lrxios ) 
    413       CALL iom_get( numror, jpdom_auto, 'e3u_n'  , ze3u_b  , ldxios = lrxios ) 
    414       CALL iom_get( numror, jpdom_auto, 'e3v_n'  , ze3v_b  , ldxios = lrxios ) 
     401      CALL iom_get( numror, jpdom_auto, 'tmask'  , ztmask_b ) 
     402      CALL iom_get( numror, jpdom_auto, 'e3u_n'  , ze3u_b  ) 
     403      CALL iom_get( numror, jpdom_auto, 'e3v_n'  , ze3v_b  ) 
    415404      ! 
    416405      ! 1.0: compute horizontal volume flux divergence difference before-after coupling 
    … …  
    520509 
    521510      ! get restart variable 
    522       CALL iom_get( numror, jpdom_auto, 'tmask'  , ztmask_b(:,:,:), ldxios = lrxios  ) ! need to extrapolate T/S 
    523       CALL iom_get( numror, jpdom_auto, 'e3t_n'  , ze3t_b(:,:,:)  , ldxios = lrxios ) 
    524       CALL iom_get( numror, jpdom_auto, 'tn'     , zt_b(:,:,:)    , ldxios = lrxios ) 
    525       CALL iom_get( numror, jpdom_auto, 'sn'     , zs_b(:,:,:)    , ldxios = lrxios ) 
     511      CALL iom_get( numror, jpdom_auto, 'tmask'  , ztmask_b(:,:,:) ) ! need to extrapolate T/S 
     512      CALL iom_get( numror, jpdom_auto, 'e3t_n'  , ze3t_b(:,:,:)  ) 
     513      CALL iom_get( numror, jpdom_auto, 'tn'     , zt_b(:,:,:)    ) 
     514      CALL iom_get( numror, jpdom_auto, 'sn'     , zs_b(:,:,:)    ) 
    526515 
    527516      ! compute run length 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/ISF/isfrst.F90

    r13899 r14012  
    5353      IF( iom_varid( numror, cfwf_b, ldstop = .FALSE. ) > 0 ) THEN 
    5454         IF(lwp) WRITE(numout,*) '          nit000-1 isf tracer content forcing fields read in the restart file' 
    55          CALL iom_get( numror, jpdom_auto, cfwf_b, pfwf_b(:,:)        , ldxios = lrxios )   ! before ice shelf melt 
    56          CALL iom_get( numror, jpdom_auto, chc_b , ptsc_b (:,:,jp_tem), ldxios = lrxios )   ! before ice shelf heat flux 
    57          CALL iom_get( numror, jpdom_auto, csc_b , ptsc_b (:,:,jp_sal), ldxios = lrxios )   ! before ice shelf heat flux 
     55         CALL iom_get( numror, jpdom_auto, cfwf_b, pfwf_b(:,:)        )   ! before ice shelf melt 
     56         CALL iom_get( numror, jpdom_auto, chc_b , ptsc_b (:,:,jp_tem) )   ! before ice shelf heat flux 
     57         CALL iom_get( numror, jpdom_auto, csc_b , ptsc_b (:,:,jp_sal) )   ! before ice shelf heat flux 
    5858      ELSE 
    5959         pfwf_b(:,:)   = pfwf(:,:) 
    … …  
    6161      ENDIF 
    6262      ! 
    63       IF( lwxios ) THEN 
    64          CALL iom_set_rstw_var_active(TRIM(chc_b )) 
    65          CALL iom_set_rstw_var_active(TRIM(csc_b )) 
    66          CALL iom_set_rstw_var_active(TRIM(cfwf_b)) 
    67       ENDIF 
    68  
    6963   END SUBROUTINE isfrst_read 
    7064   !  
    … …  
    9589      ! 
    9690      ! write restart variable 
    97       IF( lwxios ) CALL iom_swap( cwxios_context ) 
    98       CALL iom_rstput( kt, nitrst, numrow, cfwf_b, pfwf(:,:)       , ldxios = lwxios ) 
    99       CALL iom_rstput( kt, nitrst, numrow, chc_b , ptsc(:,:,jp_tem), ldxios = lwxios ) 
    100       CALL iom_rstput( kt, nitrst, numrow, csc_b , ptsc(:,:,jp_sal), ldxios = lwxios ) 
    101       IF( lwxios ) CALL iom_swap( cxios_context ) 
     91      CALL iom_rstput( kt, nitrst, numrow, cfwf_b, pfwf(:,:)        ) 
     92      CALL iom_rstput( kt, nitrst, numrow, chc_b , ptsc(:,:,jp_tem) ) 
     93      CALL iom_rstput( kt, nitrst, numrow, csc_b , ptsc(:,:,jp_sal) ) 
    10294      ! 
    10395   END SUBROUTINE isfrst_write 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/LBC/lbc_lnk_multi_generic.h90

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

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/LBC/lbclnk.F90

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

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/LBC/lib_mpp.F90

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

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/LBC/mpp_lnk_generic.h90

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

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/LBC/mppini.F90

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

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/LDF/ldfc1d_c2d.F90

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

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/LDF/ldftra.F90

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

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/SBC/sbcapr.F90

    r13899 r14012  
    6565      CHARACTER(len=100) ::  cn_dir   ! Root directory for location of ssr files 
    6666      TYPE(FLD_N)        ::  sn_apr   ! informations about the fields to be read 
    67       LOGICAL            ::  lrxios   ! read restart using XIOS? 
    6867      !! 
    6968      NAMELIST/namsbc_apr/ cn_dir, sn_apr, ln_ref_apr, rn_pref, ln_apr_obc 
    … …  
    108107            CALL ctl_warn( 'sbc_apr: use inverse barometer ssh at open boundary ONLY requires ln_apr_dyn=T' ) 
    109108      ! 
    110       IF( lwxios ) THEN 
    111          CALL iom_set_rstw_var_active('ssh_ibb') 
    112       ENDIF 
    113109   END SUBROUTINE sbc_apr_init 
    114110 
    … …  
    154150         IF( ln_rstart .AND. iom_varid( numror, 'ssh_ibb', ldstop = .FALSE. ) > 0 ) THEN  
    155151            IF(lwp) WRITE(numout,*) 'sbc_apr:   ssh_ibb read in the restart file' 
    156             CALL iom_get( numror, jpdom_auto, 'ssh_ibb', ssh_ibb, ldxios = lrxios )   ! before inv. barometer ssh 
     152            CALL iom_get( numror, jpdom_auto, 'ssh_ibb', ssh_ibb )   ! before inv. barometer ssh 
    157153            ! 
    158154         ELSE                                         !* no restart: set from nit000 values 
    … …  
    167163         IF(lwp) WRITE(numout,*) 'sbc_apr : ssh_ib written in ocean restart file at it= ', kt,' date= ', ndastp 
    168164         IF(lwp) WRITE(numout,*) '~~~~' 
    169          IF( lwxios ) CALL iom_swap(      cwxios_context          ) 
    170          CALL iom_rstput( kt, nitrst, numrow, 'ssh_ibb' , ssh_ib, ldxios = lwxios ) 
    171          IF( lwxios ) CALL iom_swap(      cxios_context          ) 
     165         CALL iom_rstput( kt, nitrst, numrow, 'ssh_ibb' , ssh_ib ) 
    172166      ENDIF 
    173167      ! 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/SBC/sbcflx.F90

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

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/SBC/sbcmod.F90

    r13899 r14012  
    359359      IF( ln_wave     )   CALL sbc_wave_init                     ! surface wave initialisation 
    360360      ! 
    361       IF( lwxios ) THEN 
    362          CALL iom_set_rstw_var_active('utau_b') 
    363          CALL iom_set_rstw_var_active('vtau_b') 
    364          CALL iom_set_rstw_var_active('qns_b') 
    365          ! The 3D heat content due to qsr forcing is treated in traqsr 
    366          ! CALL iom_set_rstw_var_active('qsr_b') 
    367          CALL iom_set_rstw_var_active('emp_b') 
    368          CALL iom_set_rstw_var_active('sfx_b') 
    369       ENDIF 
    370  
    371361   END SUBROUTINE sbc_init 
    372362 
    … …  
    510500            & iom_varid( numror, 'utau_b', ldstop = .FALSE. ) > 0 ) THEN 
    511501            IF(lwp) WRITE(numout,*) '          nit000-1 surface forcing fields red in the restart file' 
    512             CALL iom_get( numror, jpdom_auto, 'utau_b', utau_b, ldxios = lrxios, cd_type = 'U', psgn = -1._wp )   ! before i-stress  (U-point) 
    513             CALL iom_get( numror, jpdom_auto, 'vtau_b', vtau_b, ldxios = lrxios, cd_type = 'V', psgn = -1._wp )   ! before j-stress  (V-point) 
    514             CALL iom_get( numror, jpdom_auto,  'qns_b',  qns_b, ldxios = lrxios )   ! before non solar heat flux (T-point) 
     502            CALL iom_get( numror, jpdom_auto, 'utau_b', utau_b )   ! before i-stress  (U-point) 
     503            CALL iom_get( numror, jpdom_auto, 'vtau_b', vtau_b )   ! before j-stress  (V-point) 
     504            CALL iom_get( numror, jpdom_auto,  'qns_b',  qns_b )   ! before non solar heat flux (T-point) 
    515505            ! The 3D heat content due to qsr forcing is treated in traqsr 
    516             ! CALL iom_get( numror, jpdom_auto, 'qsr_b' , qsr_b, ldxios = lrxios  ) ! before     solar heat flux (T-point) 
    517             CALL iom_get( numror, jpdom_auto, 'emp_b', emp_b, ldxios = lrxios  )    ! before     freshwater flux (T-point) 
     506            ! CALL iom_get( numror, jpdom_auto, 'qsr_b' , qsr_b  ) ! before     solar heat flux (T-point) 
     507            CALL iom_get( numror, jpdom_auto, 'emp_b', emp_b  )    ! before     freshwater flux (T-point) 
    518508            ! To ensure restart capability with 3.3x/3.4 restart files    !! to be removed in v3.6 
    519509            IF( iom_varid( numror, 'sfx_b', ldstop = .FALSE. ) > 0 ) THEN 
    520                CALL iom_get( numror, jpdom_auto, 'sfx_b', sfx_b, ldxios = lrxios )  ! before salt flux (T-point) 
     510               CALL iom_get( numror, jpdom_auto, 'sfx_b', sfx_b )  ! before salt flux (T-point) 
    521511            ELSE 
    522512               sfx_b (:,:) = sfx(:,:) 
    … …  
    538528            &                    'at it= ', kt,' date= ', ndastp 
    539529         IF(lwp) WRITE(numout,*) '~~~~' 
    540          IF( lwxios ) CALL iom_swap(      cwxios_context          ) 
    541          CALL iom_rstput( kt, nitrst, numrow, 'utau_b' , utau, ldxios = lwxios ) 
    542          CALL iom_rstput( kt, nitrst, numrow, 'vtau_b' , vtau, ldxios = lwxios ) 
    543          CALL iom_rstput( kt, nitrst, numrow, 'qns_b'  , qns, ldxios = lwxios  ) 
     530         CALL iom_rstput( kt, nitrst, numrow, 'utau_b' , utau ) 
     531         CALL iom_rstput( kt, nitrst, numrow, 'vtau_b' , vtau ) 
     532         CALL iom_rstput( kt, nitrst, numrow, 'qns_b'  , qns  ) 
    544533         ! The 3D heat content due to qsr forcing is treated in traqsr 
    545534         ! CALL iom_rstput( kt, nitrst, numrow, 'qsr_b'  , qsr  ) 
    546          CALL iom_rstput( kt, nitrst, numrow, 'emp_b'  , emp, ldxios = lwxios  ) 
    547          CALL iom_rstput( kt, nitrst, numrow, 'sfx_b'  , sfx, ldxios = lwxios  ) 
    548          IF( lwxios ) CALL iom_swap(      cxios_context          ) 
     535         CALL iom_rstput( kt, nitrst, numrow, 'emp_b'  , emp  ) 
     536         CALL iom_rstput( kt, nitrst, numrow, 'sfx_b'  , sfx  ) 
    549537      ENDIF 
    550538      !                                                ! ---------------------------------------- ! 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/SBC/sbcrnf.F90

    r13899 r14012  
    160160            & iom_varid( numror, 'rnf_b', ldstop = .FALSE. ) > 0 ) THEN 
    161161            IF(lwp) WRITE(numout,*) '          nit000-1 runoff forcing fields red in the restart file', lrxios 
    162             CALL iom_get( numror, jpdom_auto, 'rnf_b', rnf_b, ldxios = lrxios )     ! before runoff 
    163             CALL iom_get( numror, jpdom_auto, 'rnf_hc_b', rnf_tsc_b(:,:,jp_tem), ldxios = lrxios )   ! before heat content of runoff 
    164             CALL iom_get( numror, jpdom_auto, 'rnf_sc_b', rnf_tsc_b(:,:,jp_sal), ldxios = lrxios )   ! before salinity content of runoff 
     162            CALL iom_get( numror, jpdom_auto, 'rnf_b', rnf_b )     ! before runoff 
     163            CALL iom_get( numror, jpdom_auto, 'rnf_hc_b', rnf_tsc_b(:,:,jp_tem) )   ! before heat content of runoff 
     164            CALL iom_get( numror, jpdom_auto, 'rnf_sc_b', rnf_tsc_b(:,:,jp_sal) )   ! before salinity content of runoff 
    165165         ELSE                                                   !* no restart: set from nit000 values 
    166166            IF(lwp) WRITE(numout,*) '          nit000-1 runoff forcing fields set to nit000' 
    … …  
    176176            &                    'at it= ', kt,' date= ', ndastp 
    177177         IF(lwp) WRITE(numout,*) '~~~~' 
    178          IF( lwxios ) CALL iom_swap(      cwxios_context          ) 
    179          CALL iom_rstput( kt, nitrst, numrow, 'rnf_b' , rnf, ldxios = lwxios ) 
    180          CALL iom_rstput( kt, nitrst, numrow, 'rnf_hc_b', rnf_tsc(:,:,jp_tem), ldxios = lwxios ) 
    181          CALL iom_rstput( kt, nitrst, numrow, 'rnf_sc_b', rnf_tsc(:,:,jp_sal), ldxios = lwxios ) 
    182          IF( lwxios ) CALL iom_swap(      cxios_context          ) 
     178         CALL iom_rstput( kt, nitrst, numrow, 'rnf_b' , rnf ) 
     179         CALL iom_rstput( kt, nitrst, numrow, 'rnf_hc_b', rnf_tsc(:,:,jp_tem) ) 
     180         CALL iom_rstput( kt, nitrst, numrow, 'rnf_sc_b', rnf_tsc(:,:,jp_sal) ) 
    183181      ENDIF 
    184182      ! 
    … …  
    480478      ENDIF 
    481479      ! 
    482       IF( lwxios ) THEN 
    483          CALL iom_set_rstw_var_active('rnf_b') 
    484          CALL iom_set_rstw_var_active('rnf_hc_b') 
    485          CALL iom_set_rstw_var_active('rnf_sc_b') 
    486       ENDIF 
    487  
    488480   END SUBROUTINE sbc_rnf_init 
    489481 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/SBC/sbcssm.F90

    r13899 r14012  
    154154            IF(lwp) WRITE(numout,*) '~~~~~~~' 
    155155            zf_sbc = REAL( nn_fsbc, wp ) 
    156             IF( lwxios ) CALL iom_swap(      cwxios_context          ) 
    157             CALL iom_rstput( kt, nitrst, numrow, 'nn_fsbc', zf_sbc, ldxios = lwxios )    ! sbc frequency 
    158             CALL iom_rstput( kt, nitrst, numrow, 'ssu_m'  , ssu_m, ldxios = lwxios  )    ! sea surface mean fields 
    159             CALL iom_rstput( kt, nitrst, numrow, 'ssv_m'  , ssv_m, ldxios = lwxios  ) 
    160             CALL iom_rstput( kt, nitrst, numrow, 'sst_m'  , sst_m, ldxios = lwxios  ) 
    161             CALL iom_rstput( kt, nitrst, numrow, 'sss_m'  , sss_m, ldxios = lwxios  ) 
    162             CALL iom_rstput( kt, nitrst, numrow, 'ssh_m'  , ssh_m, ldxios = lwxios  ) 
    163             CALL iom_rstput( kt, nitrst, numrow, 'e3t_m'  , e3t_m, ldxios = lwxios  ) 
    164             CALL iom_rstput( kt, nitrst, numrow, 'frq_m'  , frq_m, ldxios = lwxios  ) 
    165             ! 
    166             IF( lwxios ) CALL iom_swap(      cxios_context          ) 
     156            CALL iom_rstput( kt, nitrst, numrow, 'nn_fsbc', zf_sbc )    ! sbc frequency 
     157            CALL iom_rstput( kt, nitrst, numrow, 'ssu_m'  , ssu_m  )    ! sea surface mean fields 
     158            CALL iom_rstput( kt, nitrst, numrow, 'ssv_m'  , ssv_m  ) 
     159            CALL iom_rstput( kt, nitrst, numrow, 'sst_m'  , sst_m  ) 
     160            CALL iom_rstput( kt, nitrst, numrow, 'sss_m'  , sss_m  ) 
     161            CALL iom_rstput( kt, nitrst, numrow, 'ssh_m'  , ssh_m  ) 
     162            CALL iom_rstput( kt, nitrst, numrow, 'e3t_m'  , e3t_m  ) 
     163            CALL iom_rstput( kt, nitrst, numrow, 'frq_m'  , frq_m  ) 
     164            ! 
    167165         ENDIF 
    168166         ! 
    … …  
    208206         IF( ln_rstart .AND. iom_varid( numror, 'nn_fsbc', ldstop = .FALSE. ) > 0 ) THEN 
    209207            l_ssm_mean = .TRUE. 
    210             CALL iom_get( numror            , 'nn_fsbc', zf_sbc,ldxios = lrxios )     ! sbc frequency of previous run 
    211             CALL iom_get( numror, jpdom_auto, 'ssu_m'  , ssu_m, ldxios = lrxios, cd_type = 'U', psgn = -1._wp )    ! sea surface mean velocity    (U-point) 
    212             CALL iom_get( numror, jpdom_auto, 'ssv_m'  , ssv_m, ldxios = lrxios, cd_type = 'V', psgn = -1._wp )    !   "         "    velocity    (V-point) 
    213             CALL iom_get( numror, jpdom_auto, 'sst_m'  , sst_m, ldxios = lrxios )    !   "         "    temperature (T-point) 
    214             CALL iom_get( numror, jpdom_auto, 'sss_m'  , sss_m, ldxios = lrxios )    !   "         "    salinity    (T-point) 
    215             CALL iom_get( numror, jpdom_auto, 'ssh_m'  , ssh_m, ldxios = lrxios )    !   "         "    height      (T-point) 
    216             CALL iom_get( numror, jpdom_auto, 'e3t_m'  , e3t_m, ldxios = lrxios )    ! 1st level thickness          (T-point) 
     208            CALL iom_get( numror            , 'nn_fsbc', zf_sbc )     ! sbc frequency of previous run 
     209            CALL iom_get( numror, jpdom_auto, 'ssu_m'  , ssu_m, cd_type = 'U', psgn = -1._wp )    ! sea surface mean velocity    (U-point) 
     210            CALL iom_get( numror, jpdom_auto, 'ssv_m'  , ssv_m, cd_type = 'V', psgn = -1._wp )    !   "         "    velocity    (V-point) 
     211            CALL iom_get( numror, jpdom_auto, 'sst_m'  , sst_m )    !   "         "    temperature (T-point) 
     212            CALL iom_get( numror, jpdom_auto, 'sss_m'  , sss_m )    !   "         "    salinity    (T-point) 
     213            CALL iom_get( numror, jpdom_auto, 'ssh_m'  , ssh_m )    !   "         "    height      (T-point) 
     214            CALL iom_get( numror, jpdom_auto, 'e3t_m'  , e3t_m )    ! 1st level thickness          (T-point) 
    217215            ! fraction of solar net radiation absorbed in 1st T level 
    218216            IF( iom_varid( numror, 'frq_m', ldstop = .FALSE. ) > 0 ) THEN 
    219                CALL iom_get( numror, jpdom_auto, 'frq_m'  , frq_m, ldxios = lrxios  ) 
     217               CALL iom_get( numror, jpdom_auto, 'frq_m'  , frq_m  ) 
    220218            ELSE 
    221219               frq_m(:,:) = 1._wp   ! default definition 
    … …  
    255253      IF( .NOT. ln_traqsr )   fraqsr_1lev(:,:) = 1._wp   ! default definition: qsr 100% in the fisrt level  
    256254      ! 
    257       IF( lwxios.AND.nn_fsbc > 1 ) THEN 
    258          CALL iom_set_rstw_var_active('nn_fsbc') 
    259          CALL iom_set_rstw_var_active('ssu_m') 
    260          CALL iom_set_rstw_var_active('ssv_m') 
    261          CALL iom_set_rstw_var_active('sst_m') 
    262          CALL iom_set_rstw_var_active('sss_m') 
    263          CALL iom_set_rstw_var_active('ssh_m') 
    264          CALL iom_set_rstw_var_active('e3t_m') 
    265          CALL iom_set_rstw_var_active('frq_m') 
    266       ENDIF 
    267  
    268255   END SUBROUTINE sbc_ssm_init 
    269256 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/TRA/eosbn2.F90

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

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/TRA/traadv.F90

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

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/TRA/traadv_cen.F90

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

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/TRA/traadv_fct.F90

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

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/TRA/traadv_mus.F90

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

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/TRA/traadv_qck.F90

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

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/TRA/traadv_ubs.F90

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

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/TRA/traatf.F90

    r13899 r14012  
    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/branches/2020/tickets_icb_1900/src/OCE/TRA/traatf_qco.F90

    r13899 r14012  
    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/branches/2020/tickets_icb_1900/src/OCE/TRA/trabbc.F90

    r13899 r14012  
    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/branches/2020/tickets_icb_1900/src/OCE/TRA/trabbl.F90

    r13899 r14012  
    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/branches/2020/tickets_icb_1900/src/OCE/TRA/tradmp.F90

    r13899 r14012  
    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/branches/2020/tickets_icb_1900/src/OCE/TRA/traisf.F90

    r13899 r14012  
    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/branches/2020/tickets_icb_1900/src/OCE/TRA/traldf.F90

    r12377 r14012  
    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/branches/2020/tickets_icb_1900/src/OCE/TRA/traldf_iso.F90

    r13899 r14012  
    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/branches/2020/tickets_icb_1900/src/OCE/TRA/traldf_lap_blp.F90

    r13899 r14012  
    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/branches/2020/tickets_icb_1900/src/OCE/TRA/traldf_triad.F90

    r13899 r14012  
    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/branches/2020/tickets_icb_1900/src/OCE/TRA/tramle.F90

    r13899 r14012  
    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/branches/2020/tickets_icb_1900/src/OCE/TRA/tranpc.F90

    r13899 r14012  
    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/branches/2020/tickets_icb_1900/src/OCE/TRA/traqsr.F90

    r13899 r14012  
    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, ldxios = lrxios )   ! 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          IF( lwxios ) CALL iom_swap(      cwxios_context          ) 
    295          CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b'   , qsr_hc     , ldxios = lwxios ) 
    296          CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev, ldxios = lwxios )  
    297          IF( lwxios ) CALL iom_swap(      cxios_context          ) 
     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 
    298319      ENDIF 
    299320      ! 
    … …  
    301322         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) 
    302323         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_qsr, ztrdt ) 
    303          DEALLOCATE( ztrdt )  
     324         DEALLOCATE( ztrdt ) 
    304325      ENDIF 
    305326      !                       ! print mean trends (used for debugging) 
    … …  
    431452      ! 1st ocean level attenuation coefficient (used in sbcssm) 
    432453      IF( iom_varid( numror, 'fraqsr_1lev', ldstop = .FALSE. ) > 0 ) THEN 
    433          CALL iom_get( numror, jpdom_auto, 'fraqsr_1lev'  , fraqsr_1lev, ldxios = lrxios  ) 
     454         CALL iom_get( numror, jpdom_auto, 'fraqsr_1lev'  , fraqsr_1lev  ) 
    434455      ELSE 
    435456         fraqsr_1lev(:,:) = 1._wp   ! default : no penetration 
    436457      ENDIF 
    437458      ! 
    438       IF( lwxios ) THEN 
    439          CALL iom_set_rstw_var_active('qsr_hc_b') 
    440          CALL iom_set_rstw_var_active('fraqsr_1lev') 
    441       ENDIF 
    442       ! 
    443459   END SUBROUTINE tra_qsr_init 
    444460 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/TRA/trasbc.F90

    r13899 r14012  
    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), ldxios = lrxios )   ! before heat content sbc trend 
    115             CALL iom_get( numror, jpdom_auto, 'sbc_sc_b', sbc_tsc_b(:,:,jp_sal), ldxios = lrxios )   ! 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          IF( lwxios ) CALL iom_swap(      cwxios_context          ) 
    148          CALL iom_rstput( kt, nitrst, numrow, 'sbc_hc_b', sbc_tsc(:,:,jp_tem), ldxios = lwxios ) 
    149          CALL iom_rstput( kt, nitrst, numrow, 'sbc_sc_b', sbc_tsc(:,:,jp_sal), ldxios = lwxios ) 
    150          IF( lwxios ) CALL iom_swap(      cxios_context          ) 
     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 
    151170      ENDIF 
    152171      ! 
    … …  
    157176      IF( ln_rnf ) THEN         ! input of heat and salt due to river runoff  
    158177         zfact = 0.5_wp 
    159          DO_2D( 0, 1, 0, 0 ) 
     178         DO_2D( 0, 0, 0, 0 ) 
    160179            IF( rnf(ji,jj) /= 0._wp ) THEN 
    161180               zdep = zfact / h_rnf(ji,jj) 
    … …  
    170189      ENDIF 
    171190 
    172       IF( iom_use('rnf_x_sst') )   CALL iom_put( "rnf_x_sst", rnf*pts(:,:,1,jp_tem,Kmm) )   ! runoff term on sst 
    173       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 
    174195 
    175196#if defined key_asminc 
    … …  
    182203          ! 
    183204         IF( ln_linssh ) THEN  
    184             DO_2D( 0, 1, 0, 0 ) 
     205            DO_2D( 0, 0, 0, 0 ) 
    185206               ztim = ssh_iau(ji,jj) / e3t(ji,jj,1,Kmm) 
    186207               pts(ji,jj,1,jp_tem,Krhs) = pts(ji,jj,1,jp_tem,Krhs) + pts(ji,jj,1,jp_tem,Kmm) * ztim 
    … …  
    188209            END_2D 
    189210         ELSE 
    190             DO_2D( 0, 1, 0, 0 ) 
     211            DO_2D( 0, 0, 0, 0 ) 
    191212               ztim = ssh_iau(ji,jj) / ( ht(ji,jj) + 1. - ssmask(ji, jj) ) 
    192213               pts(ji,jj,:,jp_tem,Krhs) = pts(ji,jj,:,jp_tem,Krhs) + pts(ji,jj,:,jp_tem,Kmm) * ztim 
    … …  
    204225         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_nsr, ztrdt ) 
    205226         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_nsr, ztrds ) 
    206          DEALLOCATE( ztrdt , ztrds )  
     227         DEALLOCATE( ztrdt , ztrds ) 
    207228      ENDIF 
    208229      ! 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/TRA/trazdf.F90

    r13899 r14012  
    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/branches/2020/tickets_icb_1900/src/OCE/TRA/zpshde.F90

    r13899 r14012  
    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/branches/2020/tickets_icb_1900/src/OCE/TRD/trdini.F90

    r12377 r14012  
    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/branches/2020/tickets_icb_1900/src/OCE/USR/usrdef_nam.F90

    r13899 r14012  
    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/branches/2020/tickets_icb_1900/src/OCE/ZDF/zdfgls.F90

    r13899 r14012  
    10571057      CALL gls_rst( nit000, 'READ' )      ! (en, avt_k, avm_k, hmxl_n) 
    10581058      ! 
    1059       IF( lwxios ) THEN 
    1060          CALL iom_set_rstw_var_active('en') 
    1061          CALL iom_set_rstw_var_active('avt_k') 
    1062          CALL iom_set_rstw_var_active('avm_k') 
    1063          CALL iom_set_rstw_var_active('hmxl_n') 
    1064       ENDIF 
    1065       ! 
    10661059   END SUBROUTINE zdf_gls_init 
    10671060 
    … …  
    10971090            ! 
    10981091            IF( MIN( id1, id2, id3, id4 ) > 0 ) THEN        ! all required arrays exist 
    1099                CALL iom_get( numror, jpdom_auto, 'en'    , en    , ldxios = lrxios ) 
    1100                CALL iom_get( numror, jpdom_auto, 'avt_k' , avt_k , ldxios = lrxios ) 
    1101                CALL iom_get( numror, jpdom_auto, 'avm_k' , avm_k , ldxios = lrxios ) 
    1102                CALL iom_get( numror, jpdom_auto, 'hmxl_n', hmxl_n, ldxios = lrxios ) 
     1092               CALL iom_get( numror, jpdom_auto, 'en'    , en    ) 
     1093               CALL iom_get( numror, jpdom_auto, 'avt_k' , avt_k ) 
     1094               CALL iom_get( numror, jpdom_auto, 'avm_k' , avm_k ) 
     1095               CALL iom_get( numror, jpdom_auto, 'hmxl_n', hmxl_n ) 
    11031096            ELSE                         
    11041097               IF(lwp) WRITE(numout,*) 
    … …  
    11191112         !                                   ! ------------------- 
    11201113         IF(lwp) WRITE(numout,*) '---- gls-rst ----' 
    1121          IF( lwxios ) CALL iom_swap(      cwxios_context         ) 
    1122          CALL iom_rstput( kt, nitrst, numrow, 'en'    , en    , ldxios = lwxios ) 
    1123          CALL iom_rstput( kt, nitrst, numrow, 'avt_k' , avt_k , ldxios = lwxios ) 
    1124          CALL iom_rstput( kt, nitrst, numrow, 'avm_k' , avm_k , ldxios = lwxios ) 
    1125          CALL iom_rstput( kt, nitrst, numrow, 'hmxl_n', hmxl_n, ldxios = lwxios ) 
    1126          IF( lwxios ) CALL iom_swap(      cxios_context          ) 
     1114         CALL iom_rstput( kt, nitrst, numrow, 'en'    , en     ) 
     1115         CALL iom_rstput( kt, nitrst, numrow, 'avt_k' , avt_k  ) 
     1116         CALL iom_rstput( kt, nitrst, numrow, 'avm_k' , avm_k  ) 
     1117         CALL iom_rstput( kt, nitrst, numrow, 'hmxl_n', hmxl_n ) 
    11271118         ! 
    11281119      ENDIF 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/ZDF/zdfosm.F90

    r13899 r14012  
    14371437     ghamv(:,:,:) = 0. 
    14381438     ! 
    1439      IF( lwxios ) THEN 
    1440         CALL iom_set_rstw_var_active('wn') 
    1441         CALL iom_set_rstw_var_active('hbl') 
    1442         CALL iom_set_rstw_var_active('hbli') 
    1443      ENDIF 
    14441439   END SUBROUTINE zdf_osm_init 
    14451440 
    … …  
    14741469        id1 = iom_varid( numror, 'wn'   , ldstop = .FALSE. ) 
    14751470        IF( id1 > 0 ) THEN                       ! 'wn' exists; read 
    1476            CALL iom_get( numror, jpdom_auto, 'wn', ww, ldxios = lrxios ) 
     1471           CALL iom_get( numror, jpdom_auto, 'wn', ww ) 
    14771472           WRITE(numout,*) ' ===>>>> :  ww read from restart file' 
    14781473        ELSE 
    … …  
    14831478        id2 = iom_varid( numror, 'hbli'   , ldstop = .FALSE. ) 
    14841479        IF( id1 > 0 .AND. id2 > 0) THEN                       ! 'hbl' exists; read and return 
    1485            CALL iom_get( numror, jpdom_auto, 'hbl' , hbl , ldxios = lrxios ) 
    1486            CALL iom_get( numror, jpdom_auto, 'hbli', hbli, ldxios = lrxios  ) 
     1480           CALL iom_get( numror, jpdom_auto, 'hbl' , hbl ) 
     1481           CALL iom_get( numror, jpdom_auto, 'hbli', hbli  ) 
    14871482           WRITE(numout,*) ' ===>>>> :  hbl & hbli read from restart file' 
    14881483           RETURN 
    … …  
    14961491     !!----------------------------------------------------------------------------- 
    14971492     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 
    14981495        IF(lwp) WRITE(numout,*) '---- osm-rst ----' 
    1499          CALL iom_rstput( kt, nitrst, numrow, 'wn'     , ww  , ldxios = lwxios ) 
    1500          CALL iom_rstput( kt, nitrst, numrow, 'hbl'    , hbl , ldxios = lwxios ) 
    1501          CALL iom_rstput( kt, nitrst, numrow, 'hbli'   , hbli, ldxios = lwxios ) 
     1496         CALL iom_rstput( kt, nitrst, numrow, 'wn'     , ww  ) 
     1497         CALL iom_rstput( kt, nitrst, numrow, 'hbl'    , hbl ) 
     1498         CALL iom_rstput( kt, nitrst, numrow, 'hbli'   , hbli ) 
    15021499        RETURN 
    15031500     END IF 
    … …  
    15501547      ! 
    15511548      IF( kt == nit000 ) THEN 
    1552          IF(lwp) WRITE(numout,*) 
    1553          IF(lwp) WRITE(numout,*) 'tra_osm : OSM non-local tracer fluxes' 
    1554          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 
    15551554      ENDIF 
    15561555 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/ZDF/zdfric.F90

    r13899 r14012  
    103103      CALL ric_rst( nit000, 'READ' )  !* read or initialize all required files 
    104104      ! 
    105       IF( lwxios ) THEN 
    106          CALL iom_set_rstw_var_active('avt_k') 
    107          CALL iom_set_rstw_var_active('avm_k') 
    108       ENDIF 
    109105   END SUBROUTINE zdf_ric_init 
    110106 
    … …  
    214210            ! 
    215211            IF( MIN( id1, id2 ) > 0 ) THEN         ! restart exists => read it 
    216                CALL iom_get( numror, jpdom_auto, 'avt_k', avt_k, ldxios = lrxios ) 
    217                CALL iom_get( numror, jpdom_auto, 'avm_k', avm_k, ldxios = lrxios ) 
     212               CALL iom_get( numror, jpdom_auto, 'avt_k', avt_k ) 
     213               CALL iom_get( numror, jpdom_auto, 'avm_k', avm_k ) 
    218214            ENDIF 
    219215         ENDIF 
    … …  
    223219         !                                   ! ------------------- 
    224220         IF(lwp) WRITE(numout,*) '---- ric-rst ----' 
    225          IF( lwxios ) CALL iom_swap(      cwxios_context          ) 
    226          CALL iom_rstput( kt, nitrst, numrow, 'avt_k', avt_k, ldxios = lwxios ) 
    227          CALL iom_rstput( kt, nitrst, numrow, 'avm_k', avm_k, ldxios = lwxios) 
    228          IF( lwxios ) CALL iom_swap(      cxios_context          ) 
     221         CALL iom_rstput( kt, nitrst, numrow, 'avt_k', avt_k ) 
     222         CALL iom_rstput( kt, nitrst, numrow, 'avm_k', avm_k) 
    229223         ! 
    230224      ENDIF 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/ZDF/zdftke.F90

    r13899 r14012  
    721721      CALL tke_rst( nit000, 'READ' )      ! (en, avt_k, avm_k, dissl)  
    722722      ! 
    723       IF( lwxios ) THEN 
    724          CALL iom_set_rstw_var_active('en') 
    725          CALL iom_set_rstw_var_active('avt_k') 
    726          CALL iom_set_rstw_var_active('avm_k') 
    727          CALL iom_set_rstw_var_active('dissl') 
    728       ENDIF 
    729723   END SUBROUTINE zdf_tke_init 
    730724 
    … …  
    758752            ! 
    759753            IF( MIN( id1, id2, id3, id4 ) > 0 ) THEN      ! fields exist 
    760                CALL iom_get( numror, jpdom_auto, 'en'   , en   , ldxios = lrxios ) 
    761                CALL iom_get( numror, jpdom_auto, 'avt_k', avt_k, ldxios = lrxios ) 
    762                CALL iom_get( numror, jpdom_auto, 'avm_k', avm_k, ldxios = lrxios ) 
    763                CALL iom_get( numror, jpdom_auto, 'dissl', dissl, ldxios = lrxios ) 
     754               CALL iom_get( numror, jpdom_auto, 'en'   , en    ) 
     755               CALL iom_get( numror, jpdom_auto, 'avt_k', avt_k ) 
     756               CALL iom_get( numror, jpdom_auto, 'avm_k', avm_k ) 
     757               CALL iom_get( numror, jpdom_auto, 'dissl', dissl ) 
    764758            ELSE                                          ! start TKE from rest 
    765759               IF(lwp) WRITE(numout,*) 
    … …  
    780774         !                                   ! ------------------- 
    781775         IF(lwp) WRITE(numout,*) '---- tke_rst ----' 
    782          IF( lwxios ) CALL iom_swap(      cwxios_context          )  
    783          CALL iom_rstput( kt, nitrst, numrow, 'en'   , en   , ldxios = lwxios ) 
    784          CALL iom_rstput( kt, nitrst, numrow, 'avt_k', avt_k, ldxios = lwxios ) 
    785          CALL iom_rstput( kt, nitrst, numrow, 'avm_k', avm_k, ldxios = lwxios ) 
    786          CALL iom_rstput( kt, nitrst, numrow, 'dissl', dissl, ldxios = lwxios ) 
    787          IF( lwxios ) CALL iom_swap(      cxios_context          ) 
     776         CALL iom_rstput( kt, nitrst, numrow, 'en'   , en    ) 
     777         CALL iom_rstput( kt, nitrst, numrow, 'avt_k', avt_k ) 
     778         CALL iom_rstput( kt, nitrst, numrow, 'avm_k', avm_k ) 
     779         CALL iom_rstput( kt, nitrst, numrow, 'dissl', dissl ) 
    788780         ! 
    789781      ENDIF 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/do_loop_substitute.h90

    r13899 r14012  
    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/branches/2020/tickets_icb_1900/src/OCE/nemogcm.F90

    r13899 r14012  
    437437     CALL Agrif_Declare_Var_ini   !  "      "   "   "      "  DOM 
    438438#endif 
    439                            CALL     dom_init( Nbb, Nnn, Naa, "OPA") ! Domain 
     439                           CALL     dom_init( Nbb, Nnn, Naa ) ! Domain 
    440440      IF( ln_crs       )   CALL     crs_init(      Nnn )       ! coarsened grid: domain initialization  
    441441      IF( sn_cfctl%l_prtctl )   & 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/par_oce.F90

    r13899 r14012  
    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/branches/2020/tickets_icb_1900/src/OCE/step.F90

    r13237 r14012  
    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) 
    … …  
    124126         IF( ln_crs      )   CALL iom_init( TRIM(cxios_context)//"_crs" )  ! for coarse grid 
    125127      ENDIF 
     128      IF((kstp == nitrst) .AND. lwxios) THEN 
     129         CALL iom_swap(      cw_ocerst_cxt          ) 
     130         CALL iom_init_closedef(cw_ocerst_cxt) 
     131         CALL iom_setkt( kstp - nit000 + 1,      cw_ocerst_cxt          ) 
     132#if defined key_top 
     133         CALL iom_swap(      cw_toprst_cxt          ) 
     134         CALL iom_init_closedef(cw_toprst_cxt) 
     135         CALL iom_setkt( kstp - nit000 + 1,      cw_toprst_cxt          ) 
     136#endif 
     137      ENDIF 
     138#if defined key_si3 
     139      IF(((kstp + nn_fsbc - 1) == nitrst) .AND. lwxios) THEN 
     140         CALL iom_swap(      cw_icerst_cxt          ) 
     141         CALL iom_init_closedef(cw_icerst_cxt) 
     142         CALL iom_setkt( kstp - nit000 + 1,      cw_icerst_cxt          ) 
     143      ENDIF 
     144#endif 
    126145      IF( kstp /= nit000 )   CALL day( kstp )         ! Calendar (day was already called at nit000 in day_init) 
    127146                             CALL iom_setkt( kstp - nit000 + 1,      cxios_context          )   ! tell IOM we are at time step kstp 
    … …  
    246265      ! Active tracers                               
    247266      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    248                          ts(:,:,:,:,Nrhs) = 0._wp         ! set tracer trends to zero 
    249  
    250       IF(  lk_asminc .AND. ln_asmiau .AND. & 
    251          & ln_trainc )   CALL tra_asm_inc( kstp, Nbb, Nnn, ts, Nrhs )  ! apply tracer assimilation increment 
    252                          CALL tra_sbc    ( kstp,      Nnn, ts, Nrhs )  ! surface boundary condition 
    253       IF( ln_traqsr  )   CALL tra_qsr    ( kstp,      Nnn, ts, Nrhs )  ! penetrative solar radiation qsr 
    254       IF( ln_isf     )   CALL tra_isf    ( kstp,      Nnn, ts, Nrhs )  ! ice shelf heat flux 
    255       IF( ln_trabbc  )   CALL tra_bbc    ( kstp,      Nnn, ts, Nrhs )  ! bottom heat flux 
    256       IF( ln_trabbl  )   CALL tra_bbl    ( kstp, Nbb, Nnn, ts, Nrhs )  ! advective (and/or diffusive) bottom boundary layer scheme 
    257       IF( ln_tradmp  )   CALL tra_dmp    ( kstp, Nbb, Nnn, ts, Nrhs )  ! internal damping trends 
    258       IF( ln_bdy     )   CALL bdy_tra_dmp( kstp, Nbb,      ts, Nrhs )  ! bdy damping trends 
    259 #if defined key_agrif 
    260       IF(.NOT. Agrif_Root())  &  
    261                &         CALL Agrif_Sponge_tra        ! tracers sponge 
    262 #endif 
    263                          CALL tra_adv    ( kstp, Nbb, Nnn, ts, Nrhs )  ! hor. + vert. advection ==> RHS 
    264       IF( ln_zdfosm  )   CALL tra_osm    ( kstp,      Nnn, ts, Nrhs )  ! OSMOSIS non-local tracer fluxes ==> RHS 
    265       IF( lrst_oce .AND. ln_zdfosm ) & 
    266            &             CALL osm_rst    ( kstp,      Nnn, 'WRITE'  )  ! write OSMOSIS outputs + ww (so must do here) to restarts 
    267                          CALL tra_ldf    ( kstp, Nbb, Nnn, ts, Nrhs )  ! lateral mixing 
    268  
    269                          CALL tra_zdf    ( kstp, Nbb, Nnn, Nrhs, ts, Naa  )  ! vertical mixing and after tracer fields 
    270       IF( ln_zdfnpc  )   CALL tra_npc    ( kstp,      Nnn, Nrhs, ts, Naa  )  ! update after fields by non-penetrative convection 
    271  
     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 
    272308      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    273309      ! Set boundary conditions, time filter and swap time levels 
    … …  
    338374      IF( kstp == nit000 ) THEN                          ! 1st time step only 
    339375                                        CALL iom_close( numror )   ! close input  ocean restart file 
     376         IF( lrxios )                   CALL iom_context_finalize(      cr_ocerst_cxt         ) 
    340377         IF(lwm)                        CALL FLUSH    ( numond )   ! flush output namelist oce 
    341378         IF(lwm .AND. numoni /= -1 )    CALL FLUSH    ( numoni )   ! flush output namelist ice (if exist) 
    … …  
    353390      IF( kstp == nitend .OR. nstop > 0 ) THEN  
    354391                      CALL iom_context_finalize(      cxios_context          ) ! needed for XIOS+AGRIF 
    355          IF( lrxios ) CALL iom_context_finalize(      crxios_context         ) 
    356392         IF( ln_crs ) CALL iom_context_finalize( trim(cxios_context)//"_crs" ) !  
    357393      ENDIF 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/step_oce.F90

    r12377 r14012  
    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/branches/2020/tickets_icb_1900/src/OCE/stpMLF.F90

    r13237 r14012  
    364364      IF( kstp == nitend .OR. indic < 0 ) THEN 
    365365                      CALL iom_context_finalize(      cxios_context          ) ! needed for XIOS+AGRIF 
    366          IF(lrxios) CALL iom_context_finalize(      crxios_context          ) 
     366         IF(lrxios) CALL iom_context_finalize(      cr_ocerst_cxt          ) 
    367367         IF( ln_crs ) CALL iom_context_finalize( trim(cxios_context)//"_crs" ) ! 
    368368      ENDIF 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/timing.F90

    r13899 r14012  
    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. 
Note: See TracChangeset for help on using the changeset viewer.