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

Ignore:
Timestamp:
2020-12-03T12:54:29+01:00 (4 years ago)
Author:
acc
Message:

dev_r13787_OSMOSIS_IMMERSE merge in trunk changes up to 14041

Location:
NEMO/branches/2020/dev_r13787_OSMOSIS_IMMERSE
Files:
1 deleted
93 edited
6 copied

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2020/dev_r13787_OSMOSIS_IMMERSE

    • Property svn:externals

      •  

        old new  
        88 
        99# SETTE 
        10 ^/utils/CI/sette@13559        sette 
         10^/utils/CI/sette_wave@13990         sette 

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

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

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

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

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

    r13237 r14043  
    104104      IF( ln_tradmp )   CALL tra_dmp( kstp, Nbb, Nnn, ts, Nrhs  )  ! internal damping trends- tracers 
    105105      IF(.NOT.ln_linssh)CALL tra_adv( kstp, Nbb, Nnn, ts, Nrhs  )  ! horizontal & vertical advection 
     106      IF( ln_zdfmfc  )  CALL tra_mfc( kstp, Nbb     , ts, Nrhs  )  ! Mass Flux Convection 
    106107      IF( ln_zdfosm  )  CALL tra_osm( kstp, Nnn     , ts, Nrhs  )  ! OSMOSIS non-local tracer fluxes 
    107108                        CALL tra_zdf( kstp, Nbb, Nnn, Nrhs, ts, Naa   )         ! vertical mixing 
    … …  
    122123                        CALL dyn_atf    ( kstp, Nbb, Nnn, Naa , uu, vv, e3t, e3u, e3v )  ! time filtering of "now" fields 
    123124      IF(.NOT.ln_linssh)CALL ssh_atf    ( kstp, Nbb, Nnn, Naa , ssh )                    ! time filtering of "now" sea surface height 
     125      IF( kstp == nit000 .AND. ln_linssh) THEN  
     126         ssh(:,:,Naa) = ssh(:,:,Nnn)  ! init ssh after in ln_linssh case  
     127      ENDIF 
    124128      ! 
    125129      ! Swap time levels 

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

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

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

    r13286 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/DIA/diaptr.F90

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

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

    r13558 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/DOM/dom_oce.F90

    r13557 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/DOM/domain.F90

    r13558 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/DOM/domqco.F90

    r13295 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/DOM/domutl.F90

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

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

    r13497 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/DOM/dtatsd.F90

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

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

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

  • NEMO/branches/2020/dev_r13787_OSMOSIS_IMMERSE/src/OCE/DYN/dynspg.F90

    r13497 r14043  
    66   !! History :  1.0  ! 2005-12  (C. Talandier, G. Madec, V. Garnier)  Original code 
    77   !!            3.2  ! 2009-07  (R. Benshila)  Suppression of rigid-lid option 
     8   !!            4.2  ! 2020-12  (G. Madec, E. Clementi) add Bernoulli Head for 
     9   !!                            wave coupling 
    810   !!---------------------------------------------------------------------- 
    911 
    … …  
    1921   USE sbc_ice , ONLY : snwice_mass, snwice_mass_b 
    2022   USE sbcapr         ! surface boundary condition: atmospheric pressure 
     23   USE sbcwave,  ONLY : bhd_wave 
    2124   USE dynspg_exp     ! surface pressure gradient     (dyn_spg_exp routine) 
    2225   USE dynspg_ts      ! surface pressure gradient     (dyn_spg_ts  routine) 
    … …  
    143146         ENDIF 
    144147         ! 
     148         IF( ln_wave .and. ln_bern_srfc ) THEN          !== Add J terms: depth-independent Bernoulli head 
     149            DO_2D( 0, 0, 0, 0 ) 
     150               spgu(ji,jj) = spgu(ji,jj) + ( bhd_wave(ji+1,jj) - bhd_wave(ji,jj) ) / e1u(ji,jj)   !++ bhd_wave from wave model in m2/s2 [BHD parameters in WW3] 
     151               spgv(ji,jj) = spgv(ji,jj) + ( bhd_wave(ji,jj+1) - bhd_wave(ji,jj) ) / e2v(ji,jj) 
     152            END_2D 
     153         ENDIF 
     154         ! 
    145155         DO_3D( 0, 0, 0, 0, 1, jpkm1 )       !== Add all terms to the general trend 
    146156            puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + spgu(ji,jj) 

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

    r13546 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/DYN/dynvor.F90

    r13546 r14043  
    2121   !!             -   ! 2018-03  (G. Madec)  add two new schemes (ln_dynvor_enT and ln_dynvor_eet) 
    2222   !!             -   ! 2018-04  (G. Madec)  add pre-computed gradient for metric term calculation 
     23   !!            4.2  ! 2020-12  (G. Madec, E. Clementi) add vortex force trends (ln_vortex_force=T) 
    2324   !!---------------------------------------------------------------------- 
    2425 
    … …  
    3738   USE trddyn         ! trend manager: dynamics 
    3839   USE sbcwave        ! Surface Waves (add Stokes-Coriolis force) 
    39    USE sbc_oce , ONLY : ln_stcor    ! use Stoke-Coriolis force 
     40   USE sbc_oce,  ONLY : ln_stcor, ln_vortex_force   ! use Stoke-Coriolis force 
    4041   ! 
    4142   USE lbclnk         ! ocean lateral boundary conditions (or mpp link) 
    … …  
    121122         ALLOCATE( ztrdu(jpi,jpj,jpk), ztrdv(jpi,jpj,jpk) ) 
    122123         ! 
    123          ztrdu(:,:,:) = puu(:,:,:,Krhs)            !* planetary vorticity trend (including Stokes-Coriolis force) 
     124         ztrdu(:,:,:) = puu(:,:,:,Krhs)            !* planetary vorticity trend 
    124125         ztrdv(:,:,:) = pvv(:,:,:,Krhs) 
    125126         SELECT CASE( nvor_scheme ) 
    126127         CASE( np_ENS )           ;   CALL vor_ens( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! enstrophy conserving scheme 
    127             IF( ln_stcor )            CALL vor_ens( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
    128128         CASE( np_ENE, np_MIX )   ;   CALL vor_ene( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! energy conserving scheme 
    129             IF( ln_stcor )            CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
    130129         CASE( np_ENT )           ;   CALL vor_enT( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! energy conserving scheme (T-pts) 
    131             IF( ln_stcor )            CALL vor_enT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
    132130         CASE( np_EET )           ;   CALL vor_eeT( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! energy conserving scheme (een with e3t) 
    133             IF( ln_stcor )            CALL vor_eeT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
    134131         CASE( np_EEN )           ;   CALL vor_een( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! energy & enstrophy scheme 
    135             IF( ln_stcor )            CALL vor_een( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
    136132         END SELECT 
    137133         ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) 
    … …  
    161157         CASE( np_ENT )                        !* energy conserving scheme  (T-pts) 
    162158                             CALL vor_enT( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! total vorticity trend 
    163             IF( ln_stcor )   CALL vor_enT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
     159            IF( ln_stcor .AND. .NOT. ln_vortex_force )  THEN 
     160                             CALL vor_enT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend  
     161            ELSE IF( ln_stcor .AND. ln_vortex_force )   THEN 
     162                             CALL vor_enT( kt, Kmm, ntot, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend and vortex force 
     163            ENDIF 
    164164         CASE( np_EET )                        !* energy conserving scheme (een scheme using e3t) 
    165165                             CALL vor_eeT( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! total vorticity trend 
    166             IF( ln_stcor )   CALL vor_eeT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
     166            IF( ln_stcor .AND. .NOT. ln_vortex_force )  THEN 
     167                             CALL vor_eeT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
     168            ELSE IF( ln_stcor .AND. ln_vortex_force )   THEN 
     169                             CALL vor_eeT( kt, Kmm, ntot, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend and vortex force 
     170            ENDIF 
    167171         CASE( np_ENE )                        !* energy conserving scheme 
    168172                             CALL vor_ene( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! total vorticity trend 
    169             IF( ln_stcor )   CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
     173            IF( ln_stcor .AND. .NOT. ln_vortex_force )  THEN 
     174                             CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
     175            ELSE IF( ln_stcor .AND. ln_vortex_force )   THEN 
     176                             CALL vor_ene( kt, Kmm, ntot, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend and vortex force 
     177            ENDIF 
    170178         CASE( np_ENS )                        !* enstrophy conserving scheme 
    171179                             CALL vor_ens( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )  ! total vorticity trend 
    172             IF( ln_stcor )   CALL vor_ens( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )  ! add the Stokes-Coriolis trend 
     180 
     181            IF( ln_stcor .AND. .NOT. ln_vortex_force )  THEN 
     182                             CALL vor_ens( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )  ! add the Stokes-Coriolis trend 
     183            ELSE IF( ln_stcor .AND. ln_vortex_force )   THEN 
     184                             CALL vor_ens( kt, Kmm, ntot, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )  ! add the Stokes-Coriolis trend and vortex force 
     185            ENDIF 
    173186         CASE( np_MIX )                        !* mixed ene-ens scheme 
    174187                             CALL vor_ens( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! relative vorticity or metric trend (ens) 
    175188                             CALL vor_ene( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! planetary vorticity trend (ene) 
    176             IF( ln_stcor )   CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
     189            IF( ln_stcor )        CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )        ! add the Stokes-Coriolis trend 
     190            IF( ln_vortex_force ) CALL vor_ens( kt, Kmm, nrvm, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add vortex force 
    177191         CASE( np_EEN )                        !* energy and enstrophy conserving scheme 
    178192                             CALL vor_een( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! total vorticity trend 
    179             IF( ln_stcor )   CALL vor_een( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
     193            IF( ln_stcor .AND. .NOT. ln_vortex_force )  THEN 
     194                             CALL vor_een( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
     195            ELSE IF( ln_stcor .AND. ln_vortex_force )   THEN 
     196                             CALL vor_een( kt, Kmm, ntot, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend and vortex force 
     197            ENDIF 
    180198         END SELECT 
    181199         ! 

  • NEMO/branches/2020/dev_r13787_OSMOSIS_IMMERSE/src/OCE/DYN/dynzad.F90

    r13497 r14043  
    1616   USE trd_oce        ! trends: ocean variables 
    1717   USE trddyn         ! trend manager: dynamics 
     18   USE sbcwave, ONLY: wsd   ! Surface Waves (add vertical Stokes-drift) 
    1819   ! 
    1920   USE in_out_manager ! I/O manager 
    … …  
    7980      DO jk = 2, jpkm1                ! Vertical momentum advection at level w and u- and v- vertical 
    8081         DO_2D( 0, 1, 0, 1 )              ! vertical fluxes 
     82          IF( ln_vortex_force ) THEN 
     83            zww(ji,jj) = 0.25_wp * e1e2t(ji,jj) * ( ww(ji,jj,jk) + wsd(ji,jj,jk) ) 
     84          ELSE 
    8185            zww(ji,jj) = 0.25_wp * e1e2t(ji,jj) * ww(ji,jj,jk) 
     86          ENDIF 
    8287         END_2D 
    8388         DO_2D( 0, 0, 0, 0 )              ! vertical momentum advection at w-point 

  • NEMO/branches/2020/dev_r13787_OSMOSIS_IMMERSE/src/OCE/ICB/icb_oce.F90

    r13286 r14043  
    5757   TYPE, PUBLIC ::   point              !: properties of an individual iceberg (position, mass, size, etc...) 
    5858      INTEGER  ::   year 
    59       REAL(wp) ::   xi , yj                                                   ! iceberg coordinates in the (i,j) referential (global) 
     59      REAL(wp) ::   xi , yj , zk                                              ! iceberg coordinates in the (i,j) referential (global) and deepest level affected 
    6060      REAL(wp) ::   e1 , e2                                                   ! horizontal scale factors at the iceberg position 
    6161      REAL(wp) ::   lon, lat, day                                             ! geographic position 
    6262      REAL(wp) ::   mass, thickness, width, length, uvel, vvel                ! iceberg physical properties 
    63       REAL(wp) ::   uo, vo, ui, vi, ua, va, ssh_x, ssh_y, sst, cn, hi, sss    ! properties of iceberg environment  
     63      REAL(wp) ::   ssu, ssv, ui, vi, ua, va, ssh_x, ssh_y, sst, sss, cn, hi  ! properties of iceberg environment  
    6464      REAL(wp) ::   mass_of_bits, heat_density 
     65      INTEGER  ::   kb                                                   ! icb bottom level 
    6566   END TYPE point 
    6667 
    … …  
    8586   ! Extra arrays with bigger halo, needed when interpolating forcing onto iceberg position 
    8687   ! particularly for MPP when iceberg can lie inside T grid but outside U, V, or f grid 
    87    REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE ::   uo_e, vo_e 
    88    REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE ::   ff_e, tt_e, fr_e, ss_e 
     88   REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE ::   ssu_e, ssv_e 
     89   REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE ::   sst_e, sss_e, fr_e 
    8990   REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE ::   ua_e, va_e 
    9091   REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE ::   ssh_e 
    9192   REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE ::   tmask_e, umask_e, vmask_e 
     93   REAl(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE ::   rlon_e, rlat_e, ff_e 
     94   REAl(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE ::   uoce_e, voce_e, toce_e, e3t_e 
     95   ! 
    9296#if defined key_si3 || defined key_cice 
    9397   REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE ::   hi_e, ui_e, vi_e 
    … …  
    117121   INTEGER , PUBLIC ::   nn_verbose_write                !: timesteps between verbose messages 
    118122   REAL(wp), PUBLIC ::   rn_rho_bergs                    !: Density of icebergs 
     123   REAL(wp), PUBLIC ::   rho_berg_1_oce                  !: convertion factor (thickness to draft) (rn_rho_bergs/pp_rho_seawater) 
    119124   REAL(wp), PUBLIC ::   rn_LoW_ratio                    !: Initial ratio L/W for newly calved icebergs 
    120125   REAL(wp), PUBLIC ::   rn_bits_erosion_fraction        !: Fraction of erosion melt flux to divert to bergy bits 
    … …  
    124129   LOGICAL , PUBLIC ::   ln_time_average_weight          !: Time average the weight on the ocean    !!gm I don't understand that ! 
    125130   REAL(wp), PUBLIC ::   rn_speed_limit                  !: CFL speed limit for a berg 
     131   LOGICAL , PUBLIC ::   ln_M2016, ln_icb_grd            !: use Nacho's Merino 2016 work 
    126132   ! 
    127133   ! restart 
    … …  
    135141   REAL(wp), DIMENSION(nclasses), PUBLIC ::   rn_initial_thickness !  Single instance of an icebergs type initialised in icebergs_init and updated in icebergs_run 
    136142   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   src_calving, src_calving_hflx    !: accumulate input ice 
     143   INTEGER , PUBLIC             , SAVE                     ::   micbkb                           !: deepest level affected by icebergs 
    137144   INTEGER , PUBLIC             , SAVE                     ::   numicb                           !: iceberg IO 
    138145   INTEGER , PUBLIC             , SAVE, DIMENSION(nkounts) ::   num_bergs                        !: iceberg counter 
    … …  
    171178      ! 
    172179      ! expanded arrays for bilinear interpolation 
    173       ALLOCATE( uo_e(0:jpi+1,0:jpj+1) , ua_e(0:jpi+1,0:jpj+1) ,    & 
    174          &      vo_e(0:jpi+1,0:jpj+1) , va_e(0:jpi+1,0:jpj+1) ,    & 
     180      ALLOCATE( ssu_e(0:jpi+1,0:jpj+1) , ua_e(0:jpi+1,0:jpj+1) ,   & 
     181         &      ssv_e(0:jpi+1,0:jpj+1) , va_e(0:jpi+1,0:jpj+1) ,   & 
    175182#if defined key_si3 || defined key_cice 
    176183         &      ui_e(0:jpi+1,0:jpj+1) ,                            & 
    … …  
    178185         &      hi_e(0:jpi+1,0:jpj+1) ,                            & 
    179186#endif 
    180          &      ff_e(0:jpi+1,0:jpj+1) , fr_e(0:jpi+1,0:jpj+1)  ,   & 
    181          &      tt_e(0:jpi+1,0:jpj+1) , ssh_e(0:jpi+1,0:jpj+1) ,   & 
    182          &      ss_e(0:jpi+1,0:jpj+1) ,                            &  
     187         &      fr_e(0:jpi+1,0:jpj+1) ,                            & 
     188         &      sst_e(0:jpi+1,0:jpj+1) , ssh_e(0:jpi+1,0:jpj+1) ,  & 
     189         &      sss_e(0:jpi+1,0:jpj+1) ,                           &  
    183190         &      first_width(nclasses) , first_length(nclasses) ,   & 
    184191         &      src_calving (jpi,jpj) ,                            & 
    … …  
    186193      icb_alloc = icb_alloc + ill 
    187194 
     195      IF ( ln_M2016 ) THEN 
     196         ALLOCATE( uoce_e(0:jpi+1,0:jpj+1,jpk), voce_e(0:jpi+1,0:jpj+1,jpk), & 
     197            &      toce_e(0:jpi+1,0:jpj+1,jpk), e3t_e(0:jpi+1,0:jpj+1,jpk) , STAT=ill ) 
     198         icb_alloc = icb_alloc + ill 
     199      END IF 
     200      ! 
    188201      ALLOCATE( tmask_e(0:jpi+1,0:jpj+1), umask_e(0:jpi+1,0:jpj+1), vmask_e(0:jpi+1,0:jpj+1), & 
    189          &      STAT=ill) 
     202         &      rlon_e(0:jpi+1,0:jpj+1) , rlat_e(0:jpi+1,0:jpj+1) , ff_e(0:jpi+1,0:jpj+1)   , STAT=ill) 
    190203      icb_alloc = icb_alloc + ill 
    191204 

  • NEMO/branches/2020/dev_r13787_OSMOSIS_IMMERSE/src/OCE/ICB/icbclv.F90

    r13295 r14043  
    2121   USE lbclnk         ! NEMO boundary exchanges for gridded data 
    2222 
    23    USE icb_oce        ! iceberg variables 
    2423   USE icbdia         ! iceberg diagnostics 
    2524   USE icbutl         ! iceberg utility routines 
    … …  
    142141                  newpt%mass           = rn_initial_mass     (jn) 
    143142                  newpt%thickness      = rn_initial_thickness(jn) 
     143                  newpt%kb             = 1         ! compute correctly in icbthm if needed         
    144144                  newpt%width          = first_width         (jn) 
    145145                  newpt%length         = first_length        (jn) 
    … …  
    172172      END DO 
    173173      ! 
    174       DO jn = 1, nclasses 
    175          CALL lbc_lnk( 'icbclv', berg_grid%stored_ice(:,:,jn), 'T', 1._wp ) 
    176       END DO 
    177       CALL lbc_lnk( 'icbclv', berg_grid%stored_heat, 'T', 1._wp ) 
    178       ! 
    179174      IF( nn_verbose_level > 0 .AND. icntmax > 1 )   WRITE(numicb,*) 'icb_clv: icnt=', icnt,' on', narea 
    180175      ! 

  • NEMO/branches/2020/dev_r13787_OSMOSIS_IMMERSE/src/OCE/ICB/icbdyn.F90

    r13281 r14043  
    1414   USE dom_oce        ! NEMO ocean domain 
    1515   USE phycst         ! NEMO physical constants 
     16   USE in_out_manager                      ! IO parameters 
    1617   ! 
    1718   USE icb_oce        ! define iceberg arrays 
    … …  
    9798         zyj2 = zyj1 + zdt_2 * zv1          ;   zvvel2 = zvvel1 + zdt_2 * zay1 
    9899         ! 
    99          CALL icb_ground( zxi2, zxi1, zu1,   & 
    100             &             zyj2, zyj1, zv1, ll_bounced ) 
     100         CALL icb_ground( berg, zxi2, zxi1, zu1,   & 
     101            &                   zyj2, zyj1, zv1, ll_bounced ) 
    101102 
    102103         !                                         !**   A2 = A(X2,V2) 
    … …  
    113114         zyj3  = zyj1  + zdt_2 * zv2   ;   zvvel3 = zvvel1 + zdt_2 * zay2 
    114115         ! 
    115          CALL icb_ground( zxi3, zxi1, zu3,   & 
    116             &                zyj3, zyj1, zv3, ll_bounced ) 
     116         CALL icb_ground( berg, zxi3, zxi1, zu3,   & 
     117            &                   zyj3, zyj1, zv3, ll_bounced ) 
    117118 
    118119         !                                         !**   A3 = A(X3,V3) 
    … …  
    129130         zyj4 = zyj1 + zdt * zv3   ;   zvvel4 = zvvel1 + zdt * zay3 
    130131 
    131          CALL icb_ground( zxi4, zxi1, zu4,   & 
    132             &             zyj4, zyj1, zv4, ll_bounced ) 
     132         CALL icb_ground( berg, zxi4, zxi1, zu4,   & 
     133            &                   zyj4, zyj1, zv4, ll_bounced ) 
    133134 
    134135         !                                         !**   A4 = A(X4,V4) 
    … …  
    148149         zvvel_n = pt%vvel + zdt_6 * (  zay1 + 2.*(zay2 + zay3) + zay4 ) 
    149150 
    150          CALL icb_ground( zxi_n, zxi1, zuvel_n,   & 
    151             &             zyj_n, zyj1, zvvel_n, ll_bounced ) 
     151         CALL icb_ground( berg, zxi_n, zxi1, zuvel_n,   & 
     152            &                   zyj_n, zyj1, zvvel_n, ll_bounced ) 
    152153 
    153154         pt%uvel = zuvel_n                        !** save in berg structure 
    … …  
    156157         pt%yj   = zyj_n 
    157158 
    158          ! update actual position 
    159          pt%lon  = icb_utl_bilin_x(glamt, pt%xi, pt%yj ) 
    160          pt%lat  = icb_utl_bilin(gphit, pt%xi, pt%yj, 'T' ) 
    161  
    162159         berg => berg%next                         ! switch to the next berg 
    163160         ! 
    … …  
    167164 
    168165 
    169    SUBROUTINE icb_ground( pi, pi0, pu,   & 
    170       &                   pj, pj0, pv, ld_bounced ) 
     166   SUBROUTINE icb_ground( berg, pi, pi0, pu,   & 
     167      &                         pj, pj0, pv, ld_bounced ) 
    171168      !!---------------------------------------------------------------------- 
    172169      !!                  ***  ROUTINE icb_ground  *** 
    … …  
    177174      !!                NB two possibilities available one of which is hard-coded here 
    178175      !!---------------------------------------------------------------------- 
     176      TYPE(iceberg ), POINTER, INTENT(in   ) ::   berg             ! berg 
     177      ! 
    179178      REAL(wp), INTENT(inout) ::   pi , pj      ! current iceberg position 
    180179      REAL(wp), INTENT(in   ) ::   pi0, pj0     ! previous iceberg position 
    … …  
    184183      INTEGER  ::   ii, ii0 
    185184      INTEGER  ::   ij, ij0 
     185      INTEGER  ::   ikb 
    186186      INTEGER  ::   ibounce_method 
     187      ! 
     188      REAL(wp) :: zD  
     189      REAL(wp), DIMENSION(jpk) :: ze3t 
    187190      !!---------------------------------------------------------------------- 
    188191      ! 
    … …  
    200203      ij  = mj1( ij  ) 
    201204      ! 
    202       IF(  tmask(ii,ij,1)  /=   0._wp  )   RETURN           ! berg reach a new t-cell, but an ocean one 
     205      ! assume icb is grounded if tmask(ii,ij,1) or tmask(ii,ij,ikb), depending of the option is not 0 
     206      IF ( ln_M2016 .AND. ln_icb_grd ) THEN 
     207         ! 
     208         ! draught (keel depth) 
     209         zD = rho_berg_1_oce * berg%current_point%thickness 
     210         ! 
     211         ! interpol needed data 
     212         CALL icb_utl_interp( pi, pj, pe3t=ze3t ) 
     213         !  
     214         !compute bottom level 
     215         CALL icb_utl_getkb( ikb, ze3t, zD ) 
     216         ! 
     217         ! berg reach a new t-cell, but an ocean one 
     218         ! .AND. needed in case berg hit an isf (tmask(ii,ij,1) == 0 and tmask(ii,ij,ikb) /= 0) 
     219         IF(  tmask(ii,ij,ikb) /= 0._wp .AND. tmask(ii,ij,1) /= 0._wp ) RETURN 
     220         ! 
     221      ELSE 
     222         IF(  tmask(ii,ij,1)  /=   0._wp  )   RETURN           ! berg reach a new t-cell, but an ocean one 
     223      END IF 
    203224      ! 
    204225      ! From here, berg have reach land: treat grounding/bouncing 
    … …  
    257278      REAL(wp), PARAMETER ::   pp_Cr0       = 0.06_wp    ! 
    258279      ! 
    259       INTEGER  ::   itloop 
    260       REAL(wp) ::   zuo, zui, zua, zuwave, zssh_x, zsst, zcn, zhi, zsss 
    261       REAL(wp) ::   zvo, zvi, zva, zvwave, zssh_y 
     280      INTEGER  ::   itloop, ikb, jk 
     281      REAL(wp) ::   zuo, zssu, zui, zua, zuwave, zssh_x, zcn, zhi 
     282      REAL(wp) ::   zvo, zssv, zvi, zva, zvwave, zssh_y 
    262283      REAL(wp) ::   zff, zT, zD, zW, zL, zM, zF 
    263284      REAL(wp) ::   zdrag_ocn, zdrag_atm, zdrag_ice, zwave_rad 
    264       REAL(wp) ::   z_ocn, z_atm, z_ice 
     285      REAL(wp) ::   z_ocn, z_atm, z_ice, zdep 
    265286      REAL(wp) ::   zampl, zwmod, zCr, zLwavelength, zLcutoff, zLtop 
    266287      REAL(wp) ::   zlambda, zdetA, zA11, zA12, zaxe, zaye, zD_hi 
    267288      REAL(wp) ::   zuveln, zvveln, zus, zvs, zspeed, zloc_dx, zspeed_new 
     289      REAL(wp), DIMENSION(jpk) :: zuoce, zvoce, ze3t, zdepw 
    268290      !!---------------------------------------------------------------------- 
    269291 
    270292      ! Interpolate gridded fields to berg 
    271293      nknberg = berg%number(1) 
    272       CALL icb_utl_interp( pxi, pe1, zuo, zui, zua, zssh_x,                     & 
    273          &                 pyj, pe2, zvo, zvi, zva, zssh_y, zsst, zcn, zhi, zff, zsss ) 
     294      CALL icb_utl_interp( pxi, pyj, pe1=pe1, pe2=pe2,     &   ! scale factor 
     295         &                 pssu=zssu, pui=zui, pua=zua,    &   ! oce/ice/atm velocities 
     296         &                 pssv=zssv, pvi=zvi, pva=zva,    &   ! oce/ice/atm velocities 
     297         &                 pssh_i=zssh_x, pssh_j=zssh_y,   &   ! ssh gradient 
     298         &                 phi=zhi, pff=zff)                   ! ice thickness and coriolis 
    274299 
    275300      zM = berg%current_point%mass 
    276301      zT = berg%current_point%thickness               ! total thickness 
    277       zD = ( rn_rho_bergs / pp_rho_seawater ) * zT    ! draught (keel depth) 
     302      zD = rho_berg_1_oce * zT                        ! draught (keel depth) 
    278303      zF = zT - zD                                    ! freeboard 
    279304      zW = berg%current_point%width 
    … …  
    282307      zhi   = MIN( zhi   , zD    ) 
    283308      zD_hi = MAX( 0._wp, zD-zhi ) 
    284  
    285       ! Wave radiation 
    286       zuwave = zua - zuo   ;   zvwave = zva - zvo     ! Use wind speed rel. to ocean for wave model 
     309  
     310     ! Wave radiation 
     311      zuwave = zua - zssu   ;   zvwave = zva - zssv   ! Use wind speed rel. to ocean for wave model 
    287312      zwmod  = zuwave*zuwave + zvwave*zvwave          ! The wave amplitude and length depend on the  current; 
    288313      !                                               ! wind speed relative to the ocean. Actually wmod is wmod**2 here. 
    … …  
    309334      IF( abs(zui) + abs(zvi) == 0._wp )   z_ice = 0._wp 
    310335 
     336      ! lateral velocities 
     337      ! default ssu and ssv 
     338      ! ln_M2016: mean velocity along the profile 
     339      IF ( ln_M2016 ) THEN 
     340         ! interpol needed data 
     341         CALL icb_utl_interp( pxi, pyj, puoce=zuoce, pvoce=zvoce, pe3t=ze3t )   ! 3d velocities 
     342         
     343         !compute bottom level 
     344         CALL icb_utl_getkb( ikb, ze3t, zD ) 
     345          
     346         ! compute mean velocity  
     347         CALL icb_utl_zavg(zuo, zuoce, ze3t, zD, ikb) 
     348         CALL icb_utl_zavg(zvo, zvoce, ze3t, zD, ikb) 
     349      ELSE 
     350         zuo = zssu 
     351         zvo = zssv 
     352      END IF 
     353 
    311354      zuveln = puvel   ;   zvveln = pvvel ! Copy starting uvel, vvel 
    312355      ! 
    … …  
    321364         ! Explicit accelerations 
    322365         !zaxe= zff*pvvel -grav*zssh_x +zwave_rad*zuwave & 
    323          !    -zdrag_ocn*(puvel-zuo) -zdrag_atm*(puvel-zua) -zdrag_ice*(puvel-zui) 
     366         !    -zdrag_ocn*(puvel-zssu) -zdrag_atm*(puvel-zua) -zdrag_ice*(puvel-zui) 
    324367         !zaye=-zff*puvel -grav*zssh_y +zwave_rad*zvwave & 
    325          !    -zdrag_ocn*(pvvel-zvo) -zdrag_atm*(pvvel-zva) -zdrag_ice*(pvvel-zvi) 
     368         !    -zdrag_ocn*(pvvel-zssv) -zdrag_atm*(pvvel-zva) -zdrag_ice*(pvvel-zvi) 
    326369         zaxe = -grav * zssh_x + zwave_rad * zuwave 
    327370         zaye = -grav * zssh_y + zwave_rad * zvwave 

  • NEMO/branches/2020/dev_r13787_OSMOSIS_IMMERSE/src/OCE/ICB/icbini.F90

    r13295 r14043  
    7373      ! 
    7474      IF( .NOT. ln_icebergs )   RETURN 
    75  
     75      ! 
    7676      !                          ! allocate gridded fields 
    7777      IF( icb_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'icb_alloc : unable to allocate arrays' ) 
    7878      ! 
    7979      !                          ! initialised variable with extra haloes to zero 
    80       uo_e(:,:) = 0._wp   ;   vo_e(:,:) = 0._wp   ; 
    81       ua_e(:,:) = 0._wp   ;   va_e(:,:) = 0._wp   ; 
    82       ff_e(:,:) = 0._wp   ;   tt_e(:,:) = 0._wp   ; 
    83       fr_e(:,:) = 0._wp   ;   ss_e(:,:) = 0._wp   ; 
     80      ssu_e(:,:) = 0._wp   ;   ssv_e(:,:) = 0._wp   ; 
     81      ua_e(:,:)  = 0._wp   ;   va_e(:,:)  = 0._wp   ; 
     82      ff_e(:,:)  = 0._wp   ;   sst_e(:,:) = 0._wp   ; 
     83      fr_e(:,:)  = 0._wp   ;   sss_e(:,:) = 0._wp   ; 
     84      ! 
     85      IF ( ln_M2016 ) THEN 
     86         toce_e(:,:,:) = 0._wp 
     87         uoce_e(:,:,:) = 0._wp 
     88         voce_e(:,:,:) = 0._wp 
     89         e3t_e(:,:,:)  = 0._wp 
     90      END IF 
     91      ! 
    8492#if defined key_si3 
    8593      hi_e(:,:) = 0._wp   ; 
    … …  
    100108      first_width (:) = SQRT(  rn_initial_mass(:) / ( rn_LoW_ratio * rn_rho_bergs * rn_initial_thickness(:) )  ) 
    101109      first_length(:) = rn_LoW_ratio * first_width(:) 
     110      rho_berg_1_oce  = rn_rho_bergs / pp_rho_seawater  ! scale factor used for convertion thickness to draft 
     111      ! 
     112      ! deepest level affected by icebergs 
     113      ! can be tuned but the safest is this  
     114      ! (with z* and z~ the depth of each level change overtime, so the more robust micbkb is jpk) 
     115      micbkb = jpk 
    102116 
    103117      berg_grid%calving      (:,:)   = 0._wp 
    … …  
    240254      vmask_e(:,:) = 0._wp   ;   vmask_e(1:jpi,1:jpj) = vmask(:,:,1) 
    241255      CALL lbc_lnk_icb( 'icbini', tmask_e, 'T', +1._wp, 1, 1 ) 
    242       CALL lbc_lnk_icb( 'icbini', umask_e, 'T', +1._wp, 1, 1 ) 
    243       CALL lbc_lnk_icb( 'icbini', vmask_e, 'T', +1._wp, 1, 1 ) 
    244       ! 
     256      CALL lbc_lnk_icb( 'icbini', umask_e, 'U', +1._wp, 1, 1 ) 
     257      CALL lbc_lnk_icb( 'icbini', vmask_e, 'V', +1._wp, 1, 1 ) 
     258 
     259      ! definition of extended lat/lon array needed by icb_bilin_h 
     260      rlon_e(:,:) = 0._wp     ;  rlon_e(1:jpi,1:jpj) = glamt(:,:)  
     261      rlat_e(:,:) = 0._wp     ;  rlat_e(1:jpi,1:jpj) = gphit(:,:) 
     262      CALL lbc_lnk_icb( 'icbini', rlon_e, 'T', +1._wp, 1, 1 ) 
     263      CALL lbc_lnk_icb( 'icbini', rlat_e, 'T', +1._wp, 1, 1 ) 
     264      ! 
     265      ! definnitionn of extennded ff_f array needed by icb_utl_interp 
     266      ff_e(:,:) = 0._wp       ;  ff_e(1:jpi,1:jpj) = ff_f(:,:) 
     267      CALL lbc_lnk_icb( 'icbini', ff_e, 'F', +1._wp, 1, 1 ) 
     268 
    245269      ! assign each new iceberg with a unique number constructed from the processor number 
    246270      ! and incremented by the total number of processors 
    … …  
    338362               localpt%xi = REAL( mig(ji), wp ) 
    339363               localpt%yj = REAL( mjg(jj), wp ) 
    340                localpt%lon = icb_utl_bilin(glamt, localpt%xi, localpt%yj, 'T' ) 
    341                localpt%lat = icb_utl_bilin(gphit, localpt%xi, localpt%yj, 'T' ) 
     364               CALL icb_utl_interp( localpt%xi, localpt%yj, plat=localpt%lat, plon=localpt%lon )    
    342365               localpt%mass      = rn_initial_mass     (iberg) 
    343366               localpt%thickness = rn_initial_thickness(iberg) 
    … …  
    350373               localpt%uvel = 0._wp 
    351374               localpt%vvel = 0._wp 
     375               localpt%kb   = 1 
    352376               CALL icb_utl_incr() 
    353377               localberg%number(:) = num_bergs(:) 
    … …  
    383407         &              rn_bits_erosion_fraction        , rn_sicn_shift       , ln_passive_mode      ,   & 
    384408         &              ln_time_average_weight          , nn_test_icebergs    , rn_test_box          ,   & 
    385          &              ln_use_calving , rn_speed_limit , cn_dir, sn_icb      ,                          & 
    386          &              cn_icbrst_indir, cn_icbrst_in   , cn_icbrst_outdir    , cn_icbrst_out 
     409         &              ln_use_calving , rn_speed_limit , cn_dir, sn_icb      , ln_M2016             ,   & 
     410         &              cn_icbrst_indir, cn_icbrst_in   , cn_icbrst_outdir    , cn_icbrst_out        ,   & 
     411         &              ln_icb_grd 
    387412      !!---------------------------------------------------------------------- 
    388413 
    … …  
    463488            &                    'bits_erosion_fraction = ', rn_bits_erosion_fraction 
    464489 
     490         WRITE(numout,*) '   Use icb module modification from Merino et al. (2016) : ln_M2016 = ', ln_M2016 
     491         WRITE(numout,*) '       ground icebergs if icb bottom lvl hit the oce bottom level : ln_icb_grd = ', ln_icb_grd 
     492 
    465493         WRITE(numout,*) '   Shift of sea-ice concentration in erosion flux modulation ',   & 
    466494            &                    '(0<sicn_shift<1)    rn_sicn_shift  = ', rn_sicn_shift 

  • NEMO/branches/2020/dev_r13787_OSMOSIS_IMMERSE/src/OCE/ICB/icbstp.F90

    r11536 r14043  
    5252CONTAINS 
    5353 
    54    SUBROUTINE icb_stp( kt ) 
     54   SUBROUTINE icb_stp( kt, Kmm ) 
    5555      !!---------------------------------------------------------------------- 
    5656      !!                  ***  ROUTINE icb_stp  *** 
    … …  
    6161      !!---------------------------------------------------------------------- 
    6262      INTEGER, INTENT(in) ::   kt   ! time step index 
     63      INTEGER, INTENT(in) ::   Kmm  ! ocean time level index 
    6364      ! 
    6465      LOGICAL ::   ll_sample_traj, ll_budget, ll_verbose   ! local logical 
    … …  
    7071      ! 
    7172      nktberg = kt 
     73      ! 
     74      !CALL test_icb_utl_getkb 
     75      !CALL ctl_stop('end test icb') 
    7276      ! 
    7377      IF( nn_test_icebergs < 0 .OR. ln_use_calving ) THEN !* read calving data 
    … …  
    9296      ! 
    9397      !                                   !* copy nemo forcing arrays into iceberg versions with extra halo 
    94       CALL icb_utl_copy()                 ! only necessary for variables not on T points 
     98      CALL icb_utl_copy( Kmm )                 ! only necessary for variables not on T points 
    9599      ! 
    96100      ! 

  • NEMO/branches/2020/dev_r13787_OSMOSIS_IMMERSE/src/OCE/ICB/icbthm.F90

    r13281 r14043  
    4949      INTEGER, INTENT(in) ::   kt   ! timestep number, just passed to icb_utl_print_berg 
    5050      ! 
    51       INTEGER  ::   ii, ij 
    52       REAL(wp) ::   zM, zT, zW, zL, zSST, zVol, zLn, zWn, zTn, znVol, zIC, zDn 
     51      INTEGER  ::   ii, ij, jk, ikb 
     52      REAL(wp) ::   zM, zT, zW, zL, zSST, zVol, zLn, zWn, zTn, znVol, zIC, zDn, zD, zvb, zub, ztb 
     53      REAL(wp) ::   zMv, zMe, zMb, zmelt, zdvo, zdvob, zdva, zdM, zSs, zdMe, zdMb, zdMv 
    5354      REAL(wp) ::   zSSS, zfzpt 
    54       REAL(wp) ::   zMv, zMe, zMb, zmelt, zdvo, zdva, zdM, zSs, zdMe, zdMb, zdMv 
    5555      REAL(wp) ::   zMnew, zMnew1, zMnew2, zheat_hcflux, zheat_latent, z1_12 
    5656      REAL(wp) ::   zMbits, znMbits, zdMbitsE, zdMbitsM, zLbits, zAbits, zMbb 
    57       REAL(wp) ::   zxi, zyj, zff, z1_rday, z1_e1e2, zdt, z1_dt, z1_dt_e1e2 
     57      REAL(wp) ::   zxi, zyj, zff, z1_rday, z1_e1e2, zdt, z1_dt, z1_dt_e1e2, zdepw 
     58      REAL(wp), DIMENSION(jpk) :: ztoce, zuoce, zvoce, ze3t, zzMv 
    5859      TYPE(iceberg), POINTER ::   this, next 
    5960      TYPE(point)  , POINTER ::   pt 
    … …  
    8586         pt => this%current_point 
    8687         nknberg = this%number(1) 
    87          CALL icb_utl_interp( pt%xi, pt%e1, pt%uo, pt%ui, pt%ua, pt%ssh_x,   & 
    88             &                 pt%yj, pt%e2, pt%vo, pt%vi, pt%va, pt%ssh_y,   & 
    89             &                 pt%sst, pt%cn, pt%hi, zff, pt%sss ) 
     88 
     89         CALL icb_utl_interp( pt%xi, pt%yj,            &   ! position 
     90             &                 pssu=pt%ssu, pua=pt%ua, &   ! oce/atm velocities 
     91             &                 pssv=pt%ssv, pva=pt%va, &   ! oce/atm velocities 
     92             &                 psst=pt%sst, pcn=pt%cn, & 
     93             &                 psss=pt%sss             ) 
     94 
     95         IF ( nn_sample_rate > 0 .AND. MOD(kt-1,nn_sample_rate) == 0 ) THEN 
     96            CALL icb_utl_interp( pt%xi, pt%yj, pe1=pt%e1, pe2=pt%e2,                 & 
     97               &                 pui=pt%ui, pssh_i=pt%ssh_x, & 
     98               &                 pvi=pt%vi, pssh_j=pt%ssh_y, & 
     99               &                 phi=pt%hi,                  & 
     100               &                 plat=pt%lat, plon=pt%lon ) 
     101         END IF 
    90102         ! 
    91103         zSST = pt%sst 
    … …  
    95107         zM   = pt%mass 
    96108         zT   = pt%thickness                               ! total thickness 
    97        ! D   = (rn_rho_bergs/pp_rho_seawater)*zT ! draught (keel depth) 
    98        ! F   = zT - D ! freeboard 
     109         zD   = rho_berg_1_oce * zT                        ! draught (keel depth) 
    99110         zW   = pt%width 
    100111         zL   = pt%length 
    … …  
    108119 
    109120         ! Environment 
    110          zdvo = SQRT( (pt%uvel-pt%uo)**2 + (pt%vvel-pt%vo)**2 ) 
    111          zdva = SQRT( (pt%ua  -pt%uo)**2 + (pt%va  -pt%vo)**2 ) 
    112          zSs  = 1.5_wp * SQRT( zdva ) + 0.1_wp * zdva                ! Sea state      (eqn M.A9) 
    113  
     121         ! default sst, ssu and ssv 
     122         ! ln_M2016: use temp, u and v profile 
     123         IF ( ln_M2016 ) THEN 
     124 
     125            ! load t, u, v and e3 profile at icb position 
     126            CALL icb_utl_interp( pt%xi, pt%yj, ptoce=ztoce, puoce=zuoce, pvoce=zvoce, pe3t=ze3t ) 
     127             
     128            !compute bottom level 
     129            CALL icb_utl_getkb( pt%kb, ze3t, zD ) 
     130 
     131            ikb = MIN(pt%kb,mbkt(ii,ij))                             ! limit pt%kb by mbkt  
     132                                                                     ! => bottom temperature used to fill ztoce(mbkt:jpk) 
     133            ztb = ztoce(ikb)                                         ! basal temperature 
     134            zub = zuoce(ikb) 
     135            zvb = zvoce(ikb) 
     136         ELSE 
     137            ztb = pt%sst 
     138            zub = pt%ssu 
     139            zvb = pt%ssv 
     140         END IF 
     141 
     142         zdvob = SQRT( (pt%uvel-zub)**2 + (pt%vvel-zvb)**2 )        ! relative basal velocity 
     143         zdva  = SQRT( (pt%ua  -pt%ssu)**2 + (pt%va  -pt%ssv)**2 )  ! relative wind 
     144         zSs   = 1.5_wp * SQRT( zdva ) + 0.1_wp * zdva              ! Sea state      (eqn M.A9) 
     145         ! 
    114146         ! Melt rates in m/s (i.e. division by rday) 
    115          zMv = MAX( 7.62d-3*zSST+1.29d-3*(zSST**2)                    , 0._wp ) * z1_rday      ! Buoyant convection at sides (eqn M.A10) 
     147         ! Buoyant convection at sides (eqn M.A10) 
     148         IF ( ln_M2016 ) THEN 
     149            ! averaging along all the iceberg draft 
     150            zzMv(:) = MAX( 7.62d-3*ztoce(:)+1.29d-3*(ztoce(:)**2), 0._wp ) * z1_rday 
     151            CALL icb_utl_zavg(zMv, zzMv, ze3t, zD, ikb ) 
     152         ELSE 
     153            zMv = MAX( 7.62d-3*zSST+1.29d-3*(zSST**2), 0._wp ) * z1_rday 
     154         END IF 
     155         ! 
     156         ! Basal turbulent melting     (eqn M.A7 ) 
    116157         IF ( zSST > zfzpt ) THEN                                                              ! Calculate basal melting only if SST above freezing point   
    117             zMb = MAX( 0.58_wp*(zdvo**0.8_wp)*(zSST+4.0_wp)/(zL**0.2_wp) , 0._wp ) * z1_rday   ! Basal turbulent melting     (eqn M.A7 ) 
     158            zMb = MAX( 0.58_wp*(zdvob**0.8_wp)*(ztb+4.0_wp)/(zL**0.2_wp) , 0._wp ) * z1_rday 
    118159         ELSE 
    119160            zMb = 0._wp                                                                        ! No basal melting if SST below freezing point      
    120161         ENDIF 
    121          zMe = MAX( z1_12*(zSST+2.)*zSs*(1._wp+COS(rpi*(zIC**3)))     , 0._wp ) * z1_rday      ! Wave erosion                (eqn M.A8 ) 
     162         ! 
     163         ! Wave erosion                (eqn M.A8 ) 
     164         zMe = MAX( z1_12*(zSST+2.)*zSs*(1._wp+COS(rpi*(zIC**3)))     , 0._wp ) * z1_rday 
    122165 
    123166         IF( ln_operator_splitting ) THEN      ! Operator split update of volume/mass 
    … …  
    207250 
    208251         ! Rolling 
    209          zDn = ( rn_rho_bergs / pp_rho_seawater ) * zTn       ! draught (keel depth) 
     252         zDn = rho_berg_1_oce * zTn       ! draught (keel depth) 
    210253         IF( zDn > 0._wp .AND. MAX(zWn,zLn) < SQRT( 0.92*(zDn**2) + 58.32*zDn ) ) THEN 
    211254            zT  = zTn 
    … …  
    224267 
    225268!!gm  add a test to avoid over melting ? 
     269!!pm  I agree, over melting could break conservation (more melt than calving) 
    226270 
    227271         IF( zMnew <= 0._wp ) THEN       ! Delete the berg if completely melted 

  • NEMO/branches/2020/dev_r13787_OSMOSIS_IMMERSE/src/OCE/ICB/icbtrj.F90

    r13558 r14043  
    4040   INTEGER ::   numberid, nstepid, nscaling_id 
    4141   INTEGER ::   nlonid, nlatid, nxid, nyid, nuvelid, nvvelid, nmassid 
    42    INTEGER ::   nuoid, nvoid, nuaid, nvaid, nuiid, nviid 
     42   INTEGER ::   nssuid, nssvid, nuaid, nvaid, nuiid, nviid 
    4343   INTEGER ::   nsshxid, nsshyid, nsstid, ncntid, nthkid 
    4444   INTEGER ::   nthicknessid, nwidthid, nlengthid 
    … …  
    111111      iret = NF90_DEF_VAR( ntrajid, 'uvel'          , NF90_DOUBLE, n_dim          , nuvelid          ) 
    112112      iret = NF90_DEF_VAR( ntrajid, 'vvel'          , NF90_DOUBLE, n_dim          , nvvelid          ) 
    113       iret = NF90_DEF_VAR( ntrajid, 'uto'           , NF90_DOUBLE, n_dim          , nuoid            ) 
    114       iret = NF90_DEF_VAR( ntrajid, 'vto'           , NF90_DOUBLE, n_dim          , nvoid            ) 
     113      iret = NF90_DEF_VAR( ntrajid, 'ssu'           , NF90_DOUBLE, n_dim          , nssuid           ) 
     114      iret = NF90_DEF_VAR( ntrajid, 'ssv'           , NF90_DOUBLE, n_dim          , nssvid           ) 
    115115      iret = NF90_DEF_VAR( ntrajid, 'uta'           , NF90_DOUBLE, n_dim          , nuaid            ) 
    116116      iret = NF90_DEF_VAR( ntrajid, 'vta'           , NF90_DOUBLE, n_dim          , nvaid            ) 
    … …  
    148148      iret = NF90_PUT_ATT( ntrajid, nvvelid         , 'long_name', 'meridional velocity' ) 
    149149      iret = NF90_PUT_ATT( ntrajid, nvvelid         , 'units'    , 'm/s' ) 
    150       iret = NF90_PUT_ATT( ntrajid, nuoid           , 'long_name', 'ocean u component' ) 
    151       iret = NF90_PUT_ATT( ntrajid, nuoid           , 'units'    , 'm/s' ) 
    152       iret = NF90_PUT_ATT( ntrajid, nvoid           , 'long_name', 'ocean v component' ) 
    153       iret = NF90_PUT_ATT( ntrajid, nvoid           , 'units'    , 'm/s' ) 
     150      iret = NF90_PUT_ATT( ntrajid, nssuid          , 'long_name', 'ocean u component' ) 
     151      iret = NF90_PUT_ATT( ntrajid, nssuid          , 'units'    , 'm/s' ) 
     152      iret = NF90_PUT_ATT( ntrajid, nssvid          , 'long_name', 'ocean v component' ) 
     153      iret = NF90_PUT_ATT( ntrajid, nssvid          , 'units'    , 'm/s' ) 
    154154      iret = NF90_PUT_ATT( ntrajid, nuaid           , 'long_name', 'atmosphere u component' ) 
    155155      iret = NF90_PUT_ATT( ntrajid, nuaid           , 'units'    , 'm/s' ) 
    … …  
    231231         iret = NF90_PUT_VAR( ntrajid, nuvelid         , pt%uvel          , (/ jn /) ) 
    232232         iret = NF90_PUT_VAR( ntrajid, nvvelid         , pt%vvel          , (/ jn /) ) 
    233          iret = NF90_PUT_VAR( ntrajid, nuoid           , pt%uo            , (/ jn /) ) 
    234          iret = NF90_PUT_VAR( ntrajid, nvoid           , pt%vo            , (/ jn /) ) 
     233         iret = NF90_PUT_VAR( ntrajid, nssuid          , pt%ssu           , (/ jn /) ) 
     234         iret = NF90_PUT_VAR( ntrajid, nssvid          , pt%ssv           , (/ jn /) ) 
    235235         iret = NF90_PUT_VAR( ntrajid, nuaid           , pt%ua            , (/ jn /) ) 
    236236         iret = NF90_PUT_VAR( ntrajid, nvaid           , pt%va            , (/ jn /) ) 

  • NEMO/branches/2020/dev_r13787_OSMOSIS_IMMERSE/src/OCE/ICB/icbutl.F90

    r13281 r14043  
    88   !!            -    !                            Removal of mapping from another grid 
    99   !!            -    !  2011-04  (Alderson)       Split into separate modules 
     10   !!           4.2   !  2020-07  (P. Mathiot)     simplification of interpolation routine 
     11   !!                 !                            and add Nacho Merino work 
    1012   !!---------------------------------------------------------------------- 
    1113 
    1214   !!---------------------------------------------------------------------- 
    1315   !!   icb_utl_interp   : 
    14    !!   icb_utl_bilin    : 
    15    !!   icb_utl_bilin_e  : 
     16   !!   icb_utl_pos      : compute bottom left corner indice, weight and mask 
     17   !!   icb_utl_bilin_h  : interpolation field to icb position 
     18   !!   icb_utl_bilin_e  : interpolation of scale factor to icb position 
    1619   !!---------------------------------------------------------------------- 
    1720   USE par_oce                             ! ocean parameters 
     21   USE oce,    ONLY: ts, uu, vv 
    1822   USE dom_oce                             ! ocean domain 
    1923   USE in_out_manager                      ! IO parameters 
    … …  
    3135   PRIVATE 
    3236 
     37   INTERFACE icb_utl_bilin_h 
     38      MODULE PROCEDURE icb_utl_bilin_2d_h, icb_utl_bilin_3d_h 
     39   END INTERFACE 
     40 
    3341   PUBLIC   icb_utl_copy          ! routine called in icbstp module 
     42   PUBLIC   icb_utl_getkb         ! routine called in icbdyn and icbthm modules 
     43   PUBLIC   test_icb_utl_getkb    ! routine called in icbdyn and icbthm modules 
     44   PUBLIC   icb_utl_zavg          ! routine called in icbdyn and icbthm modules 
    3445   PUBLIC   icb_utl_interp        ! routine called in icbdyn, icbthm modules 
    35    PUBLIC   icb_utl_bilin         ! routine called in icbini, icbdyn modules 
    36    PUBLIC   icb_utl_bilin_x       ! routine called in icbdyn module 
     46   PUBLIC   icb_utl_bilin_h       ! routine called in icbdyn module 
    3747   PUBLIC   icb_utl_add           ! routine called in icbini.F90, icbclv, icblbc and icbrst modules 
    3848   PUBLIC   icb_utl_delete        ! routine called in icblbc, icbthm modules 
    … …  
    5464CONTAINS 
    5565 
    56    SUBROUTINE icb_utl_copy() 
     66   SUBROUTINE icb_utl_copy( Kmm ) 
    5767      !!---------------------------------------------------------------------- 
    5868      !!                  ***  ROUTINE icb_utl_copy  *** 
    … …  
    6272      !! ** Method  : - blah blah 
    6373      !!---------------------------------------------------------------------- 
     74      REAL(wp), DIMENSION(0:jpi+1,0:jpj+1) :: ztmp 
    6475#if defined key_si3 
    6576      REAL(wp), DIMENSION(jpi,jpj) :: zssh_lead_m    !    ocean surface (ssh_m) if ice is not embedded 
    6677      !                                              !    ocean surface in leads if ice is embedded    
    6778#endif 
     79      INTEGER :: jk   ! vertical loop index 
     80      INTEGER :: Kmm  ! ocean time levelindex 
     81      ! 
    6882      ! copy nemo forcing arrays into iceberg versions with extra halo 
    6983      ! only necessary for variables not on T points 
    7084      ! and ssh which is used to calculate gradients 
    71  
    72       uo_e(1:jpi,1:jpj) = ssu_m(:,:) * umask(:,:,1) 
    73       vo_e(1:jpi,1:jpj) = ssv_m(:,:) * vmask(:,:,1) 
     85      ! 
     86      ! surface forcing 
     87      ! 
     88      ssu_e(1:jpi,1:jpj) = ssu_m(:,:) * umask(:,:,1) 
     89      ssv_e(1:jpi,1:jpj) = ssv_m(:,:) * vmask(:,:,1) 
     90      sst_e(1:jpi,1:jpj) = sst_m(:,:) 
     91      sss_e(1:jpi,1:jpj) = sss_m(:,:) 
     92      fr_e (1:jpi,1:jpj) = fr_i (:,:) 
     93      ua_e (1:jpi,1:jpj) = utau (:,:) * umask(:,:,1) ! maybe mask useless because mask applied in sbcblk 
     94      va_e (1:jpi,1:jpj) = vtau (:,:) * vmask(:,:,1) ! maybe mask useless because mask applied in sbcblk 
    7495      ff_e(1:jpi,1:jpj) = ff_f (:,:)  
    75       tt_e(1:jpi,1:jpj) = sst_m(:,:) 
    76       ss_e(1:jpi,1:jpj) = sss_m(:,:) 
    77       fr_e(1:jpi,1:jpj) = fr_i (:,:) 
    78       ua_e(1:jpi,1:jpj) = utau (:,:) * umask(:,:,1) ! maybe mask useless because mask applied in sbcblk 
    79       va_e(1:jpi,1:jpj) = vtau (:,:) * vmask(:,:,1) ! maybe mask useless because mask applied in sbcblk 
    80       ! 
    81       CALL lbc_lnk_icb( 'icbutl', uo_e, 'U', -1._wp, 1, 1 ) 
    82       CALL lbc_lnk_icb( 'icbutl', vo_e, 'V', -1._wp, 1, 1 ) 
    83       CALL lbc_lnk_icb( 'icbutl', ff_e, 'F', +1._wp, 1, 1 ) 
    84       CALL lbc_lnk_icb( 'icbutl', ua_e, 'U', -1._wp, 1, 1 ) 
    85       CALL lbc_lnk_icb( 'icbutl', va_e, 'V', -1._wp, 1, 1 ) 
    86       CALL lbc_lnk_icb( 'icbutl', fr_e, 'T', +1._wp, 1, 1 ) 
    87       CALL lbc_lnk_icb( 'icbutl', tt_e, 'T', +1._wp, 1, 1 ) 
    88       CALL lbc_lnk_icb( 'icbutl', ss_e, 'T', +1._wp, 1, 1 ) 
     96      ! 
     97      CALL lbc_lnk_icb( 'icbutl', ssu_e, 'U', -1._wp, 1, 1 ) 
     98      CALL lbc_lnk_icb( 'icbutl', ssv_e, 'V', -1._wp, 1, 1 ) 
     99      CALL lbc_lnk_icb( 'icbutl', ua_e , 'U', -1._wp, 1, 1 ) 
     100      CALL lbc_lnk_icb( 'icbutl', va_e , 'V', -1._wp, 1, 1 ) 
    89101#if defined key_si3 
    90102      hi_e(1:jpi, 1:jpj) = hm_i (:,:)   
    … …  
    96108      ssh_e(1:jpi, 1:jpj) = zssh_lead_m(:,:) * tmask(:,:,1) 
    97109      ! 
    98       CALL lbc_lnk_icb( 'icbutl', hi_e , 'T', +1._wp, 1, 1 ) 
    99110      CALL lbc_lnk_icb( 'icbutl', ui_e , 'U', -1._wp, 1, 1 ) 
    100111      CALL lbc_lnk_icb( 'icbutl', vi_e , 'V', -1._wp, 1, 1 ) 
    101112#else 
    102       ssh_e(1:jpi, 1:jpj) = ssh_m(:,:) * tmask(:,:,1) 
     113      ssh_e(1:jpi, 1:jpj) = ssh_m(:,:) * tmask(:,:,1)          
    103114#endif 
    104       CALL lbc_lnk_icb( 'icbutl', ssh_e, 'T', +1._wp, 1, 1 ) 
     115      ! 
     116      ! (PM) could be improve with a 3d lbclnk gathering both variables 
     117      ! should be done once extra haloe generalised 
     118      IF ( ln_M2016 ) THEN 
     119         DO jk = 1,jpk 
     120            ! uoce 
     121            ztmp(1:jpi,1:jpj) = uu(:,:,jk,Kmm) 
     122            CALL lbc_lnk_icb( 'icbutl', ztmp, 'U', -1._wp, 1, 1 ) 
     123            uoce_e(:,:,jk) = ztmp(:,:) 
     124            ! 
     125            ! voce 
     126            ztmp(1:jpi,1:jpj) = vv(:,:,jk,Kmm) 
     127            CALL lbc_lnk_icb( 'icbutl', ztmp, 'V', -1._wp, 1, 1 ) 
     128            voce_e(:,:,jk) = ztmp(:,:) 
     129         END DO 
     130         toce_e(1:jpi,1:jpj,1:jpk) = ts(:,:,:,1,Kmm) 
     131         e3t_e (1:jpi,1:jpj,1:jpk) = e3t(:,:,:,Kmm) 
     132      END IF 
    105133      ! 
    106134   END SUBROUTINE icb_utl_copy 
    107135 
    108136 
    109    SUBROUTINE icb_utl_interp( pi, pe1, puo, pui, pua, pssh_i,   & 
    110       &                       pj, pe2, pvo, pvi, pva, pssh_j,   & 
    111       &                       psst, pcn, phi, pff, psss        ) 
     137   SUBROUTINE icb_utl_interp( pi, pj, pe1 , pssu, pui, pua, pssh_i,         & 
     138      &                               pe2 , pssv, pvi, pva, pssh_j,         & 
     139      &                               psst, psss, pcn, phi, pff   ,         & 
     140      &                               plon, plat, ptoce, puoce, pvoce, pe3t ) 
    112141      !!---------------------------------------------------------------------- 
    113142      !!                  ***  ROUTINE icb_utl_interp  *** 
    … …  
    127156      !!---------------------------------------------------------------------- 
    128157      REAL(wp), INTENT(in   ) ::   pi , pj                        ! position in (i,j) referential 
    129       REAL(wp), INTENT(  out) ::   pe1, pe2                       ! i- and j scale factors 
    130       REAL(wp), INTENT(  out) ::   puo, pvo, pui, pvi, pua, pva   ! ocean, ice and wind speeds 
    131       REAL(wp), INTENT(  out) ::   pssh_i, pssh_j                 ! ssh i- & j-gradients 
    132       REAL(wp), INTENT(  out) ::   psst, pcn, phi, pff, psss      ! SST, ice concentration, ice thickness, Coriolis, SSS 
    133       ! 
     158      REAL(wp), INTENT(  out), OPTIONAL ::   pe1, pe2                       ! i- and j scale factors 
     159      REAL(wp), INTENT(  out), OPTIONAL ::   pssu, pssv, pui, pvi, pua, pva ! ocean, ice and wind speeds 
     160      REAL(wp), INTENT(  out), OPTIONAL ::   pssh_i, pssh_j                 ! ssh i- & j-gradients 
     161      REAL(wp), INTENT(  out), OPTIONAL ::   psst, psss, pcn, phi, pff      ! SST, SSS, ice concentration, ice thickness, Coriolis 
     162      REAL(wp), INTENT(  out), OPTIONAL ::   plat, plon                     ! position 
     163      REAL(wp), DIMENSION(jpk), INTENT(  out), OPTIONAL ::   ptoce, puoce, pvoce, pe3t   ! 3D variables 
     164      ! 
     165      REAL(wp), DIMENSION(4) :: zwT  , zwU  , zwV  , zwF   ! interpolation weight 
     166      REAL(wp), DIMENSION(4) :: zmskF, zmskU, zmskV, zmskT ! mask 
     167      REAL(wp), DIMENSION(4) :: zwTp, zmskTp, zwTm, zmskTm 
     168      REAL(wp), DIMENSION(4,jpk) :: zw1d 
     169      INTEGER                :: iiT, iiU, iiV, iiF, ijT, ijU, ijV, ijF ! bottom left corner 
     170      INTEGER                :: iiTp, iiTm, ijTp, ijTm 
    134171      REAL(wp) ::   zcd, zmod       ! local scalars 
    135172      !!---------------------------------------------------------------------- 
    136  
    137       pe1 = icb_utl_bilin_e( e1t, e1u, e1v, e1f, pi, pj )      ! scale factors 
    138       pe2 = icb_utl_bilin_e( e2t, e2u, e2v, e2f, pi, pj ) 
    139       ! 
    140       puo  = icb_utl_bilin_h( uo_e, pi, pj, 'U', .false.  )    ! ocean velocities 
    141       pvo  = icb_utl_bilin_h( vo_e, pi, pj, 'V', .false.  ) 
    142       psst = icb_utl_bilin_h( tt_e, pi, pj, 'T', .true.   )    ! SST 
    143       psss = icb_utl_bilin_h( ss_e, pi, pj, 'T', .true.   )    ! SSS 
    144       pcn  = icb_utl_bilin_h( fr_e, pi, pj, 'T', .true.   )    ! ice concentration 
    145       pff  = icb_utl_bilin_h( ff_e, pi, pj, 'F', .false.  )    ! Coriolis parameter 
    146       ! 
    147       pua  = icb_utl_bilin_h( ua_e, pi, pj, 'U', .true.   )    ! 10m wind 
    148       pva  = icb_utl_bilin_h( va_e, pi, pj, 'V', .true.   )    ! here (ua,va) are stress => rough conversion from stress to speed 
    149       zcd  = 1.22_wp * 1.5e-3_wp                               ! air density * drag coefficient  
    150       zmod = 1._wp / MAX(  1.e-20, SQRT(  zcd * SQRT( pua*pua + pva*pva)  )  ) 
    151       pua  = pua * zmod                                       ! note: stress module=0 necessarly implies ua=va=0 
    152       pva  = pva * zmod 
    153  
     173      ! 
     174      ! get position, weight and mask  
     175      CALL icb_utl_pos( pi, pj, 'T', iiT, ijT, zwT, zmskT ) 
     176      CALL icb_utl_pos( pi, pj, 'U', iiU, ijU, zwU, zmskU ) 
     177      CALL icb_utl_pos( pi, pj, 'V', iiV, ijV, zwV, zmskV ) 
     178      CALL icb_utl_pos( pi, pj, 'F', iiF, ijF, zwF, zmskF ) 
     179      ! 
     180      ! metrics and coordinates 
     181      IF ( PRESENT(pe1 ) ) pe1 = icb_utl_bilin_e( e1t, e1u, e1v, e1f, pi, pj )      ! scale factors 
     182      IF ( PRESENT(pe2 ) ) pe2 = icb_utl_bilin_e( e2t, e2u, e2v, e2f, pi, pj ) 
     183      IF ( PRESENT(plon) ) plon= icb_utl_bilin_h( rlon_e, iiT, ijT, zwT, .true.  ) 
     184      IF ( PRESENT(plat) ) plat= icb_utl_bilin_h( rlat_e, iiT, ijT, zwT, .false. ) 
     185      ! 
     186      IF ( PRESENT(pssu) ) pssu = icb_utl_bilin_h( ssu_e, iiU, ijU, zwU        , .false. ) ! ocean velocities 
     187      IF ( PRESENT(pssv) ) pssv = icb_utl_bilin_h( ssv_e, iiV, ijV, zwV        , .false. ) ! 
     188      IF ( PRESENT(psst) ) psst = icb_utl_bilin_h( sst_e, iiT, ijT, zwT * zmskT, .false. ) ! sst 
     189      IF ( PRESENT(psss) ) psss = icb_utl_bilin_h( sss_e, iiT, ijT, zwT * zmskT, .false. ) ! sss 
     190      IF ( PRESENT(pcn ) ) pcn  = icb_utl_bilin_h( fr_e , iiT, ijT, zwT * zmskT, .false. ) ! ice concentration 
     191      IF ( PRESENT(pff ) ) pff  = icb_utl_bilin_h( ff_e , iiF, ijF, zwF        , .false. ) ! Coriolis parameter 
     192      ! 
     193      IF ( PRESENT(pua) .AND. PRESENT(pva) ) THEN 
     194         pua  = icb_utl_bilin_h( ua_e, iiU, ijU, zwU * zmskU, .false. ) ! 10m wind 
     195         pva  = icb_utl_bilin_h( va_e, iiV, ijV, zwV * zmskV, .false. ) ! here (ua,va) are stress => rough conversion from stress to speed 
     196         zcd  = 1.22_wp * 1.5e-3_wp                               ! air density * drag coefficient  
     197         zmod = 1._wp / MAX(  1.e-20, SQRT(  zcd * SQRT( pua*pua + pva*pva)  )  ) 
     198         pua  = pua * zmod                                       ! note: stress module=0 necessarly implies ua=va=0 
     199         pva  = pva * zmod 
     200      END IF 
     201      ! 
    154202#if defined key_si3 
    155       pui = icb_utl_bilin_h( ui_e , pi, pj, 'U', .false. )    ! sea-ice velocities 
    156       pvi = icb_utl_bilin_h( vi_e , pi, pj, 'V', .false. ) 
    157       phi = icb_utl_bilin_h( hi_e , pi, pj, 'T', .true.  )    ! ice thickness 
     203      IF ( PRESENT(pui) ) pui = icb_utl_bilin_h( ui_e , iiU, ijU, zwU        , .false. ) ! sea-ice velocities 
     204      IF ( PRESENT(pvi) ) pvi = icb_utl_bilin_h( vi_e , iiV, ijV, zwV        , .false. ) 
     205      IF ( PRESENT(phi) ) phi = icb_utl_bilin_h( hi_e , iiT, ijT, zwT * zmskT, .false. ) ! ice thickness 
    158206#else 
    159       pui = 0._wp 
    160       pvi = 0._wp 
    161       phi = 0._wp 
     207      IF ( PRESENT(pui) ) pui = 0._wp 
     208      IF ( PRESENT(pvi) ) pvi = 0._wp 
     209      IF ( PRESENT(phi) ) phi = 0._wp 
    162210#endif 
    163  
     211      ! 
    164212      ! Estimate SSH gradient in i- and j-direction (centred evaluation) 
    165       pssh_i = ( icb_utl_bilin_h( ssh_e, pi+0.1_wp, pj, 'T', .true. ) -   & 
    166          &       icb_utl_bilin_h( ssh_e, pi-0.1_wp, pj, 'T', .true. )  ) / ( 0.2_wp * pe1 ) 
    167       pssh_j = ( icb_utl_bilin_h( ssh_e, pi, pj+0.1_wp, 'T', .true. ) -   & 
    168          &       icb_utl_bilin_h( ssh_e, pi, pj-0.1_wp, 'T', .true. )  ) / ( 0.2_wp * pe2 ) 
     213      IF ( PRESENT(pssh_i) .AND. PRESENT(pssh_j) ) THEN 
     214         CALL icb_utl_pos( pi+0.1, pj    , 'T', iiTp, ijTp, zwTp, zmskTp ) 
     215         CALL icb_utl_pos( pi-0.1, pj    , 'T', iiTm, ijTm, zwTm, zmskTm ) 
     216         ! 
     217         IF ( .NOT. PRESENT(pe1) ) pe1 = icb_utl_bilin_e( e1t, e1u, e1v, e1f, pi, pj ) 
     218         pssh_i = ( icb_utl_bilin_h( ssh_e, iiTp, ijTp, zwTp*zmskTp, .false. ) -   & 
     219            &       icb_utl_bilin_h( ssh_e, iiTm, ijTm, zwTm*zmskTm, .false. )  ) / ( 0.2_wp * pe1 ) 
     220         ! 
     221         CALL icb_utl_pos( pi    , pj+0.1, 'T', iiTp, ijTp, zwTp, zmskTp ) 
     222         CALL icb_utl_pos( pi    , pj-0.1, 'T', iiTm, ijTm, zwTm, zmskTm ) 
     223         ! 
     224         IF ( .NOT. PRESENT(pe2) ) pe2 = icb_utl_bilin_e( e2t, e2u, e2v, e2f, pi, pj ) 
     225         pssh_j = ( icb_utl_bilin_h( ssh_e, iiTp, ijTp, zwTp*zmskTp, .false. ) -   & 
     226            &       icb_utl_bilin_h( ssh_e, iiTm, ijTm, zwTm*zmskTm, .false. )  ) / ( 0.2_wp * pe2 ) 
     227      END IF 
     228      ! 
     229      ! 3d interpolation 
     230      IF ( PRESENT(puoce) .AND. PRESENT(pvoce) ) THEN 
     231         ! no need to mask as 0 is a valid data for land 
     232         zw1d(1,:) = zwU(1) ; zw1d(2,:) = zwU(2) ; zw1d(3,:) = zwU(3) ; zw1d(4,:) = zwU(4) ; 
     233         puoce(:) = icb_utl_bilin_h( uoce_e , iiU, ijU, zw1d ) 
     234 
     235         zw1d(1,:) = zwV(1) ; zw1d(2,:) = zwV(2) ; zw1d(3,:) = zwV(3) ; zw1d(4,:) = zwV(4) ; 
     236         pvoce(:) = icb_utl_bilin_h( voce_e , iiV, ijV, zw1d ) 
     237      END IF 
     238 
     239      IF ( PRESENT(ptoce) ) THEN 
     240         ! for temperature we need to mask the weight properly 
     241         ! no need of extra halo as it is a T point variable 
     242         zw1d(1,:) = tmask(iiT  ,ijT  ,:) * zwT(1) * zmskT(1) 
     243         zw1d(2,:) = tmask(iiT+1,ijT  ,:) * zwT(2) * zmskT(2) 
     244         zw1d(3,:) = tmask(iiT  ,ijT+1,:) * zwT(3) * zmskT(3) 
     245         zw1d(4,:) = tmask(iiT+1,ijT+1,:) * zwT(4) * zmskT(4) 
     246         ptoce(:) = icb_utl_bilin_h( toce_e , iiT, ijT, zw1d ) 
     247      END IF 
     248      ! 
     249      IF ( PRESENT(pe3t)  ) pe3t(:)  = e3t_e(iiT,ijT,:)    ! as in Nacho tarball need to be fix once we are able to reproduce Nacho results 
    169250      ! 
    170251   END SUBROUTINE icb_utl_interp 
    171252 
    172  
    173    REAL(wp) FUNCTION icb_utl_bilin_h( pfld, pi, pj, cd_type, plmask ) 
     253   SUBROUTINE icb_utl_pos( pi, pj, cd_type, kii, kij, pw, pmsk ) 
    174254      !!---------------------------------------------------------------------- 
    175255      !!                  ***  FUNCTION icb_utl_bilin  *** 
    … …  
    182262      !! 
    183263      !!---------------------------------------------------------------------- 
    184       REAL(wp), DIMENSION(0:jpi+1,0:jpj+1), INTENT(in) ::   pfld      ! field to be interpolated 
    185       REAL(wp)                            , INTENT(in) ::   pi, pj    ! targeted coordinates in (i,j) referential 
    186       CHARACTER(len=1)                    , INTENT(in) ::   cd_type   ! type of pfld array grid-points: = T , U , V or F points 
    187       LOGICAL                             , INTENT(in) ::   plmask    ! special treatment of mask point 
    188       ! 
    189       INTEGER  ::   ii, ij   ! local integer 
    190       REAL(wp) ::   zi, zj   ! local real 
    191       REAL(wp) :: zw1, zw2, zw3, zw4 
    192       REAL(wp), DIMENSION(4) :: zmask 
     264      REAL(wp)              , INTENT(IN)  ::   pi, pj    ! targeted coordinates in (i,j) referential 
     265      CHARACTER(len=1)      , INTENT(IN)  ::   cd_type   ! point type 
     266      REAL(wp), DIMENSION(4), INTENT(OUT) ::   pw, pmsk  ! weight and mask 
     267      INTEGER ,               INTENT(OUT) ::   kii, kij  ! bottom left corner position in local domain 
     268      ! 
     269      REAL(wp) :: zwi, zwj ! distance to bottom left corner 
     270      INTEGER  :: ierr  
     271      ! 
    193272      !!---------------------------------------------------------------------- 
    194273      ! 
    … …  
    198277         ! since we're looking for four T points containing quadrant we're in of  
    199278         ! current T cell 
    200          ii = MAX(0, INT( pi     )) 
    201          ij = MAX(0, INT( pj     ))    ! T-point 
    202          zi = pi - REAL(ii,wp) 
    203          zj = pj - REAL(ij,wp) 
     279         kii = MAX(0, INT( pi        )) 
     280         kij = MAX(0, INT( pj        ))    ! T-point 
     281         zwi = pi - REAL(kii,wp) 
     282         zwj = pj - REAL(kij,wp) 
    204283      CASE ( 'U' ) 
    205          ii = MAX(0, INT( pi-0.5_wp )) 
    206          ij = MAX(0, INT( pj     ))    ! U-point 
    207          zi = pi - 0.5_wp - REAL(ii,wp) 
    208          zj = pj - REAL(ij,wp) 
     284         kii = MAX(0, INT( pi-0.5_wp )) 
     285         kij = MAX(0, INT( pj        ))    ! U-point 
     286         zwi = pi - 0.5_wp - REAL(kii,wp) 
     287         zwj = pj - REAL(kij,wp) 
    209288      CASE ( 'V' ) 
    210          ii = MAX(0, INT( pi     )) 
    211          ij = MAX(0, INT( pj-0.5_wp ))    ! V-point 
    212          zi = pi - REAL(ii,wp) 
    213          zj = pj - 0.5_wp - REAL(ij,wp) 
     289         kii = MAX(0, INT( pi        )) 
     290         kij = MAX(0, INT( pj-0.5_wp ))    ! V-point 
     291         zwi = pi - REAL(kii,wp) 
     292         zwj = pj - 0.5_wp - REAL(kij,wp) 
    214293      CASE ( 'F' ) 
    215          ii = MAX(0, INT( pi-0.5_wp )) 
    216          ij = MAX(0, INT( pj-0.5_wp ))    ! F-point 
    217          zi = pi - 0.5_wp - REAL(ii,wp) 
    218          zj = pj - 0.5_wp - REAL(ij,wp) 
     294         kii = MAX(0, INT( pi-0.5_wp )) 
     295         kij = MAX(0, INT( pj-0.5_wp ))    ! F-point 
     296         zwi = pi - 0.5_wp - REAL(kii,wp) 
     297         zwj = pj - 0.5_wp - REAL(kij,wp) 
    219298      END SELECT 
     299      ! 
     300      ! compute weight 
     301      pw(1) = (1._wp-zwi) * (1._wp-zwj) 
     302      pw(2) =        zwi  * (1._wp-zwj) 
     303      pw(3) = (1._wp-zwi) *        zwj 
     304      pw(4) =        zwi  *        zwj 
     305      ! 
     306      ! find position in this processor. Prevent near edge problems (see #1389) 
     307      ! 
     308      IF (TRIM(cd_type) == 'T' ) THEN 
     309         ierr = 0 
     310         IF    ( kii <  mig( 1 ) ) THEN   ;  ierr = ierr + 1 
     311         ELSEIF( kii >= mig(jpi) ) THEN   ;  ierr = ierr + 1 
     312         ENDIF 
     313         ! 
     314         IF    ( kij <  mjg( 1 ) ) THEN   ;   ierr = ierr + 1 
     315         ELSEIF( kij >= mjg(jpj) ) THEN   ;   ierr = ierr + 1 
     316         ENDIF 
     317         ! 
     318         IF ( ierr > 0 ) THEN 
     319            WRITE(numout,*) 'bottom left corner T point out of bound' 
     320            WRITE(numout,*) pi, kii, mig( 1 ), mig(jpi) 
     321            WRITE(numout,*) pj, kij, mjg( 1 ), mjg(jpj) 
     322            WRITE(numout,*) pmsk 
     323            CALL ctl_stop('STOP','icb_utl_bilin_h: an icebergs coordinates is out of valid range (out of bound error)') 
     324         END IF 
     325      END IF 
    220326      ! 
    221327      ! find position in this processor. Prevent near edge problems (see #1389) 
    222328      ! (PM) will be useless if extra halo is used in NEMO 
    223329      ! 
    224       IF    ( ii <= mig(1)-1 ) THEN   ;   ii = 0 
    225       ELSEIF( ii  > mig(jpi) ) THEN   ;   ii = jpi 
    226       ELSE                            ;   ii = mi1(ii) 
     330      IF    ( kii <= mig(1)-1 ) THEN   ;   kii = 0 
     331      ELSEIF( kii  > mig(jpi) ) THEN   ;   kii = jpi 
     332      ELSE                             ;   kii = mi1(kii) 
    227333      ENDIF 
    228       IF    ( ij <= mjg(1)-1 ) THEN   ;   ij = 0 
    229       ELSEIF( ij  > mjg(jpj) ) THEN   ;   ij = jpj 
    230       ELSE                            ;   ij = mj1(ij) 
     334      IF    ( kij <= mjg(1)-1 ) THEN   ;   kij = 0 
     335      ELSEIF( kij  > mjg(jpj) ) THEN   ;   kij = jpj 
     336      ELSE                             ;   kij = mj1(kij) 
    231337      ENDIF 
    232338      ! 
    233339      ! define mask array  
    234       IF (plmask) THEN 
    235          ! land value is not used in the interpolation 
    236          SELECT CASE ( cd_type ) 
    237          CASE ( 'T' ) 
    238             zmask = (/tmask_e(ii,ij), tmask_e(ii+1,ij), tmask_e(ii,ij+1), tmask_e(ii+1,ij+1)/) 
    239          CASE ( 'U' ) 
    240             zmask = (/umask_e(ii,ij), umask_e(ii+1,ij), umask_e(ii,ij+1), umask_e(ii+1,ij+1)/) 
    241          CASE ( 'V' ) 
    242             zmask = (/vmask_e(ii,ij), vmask_e(ii+1,ij), vmask_e(ii,ij+1), vmask_e(ii+1,ij+1)/) 
    243          CASE ( 'F' ) 
    244             ! F case only used for coriolis, ff_f is not mask so zmask = 1 
    245             zmask = 1. 
    246          END SELECT 
    247       ELSE 
    248          ! land value is used during interpolation 
    249          zmask = 1. 
    250       END iF 
    251       ! 
    252       ! compute weight 
    253       zw1 = zmask(1) * (1._wp-zi) * (1._wp-zj) 
    254       zw2 = zmask(2) *        zi  * (1._wp-zj) 
    255       zw3 = zmask(3) * (1._wp-zi) *        zj 
    256       zw4 = zmask(4) *        zi  *        zj 
    257       ! 
    258       ! compute interpolated value 
    259       icb_utl_bilin_h = ( pfld(ii,ij)*zw1 + pfld(ii+1,ij)*zw2 + pfld(ii,ij+1)*zw3 + pfld(ii+1,ij+1)*zw4 ) / MAX(1.e-20, zw1+zw2+zw3+zw4)  
    260       ! 
    261    END FUNCTION icb_utl_bilin_h 
    262  
    263  
    264    REAL(wp) FUNCTION icb_utl_bilin( pfld, pi, pj, cd_type ) 
     340      ! land value is not used in the interpolation 
     341      SELECT CASE ( cd_type ) 
     342      CASE ( 'T' ) 
     343         pmsk = (/tmask_e(kii,kij), tmask_e(kii+1,kij), tmask_e(kii,kij+1), tmask_e(kii+1,kij+1)/) 
     344      CASE ( 'U' ) 
     345         pmsk = (/umask_e(kii,kij), umask_e(kii+1,kij), umask_e(kii,kij+1), umask_e(kii+1,kij+1)/) 
     346      CASE ( 'V' ) 
     347         pmsk = (/vmask_e(kii,kij), vmask_e(kii+1,kij), vmask_e(kii,kij+1), vmask_e(kii+1,kij+1)/) 
     348      CASE ( 'F' ) 
     349         ! F case only used for coriolis, ff_f is not mask so zmask = 1 
     350         pmsk = 1. 
     351      END SELECT 
     352   END SUBROUTINE icb_utl_pos 
     353 
     354   REAL(wp) FUNCTION icb_utl_bilin_2d_h( pfld, pii, pij, pw, pllon ) 
    265355      !!---------------------------------------------------------------------- 
    266356      !!                  ***  FUNCTION icb_utl_bilin  *** 
    267357      !! 
    268358      !! ** Purpose :   bilinear interpolation at berg location depending on the grid-point type 
     359      !!                this version deals with extra halo points 
    269360      !! 
    270361      !!       !!gm  CAUTION an optional argument should be added to handle 
    … …  
    272363      !! 
    273364      !!---------------------------------------------------------------------- 
    274       REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pfld      ! field to be interpolated 
    275       REAL(wp)                    , INTENT(in) ::   pi, pj    ! targeted coordinates in (i,j) referential 
    276       CHARACTER(len=1)            , INTENT(in) ::   cd_type   ! type of pfld array grid-points: = T , U , V or F points 
    277       ! 
    278       INTEGER  ::   ii, ij   ! local integer 
    279       REAL(wp) ::   zi, zj   ! local real 
    280       !!---------------------------------------------------------------------- 
    281       ! 
    282       SELECT CASE ( cd_type ) 
    283          CASE ( 'T' ) 
    284             ! note that here there is no +0.5 added 
    285             ! since we're looking for four T points containing quadrant we're in of  
    286             ! current T cell 
    287             ii = MAX(1, INT( pi     )) 
    288             ij = MAX(1, INT( pj     ))    ! T-point 
    289             zi = pi - REAL(ii,wp) 
    290             zj = pj - REAL(ij,wp) 
    291          CASE ( 'U' ) 
    292             ii = MAX(1, INT( pi-0.5 )) 
    293             ij = MAX(1, INT( pj     ))    ! U-point 
    294             zi = pi - 0.5 - REAL(ii,wp) 
    295             zj = pj - REAL(ij,wp) 
    296          CASE ( 'V' ) 
    297             ii = MAX(1, INT( pi     )) 
    298             ij = MAX(1, INT( pj-0.5 ))    ! V-point 
    299             zi = pi - REAL(ii,wp) 
    300             zj = pj - 0.5 - REAL(ij,wp) 
    301          CASE ( 'F' ) 
    302             ii = MAX(1, INT( pi-0.5 )) 
    303             ij = MAX(1, INT( pj-0.5 ))    ! F-point 
    304             zi = pi - 0.5 - REAL(ii,wp) 
    305             zj = pj - 0.5 - REAL(ij,wp) 
    306       END SELECT 
    307       ! 
    308       ! find position in this processor. Prevent near edge problems (see #1389) 
    309       IF    ( ii < mig( 1 ) ) THEN   ;   ii = 1 
    310       ELSEIF( ii > mig(jpi) ) THEN   ;   ii = jpi 
    311       ELSE                           ;   ii = mi1(ii) 
     365      REAL(wp), DIMENSION(0:jpi+1,0:jpj+1), INTENT(in) ::   pfld      ! field to be interpolated 
     366      REAL(wp), DIMENSION(4)              , INTENT(in) ::   pw        ! weight 
     367      LOGICAL                             , INTENT(in) ::   pllon     ! input data is a longitude 
     368      INTEGER ,                             INTENT(in) ::   pii, pij  ! bottom left corner 
     369      ! 
     370      REAL(wp), DIMENSION(4) :: zdat ! input data 
     371      !!---------------------------------------------------------------------- 
     372      ! 
     373      ! data 
     374      zdat(1) = pfld(pii  ,pij  ) 
     375      zdat(2) = pfld(pii+1,pij  ) 
     376      zdat(3) = pfld(pii  ,pij+1) 
     377      zdat(4) = pfld(pii+1,pij+1) 
     378      ! 
     379      IF( pllon .AND. MAXVAL(zdat) - MINVAL(zdat) > 90._wp ) THEN 
     380         WHERE( zdat < 0._wp ) zdat = zdat + 360._wp 
    312381      ENDIF 
    313       IF    ( ij < mjg( 1 ) ) THEN   ;   ij = 1 
    314       ELSEIF( ij > mjg(jpj) ) THEN   ;   ij = jpj 
    315       ELSE                           ;   ij  = mj1(ij) 
    316       ENDIF 
    317       ! 
    318       IF( ii == jpi )   ii = ii-1       
    319       IF( ij == jpj )   ij = ij-1 
    320       ! 
    321       icb_utl_bilin = ( pfld(ii,ij  ) * (1.-zi) + pfld(ii+1,ij  ) * zi ) * (1.-zj)   & 
    322          &          + ( pfld(ii,ij+1) * (1.-zi) + pfld(ii+1,ij+1) * zi ) *     zj 
    323       ! 
    324    END FUNCTION icb_utl_bilin 
    325  
    326  
    327    REAL(wp) FUNCTION icb_utl_bilin_x( pfld, pi, pj ) 
    328       !!---------------------------------------------------------------------- 
    329       !!                  ***  FUNCTION icb_utl_bilin_x  *** 
     382      ! 
     383      ! compute interpolated value 
     384      icb_utl_bilin_2d_h = ( zdat(1)*pw(1) + zdat(2)*pw(2) + zdat(3)*pw(3) + zdat(4)*pw(4) ) / MAX(1.e-20, pw(1)+pw(2)+pw(3)+pw(4))  
     385      ! 
     386      IF( pllon .AND. icb_utl_bilin_2d_h > 180._wp ) icb_utl_bilin_2d_h = icb_utl_bilin_2d_h - 360._wp 
     387      ! 
     388   END FUNCTION icb_utl_bilin_2d_h 
     389 
     390   FUNCTION icb_utl_bilin_3d_h( pfld, pii, pij, pw ) 
     391      !!---------------------------------------------------------------------- 
     392      !!                  ***  FUNCTION icb_utl_bilin  *** 
    330393      !! 
    331394      !! ** Purpose :   bilinear interpolation at berg location depending on the grid-point type 
    332       !!                Special case for interpolating longitude 
     395      !!                this version deals with extra halo points 
    333396      !! 
    334397      !!       !!gm  CAUTION an optional argument should be added to handle 
    … …  
    336399      !! 
    337400      !!---------------------------------------------------------------------- 
    338       REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pfld      ! field to be interpolated 
    339       REAL(wp)                    , INTENT(in) ::   pi, pj    ! targeted coordinates in (i,j) referential 
    340       ! 
    341       INTEGER                                  ::   ii, ij   ! local integer 
    342       REAL(wp)                                 ::   zi, zj   ! local real 
    343       REAL(wp)                                 ::   zret     ! local real 
    344       REAL(wp), DIMENSION(4)                   ::   z4 
    345       !!---------------------------------------------------------------------- 
    346       ! 
    347       ! note that here there is no +0.5 added 
    348       ! since we're looking for four T points containing quadrant we're in of  
    349       ! current T cell 
    350       ii = MAX(1, INT( pi     )) 
    351       ij = MAX(1, INT( pj     ))    ! T-point 
    352       zi = pi - REAL(ii,wp) 
    353       zj = pj - REAL(ij,wp) 
    354       ! 
    355       ! find position in this processor. Prevent near edge problems (see #1389) 
    356       IF    ( ii < mig( 1 ) ) THEN   ;   ii = 1 
    357       ELSEIF( ii > mig(jpi) ) THEN   ;   ii = jpi 
    358       ELSE                           ;   ii = mi1(ii) 
    359       ENDIF 
    360       IF    ( ij < mjg( 1 ) ) THEN   ;   ij = 1 
    361       ELSEIF( ij > mjg(jpj) ) THEN   ;   ij = jpj 
    362       ELSE                           ;   ij  = mj1(ij) 
    363       ENDIF 
    364       ! 
    365       IF( ii == jpi )   ii = ii-1       
    366       IF( ij == jpj )   ij = ij-1 
    367       ! 
    368       z4(1) = pfld(ii  ,ij  ) 
    369       z4(2) = pfld(ii+1,ij  ) 
    370       z4(3) = pfld(ii  ,ij+1) 
    371       z4(4) = pfld(ii+1,ij+1) 
    372       IF( MAXVAL(z4) - MINVAL(z4) > 90._wp ) THEN 
    373          WHERE( z4 < 0._wp ) z4 = z4 + 360._wp 
    374       ENDIF 
    375       ! 
    376       zret = (z4(1) * (1.-zi) + z4(2) * zi) * (1.-zj) + (z4(3) * (1.-zi) + z4(4) * zi) * zj 
    377       IF( zret > 180._wp ) zret = zret - 360._wp 
    378       icb_utl_bilin_x = zret 
    379       ! 
    380    END FUNCTION icb_utl_bilin_x 
    381  
     401      REAL(wp), DIMENSION(0:jpi+1,0:jpj+1, jpk), INTENT(in) ::   pfld      ! field to be interpolated 
     402      REAL(wp), DIMENSION(4,jpk)               , INTENT(in) ::   pw        ! weight 
     403      INTEGER ,                                  INTENT(in) ::   pii, pij  ! bottom left corner 
     404      REAL(wp), DIMENSION(jpk) :: icb_utl_bilin_3d_h 
     405      ! 
     406      REAL(wp), DIMENSION(4,jpk) :: zdat ! input data 
     407      INTEGER :: jk 
     408      !!---------------------------------------------------------------------- 
     409      ! 
     410      ! data 
     411      zdat(1,:) = pfld(pii  ,pij  ,:) 
     412      zdat(2,:) = pfld(pii+1,pij  ,:) 
     413      zdat(3,:) = pfld(pii  ,pij+1,:) 
     414      zdat(4,:) = pfld(pii+1,pij+1,:) 
     415      ! 
     416      ! compute interpolated value 
     417      DO jk=1,jpk 
     418         icb_utl_bilin_3d_h(jk) =   ( zdat(1,jk)*pw(1,jk) + zdat(2,jk)*pw(2,jk) + zdat(3,jk)*pw(3,jk) + zdat(4,jk)*pw(4,jk) ) & 
     419            &                     /   MAX(1.e-20, pw(1,jk)+pw(2,jk)+pw(3,jk)+pw(4,jk))  
     420      END DO 
     421      ! 
     422   END FUNCTION icb_utl_bilin_3d_h 
    382423 
    383424   REAL(wp) FUNCTION icb_utl_bilin_e( pet, peu, pev, pef, pi, pj ) 
    … …  
    390431      !!---------------------------------------------------------------------- 
    391432      REAL(wp), DIMENSION(:,:), INTENT(in) ::   pet, peu, pev, pef   ! horizontal scale factor to be interpolated at t-,u-,v- & f-pts 
    392       REAL(wp)                , INTENT(in) ::   pi, pj               ! targeted coordinates in (i,j) referential 
    393       ! 
    394       INTEGER  ::   ii, ij, icase, ierr   ! local integer 
     433      REAL(wp)                , INTENT(IN) ::   pi , pj              ! iceberg position 
    395434      ! 
    396435      ! weights corresponding to corner points of a T cell quadrant 
    397436      REAL(wp) ::   zi, zj          ! local real 
     437      INTEGER  ::   ii, ij          ! bottom left corner coordinate in local domain 
    398438      ! 
    399439      ! values at corner points of a T cell quadrant 
    … …  
    402442      !!---------------------------------------------------------------------- 
    403443      ! 
     444      ! cannot used iiT because need ii/ij reltaive to global indices not local one 
    404445      ii = MAX(1, INT( pi ))   ;   ij = MAX(1, INT( pj ))            ! left bottom T-point (i,j) indices 
    405  
     446      !  
    406447      ! fractional box spacing 
    407448      ! 0   <= zi < 0.5, 0   <= zj < 0.5   -->  NW quadrant of current T cell 
    … …  
    413454      zj = pj - REAL(ij,wp) 
    414455 
    415       ! find position in this processor. Prevent near edge problems (see #1389) 
    416       ! 
    417       ierr = 0 
    418       IF    ( ii < mig( 1 ) ) THEN   ;   ii = 1       ; ierr = ierr + 1 
    419       ELSEIF( ii > mig(jpi) ) THEN   ;   ii = jpi     ; ierr = ierr + 1 
    420       ELSE                           ;   ii = mi1(ii) 
    421       ENDIF 
    422       IF    ( ij < mjg( 1 ) ) THEN   ;   ij = 1       ; ierr = ierr + 1 
    423       ELSEIF( ij > mjg(jpj) ) THEN   ;   ij = jpj     ; ierr = ierr + 1 
    424       ELSE                           ;   ij  = mj1(ij) 
    425       ENDIF 
    426       ! 
    427       IF( ii == jpi ) THEN ; ii = ii-1 ; ierr = ierr + 1 ; END IF      
    428       IF( ij == jpj ) THEN ; ij = ij-1 ; ierr = ierr + 1 ; END IF 
    429       ! 
    430       IF ( ierr > 0 ) CALL ctl_stop('STOP','icb_utl_bilin_e: an icebergs coordinates is out of valid range (out of bound error)') 
     456      ! conversion to local domain (no need to do a sanity check already done in icbpos) 
     457      ii = mi1(ii) 
     458      ij = mj1(ij) 
    431459      ! 
    432460      IF(    0.0_wp <= zi .AND. zi < 0.5_wp   ) THEN 
    … …  
    465493   END FUNCTION icb_utl_bilin_e 
    466494 
     495   SUBROUTINE icb_utl_getkb( kb, pe3, pD ) 
     496      !!---------------------------------------------------------------------- 
     497      !!                ***  ROUTINE icb_utl_getkb         *** 
     498      !! 
     499      !! ** Purpose :   compute the latest level affected by icb 
     500      !! 
     501      !!---------------------------------------------------------------------- 
     502      INTEGER,                INTENT(out):: kb 
     503      REAL(wp), DIMENSION(:), INTENT(in) :: pe3 
     504      REAL(wp),               INTENT(in) :: pD 
     505      !! 
     506      INTEGER  :: jk 
     507      REAL(wp) :: zdepw 
     508      !!---------------------------------------------------------------------- 
     509      !! 
     510      zdepw = pe3(1) ; kb = 2 
     511      DO WHILE ( zdepw <  pD) 
     512         zdepw = zdepw + pe3(kb) 
     513         kb = kb + 1 
     514      END DO 
     515      kb = MIN(kb - 1,jpk) 
     516   END SUBROUTINE 
     517 
     518   SUBROUTINE icb_utl_zavg(pzavg, pdat, pe3, pD, kb ) 
     519      !!---------------------------------------------------------------------- 
     520      !!                ***  ROUTINE icb_utl_getkb         *** 
     521      !! 
     522      !! ** Purpose :   compute the vertical average of ocean properties affected by icb 
     523      !! 
     524      !!---------------------------------------------------------------------- 
     525      INTEGER,                INTENT(in ) :: kb        ! deepest level affected by icb 
     526      REAL(wp), DIMENSION(:), INTENT(in ) :: pe3, pdat ! vertical profile 
     527      REAL(wp),               INTENT(in ) :: pD        ! draft 
     528      REAL(wp),               INTENT(out) :: pzavg     ! z average 
     529      !!---------------------------------------------------------------------- 
     530      INTEGER  :: jk 
     531      REAL(wp) :: zdep 
     532      !!---------------------------------------------------------------------- 
     533      pzavg = 0.0 ; zdep = 0.0 
     534      DO jk = 1,kb-1 
     535         pzavg = pzavg + pe3(jk)*pdat(jk) 
     536         zdep  = zdep  + pe3(jk) 
     537      END DO 
     538      ! if kb is limited by mbkt  => bottom value is used between bathy and icb tail 
     539      ! if kb not limited by mbkt => ocean value over mask is used (ie 0.0 for u, v) 
     540      pzavg = ( pzavg + (pD - zdep)*pdat(kb)) / pD 
     541   END SUBROUTINE 
    467542 
    468543   SUBROUTINE icb_utl_add( bergvals, ptvals ) 
    … …  
    653728      WRITE(numicb, 9200) kt, berg%number(1), & 
    654729                   pt%xi, pt%yj, pt%lon, pt%lat, pt%uvel, pt%vvel,  & 
    655                    pt%uo, pt%vo, pt%ua, pt%va, pt%ui, pt%vi 
     730                   pt%ssu, pt%ssv, pt%ua, pt%va, pt%ui, pt%vi 
    656731      CALL flush( numicb ) 
    657732 9200 FORMAT(5x,i5,2x,i10,6(2x,2f10.4)) 
    … …  
    679754         WRITE(numicb,'(a," pe=(",i3,")")' ) cd_label, narea 
    680755         WRITE(numicb,'(a8,4x,a6,12x,a5,15x,a7,19x,a3,17x,a5,17x,a5,17x,a5)' )   & 
    681             &         'timestep', 'number', 'xi,yj','lon,lat','u,v','uo,vo','ua,va','ui,vi' 
     756            &         'timestep', 'number', 'xi,yj','lon,lat','u,v','ssu,ssv','ua,va','ui,vi' 
    682757      ENDIF 
    683758      DO WHILE( ASSOCIATED(this) ) 
    … …  
    823898   END FUNCTION icb_utl_heat 
    824899 
     900   SUBROUTINE test_icb_utl_getkb 
     901      !!---------------------------------------------------------------------- 
     902      !!                 ***  FUNCTION test_icb_utl_getkb  *** 
     903      !! 
     904      !! ** Purpose : Test routine icb_utl_getkb, icb_utl_zavg 
     905      !! ** Methode : Call each subroutine with specific input data 
     906      !!              What should be the output is easy to determined and check  
     907      !!              if NEMO return the correct answer. 
     908      !! ** Comments : not called, if needed a CALL test_icb_utl_getkb need to be added in icb_step 
     909      !!---------------------------------------------------------------------- 
     910      INTEGER :: ikb 
     911      REAL(wp) :: zD, zout 
     912      REAL(wp), DIMENSION(jpk) :: ze3, zin 
     913      WRITE(numout,*) 'Test icb_utl_getkb : ' 
     914      zD = 0.0 ; ze3= 20.0 
     915      WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1) 
     916      CALL icb_utl_getkb(ikb, ze3, zD) 
     917      WRITE(numout,*) 'OUTPUT : kb = ',ikb 
     918 
     919      zD = 8000000.0 ; ze3= 20.0 
     920      WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1) 
     921      CALL icb_utl_getkb(ikb, ze3, zD) 
     922      WRITE(numout,*) 'OUTPUT : kb = ',ikb 
     923 
     924      zD = 80.0 ; ze3= 20.0 
     925      WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1) 
     926      CALL icb_utl_getkb(ikb, ze3, zD) 
     927      WRITE(numout,*) 'OUTPUT : kb = ',ikb 
     928 
     929      zD = 85.0 ; ze3= 20.0 
     930      WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1) 
     931      CALL icb_utl_getkb(ikb, ze3, zD) 
     932      WRITE(numout,*) 'OUTPUT : kb = ',ikb 
     933 
     934      zD = 75.0 ; ze3= 20.0 
     935      WRITE(numout,*) 'INPUT : zD = ',zD,' ze3 = ',ze3(1) 
     936      CALL icb_utl_getkb(ikb, ze3, zD) 
     937      WRITE(numout,*) 'OUTPUT : kb = ',ikb 
     938 
     939      WRITE(numout,*) '==================================' 
     940      WRITE(numout,*) 'Test icb_utl_zavg' 
     941      zD = 0.0 ; ze3= 20.0 ; zin=1.0 
     942      CALL icb_utl_getkb(ikb, ze3, zD) 
     943      CALL icb_utl_zavg(zout, zin, ze3, zD, ikb) 
     944      WRITE(numout,*) 'INPUT  : zD = ',zD,' ze3 = ',ze3(1),' zin = ', zin, ' ikb = ',ikb 
     945      WRITE(numout,*) 'OUTPUT : zout = ',zout 
     946 
     947      zD = 50.0 ; ze3= 20.0 ; zin=1.0; zin(3:jpk) = 0.0 
     948      CALL icb_utl_getkb(ikb, ze3, zD) 
     949      CALL icb_utl_zavg(zout, zin, ze3, zD, ikb) 
     950      WRITE(numout,*) 'INPUT  : zD = ',zD,' ze3 = ',ze3(1),' zin = ', zin, ' ikb = ',ikb 
     951      WRITE(numout,*) 'OUTPUT : zout = ',zout 
     952      CALL FLUSH(numout) 
     953 
     954      zD = 80.0 ; ze3= 20.0 ; zin=1.0; zin(3:jpk) = 0.0 
     955      CALL icb_utl_getkb(ikb, ze3, zD) 
     956      CALL icb_utl_zavg(zout, zin, ze3, zD, ikb) 
     957      WRITE(numout,*) 'INPUT  : zD = ',zD,' ze3 = ',ze3(1),' zin = ', zin, ' ikb = ',ikb 
     958      WRITE(numout,*) 'OUTPUT : zout = ',zout 
     959 
     960      zD = 80 ; ze3= 20.0 ; zin=1.0 ; zin(3:jpk) = 0.0 
     961      CALL icb_utl_getkb(ikb, ze3, zD) 
     962      ikb = 2 
     963      CALL icb_utl_zavg(zout, zin, ze3, zD, ikb) 
     964      WRITE(numout,*) 'INPUT  : zD = ',zD,' ze3 = ',ze3(1),' zin = ', zin, ' ikb = ',ikb 
     965      WRITE(numout,*) 'OUTPUT : zout = ',zout 
     966 
     967      CALL FLUSH(numout) 
     968 
     969   END SUBROUTINE test_icb_utl_getkb 
     970 
    825971   !!====================================================================== 
    826972END MODULE icbutl 

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

    r13286 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/IOM/iom.F90

    r13747 r14043  
    2929   USE in_out_manager  ! I/O manager 
    3030   USE lib_mpp           ! MPP library 
    31 #if defined key_iomput 
    3231   USE sbc_oce  , ONLY :   nn_fsbc, ght_abl, ghw_abl, e3t_abl, e3w_abl, jpka, jpkam1 
    3332   USE icb_oce  , ONLY :   nclasses, class_num       !  !: iceberg classes 
    … …  
    3736   USE phycst          ! physical constants 
    3837   USE dianam          ! build name of file 
     38#if defined key_iomput 
    3939   USE xios 
    4040# endif 
    … …  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/IOM/iom_def.F90

    r13558 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/IOM/iom_nf90.F90

    r13286 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/IOM/prtctl.F90

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

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

    r13286 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/ISF/isfcav.F90

    r13226 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/ISF/isfcpl.F90

    r13295 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/ISF/isfrst.F90

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  • NEMO/branches/2020/dev_r13787_OSMOSIS_IMMERSE/src/OCE/SBC/cpl_oasis3.F90

    r13415 r14043  
    6666   INTEGER                    ::   nsnd         ! total number of fields sent  
    6767   INTEGER                    ::   ncplmodel    ! Maximum number of models to/from which NEMO is potentialy sending/receiving data 
    68    INTEGER, PUBLIC, PARAMETER ::   nmaxfld=60   ! Maximum number of coupling fields 
     68   INTEGER, PUBLIC, PARAMETER ::   nmaxfld=62   ! Maximum number of coupling fields 
    6969   INTEGER, PUBLIC, PARAMETER ::   nmaxcat=5    ! Maximum number of coupling fields 
    7070   INTEGER, PUBLIC, PARAMETER ::   nmaxcpl=5    ! Maximum number of coupling fields 

  • NEMO/branches/2020/dev_r13787_OSMOSIS_IMMERSE/src/OCE/SBC/sbc_oce.F90

    r13472 r14043  
    1212   !!            4.0  ! 2016-06  (L. Brodeau) new unified bulk routine (based on AeroBulk) 
    1313   !!            4.0  ! 2019-03  (F. Lemarié, G. Samson) add compatibility with ABL mode 
     14   !!            4.2  ! 2020-12  (G. Madec, E. Clementi) modified wave parameters in namelist 
    1415   !!---------------------------------------------------------------------- 
    1516 
    … …  
    3637   LOGICAL , PUBLIC ::   ln_blk         !: bulk formulation 
    3738   LOGICAL , PUBLIC ::   ln_abl         !: Atmospheric boundary layer model 
     39   LOGICAL , PUBLIC ::   ln_wave        !: wave in the system (forced or coupled) 
    3840#if defined key_oasis3 
    3941   LOGICAL , PUBLIC ::   lk_oasis = .TRUE.  !: OASIS used 
    … …  
    5658   !                                             !:  = 1 global mean of e-p-r set to zero at each nn_fsbc time step 
    5759   !                                             !:  = 2 annual global mean of e-p-r set to zero 
    58    LOGICAL , PUBLIC ::   ln_wave        !: true if some coupling with wave model 
    59    LOGICAL , PUBLIC ::   ln_cdgw        !: true if neutral drag coefficient from wave model 
    60    LOGICAL , PUBLIC ::   ln_sdw         !: true if 3d stokes drift from wave model 
    61    LOGICAL , PUBLIC ::   ln_tauwoc       !: true if normalized stress from wave is used 
    62    LOGICAL , PUBLIC ::   ln_tauw        !: true if ocean stress components from wave is used 
    63    LOGICAL , PUBLIC ::   ln_stcor       !: true if Stokes-Coriolis term is used 
    64    ! 
    65    INTEGER , PUBLIC ::   nn_sdrift      ! type of parameterization to calculate vertical Stokes drift 
    66    ! 
    6760   LOGICAL , PUBLIC ::   ln_icebergs    !: Icebergs 
    6861   ! 
    … …  
    7164   !                                   !!* namsbc_cpl namelist * 
    7265   INTEGER , PUBLIC ::   nn_cats_cpl    !: Number of sea ice categories over which the coupling is carried out 
    73  
     66   ! 
     67   !                                   !!* namsbc_wave namelist * 
     68   LOGICAL , PUBLIC ::   ln_sdw         !: =T 3d stokes drift from wave model 
     69   LOGICAL , PUBLIC ::   ln_stcor       !: =T if Stokes-Coriolis and tracer advection terms are used 
     70   LOGICAL , PUBLIC ::   ln_cdgw        !: =T neutral drag coefficient from wave model 
     71   LOGICAL , PUBLIC ::   ln_tauoc       !: =T if normalized stress from wave is used 
     72   LOGICAL , PUBLIC ::   ln_wave_test   !: =T wave test case (constant Stokes drift) 
     73   LOGICAL , PUBLIC ::   ln_charn       !: =T Chranock coefficient from wave model 
     74   LOGICAL , PUBLIC ::   ln_taw         !: =T wind stress corrected by wave intake 
     75   LOGICAL , PUBLIC ::   ln_phioc       !: =T TKE surface BC from wave model  
     76   LOGICAL , PUBLIC ::   ln_bern_srfc   !: Bernoulli head, waves' inuced pressure 
     77   LOGICAL , PUBLIC ::   ln_breivikFV_2016 !: Breivik 2016 profile 
     78   LOGICAL , PUBLIC ::   ln_vortex_force !: vortex force activation 
     79   LOGICAL , PUBLIC ::   ln_stshear     !: Stoked Drift shear contribution in zdftke 
     80   ! 
    7481   !!---------------------------------------------------------------------- 
    7582   !!           switch definition (improve readability) 
    … …  
    8188   INTEGER , PUBLIC, PARAMETER ::   jp_purecpl = 5        !: Pure ocean-atmosphere Coupled formulation 
    8289   INTEGER , PUBLIC, PARAMETER ::   jp_none    = 6        !: for OPA when doing coupling via SAS module 
    83  
    84    !!---------------------------------------------------------------------- 
    85    !!           Stokes drift parametrization definition 
    86    !!---------------------------------------------------------------------- 
    87    INTEGER , PUBLIC, PARAMETER ::   jp_breivik_2014 = 0     !: Breivik  2014: v_z=v_0*[exp(2*k*z)/(1-8*k*z)] 
    88    INTEGER , PUBLIC, PARAMETER ::   jp_li_2017      = 1     !: Li et al 2017: Stokes drift based on Phillips spectrum (Breivik 2016) 
    89    !  with depth averaged profile 
    90    INTEGER , PUBLIC, PARAMETER ::   jp_peakfr       = 2     !: Li et al 2017: using the peak wave number read from wave model instead 
    91    !  of the inverse depth scale 
    92    LOGICAL , PUBLIC            ::   ll_st_bv2014  = .FALSE. !  logical indicator, .true. if Breivik 2014 parameterisation is active. 
    93    LOGICAL , PUBLIC            ::   ll_st_li2017  = .FALSE. !  logical indicator, .true. if Li 2017 parameterisation is active. 
    94    LOGICAL , PUBLIC            ::   ll_st_bv_li   = .FALSE. !  logical indicator, .true. if either Breivik or Li parameterisation is active. 
    95    LOGICAL , PUBLIC            ::   ll_st_peakfr  = .FALSE. !  logical indicator, .true. if using Li 2017 with peak wave number 
    96  
     90   ! 
    9791   !!---------------------------------------------------------------------- 
    9892   !!           component definition 

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

    r13286 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/SBC/sbcblk.F90

    r13501 r14043  
    314314         ENDIF 
    315315      END DO 
    316       ! 
    317       IF( ln_wave ) THEN 
    318          !Activated wave module but neither drag nor stokes drift activated 
    319          IF( .NOT.(ln_cdgw .OR. ln_sdw .OR. ln_tauwoc .OR. ln_stcor ) )   THEN 
    320             CALL ctl_stop( 'STOP',  'Ask for wave coupling but ln_cdgw=F, ln_sdw=F, ln_tauwoc=F, ln_stcor=F' ) 
    321             !drag coefficient read from wave model definable only with mfs bulk formulae and core 
    322          ELSEIF(ln_cdgw .AND. .NOT. ln_NCAR )       THEN 
    323             CALL ctl_stop( 'drag coefficient read from wave model definable only with NCAR and CORE bulk formulae') 
    324          ELSEIF(ln_stcor .AND. .NOT. ln_sdw)                             THEN 
    325             CALL ctl_stop( 'Stokes-Coriolis term calculated only if activated Stokes Drift ln_sdw=T') 
    326          ENDIF 
    327       ELSE 
    328          IF( ln_cdgw .OR. ln_sdw .OR. ln_tauwoc .OR. ln_stcor )                & 
    329             &   CALL ctl_stop( 'Not Activated Wave Module (ln_wave=F) but asked coupling ',    & 
    330             &                  'with drag coefficient (ln_cdgw =T) '  ,                        & 
    331             &                  'or Stokes Drift (ln_sdw=T) ' ,                                 & 
    332             &                  'or ocean stress modification due to waves (ln_tauwoc=T) ',      & 
    333             &                  'or Stokes-Coriolis term (ln_stcori=T)'  ) 
    334       ENDIF 
    335316      ! 
    336317      IF( ln_abl ) THEN       ! ABL: read 3D fields for wind, temperature, humidity and pressure gradient 

  • NEMO/branches/2020/dev_r13787_OSMOSIS_IMMERSE/src/OCE/SBC/sbcblk_algo_ecmwf.F90

    r13460 r14043  
    1717   !!---------------------------------------------------------------------- 
    1818   !! History :  4.0  !  2016-02  (L.Brodeau)   Original code 
     19   !!            4.2  !  2020-12  (G. Madec, E. Clementi) Charnock coeff from wave model 
    1920   !!---------------------------------------------------------------------- 
    2021 
    … …  
    3132   USE in_out_manager  ! I/O manager 
    3233   USE prtctl          ! Print control 
    33    USE sbcwave, ONLY   :  cdn_wave ! wave module 
     34   USE sbcwave, ONLY   : charn ! wave module 
    3435#if defined key_si3 || defined key_cice 
    3536   USE sbc_ice         ! Surface boundary condition: ice fields 
    … …  
    233234      u_star = 0.035_wp*U_blk*ztmp1/ztmp0       ! (u* = 0.035*Un10) 
    234235 
    235       z0     = charn0*u_star*u_star/grav + 0.11_wp*znu_a/u_star 
     236      IF (ln_charn)  THEN          !  Charnock value if wave coupling 
     237         z0     = charn*u_star*u_star/grav + 0.11_wp*znu_a/u_star 
     238      ELSE 
     239         z0     = charn0*u_star*u_star/grav + 0.11_wp*znu_a/u_star 
     240      ENDIF 
     241 
    236242      z0     = MIN( MAX(ABS(z0), 1.E-9) , 1._wp )                      ! (prevents FPE from stupid values from masked region later on) 
    237243 
    … …  
    302308         ztmp2  = u_star*u_star 
    303309         ztmp1  = znu_a/u_star 
    304          z0     = MIN( ABS( alpha_M*ztmp1 + charn0*ztmp2/grav ) , 0.001_wp) 
     310         IF (ln_charn) THEN     ! Charnock value if wave coupling 
     311            z0  = MIN( ABS( alpha_M*ztmp1 + charn*ztmp2/grav ) , 0.001_wp)          
     312         ELSE 
     313            z0     = MIN( ABS( alpha_M*ztmp1 + charn0*ztmp2/grav ) , 0.001_wp) 
     314         ENDIF 
    305315         z0t    = MIN( ABS( alpha_H*ztmp1                     ) , 0.001_wp)   ! eq.3.26, Chap.3, p.34, IFS doc - Cy31r1 
    306316         z0q    = MIN( ABS( alpha_Q*ztmp1                     ) , 0.001_wp) 

  • NEMO/branches/2020/dev_r13787_OSMOSIS_IMMERSE/src/OCE/SBC/sbccpl.F90

    r13497 r14043  
    88   !!            3.1  ! 2009_02  (G. Madec, S. Masson, E. Maisonave, A. Caubel) generic coupled interface 
    99   !!            3.4  ! 2011_11  (C. Harris) more flexibility + multi-category fields 
     10   !!            4.2  ! 2020-12  (G. Madec, E. Clementi)  wave coupling updates 
    1011   !!---------------------------------------------------------------------- 
    1112 
    … …  
    106107   INTEGER, PARAMETER ::   jpr_fraqsr = 42   ! fraction of solar net radiation absorbed in the first ocean level 
    107108   INTEGER, PARAMETER ::   jpr_mslp   = 43   ! mean sea level pressure  
    108    INTEGER, PARAMETER ::   jpr_hsig   = 44   ! Hsig  
    109    INTEGER, PARAMETER ::   jpr_phioc  = 45   ! Wave=>ocean energy flux  
    110    INTEGER, PARAMETER ::   jpr_sdrftx = 46   ! Stokes drift on grid 1  
    111    INTEGER, PARAMETER ::   jpr_sdrfty = 47   ! Stokes drift on grid 2  
     109   !**  surface wave coupling  ** 
     110   INTEGER, PARAMETER ::   jpr_hsig   = 44   ! Hsig 
     111   INTEGER, PARAMETER ::   jpr_phioc  = 45   ! Wave=>ocean energy flux 
     112   INTEGER, PARAMETER ::   jpr_sdrftx = 46   ! Stokes drift on grid 1 
     113   INTEGER, PARAMETER ::   jpr_sdrfty = 47   ! Stokes drift on grid 2 
    112114   INTEGER, PARAMETER ::   jpr_wper   = 48   ! Mean wave period 
    113115   INTEGER, PARAMETER ::   jpr_wnum   = 49   ! Mean wavenumber 
    114    INTEGER, PARAMETER ::   jpr_tauwoc = 50   ! Stress fraction adsorbed by waves 
     116   INTEGER, PARAMETER ::   jpr_wstrf = 50   ! Stress fraction adsorbed by waves 
    115117   INTEGER, PARAMETER ::   jpr_wdrag  = 51   ! Neutral surface drag coefficient 
    116    INTEGER, PARAMETER ::   jpr_isf    = 52 
    117    INTEGER, PARAMETER ::   jpr_icb    = 53 
    118    INTEGER, PARAMETER ::   jpr_wfreq  = 54   ! Wave peak frequency 
    119    INTEGER, PARAMETER ::   jpr_tauwx  = 55   ! x component of the ocean stress from waves 
    120    INTEGER, PARAMETER ::   jpr_tauwy  = 56   ! y component of the ocean stress from waves 
    121    INTEGER, PARAMETER ::   jpr_ts_ice = 57   ! Sea ice surface temp 
    122  
    123    INTEGER, PARAMETER ::   jprcv      = 57   ! total number of fields received   
     118   INTEGER, PARAMETER ::   jpr_charn  = 52   ! Chranock coefficient 
     119   INTEGER, PARAMETER ::   jpr_twox   = 53   ! wave to ocean momentum flux 
     120   INTEGER, PARAMETER ::   jpr_twoy   = 54   ! wave to ocean momentum flux 
     121   INTEGER, PARAMETER ::   jpr_tawx   = 55   ! net wave-supported stress 
     122   INTEGER, PARAMETER ::   jpr_tawy   = 56   ! net wave-supported stress 
     123   INTEGER, PARAMETER ::   jpr_bhd    = 57   ! Bernoulli head. waves' induced surface pressure 
     124   INTEGER, PARAMETER ::   jpr_tusd   = 58   ! zonal stokes transport 
     125   INTEGER, PARAMETER ::   jpr_tvsd   = 59   ! meridional stokes tranmport 
     126   INTEGER, PARAMETER ::   jpr_isf    = 60 
     127   INTEGER, PARAMETER ::   jpr_icb    = 61 
     128   INTEGER, PARAMETER ::   jpr_ts_ice = 62   ! Sea ice surface temp 
     129 
     130   INTEGER, PARAMETER ::   jprcv      = 62   ! total number of fields received   
    124131 
    125132   INTEGER, PARAMETER ::   jps_fice   =  1   ! ice fraction sent to the atmosphere 
    … …  
    184191      &             sn_snd_thick1, sn_snd_cond, sn_snd_mpnd , sn_snd_sstfrz, sn_snd_ttilyr 
    185192   !                                   ! Received from the atmosphere 
    186    TYPE(FLD_C) ::   sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau, sn_rcv_tauw, sn_rcv_dqnsdt, sn_rcv_qsr,  & 
     193   TYPE(FLD_C) ::   sn_rcv_w10m, sn_rcv_taumod, sn_rcv_tau, sn_rcv_dqnsdt, sn_rcv_qsr,  & 
    187194      &             sn_rcv_qns , sn_rcv_emp   , sn_rcv_rnf, sn_rcv_ts_ice 
    188195   TYPE(FLD_C) ::   sn_rcv_cal, sn_rcv_iceflx, sn_rcv_co2, sn_rcv_mslp, sn_rcv_icb, sn_rcv_isf 
    189    ! Send to waves  
     196   !                                   ! Send to waves  
    190197   TYPE(FLD_C) ::   sn_snd_ifrac, sn_snd_crtw, sn_snd_wlev  
    191    ! Received from waves  
    192    TYPE(FLD_C) ::   sn_rcv_hsig, sn_rcv_phioc, sn_rcv_sdrfx, sn_rcv_sdrfy, sn_rcv_wper, sn_rcv_wnum, sn_rcv_tauwoc, & 
    193                     sn_rcv_wdrag, sn_rcv_wfreq 
     198   !                                   ! Received from waves  
     199   TYPE(FLD_C) ::   sn_rcv_hsig, sn_rcv_phioc, sn_rcv_sdrfx, sn_rcv_sdrfy, sn_rcv_wper, sn_rcv_wnum, & 
     200      &             sn_rcv_wstrf, sn_rcv_wdrag, sn_rcv_charn, sn_rcv_taw, sn_rcv_bhd, sn_rcv_tusd, sn_rcv_tvsd 
    194201   !                                   ! Other namelist parameters 
    195202   INTEGER     ::   nn_cplmodel           ! Maximum number of models to/from which NEMO is potentialy sending/receiving data 
    … …  
    274281         &                  sn_snd_ifrac , sn_snd_crtw  , sn_snd_wlev , sn_rcv_hsig  , sn_rcv_phioc ,  &  
    275282         &                  sn_rcv_w10m  , sn_rcv_taumod, sn_rcv_tau  , sn_rcv_dqnsdt, sn_rcv_qsr   ,  &  
    276          &                  sn_rcv_sdrfx , sn_rcv_sdrfy , sn_rcv_wper , sn_rcv_wnum  , sn_rcv_tauwoc,  & 
    277          &                  sn_rcv_wdrag , sn_rcv_qns   , sn_rcv_emp  , sn_rcv_rnf   , sn_rcv_cal   ,  & 
    278          &                  sn_rcv_iceflx, sn_rcv_co2   , sn_rcv_mslp ,                                & 
    279          &                  sn_rcv_icb   , sn_rcv_isf   , sn_rcv_wfreq, sn_rcv_tauw  ,                 & 
    280          &                  sn_rcv_ts_ice 
     283         &                  sn_rcv_sdrfx , sn_rcv_sdrfy , sn_rcv_wper , sn_rcv_wnum  , sn_rcv_wstrf ,  & 
     284         &                  sn_rcv_charn , sn_rcv_taw   , sn_rcv_bhd  , sn_rcv_tusd  , sn_rcv_tvsd,    & 
     285         &                  sn_rcv_wdrag , sn_rcv_qns   , sn_rcv_emp  , sn_rcv_rnf   , sn_rcv_cal  ,   & 
     286         &                  sn_rcv_iceflx, sn_rcv_co2   , sn_rcv_icb  , sn_rcv_isf   , sn_rcv_ts_ice  
     287 
    281288      !!--------------------------------------------------------------------- 
    282289      ! 
    … …  
    319326         WRITE(numout,*)'      sea ice heat fluxes             = ', TRIM(sn_rcv_iceflx%cldes), ' (', TRIM(sn_rcv_iceflx%clcat), ')' 
    320327         WRITE(numout,*)'      atm co2                         = ', TRIM(sn_rcv_co2%cldes   ), ' (', TRIM(sn_rcv_co2%clcat   ), ')' 
     328         WRITE(numout,*)'      Sea ice surface skin temperature= ', TRIM(sn_rcv_ts_ice%cldes), ' (', TRIM(sn_rcv_ts_ice%clcat), ')' 
     329         WRITE(numout,*)'      surface waves:' 
    321330         WRITE(numout,*)'      significant wave heigth         = ', TRIM(sn_rcv_hsig%cldes  ), ' (', TRIM(sn_rcv_hsig%clcat  ), ')'  
    322331         WRITE(numout,*)'      wave to oce energy flux         = ', TRIM(sn_rcv_phioc%cldes ), ' (', TRIM(sn_rcv_phioc%clcat ), ')'  
    … …  
    325334         WRITE(numout,*)'      Mean wave period                = ', TRIM(sn_rcv_wper%cldes  ), ' (', TRIM(sn_rcv_wper%clcat  ), ')'  
    326335         WRITE(numout,*)'      Mean wave number                = ', TRIM(sn_rcv_wnum%cldes  ), ' (', TRIM(sn_rcv_wnum%clcat  ), ')'  
    327          WRITE(numout,*)'      Wave peak frequency             = ', TRIM(sn_rcv_wfreq%cldes ), ' (', TRIM(sn_rcv_wfreq%clcat ), ')' 
    328          WRITE(numout,*)'      Stress frac adsorbed by waves   = ', TRIM(sn_rcv_tauwoc%cldes), ' (', TRIM(sn_rcv_tauwoc%clcat ), ')'  
    329          WRITE(numout,*)'      Stress components by waves      = ', TRIM(sn_rcv_tauw%cldes  ), ' (', TRIM(sn_rcv_tauw%clcat  ), ')' 
     336         WRITE(numout,*)'      Stress frac adsorbed by waves   = ', TRIM(sn_rcv_wstrf%cldes ), ' (', TRIM(sn_rcv_wstrf%clcat ), ')' 
    330337         WRITE(numout,*)'      Neutral surf drag coefficient   = ', TRIM(sn_rcv_wdrag%cldes ), ' (', TRIM(sn_rcv_wdrag%clcat ), ')'  
    331          WRITE(numout,*)'      Sea ice surface skin temperature= ', TRIM(sn_rcv_ts_ice%cldes), ' (', TRIM(sn_rcv_ts_ice%clcat), ')'  
     338         WRITE(numout,*)'      Charnock coefficient            = ', TRIM(sn_rcv_charn%cldes ), ' (', TRIM(sn_rcv_charn%clcat ), ')' 
    332339         WRITE(numout,*)'  sent fields (multiple ice categories)' 
    333340         WRITE(numout,*)'      surface temperature             = ', TRIM(sn_snd_temp%cldes  ), ' (', TRIM(sn_snd_temp%clcat  ), ')' 
    … …  
    351358         WRITE(numout,*)'                      - mesh          = ', sn_snd_crtw%clvgrd  
    352359      ENDIF 
    353  
     360      IF( lwp .AND. ln_wave) THEN                        ! control print 
     361      WRITE(numout,*)'      surface waves:' 
     362         WRITE(numout,*)'      Significant wave heigth         = ', TRIM(sn_rcv_hsig%cldes  ), ' (', TRIM(sn_rcv_hsig%clcat  ), ')' 
     363         WRITE(numout,*)'      Wave to oce energy flux         = ', TRIM(sn_rcv_phioc%cldes ), ' (', TRIM(sn_rcv_phioc%clcat ), ')' 
     364         WRITE(numout,*)'      Surface Stokes drift grid u     = ', TRIM(sn_rcv_sdrfx%cldes ), ' (', TRIM(sn_rcv_sdrfx%clcat ), ')' 
     365         WRITE(numout,*)'      Surface Stokes drift grid v     = ', TRIM(sn_rcv_sdrfy%cldes ), ' (', TRIM(sn_rcv_sdrfy%clcat ), ')' 
     366         WRITE(numout,*)'      Mean wave period                = ', TRIM(sn_rcv_wper%cldes  ), ' (', TRIM(sn_rcv_wper%clcat  ), ')' 
     367         WRITE(numout,*)'      Mean wave number                = ', TRIM(sn_rcv_wnum%cldes  ), ' (', TRIM(sn_rcv_wnum%clcat  ), ')' 
     368         WRITE(numout,*)'      Stress frac adsorbed by waves   = ', TRIM(sn_rcv_wstrf%cldes ), ' (', TRIM(sn_rcv_wstrf%clcat ), ')' 
     369         WRITE(numout,*)'      Neutral surf drag coefficient   = ', TRIM(sn_rcv_wdrag%cldes ), ' (', TRIM(sn_rcv_wdrag%clcat ), ')' 
     370         WRITE(numout,*)'      Charnock coefficient            = ', TRIM(sn_rcv_charn%cldes ), ' (', TRIM(sn_rcv_charn%clcat ), ')' 
     371         WRITE(numout,*)' Transport associated to Stokes drift grid u = ', TRIM(sn_rcv_tusd%cldes ), ' (', TRIM(sn_rcv_tusd%clcat ), ')' 
     372         WRITE(numout,*)' Transport associated to Stokes drift grid v = ', TRIM(sn_rcv_tvsd%cldes ), ' (', TRIM(sn_rcv_tvsd%clcat ), ')' 
     373         WRITE(numout,*)'      Bernouilli pressure head        = ', TRIM(sn_rcv_bhd%cldes   ), ' (', TRIM(sn_rcv_bhd%clcat  ), ')' 
     374         WRITE(numout,*)'Wave to ocean momentum flux and Net wave-supported stress = ', TRIM(sn_rcv_taw%cldes ), ' (', TRIM(sn_rcv_taw%clcat ), ')' 
     375         WRITE(numout,*)'      Surface current to waves        = ', TRIM(sn_snd_crtw%cldes  ), ' (', TRIM(sn_snd_crtw%clcat  ), ')' 
     376         WRITE(numout,*)'                      - referential   = ', sn_snd_crtw%clvref 
     377         WRITE(numout,*)'                      - orientation   = ', sn_snd_crtw%clvor 
     378         WRITE(numout,*)'                      - mesh          = ', sn_snd_crtw%clvgrd 
     379      ENDIF 
    354380      !                                   ! allocate sbccpl arrays 
    355381      IF( sbc_cpl_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_cpl_alloc : unable to allocate arrays' ) 
    … …  
    629655         cpl_wper = .TRUE. 
    630656      ENDIF 
    631       srcv(jpr_wfreq)%clname = 'O_WFreq'     ! wave peak frequency  
    632       IF( TRIM(sn_rcv_wfreq%cldes ) == 'coupled' )  THEN 
    633          srcv(jpr_wfreq)%laction = .TRUE. 
    634          cpl_wfreq = .TRUE. 
    635       ENDIF 
    636657      srcv(jpr_wnum)%clname = 'O_WNum'       ! mean wave number 
    637658      IF( TRIM(sn_rcv_wnum%cldes ) == 'coupled' )  THEN 
    … …  
    639660         cpl_wnum = .TRUE. 
    640661      ENDIF 
    641       srcv(jpr_tauwoc)%clname = 'O_TauOce'   ! stress fraction adsorbed by the wave 
    642       IF( TRIM(sn_rcv_tauwoc%cldes ) == 'coupled' )  THEN 
    643          srcv(jpr_tauwoc)%laction = .TRUE. 
    644          cpl_tauwoc = .TRUE. 
    645       ENDIF 
    646       srcv(jpr_tauwx)%clname = 'O_Tauwx'      ! ocean stress from wave in the x direction 
    647       srcv(jpr_tauwy)%clname = 'O_Tauwy'      ! ocean stress from wave in the y direction 
    648       IF( TRIM(sn_rcv_tauw%cldes ) == 'coupled' )  THEN 
    649          srcv(jpr_tauwx)%laction = .TRUE. 
    650          srcv(jpr_tauwy)%laction = .TRUE. 
    651          cpl_tauw = .TRUE. 
     662      srcv(jpr_wstrf)%clname = 'O_WStrf'     ! stress fraction adsorbed by the wave 
     663      IF( TRIM(sn_rcv_wstrf%cldes ) == 'coupled' )  THEN 
     664         srcv(jpr_wstrf)%laction = .TRUE. 
     665         cpl_wstrf = .TRUE. 
    652666      ENDIF 
    653667      srcv(jpr_wdrag)%clname = 'O_WDrag'     ! neutral surface drag coefficient 
    … …  
    656670         cpl_wdrag = .TRUE. 
    657671      ENDIF 
    658       IF( srcv(jpr_tauwoc)%laction .AND. srcv(jpr_tauwx)%laction .AND. srcv(jpr_tauwy)%laction ) & 
    659             CALL ctl_stop( 'More than one method for modifying the ocean stress has been selected ', & 
    660                                      '(sn_rcv_tauwoc=coupled and sn_rcv_tauw=coupled)' ) 
     672      srcv(jpr_charn)%clname = 'O_Charn'     ! Chranock coefficient 
     673      IF( TRIM(sn_rcv_charn%cldes ) == 'coupled' )  THEN 
     674         srcv(jpr_charn)%laction = .TRUE. 
     675         cpl_charn = .TRUE. 
     676      ENDIF 
     677      srcv(jpr_bhd)%clname = 'O_Bhd'     ! Bernoulli head. waves' induced surface pressure 
     678      IF( TRIM(sn_rcv_bhd%cldes ) == 'coupled' )  THEN 
     679         srcv(jpr_bhd)%laction = .TRUE. 
     680         cpl_bhd = .TRUE. 
     681      ENDIF 
     682      srcv(jpr_tusd)%clname = 'O_Tusd'     ! zonal stokes transport 
     683      IF( TRIM(sn_rcv_tusd%cldes ) == 'coupled' )  THEN 
     684         srcv(jpr_tusd)%laction = .TRUE. 
     685         cpl_tusd = .TRUE. 
     686      ENDIF 
     687      srcv(jpr_tvsd)%clname = 'O_Tvsd'     ! meridional stokes tranmport 
     688      IF( TRIM(sn_rcv_tvsd%cldes ) == 'coupled' )  THEN 
     689         srcv(jpr_tvsd)%laction = .TRUE. 
     690         cpl_tvsd = .TRUE. 
     691      ENDIF 
     692 
     693      srcv(jpr_twox)%clname = 'O_Twox'     ! wave to ocean momentum flux in the u direction 
     694      srcv(jpr_twoy)%clname = 'O_Twoy'     ! wave to ocean momentum flux in the v direction 
     695      srcv(jpr_tawx)%clname = 'O_Tawx'     ! Net wave-supported stress in the u direction 
     696      srcv(jpr_tawy)%clname = 'O_Tawy'     ! Net wave-supported stress in the v direction 
     697      IF( TRIM(sn_rcv_taw%cldes ) == 'coupled' )  THEN 
     698         srcv(jpr_twox)%laction = .TRUE. 
     699         srcv(jpr_twoy)%laction = .TRUE. 
     700         srcv(jpr_tawx)%laction = .TRUE. 
     701         srcv(jpr_tawy)%laction = .TRUE. 
     702         cpl_taw = .TRUE. 
     703      ENDIF 
    661704      ! 
    662705      !                                                      ! ------------------------------- ! 
    … …  
    10581101      !   initialisation of the coupler  ! 
    10591102      ! ================================ ! 
    1060  
    10611103      CALL cpl_define(jprcv, jpsnd, nn_cplmodel) 
    10621104       
    … …  
    10711113      ENDIF 
    10721114      xcplmask(:,:,0) = 1. - SUM( xcplmask(:,:,1:nn_cplmodel), dim = 3 ) 
     1115      ! 
    10731116      ! 
    10741117   END SUBROUTINE sbc_cpl_init 
    … …  
    11461189         IF( ncpl_qsr_freq /= 0) ncpl_qsr_freq = 86400 / ncpl_qsr_freq ! used by top 
    11471190          
     1191         IF ( ln_wave .AND. nn_components == 0 ) THEN 
     1192            ncpl_qsr_freq = 1; 
     1193            WRITE(numout,*) 'ncpl_qsr_freq is set to 1 when coupling NEMO with wave (without SAS) ' 
     1194         ENDIF 
    11481195      ENDIF 
    11491196      ! 
    … …  
    13201367         IF( srcv(jpr_hsig)%laction ) hsw(:,:) = frcv(jpr_hsig)%z3(:,:,1) 
    13211368      !  
    1322       !                                                      ! ========================= !   
    1323       !                                                      !    Wave peak frequency    !  
    1324       !                                                      ! ========================= !   
    1325          IF( srcv(jpr_wfreq)%laction ) wfreq(:,:) = frcv(jpr_wfreq)%z3(:,:,1) 
    1326       ! 
    13271369      !                                                      ! ========================= !  
    13281370      !                                                      !    Vertical mixing Qiao   ! 
    … …  
    13311373 
    13321374         ! Calculate the 3D Stokes drift both in coupled and not fully uncoupled mode 
    1333          IF( srcv(jpr_sdrftx)%laction .OR. srcv(jpr_sdrfty)%laction .OR. srcv(jpr_wper)%laction & 
    1334                                       .OR. srcv(jpr_hsig)%laction   .OR. srcv(jpr_wfreq)%laction) THEN 
     1375         IF( srcv(jpr_sdrftx)%laction .OR. srcv(jpr_sdrfty)%laction .OR. & 
     1376             srcv(jpr_wper)%laction .OR. srcv(jpr_hsig)%laction )  THEN 
    13351377            CALL sbc_stokes( Kmm ) 
    13361378         ENDIF 
    … …  
    13391381      !                                                      ! Stress adsorbed by waves  ! 
    13401382      !                                                      ! ========================= !  
    1341       IF( srcv(jpr_tauwoc)%laction .AND. ln_tauwoc ) tauoc_wave(:,:) = frcv(jpr_tauwoc)%z3(:,:,1) 
    1342  
    1343       !                                                      ! ========================= !   
    1344       !                                                      ! Stress component by waves !  
    1345       !                                                      ! ========================= !   
    1346       IF( srcv(jpr_tauwx)%laction .AND. srcv(jpr_tauwy)%laction .AND. ln_tauw ) THEN 
    1347          tauw_x(:,:) = frcv(jpr_tauwx)%z3(:,:,1) 
    1348          tauw_y(:,:) = frcv(jpr_tauwy)%z3(:,:,1) 
    1349       ENDIF 
    1350  
     1383      IF( srcv(jpr_wstrf)%laction .AND. ln_tauoc )  tauoc_wave(:,:) = frcv(jpr_wstrf)%z3(:,:,1) 
     1384      ! 
    13511385      !                                                      ! ========================= !  
    13521386      !                                                      !   Wave drag coefficient   ! 
    13531387      !                                                      ! ========================= !  
    13541388      IF( srcv(jpr_wdrag)%laction .AND. ln_cdgw )   cdn_wave(:,:) = frcv(jpr_wdrag)%z3(:,:,1) 
    1355  
     1389      ! 
     1390      !                                                      ! ========================= ! 
     1391      !                                                      !   Chranock coefficient    ! 
     1392      !                                                      ! ========================= ! 
     1393      IF( srcv(jpr_charn)%laction .AND. ln_charn )  charn(:,:) = frcv(jpr_charn)%z3(:,:,1) 
     1394      ! 
     1395      !                                                      ! ========================= ! 
     1396      !                                                      ! net wave-supported stress ! 
     1397      !                                                      ! ========================= ! 
     1398      IF( srcv(jpr_tawx)%laction .AND. ln_taw )     tawx(:,:) = frcv(jpr_tawx)%z3(:,:,1) 
     1399      IF( srcv(jpr_tawy)%laction .AND. ln_taw )     tawy(:,:) = frcv(jpr_tawy)%z3(:,:,1) 
     1400      ! 
     1401      !                                                      ! ========================= ! 
     1402      !                                                      !wave to ocean momentum flux! 
     1403      !                                                      ! ========================= ! 
     1404      IF( srcv(jpr_twox)%laction .AND. ln_taw )     twox(:,:) = frcv(jpr_twox)%z3(:,:,1) 
     1405      IF( srcv(jpr_twoy)%laction .AND. ln_taw )     twoy(:,:) = frcv(jpr_twoy)%z3(:,:,1) 
     1406      !                                                       
     1407      !                                                      ! ========================= ! 
     1408      !                                                      !    wave TKE flux at sfc   ! 
     1409      !                                                      ! ========================= ! 
     1410      IF( srcv(jpr_phioc)%laction .AND. ln_phioc )     phioc(:,:) = frcv(jpr_phioc)%z3(:,:,1) 
     1411      ! 
     1412      !                                                      ! ========================= ! 
     1413      !                                                      !      Bernoulli head       ! 
     1414      !                                                      ! ========================= ! 
     1415      IF( srcv(jpr_bhd)%laction .AND. ln_bern_srfc )   bhd_wave(:,:) = frcv(jpr_bhd)%z3(:,:,1) 
     1416      ! 
     1417      !                                                      ! ========================= ! 
     1418      !                                                      !   Stokes transport u dir  ! 
     1419      !                                                      ! ========================= ! 
     1420      IF( srcv(jpr_tusd)%laction .AND. ln_breivikFV_2016 )    tusd(:,:) = frcv(jpr_tusd)%z3(:,:,1) 
     1421      ! 
     1422      !                                                      ! ========================= ! 
     1423      !                                                      !   Stokes transport v dir  ! 
     1424      !                                                      ! ========================= ! 
     1425      IF( srcv(jpr_tvsd)%laction .AND. ln_breivikFV_2016 )     tvsd(:,:) = frcv(jpr_tvsd)%z3(:,:,1) 
     1426      ! 
    13561427      !  Fields received by SAS when OASIS coupling 
    13571428      !  (arrays no more filled at sbcssm stage) 

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

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

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

    r13722 r14043  
    1616   !!            4.0  ! 2016-06  (L. Brodeau) new general bulk formulation 
    1717   !!            4.0  ! 2019-03  (F. Lemarié & G. Samson)  add ABL compatibility (ln_abl=TRUE) 
     18   !!            4.2  ! 2020-12  (G. Madec, E. Clementi) modified wave forcing and coupling   
    1819   !!---------------------------------------------------------------------- 
    1920 
    … …  
    5455   USE usrdef_sbc     ! user defined: surface boundary condition 
    5556   USE closea         ! closed sea 
     57   USE lbclnk         ! ocean lateral boundary conditions (or mpp link) 
    5658   ! 
    5759   USE prtctl         ! Print control                    (prt_ctl routine) 
    … …  
    7072 
    7173   INTEGER ::   nsbc   ! type of surface boundary condition (deduced from namsbc informations) 
    72  
     74   !! * Substitutions 
     75#  include "do_loop_substitute.h90" 
    7376   !!---------------------------------------------------------------------- 
    7477   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    99102         &             nn_ice   , ln_ice_embd,                                       & 
    100103         &             ln_traqsr, ln_dm2dc ,                                         & 
    101          &             ln_rnf   , nn_fwb   , ln_ssr   , ln_apr_dyn,                  & 
    102          &             ln_wave  , ln_cdgw  , ln_sdw   , ln_tauwoc , ln_stcor  ,      & 
    103          &             ln_tauw  , nn_lsm, nn_sdrift 
     104         &             ln_rnf   , nn_fwb     , ln_ssr   , ln_apr_dyn,                & 
     105         &             ln_wave  , nn_lsm 
    104106      !!---------------------------------------------------------------------- 
    105107      ! 
    … …  
    133135         WRITE(numout,*) '         bulk         formulation                   ln_blk        = ', ln_blk 
    134136         WRITE(numout,*) '         ABL          formulation                   ln_abl        = ', ln_abl 
     137         WRITE(numout,*) '         Surface wave (forced or coupled)           ln_wave       = ', ln_wave 
    135138         WRITE(numout,*) '      Type of coupling (Ocean/Ice/Atmosphere) : ' 
    136139         WRITE(numout,*) '         ocean-atmosphere coupled formulation       ln_cpl        = ', ln_cpl 
    … …  
    150153         WRITE(numout,*) '         runoff / runoff mouths                     ln_rnf        = ', ln_rnf 
    151154         WRITE(numout,*) '         nb of iterations if land-sea-mask applied  nn_lsm        = ', nn_lsm 
    152          WRITE(numout,*) '         surface wave                               ln_wave       = ', ln_wave 
    153          WRITE(numout,*) '               Stokes drift corr. to vert. velocity ln_sdw        = ', ln_sdw 
    154          WRITE(numout,*) '                  vertical parametrization          nn_sdrift     = ', nn_sdrift 
    155          WRITE(numout,*) '               wave modified ocean stress           ln_tauwoc     = ', ln_tauwoc 
    156          WRITE(numout,*) '               wave modified ocean stress component ln_tauw       = ', ln_tauw 
    157          WRITE(numout,*) '               Stokes coriolis term                 ln_stcor      = ', ln_stcor 
    158          WRITE(numout,*) '               neutral drag coefficient (CORE,NCAR) ln_cdgw       = ', ln_cdgw 
    159       ENDIF 
    160       ! 
    161       IF( .NOT.ln_wave ) THEN 
    162          ln_sdw = .false. ; ln_cdgw = .false. ; ln_tauwoc = .false. ; ln_tauw = .false. ; ln_stcor = .false. 
    163       ENDIF  
    164       IF( ln_sdw ) THEN 
    165          IF( .NOT.(nn_sdrift==jp_breivik_2014 .OR. nn_sdrift==jp_li_2017 .OR. nn_sdrift==jp_peakfr) ) & 
    166             CALL ctl_stop( 'The chosen nn_sdrift for Stokes drift vertical velocity must be 0, 1, or 2' ) 
    167       ENDIF 
    168       ll_st_bv2014  = ( nn_sdrift==jp_breivik_2014 ) 
    169       ll_st_li2017  = ( nn_sdrift==jp_li_2017 ) 
    170       ll_st_bv_li   = ( ll_st_bv2014 .OR. ll_st_li2017 ) 
    171       ll_st_peakfr  = ( nn_sdrift==jp_peakfr ) 
    172       IF( ln_tauwoc .AND. ln_tauw ) & 
    173          CALL ctl_stop( 'More than one method for modifying the ocean stress has been selected ', & 
    174                                   '(ln_tauwoc=.true. and ln_tauw=.true.)' ) 
    175       IF( ln_tauwoc ) & 
    176          CALL ctl_warn( 'You are subtracting the wave stress to the ocean (ln_tauwoc=.true.)' ) 
    177       IF( ln_tauw ) & 
    178          CALL ctl_warn( 'The wave modified ocean stress components are used (ln_tauw=.true.) ', & 
    179                               'This will override any other specification of the ocean stress' ) 
     155      ENDIF 
    180156      ! 
    181157      IF( .NOT.ln_usr ) THEN     ! the model calendar needs some specificities (except in user defined case) 
    … …  
    357333      IF( nn_ice == 3 )   CALL cice_sbc_init( nsbc, Kbb, Kmm )   ! CICE initialization 
    358334      ! 
    359       IF( ln_wave     )   CALL sbc_wave_init                     ! surface wave initialisation 
    360       ! 
    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  
     335      IF( ln_wave     ) THEN 
     336                          CALL sbc_wave_init                     ! surface wave initialisation 
     337      ELSE 
     338                          IF(lwp) WRITE(numout,*) 
     339                          IF(lwp) WRITE(numout,*) '   No surface waves : all wave related logical set to false' 
     340                          ln_sdw       = .false. 
     341                          ln_stcor     = .false. 
     342                          ln_cdgw      = .false. 
     343                          ln_tauoc     = .false. 
     344                          ln_wave_test = .false. 
     345                          ln_charn     = .false. 
     346                          ln_taw       = .false. 
     347                          ln_phioc     = .false. 
     348                          ln_bern_srfc = .false. 
     349                          ln_breivikFV_2016 = .false. 
     350                          ln_vortex_force = .false. 
     351                          ln_stshear  = .false. 
     352      ENDIF 
     353      ! 
    371354   END SUBROUTINE sbc_init 
    372355 
    … …  
    390373      INTEGER, INTENT(in) ::   kt   ! ocean time step 
    391374      INTEGER, INTENT(in) ::   Kbb, Kmm   ! ocean time level indices 
     375      INTEGER  ::   jj, ji          ! dummy loop argument 
    392376      ! 
    393377      LOGICAL ::   ll_sas, ll_opa   ! local logical 
    … …  
    422406      ! 
    423407      IF( .NOT.ll_sas )   CALL sbc_ssm ( kt, Kbb, Kmm )  ! mean ocean sea surface variables (sst_m, sss_m, ssu_m, ssv_m) 
    424       IF( ln_wave     )   CALL sbc_wave( kt, Kmm )       ! surface waves 
    425  
    426408      ! 
    427409      !                                            !==  sbc formulation  ==! 
    428410      !                                                    
     411      ! 
    429412      SELECT CASE( nsbc )                                ! Compute ocean surface boundary condition 
    430413      !                                                  ! (i.e. utau,vtau, qns, qsr, emp, sfx) 
    … …  
    433416      CASE( jp_blk     ) 
    434417         IF( ll_sas    )       CALL sbc_cpl_rcv   ( kt, nn_fsbc, nn_ice, Kbb, Kmm )   ! OPA-SAS coupling: SAS receiving fields from OPA 
     418!!!!!!!!!!! ATTENTION:ln_wave is not only used for oasis coupling !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
     419         IF( ln_wave )   THEN 
     420             IF ( lk_oasis )  CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice, Kbb, Kmm )   ! OPA-wave coupling 
     421             CALL sbc_wave ( kt, Kmm ) 
     422         ENDIF 
    435423                               CALL sbc_blk       ( kt )                    ! bulk formulation for the ocean 
    436424                               ! 
    … …  
    446434      IF( ln_mixcpl )          CALL sbc_cpl_rcv   ( kt, nn_fsbc, nn_ice, Kbb, Kmm )  ! forced-coupled mixed formulation after forcing 
    447435      ! 
    448       IF ( ln_wave .AND. (ln_tauwoc .OR. ln_tauw) ) CALL sbc_wstress( )              ! Wind stress provided by waves  
     436      IF( ln_wave .AND. ln_tauoc )  THEN            ! Wave stress reduction 
     437         DO_2D( 0, 0, 0, 0) 
     438            utau(ji,jj) = utau(ji,jj) * ( tauoc_wave(ji,jj) + tauoc_wave(ji-1,jj) ) * 0.5_wp 
     439            vtau(ji,jj) = vtau(ji,jj) * ( tauoc_wave(ji,jj) + tauoc_wave(ji,jj-1) ) * 0.5_wp 
     440         END_2D 
     441         ! 
     442         CALL lbc_lnk( 'sbcwave', utau, 'U', -1. ) 
     443         CALL lbc_lnk( 'sbcwave', vtau, 'V', -1. ) 
     444         ! 
     445         taum(:,:) = taum(:,:)*tauoc_wave(:,:) 
     446         ! 
     447         IF( kt == nit000 )   CALL ctl_warn( 'sbc: You are subtracting the wave stress to the ocean.',   & 
     448            &                                'If not requested select ln_tauoc=.false.' ) 
     449         ! 
     450      ELSEIF( ln_wave .AND. ln_taw ) THEN                  ! Wave stress reduction 
     451         utau(:,:) = utau(:,:) - tawx(:,:) + twox(:,:) 
     452         vtau(:,:) = vtau(:,:) - tawy(:,:) + twoy(:,:) 
     453         CALL lbc_lnk( 'sbcwave', utau, 'U', -1. ) 
     454         CALL lbc_lnk( 'sbcwave', vtau, 'V', -1. ) 
     455         ! 
     456         DO_2D( 0, 0, 0, 0) 
     457             taum(ji,jj) = sqrt((.5*(utau(ji-1,jj)+utau(ji,jj)))**2 + (.5*(vtau(ji,jj-1)+vtau(ji,jj)))**2) 
     458         END_2D 
     459         ! 
     460         IF( kt == nit000 )   CALL ctl_warn( 'sbc: You are subtracting the wave stress to the ocean.',   & 
     461            &                                'If not requested select ln_taw=.false.' ) 
     462         ! 
     463      ENDIF 
     464      CALL lbc_lnk( 'sbcmod', taum(:,:), 'T', 1. ) 
    449465      ! 
    450466      !                                            !==  Misc. Options  ==! 
    … …  
    459475 
    460476      IF( ln_icebergs    )   THEN 
    461                                      CALL icb_stp( kt )           ! compute icebergs 
     477                                     CALL icb_stp( kt, Kmm )           ! compute icebergs 
    462478         ! Icebergs do not melt over the haloes.  
    463479         ! So emp values over the haloes are no more consistent with the inner domain values.  
    … …  
    510526            & iom_varid( numror, 'utau_b', ldstop = .FALSE. ) > 0 ) THEN 
    511527            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) 
     528            CALL iom_get( numror, jpdom_auto, 'utau_b', utau_b )   ! before i-stress  (U-point) 
     529            CALL iom_get( numror, jpdom_auto, 'vtau_b', vtau_b )   ! before j-stress  (V-point) 
     530            CALL iom_get( numror, jpdom_auto,  'qns_b',  qns_b )   ! before non solar heat flux (T-point) 
    515531            ! 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) 
     532            ! CALL iom_get( numror, jpdom_auto, 'qsr_b' , qsr_b  ) ! before     solar heat flux (T-point) 
     533            CALL iom_get( numror, jpdom_auto, 'emp_b', emp_b  )    ! before     freshwater flux (T-point) 
    518534            ! To ensure restart capability with 3.3x/3.4 restart files    !! to be removed in v3.6 
    519535            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) 
     536               CALL iom_get( numror, jpdom_auto, 'sfx_b', sfx_b )  ! before salt flux (T-point) 
    521537            ELSE 
    522538               sfx_b (:,:) = sfx(:,:) 
    … …  
    538554            &                    'at it= ', kt,' date= ', ndastp 
    539555         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  ) 
     556         CALL iom_rstput( kt, nitrst, numrow, 'utau_b' , utau ) 
     557         CALL iom_rstput( kt, nitrst, numrow, 'vtau_b' , vtau ) 
     558         CALL iom_rstput( kt, nitrst, numrow, 'qns_b'  , qns  ) 
    544559         ! The 3D heat content due to qsr forcing is treated in traqsr 
    545560         ! 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          ) 
     561         CALL iom_rstput( kt, nitrst, numrow, 'emp_b'  , emp  ) 
     562         CALL iom_rstput( kt, nitrst, numrow, 'sfx_b'  , sfx  ) 
    549563      ENDIF 
    550564      !                                                ! ---------------------------------------- ! 

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

    r13497 r14043  
    4242   REAL(wp)                   ::      rn_dep_max        !: depth over which runoffs is spread       (ln_rnf_depth_ini =T) 
    4343   INTEGER                    ::      nn_rnf_depth_file !: create (=1) a runoff depth file or not (=0) 
    44    LOGICAL                   ::   ln_rnf_icb        !: iceberg flux is specified in a file 
     44   LOGICAL           , PUBLIC ::   ln_rnf_icb        !: iceberg flux is specified in a file 
    4545   LOGICAL                    ::   ln_rnf_tem        !: temperature river runoffs attribute specified in a file 
    4646   LOGICAL           , PUBLIC ::   ln_rnf_sal        !: salinity    river runoffs attribute specified in a file 
    … …  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/SBC/sbcssm.F90

    r13286 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/SBC/sbcwave.F90

    r13546 r14043  
    99   !!             -   !  2016-12  (G. Madec, E. Clementi) update Stoke drift computation 
    1010   !!                                                    + add sbc_wave_ini routine 
     11   !!            4.2  !  2020-12  (G. Madec, E. Clementi) updates, new Stoke drift computation  
     12   !!                                                    according to Couvelard et al.,2019 
    1113   !!---------------------------------------------------------------------- 
    1214 
    1315   !!---------------------------------------------------------------------- 
    1416   !!   sbc_stokes    : calculate 3D Stokes-drift velocities 
    15    !!   sbc_wave      : wave data from wave model in netcdf files  
     17   !!   sbc_wave      : wave data from wave model: forced (netcdf files) or coupled mode 
    1618   !!   sbc_wave_init : initialisation fo surface waves  
    1719   !!---------------------------------------------------------------------- 
    18    USE phycst         ! physical constants  
     20   USE phycst         ! physical constants 
    1921   USE oce            ! ocean variables 
    20    USE sbc_oce        ! Surface boundary condition: ocean fields 
    21    USE zdf_oce,  ONLY : ln_zdfswm 
     22   USE dom_oce        ! ocean domain variables 
     23   USE sbc_oce        ! Surface boundary condition: ocean fields 
    2224   USE bdy_oce        ! open boundary condition variables 
    2325   USE domvvl         ! domain: variable volume layers 
    … …  
    2628   USE in_out_manager ! I/O manager 
    2729   USE lib_mpp        ! distribued memory computing library 
    28    USE fldread        ! read input fields 
     30   USE fldread        ! read input fields 
    2931 
    3032   IMPLICIT NONE 
    … …  
    3234 
    3335   PUBLIC   sbc_stokes      ! routine called in sbccpl 
    34    PUBLIC   sbc_wstress     ! routine called in sbcmod  
    3536   PUBLIC   sbc_wave        ! routine called in sbcmod 
    3637   PUBLIC   sbc_wave_init   ! routine called in sbcmod 
    3738    
    3839   ! Variables checking if the wave parameters are coupled (if not, they are read from file) 
    39    LOGICAL, PUBLIC ::   cpl_hsig   = .FALSE. 
    40    LOGICAL, PUBLIC ::   cpl_phioc  = .FALSE. 
    41    LOGICAL, PUBLIC ::   cpl_sdrftx = .FALSE. 
    42    LOGICAL, PUBLIC ::   cpl_sdrfty = .FALSE. 
    43    LOGICAL, PUBLIC ::   cpl_wper   = .FALSE. 
    44    LOGICAL, PUBLIC ::   cpl_wfreq  = .FALSE. 
    45    LOGICAL, PUBLIC ::   cpl_wnum   = .FALSE. 
    46    LOGICAL, PUBLIC ::   cpl_tauwoc = .FALSE. 
    47    LOGICAL, PUBLIC ::   cpl_tauw   = .FALSE. 
    48    LOGICAL, PUBLIC ::   cpl_wdrag  = .FALSE. 
     40   LOGICAL, PUBLIC ::   cpl_hsig          = .FALSE. 
     41   LOGICAL, PUBLIC ::   cpl_phioc         = .FALSE. 
     42   LOGICAL, PUBLIC ::   cpl_sdrftx        = .FALSE. 
     43   LOGICAL, PUBLIC ::   cpl_sdrfty        = .FALSE. 
     44   LOGICAL, PUBLIC ::   cpl_wper          = .FALSE. 
     45   LOGICAL, PUBLIC ::   cpl_wnum          = .FALSE. 
     46   LOGICAL, PUBLIC ::   cpl_wstrf         = .FALSE. 
     47   LOGICAL, PUBLIC ::   cpl_wdrag         = .FALSE. 
     48   LOGICAL, PUBLIC ::   cpl_charn         = .FALSE. 
     49   LOGICAL, PUBLIC ::   cpl_taw           = .FALSE. 
     50   LOGICAL, PUBLIC ::   cpl_bhd           = .FALSE. 
     51   LOGICAL, PUBLIC ::   cpl_tusd          = .FALSE. 
     52   LOGICAL, PUBLIC ::   cpl_tvsd          = .FALSE. 
    4953 
    5054   INTEGER ::   jpfld    ! number of files to read for stokes drift 
    … …  
    5357   INTEGER ::   jp_hsw   ! index of significant wave hight      (m)      at T-point 
    5458   INTEGER ::   jp_wmp   ! index of mean wave period            (s)      at T-point 
    55    INTEGER ::   jp_wfr   ! index of wave peak frequency         (1/s)    at T-point 
    5659 
    5760   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_cd      ! structure of input fields (file informations, fields read) Drag Coefficient 
    5861   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_sd      ! structure of input fields (file informations, fields read) Stokes Drift 
    5962   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_wn      ! structure of input fields (file informations, fields read) wave number for Qiao 
    60    TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_tauwoc  ! structure of input fields (file informations, fields read) normalized wave stress into the ocean 
    61    TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_tauw    ! structure of input fields (file informations, fields read) ocean stress components from wave model 
    62  
    63    REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   cdn_wave            !: 
    64    REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   hsw, wmp, wnum      !:  
    65    REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   wfreq               !:  
    66    REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   tauoc_wave          !:   
    67    REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   tauw_x, tauw_y      !:   
    68    REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   tsd2d               !:  
    69    REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   div_sd              !: barotropic stokes drift divergence 
    70    REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   ut0sd, vt0sd        !: surface Stokes drift velocities at t-point 
    71    REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) ::   usd  , vsd  , wsd   !: Stokes drift velocities at u-, v- & w-points, resp. 
    72  
     63   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_tauoc   ! structure of input fields (file informations, fields read) normalized wave stress into the ocean 
     64 
     65   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   cdn_wave        !: Neutral drag coefficient at t-point 
     66   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   hsw             !: Significant Wave Height at t-point 
     67   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   wmp             !: Wave Mean Period at t-point 
     68   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   wnum            !: Wave Number at t-point 
     69   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   tauoc_wave      !: stress reduction factor  at t-point 
     70   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   tsd2d           !: Surface Stokes Drift module at t-point 
     71   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   div_sd          !: barotropic stokes drift divergence 
     72   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   ut0sd, vt0sd    !: surface Stokes drift velocities at t-point 
     73   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) ::   usd, vsd, wsd   !: Stokes drift velocities at u-, v- & w-points, resp.u 
     74! 
     75   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   charn           !: charnock coefficient at t-point 
     76   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   tawx            !: Net wave-supported stress, u 
     77   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   tawy            !: Net wave-supported stress, v 
     78   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   twox            !: wave-ocean momentum flux, u 
     79   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   twoy            !: wave-ocean momentum flux, v 
     80   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   tauoc_wavex     !: stress reduction factor  at, u component 
     81   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   tauoc_wavey     !: stress reduction factor  at, v component 
     82   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   phioc           !: tke flux from wave model 
     83   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   KZN2            !: Kz*N2 
     84   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   bhd_wave        !: Bernoulli head. wave induce pression 
     85   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:)   ::   tusd, tvsd      !: Stokes drift transport 
     86   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) ::   ZMX             !: Kz*N2 
    7387   !! * Substitutions 
    7488#  include "do_loop_substitute.h90" 
    … …  
    88102      !!                2014 (DOI: 10.1175/JPO-D-14-0020.1) 
    89103      !! 
    90       !! ** Method  : - Calculate Stokes transport speed  
    91       !!              - Calculate horizontal divergence  
    92       !!              - Integrate the horizontal divergenze from the bottom  
    93       !! ** action   
     104      !! ** Method  : - Calculate the horizontal Stokes drift velocity (Breivik et al. 2014) 
     105      !!              - Calculate its horizontal divergence 
     106      !!              - Calculate the vertical Stokes drift velocity 
     107      !!              - Calculate the barotropic Stokes drift divergence 
     108      !! 
     109      !! ** action  : - tsd2d         : module of the surface Stokes drift velocity 
     110      !!              - usd, vsd, wsd : 3 components of the Stokes drift velocity 
     111      !!              - div_sd        : barotropic Stokes drift divergence 
    94112      !!--------------------------------------------------------------------- 
    95113      INTEGER, INTENT(in) :: Kmm ! ocean time level index 
    96114      INTEGER  ::   jj, ji, jk   ! dummy loop argument 
    97115      INTEGER  ::   ik           ! local integer  
    98       REAL(wp) ::  ztransp, zfac, zsp0 
    99       REAL(wp) ::  zdepth, zsqrt_depth,  zexp_depth, z_two_thirds, zsqrtpi !sqrt of pi 
    100       REAL(wp) ::  zbot_u, zbot_v, zkb_u, zkb_v, zke3_u, zke3_v, zda_u, zda_v 
    101       REAL(wp) ::  zstokes_psi_u_bot, zstokes_psi_v_bot 
    102       REAL(wp) ::  zdep_u, zdep_v, zkh_u, zkh_v 
    103       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   zk_t, zk_u, zk_v, zu0_sd, zv0_sd     ! 2D workspace 
    104       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   zstokes_psi_u_top, zstokes_psi_v_top ! 2D workspace 
    105       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ze3divh                              ! 3D workspace 
    106       !!--------------------------------------------------------------------- 
    107       ! 
    108       ALLOCATE( ze3divh(jpi,jpj,jpkm1) )   ! jpkm1 -> avoid lbc_lnk on jpk that is not defined 
     116      REAL(wp) ::  ztransp, zfac, ztemp, zsp0, zsqrt, zbreiv16_w 
     117      REAL(wp) ::  zdep_u, zdep_v, zkh_u, zkh_v, zda_u, zda_v, sdtrp 
     118      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   zk_t, zk_u, zk_v, zu0_sd, zv0_sd ! 2D workspace 
     119      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ze3divh, zInt_w                  ! 3D workspace 
     120      !!--------------------------------------------------------------------- 
     121      ! 
     122      ALLOCATE( ze3divh(jpi,jpj,jpkm1) ) ! jpkm1 -> avoid lbc_lnk on jpk that is not defined 
     123      ALLOCATE( zInt_w(jpi,jpj,jpk) ) 
    109124      ALLOCATE( zk_t(jpi,jpj), zk_u(jpi,jpj), zk_v(jpi,jpj), zu0_sd(jpi,jpj), zv0_sd(jpi,jpj) ) 
     125      zk_t    (:,:) = 0._wp 
     126      zk_u    (:,:) = 0._wp 
     127      zk_v    (:,:) = 0._wp 
     128      zu0_sd  (:,:) = 0._wp 
     129      zv0_sd  (:,:) = 0._wp 
     130      ze3divh (:,:,:) = 0._wp 
     131 
    110132      ! 
    111133      ! select parameterization for the calculation of vertical Stokes drift 
    112134      ! exp. wave number at t-point 
    113       IF( ll_st_bv_li ) THEN   ! (Eq. (19) in Breivik et al. (2014) ) 
     135      IF( ln_breivikFV_2016 ) THEN 
     136      ! Assumptions :  ut0sd and vt0sd are surface Stokes drift at T-points 
     137      !                sdtrp is the norm of Stokes transport 
     138      ! 
     139         zfac = 0.166666666667_wp 
     140         DO_2D( 1, 1, 1, 1 ) ! In the deep-water limit we have ke = ||ust0||/( 6 * ||transport|| ) 
     141            zsp0          = SQRT( ut0sd(ji,jj)*ut0sd(ji,jj) + vt0sd(ji,jj)*vt0sd(ji,jj) ) !<-- norm of Surface Stokes drift 
     142            tsd2d(ji,jj)  = zsp0 
     143            IF( cpl_tusd .AND. cpl_tvsd ) THEN  !stokes transport is provided in coupled mode 
     144               sdtrp      = SQRT( tusd(ji,jj)*tusd(ji,jj) + tvsd(ji,jj)*tvsd(ji,jj) )  !<-- norm of Surface Stokes drift transport 
     145            ELSE  
     146               ! Stokes drift transport estimated from Hs and Tmean  
     147               sdtrp      = 2.0_wp * rpi / 16.0_wp *                             & 
     148                   &        hsw(ji,jj)*hsw(ji,jj) / MAX( wmp(ji,jj), 0.0000001_wp ) 
     149            ENDIF 
     150            zk_t (ji,jj)  = zfac * zsp0 / MAX ( sdtrp, 0.0000001_wp ) !<-- ke = ||ust0||/( 6 * ||transport|| ) 
     151         END_2D 
     152      !# define zInt_w ze3divh 
     153         DO_3D( 1, 1, 1, 1, 1, jpk ) ! Compute the primitive of Breivik 2016 function at W-points 
     154            zfac             = - 2._wp * zk_t (ji,jj) * gdepw(ji,jj,jk,Kmm)  !<-- zfac should be negative definite 
     155            ztemp            = EXP ( zfac ) 
     156            zsqrt            = SQRT( -zfac ) 
     157            zbreiv16_w       = ztemp - SQRT(rpi)*zsqrt*ERFC(zsqrt) !Eq. 16 Breivik 2016 
     158            zInt_w(ji,jj,jk) = ztemp - 4._wp * zk_t (ji,jj) * gdepw(ji,jj,jk,Kmm) * zbreiv16_w 
     159         END_3D 
     160! 
     161         DO jk = 1, jpkm1 
     162            zfac = 0.166666666667_wp 
     163            DO_2D( 1, 1, 1, 1 ) !++ Compute the FV Breivik 2016 function at T-points 
     164               zsp0          = zfac / MAX(zk_t (ji,jj),0.0000001_wp) 
     165               ztemp         = zInt_w(ji,jj,jk) - zInt_w(ji,jj,jk+1) 
     166               zu0_sd(ji,jj) = ut0sd(ji,jj) * zsp0 * ztemp * tmask(ji,jj,jk) 
     167               zv0_sd(ji,jj) = vt0sd(ji,jj) * zsp0 * ztemp * tmask(ji,jj,jk) 
     168            END_2D 
     169            DO_2D( 1, 0, 1, 0 ) ! ++ Interpolate at U/V points 
     170               zfac          =  1.0_wp / e3u(ji  ,jj,jk,Kmm) 
     171               usd(ji,jj,jk) =  0.5_wp * zfac * ( zu0_sd(ji,jj)+zu0_sd(ji+1,jj) ) * umask(ji,jj,jk) 
     172               zfac          =  1.0_wp / e3v(ji  ,jj,jk,Kmm) 
     173               vsd(ji,jj,jk) =  0.5_wp * zfac * ( zv0_sd(ji,jj)+zv0_sd(ji,jj+1) ) * vmask(ji,jj,jk) 
     174            END_2D 
     175         ENDDO 
     176      !# undef zInt_w 
     177      ! 
     178      ELSE 
    114179         zfac = 2.0_wp * rpi / 16.0_wp 
    115180         DO_2D( 1, 1, 1, 1 ) 
    … …  
    128193            zv0_sd(ji,jj) = 0.5_wp * ( vt0sd(ji,jj) + vt0sd(ji,jj+1) ) 
    129194         END_2D 
    130       ELSE IF( ll_st_peakfr ) THEN    ! peak wave number calculated from the peak frequency received by the wave model 
    131          DO_2D( 1, 1, 1, 1 ) 
    132             zk_t(ji,jj) = ( 2.0_wp * rpi * wfreq(ji,jj) ) * ( 2.0_wp * rpi * wfreq(ji,jj) ) / grav 
    133          END_2D 
    134          DO_2D( 1, 0, 1, 0 ) 
    135             zk_u(ji,jj) = 0.5_wp * ( zk_t(ji,jj) + zk_t(ji+1,jj) ) 
    136             zk_v(ji,jj) = 0.5_wp * ( zk_t(ji,jj) + zk_t(ji,jj+1) ) 
    137             ! 
    138             zu0_sd(ji,jj) = 0.5_wp * ( ut0sd(ji,jj) + ut0sd(ji+1,jj) ) 
    139             zv0_sd(ji,jj) = 0.5_wp * ( vt0sd(ji,jj) + vt0sd(ji,jj+1) ) 
    140          END_2D 
    141       ENDIF 
    142       ! 
     195 
    143196      !                       !==  horizontal Stokes Drift 3D velocity  ==! 
    144       IF( ll_st_bv2014 ) THEN 
     197 
    145198         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
    146199            zdep_u = 0.5_wp * ( gdept(ji,jj,jk,Kmm) + gdept(ji+1,jj,jk,Kmm) ) 
    147200            zdep_v = 0.5_wp * ( gdept(ji,jj,jk,Kmm) + gdept(ji,jj+1,jk,Kmm) ) 
    148             !                           
     201            ! 
    149202            zkh_u = zk_u(ji,jj) * zdep_u     ! k * depth 
    150203            zkh_v = zk_v(ji,jj) * zdep_v 
    … …  
    156209            vsd(ji,jj,jk) = zda_v * zv0_sd(ji,jj) * vmask(ji,jj,jk) 
    157210         END_3D 
    158       ELSE IF( ll_st_li2017 .OR. ll_st_peakfr ) THEN 
    159          ALLOCATE( zstokes_psi_u_top(jpi,jpj), zstokes_psi_v_top(jpi,jpj) ) 
    160          DO_2D( 1, 0, 1, 0 ) 
    161             zstokes_psi_u_top(ji,jj) = 0._wp 
    162             zstokes_psi_v_top(ji,jj) = 0._wp 
    163          END_2D 
    164          zsqrtpi = SQRT(rpi) 
    165          z_two_thirds = 2.0_wp / 3.0_wp 
    166          DO_3D( 0, 0, 0, 0, 1, jpkm1 )       ! exp. wave number & Stokes drift velocity at u- & v-points 
    167             zbot_u = ( gdepw(ji,jj,jk+1,Kmm) + gdepw(ji+1,jj,jk+1,Kmm) )  ! 2 * bottom depth 
    168             zbot_v = ( gdepw(ji,jj,jk+1,Kmm) + gdepw(ji,jj+1,jk+1,Kmm) )  ! 2 * bottom depth 
    169             zkb_u  = zk_u(ji,jj) * zbot_u                             ! 2 * k * bottom depth 
    170             zkb_v  = zk_v(ji,jj) * zbot_v                             ! 2 * k * bottom depth 
    171             ! 
    172             zke3_u = MAX(1.e-8_wp, 2.0_wp * zk_u(ji,jj) * e3u(ji,jj,jk,Kmm))     ! 2k * thickness 
    173             zke3_v = MAX(1.e-8_wp, 2.0_wp * zk_v(ji,jj) * e3v(ji,jj,jk,Kmm))     ! 2k * thickness 
    174  
    175             ! Depth attenuation .... do u component first.. 
    176             zdepth      = zkb_u 
    177             zsqrt_depth = SQRT(zdepth) 
    178             zexp_depth  = EXP(-zdepth) 
    179             zstokes_psi_u_bot = 1.0_wp - zexp_depth  & 
    180                  &              - z_two_thirds * ( zsqrtpi*zsqrt_depth*zdepth*ERFC(zsqrt_depth) & 
    181                  &              + 1.0_wp - (1.0_wp + zdepth)*zexp_depth ) 
    182             zda_u                    = ( zstokes_psi_u_bot - zstokes_psi_u_top(ji,jj) ) / zke3_u 
    183             zstokes_psi_u_top(ji,jj) =   zstokes_psi_u_bot 
    184  
    185             !         ... and then v component 
    186             zdepth      =zkb_v 
    187             zsqrt_depth = SQRT(zdepth) 
    188             zexp_depth  = EXP(-zdepth) 
    189             zstokes_psi_v_bot = 1.0_wp - zexp_depth  & 
    190                  &              - z_two_thirds * ( zsqrtpi*zsqrt_depth*zdepth*ERFC(zsqrt_depth) & 
    191                  &              + 1.0_wp - (1.0_wp + zdepth)*zexp_depth ) 
    192             zda_v                    = ( zstokes_psi_v_bot - zstokes_psi_v_top(ji,jj) ) / zke3_v 
    193             zstokes_psi_v_top(ji,jj) =   zstokes_psi_v_bot 
    194             ! 
    195             usd(ji,jj,jk) = zda_u * zu0_sd(ji,jj) * umask(ji,jj,jk) 
    196             vsd(ji,jj,jk) = zda_v * zv0_sd(ji,jj) * vmask(ji,jj,jk) 
    197          END_3D 
    198          DEALLOCATE( zstokes_psi_u_top, zstokes_psi_v_top ) 
    199211      ENDIF 
    200212 
    … …  
    235247      CALL iom_put( "vstokes",  vsd  ) 
    236248      CALL iom_put( "wstokes",  wsd  ) 
    237       ! 
    238       DEALLOCATE( ze3divh ) 
     249!      ! 
     250      DEALLOCATE( ze3divh, zInt_w ) 
    239251      DEALLOCATE( zk_t, zk_u, zk_v, zu0_sd, zv0_sd ) 
    240252      ! 
    241253   END SUBROUTINE sbc_stokes 
    242  
    243  
    244    SUBROUTINE sbc_wstress( ) 
    245       !!--------------------------------------------------------------------- 
    246       !!                     ***  ROUTINE sbc_wstress  *** 
    247       !! 
    248       !! ** Purpose :   Updates the ocean momentum modified by waves 
    249       !! 
    250       !! ** Method  : - Calculate u,v components of stress depending on stress 
    251       !!                model  
    252       !!              - Calculate the stress module 
    253       !!              - The wind module is not modified by waves  
    254       !! ** action   
    255       !!--------------------------------------------------------------------- 
    256       INTEGER  ::   jj, ji   ! dummy loop argument 
    257       ! 
    258       IF( ln_tauwoc ) THEN 
    259          utau(:,:) = utau(:,:)*tauoc_wave(:,:) 
    260          vtau(:,:) = vtau(:,:)*tauoc_wave(:,:) 
    261          taum(:,:) = taum(:,:)*tauoc_wave(:,:) 
    262       ENDIF 
    263       ! 
    264       IF( ln_tauw ) THEN 
    265          DO_2D( 1, 0, 1, 0 ) 
    266             ! Stress components at u- & v-points 
    267             utau(ji,jj) = 0.5_wp * ( tauw_x(ji,jj) + tauw_x(ji+1,jj) ) 
    268             vtau(ji,jj) = 0.5_wp * ( tauw_y(ji,jj) + tauw_y(ji,jj+1) ) 
    269             ! 
    270             ! Stress module at t points 
    271             taum(ji,jj) = SQRT( tauw_x(ji,jj)*tauw_x(ji,jj) + tauw_y(ji,jj)*tauw_y(ji,jj) ) 
    272          END_2D 
    273          CALL lbc_lnk_multi( 'sbcwave', utau(:,:), 'U', -1.0_wp , vtau(:,:), 'V', -1.0_wp , taum(:,:) , 'T', -1.0_wp ) 
    274       ENDIF 
    275       ! 
    276    END SUBROUTINE sbc_wstress 
    277  
    278  
     254! 
     255! 
    279256   SUBROUTINE sbc_wave( kt, Kmm ) 
    280257      !!--------------------------------------------------------------------- 
    281258      !!                     ***  ROUTINE sbc_wave  *** 
    282259      !! 
    283       !! ** Purpose :   read wave parameters from wave model  in netcdf files. 
    284       !! 
    285       !! ** Method  : - Read namelist namsbc_wave 
    286       !!              - Read Cd_n10 fields in netcdf files  
    287       !!              - Read stokes drift 2d in netcdf files  
    288       !!              - Read wave number in netcdf files  
    289       !!              - Compute 3d stokes drift using Breivik et al.,2014 
    290       !!                formulation 
    291       !! ** action   
     260      !! ** Purpose :   read wave parameters from wave model in netcdf files 
     261      !!                or from a coupled wave mdoel 
     262      !! 
    292263      !!--------------------------------------------------------------------- 
    293264      INTEGER, INTENT(in   ) ::   kt   ! ocean time step 
    294265      INTEGER, INTENT(in   ) ::   Kmm  ! ocean time index 
    295266      !!--------------------------------------------------------------------- 
     267      ! 
     268      IF( kt == nit000 .AND. lwp ) THEN 
     269         WRITE(numout,*) 
     270         WRITE(numout,*) 'sbc_wave : update the read waves fields' 
     271         WRITE(numout,*) '~~~~~~~~ ' 
     272      ENDIF 
    296273      ! 
    297274      IF( ln_cdgw .AND. .NOT. cpl_wdrag ) THEN     !==  Neutral drag coefficient  ==! 
    … …  
    300277      ENDIF 
    301278 
    302       IF( ln_tauwoc .AND. .NOT. cpl_tauwoc ) THEN  !==  Wave induced stress  ==! 
    303          CALL fld_read( kt, nn_fsbc, sf_tauwoc )         ! read wave norm stress from external forcing 
    304          tauoc_wave(:,:) = sf_tauwoc(1)%fnow(:,:,1) * tmask(:,:,1) 
    305       ENDIF 
    306  
    307       IF( ln_tauw .AND. .NOT. cpl_tauw ) THEN      !==  Wave induced stress  ==! 
    308          CALL fld_read( kt, nn_fsbc, sf_tauw )           ! read ocean stress components from external forcing (T grid) 
    309          tauw_x(:,:) = sf_tauw(1)%fnow(:,:,1) * tmask(:,:,1) 
    310          tauw_y(:,:) = sf_tauw(2)%fnow(:,:,1) * tmask(:,:,1) 
    311       ENDIF 
    312  
    313       IF( ln_sdw )  THEN                           !==  Computation of the 3d Stokes Drift  ==!  
     279      IF( ln_tauoc .AND. .NOT. cpl_wstrf ) THEN    !==  Wave induced stress  ==! 
     280         CALL fld_read( kt, nn_fsbc, sf_tauoc )          ! read stress reduction factor due to wave from external forcing 
     281         tauoc_wave(:,:) = sf_tauoc(1)%fnow(:,:,1) * tmask(:,:,1) 
     282      ELSEIF ( ln_taw .AND. cpl_taw ) THEN 
     283         IF (kt < 1) THEN ! The first fields gave by OASIS have very high erroneous values .... 
     284            twox(:,:)=0._wp 
     285            twoy(:,:)=0._wp 
     286            tawx(:,:)=0._wp 
     287            tawy(:,:)=0._wp 
     288            tauoc_wavex(:,:) = 1._wp 
     289            tauoc_wavey(:,:) = 1._wp 
     290         ELSE 
     291            tauoc_wavex(:,:) = abs(twox(:,:)/tawx(:,:)) 
     292            tauoc_wavey(:,:) = abs(twoy(:,:)/tawy(:,:)) 
     293         ENDIF 
     294      ENDIF 
     295 
     296      IF ( ln_phioc .and. cpl_phioc .and.  kt == nit000 ) THEN 
     297         WRITE(numout,*) 
     298         WRITE(numout,*) 'sbc_wave : PHIOC from wave model' 
     299         WRITE(numout,*) '~~~~~~~~ ' 
     300      ENDIF 
     301 
     302      IF( ln_sdw .AND. .NOT. cpl_sdrftx)  THEN       !==  Computation of the 3d Stokes Drift  ==!  
    314303         ! 
    315304         IF( jpfld > 0 ) THEN                            ! Read from file only if the field is not coupled 
    316305            CALL fld_read( kt, nn_fsbc, sf_sd )          ! read wave parameters from external forcing 
     306            !                                            ! NB: test case mode, not read as jpfld=0 
    317307            IF( jp_hsw > 0 )   hsw  (:,:) = sf_sd(jp_hsw)%fnow(:,:,1) * tmask(:,:,1)  ! significant wave height 
    318308            IF( jp_wmp > 0 )   wmp  (:,:) = sf_sd(jp_wmp)%fnow(:,:,1) * tmask(:,:,1)  ! wave mean period 
    319             IF( jp_wfr > 0 )   wfreq(:,:) = sf_sd(jp_wfr)%fnow(:,:,1) * tmask(:,:,1)  ! Peak wave frequency 
    320309            IF( jp_usd > 0 )   ut0sd(:,:) = sf_sd(jp_usd)%fnow(:,:,1) * tmask(:,:,1)  ! 2D zonal Stokes Drift at T point 
    321310            IF( jp_vsd > 0 )   vt0sd(:,:) = sf_sd(jp_vsd)%fnow(:,:,1) * tmask(:,:,1)  ! 2D meridional Stokes Drift at T point 
    322311         ENDIF 
    323312         ! 
    324          ! Read also wave number if needed, so that it is available in coupling routines 
    325          IF( ln_zdfswm .AND. .NOT.cpl_wnum ) THEN 
    326             CALL fld_read( kt, nn_fsbc, sf_wn )          ! read wave parameters from external forcing 
    327             wnum(:,:) = sf_wn(1)%fnow(:,:,1) * tmask(:,:,1) 
    328          ENDIF 
    329             
    330          ! Calculate only if required fields have been read 
    331          ! In coupled wave model-NEMO case the call is done after coupling 
     313         IF( jpfld == 4 .OR. ln_wave_test )   & 
     314            &      CALL sbc_stokes( Kmm )                 ! Calculate only if all required fields are read 
     315            !                                            ! or in wave test case 
     316         !  !                                            ! In coupled case the call is done after (in sbc_cpl) 
     317      ENDIF 
    332318         ! 
    333          IF( ( ll_st_bv_li   .AND. jp_hsw>0 .AND. jp_wmp>0 .AND. jp_usd>0 .AND. jp_vsd>0 ) .OR. & 
    334            & ( ll_st_peakfr  .AND. jp_wfr>0 .AND. jp_usd>0 .AND. jp_vsd>0                ) ) CALL sbc_stokes( Kmm ) 
    335          ! 
    336       ENDIF 
    337       ! 
    338319   END SUBROUTINE sbc_wave 
    339320 
    … …  
    343324      !!                     ***  ROUTINE sbc_wave_init  *** 
    344325      !! 
    345       !! ** Purpose :   read wave parameters from wave model  in netcdf files. 
     326      !! ** Purpose :   Initialisation fo surface waves 
    346327      !! 
    347328      !! ** Method  : - Read namelist namsbc_wave 
    348       !!              - Read Cd_n10 fields in netcdf files  
    349       !!              - Read stokes drift 2d in netcdf files  
    350       !!              - Read wave number in netcdf files  
    351       !!              - Compute 3d stokes drift using Breivik et al.,2014 
    352       !!                formulation 
     329      !!              - create the structure used to read required wave fields 
     330      !!                (its size depends on namelist options) 
    353331      !! ** action   
    354332      !!--------------------------------------------------------------------- 
    … …  
    357335      !! 
    358336      CHARACTER(len=100)     ::  cn_dir                            ! Root directory for location of drag coefficient files 
    359       TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) ::   slf_i, slf_j     ! array of namelist informations on the fields to read 
     337      TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) ::   slf_i            ! array of namelist informations on the fields to read 
    360338      TYPE(FLD_N)            ::  sn_cdg, sn_usd, sn_vsd,  & 
    361                              &   sn_hsw, sn_wmp, sn_wfr, sn_wnum, & 
    362                              &   sn_tauwoc, sn_tauwx, sn_tauwy     ! informations about the fields to be read 
    363       ! 
    364       NAMELIST/namsbc_wave/  sn_cdg, cn_dir, sn_usd, sn_vsd, sn_hsw, sn_wmp, sn_wfr, & 
    365                              sn_wnum, sn_tauwoc, sn_tauwx, sn_tauwy 
    366       !!--------------------------------------------------------------------- 
     339                             &   sn_hsw, sn_wmp, sn_wnum, sn_tauoc    ! informations about the fields to be read 
     340      ! 
     341      NAMELIST/namsbc_wave/ cn_dir, sn_cdg, sn_usd, sn_vsd, sn_hsw, sn_wmp, sn_wnum, sn_tauoc,   & 
     342         &                  ln_cdgw, ln_sdw, ln_tauoc, ln_stcor, ln_charn, ln_taw, ln_phioc,     & 
     343         &                  ln_wave_test, ln_bern_srfc, ln_breivikFV_2016, ln_vortex_force, ln_stshear 
     344      !!--------------------------------------------------------------------- 
     345      IF(lwp) THEN 
     346         WRITE(numout,*) 
     347         WRITE(numout,*) 'sbc_wave_init : surface waves in the system' 
     348         WRITE(numout,*) '~~~~~~~~~~~~~ ' 
     349      ENDIF 
    367350      ! 
    368351      READ  ( numnam_ref, namsbc_wave, IOSTAT = ios, ERR = 901) 
    369 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_wave in reference namelist' ) 
    370           
     352901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_wave in reference namelist') 
     353 
    371354      READ  ( numnam_cfg, namsbc_wave, IOSTAT = ios, ERR = 902 ) 
    372355902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_wave in configuration namelist' ) 
    373356      IF(lwm) WRITE ( numond, namsbc_wave ) 
    374357      ! 
    375       IF( ln_cdgw ) THEN 
    376          IF( .NOT. cpl_wdrag ) THEN 
    377             ALLOCATE( sf_cd(1), STAT=ierror )               !* allocate and fill sf_wave with sn_cdg 
    378             IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure' ) 
     358      IF(lwp) THEN 
     359         WRITE(numout,*) '   Namelist namsbc_wave' 
     360         WRITE(numout,*) '      Stokes drift                                  ln_sdw = ', ln_sdw 
     361         WRITE(numout,*) '      Breivik 2016                       ln_breivikFV_2016 = ', ln_breivikFV_2016 
     362         WRITE(numout,*) '      Stokes Coriolis & tracer advection terms    ln_stcor = ', ln_stcor 
     363         WRITE(numout,*) '      Vortex Force                         ln_vortex_force = ', ln_vortex_force 
     364         WRITE(numout,*) '      Bernouilli Head Pressure                ln_bern_srfc = ', ln_bern_srfc 
     365         WRITE(numout,*) '      wave modified ocean stress                  ln_tauoc = ', ln_tauoc 
     366         WRITE(numout,*) '      neutral drag coefficient (CORE bulk only)    ln_cdgw = ', ln_cdgw 
     367         WRITE(numout,*) '      charnock coefficient                        ln_charn = ', ln_charn 
     368         WRITE(numout,*) '      Stress modificated by wave                    ln_taw = ', ln_taw 
     369         WRITE(numout,*) '      TKE flux from wave                          ln_phioc = ', ln_phioc 
     370         WRITE(numout,*) '      Surface shear with Stokes drift           ln_stshear = ', ln_stshear 
     371         WRITE(numout,*) '      Test with constant wave fields          ln_wave_test = ', ln_wave_test 
     372      ENDIF 
     373 
     374      !                                ! option check 
     375      IF( .NOT.( ln_cdgw .OR. ln_sdw .OR. ln_tauoc .OR. ln_stcor .OR. ln_charn) )   & 
     376         &     CALL ctl_warn( 'Ask for wave coupling but ln_cdgw=F, ln_sdw=F, ln_tauoc=F, ln_stcor=F') 
     377      IF( ln_cdgw .AND. ln_blk )   & 
     378         &     CALL ctl_stop( 'drag coefficient read from wave model NOT available yet with aerobulk package') 
     379      IF( ln_stcor .AND. .NOT.ln_sdw )   & 
     380         &     CALL ctl_stop( 'Stokes-Coriolis term calculated only if activated Stokes Drift ln_sdw=T') 
     381 
     382      !                             !==  Allocate wave arrays  ==! 
     383      ALLOCATE( ut0sd (jpi,jpj)    , vt0sd (jpi,jpj) ) 
     384      ALLOCATE( hsw   (jpi,jpj)    , wmp   (jpi,jpj) ) 
     385      ALLOCATE( wnum  (jpi,jpj) ) 
     386      ALLOCATE( tsd2d (jpi,jpj)    , div_sd(jpi,jpj)    , bhd_wave(jpi,jpj)     ) 
     387      ALLOCATE( usd   (jpi,jpj,jpk), vsd   (jpi,jpj,jpk), wsd     (jpi,jpj,jpk) ) 
     388      ALLOCATE( tusd  (jpi,jpj)    , tvsd  (jpi,jpj)    , ZMX     (jpi,jpj,jpk) ) 
     389      usd   (:,:,:) = 0._wp 
     390      vsd   (:,:,:) = 0._wp 
     391      wsd   (:,:,:) = 0._wp 
     392      hsw     (:,:) = 0._wp 
     393      wmp     (:,:) = 0._wp 
     394      ut0sd   (:,:) = 0._wp 
     395      vt0sd   (:,:) = 0._wp 
     396      tusd    (:,:) = 0._wp 
     397      tvsd    (:,:) = 0._wp 
     398      bhd_wave(:,:) = 0._wp 
     399      ZMX   (:,:,:) = 0._wp 
     400! 
     401      IF( ln_wave_test ) THEN       !==  Wave TEST case  ==!   set uniform waves fields 
     402         jpfld    = 0                   ! No field read 
     403         ln_cdgw  = .FALSE.             ! No neutral wave drag input 
     404         ln_tauoc = .FALSE.             ! No wave induced drag reduction factor 
     405         ut0sd(:,:) = 0.13_wp * tmask(:,:,1)   ! m/s 
     406         vt0sd(:,:) = 0.00_wp                  ! m/s 
     407         hsw  (:,:) = 2.80_wp                  ! meters 
     408         wmp  (:,:) = 8.00_wp                  ! seconds 
     409         ! 
     410      ELSE                          !==  create the structure associated with fields to be read  ==! 
     411         IF( ln_cdgw ) THEN                       ! wave drag 
     412            IF( .NOT. cpl_wdrag ) THEN 
     413               ALLOCATE( sf_cd(1), STAT=ierror )               !* allocate and fill sf_wave with sn_cdg 
     414               IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure' ) 
     415               ! 
     416                                      ALLOCATE( sf_cd(1)%fnow(jpi,jpj,1)   ) 
     417               IF( sn_cdg%ln_tint )   ALLOCATE( sf_cd(1)%fdta(jpi,jpj,1,2) ) 
     418               CALL fld_fill( sf_cd, (/ sn_cdg /), cn_dir, 'sbc_wave_init', 'Wave module ', 'namsbc_wave' ) 
     419            ENDIF 
     420            ALLOCATE( cdn_wave(jpi,jpj) ) 
     421            cdn_wave(:,:) = 0._wp 
     422         ENDIF 
     423         IF( ln_charn ) THEN                     ! wave drag 
     424            IF( .NOT. cpl_charn ) THEN 
     425               CALL ctl_stop( 'STOP', 'Charnock based wind stress can be used in coupled mode only' ) 
     426            ENDIF 
     427            ALLOCATE( charn(jpi,jpj) ) 
     428            charn(:,:) = 0._wp 
     429         ENDIF 
     430         IF( ln_taw ) THEN                     ! wind stress 
     431            IF( .NOT. cpl_taw ) THEN 
     432               CALL ctl_stop( 'STOP', 'wind stress from wave model can be used in coupled mode only, use ln_cdgw instead' ) 
     433            ENDIF 
     434            ALLOCATE( tawx(jpi,jpj) ) 
     435            ALLOCATE( tawy(jpi,jpj) ) 
     436            ALLOCATE( twox(jpi,jpj) ) 
     437            ALLOCATE( twoy(jpi,jpj) ) 
     438            ALLOCATE( tauoc_wavex(jpi,jpj) ) 
     439            ALLOCATE( tauoc_wavey(jpi,jpj) ) 
     440            tawx(:,:) = 0._wp 
     441            tawy(:,:) = 0._wp 
     442            twox(:,:) = 0._wp 
     443            twoy(:,:) = 0._wp 
     444            tauoc_wavex(:,:) = 1._wp 
     445            tauoc_wavey(:,:) = 1._wp 
     446         ENDIF 
     447 
     448         IF( ln_phioc ) THEN                     ! TKE flux 
     449            IF( .NOT. cpl_phioc ) THEN 
     450                CALL ctl_stop( 'STOP', 'phioc can be used in coupled mode only' ) 
     451            ENDIF 
     452            ALLOCATE( phioc(jpi,jpj) ) 
     453            phioc(:,:) = 0._wp 
     454         ENDIF 
     455 
     456         IF( ln_tauoc ) THEN                    ! normalized wave stress into the ocean 
     457            IF( .NOT. cpl_wstrf ) THEN 
     458               ALLOCATE( sf_tauoc(1), STAT=ierror )           !* allocate and fill sf_wave with sn_tauoc 
     459               IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_tauoc structure' ) 
     460               ! 
     461                                       ALLOCATE( sf_tauoc(1)%fnow(jpi,jpj,1)   ) 
     462               IF( sn_tauoc%ln_tint )  ALLOCATE( sf_tauoc(1)%fdta(jpi,jpj,1,2) ) 
     463               CALL fld_fill( sf_tauoc, (/ sn_tauoc /), cn_dir, 'sbc_wave_init', 'Wave module', 'namsbc_wave' ) 
     464            ENDIF 
     465            ALLOCATE( tauoc_wave(jpi,jpj) ) 
     466            tauoc_wave(:,:) = 0._wp 
     467         ENDIF 
     468 
     469         IF( ln_sdw ) THEN                      ! Stokes drift 
     470            ! 1. Find out how many fields have to be read from file if not coupled 
     471            jpfld=0 
     472            jp_usd=0   ;   jp_vsd=0   ;   jp_hsw=0   ;   jp_wmp=0 
     473            IF( .NOT. cpl_sdrftx ) THEN 
     474               jpfld  = jpfld + 1 
     475               jp_usd = jpfld 
     476            ENDIF 
     477            IF( .NOT. cpl_sdrfty ) THEN 
     478               jpfld  = jpfld + 1 
     479               jp_vsd = jpfld 
     480            ENDIF 
     481            IF( .NOT. cpl_hsig ) THEN 
     482               jpfld  = jpfld + 1 
     483               jp_hsw = jpfld 
     484            ENDIF 
     485            IF( .NOT. cpl_wper ) THEN 
     486               jpfld  = jpfld + 1 
     487               jp_wmp = jpfld 
     488            ENDIF 
     489            ! 2. Read from file only the non-coupled fields  
     490            IF( jpfld > 0 ) THEN 
     491               ALLOCATE( slf_i(jpfld) ) 
     492               IF( jp_usd > 0 )   slf_i(jp_usd) = sn_usd 
     493               IF( jp_vsd > 0 )   slf_i(jp_vsd) = sn_vsd 
     494               IF( jp_hsw > 0 )   slf_i(jp_hsw) = sn_hsw 
     495               IF( jp_wmp > 0 )   slf_i(jp_wmp) = sn_wmp 
     496               ALLOCATE( sf_sd(jpfld), STAT=ierror )   !* allocate and fill sf_sd with stokes drift 
     497               IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure' ) 
     498               ! 
     499               DO ifpr= 1, jpfld 
     500                  ALLOCATE( sf_sd(ifpr)%fnow(jpi,jpj,1) ) 
     501                  IF( slf_i(ifpr)%ln_tint )   ALLOCATE( sf_sd(ifpr)%fdta(jpi,jpj,1,2) ) 
     502               END DO 
     503               ! 
     504               CALL fld_fill( sf_sd, slf_i, cn_dir, 'sbc_wave_init', 'Wave module ', 'namsbc_wave' ) 
     505            ENDIF 
    379506            ! 
    380                                    ALLOCATE( sf_cd(1)%fnow(jpi,jpj,1)   ) 
    381             IF( sn_cdg%ln_tint )   ALLOCATE( sf_cd(1)%fdta(jpi,jpj,1,2) ) 
    382             CALL fld_fill( sf_cd, (/ sn_cdg /), cn_dir, 'sbc_wave_init', 'Wave module ', 'namsbc_wave' ) 
    383          ENDIF 
    384          ALLOCATE( cdn_wave(jpi,jpj) ) 
    385       ENDIF 
    386  
    387       IF( ln_tauwoc ) THEN 
    388          IF( .NOT. cpl_tauwoc ) THEN 
    389             ALLOCATE( sf_tauwoc(1), STAT=ierror )           !* allocate and fill sf_wave with sn_tauwoc 
    390             IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure' ) 
     507            ! 3. Wave number (only needed for Qiao parametrisation, ln_zdfqiao=T) 
     508            IF( .NOT. cpl_wnum ) THEN 
     509               ALLOCATE( sf_wn(1), STAT=ierror )           !* allocate and fill sf_wave with sn_wnum 
     510               IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wn structure' ) 
     511                                      ALLOCATE( sf_wn(1)%fnow(jpi,jpj,1)   ) 
     512               IF( sn_wnum%ln_tint )  ALLOCATE( sf_wn(1)%fdta(jpi,jpj,1,2) ) 
     513               CALL fld_fill( sf_wn, (/ sn_wnum /), cn_dir, 'sbc_wave', 'Wave module', 'namsbc_wave' ) 
     514            ENDIF 
    391515            ! 
    392                                      ALLOCATE( sf_tauwoc(1)%fnow(jpi,jpj,1)   ) 
    393             IF( sn_tauwoc%ln_tint )  ALLOCATE( sf_tauwoc(1)%fdta(jpi,jpj,1,2) ) 
    394             CALL fld_fill( sf_tauwoc, (/ sn_tauwoc /), cn_dir, 'sbc_wave_init', 'Wave module', 'namsbc_wave' ) 
    395          ENDIF 
    396          ALLOCATE( tauoc_wave(jpi,jpj) ) 
    397       ENDIF 
    398  
    399       IF( ln_tauw ) THEN 
    400          IF( .NOT. cpl_tauw ) THEN 
    401             ALLOCATE( sf_tauw(2), STAT=ierror )           !* allocate and fill sf_wave with sn_tauwx/y 
    402             IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_tauw structure' ) 
    403             ! 
    404             ALLOCATE( slf_j(2) ) 
    405             slf_j(1) = sn_tauwx 
    406             slf_j(2) = sn_tauwy 
    407                                     ALLOCATE( sf_tauw(1)%fnow(jpi,jpj,1)   ) 
    408                                     ALLOCATE( sf_tauw(2)%fnow(jpi,jpj,1)   ) 
    409             IF( slf_j(1)%ln_tint )  ALLOCATE( sf_tauw(1)%fdta(jpi,jpj,1,2) ) 
    410             IF( slf_j(2)%ln_tint )  ALLOCATE( sf_tauw(2)%fdta(jpi,jpj,1,2) ) 
    411             CALL fld_fill( sf_tauw, (/ slf_j /), cn_dir, 'sbc_wave_init', 'read wave input', 'namsbc_wave' ) 
    412          ENDIF 
    413          ALLOCATE( tauw_x(jpi,jpj) ) 
    414          ALLOCATE( tauw_y(jpi,jpj) ) 
    415       ENDIF 
    416  
    417       IF( ln_sdw ) THEN   ! Find out how many fields have to be read from file if not coupled 
    418          jpfld=0 
    419          jp_usd=0   ;   jp_vsd=0   ;   jp_hsw=0   ;   jp_wmp=0   ;   jp_wfr=0 
    420          IF( .NOT. cpl_sdrftx ) THEN 
    421             jpfld  = jpfld + 1 
    422             jp_usd = jpfld 
    423          ENDIF 
    424          IF( .NOT. cpl_sdrfty ) THEN 
    425             jpfld  = jpfld + 1 
    426             jp_vsd = jpfld 
    427          ENDIF 
    428          IF( .NOT. cpl_hsig  .AND. ll_st_bv_li  ) THEN 
    429             jpfld  = jpfld + 1 
    430             jp_hsw = jpfld 
    431          ENDIF 
    432          IF( .NOT. cpl_wper  .AND. ll_st_bv_li  ) THEN 
    433             jpfld  = jpfld + 1 
    434             jp_wmp = jpfld 
    435          ENDIF 
    436          IF( .NOT. cpl_wfreq .AND. ll_st_peakfr ) THEN 
    437             jpfld  = jpfld + 1 
    438             jp_wfr = jpfld 
    439          ENDIF 
    440  
    441          ! Read from file only the non-coupled fields  
    442          IF( jpfld > 0 ) THEN 
    443             ALLOCATE( slf_i(jpfld) ) 
    444             IF( jp_usd > 0 )   slf_i(jp_usd) = sn_usd 
    445             IF( jp_vsd > 0 )   slf_i(jp_vsd) = sn_vsd 
    446             IF( jp_hsw > 0 )   slf_i(jp_hsw) = sn_hsw 
    447             IF( jp_wmp > 0 )   slf_i(jp_wmp) = sn_wmp 
    448             IF( jp_wfr > 0 )   slf_i(jp_wfr) = sn_wfr 
    449  
    450             ALLOCATE( sf_sd(jpfld), STAT=ierror )   !* allocate and fill sf_sd with stokes drift 
    451             IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure' ) 
    452             ! 
    453             DO ifpr= 1, jpfld 
    454                ALLOCATE( sf_sd(ifpr)%fnow(jpi,jpj,1) ) 
    455                IF( slf_i(ifpr)%ln_tint )   ALLOCATE( sf_sd(ifpr)%fdta(jpi,jpj,1,2) ) 
    456             END DO 
    457             ! 
    458             CALL fld_fill( sf_sd, slf_i, cn_dir, 'sbc_wave_init', 'Wave module ', 'namsbc_wave' ) 
    459          ENDIF 
    460          ALLOCATE( usd  (jpi,jpj,jpk), vsd  (jpi,jpj,jpk), wsd(jpi,jpj,jpk) ) 
    461          ALLOCATE( hsw  (jpi,jpj)    , wmp  (jpi,jpj)     ) 
    462          ALLOCATE( wfreq(jpi,jpj) ) 
    463          ALLOCATE( ut0sd(jpi,jpj)    , vt0sd(jpi,jpj)     ) 
    464          ALLOCATE( div_sd(jpi,jpj) ) 
    465          ALLOCATE( tsd2d (jpi,jpj) ) 
    466  
    467          ut0sd(:,:) = 0._wp 
    468          vt0sd(:,:) = 0._wp 
    469          hsw(:,:) = 0._wp 
    470          wmp(:,:) = 0._wp 
    471  
    472          usd(:,:,:) = 0._wp 
    473          vsd(:,:,:) = 0._wp 
    474          wsd(:,:,:) = 0._wp 
    475          ! Wave number needed only if ln_zdfswm=T 
    476          IF( .NOT. cpl_wnum ) THEN 
    477             ALLOCATE( sf_wn(1), STAT=ierror )           !* allocate and fill sf_wave with sn_wnum 
    478             IF( ierror > 0 )   CALL ctl_stop( 'STOP', 'sbc_wave_init: unable toallocate sf_wave structure' ) 
    479                                    ALLOCATE( sf_wn(1)%fnow(jpi,jpj,1)   ) 
    480             IF( sn_wnum%ln_tint )  ALLOCATE( sf_wn(1)%fdta(jpi,jpj,1,2) ) 
    481             CALL fld_fill( sf_wn, (/ sn_wnum /), cn_dir, 'sbc_wave', 'Wave module', 'namsbc_wave' ) 
    482          ENDIF 
    483          ALLOCATE( wnum(jpi,jpj) ) 
     516         ENDIF 
     517         ! 
    484518      ENDIF 
    485519      ! 

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

    r13497 r14043  
    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 
    … …  
    5556   !                  !! * Interface 
    5657   INTERFACE eos 
    57       MODULE PROCEDURE eos_insitu, eos_insitu_pot, eos_insitu_2d 
     58      MODULE PROCEDURE eos_insitu, eos_insitu_pot, eos_insitu_2d, eos_insitu_pot_2d 
    5859   END INTERFACE 
    5960   ! 
    … …  
    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 
     576 
     577 
     578   SUBROUTINE eos_insitu_pot_2d( pts, prhop ) 
     579      !!---------------------------------------------------------------------- 
     580      !!                  ***  ROUTINE eos_insitu_pot  *** 
     581      !! 
     582      !! ** Purpose :   Compute the in situ density (ratio rho/rho0) and the 
     583      !!      potential volumic mass (Kg/m3) from potential temperature and 
     584      !!      salinity fields using an equation of state selected in the 
     585      !!     namelist. 
     586      !! 
     587      !! ** Action  : 
     588      !!              - prhop, the potential volumic mass (Kg/m3) 
     589      !! 
     590      !!---------------------------------------------------------------------- 
     591      REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in   ) ::   pts    ! 1 : potential temperature  [Celsius] 
     592      !                                                                ! 2 : salinity               [psu] 
     593      REAL(wp), DIMENSION(jpi,jpj     ), INTENT(  out) ::   prhop  ! potential density (surface referenced) 
     594      ! 
     595      INTEGER  ::   ji, jj, jk, jsmp             ! dummy loop indices 
     596      INTEGER  ::   jdof 
     597      REAL(wp) ::   zt , zh , zstemp, zs , ztm   ! local scalars 
     598      REAL(wp) ::   zn , zn0, zn1, zn2, zn3      !   -      - 
     599      REAL(wp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign    ! local vectors 
     600      !!---------------------------------------------------------------------- 
     601      ! 
     602      IF( ln_timing )   CALL timing_start('eos-pot') 
     603      ! 
     604      SELECT CASE ( neos ) 
     605      ! 
     606      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
     607         ! 
     608            DO_2D( 1, 1, 1, 1 ) 
     609               ! 
     610               zt  = pts (ji,jj,jp_tem) * r1_T0                           ! temperature 
     611               zs  = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
     612               ztm = tmask(ji,jj,1)                                         ! tmask 
     613               ! 
     614               zn0 = (((((EOS060*zt   & 
     615                  &   + EOS150*zs+EOS050)*zt   & 
     616                  &   + (EOS240*zs+EOS140)*zs+EOS040)*zt   & 
     617                  &   + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt   & 
     618                  &   + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt   & 
     619                  &   + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt   & 
     620                  &   + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 
     621                  ! 
     622               ! 
     623               prhop(ji,jj) = zn0 * ztm                           ! potential density referenced at the surface 
     624               ! 
     625            END_2D 
     626 
     627      CASE( np_seos )                !==  simplified EOS  ==! 
     628         ! 
     629         DO_2D( 1, 1, 1, 1 ) 
     630            zt  = pts  (ji,jj,jp_tem) - 10._wp 
     631            zs  = pts  (ji,jj,jp_sal) - 35._wp 
     632            ztm = tmask(ji,jj,1) 
     633            !                                                     ! potential density referenced at the surface 
     634            zn =  - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt ) * zt   & 
     635               &  + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs ) * zs   & 
     636               &  - rn_nu * zt * zs 
     637            prhop(ji,jj) = ( rho0 + zn ) * ztm 
     638            ! 
     639         END_2D 
     640         ! 
     641      END SELECT 
     642      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab2d_1=prhop, clinfo1=' pot: ', kdim=1 ) 
     643      ! 
     644      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab2d_1=prhop, clinfo1=' eos-pot: ' ) 
     645      ! 
     646      IF( ln_timing )   CALL timing_stop('eos-pot') 
     647      ! 
     648   END SUBROUTINE eos_insitu_pot_2d 
    538649 
    539650 
    540651   SUBROUTINE rab_3d( pts, pab, Kmm ) 
     652      !! 
     653      INTEGER                     , INTENT(in   ) ::   Kmm   ! time level index 
     654      REAL(wp), DIMENSION(:,:,:,:), INTENT(in   ) ::   pts   ! pot. temperature & salinity 
     655      REAL(wp), DIMENSION(:,:,:,:), INTENT(  out) ::   pab   ! thermal/haline expansion ratio 
     656      !! 
     657      CALL rab_3d_t( pts, is_tile(pts), pab, is_tile(pab), Kmm ) 
     658   END SUBROUTINE rab_3d 
     659 
     660 
     661   SUBROUTINE rab_3d_t( pts, ktts, pab, ktab, Kmm ) 
    541662      !!---------------------------------------------------------------------- 
    542663      !!                 ***  ROUTINE rab_3d  *** 
    … …  
    548669      !! ** Action  : - pab     : thermal/haline expansion ratio at T-points 
    549670      !!---------------------------------------------------------------------- 
    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 
     671      INTEGER                                , INTENT(in   ) ::   Kmm   ! time level index 
     672      INTEGER                                , INTENT(in   ) ::   ktts, ktab 
     673      REAL(wp), DIMENSION(A2D_T(ktts),JPK,JPTS), INTENT(in   ) ::   pts   ! pot. temperature & salinity 
     674      REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT(  out) ::   pab   ! thermal/haline expansion ratio 
    553675      ! 
    554676      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
    … …  
    563685      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    564686         ! 
    565          DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     687         DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    566688            ! 
    567689            zh  = gdept(ji,jj,jk,Kmm) * r1_Z0                                ! depth 
    … …  
    616738      CASE( np_seos )                  !==  simplified EOS  ==! 
    617739         ! 
    618          DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     740         DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    619741            zt  = pts (ji,jj,jk,jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0) 
    620742            zs  = pts (ji,jj,jk,jp_sal) - 35._wp   ! abs. salinity anomaly (s-S0) 
    … …  
    641763      IF( ln_timing )   CALL timing_stop('rab_3d') 
    642764      ! 
    643    END SUBROUTINE rab_3d 
     765   END SUBROUTINE rab_3d_t 
    644766 
    645767 
    646768   SUBROUTINE rab_2d( pts, pdep, pab, Kmm ) 
     769      !! 
     770      INTEGER                   , INTENT(in   ) ::   Kmm   ! time level index 
     771      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pts    ! pot. temperature & salinity 
     772      REAL(wp), DIMENSION(:,:)  , INTENT(in   ) ::   pdep   ! depth                  [m] 
     773      REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   pab    ! thermal/haline expansion ratio 
     774      !! 
     775      CALL rab_2d_t(pts, is_tile(pts), pdep, is_tile(pdep), pab, is_tile(pab), Kmm) 
     776   END SUBROUTINE rab_2d 
     777 
     778 
     779   SUBROUTINE rab_2d_t( pts, ktts, pdep, ktdep, pab, ktab, Kmm ) 
    647780      !!---------------------------------------------------------------------- 
    648781      !!                 ***  ROUTINE rab_2d  *** 
    … …  
    652785      !! ** Action  : - pab     : thermal/haline expansion ratio at T-points 
    653786      !!---------------------------------------------------------------------- 
    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 
     787      INTEGER                            , INTENT(in   ) ::   Kmm   ! time level index 
     788      INTEGER                            , INTENT(in   ) ::   ktts, ktdep, ktab 
     789      REAL(wp), DIMENSION(A2D_T(ktts),JPTS), INTENT(in   ) ::   pts    ! pot. temperature & salinity 
     790      REAL(wp), DIMENSION(A2D_T(ktdep)    ), INTENT(in   ) ::   pdep   ! depth                  [m] 
     791      REAL(wp), DIMENSION(A2D_T(ktab),JPTS), INTENT(  out) ::   pab    ! thermal/haline expansion ratio 
    658792      ! 
    659793      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
    … …  
    670804      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    671805         ! 
    672          DO_2D( 1, 1, 1, 1 ) 
     806         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    673807            ! 
    674808            zh  = pdep(ji,jj) * r1_Z0                                  ! depth 
    … …  
    723857      CASE( np_seos )                  !==  simplified EOS  ==! 
    724858         ! 
    725          DO_2D( 1, 1, 1, 1 ) 
     859         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    726860            ! 
    727861            zt    = pts  (ji,jj,jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0) 
    … …  
    748882      IF( ln_timing )   CALL timing_stop('rab_2d') 
    749883      ! 
    750    END SUBROUTINE rab_2d 
     884   END SUBROUTINE rab_2d_t 
    751885 
    752886 
    … …  
    849983 
    850984   SUBROUTINE bn2( pts, pab, pn2, Kmm ) 
     985      !! 
     986      INTEGER                              , INTENT(in   ) ::  Kmm   ! time level index 
     987      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::  pts   ! pot. temperature and salinity   [Celsius,psu] 
     988      REAL(wp), DIMENSION(:,:,:,:)         , INTENT(in   ) ::  pab   ! thermal/haline expansion coef.  [Celsius-1,psu-1] 
     989      REAL(wp), DIMENSION(:,:,:)           , INTENT(  out) ::  pn2   ! Brunt-Vaisala frequency squared [1/s^2] 
     990      !! 
     991      CALL bn2_t( pts, pab, is_tile(pab), pn2, is_tile(pn2), Kmm ) 
     992   END SUBROUTINE bn2 
     993 
     994 
     995   SUBROUTINE bn2_t( pts, pab, ktab, pn2, ktn2, Kmm ) 
    851996      !!---------------------------------------------------------------------- 
    852997      !!                  ***  ROUTINE bn2  *** 
    … …  
    8621007      !! 
    8631008      !!---------------------------------------------------------------------- 
    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] 
     1009      INTEGER                                , INTENT(in   ) ::  Kmm   ! time level index 
     1010      INTEGER                                , INTENT(in   ) ::  ktab, ktn2 
     1011      REAL(wp), DIMENSION(jpi,jpj,  jpk,jpts), INTENT(in   ) ::  pts   ! pot. temperature and salinity   [Celsius,psu] 
     1012      REAL(wp), DIMENSION(A2D_T(ktab),JPK,JPTS), INTENT(in   ) ::  pab   ! thermal/haline expansion coef.  [Celsius-1,psu-1] 
     1013      REAL(wp), DIMENSION(A2D_T(ktn2),JPK     ), INTENT(  out) ::  pn2   ! Brunt-Vaisala frequency squared [1/s^2] 
    8681014      ! 
    8691015      INTEGER  ::   ji, jj, jk      ! dummy loop indices 
    … …  
    8731019      IF( ln_timing )   CALL timing_start('bn2') 
    8741020      ! 
    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 
     1021      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 
    8761022         zrw =   ( gdepw(ji,jj,jk  ,Kmm) - gdept(ji,jj,jk,Kmm) )   & 
    8771023            &  / ( gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm) )  
    … …  
    8891035      IF( ln_timing )   CALL timing_stop('bn2') 
    8901036      ! 
    891    END SUBROUTINE bn2 
     1037   END SUBROUTINE bn2_t 
    8921038 
    8931039 
    … …  
    9491095 
    9501096 
    951    SUBROUTINE  eos_fzp_2d( psal, ptf, pdep ) 
     1097   SUBROUTINE eos_fzp_2d( psal, ptf, pdep ) 
     1098      !! 
     1099      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   )           ::   psal   ! salinity   [psu] 
     1100      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ), OPTIONAL ::   pdep   ! depth      [m] 
     1101      REAL(wp), DIMENSION(:,:)    , INTENT(out  )           ::   ptf    ! freezing temperature [Celsius] 
     1102      !! 
     1103      CALL eos_fzp_2d_t( psal, ptf, is_tile(ptf), pdep ) 
     1104   END SUBROUTINE eos_fzp_2d 
     1105 
     1106 
     1107   SUBROUTINE  eos_fzp_2d_t( psal, ptf, kttf, pdep ) 
    9521108      !!---------------------------------------------------------------------- 
    9531109      !!                 ***  ROUTINE eos_fzp  *** 
    … …  
    9611117      !! Reference  :   UNESCO tech. papers in the marine science no. 28. 1978 
    9621118      !!---------------------------------------------------------------------- 
    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] 
     1119      INTEGER                       , INTENT(in   )           ::   kttf 
     1120      REAL(wp), DIMENSION(jpi,jpj)  , INTENT(in   )           ::   psal   ! salinity   [psu] 
     1121      REAL(wp), DIMENSION(jpi,jpj)  , INTENT(in   ), OPTIONAL ::   pdep   ! depth      [m] 
     1122      REAL(wp), DIMENSION(A2D_T(kttf)), INTENT(out  )           ::   ptf    ! freezing temperature [Celsius] 
    9661123      ! 
    9671124      INTEGER  ::   ji, jj          ! dummy loop indices 
    … …  
    9961153      END SELECT       
    9971154      ! 
    998   END SUBROUTINE eos_fzp_2d 
     1155  END SUBROUTINE eos_fzp_2d_t 
    9991156 
    10001157 

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

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

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

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

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

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

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

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

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

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

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

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

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

    r13867 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/TRA/traatf_qco.F90

    r13295 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/TRA/trabbc.F90

    r13295 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/TRA/trabbl.F90

    r13532 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/TRA/tradmp.F90

    r13295 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/TRA/traisf.F90

    r13295 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/TRA/traldf.F90

    r12377 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/TRA/traldf_iso.F90

    r13497 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/TRA/traldf_lap_blp.F90

    r13497 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/TRA/traldf_triad.F90

    r13497 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/TRA/tramle.F90

    r13867 r14043  
    8383      !!             Fox-Kemper and Ferrari, JPO, 38, 1166-1179, 2008 
    8484      !!---------------------------------------------------------------------- 
    85       INTEGER                         , INTENT(in   ) ::   kt         ! ocean time-step index 
    86       INTEGER                         , INTENT(in   ) ::   kit000     ! first time step index 
    87       INTEGER                         , INTENT(in   ) ::   Kmm        ! ocean time level index 
    88       CHARACTER(len=3)                , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator) 
    89       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu         ! in : 3 ocean transport components 
    90       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pv         ! out: same 3  transport components 
    91       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pw         !   increased by the MLE induced transport 
     85      INTEGER                     , INTENT(in   ) ::   kt         ! ocean time-step index 
     86      INTEGER                     , INTENT(in   ) ::   kit000     ! first time step index 
     87      INTEGER                     , INTENT(in   ) ::   Kmm        ! ocean time level index 
     88      CHARACTER(len=3)            , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator) 
     89      REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) ::   pu         ! in : 3 ocean transport components 
     90      REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) ::   pv         ! out: same 3  transport components 
     91      REAL(wp), DIMENSION(A2D(nn_hls),jpk), INTENT(inout) ::   pw         !   increased by the MLE induced transport 
    9292      ! 
    9393      INTEGER  ::   ji, jj, jk          ! dummy loop indices 
    … …  
    9595      REAL(wp) ::   zcuw, zmuw, zc      ! local scalar 
    9696      REAL(wp) ::   zcvw, zmvw          !   -      - 
    97       INTEGER , DIMENSION(jpi,jpj)     :: inml_mle 
    98       REAL(wp), DIMENSION(jpi,jpj)     :: zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_NH, zLf_MH 
    99       REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpsi_uw, zpsi_vw 
     97      INTEGER , DIMENSION(A2D(nn_hls))     :: inml_mle 
     98      REAL(wp), DIMENSION(A2D(nn_hls))     :: zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_MH 
     99      REAL(wp), DIMENSION(A2D(nn_hls),jpk) :: zpsi_uw, zpsi_vw 
     100      ! TEMP: [tiling] These changes not necessary if using XIOS (subdomain support) 
     101      REAL(wp), DIMENSION(:,:),   ALLOCATABLE, SAVE :: zLf_NH 
     102      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: zpsiu_mle, zpsiv_mle 
    100103      !!---------------------------------------------------------------------- 
    101104      ! 
    … …  
    146149         !                                      !==  MLD used for MLE  ==! 
    147150         !                                                ! compute from the 10m density to deal with the diurnal cycle 
    148          inml_mle(:,:) = mbkt(:,:) + 1                    ! init. to number of ocean w-level (T-level + 1) 
     151         DO_2D( 1, 1, 1, 1 ) 
     152            inml_mle(ji,jj) = mbkt(ji,jj) + 1                    ! init. to number of ocean w-level (T-level + 1) 
     153         END_2D 
    149154         IF ( nla10 > 0 ) THEN                            ! avoid case where first level is thicker than 10m 
    150155           DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 )        ! from the bottom to nlb10 (10m) 
    … …  
    183188         END SELECT 
    184189         !                                                ! convert density into buoyancy 
    185          zbm(:,:) = + grav * zbm(:,:) / MAX( e3t(:,:,1,Kmm), zmld(:,:) ) 
     190         DO_2D( 1, 1, 1, 1 ) 
     191            zbm(ji,jj) = + grav * zbm(ji,jj) / MAX( e3t(ji,jj,1,Kmm), zmld(ji,jj) ) 
     192         END_2D 
    186193         ! 
    187194         ! 
    … …  
    255262      END DO 
    256263 
    257     IF( cdtype == 'TRA') THEN              !==  outputs  ==! 
    258        ! 
    259        IF (ln_osm_mle.and.ln_zdfosm) THEN 
    260           zLf_NH(:,:) = SQRT( rb_c * hmle(:,:) ) * r1_ft(:,:)      ! Lf = N H / f 
    261        ELSE 
    262           zLf_NH(:,:) = SQRT( rb_c * zmld(:,:) ) * r1_ft(:,:)      ! Lf = N H / f 
    263        END IF 
    264        CALL iom_put( "Lf_NHpf" , zLf_NH  )    ! Lf = N H / f 
    265        ! 
    266        ! divide by cross distance to give streamfunction with dimensions m^2/s 
    267        DO jk = 1, ikmax+1 
    268           zpsi_uw(:,:,jk) = zpsi_uw(:,:,jk) * r1_e2u(:,:) 
    269           zpsi_vw(:,:,jk) = zpsi_vw(:,:,jk) * r1_e1v(:,:) 
    270        END DO 
    271        CALL iom_put( "psiu_mle", zpsi_uw )    ! i-mle streamfunction 
    272        CALL iom_put( "psiv_mle", zpsi_vw )    ! j-mle streamfunction 
    273     ENDIF 
    274     ! 
    275   END SUBROUTINE tra_mle_trp 
    276  
     264      ! TEMP: [tiling] These changes not necessary if using XIOS (subdomain support) 
     265      IF( cdtype == 'TRA') THEN              !==  outputs  ==! 
     266         IF( ntile == 0 .OR. ntile == 1 ) THEN                             ! Do only on the first tile 
     267            ALLOCATE( zLf_NH(jpi,jpj), zpsiu_mle(jpi,jpj,jpk), zpsiv_mle(jpi,jpj,jpk) ) 
     268            zpsiu_mle(:,:,:) = 0._wp ; zpsiv_mle(:,:,:) = 0._wp 
     269         ENDIF 
     270         ! 
     271         IF (ln_osm_mle.and.ln_zdfosm) THEN 
     272            DO_2D( 0, 0, 0, 0 ) 
     273               zLf_NH(ji,jj) = SQRT( rb_c * hmle(ji,jj) ) * r1_ft(ji,jj)      ! Lf = N H / f 
     274            END_2D 
     275         ELSE 
     276            DO_2D( 0, 0, 0, 0 ) 
     277               zLf_NH(ji,jj) = SQRT( rb_c * zmld(ji,jj) ) * r1_ft(ji,jj)      ! Lf = N H / f 
     278            END_2D 
     279         ENDIF 
     280         ! 
     281         ! divide by cross distance to give streamfunction with dimensions m^2/s 
     282         DO_3D( 0, 0, 0, 0, 1, ikmax+1 ) 
     283            zpsiu_mle(ji,jj,jk) = zpsi_uw(ji,jj,jk) * r1_e2u(ji,jj) 
     284            zpsiv_mle(ji,jj,jk) = zpsi_vw(ji,jj,jk) * r1_e1v(ji,jj) 
     285         END_3D 
     286 
     287         IF( ntile == 0 .OR. ntile == nijtile ) THEN                       ! Do only on the last tile 
     288            CALL iom_put( "Lf_NHpf" , zLf_NH  )    ! Lf = N H / f 
     289            CALL iom_put( "psiu_mle", zpsiu_mle )    ! i-mle streamfunction 
     290            CALL iom_put( "psiv_mle", zpsiv_mle )    ! j-mle streamfunction 
     291            DEALLOCATE( zLf_NH, zpsiu_mle, zpsiv_mle ) 
     292         ENDIF 
     293      ENDIF 
     294      ! 
     295   END SUBROUTINE tra_mle_trp 
    277296 
    278297   SUBROUTINE tra_mle_init 

  • NEMO/branches/2020/dev_r13787_OSMOSIS_IMMERSE/src/OCE/TRA/tranpc.F90

    r13497 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/TRA/traqsr.F90

    r13497 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/TRA/trasbc.F90

    r13497 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/TRA/trazdf.F90

    r13497 r14043  
    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 
    1818   USE zdf_oce        ! ocean vertical physics variables 
     19   USE zdfmfc         ! Mass FLux Convection  
    1920   USE sbc_oce        ! surface boundary condition: ocean 
    2021   USE ldftra         ! lateral diffusion: eddy diffusivity 
    … …  
    5556      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts                 ! active tracers and RHS of tracer equation 
    5657      ! 
    57       INTEGER  ::   jk   ! Dummy loop indices 
     58      INTEGER  ::   ji, jj, jk   ! Dummy loop indices 
    5859      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztrdt, ztrds   ! 3D workspace 
    5960      !!--------------------------------------------------------------------- 
    … …  
    6263      ! 
    6364      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,*) '~~~~~~~ ' 
     65         IF( ntile == 0 .OR. ntile == 1 )  THEN                   ! Do only on the first tile 
     66            IF(lwp)WRITE(numout,*) 
     67            IF(lwp)WRITE(numout,*) 'tra_zdf : implicit vertical mixing on T & S' 
     68            IF(lwp)WRITE(numout,*) '~~~~~~~ ' 
     69         ENDIF 
    6770      ENDIF 
    6871      ! 
    6972      IF( l_trdtra )   THEN                  !* Save ta and sa trends 
    70          ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 
     73         ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 
    7174         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kaa) 
    7275         ztrds(:,:,:) = pts(:,:,:,jp_sal,Kaa) 
    … …  
    8083      ! JMM avoid negative salinities near river outlet ! Ugly fix 
    8184      ! JMM : restore negative salinities to small salinities: 
    82       WHERE( pts(:,:,:,jp_sal,Kaa) < 0._wp )   pts(:,:,:,jp_sal,Kaa) = 0.1_wp 
     85      WHERE( pts(A2D(0),:,jp_sal,Kaa) < 0._wp )   pts(A2D(0),:,jp_sal,Kaa) = 0.1_wp 
    8386!!gm 
    8487 
    8588      IF( l_trdtra )   THEN                      ! save the vertical diffusive trends for further diagnostics 
    86          DO jk = 1, jpkm1 
     89         DO jk = 1, jpk 
    8790            ztrdt(:,:,jk) = (   (  pts(:,:,jk,jp_tem,Kaa)*e3t(:,:,jk,Kaa)     & 
    8891               &                 - pts(:,:,jk,jp_tem,Kbb)*e3t(:,:,jk,Kbb)  )  & 
    … …  
    9497               &          - ztrds(:,:,jk) 
    9598         END DO 
     99         ! NOTE: [tiling-comms-merge] The diagnostic results change along the north fold if this is removed 
    96100!!gm this should be moved in trdtra.F90 and done on all trends 
    97101         CALL lbc_lnk_multi( 'trazdf', ztrdt, 'T', 1.0_wp , ztrds, 'T', 1.0_wp ) 
    … …  
    140144      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices 
    141145      REAL(wp) ::  zrhs, zzwi, zzws ! local scalars 
    142       REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zwi, zwt, zwd, zws 
     146      REAL(wp), DIMENSION(A2D(nn_hls),jpk) ::  zwi, zwt, zwd, zws 
    143147      !!--------------------------------------------------------------------- 
    144148      ! 
    … …  
    154158            ! 
    155159            ! 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) 
     160            IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN 
     161               DO_3D( 1, 1, 1, 1, 2, jpk ) 
     162                  zwt(ji,jj,jk) = avt(ji,jj,jk) 
     163               END_3D 
     164            ELSE 
     165               DO_3D( 1, 1, 1, 1, 2, jpk ) 
     166                  zwt(ji,jj,jk) = avs(ji,jj,jk) 
     167               END_3D 
    158168            ENDIF 
    159169            zwt(:,:,1) = 0._wp 
    … …  
    189199            ENDIF 
    190200            ! 
     201            ! Modification of diagonal to add MF scheme 
     202            IF ( ln_zdfmfc ) THEN 
     203               CALL diag_mfc( zwi, zwd, zws, p2dt, Kaa ) 
     204            END IF 
     205            ! 
    191206            !! Matrix inversion from the first level 
    192207            !!---------------------------------------------------------------------- 
    … …  
    217232         ENDIF  
    218233         !          
     234         ! Modification of rhs to add MF scheme 
     235         IF ( ln_zdfmfc ) THEN 
     236            CALL rhs_mfc( pt(:,:,:,jn,Krhs), jn ) 
     237         END IF 
     238         ! 
    219239         DO_2D( 0, 0, 0, 0 )         !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    220240            pt(ji,jj,1,jn,Kaa) =        e3t(ji,jj,1,Kbb) * pt(ji,jj,1,jn,Kbb)    & 
    221                &               + p2dt * e3t(ji,jj,1,Kmm) * pt(ji,jj,1,jn,Krhs) 
     241               &               + p2dt * e3t(ji,jj,1,Kmm) * pt(ji,jj,1,jn,Krhs)  
    222242         END_2D 
    223243         DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
    224             zrhs =        e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb)    &  
     244            zrhs =        e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb)    & 
    225245               & + p2dt * e3t(ji,jj,jk,Kmm) * pt(ji,jj,jk,jn,Krhs)   ! zrhs=right hand side 
    226246            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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/TRA/zpshde.F90

    r13497 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/TRD/trdini.F90

    r12377 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/USR/usrdef_nam.F90

    r13286 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/ZDF/zdf_oce.F90

    r10425 r14043  
    4040   LOGICAL , PUBLIC ::   ln_zdfswm   !: surface  wave-induced mixing flag 
    4141   LOGICAL , PUBLIC ::   ln_zdfiwm   !: internal wave-induced mixing flag 
     42   LOGICAL , PUBLIC ::   ln_zdfmfc   !: convection: eddy diffusivity Mass Flux Convection 
    4243   !                             ! coefficients  
    4344   REAL(wp), PUBLIC ::   rn_avm0     !: vertical eddy viscosity (m2/s) 

  • NEMO/branches/2020/dev_r13787_OSMOSIS_IMMERSE/src/OCE/ZDF/zdfgls.F90

    r13558 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/ZDF/zdfosm.F90

    r13900 r14043  
    26722672     ghamv(:,:,:) = 0. 
    26732673     ! 
    2674      IF( lwxios ) THEN 
    2675         CALL iom_set_rstw_var_active('wn') 
    2676         CALL iom_set_rstw_var_active('hbl') 
    2677         CALL iom_set_rstw_var_active('dh') 
    2678         IF( ln_osm_mle ) THEN 
    2679             CALL iom_set_rstw_var_active('hmle') 
    2680         END IF 
    2681      ENDIF 
    26822674   END SUBROUTINE zdf_osm_init 
    26832675 
    … …  
    27122704        id1 = iom_varid( numror, 'wn'   , ldstop = .FALSE. ) 
    27132705        IF( id1 > 0 ) THEN                       ! 'wn' exists; read 
    2714            CALL iom_get( numror, jpdom_auto, 'wn', ww, ldxios = lrxios ) 
     2706           CALL iom_get( numror, jpdom_auto, 'wn', ww ) 
    27152707           WRITE(numout,*) ' ===>>>> :  wn read from restart file' 
    27162708        ELSE 
    … …  
    27222714        id2 = iom_varid( numror, 'dh'   , ldstop = .FALSE. ) 
    27232715        IF( id1 > 0 .AND. id2 > 0) THEN                       ! 'hbl' exists; read and return 
    2724            CALL iom_get( numror, jpdom_auto, 'hbl' , hbl , ldxios = lrxios ) 
    2725            CALL iom_get( numror, jpdom_auto, 'dh', dh, ldxios = lrxios ) 
     2716           CALL iom_get( numror, jpdom_auto, 'hbl' , hbl ) 
     2717           CALL iom_get( numror, jpdom_auto, 'dh', dh ) 
    27262718           WRITE(numout,*) ' ===>>>> :  hbl & dh read from restart file' 
    27272719           IF( ln_osm_mle ) THEN 
    27282720              id3 = iom_varid( numror, 'hmle'   , ldstop = .FALSE. ) 
    27292721              IF( id3 > 0) THEN 
    2730                  CALL iom_get( numror, jpdom_auto, 'hmle' , hmle , ldxios = lrxios ) 
     2722                 CALL iom_get( numror, jpdom_auto, 'hmle' , hmle ) 
    27312723                 WRITE(numout,*) ' ===>>>> :  hmle read from restart file' 
    27322724              ELSE 
    … …  
    27462738     IF( TRIM(cdrw) == 'WRITE') THEN     !* Write hbl into the restart file, then return 
    27472739        IF(lwp) WRITE(numout,*) '---- osm-rst ----' 
    2748          CALL iom_rstput( kt, nitrst, numrow, 'wn'     , ww,   ldxios = lwxios ) 
    2749          CALL iom_rstput( kt, nitrst, numrow, 'hbl'    , hbl,  ldxios = lwxios ) 
    2750          CALL iom_rstput( kt, nitrst, numrow, 'dh'     , dh,   ldxios = lwxios ) 
     2740         CALL iom_rstput( kt, nitrst, numrow, 'wn'     , ww  ) 
     2741         CALL iom_rstput( kt, nitrst, numrow, 'hbl'    , hbl ) 
     2742         CALL iom_rstput( kt, nitrst, numrow, 'dh'     , dh  ) 
    27512743         IF( ln_osm_mle ) THEN 
    2752             CALL iom_rstput( kt, nitrst, numrow, 'hmle', hmle, ldxios = lwxios ) 
     2744            CALL iom_rstput( kt, nitrst, numrow, 'hmle', hmle ) 
    27532745         END IF 
    27542746        RETURN 
    … …  
    28082800      ! 
    28092801      IF( kt == nit000 ) THEN 
    2810          IF(lwp) WRITE(numout,*) 
    2811          IF(lwp) WRITE(numout,*) 'tra_osm : OSM non-local tracer fluxes' 
    2812          IF(lwp) WRITE(numout,*) '~~~~~~~   ' 
     2802         IF( ntile == 0 .OR. ntile == 1 ) THEN                    ! Do only on the first tile 
     2803            IF(lwp) WRITE(numout,*) 
     2804            IF(lwp) WRITE(numout,*) 'tra_osm : OSM non-local tracer fluxes' 
     2805            IF(lwp) WRITE(numout,*) '~~~~~~~   ' 
     2806         ENDIF 
    28132807      ENDIF 
    28142808 

  • NEMO/branches/2020/dev_r13787_OSMOSIS_IMMERSE/src/OCE/ZDF/zdfphy.F90

    r13872 r14043  
    2121   USE zdfddm         ! vertical physics: double diffusion mixing       
    2222   USE zdfevd         ! vertical physics: convection via enhanced vertical diffusion   
     23   USE zdfmfc         ! vertical physics: Mass Flux Convection  
    2324   USE zdfiwm         ! vertical physics: internal wave-induced mixing   
    2425   USE zdfswm         ! vertical physics: surface  wave-induced mixing 
    … …  
    7879      NAMELIST/namzdf/ ln_zdfcst, ln_zdfric, ln_zdftke, ln_zdfgls,   &     ! type of closure scheme 
    7980         &             ln_zdfosm,                                    &     ! type of closure scheme 
     81         &             ln_zdfmfc,                                    &     ! convection : mass flux 
    8082         &             ln_zdfevd, nn_evdm, rn_evd ,                  &     ! convection : evd 
    8183         &             ln_zdfnpc, nn_npc , nn_npcp,                  &     ! convection : npc 
    … …  
    112114         WRITE(numout,*) '         OSMOSIS-OBL closure (OSM)               ln_zdfosm = ', ln_zdfosm 
    113115         WRITE(numout,*) '      convection: ' 
     116         WRITE(numout,*) '         convection mass flux (mfc)              ln_zdfmfc = ', ln_zdfmfc 
    114117         WRITE(numout,*) '         enhanced vertical diffusion             ln_zdfevd = ', ln_zdfevd 
    115118         WRITE(numout,*) '            applied on momentum (=1/0)             nn_evdm = ', nn_evdm 
    … …  
    172175      IF( ln_zdfnpc .AND. ln_zdfevd )   CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfnpc and ln_zdfevd' ) 
    173176      IF( ln_zdfosm .AND. ln_zdfevd )   CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfosm and ln_zdfevd' ) 
     177      IF( ln_zdfmfc .AND. ln_zdfevd )   CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfmfc and ln_zdfevd' ) 
     178      IF( ln_zdfmfc .AND. ln_zdfnpc )   CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfmfc and ln_zdfnpc' ) 
     179      IF( ln_zdfmfc .AND. ln_zdfosm )   CALL ctl_stop( 'zdf_phy_init: chose between ln_zdfmfc and ln_zdfosm' ) 
    174180      IF( lk_top    .AND. ln_zdfnpc )   CALL ctl_stop( 'zdf_phy_init: npc scheme is not working with key_top' ) 
    175181      IF( lk_top    .AND. ln_zdfosm )   CALL ctl_warn( 'zdf_phy_init: osmosis gives no non-local fluxes for TOP tracers yet' ) 
     182      IF( lk_top    .AND. ln_zdfmfc )   CALL ctl_stop( 'zdf_phy_init: Mass Flux scheme is not working with key_top' ) 
    176183      IF(lwp) THEN 
    177184         WRITE(numout,*) 
    178185         IF    ( ln_zdfnpc ) THEN  ;   WRITE(numout,*) '   ==>>>   convection: use non penetrative convective scheme' 
    179186         ELSEIF( ln_zdfevd ) THEN  ;   WRITE(numout,*) '   ==>>>   convection: use enhanced vertical diffusion scheme' 
     187         ELSEIF( ln_zdfmfc ) THEN  ;   WRITE(numout,*) '   ==>>>   convection: use Mass Flux scheme' 
    180188         ELSE                      ;   WRITE(numout,*) '   ==>>>   convection: no specific scheme used' 
    181189         ENDIF 
    … …  
    205213      ELSE                   ;   l_zdfsh2 = .TRUE. 
    206214      ENDIF 
    207  
     215      !                          !== Mass Flux Convectiive algorithm  ==! 
     216      IF( ln_zdfmfc )   CALL zdf_mfc_init       ! Convection computed with eddy diffusivity mass flux 
     217      ! 
    208218      !                          !== gravity wave-driven mixing  ==! 
    209219      IF( ln_zdfiwm )   CALL zdf_iwm_init       ! internal wave-driven mixing 

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

    r13497 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/ZDF/zdfsh2.F90

    r13497 r14043  
    66   !! History :   -   !  2014-10  (A. Barthelemy, G. Madec)  original code 
    77   !!   NEMO     4.0  !  2017-04  (G. Madec)  remove u-,v-pts avm 
     8   !!   NEMO     4.2  !  2020-12  (G. Madec, E. Clementi) add Stokes Drift Shear 
     9   !                  !           for wave coupling 
    810   !!---------------------------------------------------------------------- 
    911 
    … …  
    1315   USE oce 
    1416   USE dom_oce        ! domain: ocean 
     17   USE sbcwave        ! Surface Waves (add Stokes shear) 
     18   USE sbc_oce , ONLY: ln_stshear  !Stoked Drift shear contribution 
    1519   ! 
    1620   USE in_out_manager ! I/O manager 
    … …  
    2125 
    2226   PUBLIC   zdf_sh2        ! called by zdftke, zdfglf, and zdfric 
    23     
     27 
    2428   !! * Substitutions 
    2529#  include "do_loop_substitute.h90" 
    … …  
    5963      !!-------------------------------------------------------------------- 
    6064      ! 
    61       DO jk = 2, jpkm1 
    62          DO_2D( 1, 0, 1, 0 )     !* 2 x shear production at uw- and vw-points (energy conserving form) 
    63             zsh2u(ji,jj) = ( p_avm(ji+1,jj,jk) + p_avm(ji,jj,jk) ) & 
    64                &         * (   uu(ji,jj,jk-1,Kmm) -   uu(ji,jj,jk,Kmm) ) & 
    65                &         * (   uu(ji,jj,jk-1,Kbb) -   uu(ji,jj,jk,Kbb) ) &  
    66                &         / ( e3uw(ji,jj,jk  ,Kmm) * e3uw(ji,jj,jk,Kbb) ) & 
    67                &         * wumask(ji,jj,jk) 
    68             zsh2v(ji,jj) = ( p_avm(ji,jj+1,jk) + p_avm(ji,jj,jk) ) & 
    69                &         * (   vv(ji,jj,jk-1,Kmm) -   vv(ji,jj,jk,Kmm) ) & 
    70                &         * (   vv(ji,jj,jk-1,Kbb) -   vv(ji,jj,jk,Kbb) ) & 
    71                &         / ( e3vw(ji,jj,jk  ,Kmm) * e3vw(ji,jj,jk,Kbb) ) & 
    72                &         * wvmask(ji,jj,jk) 
    73          END_2D 
     65      DO jk = 2, jpkm1                 !* Shear production at uw- and vw-points (energy conserving form) 
     66         IF ( cpl_sdrftx .AND. ln_stshear )  THEN       ! Surface Stokes Drift available  ===>>>  shear + stokes drift contibution 
     67            DO_2D( 1, 0, 1, 0 ) 
     68               zsh2u(ji,jj) = ( p_avm(ji+1,jj,jk) + p_avm(ji,jj,jk) )        & 
     69                  &         * ( uu (ji,jj,jk-1,Kmm) -   uu (ji,jj,jk,Kmm)    & 
     70                  &           + usd(ji,jj,jk-1) -   usd(ji,jj,jk) )  & 
     71                  &         * ( uu (ji,jj,jk-1,Kbb) -   uu (ji,jj,jk,Kbb) )  & 
     72                  &         / ( e3uw(ji,jj,jk,Kmm) * e3uw(ji,jj,jk,Kbb) ) * wumask(ji,jj,jk) 
     73               zsh2v(ji,jj) = ( p_avm(ji,jj+1,jk) + p_avm(ji,jj,jk) )         & 
     74                  &         * ( vv (ji,jj,jk-1,Kmm) -   vv (ji,jj,jk,Kmm)     & 
     75                  &           + vsd(ji,jj,jk-1) -   vsd(ji,jj,jk) )   & 
     76                  &         * ( vv (ji,jj,jk-1,Kbb) -   vv (ji,jj,jk,Kbb) )   & 
     77                  &/ ( e3vw(ji,jj,jk,Kmm) * e3vw(ji,jj,jk,Kbb) ) * wvmask(ji,jj,jk) 
     78            END_2D 
     79         ELSE 
     80            DO_2D( 1, 0, 1, 0 )     !* 2 x shear production at uw- and vw-points (energy conserving form) 
     81               zsh2u(ji,jj) = ( p_avm(ji+1,jj,jk) + p_avm(ji,jj,jk) ) & 
     82                  &         * (   uu(ji,jj,jk-1,Kmm) -   uu(ji,jj,jk,Kmm) ) & 
     83                  &         * (   uu(ji,jj,jk-1,Kbb) -   uu(ji,jj,jk,Kbb) ) &  
     84                  &         / ( e3uw(ji,jj,jk  ,Kmm) * e3uw(ji,jj,jk,Kbb) ) & 
     85                  &         * wumask(ji,jj,jk) 
     86               zsh2v(ji,jj) = ( p_avm(ji,jj+1,jk) + p_avm(ji,jj,jk) ) & 
     87                  &         * (   vv(ji,jj,jk-1,Kmm) -   vv(ji,jj,jk,Kmm) ) & 
     88                  &         * (   vv(ji,jj,jk-1,Kbb) -   vv(ji,jj,jk,Kbb) ) & 
     89                  &         / ( e3vw(ji,jj,jk  ,Kmm) * e3vw(ji,jj,jk,Kbb) ) & 
     90                  &         * wvmask(ji,jj,jk) 
     91            END_2D 
     92         ENDIF 
    7493         DO_2D( 0, 0, 0, 0 )     !* shear production at w-point ! coast mask: =2 at the coast ; =1 otherwise (NB: wmask useless as zsh2 are masked) 
    7594            p_sh2(ji,jj,jk) = 0.25 * (   ( zsh2u(ji-1,jj) + zsh2u(ji,jj) ) * ( 2. - umask(ji-1,jj,jk) * umask(ji,jj,jk) )   & 
    7695               &                       + ( zsh2v(ji,jj-1) + zsh2v(ji,jj) ) * ( 2. - vmask(ji,jj-1,jk) * vmask(ji,jj,jk) )   ) 
    7796         END_2D 
    78       END DO  
     97      END DO 
    7998      ! 
    8099   END SUBROUTINE zdf_sh2 

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

    r13558 r14043  
    2929   !!            4.0  !  2017-04  (G. Madec)  remove CPP ddm key & avm at t-point only  
    3030   !!             -   !  2017-05  (G. Madec)  add top/bottom friction as boundary condition 
     31   !!            4.2  !  2020-12  (G. Madec, E. Clementi) add wave coupling 
     32   !                  !           following Couvelard et al., 2019 
    3133   !!---------------------------------------------------------------------- 
    3234 
    … …  
    5860   USE prtctl         ! Print control 
    5961   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     62   USE sbcwave        ! Surface boundary waves 
    6063 
    6164   IMPLICIT NONE 
    … …  
    6871   !                      !!** Namelist  namzdf_tke  ** 
    6972   LOGICAL  ::   ln_mxl0   ! mixing length scale surface value as function of wind stress or not 
     73   LOGICAL  ::   ln_mxhsw  ! mixing length scale surface value as a fonction of wave height 
    7074   INTEGER  ::   nn_mxlice ! type of scaling under sea-ice (=0/1/2/3) 
    7175   REAL(wp) ::   rn_mxlice ! ice thickness value when scaling under sea-ice 
    … …  
    8185   INTEGER  ::   nn_etau   ! type of depth penetration of surface tke (=0/1/2/3) 
    8286   INTEGER  ::      nn_htau   ! type of tke profile of penetration (=0/1) 
     87   INTEGER  ::   nn_bc_surf! surface condition (0/1=Dir/Neum) ! Only applicable for wave coupling 
     88   INTEGER  ::   nn_bc_bot ! surface condition (0/1=Dir/Neum) ! Only applicable for wave coupling 
    8389   REAL(wp) ::      rn_efr    ! fraction of TKE surface value which penetrates in the ocean 
    8490   LOGICAL  ::   ln_lc     ! Langmuir cells (LC) as a source term of TKE or not 
    … …  
    209215      REAL(wp) ::   zus   , zwlc  , zind       !   -      - 
    210216      REAL(wp) ::   zzd_up, zzd_lw             !   -      - 
     217      REAL(wp) ::   ztaui, ztauj, z1_norm 
    211218      INTEGER , DIMENSION(jpi,jpj)     ::   imlc 
    212       REAL(wp), DIMENSION(jpi,jpj)     ::   zice_fra, zhlc, zus3 
     219      REAL(wp), DIMENSION(jpi,jpj)     ::   zice_fra, zhlc, zus3, zWlc2 
    213220      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zpelc, zdiag, zd_up, zd_lw 
    214221      !!-------------------------------------------------------------------- 
    … …  
    219226      zfact2  = 1.5_wp * rn_Dt * rn_ediss 
    220227      zfact3  = 0.5_wp         * rn_ediss 
     228      ! 
     229      zpelc(:,:,:) = 0._wp ! need to be initialised in case ln_lc is not used 
    221230      ! 
    222231      ! ice fraction considered for attenuation of langmuir & wave breaking 
    … …  
    232241      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    233242      ! 
    234       DO_2D( 0, 0, 0, 0 )         ! en(1)   = rn_ebb taum / rau0  (min value rn_emin0) 
    235 !! clem: this should be the right formulation but it makes the model unstable unless drags are calculated implicitly 
    236 !!       one way around would be to increase zbbirau  
    237 !!          en(ji,jj,1) = MAX( rn_emin0, ( ( 1._wp - fr_i(ji,jj) ) * zbbrau + & 
    238 !!             &                                     fr_i(ji,jj)   * zbbirau ) * taum(ji,jj) ) * tmask(ji,jj,1) 
     243      DO_2D( 0, 0, 0, 0 ) 
    239244         en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1) 
     245         zdiag(ji,jj,1) = 1._wp/en(ji,jj,1) 
     246         zd_lw(ji,jj,1) = 1._wp   
     247         zd_up(ji,jj,1) = 0._wp 
    240248      END_2D 
    241249      ! 
    … …  
    274282      ! 
    275283      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    276       IF( ln_lc ) THEN      !  Langmuir circulation source term added to tke   !   (Axell JGR 2002) 
     284      IF( ln_lc ) THEN      !  Langmuir circulation source term added to tke (Axell JGR 2002) 
    277285         !                  !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    278286         ! 
    279          !                        !* total energy produce by LC : cumulative sum over jk 
     287         !                       !* Langmuir velocity scale 
     288         ! 
     289         IF ( cpl_sdrftx )  THEN       ! Surface Stokes Drift available 
     290            !                                ! Craik-Leibovich velocity scale Wlc = ( u* u_s )^1/2    with u* = (taum/rho0)^1/2 
     291            !                                ! associated kinetic energy : 1/2 (Wlc)^2 = u* u_s 
     292            !                                ! more precisely, it is the dot product that must be used : 
     293            !                                !     1/2  (W_lc)^2 = MAX( u* u_s + v* v_s , 0 )   only the positive part 
     294!!gm  ! PS: currently we don't have neither the 2 stress components at t-point !nor the angle between u* and u_s 
     295!!gm  ! so we will overestimate the LC velocity....   !!gm I will do the work if !LC have an effect ! 
     296            DO_2D( 0, 0, 0, 0 ) 
     297!!XC                  zWlc2(ji,jj) = 0.5_wp * SQRT( taum(ji,jj) * r1_rho0 * ( ut0sd(ji,jj)**2 +vt0sd(ji,jj)**2 )  ) 
     298                  zWlc2(ji,jj) = 0.5_wp *  ( ut0sd(ji,jj)**2 +vt0sd(ji,jj)**2 ) 
     299            END_2D 
     300! 
     301!  Projection of Stokes drift in the wind stress direction 
     302! 
     303            DO_2D( 0, 0, 0, 0 ) 
     304                  ztaui   = 0.5_wp * ( utau(ji,jj) + utau(ji-1,jj) ) 
     305                  ztauj   = 0.5_wp * ( vtau(ji,jj) + vtau(ji,jj-1) ) 
     306                  z1_norm = 1._wp / MAX( SQRT(ztaui*ztaui+ztauj*ztauj), 1.e-12 ) * tmask(ji,jj,1) 
     307                  zWlc2(ji,jj) = 0.5_wp * z1_norm * ( MAX( ut0sd(ji,jj)*ztaui + vt0sd(ji,jj)*ztauj, 0._wp ) )**2 
     308            END_2D 
     309         CALL lbc_lnk      ( 'zdftke', zWlc2, 'T', 1. ) 
     310! 
     311         ELSE                          ! Surface Stokes drift deduced from surface stress 
     312            !                                ! Wlc = u_s   with u_s = 0.016*U_10m, the surface stokes drift  (Axell 2002, Eq.44) 
     313            !                                ! using |tau| = rho_air Cd |U_10m|^2 , it comes: 
     314            !                                ! Wlc = 0.016 * [|tau|/(rho_air Cdrag) ]^1/2   and thus: 
     315            !                                ! 1/2 Wlc^2 = 0.5 * 0.016 * 0.016 |tau| /( rho_air Cdrag ) 
     316            zcof = 0.5 * 0.016 * 0.016 / ( zrhoa * zcdrag )      ! to convert stress in 10m wind using a constant drag 
     317            DO_2D( 1, 1, 1, 1 ) 
     318               zWlc2(ji,jj) = zcof * taum(ji,jj) 
     319            END_2D 
     320            ! 
     321         ENDIF 
     322         ! 
     323         !                       !* Depth of the LC circulation  (Axell 2002, Eq.47) 
     324         !                             !- LHS of Eq.47 
    280325         zpelc(:,:,1) =  MAX( rn2b(:,:,1), 0._wp ) * gdepw(:,:,1,Kmm) * e3w(:,:,1,Kmm) 
    281326         DO jk = 2, jpk 
    … …  
    283328               &        MAX( rn2b(:,:,jk), 0._wp ) * gdepw(:,:,jk,Kmm) * e3w(:,:,jk,Kmm) 
    284329         END DO 
    285          !                        !* finite Langmuir Circulation depth 
    286          zcof = 0.5 * 0.016 * 0.016 / ( zrhoa * zcdrag ) 
     330         ! 
     331         !                             !- compare LHS to RHS of Eq.47 
    287332         imlc(:,:) = mbkt(:,:) + 1       ! Initialization to the number of w ocean point (=2 over land) 
    288          DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 )   ! Last w-level at which zpelc>=0.5*us*us  
    289             zus = zcof * taum(ji,jj)          !      with us=0.016*wind(starting from jpk-1) 
    290             IF( zpelc(ji,jj,jk) > zus )   imlc(ji,jj) = jk 
     333         DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) 
     334            IF( zpelc(ji,jj,jk) > zWlc2(ji,jj) )   imlc(ji,jj) = jk 
    291335         END_3D 
    292336         !                               ! finite LC depth 
    … …  
    294338            zhlc(ji,jj) = gdepw(ji,jj,imlc(ji,jj),Kmm) 
    295339         END_2D 
     340         ! 
    296341         zcof = 0.016 / SQRT( zrhoa * zcdrag ) 
    297342         DO_2D( 0, 0, 0, 0 ) 
    298             zus  = zcof * SQRT( taum(ji,jj) )           ! Stokes drift 
     343            zus = SQRT( 2. * zWlc2(ji,jj) )             ! Stokes drift 
    299344            zus3(ji,jj) = MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * zus * zus * zus * tmask(ji,jj,1) ! zus > 0. ok 
    300345         END_2D 
    … …  
    351396            &                                ) * wmask(ji,jj,jk) 
    352397      END_3D 
     398      ! 
     399      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
     400      !                     !  Surface boundary condition on tke if 
     401      !                     !  coupling with waves 
     402      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
     403      ! 
     404      IF ( cpl_phioc .and. ln_phioc )  THEN 
     405         SELECT CASE (nn_bc_surf) ! Boundary Condition using surface TKE flux from waves  
     406 
     407         CASE ( 0 ) ! Dirichlet BC 
     408            DO_2D( 0, 0, 0, 0 )    ! en(1)   = rn_ebb taum / rho0  (min value rn_emin0) 
     409               IF ( phioc(ji,jj) < 0 )  phioc(ji,jj) = 0._wp 
     410               en(ji,jj,1) = MAX( rn_emin0, .5 * ( 15.8 * phioc(ji,jj) / rho0 )**(2./3.) )  * tmask(ji,jj,1) 
     411               zdiag(ji,jj,1) = 1._wp/en(ji,jj,1)  ! choose to keep coherence with former estimation of 
     412            END_2D 
     413 
     414         CASE ( 1 ) ! Neumann BC 
     415            DO_2D( 0, 0, 0, 0 ) 
     416               IF ( phioc(ji,jj) < 0 )  phioc(ji,jj) = 0._wp 
     417               en(ji,jj,2)    = en(ji,jj,2) + ( rn_Dt * phioc(ji,jj) / rho0 ) /e3w(ji,jj,2,Kmm) 
     418               en(ji,jj,1)    = en(ji,jj,2) + (2 * e3t(ji,jj,1,Kmm) * phioc(ji,jj)/rho0) / ( p_avm(ji,jj,1) + p_avm(ji,jj,2) ) 
     419               zdiag(ji,jj,2) = zdiag(ji,jj,2) + zd_lw(ji,jj,2) 
     420               zdiag(ji,jj,1) = 1._wp 
     421               zd_lw(ji,jj,2) = 0._wp 
     422            END_2D 
     423 
     424         END SELECT 
     425 
     426      ENDIF 
     427      ! 
    353428      !                          !* Matrix inversion from level 2 (tke prescribed at level 1) 
    354       DO_3D( 0, 0, 0, 0, 3, jpkm1 )                ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 
     429      DO_3D( 0, 0, 0, 0, 2, jpkm1 )                ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 
    355430         zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 
    356431      END_3D 
    357       DO_2D( 0, 0, 0, 0 )                          ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 
    358          zd_lw(ji,jj,2) = en(ji,jj,2) - zd_lw(ji,jj,2) * en(ji,jj,1)    ! Surface boudary conditions on tke 
    359       END_2D 
    360       DO_3D( 0, 0, 0, 0, 3, jpkm1 ) 
     432!XC : commented to allow for neumann boundary condition 
     433!      DO_2D( 0, 0, 0, 0 ) 
     434!         zd_lw(ji,jj,2) = en(ji,jj,2) - zd_lw(ji,jj,2) * en(ji,jj,1)    ! Surface boudary conditions on tke 
     435!      END_2D 
     436      DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
    361437         zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) *zd_lw(ji,jj,jk-1) 
    362438      END_3D 
    … …  
    460536      zmxlm(:,:,:)  = rmxl_min     
    461537      zmxld(:,:,:)  = rmxl_min 
     538      ! 
     539      IF(ln_sdw .AND. ln_mxhsw) THEN 
     540         zmxlm(:,:,1)= vkarmn * MAX ( 1.6 * hsw(:,:) , 0.02 )        ! surface mixing length = F(wave height) 
     541         ! from terray et al 1999 and mellor and blumberg 2004 it should be 0.85 and not 1.6 
     542         zcoef       = vkarmn * ( (rn_ediff*rn_ediss)**0.25 ) / rn_ediff 
     543         zmxlm(:,:,1)= zcoef * MAX ( 1.6 * hsw(:,:) , 0.02 )        ! surface mixing length = F(wave height) 
     544      ELSE 
    462545      !  
    463      IF( ln_mxl0 ) THEN            ! surface mixing length = F(stress) : l=vkarmn*2.e5*taum/(rho0*g) 
    464          ! 
    465          zraug = vkarmn * 2.e5_wp / ( rho0 * grav ) 
     546         IF( ln_mxl0 ) THEN            ! surface mixing length = F(stress) : l=vkarmn*2.e5*taum/(rho0*g) 
     547         ! 
     548            zraug = vkarmn * 2.e5_wp / ( rho0 * grav ) 
    466549#if ! defined key_si3 && ! defined key_cice 
    467          DO_2D( 0, 0, 0, 0 )                  ! No sea-ice 
    468             zmxlm(ji,jj,1) =  zraug * taum(ji,jj) * tmask(ji,jj,1) 
    469          END_2D 
     550            DO_2D( 0, 0, 0, 0 )                  ! No sea-ice 
     551               zmxlm(ji,jj,1) =  zraug * taum(ji,jj) * tmask(ji,jj,1) 
     552            END_2D 
    470553#else 
    471          SELECT CASE( nn_mxlice )             ! Type of scaling under sea-ice 
    472          ! 
    473          CASE( 0 )                      ! No scaling under sea-ice 
     554            SELECT CASE( nn_mxlice )             ! Type of scaling under sea-ice 
     555            ! 
     556            CASE( 0 )                      ! No scaling under sea-ice 
     557               DO_2D( 0, 0, 0, 0 ) 
     558                  zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1) 
     559               END_2D 
     560               ! 
     561            CASE( 1 )                      ! scaling with constant sea-ice thickness 
     562               DO_2D( 0, 0, 0, 0 ) 
     563                  zmxlm(ji,jj,1) =  ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 
     564                     &                          fr_i(ji,jj)   * rn_mxlice           ) * tmask(ji,jj,1) 
     565               END_2D 
     566               ! 
     567            CASE( 2 )                      ! scaling with mean sea-ice thickness 
     568               DO_2D( 0, 0, 0, 0 ) 
     569#if defined key_si3 
     570                  zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 
     571                     &                         fr_i(ji,jj)   * hm_i(ji,jj) * 2._wp ) * tmask(ji,jj,1) 
     572#elif defined key_cice 
     573                  zmaxice = MAXVAL( h_i(ji,jj,:) ) 
     574                  zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 
     575                     &                         fr_i(ji,jj)   * zmaxice             ) * tmask(ji,jj,1) 
     576#endif 
     577               END_2D 
     578               ! 
     579            CASE( 3 )                      ! scaling with max sea-ice thickness 
     580               DO_2D( 0, 0, 0, 0 ) 
     581                  zmaxice = MAXVAL( h_i(ji,jj,:) ) 
     582                  zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 
     583                     &                         fr_i(ji,jj)   * zmaxice             ) * tmask(ji,jj,1) 
     584               END_2D 
     585               ! 
     586            END SELECT 
     587#endif 
     588            ! 
    474589            DO_2D( 0, 0, 0, 0 ) 
    475                zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1) 
     590               zmxlm(ji,jj,1) = MAX( rn_mxl0, zmxlm(ji,jj,1) ) 
    476591            END_2D 
    477592            ! 
    478          CASE( 1 )                      ! scaling with constant sea-ice thickness 
    479             DO_2D( 0, 0, 0, 0 ) 
    480                zmxlm(ji,jj,1) =  ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 
    481                   &                          fr_i(ji,jj)   * rn_mxlice           ) * tmask(ji,jj,1) 
    482             END_2D 
    483             ! 
    484          CASE( 2 )                      ! scaling with mean sea-ice thickness 
    485             DO_2D( 0, 0, 0, 0 ) 
    486 #if defined key_si3 
    487                zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 
    488                   &                         fr_i(ji,jj)   * hm_i(ji,jj) * 2._wp ) * tmask(ji,jj,1) 
    489 #elif defined key_cice 
    490                zmaxice = MAXVAL( h_i(ji,jj,:) ) 
    491                zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 
    492                   &                         fr_i(ji,jj)   * zmaxice             ) * tmask(ji,jj,1) 
    493 #endif 
    494             END_2D 
    495             ! 
    496          CASE( 3 )                      ! scaling with max sea-ice thickness 
    497             DO_2D( 0, 0, 0, 0 ) 
    498                zmaxice = MAXVAL( h_i(ji,jj,:) ) 
    499                zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 
    500                   &                         fr_i(ji,jj)   * zmaxice             ) * tmask(ji,jj,1) 
    501             END_2D 
    502             ! 
    503          END SELECT 
    504 #endif 
    505          ! 
    506          DO_2D( 0, 0, 0, 0 ) 
    507             zmxlm(ji,jj,1) = MAX( rn_mxl0, zmxlm(ji,jj,1) ) 
    508          END_2D 
    509          ! 
    510       ELSE 
    511          zmxlm(:,:,1) = rn_mxl0 
    512       ENDIF 
    513  
     593         ELSE 
     594            zmxlm(:,:,1) = rn_mxl0 
     595         ENDIF 
     596      ENDIF 
    514597      ! 
    515598      DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
    … …  
    624707         &                 rn_mxl0 , nn_mxlice, rn_mxlice,             & 
    625708         &                 nn_pdl  , ln_lc    , rn_lc    ,             & 
    626          &                 nn_etau , nn_htau  , rn_efr   , nn_eice   
     709         &                 nn_etau , nn_htau  , rn_efr   , nn_eice  ,  &    
     710         &                 nn_bc_surf, nn_bc_bot, ln_mxhsw 
    627711      !!---------------------------------------------------------------------- 
    628712      ! 
    … …  
    666750         WRITE(numout,*) '      Langmuir cells parametrization              ln_lc     = ', ln_lc 
    667751         WRITE(numout,*) '         coef to compute vertical velocity of LC     rn_lc  = ', rn_lc 
     752         IF ( cpl_phioc .and. ln_phioc )  THEN 
     753            SELECT CASE( nn_bc_surf)             ! Type of scaling under sea-ice 
     754            CASE( 0 )   ;   WRITE(numout,*) '  nn_bc_surf=0 ==>>> DIRICHLET SBC using surface TKE flux from waves' 
     755            CASE( 1 )   ;   WRITE(numout,*) '  nn_bc_surf=1 ==>>> NEUMANN SBC using surface TKE flux from waves' 
     756            END SELECT 
     757         ENDIF 
    668758         WRITE(numout,*) '      test param. to add tke induced by wind      nn_etau   = ', nn_etau 
    669759         WRITE(numout,*) '          type of tke penetration profile            nn_htau   = ', nn_htau 
    … …  
    721811      CALL tke_rst( nit000, 'READ' )      ! (en, avt_k, avm_k, dissl)  
    722812      ! 
    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 
    729813   END SUBROUTINE zdf_tke_init 
    730814 
    … …  
    758842            ! 
    759843            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 ) 
     844               CALL iom_get( numror, jpdom_auto, 'en'   , en    ) 
     845               CALL iom_get( numror, jpdom_auto, 'avt_k', avt_k ) 
     846               CALL iom_get( numror, jpdom_auto, 'avm_k', avm_k ) 
     847               CALL iom_get( numror, jpdom_auto, 'dissl', dissl ) 
    764848            ELSE                                          ! start TKE from rest 
    765849               IF(lwp) WRITE(numout,*) 
    … …  
    780864         !                                   ! ------------------- 
    781865         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          ) 
     866         CALL iom_rstput( kt, nitrst, numrow, 'en'   , en    ) 
     867         CALL iom_rstput( kt, nitrst, numrow, 'avt_k', avt_k ) 
     868         CALL iom_rstput( kt, nitrst, numrow, 'avm_k', avm_k ) 
     869         CALL iom_rstput( kt, nitrst, numrow, 'dissl', dissl ) 
    788870         ! 
    789871      ENDIF 

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

    r13296 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/nemogcm.F90

    r13558 r14043  
    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 )   & 
    … …  
    490490                           CALL dyn_spg_init         ! surface pressure gradient 
    491491 
     492      !                                      ! Icebergs 
     493                           CALL icb_init( rn_Dt, nit000)   ! initialise icebergs instance 
     494 
     495                                                ! ice shelf 
     496                           CALL isf_init( Nbb, Nnn, Naa ) 
    492497#if defined key_top 
    493498      !                                      ! Passive tracers 
    … …  
    495500#endif 
    496501      IF( l_ldfslp     )   CALL ldf_slp_init    ! slope of lateral mixing 
    497  
    498       !                                      ! Icebergs 
    499                            CALL icb_init( rn_Dt, nit000)   ! initialise icebergs instance 
    500  
    501                                                 ! ice shelf 
    502                            CALL isf_init( Nbb, Nnn, Naa ) 
    503502 
    504503      !                                      ! Misc. options 

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

    r13286 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/step.F90

    r13237 r14043  
    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_zdfmfc  )   CALL tra_mfc    ( kstp, Nbb,      ts, Nrhs )  ! Mass Flux Convection  
     299         IF( ln_zdfosm  )   CALL tra_osm    ( kstp,      Nnn, ts, Nrhs )  ! OSMOSIS non-local tracer fluxes ==> RHS 
     300         IF( lrst_oce .AND. ln_zdfosm ) & 
     301              &             CALL osm_rst    ( kstp,      Nnn, 'WRITE'  )  ! write OSMOSIS outputs + ww (so must do here) to restarts 
     302                            CALL tra_ldf    ( kstp, Nbb, Nnn, ts, Nrhs )  ! lateral mixing 
     303 
     304                            CALL tra_zdf    ( kstp, Nbb, Nnn, Nrhs, ts, Naa  )  ! vertical mixing and after tracer fields 
     305         IF( ln_zdfnpc  )   CALL tra_npc    ( kstp,      Nnn, Nrhs, ts, Naa  )  ! update after fields by non-penetrative convection 
     306      END DO 
     307 
     308      IF( ln_tile ) CALL dom_tile( ntsi, ntsj, ntei, ntej, ktile = 0 ) ! Revert to tile over full domain 
    272309      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    273310      ! Set boundary conditions, time filter and swap time levels 
    … …  
    338375      IF( kstp == nit000 ) THEN                          ! 1st time step only 
    339376                                        CALL iom_close( numror )   ! close input  ocean restart file 
     377         IF( lrxios )                   CALL iom_context_finalize(      cr_ocerst_cxt         ) 
    340378         IF(lwm)                        CALL FLUSH    ( numond )   ! flush output namelist oce 
    341379         IF(lwm .AND. numoni /= -1 )    CALL FLUSH    ( numoni )   ! flush output namelist ice (if exist) 
    … …  
    353391      IF( kstp == nitend .OR. nstop > 0 ) THEN  
    354392                      CALL iom_context_finalize(      cxios_context          ) ! needed for XIOS+AGRIF 
    355          IF( lrxios ) CALL iom_context_finalize(      crxios_context         ) 
    356393         IF( ln_crs ) CALL iom_context_finalize( trim(cxios_context)//"_crs" ) !  
    357394      ENDIF 

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

    r12377 r14043  
    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 
    … …  
    6970   USE zdfphy          ! vertical physics manager      (zdf_phy_init routine) 
    7071   USE zdfosm  , ONLY : osm_rst, dyn_osm, tra_osm      ! OSMOSIS routines used in step.F90 
     72   USE zdfmfc          ! Mass FLux Convection routine used in step.F90 
    7173 
    7274   USE diu_layers      ! diurnal SST bulk and coolskin routines 

  • NEMO/branches/2020/dev_r13787_OSMOSIS_IMMERSE/src/OCE/stpMLF.F90

    r13237 r14043  
    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/dev_r13787_OSMOSIS_IMMERSE/src/OCE/timing.F90

    r13558 r14043  
    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.