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 11822 for NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE – NEMO

Ignore:
Timestamp:
2019-10-29T11:41:36+01:00 (5 years ago)
Author:
acc
Message:

Branch 2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps. Sette tested updates to branch to align with trunk changes between 10721 and 11740. Sette tests are passing but results differ from branch before these changes (except for GYRE_PISCES and VORTEX) and branch results already differed from trunk because of algorithmic fixes. Will need more checks to confirm correctness.

Location:
NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE
Files:
2 deleted
111 edited

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/ASM/asminc.F90

    r11480 r11822  
    149149      REWIND( numnam_ref )              ! Namelist nam_asminc in reference namelist : Assimilation increment 
    150150      READ  ( numnam_ref, nam_asminc, IOSTAT = ios, ERR = 901) 
    151 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nam_asminc in reference namelist', lwp ) 
     151901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nam_asminc in reference namelist' ) 
    152152      REWIND( numnam_cfg )              ! Namelist nam_asminc in configuration namelist : Assimilation increment 
    153153      READ  ( numnam_cfg, nam_asminc, IOSTAT = ios, ERR = 902 ) 
    154 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nam_asminc in configuration namelist', lwp ) 
     154902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nam_asminc in configuration namelist' ) 
    155155      IF(lwm) WRITE ( numond, nam_asminc ) 
    156156 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/BDY/bdy_oce.F90

    r10425 r11822  
    2222      INTEGER ,          DIMENSION(jpbgrd) ::  nblen 
    2323      INTEGER ,          DIMENSION(jpbgrd) ::  nblenrim 
     24      INTEGER ,          DIMENSION(jpbgrd) ::  nblenrim0 
    2425      INTEGER , POINTER, DIMENSION(:,:)    ::  nbi 
    2526      INTEGER , POINTER, DIMENSION(:,:)    ::  nbj 
    2627      INTEGER , POINTER, DIMENSION(:,:)    ::  nbr 
    2728      INTEGER , POINTER, DIMENSION(:,:)    ::  nbmap 
     29      INTEGER , POINTER, DIMENSION(:,:)    ::  ntreat 
    2830      REAL(wp), POINTER, DIMENSION(:,:)    ::  nbw 
    2931      REAL(wp), POINTER, DIMENSION(:,:)    ::  nbd 
    … …  
    4042   TYPE, PUBLIC ::   OBC_DATA     !: Storage for external data 
    4143      INTEGER          , DIMENSION(2)   ::  nread 
    42       LOGICAL                           ::  ll_ssh 
    43       LOGICAL                           ::  ll_u2d 
    44       LOGICAL                           ::  ll_v2d 
    45       LOGICAL                           ::  ll_u3d 
    46       LOGICAL                           ::  ll_v3d 
    47       LOGICAL                           ::  ll_tem 
    48       LOGICAL                           ::  ll_sal 
    49       LOGICAL                           ::  ll_fvl 
     44      LOGICAL                           ::  lneed_ssh 
     45      LOGICAL                           ::  lneed_dyn2d 
     46      LOGICAL                           ::  lneed_dyn3d 
     47      LOGICAL                           ::  lneed_tra 
     48      LOGICAL                           ::  lneed_ice 
    5049      REAL(wp), POINTER, DIMENSION(:)   ::  ssh 
    5150      REAL(wp), POINTER, DIMENSION(:)   ::  u2d 
    … …  
    5554      REAL(wp), POINTER, DIMENSION(:,:) ::  tem 
    5655      REAL(wp), POINTER, DIMENSION(:,:) ::  sal 
    57 #if defined key_si3 
    58       LOGICAL                           ::   ll_a_i 
    59       LOGICAL                           ::   ll_h_i 
    60       LOGICAL                           ::   ll_h_s 
    61       REAL(wp), POINTER, DIMENSION(:,:) ::   a_i    !: now ice leads fraction climatology 
    62       REAL(wp), POINTER, DIMENSION(:,:) ::   h_i    !: Now ice  thickness climatology 
    63       REAL(wp), POINTER, DIMENSION(:,:) ::   h_s    !: now snow thickness 
    64 #endif 
     56      REAL(wp), POINTER, DIMENSION(:,:) ::  a_i    !: now ice leads fraction climatology 
     57      REAL(wp), POINTER, DIMENSION(:,:) ::  h_i    !: Now ice  thickness climatology 
     58      REAL(wp), POINTER, DIMENSION(:,:) ::  h_s    !: now snow thickness 
     59      REAL(wp), POINTER, DIMENSION(:,:) ::  t_i    !: now ice  temperature 
     60      REAL(wp), POINTER, DIMENSION(:,:) ::  t_s    !: now snow temperature 
     61      REAL(wp), POINTER, DIMENSION(:,:) ::  tsu    !: now surf temperature 
     62      REAL(wp), POINTER, DIMENSION(:,:) ::  s_i    !: now ice  salinity 
     63      REAL(wp), POINTER, DIMENSION(:,:) ::  aip    !: now ice  pond concentration 
     64      REAL(wp), POINTER, DIMENSION(:,:) ::  hip    !: now ice  pond depth 
    6565#if defined key_top 
    6666      CHARACTER(LEN=20)                   :: cn_obc  !: type of boundary condition to apply 
    … …  
    7474   !! Namelist variables 
    7575   !!---------------------------------------------------------------------- 
     76   !                                                   !!** nambdy ** 
    7677   LOGICAL, PUBLIC            ::   ln_bdy                   !: Unstructured Ocean Boundary Condition 
    7778 
    … …  
    8586   ! 
    8687   INTEGER                    ::   nb_bdy                   !: number of open boundary sets 
    87    INTEGER                    ::   nb_jpk_bdy               !: number of levels in the bdy data (set < 0 if consistent with planned run) 
    8888   INTEGER, DIMENSION(jp_bdy) ::   nn_rimwidth              !: boundary rim width for Flow Relaxation Scheme 
    8989   INTEGER                    ::   nn_volctl                !: = 0 the total volume will have the variability of the surface Flux E-P  
    … …  
    108108   INTEGER , DIMENSION(jp_bdy)          ::   nn_ice_dta     !: = 0 use the initial state as bdy dta ;  
    109109                                                            !: = 1 read it in a NetCDF file 
    110    REAL(wp), DIMENSION(jp_bdy) ::   rn_ice_tem              !: choice of the temperature of incoming sea ice 
    111    REAL(wp), DIMENSION(jp_bdy) ::   rn_ice_sal              !: choice of the salinity    of incoming sea ice 
    112    REAL(wp), DIMENSION(jp_bdy) ::   rn_ice_age              !: choice of the age         of incoming sea ice 
     110   !  
     111   !                                                   !!** nambdy_dta ** 
     112   REAL(wp), DIMENSION(jp_bdy) ::   rice_tem                !: temperature of incoming sea ice 
     113   REAL(wp), DIMENSION(jp_bdy) ::   rice_sal                !: salinity    of incoming sea ice 
     114   REAL(wp), DIMENSION(jp_bdy) ::   rice_age                !: age         of incoming sea ice 
     115   REAL(wp), DIMENSION(jp_bdy) ::   rice_apnd               !: pond conc.  of incoming sea ice 
     116   REAL(wp), DIMENSION(jp_bdy) ::   rice_hpnd               !: pond thick. of incoming sea ice 
    113117   ! 
    114     
    115118   !!---------------------------------------------------------------------- 
    116119   !! Global variables 
    … …  
    128131   INTEGER,  DIMENSION(jp_bdy)                     ::   nn_dta            !: =0 => *all* data is set to initial conditions 
    129132                                                                          !: =1 => some data to be read in from data files 
    130    REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET ::   dta_global        !: workspace for reading in global data arrays (unstr.  bdy) 
    131    REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET ::   dta_global_z      !: workspace for reading in global depth arrays (unstr.  bdy) 
    132    REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET ::   dta_global_dz     !: workspace for reading in global depth arrays (unstr.  bdy) 
    133    REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET ::   dta_global2       !: workspace for reading in global data arrays (struct. bdy) 
    134    REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET ::   dta_global2_z     !: workspace for reading in global depth arrays (struct. bdy) 
    135    REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET ::   dta_global2_dz    !: workspace for reading in global depth arrays (struct. bdy) 
    136133!$AGRIF_DO_NOT_TREAT 
    137134   TYPE(OBC_INDEX), DIMENSION(jp_bdy), TARGET      ::   idx_bdy           !: bdy indices (local process) 
    138135   TYPE(OBC_DATA) , DIMENSION(jp_bdy), TARGET      ::   dta_bdy           !: bdy external data (local process) 
    139136!$AGRIF_END_DO_NOT_TREAT 
     137   LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) ::   lsend_bdy      !: mark needed communication for given boundary, grid and neighbour 
     138   LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) ::   lrecv_bdy      !:  when searching in any direction 
     139   LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) ::   lsend_bdyint   !: mark needed communication for given boundary, grid and neighbour 
     140   LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) ::   lrecv_bdyint   !:  when searching towards the interior of the computational domain 
     141   LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) ::   lsend_bdyext   !: mark needed communication for given boundary, grid and neighbour 
     142   LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) ::   lrecv_bdyext   !:  when searching towards the exterior of the computational domain 
    140143   !!---------------------------------------------------------------------- 
    141144   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/BDY/bdydta.F90

    r11480 r11822  
    4343   PUBLIC   bdy_dta_init     ! routine called by nemogcm.F90 
    4444 
    45    INTEGER, ALLOCATABLE, DIMENSION(:)   ::   nb_bdy_fld        ! Number of fields to update for each boundary set. 
    46    INTEGER                              ::   nb_bdy_fld_sum    ! Total number of fields to update for all boundary sets. 
    47    LOGICAL,           DIMENSION(jp_bdy) ::   ln_full_vel_array ! =T => full velocities in 3D boundary conditions 
    48                                                                ! =F => baroclinic velocities in 3D boundary conditions 
     45   INTEGER , PARAMETER ::   jpbdyfld  = 16    ! maximum number of files to read  
     46   INTEGER , PARAMETER ::   jp_bdyssh = 1     !  
     47   INTEGER , PARAMETER ::   jp_bdyu2d = 2     !  
     48   INTEGER , PARAMETER ::   jp_bdyv2d = 3     ! 
     49   INTEGER , PARAMETER ::   jp_bdyu3d = 4     ! 
     50   INTEGER , PARAMETER ::   jp_bdyv3d = 5     ! 
     51   INTEGER , PARAMETER ::   jp_bdytem = 6     !  
     52   INTEGER , PARAMETER ::   jp_bdysal = 7     !  
     53   INTEGER , PARAMETER ::   jp_bdya_i = 8     !  
     54   INTEGER , PARAMETER ::   jp_bdyh_i = 9     !  
     55   INTEGER , PARAMETER ::   jp_bdyh_s = 10    !  
     56   INTEGER , PARAMETER ::   jp_bdyt_i = 11    !  
     57   INTEGER , PARAMETER ::   jp_bdyt_s = 12    !  
     58   INTEGER , PARAMETER ::   jp_bdytsu = 13    !  
     59   INTEGER , PARAMETER ::   jp_bdys_i = 14    !  
     60   INTEGER , PARAMETER ::   jp_bdyaip = 15    !  
     61   INTEGER , PARAMETER ::   jp_bdyhip = 16    !  
     62#if ! defined key_si3 
     63   INTEGER , PARAMETER ::   jpl = 1 
     64#endif 
     65 
    4966!$AGRIF_DO_NOT_TREAT 
    50    TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:), TARGET ::   bf        ! structure of input fields (file informations, fields read) 
     67   TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:,:), TARGET ::   bf   ! structure of input fields (file informations, fields read) 
    5168!$AGRIF_END_DO_NOT_TREAT 
    52    TYPE(MAP_POINTER), ALLOCATABLE, DIMENSION(:) :: nbmap_ptr   ! array of pointers to nbmap 
    53  
    54 #if defined key_si3 
    55    INTEGER ::   nice_cat                      ! number of categories in the input file 
    56    INTEGER ::   jfld_hti, jfld_hts, jfld_ai   ! indices of ice thickness, snow thickness and concentration in bf structure 
    57    INTEGER, DIMENSION(jp_bdy) :: jfld_htit, jfld_htst, jfld_ait 
    58 #endif 
    5969 
    6070   !!---------------------------------------------------------------------- 
    … …  
    6575CONTAINS 
    6676 
    67       SUBROUTINE bdy_dta( kt, Kmm, time_offset ) 
     77   SUBROUTINE bdy_dta( kt, Kmm, kit, kt_offset ) 
    6878      !!---------------------------------------------------------------------- 
    6979      !!                   ***  SUBROUTINE bdy_dta  *** 
    … …  
    7686      INTEGER, INTENT(in)           ::   kt           ! ocean time-step index  
    7787      INTEGER, INTENT(in)           ::   Kmm          ! ocean time level index 
    78       INTEGER, INTENT(in), OPTIONAL ::   time_offset  ! time offset in units of timesteps. NB. if jit 
     88      INTEGER, INTENT(in), OPTIONAL ::   kit          ! subcycle time-step index (for timesplitting option) 
     89      INTEGER, INTENT(in), OPTIONAL ::   kt_offset    ! time offset in units of timesteps. NB. if kit 
    7990      !                                               ! is present then units = subcycle timesteps. 
    80       !                                               ! time_offset = 0 => get data at "now" time level 
    81       !                                               ! time_offset = -1 => get data at "before" time level 
    82       !                                               ! time_offset = +1 => get data at "after" time level 
     91      !                                               ! kt_offset = 0 => get data at "now" time level 
     92      !                                               ! kt_offset = -1 => get data at "before" time level 
     93      !                                               ! kt_offset = +1 => get data at "after" time level 
    8394      !                                               ! etc. 
    8495      ! 
    85       INTEGER ::  jbdy, jfld, jstart, jend, ib, jl  ! dummy loop indices 
    86       INTEGER ::  ii, ij, ik, igrd                  ! local integers 
    87       INTEGER,          DIMENSION(jpbgrd) ::   ilen1  
    88       INTEGER, POINTER, DIMENSION(:)      ::   nblen, nblenrim  ! short cuts 
    89       TYPE(OBC_DATA), POINTER             ::   dta              ! short cut 
     96      INTEGER ::  jbdy, jfld, jstart, jend, ib, jl    ! dummy loop indices 
     97      INTEGER ::  ii, ij, ik, igrd, ipl               ! local integers 
     98      INTEGER,   DIMENSION(jpbgrd)     ::   ilen1  
     99      INTEGER,   DIMENSION(:), POINTER ::   nblen, nblenrim  ! short cuts 
     100      TYPE(OBC_DATA)         , POINTER ::   dta_alias        ! short cut 
     101      TYPE(FLD), DIMENSION(:), POINTER ::   bf_alias 
    90102      !!--------------------------------------------------------------------------- 
    91103      ! 
    … …  
    94106      ! Initialise data arrays once for all from initial conditions where required 
    95107      !--------------------------------------------------------------------------- 
    96       IF( kt == nit000 ) THEN 
     108      IF( kt == nit000 .AND. .NOT.PRESENT(kit) ) THEN 
    97109 
    98110         ! Calculate depth-mean currents 
    99111         !----------------------------- 
    100           
     112 
    101113         DO jbdy = 1, nb_bdy 
    102114            ! 
    103115            nblen    => idx_bdy(jbdy)%nblen 
    104116            nblenrim => idx_bdy(jbdy)%nblenrim 
    105             dta      => dta_bdy(jbdy) 
    106117            ! 
    107118            IF( nn_dyn2d_dta(jbdy) == 0 ) THEN  
    108119               ilen1(:) = nblen(:) 
    109                IF( dta%ll_ssh ) THEN  
     120               IF( dta_bdy(jbdy)%lneed_ssh ) THEN  
    110121                  igrd = 1 
    111122                  DO ib = 1, ilen1(igrd) 
    … …  
    113124                     ij = idx_bdy(jbdy)%nbj(ib,igrd) 
    114125                     dta_bdy(jbdy)%ssh(ib) = ssh(ii,ij,Kmm) * tmask(ii,ij,1)          
    115                   END DO  
    116                ENDIF 
    117                IF( dta%ll_u2d ) THEN  
     126                  END DO 
     127               ENDIF 
     128               IF( dta_bdy(jbdy)%lneed_dyn2d) THEN  
    118129                  igrd = 2 
    119130                  DO ib = 1, ilen1(igrd) 
    … …  
    121132                     ij = idx_bdy(jbdy)%nbj(ib,igrd) 
    122133                     dta_bdy(jbdy)%u2d(ib) = uu_b(ii,ij,Kmm) * umask(ii,ij,1)          
    123                   END DO  
    124                ENDIF 
    125                IF( dta%ll_v2d ) THEN  
     134                  END DO 
    126135                  igrd = 3 
    127136                  DO ib = 1, ilen1(igrd) 
    … …  
    129138                     ij = idx_bdy(jbdy)%nbj(ib,igrd) 
    130139                     dta_bdy(jbdy)%v2d(ib) = vv_b(ii,ij,Kmm) * vmask(ii,ij,1)          
    131                   END DO  
     140                  END DO 
    132141               ENDIF 
    133142            ENDIF 
    … …  
    135144            IF( nn_dyn3d_dta(jbdy) == 0 ) THEN  
    136145               ilen1(:) = nblen(:) 
    137                IF( dta%ll_u3d ) THEN  
     146               IF( dta_bdy(jbdy)%lneed_dyn3d ) THEN  
    138147                  igrd = 2  
    139148                  DO ib = 1, ilen1(igrd) 
    … …  
    143152                        dta_bdy(jbdy)%u3d(ib,ik) =  ( uu(ii,ij,ik,Kmm) - uu_b(ii,ij,Kmm) ) * umask(ii,ij,ik)          
    144153                     END DO 
    145                   END DO  
    146                ENDIF 
    147                IF( dta%ll_v3d ) THEN  
     154                  END DO 
    148155                  igrd = 3  
    149156                  DO ib = 1, ilen1(igrd) 
    … …  
    152159                        ij = idx_bdy(jbdy)%nbj(ib,igrd) 
    153160                        dta_bdy(jbdy)%v3d(ib,ik) =  ( vv(ii,ij,ik,Kmm) - vv_b(ii,ij,Kmm) ) * vmask(ii,ij,ik)          
    154                         END DO 
    155                   END DO  
     161                     END DO 
     162                  END DO 
    156163               ENDIF 
    157164            ENDIF 
    … …  
    159166            IF( nn_tra_dta(jbdy) == 0 ) THEN  
    160167               ilen1(:) = nblen(:) 
    161                IF( dta%ll_tem ) THEN 
     168               IF( dta_bdy(jbdy)%lneed_tra ) THEN 
    162169                  igrd = 1  
    163170                  DO ib = 1, ilen1(igrd) 
    … …  
    165172                        ii = idx_bdy(jbdy)%nbi(ib,igrd) 
    166173                        ij = idx_bdy(jbdy)%nbj(ib,igrd) 
    167                         dta_bdy(jbdy)%tem(ib,ik) = ts(ii,ij,ik,jp_tem,Kmm) * tmask(ii,ij,ik)          
     174                        dta_bdy(jbdy)%tem(ib,ik) = ts(ii,ij,ik,jp_bdytem,Kmm) * tmask(ii,ij,ik)          
     175                        dta_bdy(jbdy)%sal(ib,ik) = ts(ii,ij,ik,jp_bdysal,Kmm) * tmask(ii,ij,ik)          
    168176                     END DO 
    169                   END DO  
    170                ENDIF 
    171                IF( dta%ll_sal ) THEN 
    172                   igrd = 1  
    173                   DO ib = 1, ilen1(igrd) 
    174                      DO ik = 1, jpkm1 
    175                         ii = idx_bdy(jbdy)%nbi(ib,igrd) 
    176                         ij = idx_bdy(jbdy)%nbj(ib,igrd) 
    177                         dta_bdy(jbdy)%sal(ib,ik) = ts(ii,ij,ik,jp_sal,Kmm) * tmask(ii,ij,ik)          
    178                      END DO 
    179                   END DO  
     177                  END DO 
    180178               ENDIF 
    181179            ENDIF 
    … …  
    184182            IF( nn_ice_dta(jbdy) == 0 ) THEN    ! set ice to initial values 
    185183               ilen1(:) = nblen(:) 
    186                IF( dta%ll_a_i ) THEN 
     184               IF( dta_bdy(jbdy)%lneed_ice ) THEN 
    187185                  igrd = 1    
    188186                  DO jl = 1, jpl 
    … …  
    190188                        ii = idx_bdy(jbdy)%nbi(ib,igrd) 
    191189                        ij = idx_bdy(jbdy)%nbj(ib,igrd) 
    192                         dta_bdy(jbdy)%a_i (ib,jl) =  a_i(ii,ij,jl) * tmask(ii,ij,1)  
    193                      END DO 
    194                   END DO 
    195                ENDIF 
    196                IF( dta%ll_h_i ) THEN 
    197                   igrd = 1    
    198                   DO jl = 1, jpl 
    199                      DO ib = 1, ilen1(igrd) 
    200                         ii = idx_bdy(jbdy)%nbi(ib,igrd) 
    201                         ij = idx_bdy(jbdy)%nbj(ib,igrd) 
    202                         dta_bdy(jbdy)%h_i (ib,jl) =  h_i(ii,ij,jl) * tmask(ii,ij,1)  
    203                      END DO 
    204                   END DO 
    205                ENDIF 
    206                IF( dta%ll_h_s ) THEN 
    207                   igrd = 1    
    208                   DO jl = 1, jpl 
    209                      DO ib = 1, ilen1(igrd) 
    210                         ii = idx_bdy(jbdy)%nbi(ib,igrd) 
    211                         ij = idx_bdy(jbdy)%nbj(ib,igrd) 
    212                         dta_bdy(jbdy)%h_s (ib,jl) =  h_s(ii,ij,jl) * tmask(ii,ij,1)  
     190                        dta_bdy(jbdy)%a_i(ib,jl) =  a_i (ii,ij,jl) * tmask(ii,ij,1)  
     191                        dta_bdy(jbdy)%h_i(ib,jl) =  h_i (ii,ij,jl) * tmask(ii,ij,1)  
     192                        dta_bdy(jbdy)%h_s(ib,jl) =  h_s (ii,ij,jl) * tmask(ii,ij,1)  
     193                        dta_bdy(jbdy)%t_i(ib,jl) =  SUM(t_i (ii,ij,:,jl)) * r1_nlay_i * tmask(ii,ij,1)  
     194                        dta_bdy(jbdy)%t_s(ib,jl) =  SUM(t_s (ii,ij,:,jl)) * r1_nlay_s * tmask(ii,ij,1) 
     195                        dta_bdy(jbdy)%tsu(ib,jl) =  t_su(ii,ij,jl) * tmask(ii,ij,1)  
     196                        dta_bdy(jbdy)%s_i(ib,jl) =  s_i (ii,ij,jl) * tmask(ii,ij,1) 
     197                        ! melt ponds 
     198                        dta_bdy(jbdy)%aip(ib,jl) =  a_ip(ii,ij,jl) * tmask(ii,ij,1)  
     199                        dta_bdy(jbdy)%hip(ib,jl) =  h_ip(ii,ij,jl) * tmask(ii,ij,1)  
    213200                     END DO 
    214201                  END DO 
    … …  
    222209      ! update external data from files 
    223210      !-------------------------------- 
    224       
    225       jstart = 1 
    226       DO jbdy = 1, nb_bdy    
    227          dta => dta_bdy(jbdy) 
    228          IF( nn_dta(jbdy) == 1 ) THEN ! skip this bit if no external data required 
    229             IF (cn_tra(jbdy) == 'runoff') then      ! runoff condition 
    230                jend = nb_bdy_fld(jbdy) 
    231                CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend),  & 
    232                     & map=nbmap_ptr(jstart:jend), kt_offset=time_offset ) 
    233                ! 
    234                igrd = 2                      ! zonal velocity 
    235                DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 
    236                   ii   = idx_bdy(jbdy)%nbi(ib,igrd) 
    237                   ij   = idx_bdy(jbdy)%nbj(ib,igrd) 
    238                   dta%u2d(ib) = dta%u2d(ib) / ( e2u(ii,ij) * hu_0(ii,ij) ) 
     211 
     212      DO jbdy = 1, nb_bdy 
     213 
     214         dta_alias => dta_bdy(jbdy) 
     215         bf_alias  => bf(:,jbdy) 
     216 
     217         ! read/update all bdy data 
     218         ! ------------------------ 
     219         CALL fld_read( kt, 1, bf_alias, kit = kit, kt_offset = kt_offset ) 
     220         ! apply some corrections in some specific cases... 
     221         ! -------------------------------------------------- 
     222         ! 
     223         ! if runoff condition: change river flow we read (in m3/s) into barotropic velocity (m/s) 
     224         IF( cn_tra(jbdy) == 'runoff' .AND. TRIM(bf_alias(jp_bdyu2d)%clrootname) /= 'NOT USED' ) THEN   ! runoff and we read u/v2d 
     225            ! 
     226            igrd = 2                      ! zonal flow (m3/s) to barotropic zonal velocity (m/s) 
     227            DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 
     228               ii   = idx_bdy(jbdy)%nbi(ib,igrd) 
     229               ij   = idx_bdy(jbdy)%nbj(ib,igrd) 
     230               dta_alias%u2d(ib) = dta_alias%u2d(ib) / ( e2u(ii,ij) * hu_0(ii,ij) ) 
     231            END DO 
     232            igrd = 3                      ! meridional flow (m3/s) to barotropic meridional velocity (m/s) 
     233            DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 
     234               ii   = idx_bdy(jbdy)%nbi(ib,igrd) 
     235               ij   = idx_bdy(jbdy)%nbj(ib,igrd) 
     236               dta_alias%v2d(ib) = dta_alias%v2d(ib) / ( e1v(ii,ij) * hv_0(ii,ij) ) 
     237            END DO 
     238         ENDIF 
     239 
     240         ! tidal harmonic forcing ONLY: initialise arrays 
     241         IF( nn_dyn2d_dta(jbdy) == 2 ) THEN   ! we did not read ssh, u/v2d  
     242            IF( dta_alias%lneed_ssh   ) dta_alias%ssh(:) = 0._wp 
     243            IF( dta_alias%lneed_dyn2d ) dta_alias%u2d(:) = 0._wp 
     244            IF( dta_alias%lneed_dyn2d ) dta_alias%v2d(:) = 0._wp 
     245         ENDIF 
     246 
     247         ! If full velocities in boundary data, then split it into barotropic and baroclinic component 
     248         IF( bf_alias(jp_bdyu3d)%ltotvel ) THEN     ! if we read 3D total velocity (can be true only if u3d was read) 
     249            ! 
     250            igrd = 2                       ! zonal velocity 
     251            dta_alias%u2d(:) = 0._wp       ! compute barotrope zonal velocity and put it in u2d 
     252            DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 
     253               ii   = idx_bdy(jbdy)%nbi(ib,igrd) 
     254               ij   = idx_bdy(jbdy)%nbj(ib,igrd) 
     255               DO ik = 1, jpkm1 
     256                  dta_alias%u2d(ib) = dta_alias%u2d(ib) + e3u(ii,ij,ik,Kmm) * umask(ii,ij,ik) * dta_alias%u3d(ib,ik) 
    239257               END DO 
    240                ! 
    241                igrd = 3                      ! meridional velocity 
    242                DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 
    243                   ii   = idx_bdy(jbdy)%nbi(ib,igrd) 
    244                   ij   = idx_bdy(jbdy)%nbj(ib,igrd) 
    245                   dta%v2d(ib) = dta%v2d(ib) / ( e1v(ii,ij) * hv_0(ii,ij) ) 
     258               dta_alias%u2d(ib) =  dta_alias%u2d(ib) * r1_hu(ii,ij,Kmm) 
     259               DO ik = 1, jpkm1            ! compute barocline zonal velocity and put it in u3d 
     260                  dta_alias%u3d(ib,ik) = dta_alias%u3d(ib,ik) - dta_alias%u2d(ib) 
    246261               END DO 
    247             ELSE 
    248                IF( nn_dyn2d_dta(jbdy) == 2 ) THEN ! tidal harmonic forcing ONLY: initialise arrays 
    249                   IF( dta%ll_ssh ) dta%ssh(:) = 0._wp 
    250                   IF( dta%ll_u2d ) dta%u2d(:) = 0._wp 
    251                   IF( dta%ll_v2d ) dta%v2d(:) = 0._wp 
    252                ENDIF 
    253                IF( dta%nread(1) .gt. 0 ) THEN ! update external data 
    254                   jend = jstart + dta%nread(1) - 1 
    255                   CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), & 
    256                        & map=nbmap_ptr(jstart:jend), kt_offset=time_offset, jpk_bdy=nb_jpk_bdy,   & 
    257                        & fvl=ln_full_vel_array(jbdy), Kmm=Kmm ) 
    258                ENDIF 
    259                ! If full velocities in boundary data then split into barotropic and baroclinic data 
    260                IF( ln_full_vel_array(jbdy) .and.                                             & 
    261                     & ( nn_dyn2d_dta(jbdy) == 1 .OR. nn_dyn2d_dta(jbdy) == 3 .OR. & 
    262                     &   nn_dyn3d_dta(jbdy) == 1 ) ) THEN 
    263                   igrd = 2                      ! zonal velocity 
    264                   dta%u2d(:) = 0._wp 
    265                   DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 
    266                      ii   = idx_bdy(jbdy)%nbi(ib,igrd) 
    267                      ij   = idx_bdy(jbdy)%nbj(ib,igrd) 
    268                      DO ik = 1, jpkm1 
    269                         dta%u2d(ib) = dta%u2d(ib) & 
    270                              &                       + e3u(ii,ij,ik,Kmm) * umask(ii,ij,ik) * dta%u3d(ib,ik) 
    271                      END DO 
    272                      dta%u2d(ib) =  dta%u2d(ib) * r1_hu(ii,ij,Kmm) 
    273                      DO ik = 1, jpkm1 
    274                         dta%u3d(ib,ik) = dta%u3d(ib,ik) - dta%u2d(ib) 
    275                      END DO 
    276                   END DO 
    277                   igrd = 3                      ! meridional velocity 
    278                   dta%v2d(:) = 0._wp 
    279                   DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 
    280                      ii   = idx_bdy(jbdy)%nbi(ib,igrd) 
    281                      ij   = idx_bdy(jbdy)%nbj(ib,igrd) 
    282                      DO ik = 1, jpkm1 
    283                         dta%v2d(ib) = dta%v2d(ib) & 
    284                              &                       + e3v(ii,ij,ik,Kmm) * vmask(ii,ij,ik) * dta%v3d(ib,ik) 
    285                      END DO 
    286                      dta%v2d(ib) =  dta%v2d(ib) * r1_hv(ii,ij,Kmm) 
    287                      DO ik = 1, jpkm1 
    288                         dta%v3d(ib,ik) = dta%v3d(ib,ik) - dta%v2d(ib) 
    289                      END DO 
    290                   END DO 
    291                ENDIF 
    292  
    293             ENDIF 
     262            END DO 
     263            igrd = 3                       ! meridional velocity 
     264            dta_alias%v2d(:) = 0._wp       ! compute barotrope meridional velocity and put it in v2d 
     265            DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 
     266               ii   = idx_bdy(jbdy)%nbi(ib,igrd) 
     267               ij   = idx_bdy(jbdy)%nbj(ib,igrd) 
     268               DO ik = 1, jpkm1 
     269                  dta_alias%v2d(ib) = dta_alias%v2d(ib) + e3v(ii,ij,ik,Kmm) * vmask(ii,ij,ik) * dta_alias%v3d(ib,ik) 
     270               END DO 
     271               dta_alias%v2d(ib) =  dta_alias%v2d(ib) * r1_hv(ii,ij,Kmm) 
     272               DO ik = 1, jpkm1            ! compute barocline meridional velocity and put it in v3d 
     273                  dta_alias%v3d(ib,ik) = dta_alias%v3d(ib,ik) - dta_alias%v2d(ib) 
     274               END DO 
     275            END DO 
     276         ENDIF   ! ltotvel 
     277 
     278         ! update tidal harmonic forcing 
     279         IF( PRESENT(kit) .AND. nn_dyn2d_dta(jbdy) .GE. 2 ) THEN 
     280            CALL bdytide_update( kt = kt, idx = idx_bdy(jbdy), dta = dta_alias, td = tides(jbdy),   &  
     281               &                 kit = kit, kt_offset = kt_offset ) 
     282         ENDIF 
     283 
     284         !  atm surface pressure : add inverted barometer effect to ssh if it was read 
     285         IF ( ln_apr_obc .AND. TRIM(bf_alias(jp_bdyssh)%clrootname) /= 'NOT USED' ) THEN 
     286            igrd = 1 
     287            DO ib = 1, idx_bdy(jbdy)%nblenrim(igrd)   ! ssh is used only on the rim 
     288               ii   = idx_bdy(jbdy)%nbi(ib,igrd) 
     289               ij   = idx_bdy(jbdy)%nbj(ib,igrd) 
     290               dta_alias%ssh(ib) = dta_alias%ssh(ib) + ssh_ib(ii,ij) 
     291            END DO 
     292         ENDIF 
     293 
    294294#if defined key_si3 
     295         IF( dta_alias%lneed_ice ) THEN 
     296            ! fill temperature and salinity arrays 
     297            IF( TRIM(bf_alias(jp_bdyt_i)%clrootname) == 'NOT USED' )   bf_alias(jp_bdyt_i)%fnow(:,1,:) = rice_tem (jbdy) 
     298            IF( TRIM(bf_alias(jp_bdyt_s)%clrootname) == 'NOT USED' )   bf_alias(jp_bdyt_s)%fnow(:,1,:) = rice_tem (jbdy) 
     299            IF( TRIM(bf_alias(jp_bdytsu)%clrootname) == 'NOT USED' )   bf_alias(jp_bdytsu)%fnow(:,1,:) = rice_tem (jbdy) 
     300            IF( TRIM(bf_alias(jp_bdys_i)%clrootname) == 'NOT USED' )   bf_alias(jp_bdys_i)%fnow(:,1,:) = rice_sal (jbdy) 
     301            IF( TRIM(bf_alias(jp_bdyaip)%clrootname) == 'NOT USED' )   bf_alias(jp_bdyaip)%fnow(:,1,:) = rice_apnd(jbdy) * & ! rice_apnd is the pond fraction 
     302               &                                                                         bf_alias(jp_bdya_i)%fnow(:,1,:)     !   ( a_ip = rice_apnd * a_i ) 
     303            IF( TRIM(bf_alias(jp_bdyhip)%clrootname) == 'NOT USED' )   bf_alias(jp_bdyhip)%fnow(:,1,:) = rice_hpnd(jbdy) 
     304            ! if T_su is read and not T_i, set T_i = (T_su + T_freeze)/2 
     305            IF( TRIM(bf_alias(jp_bdytsu)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdyt_i)%clrootname) == 'NOT USED' ) & 
     306               &   bf_alias(jp_bdyt_i)%fnow(:,1,:) = 0.5_wp * ( bf_alias(jp_bdytsu)%fnow(:,1,:) + 271.15 ) 
     307            ! if T_su is read and not T_s, set T_s = T_su 
     308            IF( TRIM(bf_alias(jp_bdytsu)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdyt_s)%clrootname) == 'NOT USED' ) & 
     309               &   bf_alias(jp_bdyt_s)%fnow(:,1,:) = bf_alias(jp_bdytsu)%fnow(:,1,:) 
     310            ! if T_s is read and not T_su, set T_su = T_s 
     311            IF( TRIM(bf_alias(jp_bdyt_s)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdytsu)%clrootname) == 'NOT USED' ) & 
     312               &   bf_alias(jp_bdytsu)%fnow(:,1,:) = bf_alias(jp_bdyt_s)%fnow(:,1,:) 
     313            ! if T_s is read and not T_i, set T_i = (T_s + T_freeze)/2 
     314            IF( TRIM(bf_alias(jp_bdyt_s)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdyt_i)%clrootname) == 'NOT USED' ) & 
     315               &   bf_alias(jp_bdyt_i)%fnow(:,1,:) = 0.5_wp * ( bf_alias(jp_bdyt_s)%fnow(:,1,:) + 271.15 ) 
     316 
     317            ! make sure ponds = 0 if no ponds scheme 
     318            IF ( .NOT.ln_pnd ) THEN 
     319               bf_alias(jp_bdyaip)%fnow(:,1,:) = 0._wp 
     320               bf_alias(jp_bdyhip)%fnow(:,1,:) = 0._wp 
     321            ENDIF 
     322             
    295323            ! convert N-cat fields (input) into jpl-cat (output) 
    296             IF( cn_ice(jbdy) /= 'none' .AND. nn_ice_dta(jbdy) == 1 ) THEN 
    297                jfld_hti = jfld_htit(jbdy) 
    298                jfld_hts = jfld_htst(jbdy) 
    299                jfld_ai  = jfld_ait(jbdy) 
    300                IF    ( jpl /= 1 .AND. nice_cat == 1 ) THEN                       ! case input cat = 1 
    301                   CALL ice_var_itd ( bf(jfld_hti)%fnow(:,1,1), bf(jfld_hts)%fnow(:,1,1), bf(jfld_ai)%fnow(:,1,1), & 
    302                        &               dta_bdy(jbdy)%h_i     , dta_bdy(jbdy)%h_s     , dta_bdy(jbdy)%a_i    ) 
    303                ELSEIF( jpl /= 1 .AND. nice_cat /= 1 .AND. nice_cat /= jpl ) THEN ! case input cat /=1 and /=jpl 
    304                   CALL ice_var_itd2( bf(jfld_hti)%fnow(:,1,:), bf(jfld_hts)%fnow(:,1,:), bf(jfld_ai)%fnow(:,1,:), & 
    305                        &               dta_bdy(jbdy)%h_i     , dta_bdy(jbdy)%h_s     , dta_bdy(jbdy)%a_i    ) 
    306                ENDIF 
    307             ENDIF 
     324            ipl = SIZE(bf_alias(jp_bdya_i)%fnow, 3)             
     325            IF( ipl /= jpl ) THEN      ! ice: convert N-cat fields (input) into jpl-cat (output) 
     326               CALL ice_var_itd( bf_alias(jp_bdyh_i)%fnow(:,1,:), bf_alias(jp_bdyh_s)%fnow(:,1,:), bf_alias(jp_bdya_i)%fnow(:,1,:), & 
     327                  &              dta_alias%h_i                  , dta_alias%h_s                  , dta_alias%a_i                  , & 
     328                  &              bf_alias(jp_bdyt_i)%fnow(:,1,:), bf_alias(jp_bdyt_s)%fnow(:,1,:), & 
     329                  &              bf_alias(jp_bdytsu)%fnow(:,1,:), bf_alias(jp_bdys_i)%fnow(:,1,:), & 
     330                  &              bf_alias(jp_bdyaip)%fnow(:,1,:), bf_alias(jp_bdyhip)%fnow(:,1,:), & 
     331                  &              dta_alias%t_i                  , dta_alias%t_s                  , & 
     332                  &              dta_alias%tsu                  , dta_alias%s_i                  , & 
     333                  &              dta_alias%aip                  , dta_alias%hip ) 
     334            ENDIF 
     335         ENDIF 
    308336#endif 
    309             jstart = jstart + dta%nread(1) 
    310          ENDIF    ! nn_dta(jbdy) = 1 
    311337      END DO  ! jbdy 
    312  
    313       IF ( ln_apr_obc ) THEN 
    314          DO jbdy = 1, nb_bdy 
    315             IF (cn_tra(jbdy) /= 'runoff')THEN 
    316                igrd = 1                      ! meridional velocity 
    317                DO ib = 1, idx_bdy(jbdy)%nblenrim(igrd) 
    318                   ii   = idx_bdy(jbdy)%nbi(ib,igrd) 
    319                   ij   = idx_bdy(jbdy)%nbj(ib,igrd) 
    320                   dta_bdy(jbdy)%ssh(ib) = dta_bdy(jbdy)%ssh(ib) + ssh_ib(ii,ij) 
    321                END DO 
    322             ENDIF 
    323          END DO 
    324       ENDIF 
    325338 
    326339      IF ( ln_tide ) THEN 
    327340         IF (ln_dynspg_ts) THEN      ! Fill temporary arrays with slow-varying bdy data                            
    328             DO jbdy = 1, nb_bdy    ! Tidal component added in ts loop 
    329                IF ( nn_dyn2d_dta(jbdy) .ge. 2 ) THEN 
     341            DO jbdy = 1, nb_bdy      ! Tidal component added in ts loop 
     342               IF ( nn_dyn2d_dta(jbdy) .GE. 2 ) THEN 
    330343                  nblen => idx_bdy(jbdy)%nblen 
    331344                  nblenrim => idx_bdy(jbdy)%nblenrim 
    332                   IF( cn_dyn2d(jbdy) == 'frs' ) THEN; ilen1(:)=nblen(:) ; ELSE ; ilen1(:)=nblenrim(:) ; ENDIF  
    333                   IF ( dta_bdy(jbdy)%ll_ssh ) dta_bdy_s(jbdy)%ssh(1:ilen1(1)) = dta_bdy(jbdy)%ssh(1:ilen1(1)) 
    334                   IF ( dta_bdy(jbdy)%ll_u2d ) dta_bdy_s(jbdy)%u2d(1:ilen1(2)) = dta_bdy(jbdy)%u2d(1:ilen1(2)) 
    335                   IF ( dta_bdy(jbdy)%ll_v2d ) dta_bdy_s(jbdy)%v2d(1:ilen1(3)) = dta_bdy(jbdy)%v2d(1:ilen1(3)) 
    336                ENDIF 
    337             END DO 
    338          ELSE ! Add tides if not split-explicit free surface else this is done in ts loop 
    339             ! 
    340             CALL bdy_dta_tides( kt=kt, time_offset=time_offset ) 
    341          ENDIF 
    342       ENDIF 
    343  
    344       ! 
    345       IF( ln_timing )   CALL timing_stop('bdy_dta') 
    346       ! 
    347    END SUBROUTINE bdy_dta 
     345                  IF( cn_dyn2d(jbdy) == 'frs' ) THEN ; ilen1(:)=nblen(:) ; ELSE ; ilen1(:)=nblenrim(:) ; ENDIF  
     346                     IF ( dta_bdy(jbdy)%lneed_ssh   ) dta_bdy_s(jbdy)%ssh(1:ilen1(1)) = dta_bdy(jbdy)%ssh(1:ilen1(1)) 
     347                     IF ( dta_bdy(jbdy)%lneed_dyn2d ) dta_bdy_s(jbdy)%u2d(1:ilen1(2)) = dta_bdy(jbdy)%u2d(1:ilen1(2)) 
     348                     IF ( dta_bdy(jbdy)%lneed_dyn2d ) dta_bdy_s(jbdy)%v2d(1:ilen1(3)) = dta_bdy(jbdy)%v2d(1:ilen1(3)) 
     349                  ENDIF 
     350               END DO 
     351            ELSE ! Add tides if not split-explicit free surface else this is done in ts loop 
     352               ! 
     353               CALL bdy_dta_tides( kt=kt, kt_offset=kt_offset ) 
     354            ENDIF 
     355         ENDIF 
     356         ! 
     357         IF( ln_timing )   CALL timing_stop('bdy_dta') 
     358         ! 
     359      END SUBROUTINE bdy_dta 
    348360 
    349361 
    … …  
    358370      !!                 
    359371      !!---------------------------------------------------------------------- 
    360       INTEGER ::   jbdy, jfld, jstart, jend, ierror, ios     ! Local integers 
     372      INTEGER ::   jbdy, jfld    ! Local integers 
     373      INTEGER ::   ierror, ios     !  
    361374      ! 
     375      CHARACTER(len=3)                       ::   cl3           !  
    362376      CHARACTER(len=100)                     ::   cn_dir        ! Root directory for location of data files 
    363       CHARACTER(len=100), DIMENSION(nb_bdy)  ::   cn_dir_array  ! Root directory for location of data files 
    364       CHARACTER(len = 256)::   clname                           ! temporary file name 
    365377      LOGICAL                                ::   ln_full_vel   ! =T => full velocities in 3D boundary data 
    366378      !                                                         ! =F => baroclinic velocities in 3D boundary data 
    367       INTEGER                                ::   ilen_global   ! Max length required for global bdy dta arrays 
    368       INTEGER, ALLOCATABLE, DIMENSION(:)     ::   ilen1, ilen3  ! size of 1st and 3rd dimensions of local arrays 
    369       INTEGER, ALLOCATABLE, DIMENSION(:)     ::   ibdy           ! bdy set for a particular jfld 
    370       INTEGER, ALLOCATABLE, DIMENSION(:)     ::   igrid         ! index for grid type (1,2,3 = T,U,V) 
    371       INTEGER, POINTER, DIMENSION(:)         ::   nblen, nblenrim  ! short cuts 
    372       TYPE(OBC_DATA), POINTER                ::   dta           ! short cut 
    373 #if defined key_si3 
    374       INTEGER               ::   kndims   ! number of dimensions in an array (i.e. 3 = wo ice cat; 4 = w ice cat) 
    375       INTEGER, DIMENSION(4) ::   kdimsz   ! size   of dimensions 
    376       INTEGER               ::   inum,id1 ! local integer 
    377 #endif 
    378       TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) ::   blf_i         !  array of namelist information structures 
    379       TYPE(FLD_N) ::   bn_tem, bn_sal, bn_u3d, bn_v3d   !  
    380       TYPE(FLD_N) ::   bn_ssh, bn_u2d, bn_v2d           ! informations about the fields to be read 
    381 #if defined key_si3 
    382       TYPE(FLD_N) ::   bn_a_i, bn_h_i, bn_h_s       
    383 #endif 
     379      LOGICAL                                ::   ln_zinterp    ! =T => requires a vertical interpolation of the bdydta 
     380      REAL(wp)                               ::   rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd  
     381      INTEGER                                ::   ipk,ipl       ! 
     382      INTEGER                                ::   idvar         ! variable ID 
     383      INTEGER                                ::   indims        ! number of dimensions of the variable 
     384      INTEGER                                ::   iszdim        ! number of dimensions of the variable 
     385      INTEGER, DIMENSION(4)                  ::   i4dimsz       ! size of variable dimensions  
     386      INTEGER                                ::   igrd          ! index for grid type (1,2,3 = T,U,V) 
     387      LOGICAL                                ::   lluld         ! is the variable using the unlimited dimension 
     388      LOGICAL                                ::   llneed        ! 
     389      LOGICAL                                ::   llread        ! 
     390      TYPE(FLD_N), DIMENSION(1), TARGET  ::   bn_tem, bn_sal, bn_u3d, bn_v3d   ! must be an array to be used with fld_fill 
     391      TYPE(FLD_N), DIMENSION(1), TARGET  ::   bn_ssh, bn_u2d, bn_v2d           ! informations about the fields to be read 
     392      TYPE(FLD_N), DIMENSION(1), TARGET  ::   bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip        
     393      TYPE(FLD_N), DIMENSION(:), POINTER ::   bn_alias                        ! must be an array to be used with fld_fill 
     394      TYPE(FLD  ), DIMENSION(:), POINTER ::   bf_alias 
     395      ! 
    384396      NAMELIST/nambdy_dta/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d  
    385 #if defined key_si3 
    386       NAMELIST/nambdy_dta/ bn_a_i, bn_h_i, bn_h_s 
    387 #endif 
    388       NAMELIST/nambdy_dta/ ln_full_vel, nb_jpk_bdy 
     397      NAMELIST/nambdy_dta/ bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip 
     398      NAMELIST/nambdy_dta/ rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd 
     399      NAMELIST/nambdy_dta/ ln_full_vel, ln_zinterp 
    389400      !!--------------------------------------------------------------------------- 
    390401      ! 
    … …  
    394405      IF(lwp) WRITE(numout,*) '' 
    395406 
    396       ! Set nn_dta 
    397       DO jbdy = 1, nb_bdy 
    398          nn_dta(jbdy) = MAX(   nn_dyn2d_dta  (jbdy)    & 
    399             &                , nn_dyn3d_dta  (jbdy)    & 
    400             &                , nn_tra_dta    (jbdy)    & 
    401 #if defined key_si3 
    402             &                , nn_ice_dta    (jbdy)    & 
    403 #endif 
    404                               ) 
    405          IF(nn_dta(jbdy) > 1)   nn_dta(jbdy) = 1 
    406       END DO 
    407  
    408       ! Work out upper bound of how many fields there are to read in and allocate arrays 
    409       ! --------------------------------------------------------------------------- 
    410       ALLOCATE( nb_bdy_fld(nb_bdy) ) 
    411       nb_bdy_fld(:) = 0 
    412       DO jbdy = 1, nb_bdy          
    413          IF( cn_dyn2d(jbdy) /= 'none' .AND. ( nn_dyn2d_dta(jbdy) == 1 .or. nn_dyn2d_dta(jbdy) == 3 ) ) THEN 
    414             nb_bdy_fld(jbdy) = nb_bdy_fld(jbdy) + 3 
    415          ENDIF 
    416          IF( cn_dyn3d(jbdy) /= 'none' .AND. nn_dyn3d_dta(jbdy) == 1 ) THEN 
    417             nb_bdy_fld(jbdy) = nb_bdy_fld(jbdy) + 2 
    418          ENDIF 
    419          IF( cn_tra(jbdy) /= 'none' .AND. nn_tra_dta(jbdy) == 1  ) THEN 
    420             nb_bdy_fld(jbdy) = nb_bdy_fld(jbdy) + 2 
    421          ENDIF 
    422 #if defined key_si3 
    423          IF( cn_ice(jbdy) /= 'none' .AND. nn_ice_dta(jbdy) == 1  ) THEN 
    424             nb_bdy_fld(jbdy) = nb_bdy_fld(jbdy) + 3 
    425          ENDIF 
    426 #endif                
    427          IF(lwp) WRITE(numout,*) 'Maximum number of files to open =', nb_bdy_fld(jbdy) 
    428       END DO             
    429  
    430       nb_bdy_fld_sum = SUM( nb_bdy_fld ) 
    431  
    432       ALLOCATE( bf(nb_bdy_fld_sum), STAT=ierror ) 
     407      ALLOCATE( bf(jpbdyfld,nb_bdy), STAT=ierror ) 
    433408      IF( ierror > 0 ) THEN    
    434409         CALL ctl_stop( 'bdy_dta: unable to allocate bf structure' )   ;   RETURN   
    435410      ENDIF 
    436       ALLOCATE( blf_i(nb_bdy_fld_sum), STAT=ierror ) 
    437       IF( ierror > 0 ) THEN    
    438          CALL ctl_stop( 'bdy_dta: unable to allocate blf_i structure' )   ;   RETURN   
    439       ENDIF 
    440       ALLOCATE( nbmap_ptr(nb_bdy_fld_sum), STAT=ierror ) 
    441       IF( ierror > 0 ) THEN    
    442          CALL ctl_stop( 'bdy_dta: unable to allocate nbmap_ptr structure' )   ;   RETURN   
    443       ENDIF 
    444       ALLOCATE( ilen1(nb_bdy_fld_sum), ilen3(nb_bdy_fld_sum) )  
    445       ALLOCATE( ibdy(nb_bdy_fld_sum) )  
    446       ALLOCATE( igrid(nb_bdy_fld_sum) )  
    447  
     411      bf(:,:)%clrootname = 'NOT USED'   ! default definition used as a flag in fld_read to do nothing. 
     412      bf(:,:)%lzint      = .FALSE.      ! default definition 
     413      bf(:,:)%ltotvel    = .FALSE.      ! default definition 
     414  
    448415      ! Read namelists 
    449416      ! -------------- 
    450       REWIND(numnam_ref) 
    451417      REWIND(numnam_cfg) 
    452       jfld = 0  
    453       DO jbdy = 1, nb_bdy          
    454          IF( nn_dta(jbdy) == 1 ) THEN 
    455             READ  ( numnam_ref, nambdy_dta, IOSTAT = ios, ERR = 901) 
    456 901         IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambdy_dta in reference namelist', lwp ) 
     418      DO jbdy = 1, nb_bdy 
     419 
     420         WRITE(ctmp1, '(a,i2)') 'BDY number ', jbdy 
     421         WRITE(ctmp2, '(a,i2)') 'block nambdy_dta number ', jbdy 
     422 
     423         ! There is only one nambdy_dta block in namelist_ref -> use it for each bdy so we do a rewind  
     424         REWIND(numnam_ref) 
     425         READ  ( numnam_ref, nambdy_dta, IOSTAT = ios, ERR = 901) 
     426901      IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambdy_dta in reference namelist' ) 
     427 
     428         !   by-pass nambdy_dta reading if no input data used in this bdy    
     429         IF(       ( dta_bdy(jbdy)%lneed_dyn2d .AND. MOD(nn_dyn2d_dta(jbdy),2) == 1 )   & 
     430            & .OR. ( dta_bdy(jbdy)%lneed_dyn3d .AND.     nn_dyn3d_dta(jbdy)    == 1 )   & 
     431            & .OR. ( dta_bdy(jbdy)%lneed_tra   .AND.       nn_tra_dta(jbdy)    == 1 )   & 
     432            & .OR. ( dta_bdy(jbdy)%lneed_ice   .AND.       nn_ice_dta(jbdy)    == 1 )   )   THEN 
     433            ! WARNING: we don't do a rewind here, each bdy reads its own nambdy_dta block one after another 
    457434            READ  ( numnam_cfg, nambdy_dta, IOSTAT = ios, ERR = 902 ) 
    458 902         IF( ios >  0 )   CALL ctl_nam ( ios , 'nambdy_dta in configuration namelist', lwp ) 
    459             IF(lwm) WRITE( numond, nambdy_dta ) 
    460  
    461             cn_dir_array(jbdy) = cn_dir 
    462             ln_full_vel_array(jbdy) = ln_full_vel 
    463  
    464             nblen => idx_bdy(jbdy)%nblen 
    465             nblenrim => idx_bdy(jbdy)%nblenrim 
    466             dta => dta_bdy(jbdy) 
    467             dta%nread(2) = 0 
    468  
    469             ! Only read in necessary fields for this set. 
    470             ! Important that barotropic variables come first. 
    471             IF( nn_dyn2d_dta(jbdy) == 1 .or. nn_dyn2d_dta(jbdy) == 3 ) THEN  
    472  
    473                IF( dta%ll_ssh ) THEN  
    474                   if(lwp) write(numout,*) '++++++ reading in ssh field' 
    475                   jfld = jfld + 1 
    476                   blf_i(jfld) = bn_ssh 
    477                   ibdy(jfld) = jbdy 
    478                   igrid(jfld) = 1 
    479                   ilen1(jfld) = nblen(igrid(jfld)) 
    480                   ilen3(jfld) = 1 
    481                   dta%nread(2) = dta%nread(2) + 1 
    482                ENDIF 
    483  
    484                IF( dta%ll_u2d .and. .not. ln_full_vel_array(jbdy) ) THEN 
    485                   if(lwp) write(numout,*) '++++++ reading in u2d field' 
    486                   jfld = jfld + 1 
    487                   blf_i(jfld) = bn_u2d 
    488                   ibdy(jfld) = jbdy 
    489                   igrid(jfld) = 2 
    490                   ilen1(jfld) = nblen(igrid(jfld)) 
    491                   ilen3(jfld) = 1 
    492                   dta%nread(2) = dta%nread(2) + 1 
    493                ENDIF 
    494  
    495                IF( dta%ll_v2d .and. .not. ln_full_vel_array(jbdy) ) THEN 
    496                   if(lwp) write(numout,*) '++++++ reading in v2d field' 
    497                   jfld = jfld + 1 
    498                   blf_i(jfld) = bn_v2d 
    499                   ibdy(jfld) = jbdy 
    500                   igrid(jfld) = 3 
    501                   ilen1(jfld) = nblen(igrid(jfld)) 
    502                   ilen3(jfld) = 1 
    503                   dta%nread(2) = dta%nread(2) + 1 
    504                ENDIF 
    505  
    506             ENDIF 
    507  
    508             ! read 3D velocities if baroclinic velocities require OR if 
    509             ! barotropic velocities required and ln_full_vel set to .true. 
    510             IF( nn_dyn3d_dta(jbdy) == 1 .OR. & 
    511            &  ( ln_full_vel_array(jbdy) .AND. ( nn_dyn2d_dta(jbdy) == 1 .OR. nn_dyn2d_dta(jbdy) == 3 ) ) ) THEN 
    512  
    513                IF( dta%ll_u3d .OR. ( ln_full_vel_array(jbdy) .and. dta%ll_u2d ) ) THEN 
    514                   if(lwp) write(numout,*) '++++++ reading in u3d field' 
    515                   jfld = jfld + 1 
    516                   blf_i(jfld) = bn_u3d 
    517                   ibdy(jfld) = jbdy 
    518                   igrid(jfld) = 2 
    519                   ilen1(jfld) = nblen(igrid(jfld)) 
    520                   ilen3(jfld) = jpk 
    521                   IF( ln_full_vel_array(jbdy) .and. dta%ll_u2d ) dta%nread(2) = dta%nread(2) + 1 
    522                ENDIF 
    523  
    524                IF( dta%ll_v3d .OR. ( ln_full_vel_array(jbdy) .and. dta%ll_v2d ) ) THEN 
    525                   if(lwp) write(numout,*) '++++++ reading in v3d field' 
    526                   jfld = jfld + 1 
    527                   blf_i(jfld) = bn_v3d 
    528                   ibdy(jfld) = jbdy 
    529                   igrid(jfld) = 3 
    530                   ilen1(jfld) = nblen(igrid(jfld)) 
    531                   ilen3(jfld) = jpk 
    532                   IF( ln_full_vel_array(jbdy) .and. dta%ll_v2d ) dta%nread(2) = dta%nread(2) + 1 
    533                ENDIF 
    534  
    535             ENDIF 
    536  
    537             ! temperature and salinity 
    538             IF( nn_tra_dta(jbdy) == 1 ) THEN 
    539  
    540                IF( dta%ll_tem ) THEN 
    541                   if(lwp) write(numout,*) '++++++ reading in tem field' 
    542                   jfld = jfld + 1 
    543                   blf_i(jfld) = bn_tem 
    544                   ibdy(jfld) = jbdy 
    545                   igrid(jfld) = 1 
    546                   ilen1(jfld) = nblen(igrid(jfld)) 
    547                   ilen3(jfld) = jpk 
    548                ENDIF 
    549  
    550                IF( dta%ll_sal ) THEN 
    551                   if(lwp) write(numout,*) '++++++ reading in sal field' 
    552                   jfld = jfld + 1 
    553                   blf_i(jfld) = bn_sal 
    554                   ibdy(jfld) = jbdy 
    555                   igrid(jfld) = 1 
    556                   ilen1(jfld) = nblen(igrid(jfld)) 
    557                   ilen3(jfld) = jpk 
    558                ENDIF 
    559  
    560             ENDIF 
     435902         IF( ios >  0 )   CALL ctl_nam ( ios , 'nambdy_dta in configuration namelist' ) 
     436            IF(lwm) WRITE( numond, nambdy_dta )            
     437         ENDIF 
     438 
     439         ! get the number of ice categories in bdy data file (use a_i information to do this) 
     440         ipl = jpl   ! default definition 
     441         IF( dta_bdy(jbdy)%lneed_ice ) THEN    ! if we need ice bdy data 
     442            IF( nn_ice_dta(jbdy) == 1 ) THEN   ! if we get ice bdy data from netcdf file 
     443               CALL fld_fill(  bf(jp_bdya_i,jbdy:jbdy), bn_a_i, cn_dir, 'bdy_dta', 'a_i'//' '//ctmp1, ctmp2 )   ! use namelist info 
     444               CALL fld_clopn( bf(jp_bdya_i,jbdy), nyear, nmonth, nday )   ! not a problem when we call it again after 
     445               idvar = iom_varid( bf(jp_bdya_i,jbdy)%num, bf(jp_bdya_i,jbdy)%clvar, kndims=indims, kdimsz=i4dimsz, lduld=lluld ) 
     446               IF( indims == 4 .OR. ( indims == 3 .AND. .NOT. lluld ) ) THEN   ;   ipl = i4dimsz(3)   ! xylt or xyl 
     447               ELSE                                                            ;   ipl = 1            ! xy or xyt 
     448               ENDIF 
     449            ENDIF 
     450         ENDIF 
    561451 
    562452#if defined key_si3 
    563             ! sea ice 
    564             IF( nn_ice_dta(jbdy) == 1 ) THEN 
    565                ! Test for types of ice input (1cat or Xcat)  
    566                ! Build file name to find dimensions  
    567                clname=TRIM( cn_dir )//TRIM(bn_a_i%clname) 
    568                IF( .NOT. bn_a_i%ln_clim ) THEN    
    569                                                   WRITE(clname, '(a,"_y",i4.4)' ) TRIM( clname ), nyear    ! add year 
    570                   IF( bn_a_i%cltype /= 'yearly' ) WRITE(clname, '(a,"m" ,i2.2)' ) TRIM( clname ), nmonth   ! add month 
    571                ELSE 
    572                   IF( bn_a_i%cltype /= 'yearly' ) WRITE(clname, '(a,"_m",i2.2)' ) TRIM( clname ), nmonth   ! add month 
    573                ENDIF 
    574                IF( bn_a_i%cltype == 'daily' .OR. bn_a_i%cltype(1:4) == 'week' ) & 
    575                &                                  WRITE(clname, '(a,"d" ,i2.2)' ) TRIM( clname ), nday     ! add day 
     453         IF( .NOT.ln_pnd ) THEN 
     454            rn_ice_apnd = 0. ; rn_ice_hpnd = 0. 
     455            CALL ctl_warn( 'rn_ice_apnd & rn_ice_hpnd = 0 when no ponds' ) 
     456         ENDIF 
     457#endif 
     458 
     459         ! temp, salt, age and ponds of incoming ice 
     460         rice_tem (jbdy) = rn_ice_tem 
     461         rice_sal (jbdy) = rn_ice_sal 
     462         rice_age (jbdy) = rn_ice_age 
     463         rice_apnd(jbdy) = rn_ice_apnd 
     464         rice_hpnd(jbdy) = rn_ice_hpnd 
     465          
     466          
     467         DO jfld = 1, jpbdyfld 
     468 
     469            ! ===================== 
     470            !          ssh  
     471            ! ===================== 
     472            IF( jfld == jp_bdyssh ) THEN 
     473               cl3 = 'ssh' 
     474               igrd = 1                                                    ! T point 
     475               ipk = 1                                                     ! surface data 
     476               llneed = dta_bdy(jbdy)%lneed_ssh                            ! dta_bdy(jbdy)%ssh will be needed 
     477               llread = MOD(nn_dyn2d_dta(jbdy),2) == 1                     ! get data from NetCDF file 
     478               bf_alias => bf(jp_bdyssh,jbdy:jbdy)                         ! alias for ssh structure of bdy number jbdy 
     479               bn_alias => bn_ssh                                          ! alias for ssh structure of nambdy_dta  
     480               iszdim = idx_bdy(jbdy)%nblenrim(igrd)                       ! length of this bdy on this MPI processus : used only on the rim 
     481            ENDIF 
     482            ! ===================== 
     483            !         dyn2d 
     484            ! ===================== 
     485            IF( jfld == jp_bdyu2d ) THEN 
     486               cl3 = 'u2d' 
     487               igrd = 2                                                    ! U point 
     488               ipk = 1                                                     ! surface data 
     489               llneed = dta_bdy(jbdy)%lneed_dyn2d                          ! dta_bdy(jbdy)%ssh will be needed 
     490               llread = .NOT. ln_full_vel .AND. MOD(nn_dyn2d_dta(jbdy),2) == 1   ! don't get u2d from u3d and read NetCDF file 
     491               bf_alias => bf(jp_bdyu2d,jbdy:jbdy)                         ! alias for u2d structure of bdy number jbdy 
     492               bn_alias => bn_u2d                                          ! alias for u2d structure of nambdy_dta 
     493               IF( ln_full_vel ) THEN  ;   iszdim = idx_bdy(jbdy)%nblen(igrd)      ! will be computed from u3d -> need on the full bdy 
     494               ELSE                    ;   iszdim = idx_bdy(jbdy)%nblenrim(igrd)   ! used only on the rim 
     495               ENDIF 
     496            ENDIF 
     497            IF( jfld == jp_bdyv2d ) THEN 
     498               cl3 = 'v2d' 
     499               igrd = 3                                                    ! V point 
     500               ipk = 1                                                     ! surface data 
     501               llneed = dta_bdy(jbdy)%lneed_dyn2d                          ! dta_bdy(jbdy)%ssh will be needed 
     502               llread = .NOT. ln_full_vel .AND. MOD(nn_dyn2d_dta(jbdy),2) == 1   ! don't get v2d from v3d and read NetCDF file 
     503               bf_alias => bf(jp_bdyv2d,jbdy:jbdy)                         ! alias for v2d structure of bdy number jbdy 
     504               bn_alias => bn_v2d                                          ! alias for v2d structure of nambdy_dta  
     505               IF( ln_full_vel ) THEN  ;   iszdim = idx_bdy(jbdy)%nblen(igrd)      ! will be computed from v3d -> need on the full bdy 
     506               ELSE                    ;   iszdim = idx_bdy(jbdy)%nblenrim(igrd)   ! used only on the rim 
     507               ENDIF 
     508            ENDIF 
     509            ! ===================== 
     510            !         dyn3d 
     511            ! ===================== 
     512            IF( jfld == jp_bdyu3d ) THEN 
     513               cl3 = 'u3d' 
     514               igrd = 2                                                    ! U point 
     515               ipk = jpk                                                   ! 3d data 
     516               llneed = dta_bdy(jbdy)%lneed_dyn3d .OR.               &     ! dta_bdy(jbdy)%u3d will be needed 
     517                  &   ( dta_bdy(jbdy)%lneed_dyn2d .AND. ln_full_vel )      !   u3d needed to compute u2d 
     518               llread = nn_dyn3d_dta(jbdy) == 1                            ! get data from NetCDF file 
     519               bf_alias => bf(jp_bdyu3d,jbdy:jbdy)                         ! alias for u3d structure of bdy number jbdy 
     520               bn_alias => bn_u3d                                          ! alias for u3d structure of nambdy_dta  
     521               iszdim = idx_bdy(jbdy)%nblen(igrd)                          ! length of this bdy on this MPI processus 
     522           ENDIF 
     523            IF( jfld == jp_bdyv3d ) THEN 
     524               cl3 = 'v3d' 
     525               igrd = 3                                                    ! V point 
     526               ipk = jpk                                                   ! 3d data 
     527               llneed = dta_bdy(jbdy)%lneed_dyn3d .OR.               &     ! dta_bdy(jbdy)%v3d will be needed 
     528                  &   ( dta_bdy(jbdy)%lneed_dyn2d .AND. ln_full_vel )      !   v3d needed to compute v2d 
     529               llread = nn_dyn3d_dta(jbdy) == 1                            ! get data from NetCDF file 
     530               bf_alias => bf(jp_bdyv3d,jbdy:jbdy)                         ! alias for v3d structure of bdy number jbdy 
     531               bn_alias => bn_v3d                                          ! alias for v3d structure of nambdy_dta  
     532               iszdim = idx_bdy(jbdy)%nblen(igrd)                          ! length of this bdy on this MPI processus 
     533           ENDIF 
     534 
     535            ! ===================== 
     536            !          tra 
     537            ! ===================== 
     538            IF( jfld == jp_bdytem ) THEN 
     539               cl3 = 'tem' 
     540               igrd = 1                                                    ! T point 
     541               ipk = jpk                                                   ! 3d data 
     542               llneed = dta_bdy(jbdy)%lneed_tra                            ! dta_bdy(jbdy)%tem will be needed 
     543               llread = nn_tra_dta(jbdy) == 1                              ! get data from NetCDF file 
     544               bf_alias => bf(jp_bdytem,jbdy:jbdy)                         ! alias for ssh structure of bdy number jbdy 
     545               bn_alias => bn_tem                                          ! alias for ssh structure of nambdy_dta  
     546               iszdim = idx_bdy(jbdy)%nblen(igrd)                          ! length of this bdy on this MPI processus 
     547            ENDIF 
     548            IF( jfld == jp_bdysal ) THEN 
     549               cl3 = 'sal' 
     550               igrd = 1                                                    ! T point 
     551               ipk = jpk                                                   ! 3d data 
     552               llneed = dta_bdy(jbdy)%lneed_tra                            ! dta_bdy(jbdy)%sal will be needed 
     553               llread = nn_tra_dta(jbdy) == 1                              ! get data from NetCDF file 
     554               bf_alias => bf(jp_bdysal,jbdy:jbdy)                         ! alias for ssh structure of bdy number jbdy 
     555               bn_alias => bn_sal                                          ! alias for ssh structure of nambdy_dta  
     556               iszdim = idx_bdy(jbdy)%nblen(igrd)                          ! length of this bdy on this MPI processus 
     557            ENDIF 
     558 
     559            ! ===================== 
     560            !          ice 
     561            ! ===================== 
     562            IF(  jfld == jp_bdya_i .OR. jfld == jp_bdyh_i .OR. jfld == jp_bdyh_s .OR. & 
     563               & jfld == jp_bdyt_i .OR. jfld == jp_bdyt_s .OR. jfld == jp_bdytsu .OR. & 
     564               & jfld == jp_bdys_i .OR. jfld == jp_bdyaip .OR. jfld == jp_bdyhip      ) THEN 
     565               igrd = 1                                                    ! T point 
     566               ipk = ipl                                                   ! jpl-cat data 
     567               llneed = dta_bdy(jbdy)%lneed_ice                            ! ice will be needed 
     568               llread = nn_ice_dta(jbdy) == 1                              ! get data from NetCDF file 
     569               iszdim = idx_bdy(jbdy)%nblen(igrd)                          ! length of this bdy on this MPI processus 
     570            ENDIF 
     571            IF( jfld == jp_bdya_i ) THEN 
     572               cl3 = 'a_i' 
     573               bf_alias => bf(jp_bdya_i,jbdy:jbdy)                         ! alias for a_i structure of bdy number jbdy 
     574               bn_alias => bn_a_i                                          ! alias for a_i structure of nambdy_dta  
     575            ENDIF 
     576            IF( jfld == jp_bdyh_i ) THEN 
     577               cl3 = 'h_i' 
     578               bf_alias => bf(jp_bdyh_i,jbdy:jbdy)                         ! alias for h_i structure of bdy number jbdy 
     579               bn_alias => bn_h_i                                          ! alias for h_i structure of nambdy_dta  
     580            ENDIF 
     581            IF( jfld == jp_bdyh_s ) THEN 
     582               cl3 = 'h_s' 
     583               bf_alias => bf(jp_bdyh_s,jbdy:jbdy)                         ! alias for h_s structure of bdy number jbdy 
     584               bn_alias => bn_h_s                                          ! alias for h_s structure of nambdy_dta  
     585            ENDIF 
     586            IF( jfld == jp_bdyt_i ) THEN 
     587               cl3 = 't_i' 
     588               bf_alias => bf(jp_bdyt_i,jbdy:jbdy)                         ! alias for t_i structure of bdy number jbdy 
     589               bn_alias => bn_t_i                                          ! alias for t_i structure of nambdy_dta  
     590            ENDIF 
     591            IF( jfld == jp_bdyt_s ) THEN 
     592               cl3 = 't_s' 
     593               bf_alias => bf(jp_bdyt_s,jbdy:jbdy)                         ! alias for t_s structure of bdy number jbdy 
     594               bn_alias => bn_t_s                                          ! alias for t_s structure of nambdy_dta  
     595            ENDIF 
     596            IF( jfld == jp_bdytsu ) THEN 
     597               cl3 = 'tsu' 
     598               bf_alias => bf(jp_bdytsu,jbdy:jbdy)                         ! alias for tsu structure of bdy number jbdy 
     599               bn_alias => bn_tsu                                          ! alias for tsu structure of nambdy_dta  
     600            ENDIF 
     601            IF( jfld == jp_bdys_i ) THEN 
     602               cl3 = 's_i' 
     603               bf_alias => bf(jp_bdys_i,jbdy:jbdy)                         ! alias for s_i structure of bdy number jbdy 
     604               bn_alias => bn_s_i                                          ! alias for s_i structure of nambdy_dta  
     605            ENDIF 
     606            IF( jfld == jp_bdyaip ) THEN 
     607               cl3 = 'aip' 
     608               bf_alias => bf(jp_bdyaip,jbdy:jbdy)                         ! alias for aip structure of bdy number jbdy 
     609               bn_alias => bn_aip                                          ! alias for aip structure of nambdy_dta  
     610            ENDIF 
     611            IF( jfld == jp_bdyhip ) THEN 
     612               cl3 = 'hip' 
     613               bf_alias => bf(jp_bdyhip,jbdy:jbdy)                         ! alias for hip structure of bdy number jbdy 
     614               bn_alias => bn_hip                                          ! alias for hip structure of nambdy_dta  
     615            ENDIF 
     616 
     617            IF( llneed ) THEN                                              ! dta_bdy(jbdy)%xxx will be needed 
     618               !                                                           !   -> must be associated with an allocated target 
     619               ALLOCATE( bf_alias(1)%fnow( iszdim, 1, ipk ) )              ! allocate the target 
    576620               ! 
    577                CALL iom_open  ( clname, inum ) 
    578                id1 = iom_varid( inum, bn_a_i%clvar, kdimsz=kdimsz, kndims=kndims, ldstop = .FALSE. ) 
    579                CALL iom_close ( inum ) 
    580  
    581                 IF ( kndims == 4 ) THEN 
    582                  nice_cat = kdimsz(4)   ! Xcat input 
    583                ELSE 
    584                  nice_cat = 1           ! 1cat input       
    585                ENDIF 
    586                ! End test 
    587  
    588                IF( dta%ll_a_i ) THEN 
    589                   jfld = jfld + 1 
    590                   blf_i(jfld) = bn_a_i 
    591                   ibdy(jfld)  = jbdy 
    592                   igrid(jfld) = 1 
    593                   ilen1(jfld) = nblen(igrid(jfld)) 
    594                   ilen3(jfld) = nice_cat 
    595                ENDIF 
    596  
    597                IF( dta%ll_h_i ) THEN 
    598                   jfld = jfld + 1 
    599                   blf_i(jfld) = bn_h_i 
    600                   ibdy(jfld)  = jbdy 
    601                   igrid(jfld) = 1 
    602                   ilen1(jfld) = nblen(igrid(jfld)) 
    603                   ilen3(jfld) = nice_cat 
    604                ENDIF 
    605  
    606                IF( dta%ll_h_s ) THEN 
    607                   jfld = jfld + 1 
    608                   blf_i(jfld) = bn_h_s 
    609                   ibdy(jfld)  = jbdy 
    610                   igrid(jfld) = 1 
    611                   ilen1(jfld) = nblen(igrid(jfld)) 
    612                   ilen3(jfld) = nice_cat 
    613                ENDIF 
    614  
    615             ENDIF 
    616 #endif 
    617             ! Recalculate field counts 
    618             !------------------------- 
    619             IF( jbdy == 1 ) THEN  
    620                nb_bdy_fld_sum = 0 
    621                nb_bdy_fld(jbdy) = jfld 
    622                nb_bdy_fld_sum     = jfld               
    623             ELSE 
    624                nb_bdy_fld(jbdy) = jfld - nb_bdy_fld_sum 
    625                nb_bdy_fld_sum = nb_bdy_fld_sum + nb_bdy_fld(jbdy) 
    626             ENDIF 
    627  
    628             dta%nread(1) = nb_bdy_fld(jbdy) 
    629  
    630          ENDIF ! nn_dta == 1 
    631       ENDDO ! jbdy 
    632  
    633       DO jfld = 1, nb_bdy_fld_sum 
    634          ALLOCATE( bf(jfld)%fnow(ilen1(jfld),1,ilen3(jfld)) ) 
    635          IF( blf_i(jfld)%ln_tint ) ALLOCATE( bf(jfld)%fdta(ilen1(jfld),1,ilen3(jfld),2) ) 
    636          nbmap_ptr(jfld)%ptr => idx_bdy(ibdy(jfld))%nbmap(:,igrid(jfld)) 
    637          nbmap_ptr(jfld)%ll_unstruc = ln_coords_file(ibdy(jfld)) 
    638       ENDDO 
    639  
    640       ! fill bf with blf_i and control print 
    641       !------------------------------------- 
    642       jstart = 1 
    643       DO jbdy = 1, nb_bdy 
    644          jend = jstart - 1 + nb_bdy_fld(jbdy)  
    645          CALL fld_fill( bf(jstart:jend), blf_i(jstart:jend), cn_dir_array(jbdy), 'bdy_dta',   & 
    646          &              'open boundary conditions', 'nambdy_dta' ) 
    647          jstart = jend + 1 
    648       ENDDO 
    649  
    650       DO jfld = 1, nb_bdy_fld_sum 
    651          bf(jfld)%igrd = igrid(jfld) 
    652          bf(jfld)%ibdy = ibdy(jfld) 
    653       ENDDO 
    654  
    655       ! Initialise local boundary data arrays 
    656       ! nn_xxx_dta=0 : allocate space - will be filled from initial conditions later 
    657       ! nn_xxx_dta=1 : point to "fnow" arrays 
    658       !------------------------------------- 
    659  
    660       jfld = 0 
    661       DO jbdy=1, nb_bdy 
    662  
    663          nblen => idx_bdy(jbdy)%nblen 
    664          dta => dta_bdy(jbdy) 
    665  
    666          if(lwp) then 
    667             write(numout,*) '++++++ dta%ll_ssh = ',dta%ll_ssh 
    668             write(numout,*) '++++++ dta%ll_u2d = ',dta%ll_u2d 
    669             write(numout,*) '++++++ dta%ll_v2d = ',dta%ll_v2d 
    670             write(numout,*) '++++++ dta%ll_u3d = ',dta%ll_u3d 
    671             write(numout,*) '++++++ dta%ll_v3d = ',dta%ll_v3d 
    672             write(numout,*) '++++++ dta%ll_tem = ',dta%ll_tem 
    673             write(numout,*) '++++++ dta%ll_sal = ',dta%ll_sal 
    674          endif 
    675  
    676          IF ( nn_dyn2d_dta(jbdy) == 0 .or. nn_dyn2d_dta(jbdy) == 2 ) THEN 
    677             if(lwp) write(numout,*) '++++++ dta%ssh/u2d/u3d allocated space' 
    678             IF( dta%ll_ssh ) ALLOCATE( dta%ssh(nblen(1)) ) 
    679             IF( dta%ll_u2d ) ALLOCATE( dta%u2d(nblen(2)) ) 
    680             IF( dta%ll_v2d ) ALLOCATE( dta%v2d(nblen(3)) ) 
    681          ENDIF 
    682          IF ( nn_dyn2d_dta(jbdy) == 1 .or. nn_dyn2d_dta(jbdy) == 3 ) THEN 
    683             IF( dta%ll_ssh ) THEN 
    684                if(lwp) write(numout,*) '++++++ dta%ssh pointing to fnow' 
    685                jfld = jfld + 1 
    686                dta%ssh => bf(jfld)%fnow(:,1,1) 
    687             ENDIF 
    688             IF ( dta%ll_u2d ) THEN 
    689                IF ( ln_full_vel_array(jbdy) ) THEN 
    690                   if(lwp) write(numout,*) '++++++ dta%u2d allocated space' 
    691                   ALLOCATE( dta%u2d(nblen(2)) ) 
    692                ELSE 
    693                   if(lwp) write(numout,*) '++++++ dta%u2d pointing to fnow' 
    694                   jfld = jfld + 1 
    695                   dta%u2d => bf(jfld)%fnow(:,1,1) 
    696                ENDIF 
    697             ENDIF 
    698             IF ( dta%ll_v2d ) THEN 
    699                IF ( ln_full_vel_array(jbdy) ) THEN 
    700                   if(lwp) write(numout,*) '++++++ dta%v2d allocated space' 
    701                   ALLOCATE( dta%v2d(nblen(3)) ) 
    702                ELSE 
    703                   if(lwp) write(numout,*) '++++++ dta%v2d pointing to fnow' 
    704                   jfld = jfld + 1 
    705                   dta%v2d => bf(jfld)%fnow(:,1,1) 
    706                ENDIF 
    707             ENDIF 
    708          ENDIF 
    709  
    710          IF ( nn_dyn3d_dta(jbdy) == 0 ) THEN 
    711             if(lwp) write(numout,*) '++++++ dta%u3d/v3d allocated space' 
    712             IF( dta%ll_u3d ) ALLOCATE( dta_bdy(jbdy)%u3d(nblen(2),jpk) ) 
    713             IF( dta%ll_v3d ) ALLOCATE( dta_bdy(jbdy)%v3d(nblen(3),jpk) ) 
    714          ENDIF 
    715          IF ( nn_dyn3d_dta(jbdy) == 1 .or. & 
    716            &  ( ln_full_vel_array(jbdy) .and. ( nn_dyn2d_dta(jbdy) == 1 .or. nn_dyn2d_dta(jbdy) == 3 ) ) ) THEN 
    717             IF ( dta%ll_u3d .or. ( ln_full_vel_array(jbdy) .and. dta%ll_u2d ) ) THEN 
    718                if(lwp) write(numout,*) '++++++ dta%u3d pointing to fnow' 
    719                jfld = jfld + 1 
    720                dta_bdy(jbdy)%u3d => bf(jfld)%fnow(:,1,:) 
    721             ENDIF 
    722             IF ( dta%ll_v3d .or. ( ln_full_vel_array(jbdy) .and. dta%ll_v2d ) ) THEN 
    723                if(lwp) write(numout,*) '++++++ dta%v3d pointing to fnow' 
    724                jfld = jfld + 1 
    725                dta_bdy(jbdy)%v3d => bf(jfld)%fnow(:,1,:) 
    726             ENDIF 
    727          ENDIF 
    728  
    729          IF( nn_tra_dta(jbdy) == 0 ) THEN 
    730             if(lwp) write(numout,*) '++++++ dta%tem/sal allocated space' 
    731             IF( dta%ll_tem ) ALLOCATE( dta_bdy(jbdy)%tem(nblen(1),jpk) ) 
    732             IF( dta%ll_sal ) ALLOCATE( dta_bdy(jbdy)%sal(nblen(1),jpk) ) 
    733          ELSE 
    734             IF( dta%ll_tem ) THEN 
    735                if(lwp) write(numout,*) '++++++ dta%tem pointing to fnow' 
    736                jfld = jfld + 1 
    737                dta_bdy(jbdy)%tem => bf(jfld)%fnow(:,1,:) 
    738             ENDIF 
    739             IF( dta%ll_sal ) THEN  
    740                if(lwp) write(numout,*) '++++++ dta%sal pointing to fnow' 
    741                jfld = jfld + 1 
    742                dta_bdy(jbdy)%sal => bf(jfld)%fnow(:,1,:) 
    743             ENDIF 
    744          ENDIF 
    745  
    746 #if defined key_si3 
    747          IF (cn_ice(jbdy) /= 'none') THEN 
    748             IF( nn_ice_dta(jbdy) == 0 ) THEN 
    749                ALLOCATE( dta_bdy(jbdy)%a_i(nblen(1),jpl) ) 
    750                ALLOCATE( dta_bdy(jbdy)%h_i(nblen(1),jpl) ) 
    751                ALLOCATE( dta_bdy(jbdy)%h_s(nblen(1),jpl) ) 
    752             ELSE 
    753                IF ( nice_cat == jpl ) THEN ! case input cat = jpl 
    754                   jfld = jfld + 1 
    755                   dta_bdy(jbdy)%a_i => bf(jfld)%fnow(:,1,:) 
    756                   jfld = jfld + 1 
    757                   dta_bdy(jbdy)%h_i => bf(jfld)%fnow(:,1,:) 
    758                   jfld = jfld + 1 
    759                   dta_bdy(jbdy)%h_s => bf(jfld)%fnow(:,1,:) 
    760                ELSE                        ! case input cat = 1 OR (/=1 and /=jpl) 
    761                   jfld_ait(jbdy)  = jfld + 1 
    762                   jfld_htit(jbdy) = jfld + 2 
    763                   jfld_htst(jbdy) = jfld + 3 
    764                   jfld     = jfld + 3 
    765                   ALLOCATE( dta_bdy(jbdy)%a_i(nblen(1),jpl) ) 
    766                   ALLOCATE( dta_bdy(jbdy)%h_i(nblen(1),jpl) ) 
    767                   ALLOCATE( dta_bdy(jbdy)%h_s(nblen(1),jpl) ) 
    768                   dta_bdy(jbdy)%a_i(:,:) = 0._wp 
    769                   dta_bdy(jbdy)%h_i(:,:) = 0._wp 
    770                   dta_bdy(jbdy)%h_s(:,:) = 0._wp 
    771                ENDIF 
    772  
    773             ENDIF 
    774          ENDIF 
    775 #endif 
     621               IF( llread ) THEN                                           ! get data from NetCDF file 
     622                  CALL fld_fill( bf_alias, bn_alias, cn_dir, 'bdy_dta', cl3//' '//ctmp1, ctmp2 )   ! use namelist info 
     623                  IF( bf_alias(1)%ln_tint ) ALLOCATE( bf_alias(1)%fdta( iszdim, 1, ipk, 2 ) ) 
     624                  bf_alias(1)%imap    => idx_bdy(jbdy)%nbmap(1:iszdim,igrd)   ! associate the mapping used for this bdy 
     625                  bf_alias(1)%igrd    = igrd                                  ! used only for vertical integration of 3D arrays 
     626                  bf_alias(1)%ltotvel = ln_full_vel                           ! T if u3d is full velocity 
     627                  bf_alias(1)%lzint   = ln_zinterp                            ! T if it requires a vertical interpolation 
     628               ENDIF 
     629 
     630               ! associate the pointer and get rid of the dimensions with a size equal to 1 
     631               IF( jfld == jp_bdyssh )        dta_bdy(jbdy)%ssh => bf_alias(1)%fnow(:,1,1) 
     632               IF( jfld == jp_bdyu2d )        dta_bdy(jbdy)%u2d => bf_alias(1)%fnow(:,1,1) 
     633               IF( jfld == jp_bdyv2d )        dta_bdy(jbdy)%v2d => bf_alias(1)%fnow(:,1,1) 
     634               IF( jfld == jp_bdyu3d )        dta_bdy(jbdy)%u3d => bf_alias(1)%fnow(:,1,:) 
     635               IF( jfld == jp_bdyv3d )        dta_bdy(jbdy)%v3d => bf_alias(1)%fnow(:,1,:) 
     636               IF( jfld == jp_bdytem )        dta_bdy(jbdy)%tem => bf_alias(1)%fnow(:,1,:) 
     637               IF( jfld == jp_bdysal )        dta_bdy(jbdy)%sal => bf_alias(1)%fnow(:,1,:) 
     638               IF( jfld == jp_bdya_i ) THEN 
     639                  IF( ipk == jpl ) THEN   ;   dta_bdy(jbdy)%a_i => bf_alias(1)%fnow(:,1,:) 
     640                  ELSE                    ;   ALLOCATE( dta_bdy(jbdy)%a_i(iszdim,jpl) ) 
     641                  ENDIF 
     642               ENDIF 
     643               IF( jfld == jp_bdyh_i ) THEN 
     644                  IF( ipk == jpl ) THEN   ;   dta_bdy(jbdy)%h_i => bf_alias(1)%fnow(:,1,:) 
     645                  ELSE                    ;   ALLOCATE( dta_bdy(jbdy)%h_i(iszdim,jpl) ) 
     646                  ENDIF 
     647               ENDIF 
     648               IF( jfld == jp_bdyh_s ) THEN 
     649                  IF( ipk == jpl ) THEN   ;   dta_bdy(jbdy)%h_s => bf_alias(1)%fnow(:,1,:) 
     650                  ELSE                    ;   ALLOCATE( dta_bdy(jbdy)%h_s(iszdim,jpl) ) 
     651                  ENDIF 
     652               ENDIF 
     653               IF( jfld == jp_bdyt_i ) THEN 
     654                  IF( ipk == jpl ) THEN   ;   dta_bdy(jbdy)%t_i => bf_alias(1)%fnow(:,1,:) 
     655                  ELSE                    ;   ALLOCATE( dta_bdy(jbdy)%t_i(iszdim,jpl) ) 
     656                  ENDIF 
     657               ENDIF 
     658               IF( jfld == jp_bdyt_s ) THEN 
     659                  IF( ipk == jpl ) THEN   ;   dta_bdy(jbdy)%t_s => bf_alias(1)%fnow(:,1,:) 
     660                  ELSE                    ;   ALLOCATE( dta_bdy(jbdy)%t_s(iszdim,jpl) ) 
     661                  ENDIF 
     662               ENDIF 
     663               IF( jfld == jp_bdytsu ) THEN 
     664                  IF( ipk == jpl ) THEN   ;   dta_bdy(jbdy)%tsu => bf_alias(1)%fnow(:,1,:) 
     665                  ELSE                    ;   ALLOCATE( dta_bdy(jbdy)%tsu(iszdim,jpl) ) 
     666                  ENDIF 
     667               ENDIF 
     668               IF( jfld == jp_bdys_i ) THEN 
     669                  IF( ipk == jpl ) THEN   ;   dta_bdy(jbdy)%s_i => bf_alias(1)%fnow(:,1,:) 
     670                  ELSE                    ;   ALLOCATE( dta_bdy(jbdy)%s_i(iszdim,jpl) ) 
     671                  ENDIF 
     672               ENDIF 
     673               IF( jfld == jp_bdyaip ) THEN 
     674                  IF( ipk == jpl ) THEN   ;   dta_bdy(jbdy)%aip => bf_alias(1)%fnow(:,1,:) 
     675                  ELSE                    ;   ALLOCATE( dta_bdy(jbdy)%aip(iszdim,jpl) ) 
     676                  ENDIF 
     677               ENDIF 
     678               IF( jfld == jp_bdyhip ) THEN 
     679                  IF( ipk == jpl ) THEN   ;   dta_bdy(jbdy)%hip => bf_alias(1)%fnow(:,1,:) 
     680                  ELSE                    ;   ALLOCATE( dta_bdy(jbdy)%hip(iszdim,jpl) ) 
     681                  ENDIF 
     682               ENDIF 
     683            ENDIF 
     684 
     685         END DO   ! jpbdyfld 
    776686         ! 
    777687      END DO ! jbdy  
    778688      ! 
    779689   END SUBROUTINE bdy_dta_init 
    780  
     690    
    781691   !!============================================================================== 
    782692END MODULE bdydta 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/BDY/bdydyn2d.F90

    r10529 r11822  
    1414   !!   bdy_ssh            : Duplicate sea level across open boundaries 
    1515   !!---------------------------------------------------------------------- 
    16    USE oce             ! ocean dynamics and tracers  
    1716   USE dom_oce         ! ocean space and time domain 
    1817   USE bdy_oce         ! ocean open boundary conditions 
    … …  
    5049      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: pssh 
    5150      !! 
    52       INTEGER                                  ::   ib_bdy ! Loop counter 
    53  
    54       DO ib_bdy=1, nb_bdy 
    55  
    56          SELECT CASE( cn_dyn2d(ib_bdy) ) 
    57          CASE('none') 
    58             CYCLE 
    59          CASE('frs') 
    60             CALL bdy_dyn2d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, pua2d, pva2d ) 
    61          CASE('flather') 
    62             CALL bdy_dyn2d_fla( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, pua2d, pva2d, pssh, phur, phvr ) 
    63          CASE('orlanski') 
    64             CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, & 
    65                                      & pua2d, pva2d, pub2d, pvb2d, ll_npo=.false.) 
    66          CASE('orlanski_npo') 
    67             CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, & 
    68                                      & pua2d, pva2d, pub2d, pvb2d, ll_npo=.true. ) 
    69          CASE DEFAULT 
    70             CALL ctl_stop( 'bdy_dyn2d : unrecognised option for open boundaries for barotropic variables' ) 
    71          END SELECT 
    72       ENDDO 
    73  
     51      INTEGER  ::   ib_bdy, ir     ! BDY set index, rim index 
     52      LOGICAL  ::   llrim0         ! indicate if rim 0 is treated 
     53      LOGICAL, DIMENSION(4) :: llsend2, llrecv2, llsend3, llrecv3  ! indicate how communications are to be carried out 
     54       
     55      llsend2(:) = .false.   ;   llrecv2(:) = .false. 
     56      llsend3(:) = .false.   ;   llrecv3(:) = .false. 
     57      DO ir = 1, 0, -1   ! treat rim 1 before rim 0 
     58         IF( ir == 0 ) THEN   ;   llrim0 = .TRUE. 
     59         ELSE                 ;   llrim0 = .FALSE. 
     60         END IF 
     61         DO ib_bdy=1, nb_bdy 
     62            SELECT CASE( cn_dyn2d(ib_bdy) ) 
     63            CASE('none') 
     64               CYCLE 
     65            CASE('frs')   ! treat the whole boundary at once 
     66               IF( llrim0 )   CALL bdy_dyn2d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, pua2d, pva2d ) 
     67            CASE('flather') 
     68               CALL bdy_dyn2d_fla( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, pua2d, pva2d, pssh, phur, phvr, llrim0 ) 
     69            CASE('orlanski') 
     70               CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, & 
     71                    & pua2d, pva2d, pub2d, pvb2d, llrim0, ll_npo=.false. ) 
     72            CASE('orlanski_npo') 
     73               CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, & 
     74                    & pua2d, pva2d, pub2d, pvb2d, llrim0, ll_npo=.true.  ) 
     75            CASE DEFAULT 
     76               CALL ctl_stop( 'bdy_dyn2d : unrecognised option for open boundaries for barotropic variables' ) 
     77            END SELECT 
     78         ENDDO 
     79         ! 
     80         IF( nn_hls > 1 .AND. ir == 1 ) CYCLE   ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 
     81         IF( nn_hls == 1 ) THEN 
     82            llsend2(:) = .false.   ;   llrecv2(:) = .false. 
     83            llsend3(:) = .false.   ;   llrecv3(:) = .false. 
     84         END IF 
     85         DO ib_bdy=1, nb_bdy 
     86            SELECT CASE( cn_dyn2d(ib_bdy) ) 
     87            CASE('flather') 
     88               llsend2(1:2) = llsend2(1:2) .OR. lsend_bdyint(ib_bdy,2,1:2,ir)   ! west/east, U points 
     89               llsend2(1)   = llsend2(1)   .OR. lsend_bdyext(ib_bdy,2,1,ir)     ! neighbour might search point towards its east bdy 
     90               llrecv2(1:2) = llrecv2(1:2) .OR. lrecv_bdyint(ib_bdy,2,1:2,ir)   ! west/east, U points 
     91               llrecv2(2)   = llrecv2(2)   .OR. lrecv_bdyext(ib_bdy,2,2,ir)     ! might search point towards bdy on the east 
     92               llsend3(3:4) = llsend3(3:4) .OR. lsend_bdyint(ib_bdy,3,3:4,ir)   ! north/south, V points 
     93               llsend3(3)   = llsend3(3)   .OR. lsend_bdyext(ib_bdy,3,3,ir)     ! neighbour might search point towards its north bdy  
     94               llrecv3(3:4) = llrecv3(3:4) .OR. lrecv_bdyint(ib_bdy,3,3:4,ir)   ! north/south, V points 
     95               llrecv3(4)   = llrecv3(4)   .OR. lrecv_bdyext(ib_bdy,3,4,ir)     ! might search point towards bdy on the north 
     96            CASE('orlanski', 'orlanski_npo') 
     97               llsend2(:) = llsend2(:) .OR. lsend_bdy(ib_bdy,2,:,ir)   ! possibly every direction, U points 
     98               llrecv2(:) = llrecv2(:) .OR. lrecv_bdy(ib_bdy,2,:,ir)   ! possibly every direction, U points 
     99               llsend3(:) = llsend3(:) .OR. lsend_bdy(ib_bdy,3,:,ir)   ! possibly every direction, V points 
     100               llrecv3(:) = llrecv3(:) .OR. lrecv_bdy(ib_bdy,3,:,ir)   ! possibly every direction, V points 
     101            END SELECT 
     102         END DO 
     103         IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN   ! if need to send/recv in at least one direction 
     104            CALL lbc_lnk( 'bdydyn2d', pua2d, 'U', -1., kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) 
     105         END IF 
     106         IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN   ! if need to send/recv in at least one direction 
     107            CALL lbc_lnk( 'bdydyn2d', pva2d, 'V', -1., kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) 
     108         END IF 
     109         ! 
     110      END DO   ! ir 
     111      ! 
    74112   END SUBROUTINE bdy_dyn2d 
    75113 
    … …  
    90128      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d  
    91129      !! 
    92       INTEGER  ::   jb, jk         ! dummy loop indices 
     130      INTEGER  ::   jb             ! dummy loop indices 
    93131      INTEGER  ::   ii, ij, igrd   ! local integers 
    94132      REAL(wp) ::   zwgt           ! boundary weight 
    … …  
    110148         pva2d(ii,ij) = ( pva2d(ii,ij) + zwgt * ( dta%v2d(jb) - pva2d(ii,ij) ) ) * vmask(ii,ij,1) 
    111149      END DO  
    112       CALL lbc_bdy_lnk( 'bdydyn2d', pua2d, 'U', -1., ib_bdy )  
    113       CALL lbc_bdy_lnk( 'bdydyn2d', pva2d, 'V', -1., ib_bdy)   ! Boundary points should be updated 
    114150      ! 
    115151   END SUBROUTINE bdy_dyn2d_frs 
    116152 
    117153 
    118    SUBROUTINE bdy_dyn2d_fla( idx, dta, ib_bdy, pua2d, pva2d, pssh, phur, phvr ) 
     154   SUBROUTINE bdy_dyn2d_fla( idx, dta, ib_bdy, pua2d, pva2d, pssh, phur, phvr, llrim0 ) 
    119155      !!---------------------------------------------------------------------- 
    120156      !!                 ***  SUBROUTINE bdy_dyn2d_fla  *** 
    … …  
    139175      INTEGER,                      INTENT(in) ::   ib_bdy  ! BDY set index 
    140176      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d 
    141       REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pssh, phur, phvr  
    142  
     177      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pssh, phur, phvr 
     178      LOGICAL                     , INTENT(in) ::   llrim0   ! indicate if rim 0 is treated 
     179      INTEGER  ::   ibeg, iend                       ! length of rim to be treated (rim 0 or rim 1) 
    143180      INTEGER  ::   jb, igrd                         ! dummy loop indices 
    144       INTEGER  ::   ii, ij, iim1, iip1, ijm1, ijp1   ! 2D addresses 
    145       REAL(wp), POINTER :: flagu, flagv              ! short cuts 
    146       REAL(wp) ::   zcorr                            ! Flather correction 
    147       REAL(wp) ::   zforc                            ! temporary scalar 
    148       REAL(wp) ::   zflag, z1_2                      !    "        " 
     181      INTEGER  ::   ii, ij                           ! 2D addresses 
     182      INTEGER  ::   iiTrim, ijTrim                   ! T pts i/j-indice on the rim 
     183      INTEGER  ::   iiToce, ijToce, iiUoce, ijVoce   ! T, U and V pts i/j-indice of the ocean next to the rim 
     184      REAL(wp) ::   flagu, flagv                     ! short cuts 
     185      REAL(wp) ::   zfla                             ! Flather correction 
     186      REAL(wp) ::   z1_2                             !  
     187      REAL(wp), DIMENSION(jpi,jpj) ::   sshdta       ! 2D version of dta%ssh 
    149188      !!---------------------------------------------------------------------- 
    150189 
    … …  
    153192      ! ---------------------------------! 
    154193      ! Flather boundary conditions     :! 
    155       ! ---------------------------------!  
    156       
    157 !!! REPLACE spgu with nemo_wrk work space 
    158  
    159       ! Fill temporary array with ssh data (here spgu): 
     194      ! ---------------------------------! 
     195 
     196      ! Fill temporary array with ssh data (here we use spgu with the alias sshdta): 
    160197      igrd = 1 
    161       spgu(:,:) = 0.0 
    162       DO jb = 1, idx%nblenrim(igrd) 
     198      IF( llrim0 ) THEN   ;   ibeg = 1                       ;   iend = idx%nblenrim0(igrd) 
     199      ELSE                ;   ibeg = idx%nblenrim0(igrd)+1   ;   iend = idx%nblenrim(igrd) 
     200      END IF 
     201      ! 
     202      DO jb = ibeg, iend 
    163203         ii = idx%nbi(jb,igrd) 
    164204         ij = idx%nbj(jb,igrd) 
    165          IF( ll_wd ) THEN 
    166             spgu(ii, ij) = dta%ssh(jb)  - ssh_ref  
    167          ELSE 
    168             spgu(ii, ij) = dta%ssh(jb) 
     205         IF( ll_wd ) THEN   ;   sshdta(ii, ij) = dta%ssh(jb) - ssh_ref  
     206         ELSE               ;   sshdta(ii, ij) = dta%ssh(jb) 
    169207         ENDIF 
    170208      END DO 
    171  
    172       CALL lbc_bdy_lnk( 'bdydyn2d', spgu(:,:), 'T', 1., ib_bdy ) 
    173       ! 
    174       igrd = 2      ! Flather bc on u-velocity;  
     209      ! 
     210      igrd = 2      ! Flather bc on u-velocity 
    175211      !             ! remember that flagu=-1 if normal velocity direction is outward 
    176212      !             ! I think we should rather use after ssh ? 
    177       DO jb = 1, idx%nblenrim(igrd) 
    178          ii  = idx%nbi(jb,igrd) 
    179          ij  = idx%nbj(jb,igrd)  
    180          flagu => idx%flagu(jb,igrd) 
    181          iim1 = ii + MAX( 0, INT( flagu ) )   ! T pts i-indice inside the boundary 
    182          iip1 = ii - MIN( 0, INT( flagu ) )   ! T pts i-indice outside the boundary  
    183          ! 
    184          zcorr = - flagu * SQRT( grav * phur(ii, ij) ) * ( pssh(iim1, ij) - spgu(iip1,ij) ) 
    185  
    186          ! jchanut tschanges: Set zflag to 0 below to revert to Flather scheme 
    187          ! Use characteristics method instead 
    188          zflag = ABS(flagu) 
    189          zforc = dta%u2d(jb) * (1._wp - z1_2*zflag) + z1_2 * zflag * pua2d(iim1,ij) 
    190          pua2d(ii,ij) = zforc + (1._wp - z1_2*zflag) * zcorr * umask(ii,ij,1)  
     213      IF( llrim0 ) THEN   ;   ibeg = 1                       ;   iend = idx%nblenrim0(igrd) 
     214      ELSE                ;   ibeg = idx%nblenrim0(igrd)+1   ;   iend = idx%nblenrim(igrd) 
     215      END IF 
     216      DO jb = ibeg, iend 
     217         ii    = idx%nbi(jb,igrd) 
     218         ij    = idx%nbj(jb,igrd) 
     219         flagu = idx%flagu(jb,igrd) 
     220         IF( flagu == 0. ) THEN 
     221            pua2d(ii,ij) = dta%u2d(jb) 
     222         ELSE      ! T pts j-indice       on the rim          on the ocean next to the rim on T and U points 
     223            IF( flagu ==  1. ) THEN   ;   iiTrim = ii     ;   iiToce = ii+1   ;   iiUoce = ii+1   ;   ENDIF 
     224            IF( flagu == -1. ) THEN   ;   iiTrim = ii+1   ;   iiToce = ii     ;   iiUoce = ii-1   ;   ENDIF 
     225            ! 
     226            ! Rare case : rim is parallel to the mpi subdomain border and on the halo : point will be received 
     227            IF( iiTrim > jpi .OR. iiToce > jpi .OR. iiUoce > jpi .OR. iiUoce < 1 )   CYCLE    
     228            ! 
     229            zfla = dta%u2d(jb) - flagu * SQRT( grav * phur(ii, ij) ) * ( pssh(iiToce,ij) - sshdta(iiTrim,ij) ) 
     230            ! 
     231            ! jchanut tschanges, use characteristics method (Blayo et Debreu, 2005) : 
     232            ! mix Flather scheme with velocity of the ocean next to the rim 
     233            pua2d(ii,ij) =  z1_2 * ( pua2d(iiUoce,ij) + zfla ) 
     234         END IF 
    191235      END DO 
    192236      ! 
    193237      igrd = 3      ! Flather bc on v-velocity 
    194238      !             ! remember that flagv=-1 if normal velocity direction is outward 
    195       DO jb = 1, idx%nblenrim(igrd) 
    196          ii  = idx%nbi(jb,igrd) 
    197          ij  = idx%nbj(jb,igrd)  
    198          flagv => idx%flagv(jb,igrd) 
    199          ijm1 = ij + MAX( 0, INT( flagv ) )   ! T pts j-indice inside the boundary 
    200          ijp1 = ij - MIN( 0, INT( flagv ) )   ! T pts j-indice outside the boundary  
    201          ! 
    202          zcorr = - flagv * SQRT( grav * phvr(ii, ij) ) * ( pssh(ii, ijm1) - spgu(ii,ijp1) ) 
    203  
    204          ! jchanut tschanges: Set zflag to 0 below to revert to std Flather scheme 
    205          ! Use characteristics method instead 
    206          zflag = ABS(flagv) 
    207          zforc  = dta%v2d(jb) * (1._wp - z1_2*zflag) + z1_2 * zflag * pva2d(ii,ijm1) 
    208          pva2d(ii,ij) = zforc + (1._wp - z1_2*zflag) * zcorr * vmask(ii,ij,1) 
    209       END DO 
    210       CALL lbc_bdy_lnk( 'bdydyn2d', pua2d, 'U', -1., ib_bdy )   ! Boundary points should be updated 
    211       CALL lbc_bdy_lnk( 'bdydyn2d', pva2d, 'V', -1., ib_bdy )   ! 
     239      IF( llrim0 ) THEN   ;   ibeg = 1                       ;   iend = idx%nblenrim0(igrd) 
     240      ELSE                ;   ibeg = idx%nblenrim0(igrd)+1   ;   iend = idx%nblenrim(igrd) 
     241      END IF 
     242      DO jb = ibeg, iend 
     243         ii    = idx%nbi(jb,igrd) 
     244         ij    = idx%nbj(jb,igrd) 
     245         flagv = idx%flagv(jb,igrd) 
     246         IF( flagv == 0. ) THEN 
     247            pva2d(ii,ij) = dta%v2d(jb) 
     248         ELSE      ! T pts j-indice       on the rim          on the ocean next to the rim on T and V points 
     249            IF( flagv ==  1. ) THEN   ;   ijTrim = ij     ;   ijToce = ij+1   ;   ijVoce = ij+1   ;   ENDIF 
     250            IF( flagv == -1. ) THEN   ;   ijTrim = ij+1   ;   ijToce = ij     ;   ijVoce = ij-1   ;   ENDIF 
     251            ! 
     252            ! Rare case : rim is parallel to the mpi subdomain border and on the halo : point will be received 
     253            IF( ijTrim > jpj .OR. ijToce > jpj .OR. ijVoce > jpj .OR. ijVoce < 1 )   CYCLE 
     254            ! 
     255            zfla = dta%v2d(jb) - flagv * SQRT( grav * phvr(ii, ij) ) * ( pssh(ii,ijToce) - sshdta(ii,ijTrim) ) 
     256            ! 
     257            ! jchanut tschanges, use characteristics method (Blayo et Debreu, 2005) : 
     258            ! mix Flather scheme with velocity of the ocean next to the rim 
     259            pva2d(ii,ij) =  z1_2 * ( pva2d(ii,ijVoce) + zfla ) 
     260         END IF 
     261      END DO 
    212262      ! 
    213263   END SUBROUTINE bdy_dyn2d_fla 
    214264 
    215265 
    216    SUBROUTINE bdy_dyn2d_orlanski( idx, dta, ib_bdy, pua2d, pva2d, pub2d, pvb2d, ll_npo ) 
     266   SUBROUTINE bdy_dyn2d_orlanski( idx, dta, ib_bdy, pua2d, pva2d, pub2d, pvb2d, llrim0, ll_npo ) 
    217267      !!---------------------------------------------------------------------- 
    218268      !!                 ***  SUBROUTINE bdy_dyn2d_orlanski  *** 
    … …  
    231281      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pub2d, pvb2d  
    232282      LOGICAL,                      INTENT(in) ::   ll_npo  ! flag for NPO version 
    233  
     283      LOGICAL,                      INTENT(in) ::   llrim0   ! indicate if rim 0 is treated 
    234284      INTEGER  ::   ib, igrd                               ! dummy loop indices 
    235285      INTEGER  ::   ii, ij, iibm1, ijbm1                   ! indices 
    … …  
    238288      igrd = 2      ! Orlanski bc on u-velocity;  
    239289      !             
    240       CALL bdy_orlanski_2d( idx, igrd, pub2d, pua2d, dta%u2d, ll_npo ) 
     290      CALL bdy_orlanski_2d( idx, igrd, pub2d, pua2d, dta%u2d, llrim0, ll_npo ) 
    241291 
    242292      igrd = 3      ! Orlanski bc on v-velocity 
    243293      !   
    244       CALL bdy_orlanski_2d( idx, igrd, pvb2d, pva2d, dta%v2d, ll_npo ) 
    245       ! 
    246       CALL lbc_bdy_lnk( 'bdydyn2d', pua2d, 'U', -1., ib_bdy )   ! Boundary points should be updated 
    247       CALL lbc_bdy_lnk( 'bdydyn2d', pva2d, 'V', -1., ib_bdy )   ! 
     294      CALL bdy_orlanski_2d( idx, igrd, pvb2d, pva2d, dta%v2d, llrim0, ll_npo ) 
    248295      ! 
    249296   END SUBROUTINE bdy_dyn2d_orlanski 
    … …  
    257304      !! 
    258305      !!---------------------------------------------------------------------- 
    259       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   zssh ! Sea level 
    260       !! 
    261       INTEGER  ::   ib_bdy, ib, igrd                        ! local integers 
    262       INTEGER  ::   ii, ij, zcoef, zcoef1, zcoef2, ip, jp   !   "       " 
    263  
    264       igrd = 1                       ! Everything is at T-points here 
    265  
    266       DO ib_bdy = 1, nb_bdy 
    267          DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 
    268             ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    269             ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    270             ! Set gradient direction: 
    271             zcoef1 = bdytmask(ii-1,ij  ) +  bdytmask(ii+1,ij  ) 
    272             zcoef2 = bdytmask(ii  ,ij-1) +  bdytmask(ii  ,ij+1) 
    273             IF ( zcoef1+zcoef2 == 0 ) THEN   ! corner 
    274                zcoef = bdytmask(ii-1,ij-1) + bdytmask(ii+1,ij+1) + bdytmask(ii+1,ij-1) + bdytmask(ii-1,ij+1) 
    275                zssh(ii,ij) = zssh( ii-1, ij-1 ) * bdytmask( ii-1, ij-1) + & 
    276                  &           zssh( ii+1, ij+1 ) * bdytmask( ii+1, ij+1) + & 
    277                  &           zssh( ii+1, ij-1 ) * bdytmask( ii+1, ij-1) + & 
    278                  &           zssh( ii-1, ij+1 ) * bdytmask( ii-1, ij+1) 
    279                zssh(ii,ij) = ( zssh(ii,ij) / MAX( 1, zcoef) ) * tmask(ii,ij,1) 
    280             ELSE 
    281                ip = bdytmask(ii+1,ij  ) - bdytmask(ii-1,ij  ) 
    282                jp = bdytmask(ii  ,ij+1) - bdytmask(ii  ,ij-1) 
    283                zssh(ii,ij) = zssh(ii+ip,ij+jp) * tmask(ii+ip,ij+jp,1) 
    284             ENDIF 
     306      REAL(wp), DIMENSION(jpi,jpj,1), INTENT(inout) ::   zssh ! Sea level, need 3 dimensions to be used by bdy_nmn 
     307      !! 
     308      INTEGER ::   ib_bdy, ir      ! bdy index, rim index 
     309      INTEGER ::   ibeg, iend      ! length of rim to be treated (rim 0 or rim 1) 
     310      LOGICAL ::   llrim0          ! indicate if rim 0 is treated 
     311      LOGICAL, DIMENSION(4) :: llsend1, llrecv1  ! indicate how communications are to be carried out 
     312      !!---------------------------------------------------------------------- 
     313      llsend1(:) = .false.   ;   llrecv1(:) = .false. 
     314      DO ir = 1, 0, -1   ! treat rim 1 before rim 0 
     315         IF( nn_hls == 1 ) THEN   ;   llsend1(:) = .false.   ;   llrecv1(:) = .false.   ;   END IF 
     316         IF( ir == 0 ) THEN   ;   llrim0 = .TRUE. 
     317         ELSE                 ;   llrim0 = .FALSE. 
     318         END IF 
     319         DO ib_bdy = 1, nb_bdy 
     320            CALL bdy_nmn( idx_bdy(ib_bdy), 1, zssh, llrim0 )   ! zssh is masked 
     321            llsend1(:) = llsend1(:) .OR. lsend_bdyint(ib_bdy,1,:,ir)   ! possibly every direction, T points 
     322            llrecv1(:) = llrecv1(:) .OR. lrecv_bdyint(ib_bdy,1,:,ir)   ! possibly every direction, T points 
    285323         END DO 
    286  
    287          ! Boundary points should be updated 
    288          CALL lbc_bdy_lnk( 'bdydyn2d', zssh(:,:), 'T', 1., ib_bdy ) 
    289       END DO 
    290  
     324         IF( nn_hls > 1 .AND. ir == 1 ) CYCLE   ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 
     325         IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN   ! if need to send/recv in at least one direction 
     326            CALL lbc_lnk( 'bdydyn2d', zssh(:,:,1), 'T',  1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
     327         END IF 
     328      END DO 
     329      ! 
    291330   END SUBROUTINE bdy_ssh 
    292331 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/BDY/bdydyn3d.F90

    r10957 r11822  
    4444      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT( inout ) ::   puu, pvv  ! Ocean velocities (to be updated at open boundaries) 
    4545      ! 
    46       INTEGER ::   ib_bdy   ! loop index 
    47       !!---------------------------------------------------------------------- 
    48       ! 
    49       DO ib_bdy=1, nb_bdy 
     46      INTEGER  ::   ib_bdy, ir     ! BDY set index, rim index 
     47      LOGICAL  ::   llrim0         ! indicate if rim 0 is treated 
     48      LOGICAL, DIMENSION(4) :: llsend2, llrecv2, llsend3, llrecv3  ! indicate how communications are to be carried out 
     49 
     50      !!---------------------------------------------------------------------- 
     51      llsend2(:) = .false.   ;   llrecv2(:) = .false. 
     52      llsend3(:) = .false.   ;   llrecv3(:) = .false. 
     53      DO ir = 1, 0, -1   ! treat rim 1 before rim 0 
     54         IF( ir == 0 ) THEN   ;   llrim0 = .TRUE. 
     55         ELSE                 ;   llrim0 = .FALSE. 
     56         END IF 
     57         DO ib_bdy=1, nb_bdy 
     58            ! 
     59            SELECT CASE( cn_dyn3d(ib_bdy) ) 
     60            CASE('none')        ;   CYCLE 
     61            CASE('frs' )        ! treat the whole boundary at once 
     62                       IF( ir == 0) CALL bdy_dyn3d_frs( puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
     63            CASE('specified')   ! treat the whole rim      at once 
     64                       IF( ir == 0) CALL bdy_dyn3d_spe( puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
     65            CASE('zero')        ! treat the whole rim      at once 
     66                       IF( ir == 0) CALL bdy_dyn3d_zro( puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
     67            CASE('orlanski' )   ;   CALL bdy_dyn3d_orlanski( Kbb, puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, llrim0, ll_npo=.false. ) 
     68            CASE('orlanski_npo');   CALL bdy_dyn3d_orlanski( Kbb, puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, llrim0, ll_npo=.true.  ) 
     69            CASE('zerograd')    ;   CALL bdy_dyn3d_zgrad( puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy, llrim0 ) 
     70            CASE('neumann')     ;   CALL bdy_dyn3d_nmn( puu, pvv, Kaa, idx_bdy(ib_bdy), ib_bdy, llrim0 ) 
     71            CASE DEFAULT        ;   CALL ctl_stop( 'bdy_dyn3d : unrecognised option for open boundaries for baroclinic velocities' ) 
     72            END SELECT 
     73         END DO 
    5074         ! 
    51          SELECT CASE( cn_dyn3d(ib_bdy) ) 
    52          CASE('none')        ;   CYCLE 
    53          CASE('frs' )        ;   CALL bdy_dyn3d_frs(           puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy ) 
    54          CASE('specified')   ;   CALL bdy_dyn3d_spe(           puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy ) 
    55          CASE('zero')        ;   CALL bdy_dyn3d_zro(           puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy ) 
    56          CASE('orlanski' )   ;   CALL bdy_dyn3d_orlanski( Kbb, puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, ll_npo=.false. ) 
    57          CASE('orlanski_npo');   CALL bdy_dyn3d_orlanski( Kbb, puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, ll_npo=.true. ) 
    58          CASE('zerograd')    ;   CALL bdy_dyn3d_zgrad(         puu, pvv, Kaa, idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy ) 
    59          CASE('neumann')     ;   CALL bdy_dyn3d_nmn(           puu, pvv, Kaa, idx_bdy(ib_bdy), ib_bdy ) 
    60          CASE DEFAULT        ;   CALL ctl_stop( 'bdy_dyn3d : unrecognised option for open boundaries for baroclinic velocities' ) 
    61          END SELECT 
    62       END DO 
     75         IF( nn_hls > 1 .AND. ir == 1 ) CYCLE   ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 
     76         IF( nn_hls == 1 ) THEN 
     77            llsend2(:) = .false.   ;   llrecv2(:) = .false. 
     78            llsend3(:) = .false.   ;   llrecv3(:) = .false. 
     79         END IF 
     80         DO ib_bdy=1, nb_bdy 
     81            SELECT CASE( cn_dyn3d(ib_bdy) ) 
     82            CASE('orlanski', 'orlanski_npo') 
     83               llsend2(:) = llsend2(:) .OR. lsend_bdy(ib_bdy,2,:,ir)   ! possibly every direction, U points 
     84               llrecv2(:) = llrecv2(:) .OR. lrecv_bdy(ib_bdy,2,:,ir)   ! possibly every direction, U points 
     85               llsend3(:) = llsend3(:) .OR. lsend_bdy(ib_bdy,3,:,ir)   ! possibly every direction, V points 
     86               llrecv3(:) = llrecv3(:) .OR. lrecv_bdy(ib_bdy,3,:,ir)   ! possibly every direction, V points 
     87            CASE('zerograd') 
     88               llsend2(3:4) = llsend2(3:4) .OR. lsend_bdyint(ib_bdy,2,3:4,ir)   ! north/south, U points 
     89               llrecv2(3:4) = llrecv2(3:4) .OR. lrecv_bdyint(ib_bdy,2,3:4,ir)   ! north/south, U points 
     90               llsend3(1:2) = llsend3(1:2) .OR. lsend_bdyint(ib_bdy,3,1:2,ir)   ! west/east, V points 
     91               llrecv3(1:2) = llrecv3(1:2) .OR. lrecv_bdyint(ib_bdy,3,1:2,ir)   ! west/east, V points 
     92            CASE('neumann') 
     93               llsend2(:) = llsend2(:) .OR. lsend_bdyint(ib_bdy,2,:,ir)   ! possibly every direction, U points 
     94               llrecv2(:) = llrecv2(:) .OR. lrecv_bdyint(ib_bdy,2,:,ir)   ! possibly every direction, U points 
     95               llsend3(:) = llsend3(:) .OR. lsend_bdyint(ib_bdy,3,:,ir)   ! possibly every direction, V points 
     96               llrecv3(:) = llrecv3(:) .OR. lrecv_bdyint(ib_bdy,3,:,ir)   ! possibly every direction, V points 
     97            END SELECT 
     98         END DO 
     99         ! 
     100         IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN   ! if need to send/recv in at least one direction 
     101            CALL lbc_lnk( 'bdydyn2d', puu(:,:,:,Kaa), 'U', -1., kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) 
     102         END IF 
     103         IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN   ! if need to send/recv in at least one direction 
     104            CALL lbc_lnk( 'bdydyn2d', pvv(:,:,:,Kaa), 'V', -1., kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) 
     105         END IF 
     106      END DO   ! ir 
    63107      ! 
    64108   END SUBROUTINE bdy_dyn3d 
    65109 
    66110 
    67    SUBROUTINE bdy_dyn3d_spe( puu, pvv, Kaa, idx, dta, ib_bdy ) 
     111   SUBROUTINE bdy_dyn3d_spe( puu, pvv, Kaa, idx, dta, kt, ib_bdy ) 
    68112      !!---------------------------------------------------------------------- 
    69113      !!                  ***  SUBROUTINE bdy_dyn3d_spe  *** 
    … …  
    77121      TYPE(OBC_INDEX)                     , INTENT( in    ) ::   idx       ! OBC indices 
    78122      TYPE(OBC_DATA)                      , INTENT( in    ) ::   dta       ! OBC external data 
     123      INTEGER                             , INTENT( in    ) ::   kt        ! Time step 
    79124      INTEGER                             , INTENT( in    ) ::   ib_bdy    ! BDY set index 
    80125      ! 
    81126      INTEGER  ::   jb, jk         ! dummy loop indices 
    82127      INTEGER  ::   ii, ij, igrd   ! local integers 
    83       REAL(wp) ::   zwgt           ! boundary weight 
    84128      !!---------------------------------------------------------------------- 
    85129      ! 
    … …  
    101145         END DO 
    102146      END DO 
    103       CALL lbc_bdy_lnk( 'bdydyn3d', puu(:,:,:,Kaa), 'U', -1., ib_bdy )   ! Boundary points should be updated   
    104       CALL lbc_bdy_lnk( 'bdydyn3d', pvv(:,:,:,Kaa), 'V', -1., ib_bdy )    
    105147      ! 
    106148   END SUBROUTINE bdy_dyn3d_spe 
    107149 
    108150 
    109    SUBROUTINE bdy_dyn3d_zgrad( puu, pvv, Kaa, idx, dta, ib_bdy ) 
     151   SUBROUTINE bdy_dyn3d_zgrad( puu, pvv, Kaa, idx, dta, kt, ib_bdy, llrim0 ) 
    110152      !!---------------------------------------------------------------------- 
    111153      !!                  ***  SUBROUTINE bdy_dyn3d_zgrad  *** 
    … …  
    118160      TYPE(OBC_INDEX)                     , INTENT( in    ) ::   idx       ! OBC indices 
    119161      TYPE(OBC_DATA)                      , INTENT( in    ) ::   dta       ! OBC external data 
    120       INTEGER                             , INTENT( in    ) ::   ib_bdy    ! BDY set index 
     162      INTEGER                             , INTENT( in    ) ::   kt 
     163      INTEGER                             , INTENT( in    ) ::   ib_bdy    ! BDY set index 
     164      LOGICAL                             , INTENT( in    ) ::   llrim0   ! indicate if rim 0 is treated 
    121165      !! 
    122166      INTEGER  ::   jb, jk         ! dummy loop indices 
    123167      INTEGER  ::   ii, ij, igrd   ! local integers 
    124       REAL(wp) ::   zwgt           ! boundary weight 
    125       INTEGER  ::   fu, fv 
     168      INTEGER  ::   flagu, flagv           ! short cuts 
     169      INTEGER  ::   ibeg, iend     ! length of rim to be treated (rim 0 or rim 1 or both) 
    126170      !!---------------------------------------------------------------------- 
    127171      ! 
    128172      igrd = 2                      ! Copying tangential velocity into bdy points 
    129       DO jb = 1, idx%nblenrim(igrd) 
    130          DO jk = 1, jpkm1 
    131             ii   = idx%nbi(jb,igrd) 
    132             ij   = idx%nbj(jb,igrd) 
    133             fu   = ABS( ABS (NINT( idx%flagu(jb,igrd) ) ) - 1 ) 
    134             puu(ii,ij,jk,Kaa) = puu(ii,ij,jk,Kaa) * REAL( 1 - fu) + ( puu(ii,ij+fu,jk,Kaa) * umask(ii,ij+fu,jk) & 
    135                         &+ puu(ii,ij-fu,jk,Kaa) * umask(ii,ij-fu,jk) ) * umask(ii,ij,jk) * REAL( fu ) 
    136          END DO 
     173      IF( llrim0 ) THEN   ;   ibeg = 1                       ;   iend = idx%nblenrim0(igrd) 
     174      ELSE                ;   ibeg = idx%nblenrim0(igrd)+1   ;   iend = idx%nblenrim(igrd) 
     175      ENDIF 
     176      DO jb = ibeg, iend 
     177         ii    = idx%nbi(jb,igrd) 
     178         ij    = idx%nbj(jb,igrd) 
     179         flagu = NINT(idx%flagu(jb,igrd)) 
     180         flagv = NINT(idx%flagv(jb,igrd)) 
     181         ! 
     182         IF( flagu == 0 )   THEN              ! north/south bdy 
     183            IF( ij+flagv > jpj .OR. ij+flagv < 1 )   CYCLE       
     184            ! 
     185            DO jk = 1, jpkm1 
     186               puu(ii,ij,jk,Kaa) = puu(ii,ij+flagv,jk,Kaa) * umask(ii,ij+flagv,jk) 
     187            END DO 
     188            ! 
     189         END IF 
    137190      END DO 
    138191      ! 
    139192      igrd = 3                      ! Copying tangential velocity into bdy points 
    140       DO jb = 1, idx%nblenrim(igrd) 
    141          DO jk = 1, jpkm1 
    142             ii   = idx%nbi(jb,igrd) 
    143             ij   = idx%nbj(jb,igrd) 
    144             fv   = ABS( ABS (NINT( idx%flagv(jb,igrd) ) ) - 1 ) 
    145             pvv(ii,ij,jk,Kaa) = pvv(ii,ij,jk,Kaa) * REAL( 1 - fv ) + ( pvv(ii+fv,ij,jk,Kaa) * vmask(ii+fv,ij,jk) & 
    146                         &+ pvv(ii-fv,ij,jk,Kaa) * vmask(ii-fv,ij,jk) ) * vmask(ii,ij,jk) * REAL( fv ) 
    147          END DO 
    148       END DO 
    149       CALL lbc_bdy_lnk( 'bdydyn3d', puu(:,:,:,Kaa), 'U', -1., ib_bdy )   ! Boundary points should be updated   
    150       CALL lbc_bdy_lnk( 'bdydyn3d', pvv(:,:,:,Kaa), 'V', -1., ib_bdy )    
     193      IF( llrim0 ) THEN   ;   ibeg = 1                       ;   iend = idx%nblenrim0(igrd) 
     194      ELSE                ;   ibeg = idx%nblenrim0(igrd)+1   ;   iend = idx%nblenrim(igrd) 
     195      ENDIF 
     196      DO jb = ibeg, iend 
     197         ii    = idx%nbi(jb,igrd) 
     198         ij    = idx%nbj(jb,igrd) 
     199         flagu = NINT(idx%flagu(jb,igrd)) 
     200         flagv = NINT(idx%flagv(jb,igrd)) 
     201         ! 
     202         IF( flagv == 0 )   THEN              !  west/east  bdy 
     203            IF( ii+flagu > jpi .OR. ii+flagu < 1 )   CYCLE       
     204            ! 
     205            DO jk = 1, jpkm1 
     206               pvv(ii,ij,jk,Kaa) = pvv(ii+flagu,ij,jk,Kaa) * vmask(ii+flagu,ij,jk) 
     207            END DO 
     208            ! 
     209         END IF 
     210      END DO 
    151211      ! 
    152212   END SUBROUTINE bdy_dyn3d_zgrad 
    153213 
    154214 
    155    SUBROUTINE bdy_dyn3d_zro( puu, pvv, Kaa, idx, dta, ib_bdy ) 
     215   SUBROUTINE bdy_dyn3d_zro( puu, pvv, Kaa, idx, dta, kt, ib_bdy ) 
    156216      !!---------------------------------------------------------------------- 
    157217      !!                  ***  SUBROUTINE bdy_dyn3d_zro  *** 
    … …  
    160220      !! 
    161221      !!---------------------------------------------------------------------- 
     222      INTEGER                             , INTENT( in    ) ::   kt        ! time step index 
    162223      INTEGER                             , INTENT( in    ) ::   Kaa       ! Time level index 
    163224      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT( inout ) ::   puu, pvv  ! Ocean velocities (to be updated at open boundaries) 
    … …  
    168229      INTEGER  ::   ib, ik         ! dummy loop indices 
    169230      INTEGER  ::   ii, ij, igrd   ! local integers 
    170       REAL(wp) ::   zwgt           ! boundary weight 
    171231      !!---------------------------------------------------------------------- 
    172232      ! 
    … …  
    179239         END DO 
    180240      END DO 
    181  
     241      ! 
    182242      igrd = 3                       ! Everything is at T-points here 
    183243      DO ib = 1, idx%nblenrim(igrd) 
    … …  
    189249      END DO 
    190250      ! 
    191       CALL lbc_bdy_lnk( 'bdydyn3d', puu(:,:,:,Kaa), 'U', -1., ib_bdy )   ;   CALL lbc_bdy_lnk( 'bdydyn3d', pvv(:,:,:,Kaa), 'V', -1.,ib_bdy )   ! Boundary points should be updated 
    192       ! 
    193251   END SUBROUTINE bdy_dyn3d_zro 
    194252 
    195253 
    196    SUBROUTINE bdy_dyn3d_frs( puu, pvv, Kaa, idx, dta, ib_bdy ) 
     254   SUBROUTINE bdy_dyn3d_frs( puu, pvv, Kaa, idx, dta, kt, ib_bdy ) 
    197255      !!---------------------------------------------------------------------- 
    198256      !!                  ***  SUBROUTINE bdy_dyn3d_frs  *** 
    … …  
    205263      !!               topography. Tellus, 365-382. 
    206264      !!---------------------------------------------------------------------- 
     265      INTEGER                             , INTENT( in    ) ::   kt        ! time step index 
    207266      INTEGER                             , INTENT( in    ) ::   Kaa       ! Time level index 
    208267      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT( inout ) ::   puu, pvv  ! Ocean velocities (to be updated at open boundaries) 
    … …  
    234293            pvv(ii,ij,jk,Kaa) = ( pvv(ii,ij,jk,Kaa) + zwgt * ( dta%v3d(jb,jk) - pvv(ii,ij,jk,Kaa) ) ) * vmask(ii,ij,jk) 
    235294         END DO 
    236       END DO  
    237       CALL lbc_bdy_lnk( 'bdydyn3d', puu(:,:,:,Kaa), 'U', -1., ib_bdy )    ! Boundary points should be updated 
    238       CALL lbc_bdy_lnk( 'bdydyn3d', pvv(:,:,:,Kaa), 'V', -1., ib_bdy )    
     295      END DO    
    239296      ! 
    240297   END SUBROUTINE bdy_dyn3d_frs 
    241298 
    242299 
    243    SUBROUTINE bdy_dyn3d_orlanski( Kbb, puu, pvv, Kaa, idx, dta, ib_bdy, ll_npo ) 
     300   SUBROUTINE bdy_dyn3d_orlanski( Kbb, puu, pvv, Kaa, idx, dta, ib_bdy, llrim0, ll_npo ) 
    244301      !!---------------------------------------------------------------------- 
    245302      !!                 ***  SUBROUTINE bdy_dyn3d_orlanski  *** 
    … …  
    253310      INTEGER                             , INTENT( in    ) ::   Kbb, Kaa  ! Time level indices 
    254311      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT( inout ) ::   puu, pvv  ! Ocean velocities (to be updated at open boundaries) 
    255       TYPE(OBC_INDEX)                     , INTENT( in    ) ::   idx  ! OBC indices 
    256       TYPE(OBC_DATA)                      , INTENT( in    ) ::   dta  ! OBC external data 
    257       INTEGER                             , INTENT( in    ) ::   ib_bdy  ! BDY set index 
    258       LOGICAL                             , INTENT( in    ) ::   ll_npo  ! switch for NPO version 
     312      TYPE(OBC_INDEX)                     , INTENT( in    ) ::   idx       ! OBC indices 
     313      TYPE(OBC_DATA)                      , INTENT( in    ) ::   dta       ! OBC external data 
     314      INTEGER                             , INTENT( in    ) ::   ib_bdy    ! BDY set index 
     315      LOGICAL                             , INTENT( in    ) ::   llrim0    ! indicate if rim 0 is treated 
     316      LOGICAL                             , INTENT( in    ) ::   ll_npo    ! switch for NPO version 
    259317 
    260318      INTEGER  ::   jb, igrd                               ! dummy loop indices 
    … …  
    265323      igrd = 2      ! Orlanski bc on u-velocity;  
    266324      !             
    267       CALL bdy_orlanski_3d( idx, igrd, puu(:,:,:,Kbb), puu(:,:,:,Kaa), dta%u3d, ll_npo ) 
     325      CALL bdy_orlanski_3d( idx, igrd, puu(:,:,:,Kbb), puu(:,:,:,Kaa), dta%u3d, ll_npo, llrim0 ) 
    268326 
    269327      igrd = 3      ! Orlanski bc on v-velocity 
    270328      !   
    271       CALL bdy_orlanski_3d( idx, igrd, pvv(:,:,:,Kbb), pvv(:,:,:,Kaa), dta%v3d, ll_npo ) 
    272       ! 
    273       CALL lbc_bdy_lnk( 'bdydyn3d', puu(:,:,:,Kaa), 'U', -1., ib_bdy )    ! Boundary points should be updated 
    274       CALL lbc_bdy_lnk( 'bdydyn3d', pvv(:,:,:,Kaa), 'V', -1., ib_bdy )    
     329      CALL bdy_orlanski_3d( idx, igrd, pvv(:,:,:,Kbb), pvv(:,:,:,Kaa), dta%v3d, ll_npo, llrim0 ) 
    275330      ! 
    276331   END SUBROUTINE bdy_dyn3d_orlanski 
    … …  
    322377      END DO 
    323378      ! 
    324       CALL lbc_lnk_multi( 'bdydyn3d', puu(:,:,:,Krhs), 'U', -1.,  pvv(:,:,:,Krhs), 'V', -1. )   ! Boundary points should be updated 
    325       ! 
    326379      IF( ln_timing )   CALL timing_stop('bdy_dyn3d_dmp') 
    327380      ! 
    … …  
    329382 
    330383 
    331    SUBROUTINE bdy_dyn3d_nmn( puu, pvv, Kaa, idx, ib_bdy ) 
     384   SUBROUTINE bdy_dyn3d_nmn( puu, pvv, Kaa, idx, ib_bdy, llrim0 ) 
    332385      !!---------------------------------------------------------------------- 
    333386      !!                 ***  SUBROUTINE bdy_dyn3d_nmn  *** 
    … …  
    342395      TYPE(OBC_INDEX)                     , INTENT( in    ) ::   idx       ! OBC indices 
    343396      INTEGER                             , INTENT( in    ) ::   ib_bdy    ! BDY set index 
    344  
    345       INTEGER  ::   jb, igrd                               ! dummy loop indices 
     397      LOGICAL                             , INTENT( in    ) ::   llrim0    ! indicate if rim 0 is treated 
     398      INTEGER  ::   igrd                        ! dummy indice 
    346399      !!---------------------------------------------------------------------- 
    347400      ! 
    … …  
    350403      igrd = 2      ! Neumann bc on u-velocity;  
    351404      !             
    352       CALL bdy_nmn( idx, igrd, puu(:,:,:,Kaa) ) 
     405      CALL bdy_nmn( idx, igrd, puu(:,:,:,Kaa), llrim0 ) 
    353406 
    354407      igrd = 3      ! Neumann bc on v-velocity 
    355408      !   
    356       CALL bdy_nmn( idx, igrd, pvv(:,:,:,Kaa) ) 
    357       ! 
    358       CALL lbc_bdy_lnk( 'bdydyn3d', puu(:,:,:,Kaa), 'U', -1., ib_bdy )    ! Boundary points should be updated 
    359       CALL lbc_bdy_lnk( 'bdydyn3d', pvv(:,:,:,Kaa), 'V', -1., ib_bdy ) 
     409      CALL bdy_nmn( idx, igrd, pvv(:,:,:,Kaa), llrim0 ) 
    360410      ! 
    361411   END SUBROUTINE bdy_dyn3d_nmn 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/BDY/bdyice.F90

    r10425 r11822  
    5555      INTEGER, INTENT(in) ::   kt   ! Main time step counter 
    5656      ! 
    57       INTEGER ::   jbdy   ! BDY set index 
     57      INTEGER ::   jbdy, ir                             ! BDY set index, rim index 
     58      INTEGER ::   ibeg, iend                           ! length of rim to be treated (rim 0 or rim 1) 
     59      LOGICAL ::   llrim0                               ! indicate if rim 0 is treated 
     60      LOGICAL, DIMENSION(4)  :: llsend1, llrecv1        ! indicate how communications are to be carried out 
    5861      !!---------------------------------------------------------------------- 
    59       ! 
    60       IF( ln_timing )   CALL timing_start('bdy_ice_thd') 
     62      ! controls 
     63      IF( ln_timing    )   CALL timing_start('bdy_ice_thd')                                                            ! timing 
     64      IF( ln_icediachk )   CALL ice_cons_hsm(0,'bdy_ice_thd', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation 
     65      IF( ln_icediachk )   CALL ice_cons2D  (0,'bdy_ice_thd',  diag_v,  diag_s,  diag_t,  diag_fv,  diag_fs,  diag_ft) ! conservation 
    6166      ! 
    6267      CALL ice_var_glo2eqv 
    6368      ! 
    64       DO jbdy = 1, nb_bdy 
     69      llsend1(:) = .false.   ;   llrecv1(:) = .false. 
     70      DO ir = 1, 0, -1   ! treat rim 1 before rim 0 
     71         IF( ir == 0 ) THEN   ;   llrim0 = .TRUE. 
     72         ELSE                 ;   llrim0 = .FALSE. 
     73         END IF 
     74         DO jbdy = 1, nb_bdy 
     75            ! 
     76            SELECT CASE( cn_ice(jbdy) ) 
     77            CASE('none')   ;   CYCLE 
     78            CASE('frs' )   ;   CALL bdy_ice_frs( idx_bdy(jbdy), dta_bdy(jbdy), kt, jbdy, llrim0 ) 
     79            CASE DEFAULT 
     80               CALL ctl_stop( 'bdy_ice : unrecognised option for open boundaries for ice fields' ) 
     81            END SELECT 
     82            ! 
     83         END DO 
    6584         ! 
    66          SELECT CASE( cn_ice(jbdy) ) 
    67          CASE('none')   ;   CYCLE 
    68          CASE('frs' )   ;   CALL bdy_ice_frs( idx_bdy(jbdy), dta_bdy(jbdy), kt, jbdy ) 
    69          CASE DEFAULT 
    70             CALL ctl_stop( 'bdy_ice : unrecognised option for open boundaries for ice fields' ) 
    71          END SELECT 
    72          ! 
    73       END DO 
     85         ! Update bdy points         
     86         IF( nn_hls > 1 .AND. ir == 1 ) CYCLE   ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 
     87         IF( nn_hls == 1 ) THEN   ;   llsend1(:) = .false.   ;   llrecv1(:) = .false.   ;   END IF 
     88         DO jbdy = 1, nb_bdy 
     89            IF( cn_ice(jbdy) == 'frs' ) THEN 
     90               llsend1(:) = llsend1(:) .OR. lsend_bdyint(jbdy,1,:,ir)   ! possibly every direction, T points 
     91               llrecv1(:) = llrecv1(:) .OR. lrecv_bdyint(jbdy,1,:,ir)   ! possibly every direction, T points 
     92            END IF 
     93         END DO   ! jbdy 
     94         IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN   ! if need to send/recv in at least one direction 
     95            ! exchange 3d arrays 
     96            CALL lbc_lnk_multi( 'bdyice', a_i , 'T', 1., h_i , 'T', 1., h_s , 'T', 1., oa_i, 'T', 1. & 
     97                 &                      , a_ip, 'T', 1., v_ip, 'T', 1., s_i , 'T', 1., t_su, 'T', 1. & 
     98                 &                      , v_i , 'T', 1., v_s , 'T', 1., sv_i, 'T', 1.                & 
     99                 &                      , kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1      ) 
     100            ! exchange 4d arrays :   third dimension = 1   and then   third dimension = jpk 
     101            CALL lbc_lnk_multi( 'bdyice', t_s , 'T', 1., e_s , 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
     102            CALL lbc_lnk_multi( 'bdyice', t_i , 'T', 1., e_i , 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
     103         END IF 
     104      END DO   ! ir 
    74105      ! 
    75106      CALL ice_cor( kt , 0 )      ! -- In case categories are out of bounds, do a remapping 
    … …  
    78109      CALL ice_var_agg(1) 
    79110      ! 
    80       IF( ln_icectl )   CALL ice_prt( kt, iiceprt, jiceprt, 1, ' - ice thermo bdy - ' ) 
    81       IF( ln_timing )   CALL timing_stop('bdy_ice_thd') 
     111      ! controls 
     112      IF( ln_icectl    )   CALL ice_prt     ( kt, iiceprt, jiceprt, 1, ' - ice thermo bdy - ' )                        ! prints 
     113      IF( ln_icediachk )   CALL ice_cons_hsm(1,'bdy_ice_thd', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation 
     114      IF( ln_icediachk )   CALL ice_cons2D  (1,'bdy_ice_thd',  diag_v,  diag_s,  diag_t,  diag_fv,  diag_fs,  diag_ft) ! conservation 
     115      IF( ln_timing    )   CALL timing_stop ('bdy_ice_thd')                                                            ! timing 
    82116      ! 
    83117   END SUBROUTINE bdy_ice 
    84118 
    85119 
    86    SUBROUTINE bdy_ice_frs( idx, dta, kt, jbdy ) 
     120   SUBROUTINE bdy_ice_frs( idx, dta, kt, jbdy, llrim0 ) 
    87121      !!------------------------------------------------------------------------------ 
    88122      !!                 ***  SUBROUTINE bdy_ice_frs  *** 
    … …  
    93127      !!             dimensional baroclinic ocean model with realistic topography. Tellus, 365-382. 
    94128      !!------------------------------------------------------------------------------ 
    95       TYPE(OBC_INDEX), INTENT(in) ::   idx     ! OBC indices 
    96       TYPE(OBC_DATA),  INTENT(in) ::   dta     ! OBC external data 
    97       INTEGER,         INTENT(in) ::   kt      ! main time-step counter 
    98       INTEGER,         INTENT(in) ::   jbdy    ! BDY set index 
     129      TYPE(OBC_INDEX), INTENT(in) ::   idx      ! OBC indices 
     130      TYPE(OBC_DATA),  INTENT(in) ::   dta      ! OBC external data 
     131      INTEGER,         INTENT(in) ::   kt       ! main time-step counter 
     132      INTEGER,         INTENT(in) ::   jbdy     ! BDY set index 
     133      LOGICAL,         INTENT(in) ::   llrim0   ! indicate if rim 0 is treated 
    99134      ! 
    100135      INTEGER  ::   jpbound            ! 0 = incoming ice 
    101136      !                                ! 1 = outgoing ice 
     137      INTEGER  ::   ibeg, iend         ! length of rim to be treated (rim 0 or rim 1) 
    102138      INTEGER  ::   i_bdy, jgrd        ! dummy loop indices 
    103139      INTEGER  ::   ji, jj, jk, jl, ib, jb 
    104140      REAL(wp) ::   zwgt, zwgt1        ! local scalar 
    105141      REAL(wp) ::   ztmelts, zdh 
     142      REAL(wp), POINTER  :: flagu, flagv              ! short cuts 
    106143      !!------------------------------------------------------------------------------ 
    107144      ! 
    108145      jgrd = 1      ! Everything is at T-points here 
     146      IF( llrim0 ) THEN   ;   ibeg = 1                       ;   iend = idx%nblenrim0(jgrd) 
     147      ELSE                ;   ibeg = idx%nblenrim0(jgrd)+1   ;   iend = idx%nblenrim(jgrd) 
     148      END IF 
    109149      ! 
    110150      DO jl = 1, jpl 
    111          DO i_bdy = 1, idx%nblenrim(jgrd) 
     151         DO i_bdy = ibeg, iend 
    112152            ji    = idx%nbi(i_bdy,jgrd) 
    113153            jj    = idx%nbj(i_bdy,jgrd) 
    114154            zwgt  = idx%nbw(i_bdy,jgrd) 
    115155            zwgt1 = 1.e0 - idx%nbw(i_bdy,jgrd) 
    116             a_i(ji,jj,jl) = ( a_i(ji,jj,jl) * zwgt1 + dta%a_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1)  ! Leads fraction  
    117             h_i(ji,jj,jl) = ( h_i(ji,jj,jl) * zwgt1 + dta%h_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1)  ! Ice depth  
    118             h_s(ji,jj,jl) = ( h_s(ji,jj,jl) * zwgt1 + dta%h_s(i_bdy,jl) * zwgt ) * tmask(ji,jj,1)  ! Snow depth 
    119  
     156            a_i (ji,jj,  jl) = ( a_i (ji,jj,  jl) * zwgt1 + dta%a_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1)  ! Ice  concentration  
     157            h_i (ji,jj,  jl) = ( h_i (ji,jj,  jl) * zwgt1 + dta%h_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1)  ! Ice  depth  
     158            h_s (ji,jj,  jl) = ( h_s (ji,jj,  jl) * zwgt1 + dta%h_s(i_bdy,jl) * zwgt ) * tmask(ji,jj,1)  ! Snow depth 
     159            t_i (ji,jj,:,jl) = ( t_i (ji,jj,:,jl) * zwgt1 + dta%t_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1)  ! Ice  temperature 
     160            t_s (ji,jj,:,jl) = ( t_s (ji,jj,:,jl) * zwgt1 + dta%t_s(i_bdy,jl) * zwgt ) * tmask(ji,jj,1)  ! Snow temperature 
     161            t_su(ji,jj,  jl) = ( t_su(ji,jj,  jl) * zwgt1 + dta%tsu(i_bdy,jl) * zwgt ) * tmask(ji,jj,1)  ! Surf temperature 
     162            s_i (ji,jj,  jl) = ( s_i (ji,jj,  jl) * zwgt1 + dta%s_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1)  ! Ice  salinity 
     163            a_ip(ji,jj,  jl) = ( a_ip(ji,jj,  jl) * zwgt1 + dta%aip(i_bdy,jl) * zwgt ) * tmask(ji,jj,1)  ! Ice  pond concentration 
     164            h_ip(ji,jj,  jl) = ( h_ip(ji,jj,  jl) * zwgt1 + dta%hip(i_bdy,jl) * zwgt ) * tmask(ji,jj,1)  ! Ice  pond depth 
     165            ! 
     166            sz_i(ji,jj,:,jl) = s_i(ji,jj,jl) 
     167            ! 
     168            ! make sure ponds = 0 if no ponds scheme 
     169            IF( .NOT.ln_pnd ) THEN 
     170               a_ip(ji,jj,jl) = 0._wp 
     171               h_ip(ji,jj,jl) = 0._wp 
     172            ENDIF 
     173            ! 
    120174            ! ----------------- 
    121175            ! Pathological case 
    … …  
    132186            h_i(ji,jj,jl) = MIN( hi_max(jl), h_i(ji,jj,jl) + zdh ) 
    133187            h_s(ji,jj,jl) = MAX( 0._wp, h_s(ji,jj,jl) - zdh * rhoi / rhos )  
    134  
     188            ! 
    135189         ENDDO 
    136190      ENDDO 
    137       CALL lbc_bdy_lnk( 'bdyice', a_i(:,:,:), 'T', 1., jbdy ) 
    138       CALL lbc_bdy_lnk( 'bdyice', h_i(:,:,:), 'T', 1., jbdy ) 
    139       CALL lbc_bdy_lnk( 'bdyice', h_s(:,:,:), 'T', 1., jbdy ) 
    140191 
    141192      DO jl = 1, jpl 
    142          DO i_bdy = 1, idx%nblenrim(jgrd) 
     193         DO i_bdy = ibeg, iend 
    143194            ji = idx%nbi(i_bdy,jgrd) 
    144195            jj = idx%nbj(i_bdy,jgrd) 
    145  
     196            flagu => idx%flagu(i_bdy,jgrd) 
     197            flagv => idx%flagv(i_bdy,jgrd) 
    146198            ! condition on ice thickness depends on the ice velocity 
    147199            ! if velocity is outward (strictly), then ice thickness, volume... must be equal to adjacent values 
    148200            jpbound = 0   ;   ib = ji   ;   jb = jj 
    149201            ! 
    150             IF( u_ice(ji+1,jj  ) < 0. .AND. umask(ji-1,jj  ,1) == 0. )   jpbound = 1 ; ib = ji+1 ; jb = jj 
    151             IF( u_ice(ji-1,jj  ) > 0. .AND. umask(ji+1,jj  ,1) == 0. )   jpbound = 1 ; ib = ji-1 ; jb = jj 
    152             IF( v_ice(ji  ,jj+1) < 0. .AND. vmask(ji  ,jj-1,1) == 0. )   jpbound = 1 ; ib = ji   ; jb = jj+1 
    153             IF( v_ice(ji  ,jj-1) > 0. .AND. vmask(ji  ,jj+1,1) == 0. )   jpbound = 1 ; ib = ji   ; jb = jj-1 
     202            IF( flagu ==  1. )   THEN 
     203               IF( ji+1 > jpi )   CYCLE 
     204               IF( u_ice(ji  ,jj  ) < 0. )   jpbound = 1 ; ib = ji+1 
     205            END IF 
     206            IF( flagu == -1. )   THEN 
     207               IF( ji-1 < 1   )   CYCLE 
     208               IF( u_ice(ji-1,jj  ) < 0. )   jpbound = 1 ; ib = ji-1 
     209            END IF 
     210            IF( flagv ==  1. )   THEN 
     211               IF( jj+1 > jpj )   CYCLE 
     212               IF( v_ice(ji  ,jj  ) < 0. )   jpbound = 1 ; jb = jj+1 
     213            END IF 
     214            IF( flagv == -1. )   THEN 
     215               IF( jj-1 < 1   )   CYCLE 
     216               IF( v_ice(ji  ,jj-1) < 0. )   jpbound = 1 ; jb = jj-1 
     217            END IF 
    154218            ! 
    155219            IF( nn_ice_dta(jbdy) == 0 )   jpbound = 0 ; ib = ji ; jb = jj   ! case ice boundaries = initial conditions 
    … …  
    158222            IF( a_i(ib,jb,jl) > 0._wp ) THEN   ! there is ice at the boundary 
    159223               ! 
    160                a_i(ji,jj,jl) = a_i(ib,jb,jl) ! concentration 
    161                h_i(ji,jj,jl) = h_i(ib,jb,jl) ! thickness ice 
    162                h_s(ji,jj,jl) = h_s(ib,jb,jl) ! thickness snw 
    163                ! 
    164                SELECT CASE( jpbound ) 
    165                   ! 
    166                CASE( 0 )   ! velocity is inward 
    167                   ! 
    168                   oa_i(ji,jj,  jl) = rn_ice_age(jbdy) * a_i(ji,jj,jl) ! age 
    169                   a_ip(ji,jj,  jl) = 0._wp                            ! pond concentration 
    170                   v_ip(ji,jj,  jl) = 0._wp                            ! pond volume 
    171                   t_su(ji,jj,  jl) = rn_ice_tem(jbdy)                 ! temperature surface 
    172                   t_s (ji,jj,:,jl) = rn_ice_tem(jbdy)                 ! temperature snw 
    173                   t_i (ji,jj,:,jl) = rn_ice_tem(jbdy)                 ! temperature ice 
    174                   s_i (ji,jj,  jl) = rn_ice_sal(jbdy)                 ! salinity 
    175                   sz_i(ji,jj,:,jl) = rn_ice_sal(jbdy)                 ! salinity profile 
    176                   ! 
    177                CASE( 1 )   ! velocity is outward 
    178                   ! 
    179                   oa_i(ji,jj,  jl) = oa_i(ib,jb,  jl) ! age 
    180                   a_ip(ji,jj,  jl) = a_ip(ib,jb,  jl) ! pond concentration 
    181                   v_ip(ji,jj,  jl) = v_ip(ib,jb,  jl) ! pond volume 
    182                   t_su(ji,jj,  jl) = t_su(ib,jb,  jl) ! temperature surface 
    183                   t_s (ji,jj,:,jl) = t_s (ib,jb,:,jl) ! temperature snw 
    184                   t_i (ji,jj,:,jl) = t_i (ib,jb,:,jl) ! temperature ice 
    185                   s_i (ji,jj,  jl) = s_i (ib,jb,  jl) ! salinity 
    186                   sz_i(ji,jj,:,jl) = sz_i(ib,jb,:,jl) ! salinity profile 
    187                   ! 
    188                END SELECT 
     224               a_i (ji,jj,  jl) = a_i (ib,jb,  jl) 
     225               h_i (ji,jj,  jl) = h_i (ib,jb,  jl) 
     226               h_s (ji,jj,  jl) = h_s (ib,jb,  jl) 
     227               t_i (ji,jj,:,jl) = t_i (ib,jb,:,jl) 
     228               t_s (ji,jj,:,jl) = t_s (ib,jb,:,jl) 
     229               t_su(ji,jj,  jl) = t_su(ib,jb,  jl) 
     230               s_i (ji,jj,  jl) = s_i (ib,jb,  jl) 
     231               a_ip(ji,jj,  jl) = a_ip(ib,jb,  jl) 
     232               h_ip(ji,jj,  jl) = h_ip(ib,jb,  jl) 
     233               ! 
     234               sz_i(ji,jj,:,jl) = sz_i(ib,jb,:,jl) 
     235               ! 
     236               ! ice age 
     237               IF    ( jpbound == 0 ) THEN  ! velocity is inward 
     238                  oa_i(ji,jj,jl) = rice_age(jbdy) * a_i(ji,jj,jl) 
     239               ELSEIF( jpbound == 1 ) THEN  ! velocity is outward 
     240                  oa_i(ji,jj,jl) = oa_i(ib,jb,jl) 
     241               ENDIF 
    189242               ! 
    190243               IF( nn_icesal == 1 ) THEN     ! if constant salinity 
    … …  
    211264               END DO 
    212265               ! 
     266               ! melt ponds 
     267               IF( a_i(ji,jj,jl) > epsi10 ) THEN 
     268                  a_ip_frac(ji,jj,jl) = a_ip(ji,jj,jl) / a_i (ji,jj,jl) 
     269               ELSE 
     270                  a_ip_frac(ji,jj,jl) = 0._wp 
     271               ENDIF 
     272               v_ip(ji,jj,jl) = h_ip(ji,jj,jl) * a_ip(ji,jj,jl) 
     273               ! 
    213274            ELSE   ! no ice at the boundary 
    214275               ! 
    … …  
    222283               t_s (ji,jj,:,jl) = rt0 
    223284               t_i (ji,jj,:,jl) = rt0  
     285 
     286               a_ip_frac(ji,jj,jl) = 0._wp 
     287               h_ip     (ji,jj,jl) = 0._wp 
     288               a_ip     (ji,jj,jl) = 0._wp 
     289               v_ip     (ji,jj,jl) = 0._wp 
    224290                
    225291               IF( nn_icesal == 1 ) THEN     ! if constant salinity 
    … …  
    243309         ! 
    244310      END DO ! jl 
    245  
    246       CALL lbc_bdy_lnk( 'bdyice', a_i (:,:,:)  , 'T', 1., jbdy ) 
    247       CALL lbc_bdy_lnk( 'bdyice', h_i (:,:,:)  , 'T', 1., jbdy ) 
    248       CALL lbc_bdy_lnk( 'bdyice', h_s (:,:,:)  , 'T', 1., jbdy ) 
    249       CALL lbc_bdy_lnk( 'bdyice', oa_i(:,:,:)  , 'T', 1., jbdy ) 
    250       CALL lbc_bdy_lnk( 'bdyice', a_ip(:,:,:)  , 'T', 1., jbdy ) 
    251       CALL lbc_bdy_lnk( 'bdyice', v_ip(:,:,:)  , 'T', 1., jbdy ) 
    252       CALL lbc_bdy_lnk( 'bdyice', s_i (:,:,:)  , 'T', 1., jbdy ) 
    253       CALL lbc_bdy_lnk( 'bdyice', t_su(:,:,:)  , 'T', 1., jbdy ) 
    254       CALL lbc_bdy_lnk( 'bdyice', v_i (:,:,:)  , 'T', 1., jbdy ) 
    255       CALL lbc_bdy_lnk( 'bdyice', v_s (:,:,:)  , 'T', 1., jbdy ) 
    256       CALL lbc_bdy_lnk( 'bdyice', sv_i(:,:,:)  , 'T', 1., jbdy ) 
    257       CALL lbc_bdy_lnk( 'bdyice', t_s (:,:,:,:), 'T', 1., jbdy ) 
    258       CALL lbc_bdy_lnk( 'bdyice', e_s (:,:,:,:), 'T', 1., jbdy ) 
    259       CALL lbc_bdy_lnk( 'bdyice', t_i (:,:,:,:), 'T', 1., jbdy ) 
    260       CALL lbc_bdy_lnk( 'bdyice', e_i (:,:,:,:), 'T', 1., jbdy ) 
    261311      !       
    262312   END SUBROUTINE bdy_ice_frs 
    … …  
    276326      CHARACTER(len=1), INTENT(in)  ::   cd_type   ! nature of velocity grid-points 
    277327      ! 
    278       INTEGER  ::   i_bdy, jgrd      ! dummy loop indices 
    279       INTEGER  ::   ji, jj           ! local scalar 
    280       INTEGER  ::   jbdy             ! BDY set index 
     328      INTEGER  ::   i_bdy, jgrd       ! dummy loop indices 
     329      INTEGER  ::   ji, jj            ! local scalar 
     330      INTEGER  ::   jbdy, ir     ! BDY set index, rim index 
     331      INTEGER  ::   ibeg, iend   ! length of rim to be treated (rim 0 or rim 1) 
    281332      REAL(wp) ::   zmsk1, zmsk2, zflag 
     333      LOGICAL, DIMENSION(4) :: llsend2, llrecv2, llsend3, llrecv3  ! indicate how communications are to be carried out 
    282334      !!------------------------------------------------------------------------------ 
    283335      IF( ln_timing )   CALL timing_start('bdy_ice_dyn') 
    284336      ! 
    285       DO jbdy=1, nb_bdy 
     337      llsend2(:) = .false.   ;   llrecv2(:) = .false. 
     338      llsend3(:) = .false.   ;   llrecv3(:) = .false. 
     339      DO ir = 1, 0, -1 
     340         DO jbdy = 1, nb_bdy 
     341            ! 
     342            SELECT CASE( cn_ice(jbdy) ) 
     343               ! 
     344            CASE('none') 
     345               CYCLE 
     346               ! 
     347            CASE('frs') 
     348               ! 
     349               IF( nn_ice_dta(jbdy) == 0 ) CYCLE            ! case ice boundaries = initial conditions  
     350               !                                            !      do not change ice velocity (it is only computed by rheology) 
     351               SELECT CASE ( cd_type ) 
     352                  !      
     353               CASE ( 'U' )   
     354                  jgrd = 2      ! u velocity 
     355                  IF( ir == 0 ) THEN   ;   ibeg = 1                                 ;   iend = idx_bdy(jbdy)%nblenrim0(jgrd) 
     356                  ELSE                 ;   ibeg = idx_bdy(jbdy)%nblenrim0(jgrd)+1   ;   iend = idx_bdy(jbdy)%nblenrim(jgrd) 
     357                  END IF 
     358                  DO i_bdy = ibeg, iend 
     359                     ji    = idx_bdy(jbdy)%nbi(i_bdy,jgrd) 
     360                     jj    = idx_bdy(jbdy)%nbj(i_bdy,jgrd) 
     361                     zflag = idx_bdy(jbdy)%flagu(i_bdy,jgrd) 
     362                     !     i-1  i   i    |  !        i  i i+1 |  !          i  i i+1 | 
     363                     !      >  ice  >    |  !        o  > ice |  !          o  >  o  |       
     364                     ! => set at u_ice(i-1) !  => set to O       !  => unchanged 
     365                     IF( zflag == -1. .AND. ji > 1 .AND. ji < jpi )   THEN   
     366                        IF    ( vt_i(ji  ,jj) > 0. )   THEN   ;   u_ice(ji,jj) = u_ice(ji-1,jj)  
     367                        ELSEIF( vt_i(ji+1,jj) > 0. )   THEN   ;   u_ice(ji,jj) = 0._wp 
     368                        END IF 
     369                     END IF 
     370                     ! |    i  i+1 i+1        !  |  i   i i+1        !  | i  i i+1 
     371                     ! |    >  ice  >         !  | ice  >  o         !  | o  >  o    
     372                     ! => set at u_ice(i+1)   !     => set to O      !     =>  unchanged 
     373                     IF( zflag ==  1. .AND. ji+1 < jpi+1 )   THEN 
     374                        IF    ( vt_i(ji+1,jj) > 0. )   THEN   ;   u_ice(ji,jj) = u_ice(ji+1,jj) 
     375                        ELSEIF( vt_i(ji  ,jj) > 0. )   THEN   ;   u_ice(ji,jj) = 0._wp 
     376                        END IF 
     377                     END IF 
     378                     ! 
     379                     IF( zflag ==  0. )   u_ice(ji,jj) = 0._wp   ! u_ice = 0  if north/south bdy   
     380                     ! 
     381                  END DO 
     382                  ! 
     383               CASE ( 'V' ) 
     384                  jgrd = 3      ! v velocity 
     385                  IF( ir == 0 ) THEN   ;   ibeg = 1                                 ;   iend = idx_bdy(jbdy)%nblenrim0(jgrd) 
     386                  ELSE                 ;   ibeg = idx_bdy(jbdy)%nblenrim0(jgrd)+1   ;   iend = idx_bdy(jbdy)%nblenrim(jgrd) 
     387                  END IF 
     388                  DO i_bdy = ibeg, iend 
     389                     ji    = idx_bdy(jbdy)%nbi(i_bdy,jgrd) 
     390                     jj    = idx_bdy(jbdy)%nbj(i_bdy,jgrd) 
     391                     zflag = idx_bdy(jbdy)%flagv(i_bdy,jgrd) 
     392                     !                         !      ice   (jj+1)       !       o    (jj+1) 
     393                     !       ^    (jj  )       !       ^    (jj  )       !       ^    (jj  )        
     394                     !      ice   (jj  )       !       o    (jj  )       !       o    (jj  )        
     395                     !       ^    (jj-1)       !                         ! 
     396                     ! => set to u_ice(jj-1)   !  =>   set to 0          !   => unchanged         
     397                     IF( zflag == -1. .AND. jj > 1 .AND. jj < jpj )   THEN                  
     398                        IF    ( vt_i(ji,jj  ) > 0. )   THEN   ;   v_ice(ji,jj) = v_ice(ji,jj-1) 
     399                        ELSEIF( vt_i(ji,jj+1) > 0. )   THEN   ;   v_ice(ji,jj) = 0._wp 
     400                        END IF 
     401                     END IF 
     402                     !       ^    (jj+1)       !                         !               
     403                     !      ice   (jj+1)       !       o    (jj+1)       !       o    (jj+1)        
     404                     !       ^    (jj  )       !       ^    (jj  )       !       ^    (jj  ) 
     405                     !   ________________      !  ____ice___(jj  )_      !  _____o____(jj  )  
     406                     ! => set to u_ice(jj+1)   !    => set to 0          !    => unchanged   
     407                     IF( zflag ==  1. .AND. jj < jpj )   THEN               
     408                        IF    ( vt_i(ji,jj+1) > 0. )   THEN   ;   v_ice(ji,jj) = v_ice(ji,jj+1) 
     409                        ELSEIF( vt_i(ji,jj  ) > 0. )   THEN   ;   v_ice(ji,jj) = 0._wp 
     410                        END IF 
     411                     END IF 
     412                     ! 
     413                     IF( zflag ==  0. )   v_ice(ji,jj) = 0._wp   ! v_ice = 0  if west/east bdy   
     414                     ! 
     415                  END DO 
     416                  ! 
     417               END SELECT 
     418               ! 
     419            CASE DEFAULT 
     420               CALL ctl_stop( 'bdy_ice_dyn : unrecognised option for open boundaries for ice fields' ) 
     421            END SELECT 
     422            ! 
     423         END DO    ! jbdy 
    286424         ! 
    287          SELECT CASE( cn_ice(jbdy) ) 
    288          ! 
    289          CASE('none') 
    290             CYCLE 
    291             ! 
    292          CASE('frs') 
    293             ! 
    294             IF( nn_ice_dta(jbdy) == 0 ) CYCLE            ! case ice boundaries = initial conditions  
    295             !                                            !      do not change ice velocity (it is only computed by rheology) 
    296             SELECT CASE ( cd_type ) 
    297             !      
    298             CASE ( 'U' )   
    299                jgrd = 2      ! u velocity 
    300                DO i_bdy = 1, idx_bdy(jbdy)%nblenrim(jgrd) 
    301                   ji    = idx_bdy(jbdy)%nbi(i_bdy,jgrd) 
    302                   jj    = idx_bdy(jbdy)%nbj(i_bdy,jgrd) 
    303                   zflag = idx_bdy(jbdy)%flagu(i_bdy,jgrd) 
    304                   ! 
    305                   IF ( ABS( zflag ) == 1. ) THEN  ! eastern and western boundaries 
    306                      ! one of the two zmsk is always 0 (because of zflag) 
    307                      zmsk1 = 1._wp - MAX( 0.0_wp, SIGN ( 1.0_wp , - vt_i(ji+1,jj) ) ) ! 0 if no ice 
    308                      zmsk2 = 1._wp - MAX( 0.0_wp, SIGN ( 1.0_wp , - vt_i(ji-1,jj) ) ) ! 0 if no ice 
    309                      !   
    310                      ! u_ice = u_ice of the adjacent grid point except if this grid point is ice-free (then do not change u_ice) 
    311                      u_ice (ji,jj) = u_ice(ji+1,jj) * 0.5_wp * ABS( zflag + 1._wp ) * zmsk1 + & 
    312                         &            u_ice(ji-1,jj) * 0.5_wp * ABS( zflag - 1._wp ) * zmsk2 + & 
    313                         &            u_ice(ji  ,jj) * ( 1._wp - MIN( 1._wp, zmsk1 + zmsk2 ) ) 
    314                   ELSE                             ! everywhere else 
    315                      u_ice(ji,jj) = 0._wp 
    316                   ENDIF 
    317                   ! 
    318                END DO 
    319                CALL lbc_bdy_lnk( 'bdyice', u_ice(:,:), 'U', -1., jbdy ) 
    320                ! 
    321             CASE ( 'V' ) 
    322                jgrd = 3      ! v velocity 
    323                DO i_bdy = 1, idx_bdy(jbdy)%nblenrim(jgrd) 
    324                   ji    = idx_bdy(jbdy)%nbi(i_bdy,jgrd) 
    325                   jj    = idx_bdy(jbdy)%nbj(i_bdy,jgrd) 
    326                   zflag = idx_bdy(jbdy)%flagv(i_bdy,jgrd) 
    327                   ! 
    328                   IF ( ABS( zflag ) == 1. ) THEN  ! northern and southern boundaries 
    329                      ! one of the two zmsk is always 0 (because of zflag) 
    330                      zmsk1 = 1._wp - MAX( 0.0_wp, SIGN ( 1.0_wp , - vt_i(ji,jj+1) ) ) ! 0 if no ice 
    331                      zmsk2 = 1._wp - MAX( 0.0_wp, SIGN ( 1.0_wp , - vt_i(ji,jj-1) ) ) ! 0 if no ice 
    332                      !   
    333                      ! v_ice = v_ice of the adjacent grid point except if this grid point is ice-free (then do not change v_ice) 
    334                      v_ice (ji,jj) = v_ice(ji,jj+1) * 0.5_wp * ABS( zflag + 1._wp ) * zmsk1 + & 
    335                         &            v_ice(ji,jj-1) * 0.5_wp * ABS( zflag - 1._wp ) * zmsk2 + & 
    336                         &            v_ice(ji,jj  ) * ( 1._wp - MIN( 1._wp, zmsk1 + zmsk2 ) ) 
    337                   ELSE                             ! everywhere else 
    338                      v_ice(ji,jj) = 0._wp 
    339                   ENDIF 
    340                   ! 
    341                END DO 
    342                CALL lbc_bdy_lnk( 'bdyice', v_ice(:,:), 'V', -1., jbdy ) 
    343                ! 
    344             END SELECT 
    345             ! 
    346          CASE DEFAULT 
    347             CALL ctl_stop( 'bdy_ice_dyn : unrecognised option for open boundaries for ice fields' ) 
     425         SELECT CASE ( cd_type )         
     426         CASE ( 'U' )  
     427         IF( nn_hls > 1 .AND. ir == 1 ) CYCLE   ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 
     428         IF( nn_hls == 1 ) THEN   ;   llsend2(:) = .false.   ;   llrecv2(:) = .false.   ;   END IF 
     429            DO jbdy = 1, nb_bdy 
     430               IF( cn_ice(jbdy) == 'frs' .AND. nn_ice_dta(jbdy) /= 0 ) THEN 
     431                  llsend2(:) = llsend2(:) .OR. lsend_bdyint(jbdy,2,:,ir)   ! possibly every direction, U points 
     432                  llsend2(1) = llsend2(1) .OR. lsend_bdyext(jbdy,2,1,ir)   ! neighbour might search point towards its west bdy 
     433                  llrecv2(:) = llrecv2(:) .OR. lrecv_bdyint(jbdy,2,:,ir)   ! possibly every direction, U points 
     434                  llrecv2(2) = llrecv2(2) .OR. lrecv_bdyext(jbdy,2,2,ir)   ! might search point towards east bdy 
     435               END IF 
     436            END DO 
     437            IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN   ! if need to send/recv in at least one direction 
     438               CALL lbc_lnk( 'bdyice', u_ice, 'U', -1., kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) 
     439            END IF 
     440         CASE ( 'V' ) 
     441         IF( nn_hls > 1 .AND. ir == 1 ) CYCLE   ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 
     442         IF( nn_hls == 1 ) THEN   ;   llsend3(:) = .false.   ;   llrecv3(:) = .false.   ;   END IF 
     443            DO jbdy = 1, nb_bdy 
     444               IF( cn_ice(jbdy) == 'frs' .AND. nn_ice_dta(jbdy) /= 0 ) THEN 
     445                  llsend3(:) = llsend3(:) .OR. lsend_bdyint(jbdy,3,:,ir)   ! possibly every direction, V points 
     446                  llsend3(3) = llsend3(3) .OR. lsend_bdyext(jbdy,3,3,ir)   ! neighbour might search point towards its south bdy 
     447                  llrecv3(:) = llrecv3(:) .OR. lrecv_bdyint(jbdy,3,:,ir)   ! possibly every direction, V points 
     448                  llrecv3(4) = llrecv3(4) .OR. lrecv_bdyext(jbdy,3,4,ir)   ! might search point towards north bdy 
     449               END IF 
     450            END DO 
     451            IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN   ! if need to send/recv in at least one direction 
     452               CALL lbc_lnk( 'bdyice', v_ice, 'V', -1., kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) 
     453            END IF 
    348454         END SELECT 
    349          ! 
    350       END DO 
     455      END DO   ! ir 
    351456      ! 
    352457      IF( ln_timing )   CALL timing_stop('bdy_ice_dyn') 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/BDY/bdyini.F90

    r10629 r11822  
    3333   PRIVATE 
    3434 
    35    PUBLIC   bdy_init   ! routine called in nemo_init 
     35   PUBLIC   bdy_init    ! routine called in nemo_init 
     36   PUBLIC   find_neib   ! routine called in bdy_nmn 
    3637 
    3738   INTEGER, PARAMETER ::   jp_nseg = 100   !  
    38    INTEGER, PARAMETER ::   nrimmax =  20   ! maximum rimwidth in structured 
    39                                                ! open boundary data files 
    4039   ! Straight open boundary segment parameters: 
    4140   INTEGER  ::   nbdysege, nbdysegw, nbdysegn, nbdysegs  
    … …  
    6867         &             ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & 
    6968         &             cn_ice, nn_ice_dta,                                     & 
    70          &             rn_ice_tem, rn_ice_sal, rn_ice_age,                     & 
    71          &             ln_vol, nn_volctl, nn_rimwidth, nb_jpk_bdy 
     69         &             ln_vol, nn_volctl, nn_rimwidth 
    7270         ! 
    7371      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    … …  
    7977      REWIND( numnam_ref )              ! Namelist nambdy in reference namelist :Unstructured open boundaries 
    8078      READ  ( numnam_ref, nambdy, IOSTAT = ios, ERR = 901) 
    81 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambdy in reference namelist', lwp ) 
     79901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambdy in reference namelist' ) 
     80      ! make sur that all elements of the namelist variables have a default definition from namelist_ref 
     81      ln_coords_file (2:jp_bdy) = ln_coords_file (1) 
     82      cn_coords_file (2:jp_bdy) = cn_coords_file (1) 
     83      cn_dyn2d       (2:jp_bdy) = cn_dyn2d       (1) 
     84      nn_dyn2d_dta   (2:jp_bdy) = nn_dyn2d_dta   (1) 
     85      cn_dyn3d       (2:jp_bdy) = cn_dyn3d       (1) 
     86      nn_dyn3d_dta   (2:jp_bdy) = nn_dyn3d_dta   (1) 
     87      cn_tra         (2:jp_bdy) = cn_tra         (1) 
     88      nn_tra_dta     (2:jp_bdy) = nn_tra_dta     (1)     
     89      ln_tra_dmp     (2:jp_bdy) = ln_tra_dmp     (1) 
     90      ln_dyn3d_dmp   (2:jp_bdy) = ln_dyn3d_dmp   (1) 
     91      rn_time_dmp    (2:jp_bdy) = rn_time_dmp    (1) 
     92      rn_time_dmp_out(2:jp_bdy) = rn_time_dmp_out(1) 
     93      cn_ice         (2:jp_bdy) = cn_ice         (1) 
     94      nn_ice_dta     (2:jp_bdy) = nn_ice_dta     (1) 
    8295      REWIND( numnam_cfg )              ! Namelist nambdy in configuration namelist :Unstructured open boundaries 
    8396      READ  ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 902 ) 
    84 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambdy in configuration namelist', lwp ) 
     97902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambdy in configuration namelist' ) 
    8598      IF(lwm) WRITE ( numond, nambdy ) 
    8699 
    87100      IF( .NOT. Agrif_Root() ) ln_bdy = .FALSE.   ! forced for Agrif children 
     101 
     102      IF( nb_bdy == 0 ) ln_bdy = .FALSE. 
    88103       
    89104      ! ----------------------------------------- 
    … …  
    96111         ! 
    97112         ! Open boundaries definition (arrays and masks) 
    98          CALL bdy_segs 
     113         CALL bdy_def 
     114         IF( ln_meshmask )   CALL bdy_meshwri() 
    99115         ! 
    100116         ! Open boundaries initialisation of external data arrays 
    … …  
    114130 
    115131 
    116    SUBROUTINE bdy_segs 
     132   SUBROUTINE bdy_def 
    117133      !!---------------------------------------------------------------------- 
    118134      !!                 ***  ROUTINE bdy_init  *** 
    … …  
    125141      !! ** Input   :  bdy_init.nc, input file for unstructured open boundaries 
    126142      !!----------------------------------------------------------------------       
    127       INTEGER  ::   ib_bdy, ii, ij, ik, igrd, ib, ir, iseg ! dummy loop indices 
    128       INTEGER  ::   icount, icountr, ibr_max, ilen1, ibm1  ! local integers 
     143      INTEGER  ::   ib_bdy, ii, ij, igrd, ib, ir, iseg     ! dummy loop indices 
     144      INTEGER  ::   icount, icountr, icountr0, ibr_max     ! local integers 
     145      INTEGER  ::   ilen1                                  !   -       - 
    129146      INTEGER  ::   iwe, ies, iso, ino, inum, id_dummy     !   -       - 
    130       INTEGER  ::   igrd_start, igrd_end, jpbdta           !   -       - 
    131       INTEGER  ::   jpbdtau, jpbdtas                       !   -       - 
     147      INTEGER  ::   jpbdta                                 !   -       - 
    132148      INTEGER  ::   ib_bdy1, ib_bdy2, ib1, ib2             !   -       - 
    133       INTEGER  ::   i_offset, j_offset                     !   -       - 
    134       INTEGER , POINTER  ::  nbi, nbj, nbr                 ! short cuts 
    135       REAL(wp), POINTER, DIMENSION(:,:)       ::   pmask    ! pointer to 2D mask fields 
    136       REAL(wp) ::   zefl, zwfl, znfl, zsfl                 ! local scalars 
    137       INTEGER, DIMENSION (2)                  ::   kdimsz 
    138       INTEGER, DIMENSION(jpbgrd,jp_bdy)       ::   nblendta         ! Length of index arrays  
    139       INTEGER, ALLOCATABLE, DIMENSION(:,:,:)  ::   nbidta, nbjdta   ! Index arrays: i and j indices of bdy dta 
    140       INTEGER, ALLOCATABLE, DIMENSION(:,:,:)  ::   nbrdta           ! Discrete distance from rim points 
    141       CHARACTER(LEN=1),DIMENSION(jpbgrd)      ::   cgrid 
    142       INTEGER :: com_east, com_west, com_south, com_north          ! Flags for boundaries sending 
    143       INTEGER :: com_east_b, com_west_b, com_south_b, com_north_b  ! Flags for boundaries receiving 
    144       INTEGER :: iw_b(4), ie_b(4), is_b(4), in_b(4)                ! Arrays for neighbours coordinates 
    145       REAL(wp), TARGET, DIMENSION(jpi,jpj) ::   zfmask  ! temporary fmask array excluding coastal boundary condition (shlat) 
    146       !! 
    147       CHARACTER(LEN=1)                     ::   ctypebdy   !     -        -  
    148       INTEGER                              ::   nbdyind, nbdybeg, nbdyend 
    149       !! 
    150       NAMELIST/nambdy_index/ ctypebdy, nbdyind, nbdybeg, nbdyend 
    151       INTEGER  ::   ios                 ! Local integer output status for namelist read 
     149      INTEGER  ::   ii1, ii2, ii3, ij1, ij2, ij3           !   -       - 
     150      INTEGER  ::   iibe, ijbe, iibi, ijbi                 !   -       - 
     151      INTEGER  ::   flagu, flagv                           ! short cuts 
     152      INTEGER  ::   nbdyind, nbdybeg, nbdyend 
     153      INTEGER              , DIMENSION(4)             ::   kdimsz 
     154      INTEGER              , DIMENSION(jpbgrd,jp_bdy) ::   nblendta          ! Length of index arrays  
     155      INTEGER,  ALLOCATABLE, DIMENSION(:,:,:)         ::   nbidta, nbjdta    ! Index arrays: i and j indices of bdy dta 
     156      INTEGER,  ALLOCATABLE, DIMENSION(:,:,:)         ::   nbrdta            ! Discrete distance from rim points 
     157      CHARACTER(LEN=1)     , DIMENSION(jpbgrd)        ::   cgrid 
     158      REAL(wp), ALLOCATABLE, DIMENSION(:,:)     ::   zz_read                 ! work space for 2D global boundary data 
     159      REAL(wp), POINTER    , DIMENSION(:,:)     ::   zmask                   ! pointer to 2D mask fields 
     160      REAL(wp)             , DIMENSION(jpi,jpj) ::   zfmask   ! temporary fmask array excluding coastal boundary condition (shlat) 
     161      REAL(wp)             , DIMENSION(jpi,jpj) ::   ztmask, zumask, zvmask  ! temporary u/v mask array 
    152162      !!---------------------------------------------------------------------- 
    153163      ! 
    … …  
    160170         &                               ' and general open boundary condition are not compatible' ) 
    161171 
    162       IF( nb_bdy == 0 ) THEN  
    163         IF(lwp) WRITE(numout,*) 'nb_bdy = 0, NO OPEN BOUNDARIES APPLIED.' 
    164       ELSE 
    165         IF(lwp) WRITE(numout,*) 'Number of open boundary sets : ', nb_bdy 
     172      IF(lwp) WRITE(numout,*) 'Number of open boundary sets : ', nb_bdy 
     173 
     174      DO ib_bdy = 1,nb_bdy 
     175 
     176         IF(lwp) THEN 
     177            WRITE(numout,*) ' '  
     178            WRITE(numout,*) '------ Open boundary data set ',ib_bdy,' ------'  
     179            IF( ln_coords_file(ib_bdy) ) THEN 
     180               WRITE(numout,*) 'Boundary definition read from file '//TRIM(cn_coords_file(ib_bdy)) 
     181            ELSE 
     182               WRITE(numout,*) 'Boundary defined in namelist.' 
     183            ENDIF 
     184            WRITE(numout,*) 
     185         ENDIF 
     186 
     187         ! barotropic bdy 
     188         !---------------- 
     189         IF(lwp) THEN 
     190            WRITE(numout,*) 'Boundary conditions for barotropic solution:  ' 
     191            SELECT CASE( cn_dyn2d(ib_bdy) )                   
     192            CASE( 'none' )           ;   WRITE(numout,*) '      no open boundary condition'         
     193            CASE( 'frs' )            ;   WRITE(numout,*) '      Flow Relaxation Scheme' 
     194            CASE( 'flather' )        ;   WRITE(numout,*) '      Flather radiation condition' 
     195            CASE( 'orlanski' )       ;   WRITE(numout,*) '      Orlanski (fully oblique) radiation condition with adaptive nudging' 
     196            CASE( 'orlanski_npo' )   ;   WRITE(numout,*) '      Orlanski (NPO) radiation condition with adaptive nudging' 
     197            CASE DEFAULT             ;   CALL ctl_stop( 'unrecognised value for cn_dyn2d' ) 
     198            END SELECT 
     199         ENDIF 
     200 
     201         dta_bdy(ib_bdy)%lneed_ssh   = cn_dyn2d(ib_bdy) == 'flather' 
     202         dta_bdy(ib_bdy)%lneed_dyn2d = cn_dyn2d(ib_bdy) /= 'none' 
     203 
     204         IF( lwp .AND. dta_bdy(ib_bdy)%lneed_dyn2d ) THEN 
     205            SELECT CASE( nn_dyn2d_dta(ib_bdy) )                   !  
     206            CASE( 0 )      ;   WRITE(numout,*) '      initial state used for bdy data'         
     207            CASE( 1 )      ;   WRITE(numout,*) '      boundary data taken from file' 
     208            CASE( 2 )      ;   WRITE(numout,*) '      tidal harmonic forcing taken from file' 
     209            CASE( 3 )      ;   WRITE(numout,*) '      boundary data AND tidal harmonic forcing taken from files' 
     210            CASE DEFAULT   ;   CALL ctl_stop( 'nn_dyn2d_dta must be between 0 and 3' ) 
     211            END SELECT 
     212         ENDIF 
     213         IF ( dta_bdy(ib_bdy)%lneed_dyn2d .AND. nn_dyn2d_dta(ib_bdy) .GE. 2  .AND. .NOT.ln_tide ) THEN 
     214            CALL ctl_stop( 'You must activate with ln_tide to add tidal forcing at open boundaries' ) 
     215         ENDIF 
     216         IF(lwp) WRITE(numout,*) 
     217 
     218         ! baroclinic bdy 
     219         !---------------- 
     220         IF(lwp) THEN 
     221            WRITE(numout,*) 'Boundary conditions for baroclinic velocities:  ' 
     222            SELECT CASE( cn_dyn3d(ib_bdy) )                   
     223            CASE('none')           ;   WRITE(numout,*) '      no open boundary condition'         
     224            CASE('frs')            ;   WRITE(numout,*) '      Flow Relaxation Scheme' 
     225            CASE('specified')      ;   WRITE(numout,*) '      Specified value' 
     226            CASE('neumann')        ;   WRITE(numout,*) '      Neumann conditions' 
     227            CASE('zerograd')       ;   WRITE(numout,*) '      Zero gradient for baroclinic velocities' 
     228            CASE('zero')           ;   WRITE(numout,*) '      Zero baroclinic velocities (runoff case)' 
     229            CASE('orlanski')       ;   WRITE(numout,*) '      Orlanski (fully oblique) radiation condition with adaptive nudging' 
     230            CASE('orlanski_npo')   ;   WRITE(numout,*) '      Orlanski (NPO) radiation condition with adaptive nudging' 
     231            CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for cn_dyn3d' ) 
     232            END SELECT 
     233         ENDIF 
     234 
     235         dta_bdy(ib_bdy)%lneed_dyn3d = cn_dyn3d(ib_bdy) == 'frs'      .OR. cn_dyn3d(ib_bdy) == 'specified'   & 
     236            &                     .OR. cn_dyn3d(ib_bdy) == 'orlanski' .OR. cn_dyn3d(ib_bdy) == 'orlanski_npo' 
     237 
     238         IF( lwp .AND. dta_bdy(ib_bdy)%lneed_dyn3d ) THEN 
     239            SELECT CASE( nn_dyn3d_dta(ib_bdy) )                   !  
     240            CASE( 0 )      ;   WRITE(numout,*) '      initial state used for bdy data'         
     241            CASE( 1 )      ;   WRITE(numout,*) '      boundary data taken from file' 
     242            CASE DEFAULT   ;   CALL ctl_stop( 'nn_dyn3d_dta must be 0 or 1' ) 
     243            END SELECT 
     244         END IF 
     245 
     246         IF ( ln_dyn3d_dmp(ib_bdy) ) THEN 
     247            IF ( cn_dyn3d(ib_bdy) == 'none' ) THEN 
     248               IF(lwp) WRITE(numout,*) 'No open boundary condition for baroclinic velocities: ln_dyn3d_dmp is set to .false.' 
     249               ln_dyn3d_dmp(ib_bdy) = .false. 
     250            ELSEIF ( cn_dyn3d(ib_bdy) == 'frs' ) THEN 
     251               CALL ctl_stop( 'Use FRS OR relaxation' ) 
     252            ELSE 
     253               IF(lwp) WRITE(numout,*) '      + baroclinic velocities relaxation zone' 
     254               IF(lwp) WRITE(numout,*) '      Damping time scale: ',rn_time_dmp(ib_bdy),' days' 
     255               IF(rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' ) 
     256               dta_bdy(ib_bdy)%lneed_dyn3d = .TRUE. 
     257            ENDIF 
     258         ELSE 
     259            IF(lwp) WRITE(numout,*) '      NO relaxation on baroclinic velocities' 
     260         ENDIF 
     261         IF(lwp) WRITE(numout,*) 
     262 
     263         !    tra bdy 
     264         !---------------- 
     265         IF(lwp) THEN 
     266            WRITE(numout,*) 'Boundary conditions for temperature and salinity:  ' 
     267            SELECT CASE( cn_tra(ib_bdy) )                   
     268            CASE('none')           ;   WRITE(numout,*) '      no open boundary condition'         
     269            CASE('frs')            ;   WRITE(numout,*) '      Flow Relaxation Scheme' 
     270            CASE('specified')      ;   WRITE(numout,*) '      Specified value' 
     271            CASE('neumann')        ;   WRITE(numout,*) '      Neumann conditions' 
     272            CASE('runoff')         ;   WRITE(numout,*) '      Runoff conditions : Neumann for T and specified to 0.1 for salinity' 
     273            CASE('orlanski')       ;   WRITE(numout,*) '      Orlanski (fully oblique) radiation condition with adaptive nudging' 
     274            CASE('orlanski_npo')   ;   WRITE(numout,*) '      Orlanski (NPO) radiation condition with adaptive nudging' 
     275            CASE DEFAULT           ;   CALL ctl_stop( 'unrecognised value for cn_tra' ) 
     276            END SELECT 
     277         ENDIF 
     278 
     279         dta_bdy(ib_bdy)%lneed_tra = cn_tra(ib_bdy) == 'frs'       .OR. cn_tra(ib_bdy) == 'specified'   & 
     280            &                   .OR. cn_tra(ib_bdy) == 'orlanski'  .OR. cn_tra(ib_bdy) == 'orlanski_npo'  
     281 
     282         IF( lwp .AND. dta_bdy(ib_bdy)%lneed_tra ) THEN 
     283            SELECT CASE( nn_tra_dta(ib_bdy) )                   !  
     284            CASE( 0 )      ;   WRITE(numout,*) '      initial state used for bdy data'         
     285            CASE( 1 )      ;   WRITE(numout,*) '      boundary data taken from file' 
     286            CASE DEFAULT   ;   CALL ctl_stop( 'nn_tra_dta must be 0 or 1' ) 
     287            END SELECT 
     288         ENDIF 
     289 
     290         IF ( ln_tra_dmp(ib_bdy) ) THEN 
     291            IF ( cn_tra(ib_bdy) == 'none' ) THEN 
     292               IF(lwp) WRITE(numout,*) 'No open boundary condition for tracers: ln_tra_dmp is set to .false.' 
     293               ln_tra_dmp(ib_bdy) = .false. 
     294            ELSEIF ( cn_tra(ib_bdy) == 'frs' ) THEN 
     295               CALL ctl_stop( 'Use FRS OR relaxation' ) 
     296            ELSE 
     297               IF(lwp) WRITE(numout,*) '      + T/S relaxation zone' 
     298               IF(lwp) WRITE(numout,*) '      Damping time scale: ',rn_time_dmp(ib_bdy),' days' 
     299               IF(lwp) WRITE(numout,*) '      Outflow damping time scale: ',rn_time_dmp_out(ib_bdy),' days' 
     300               IF(lwp.AND.rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' ) 
     301               dta_bdy(ib_bdy)%lneed_tra = .TRUE. 
     302            ENDIF 
     303         ELSE 
     304            IF(lwp) WRITE(numout,*) '      NO T/S relaxation' 
     305         ENDIF 
     306         IF(lwp) WRITE(numout,*) 
     307 
     308#if defined key_si3 
     309         IF(lwp) THEN 
     310            WRITE(numout,*) 'Boundary conditions for sea ice:  ' 
     311            SELECT CASE( cn_ice(ib_bdy) )                   
     312            CASE('none')   ;   WRITE(numout,*) '      no open boundary condition'         
     313            CASE('frs')    ;   WRITE(numout,*) '      Flow Relaxation Scheme' 
     314            CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for cn_ice' ) 
     315            END SELECT 
     316         ENDIF 
     317 
     318         dta_bdy(ib_bdy)%lneed_ice = cn_ice(ib_bdy) /= 'none' 
     319 
     320         IF( lwp .AND. dta_bdy(ib_bdy)%lneed_ice ) THEN  
     321            SELECT CASE( nn_ice_dta(ib_bdy) )                   !  
     322            CASE( 0 )      ;   WRITE(numout,*) '      initial state used for bdy data'         
     323            CASE( 1 )      ;   WRITE(numout,*) '      boundary data taken from file' 
     324            CASE DEFAULT   ;   CALL ctl_stop( 'nn_ice_dta must be 0 or 1' ) 
     325            END SELECT 
     326         ENDIF 
     327#else 
     328         dta_bdy(ib_bdy)%lneed_ice = .FALSE. 
     329#endif 
     330         ! 
     331         IF(lwp) WRITE(numout,*) 
     332         IF(lwp) WRITE(numout,*) '      Width of relaxation zone = ', nn_rimwidth(ib_bdy) 
     333         IF(lwp) WRITE(numout,*) 
     334         ! 
     335      END DO   ! nb_bdy 
     336 
     337      IF( lwp ) THEN 
     338         IF( ln_vol ) THEN                     ! check volume conservation (nn_volctl value) 
     339            WRITE(numout,*) 'Volume correction applied at open boundaries' 
     340            WRITE(numout,*) 
     341            SELECT CASE ( nn_volctl ) 
     342            CASE( 1 )      ;   WRITE(numout,*) '      The total volume will be constant' 
     343            CASE( 0 )      ;   WRITE(numout,*) '      The total volume will vary according to the surface E-P flux' 
     344            CASE DEFAULT   ;   CALL ctl_stop( 'nn_volctl must be 0 or 1' ) 
     345            END SELECT 
     346            WRITE(numout,*) 
     347            ! 
     348            ! sanity check if used with tides         
     349            IF( ln_tide ) THEN  
     350               WRITE(numout,*) ' The total volume correction is not working with tides. ' 
     351               WRITE(numout,*) ' Set ln_vol to .FALSE. ' 
     352               WRITE(numout,*) ' or ' 
     353               WRITE(numout,*) ' equilibriate your bdy input files ' 
     354               CALL ctl_stop( 'The total volume correction is not working with tides.' ) 
     355            END IF 
     356         ELSE 
     357            WRITE(numout,*) 'No volume correction applied at open boundaries' 
     358            WRITE(numout,*) 
     359         ENDIF 
    166360      ENDIF 
    167  
    168       DO ib_bdy = 1,nb_bdy 
    169         IF(lwp) WRITE(numout,*) ' '  
    170         IF(lwp) WRITE(numout,*) '------ Open boundary data set ',ib_bdy,'------'  
    171  
    172         IF( ln_coords_file(ib_bdy) ) THEN 
    173            IF(lwp) WRITE(numout,*) 'Boundary definition read from file '//TRIM(cn_coords_file(ib_bdy)) 
    174         ELSE 
    175            IF(lwp) WRITE(numout,*) 'Boundary defined in namelist.' 
    176         ENDIF 
    177         IF(lwp) WRITE(numout,*) 
    178  
    179         IF(lwp) WRITE(numout,*) 'Boundary conditions for barotropic solution:  ' 
    180         SELECT CASE( cn_dyn2d(ib_bdy) )                   
    181           CASE( 'none' )          
    182              IF(lwp) WRITE(numout,*) '      no open boundary condition'         
    183              dta_bdy(ib_bdy)%ll_ssh = .false. 
    184              dta_bdy(ib_bdy)%ll_u2d = .false. 
    185              dta_bdy(ib_bdy)%ll_v2d = .false. 
    186           CASE( 'frs' )           
    187              IF(lwp) WRITE(numout,*) '      Flow Relaxation Scheme' 
    188              dta_bdy(ib_bdy)%ll_ssh = .false. 
    189              dta_bdy(ib_bdy)%ll_u2d = .true. 
    190              dta_bdy(ib_bdy)%ll_v2d = .true. 
    191           CASE( 'flather' )       
    192              IF(lwp) WRITE(numout,*) '      Flather radiation condition' 
    193              dta_bdy(ib_bdy)%ll_ssh = .true. 
    194              dta_bdy(ib_bdy)%ll_u2d = .true. 
    195              dta_bdy(ib_bdy)%ll_v2d = .true. 
    196           CASE( 'orlanski' )      
    197              IF(lwp) WRITE(numout,*) '      Orlanski (fully oblique) radiation condition with adaptive nudging' 
    198              dta_bdy(ib_bdy)%ll_ssh = .false. 
    199              dta_bdy(ib_bdy)%ll_u2d = .true. 
    200              dta_bdy(ib_bdy)%ll_v2d = .true. 
    201           CASE( 'orlanski_npo' )  
    202              IF(lwp) WRITE(numout,*) '      Orlanski (NPO) radiation condition with adaptive nudging' 
    203              dta_bdy(ib_bdy)%ll_ssh = .false. 
    204              dta_bdy(ib_bdy)%ll_u2d = .true. 
    205              dta_bdy(ib_bdy)%ll_v2d = .true. 
    206           CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for cn_dyn2d' ) 
    207         END SELECT 
    208         IF( cn_dyn2d(ib_bdy) /= 'none' ) THEN 
    209            SELECT CASE( nn_dyn2d_dta(ib_bdy) )                   !  
    210               CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      initial state used for bdy data'         
    211               CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      boundary data taken from file' 
    212               CASE( 2 )      ;   IF(lwp) WRITE(numout,*) '      tidal harmonic forcing taken from file' 
    213               CASE( 3 )      ;   IF(lwp) WRITE(numout,*) '      boundary data AND tidal harmonic forcing taken from files' 
    214               CASE DEFAULT   ;   CALL ctl_stop( 'nn_dyn2d_dta must be between 0 and 3' ) 
    215            END SELECT 
    216            IF (( nn_dyn2d_dta(ib_bdy) .ge. 2 ).AND.(.NOT.ln_tide)) THEN 
    217              CALL ctl_stop( 'You must activate with ln_tide to add tidal forcing at open boundaries' ) 
    218            ENDIF 
    219         ENDIF 
    220         IF(lwp) WRITE(numout,*) 
    221  
    222         IF(lwp) WRITE(numout,*) 'Boundary conditions for baroclinic velocities:  ' 
    223         SELECT CASE( cn_dyn3d(ib_bdy) )                   
    224           CASE('none') 
    225              IF(lwp) WRITE(numout,*) '      no open boundary condition'         
    226              dta_bdy(ib_bdy)%ll_u3d = .false. 
    227              dta_bdy(ib_bdy)%ll_v3d = .false. 
    228           CASE('frs')        
    229              IF(lwp) WRITE(numout,*) '      Flow Relaxation Scheme' 
    230              dta_bdy(ib_bdy)%ll_u3d = .true. 
    231              dta_bdy(ib_bdy)%ll_v3d = .true. 
    232           CASE('specified') 
    233              IF(lwp) WRITE(numout,*) '      Specified value' 
    234              dta_bdy(ib_bdy)%ll_u3d = .true. 
    235              dta_bdy(ib_bdy)%ll_v3d = .true. 
    236           CASE('neumann') 
    237              IF(lwp) WRITE(numout,*) '      Neumann conditions' 
    238              dta_bdy(ib_bdy)%ll_u3d = .false. 
    239              dta_bdy(ib_bdy)%ll_v3d = .false. 
    240           CASE('zerograd') 
    241              IF(lwp) WRITE(numout,*) '      Zero gradient for baroclinic velocities' 
    242              dta_bdy(ib_bdy)%ll_u3d = .false. 
    243              dta_bdy(ib_bdy)%ll_v3d = .false. 
    244           CASE('zero') 
    245              IF(lwp) WRITE(numout,*) '      Zero baroclinic velocities (runoff case)' 
    246              dta_bdy(ib_bdy)%ll_u3d = .false. 
    247              dta_bdy(ib_bdy)%ll_v3d = .false. 
    248           CASE('orlanski') 
    249              IF(lwp) WRITE(numout,*) '      Orlanski (fully oblique) radiation condition with adaptive nudging' 
    250              dta_bdy(ib_bdy)%ll_u3d = .true. 
    251              dta_bdy(ib_bdy)%ll_v3d = .true. 
    252           CASE('orlanski_npo') 
    253              IF(lwp) WRITE(numout,*) '      Orlanski (NPO) radiation condition with adaptive nudging' 
    254              dta_bdy(ib_bdy)%ll_u3d = .true. 
    255              dta_bdy(ib_bdy)%ll_v3d = .true. 
    256           CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for cn_dyn3d' ) 
    257         END SELECT 
    258         IF( cn_dyn3d(ib_bdy) /= 'none' ) THEN 
    259            SELECT CASE( nn_dyn3d_dta(ib_bdy) )                   !  
    260               CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      initial state used for bdy data'         
    261               CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      boundary data taken from file' 
    262               CASE DEFAULT   ;   CALL ctl_stop( 'nn_dyn3d_dta must be 0 or 1' ) 
    263            END SELECT 
    264         ENDIF 
    265  
    266         IF ( ln_dyn3d_dmp(ib_bdy) ) THEN 
    267            IF ( cn_dyn3d(ib_bdy) == 'none' ) THEN 
    268               IF(lwp) WRITE(numout,*) 'No open boundary condition for baroclinic velocities: ln_dyn3d_dmp is set to .false.' 
    269               ln_dyn3d_dmp(ib_bdy)=.false. 
    270            ELSEIF ( cn_dyn3d(ib_bdy) == 'frs' ) THEN 
    271               CALL ctl_stop( 'Use FRS OR relaxation' ) 
    272            ELSE 
    273               IF(lwp) WRITE(numout,*) '      + baroclinic velocities relaxation zone' 
    274               IF(lwp) WRITE(numout,*) '      Damping time scale: ',rn_time_dmp(ib_bdy),' days' 
    275               IF((lwp).AND.rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' ) 
    276               dta_bdy(ib_bdy)%ll_u3d = .true. 
    277               dta_bdy(ib_bdy)%ll_v3d = .true. 
    278            ENDIF 
    279         ELSE 
    280            IF(lwp) WRITE(numout,*) '      NO relaxation on baroclinic velocities' 
    281         ENDIF 
    282         IF(lwp) WRITE(numout,*) 
    283  
    284         IF(lwp) WRITE(numout,*) 'Boundary conditions for temperature and salinity:  ' 
    285         SELECT CASE( cn_tra(ib_bdy) )                   
    286           CASE('none') 
    287              IF(lwp) WRITE(numout,*) '      no open boundary condition'         
    288              dta_bdy(ib_bdy)%ll_tem = .false. 
    289              dta_bdy(ib_bdy)%ll_sal = .false. 
    290           CASE('frs') 
    291              IF(lwp) WRITE(numout,*) '      Flow Relaxation Scheme' 
    292              dta_bdy(ib_bdy)%ll_tem = .true. 
    293              dta_bdy(ib_bdy)%ll_sal = .true. 
    294           CASE('specified') 
    295              IF(lwp) WRITE(numout,*) '      Specified value' 
    296              dta_bdy(ib_bdy)%ll_tem = .true. 
    297              dta_bdy(ib_bdy)%ll_sal = .true. 
    298           CASE('neumann') 
    299              IF(lwp) WRITE(numout,*) '      Neumann conditions' 
    300              dta_bdy(ib_bdy)%ll_tem = .false. 
    301              dta_bdy(ib_bdy)%ll_sal = .false. 
    302           CASE('runoff') 
    303              IF(lwp) WRITE(numout,*) '      Runoff conditions : Neumann for T and specified to 0.1 for salinity' 
    304              dta_bdy(ib_bdy)%ll_tem = .false. 
    305              dta_bdy(ib_bdy)%ll_sal = .false. 
    306           CASE('orlanski') 
    307              IF(lwp) WRITE(numout,*) '      Orlanski (fully oblique) radiation condition with adaptive nudging' 
    308              dta_bdy(ib_bdy)%ll_tem = .true. 
    309              dta_bdy(ib_bdy)%ll_sal = .true. 
    310           CASE('orlanski_npo') 
    311              IF(lwp) WRITE(numout,*) '      Orlanski (NPO) radiation condition with adaptive nudging' 
    312              dta_bdy(ib_bdy)%ll_tem = .true. 
    313              dta_bdy(ib_bdy)%ll_sal = .true. 
    314           CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for cn_tra' ) 
    315         END SELECT 
    316         IF( cn_tra(ib_bdy) /= 'none' ) THEN 
    317            SELECT CASE( nn_tra_dta(ib_bdy) )                   !  
    318               CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      initial state used for bdy data'         
    319               CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      boundary data taken from file' 
    320               CASE DEFAULT   ;   CALL ctl_stop( 'nn_tra_dta must be 0 or 1' ) 
    321            END SELECT 
    322         ENDIF 
    323  
    324         IF ( ln_tra_dmp(ib_bdy) ) THEN 
    325            IF ( cn_tra(ib_bdy) == 'none' ) THEN 
    326               IF(lwp) WRITE(numout,*) 'No open boundary condition for tracers: ln_tra_dmp is set to .false.' 
    327               ln_tra_dmp(ib_bdy)=.false. 
    328            ELSEIF ( cn_tra(ib_bdy) == 'frs' ) THEN 
    329               CALL ctl_stop( 'Use FRS OR relaxation' ) 
    330            ELSE 
    331               IF(lwp) WRITE(numout,*) '      + T/S relaxation zone' 
    332               IF(lwp) WRITE(numout,*) '      Damping time scale: ',rn_time_dmp(ib_bdy),' days' 
    333               IF(lwp) WRITE(numout,*) '      Outflow damping time scale: ',rn_time_dmp_out(ib_bdy),' days' 
    334               IF((lwp).AND.rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' ) 
    335               dta_bdy(ib_bdy)%ll_tem = .true. 
    336               dta_bdy(ib_bdy)%ll_sal = .true. 
    337            ENDIF 
    338         ELSE 
    339            IF(lwp) WRITE(numout,*) '      NO T/S relaxation' 
    340         ENDIF 
    341         IF(lwp) WRITE(numout,*) 
    342  
    343 #if defined key_si3 
    344          IF(lwp) WRITE(numout,*) 'Boundary conditions for sea ice:  ' 
    345          SELECT CASE( cn_ice(ib_bdy) )                   
    346          CASE('none') 
    347              IF(lwp) WRITE(numout,*) '      no open boundary condition'         
    348              dta_bdy(ib_bdy)%ll_a_i = .false. 
    349              dta_bdy(ib_bdy)%ll_h_i = .false. 
    350              dta_bdy(ib_bdy)%ll_h_s = .false. 
    351          CASE('frs') 
    352              IF(lwp) WRITE(numout,*) '      Flow Relaxation Scheme' 
    353              dta_bdy(ib_bdy)%ll_a_i = .true. 
    354              dta_bdy(ib_bdy)%ll_h_i = .true. 
    355              dta_bdy(ib_bdy)%ll_h_s = .true. 
    356          CASE DEFAULT   ;   CALL ctl_stop( 'unrecognised value for cn_ice' ) 
    357          END SELECT 
    358         IF( cn_ice(ib_bdy) /= 'none' ) THEN  
    359            SELECT CASE( nn_ice_dta(ib_bdy) )                   !  
    360               CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      initial state used for bdy data'         
    361               CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      boundary data taken from file' 
    362               CASE DEFAULT   ;   CALL ctl_stop( 'nn_ice_dta must be 0 or 1' ) 
    363            END SELECT 
    364         ENDIF 
    365         IF(lwp) WRITE(numout,*) 
    366         IF(lwp) WRITE(numout,*) '      tem of bdy sea-ice = ', rn_ice_tem(ib_bdy)          
    367         IF(lwp) WRITE(numout,*) '      sal of bdy sea-ice = ', rn_ice_sal(ib_bdy)          
    368         IF(lwp) WRITE(numout,*) '      age of bdy sea-ice = ', rn_ice_age(ib_bdy)          
    369 #endif 
    370  
    371         IF(lwp) WRITE(numout,*) '      Width of relaxation zone = ', nn_rimwidth(ib_bdy) 
    372         IF(lwp) WRITE(numout,*) 
    373          ! 
    374       END DO 
    375  
    376      IF( nb_bdy > 0 ) THEN 
    377         IF( ln_vol ) THEN                     ! check volume conservation (nn_volctl value) 
    378           IF(lwp) WRITE(numout,*) 'Volume correction applied at open boundaries' 
    379           IF(lwp) WRITE(numout,*) 
    380           SELECT CASE ( nn_volctl ) 
    381             CASE( 1 )      ;   IF(lwp) WRITE(numout,*) '      The total volume will be constant' 
    382             CASE( 0 )      ;   IF(lwp) WRITE(numout,*) '      The total volume will vary according to the surface E-P flux' 
    383             CASE DEFAULT   ;   CALL ctl_stop( 'nn_volctl must be 0 or 1' ) 
    384           END SELECT 
    385           IF(lwp) WRITE(numout,*) 
    386           ! 
    387           ! sanity check if used with tides         
    388           IF( ln_tide ) THEN  
    389              IF(lwp) WRITE(numout,*) ' The total volume correction is not working with tides. ' 
    390              IF(lwp) WRITE(numout,*) ' Set ln_vol to .FALSE. ' 
    391              IF(lwp) WRITE(numout,*) ' or ' 
    392              IF(lwp) WRITE(numout,*) ' equilibriate your bdy input files ' 
    393              CALL ctl_stop( 'The total volume correction is not working with tides.' ) 
    394           END IF 
    395         ELSE 
    396           IF(lwp) WRITE(numout,*) 'No volume correction applied at open boundaries' 
    397           IF(lwp) WRITE(numout,*) 
    398         ENDIF 
    399         IF( nb_jpk_bdy > 0 ) THEN 
    400            IF(lwp) WRITE(numout,*) '*** open boundary will be interpolate in the vertical onto the native grid ***' 
    401         ELSE 
    402            IF(lwp) WRITE(numout,*) '*** open boundary will be read straight onto the native grid without vertical interpolation ***' 
    403         ENDIF 
    404      ENDIF 
    405361 
    406362      ! ------------------------------------------------- 
    … …  
    408364      ! ------------------------------------------------- 
    409365 
    410       ! Work out global dimensions of boundary data 
    411       ! --------------------------------------------- 
    412366      REWIND( numnam_cfg )      
    413  
    414367      nblendta(:,:) = 0 
    415368      nbdysege = 0 
    … …  
    417370      nbdysegn = 0 
    418371      nbdysegs = 0 
    419       icount   = 0 ! count user defined segments 
    420       ! Dimensions below are used to allocate arrays to read external data 
    421       jpbdtas = 1 ! Maximum size of boundary data (structured case) 
    422       jpbdtau = 1 ! Maximum size of boundary data (unstructured case) 
    423  
     372 
     373      ! Define all boundaries  
     374      ! --------------------- 
    424375      DO ib_bdy = 1, nb_bdy 
    425  
    426          IF( .NOT. ln_coords_file(ib_bdy) ) THEN ! Work out size of global arrays from namelist parameters 
    427   
    428             icount = icount + 1 
    429             ! No REWIND here because may need to read more than one nambdy_index namelist. 
    430             ! Read only namelist_cfg to avoid unseccessfull overwrite  
    431             ! keep full control of the configuration namelist 
    432             READ  ( numnam_cfg, nambdy_index, IOSTAT = ios, ERR = 904 ) 
    433 904         IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambdy_index in configuration namelist', lwp ) 
    434             IF(lwm) WRITE ( numond, nambdy_index ) 
    435  
    436             SELECT CASE ( TRIM(ctypebdy) ) 
    437               CASE( 'N' ) 
    438                  IF( nbdyind == -1 ) THEN  ! Automatic boundary definition: if nbdysegX = -1 
    439                     nbdyind  = jpjglo - 2  ! set boundary to whole side of model domain. 
    440                     nbdybeg  = 2 
    441                     nbdyend  = jpiglo - 1 
    442                  ENDIF 
    443                  nbdysegn = nbdysegn + 1 
    444                  npckgn(nbdysegn) = ib_bdy ! Save bdy package number 
    445                  jpjnob(nbdysegn) = nbdyind 
    446                  jpindt(nbdysegn) = nbdybeg 
    447                  jpinft(nbdysegn) = nbdyend 
    448                  ! 
    449               CASE( 'S' ) 
    450                  IF( nbdyind == -1 ) THEN  ! Automatic boundary definition: if nbdysegX = -1 
    451                     nbdyind  = 2           ! set boundary to whole side of model domain. 
    452                     nbdybeg  = 2 
    453                     nbdyend  = jpiglo - 1 
    454                  ENDIF 
    455                  nbdysegs = nbdysegs + 1 
    456                  npckgs(nbdysegs) = ib_bdy ! Save bdy package number 
    457                  jpjsob(nbdysegs) = nbdyind 
    458                  jpisdt(nbdysegs) = nbdybeg 
    459                  jpisft(nbdysegs) = nbdyend 
    460                  ! 
    461               CASE( 'E' ) 
    462                  IF( nbdyind == -1 ) THEN  ! Automatic boundary definition: if nbdysegX = -1 
    463                     nbdyind  = jpiglo - 2  ! set boundary to whole side of model domain. 
    464                     nbdybeg  = 2 
    465                     nbdyend  = jpjglo - 1 
    466                  ENDIF 
    467                  nbdysege = nbdysege + 1  
    468                  npckge(nbdysege) = ib_bdy ! Save bdy package number 
    469                  jpieob(nbdysege) = nbdyind 
    470                  jpjedt(nbdysege) = nbdybeg 
    471                  jpjeft(nbdysege) = nbdyend 
    472                  ! 
    473               CASE( 'W' ) 
    474                  IF( nbdyind == -1 ) THEN  ! Automatic boundary definition: if nbdysegX = -1 
    475                     nbdyind  = 2           ! set boundary to whole side of model domain. 
    476                     nbdybeg  = 2 
    477                     nbdyend  = jpjglo - 1 
    478                  ENDIF 
    479                  nbdysegw = nbdysegw + 1 
    480                  npckgw(nbdysegw) = ib_bdy ! Save bdy package number 
    481                  jpiwob(nbdysegw) = nbdyind 
    482                  jpjwdt(nbdysegw) = nbdybeg 
    483                  jpjwft(nbdysegw) = nbdyend 
    484                  ! 
    485               CASE DEFAULT   ;   CALL ctl_stop( 'ctypebdy must be N, S, E or W' ) 
    486             END SELECT 
    487  
    488             ! For simplicity we assume that in case of straight bdy, arrays have the same length 
    489             ! (even if it is true that last tangential velocity points 
    490             ! are useless). This simplifies a little bit boundary data format (and agrees with format 
    491             ! used so far in obc package) 
    492  
    493             nblendta(1:jpbgrd,ib_bdy) =  (nbdyend - nbdybeg + 1) * nn_rimwidth(ib_bdy) 
    494             jpbdtas = MAX(jpbdtas, (nbdyend - nbdybeg + 1)) 
    495             IF (lwp.and.(nn_rimwidth(ib_bdy)>nrimmax)) & 
    496             & CALL ctl_stop( 'rimwidth must be lower than nrimmax' ) 
    497  
    498          ELSE            ! Read size of arrays in boundary coordinates file. 
     376         ! 
     377         IF( .NOT. ln_coords_file(ib_bdy) ) THEN     ! build bdy coordinates with segments defined in namelist 
     378 
     379            CALL bdy_read_seg( ib_bdy, nblendta(:,ib_bdy) ) 
     380 
     381         ELSE                                        ! Read size of arrays in boundary coordinates file. 
     382             
    499383            CALL iom_open( cn_coords_file(ib_bdy), inum ) 
    500384            DO igrd = 1, jpbgrd 
    501385               id_dummy = iom_varid( inum, 'nbi'//cgrid(igrd), kdimsz=kdimsz )   
    502386               nblendta(igrd,ib_bdy) = MAXVAL(kdimsz) 
    503                jpbdtau = MAX(jpbdtau, MAXVAL(kdimsz)) 
    504387            END DO 
    505388            CALL iom_close( inum ) 
    506             ! 
    507          ENDIF  
     389         ENDIF 
    508390         ! 
    509391      END DO ! ib_bdy 
    510392 
    511       IF (nb_bdy>0) THEN 
    512          jpbdta = MAXVAL(nblendta(1:jpbgrd,1:nb_bdy)) 
    513  
    514          ! Allocate arrays 
    515          !--------------- 
    516          ALLOCATE( nbidta(jpbdta, jpbgrd, nb_bdy), nbjdta(jpbdta, jpbgrd, nb_bdy),    & 
    517             &      nbrdta(jpbdta, jpbgrd, nb_bdy) ) 
    518  
    519          IF( nb_jpk_bdy>0 ) THEN 
    520             ALLOCATE( dta_global(jpbdtau, 1, nb_jpk_bdy) ) 
    521             ALLOCATE( dta_global_z(jpbdtau, 1, nb_jpk_bdy) ) 
    522             ALLOCATE( dta_global_dz(jpbdtau, 1, nb_jpk_bdy) ) 
    523          ELSE 
    524             ALLOCATE( dta_global(jpbdtau, 1, jpk) ) 
    525             ALLOCATE( dta_global_z(jpbdtau, 1, jpk) ) ! needed ?? TODO 
    526             ALLOCATE( dta_global_dz(jpbdtau, 1, jpk) )! needed ?? TODO 
    527          ENDIF 
    528  
    529          IF ( icount>0 ) THEN 
    530             IF( nb_jpk_bdy>0 ) THEN 
    531                ALLOCATE( dta_global2(jpbdtas, nrimmax, nb_jpk_bdy) ) 
    532                ALLOCATE( dta_global2_z(jpbdtas, nrimmax, nb_jpk_bdy) ) 
    533                ALLOCATE( dta_global2_dz(jpbdtas, nrimmax, nb_jpk_bdy) ) 
    534             ELSE 
    535                ALLOCATE( dta_global2(jpbdtas, nrimmax, jpk) ) 
    536                ALLOCATE( dta_global2_z(jpbdtas, nrimmax, jpk) ) ! needed ?? TODO 
    537                ALLOCATE( dta_global2_dz(jpbdtas, nrimmax, jpk) )! needed ?? TODO   
    538             ENDIF 
    539          ENDIF 
    540          !  
    541       ENDIF 
    542  
    543393      ! Now look for crossings in user (namelist) defined open boundary segments: 
    544       !-------------------------------------------------------------------------- 
    545       IF( icount>0 )   CALL bdy_ctl_seg 
    546  
     394      IF( nbdysege > 0 .OR. nbdysegw > 0 .OR. nbdysegn > 0 .OR. nbdysegs > 0)   CALL bdy_ctl_seg 
     395       
     396      ! Allocate arrays 
     397      !--------------- 
     398      jpbdta = MAXVAL(nblendta(1:jpbgrd,1:nb_bdy)) 
     399      ALLOCATE( nbidta(jpbdta, jpbgrd, nb_bdy), nbjdta(jpbdta, jpbgrd, nb_bdy), nbrdta(jpbdta, jpbgrd, nb_bdy) ) 
     400     
    547401      ! Calculate global boundary index arrays or read in from file 
    548402      !------------------------------------------------------------                
    … …  
    552406         IF( ln_coords_file(ib_bdy) ) THEN 
    553407            ! 
     408            ALLOCATE( zz_read( MAXVAL(nblendta), 1 ) )           
    554409            CALL iom_open( cn_coords_file(ib_bdy), inum ) 
     410            ! 
    555411            DO igrd = 1, jpbgrd 
    556                CALL iom_get( inum, jpdom_unknown, 'nbi'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_bdy),:,1) ) 
     412               CALL iom_get( inum, jpdom_unknown, 'nbi'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) ) 
    557413               DO ii = 1,nblendta(igrd,ib_bdy) 
    558                   nbidta(ii,igrd,ib_bdy) = INT( dta_global(ii,1,1) ) 
     414                  nbidta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) 
    559415               END DO 
    560                CALL iom_get( inum, jpdom_unknown, 'nbj'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_bdy),:,1) ) 
     416               CALL iom_get( inum, jpdom_unknown, 'nbj'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) ) 
    561417               DO ii = 1,nblendta(igrd,ib_bdy) 
    562                   nbjdta(ii,igrd,ib_bdy) = INT( dta_global(ii,1,1) ) 
     418                  nbjdta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) 
    563419               END DO 
    564                CALL iom_get( inum, jpdom_unknown, 'nbr'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_bdy),:,1) ) 
     420               CALL iom_get( inum, jpdom_unknown, 'nbr'//cgrid(igrd), zz_read(1:nblendta(igrd,ib_bdy),:) ) 
    565421               DO ii = 1,nblendta(igrd,ib_bdy) 
    566                   nbrdta(ii,igrd,ib_bdy) = INT( dta_global(ii,1,1) ) 
     422                  nbrdta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) 
    567423               END DO 
    568424               ! 
    … …  
    572428               IF(lwp) WRITE(numout,*) ' nn_rimwidth from namelist is ', nn_rimwidth(ib_bdy) 
    573429               IF (ibr_max < nn_rimwidth(ib_bdy))   & 
    574                      CALL ctl_stop( 'nn_rimwidth is larger than maximum rimwidth in file',cn_coords_file(ib_bdy) ) 
    575             END DO 
     430                  CALL ctl_stop( 'nn_rimwidth is larger than maximum rimwidth in file',cn_coords_file(ib_bdy) ) 
     431            END DO 
     432            ! 
    576433            CALL iom_close( inum ) 
     434            DEALLOCATE( zz_read ) 
    577435            ! 
    578          ENDIF  
    579          ! 
    580       END DO       
    581      
     436         ENDIF 
     437         ! 
     438      END DO 
     439 
    582440      ! 2. Now fill indices corresponding to straight open boundary arrays: 
    583       ! East 
    584       !----- 
    585       DO iseg = 1, nbdysege 
    586          ib_bdy = npckge(iseg) 
    587          ! 
    588          ! ------------ T points ------------- 
    589          igrd=1 
    590          icount=0 
    591          DO ir = 1, nn_rimwidth(ib_bdy) 
    592             DO ij = jpjedt(iseg), jpjeft(iseg) 
    593                icount = icount + 1 
    594                nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir 
    595                nbjdta(icount, igrd, ib_bdy) = ij 
    596                nbrdta(icount, igrd, ib_bdy) = ir 
    597             ENDDO 
    598          ENDDO 
    599          ! 
    600          ! ------------ U points ------------- 
    601          igrd=2 
    602          icount=0 
    603          DO ir = 1, nn_rimwidth(ib_bdy) 
    604             DO ij = jpjedt(iseg), jpjeft(iseg) 
    605                icount = icount + 1 
    606                nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 1 - ir 
    607                nbjdta(icount, igrd, ib_bdy) = ij 
    608                nbrdta(icount, igrd, ib_bdy) = ir 
    609             ENDDO 
    610          ENDDO 
    611          ! 
    612          ! ------------ V points ------------- 
    613          igrd=3 
    614          icount=0 
    615          DO ir = 1, nn_rimwidth(ib_bdy) 
    616 !            DO ij = jpjedt(iseg), jpjeft(iseg) - 1 
    617             DO ij = jpjedt(iseg), jpjeft(iseg) 
    618                icount = icount + 1 
    619                nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir 
    620                nbjdta(icount, igrd, ib_bdy) = ij 
    621                nbrdta(icount, igrd, ib_bdy) = ir 
    622             ENDDO 
    623             nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
    624             nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
    625          ENDDO 
    626       ENDDO 
    627       ! 
    628       ! West 
    629       !----- 
    630       DO iseg = 1, nbdysegw 
    631          ib_bdy = npckgw(iseg) 
    632          ! 
    633          ! ------------ T points ------------- 
    634          igrd=1 
    635          icount=0 
    636          DO ir = 1, nn_rimwidth(ib_bdy) 
    637             DO ij = jpjwdt(iseg), jpjwft(iseg) 
    638                icount = icount + 1 
    639                nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 
    640                nbjdta(icount, igrd, ib_bdy) = ij 
    641                nbrdta(icount, igrd, ib_bdy) = ir 
    642             ENDDO 
    643          ENDDO 
    644          ! 
    645          ! ------------ U points ------------- 
    646          igrd=2 
    647          icount=0 
    648          DO ir = 1, nn_rimwidth(ib_bdy) 
    649             DO ij = jpjwdt(iseg), jpjwft(iseg) 
    650                icount = icount + 1 
    651                nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 
    652                nbjdta(icount, igrd, ib_bdy) = ij 
    653                nbrdta(icount, igrd, ib_bdy) = ir 
    654             ENDDO 
    655          ENDDO 
    656          ! 
    657          ! ------------ V points ------------- 
    658          igrd=3 
    659          icount=0 
    660          DO ir = 1, nn_rimwidth(ib_bdy) 
    661 !            DO ij = jpjwdt(iseg), jpjwft(iseg) - 1 
    662             DO ij = jpjwdt(iseg), jpjwft(iseg) 
    663                icount = icount + 1 
    664                nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 
    665                nbjdta(icount, igrd, ib_bdy) = ij 
    666                nbrdta(icount, igrd, ib_bdy) = ir 
    667             ENDDO 
    668             nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
    669             nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
    670          ENDDO 
    671       ENDDO 
    672       ! 
    673       ! North 
    674       !----- 
    675       DO iseg = 1, nbdysegn 
    676          ib_bdy = npckgn(iseg) 
    677          ! 
    678          ! ------------ T points ------------- 
    679          igrd=1 
    680          icount=0 
    681          DO ir = 1, nn_rimwidth(ib_bdy) 
    682             DO ii = jpindt(iseg), jpinft(iseg) 
    683                icount = icount + 1 
    684                nbidta(icount, igrd, ib_bdy) = ii 
    685                nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir  
    686                nbrdta(icount, igrd, ib_bdy) = ir 
    687             ENDDO 
    688          ENDDO 
    689          ! 
    690          ! ------------ U points ------------- 
    691          igrd=2 
    692          icount=0 
    693          DO ir = 1, nn_rimwidth(ib_bdy) 
    694 !            DO ii = jpindt(iseg), jpinft(iseg) - 1 
    695             DO ii = jpindt(iseg), jpinft(iseg) 
    696                icount = icount + 1 
    697                nbidta(icount, igrd, ib_bdy) = ii 
    698                nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir 
    699                nbrdta(icount, igrd, ib_bdy) = ir 
    700             ENDDO 
    701             nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
    702             nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
    703          ENDDO 
    704          ! 
    705          ! ------------ V points ------------- 
    706          igrd=3 
    707          icount=0 
    708          DO ir = 1, nn_rimwidth(ib_bdy) 
    709             DO ii = jpindt(iseg), jpinft(iseg) 
    710                icount = icount + 1 
    711                nbidta(icount, igrd, ib_bdy) = ii 
    712                nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 1 - ir 
    713                nbrdta(icount, igrd, ib_bdy) = ir 
    714             ENDDO 
    715          ENDDO 
    716       ENDDO 
    717       ! 
    718       ! South 
    719       !----- 
    720       DO iseg = 1, nbdysegs 
    721          ib_bdy = npckgs(iseg) 
    722          ! 
    723          ! ------------ T points ------------- 
    724          igrd=1 
    725          icount=0 
    726          DO ir = 1, nn_rimwidth(ib_bdy) 
    727             DO ii = jpisdt(iseg), jpisft(iseg) 
    728                icount = icount + 1 
    729                nbidta(icount, igrd, ib_bdy) = ii 
    730                nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 
    731                nbrdta(icount, igrd, ib_bdy) = ir 
    732             ENDDO 
    733          ENDDO 
    734          ! 
    735          ! ------------ U points ------------- 
    736          igrd=2 
    737          icount=0 
    738          DO ir = 1, nn_rimwidth(ib_bdy) 
    739 !            DO ii = jpisdt(iseg), jpisft(iseg) - 1 
    740             DO ii = jpisdt(iseg), jpisft(iseg) 
    741                icount = icount + 1 
    742                nbidta(icount, igrd, ib_bdy) = ii 
    743                nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 
    744                nbrdta(icount, igrd, ib_bdy) = ir 
    745             ENDDO 
    746             nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
    747             nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
    748          ENDDO 
    749          ! 
    750          ! ------------ V points ------------- 
    751          igrd=3 
    752          icount=0 
    753          DO ir = 1, nn_rimwidth(ib_bdy) 
    754             DO ii = jpisdt(iseg), jpisft(iseg) 
    755                icount = icount + 1 
    756                nbidta(icount, igrd, ib_bdy) = ii 
    757                nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 
    758                nbrdta(icount, igrd, ib_bdy) = ir 
    759             ENDDO 
    760          ENDDO 
    761       ENDDO 
     441      CALL bdy_coords_seg( nbidta, nbjdta, nbrdta ) 
    762442 
    763443      !  Deal with duplicated points 
    … …  
    773453                     DO ib2 = 1, nblendta(igrd,ib_bdy2) 
    774454                        IF ((nbidta(ib1, igrd, ib_bdy1)==nbidta(ib2, igrd, ib_bdy2)).AND. & 
    775                         &   (nbjdta(ib1, igrd, ib_bdy1)==nbjdta(ib2, igrd, ib_bdy2))) THEN 
    776 !                           IF ((lwp).AND.(igrd==1)) WRITE(numout,*) ' found coincident point ji, jj:', &  
    777 !                                                       &              nbidta(ib1, igrd, ib_bdy1),      &  
    778 !                                                       &              nbjdta(ib2, igrd, ib_bdy2) 
     455                           &   (nbjdta(ib1, igrd, ib_bdy1)==nbjdta(ib2, igrd, ib_bdy2))) THEN 
     456                           !                           IF ((lwp).AND.(igrd==1)) WRITE(numout,*) ' found coincident point ji, jj:', &  
     457                           !                                                       &              nbidta(ib1, igrd, ib_bdy1),      &  
     458                           !                                                       &              nbjdta(ib2, igrd, ib_bdy2) 
    779459                           ! keep only points with the lowest distance to boundary: 
    780460                           IF (nbrdta(ib1, igrd, ib_bdy1)<nbrdta(ib2, igrd, ib_bdy2)) THEN 
    781                              nbidta(ib2, igrd, ib_bdy2) =-ib_bdy2 
    782                              nbjdta(ib2, igrd, ib_bdy2) =-ib_bdy2 
     461                              nbidta(ib2, igrd, ib_bdy2) =-ib_bdy2 
     462                              nbjdta(ib2, igrd, ib_bdy2) =-ib_bdy2 
    783463                           ELSEIF (nbrdta(ib1, igrd, ib_bdy1)>nbrdta(ib2, igrd, ib_bdy2)) THEN 
    784                              nbidta(ib1, igrd, ib_bdy1) =-ib_bdy1 
    785                              nbjdta(ib1, igrd, ib_bdy1) =-ib_bdy1 
    786                            ! Arbitrary choice if distances are the same: 
     464                              nbidta(ib1, igrd, ib_bdy1) =-ib_bdy1 
     465                              nbjdta(ib1, igrd, ib_bdy1) =-ib_bdy1 
     466                              ! Arbitrary choice if distances are the same: 
    787467                           ELSE 
    788                              nbidta(ib1, igrd, ib_bdy1) =-ib_bdy1 
    789                              nbjdta(ib1, igrd, ib_bdy1) =-ib_bdy1 
     468                              nbidta(ib1, igrd, ib_bdy1) =-ib_bdy1 
     469                              nbjdta(ib1, igrd, ib_bdy1) =-ib_bdy1 
    790470                           ENDIF 
    791471                        END IF 
    … …  
    796476         END DO 
    797477      END DO 
    798  
    799       ! Work out dimensions of boundary data on each processor 
    800       ! ------------------------------------------------------ 
    801  
    802       ! Rather assume that boundary data indices are given on global domain 
    803       ! TO BE DISCUSSED ? 
    804 !      iw = mig(1) + 1            ! if monotasking and no zoom, iw=2 
    805 !      ie = mig(1) + nlci-1 - 1   ! if monotasking and no zoom, ie=jpim1 
    806 !      is = mjg(1) + 1            ! if monotasking and no zoom, is=2 
    807 !      in = mjg(1) + nlcj-1 - 1   ! if monotasking and no zoom, in=jpjm1       
    808       iwe = mig(1) - 1 + 2         ! if monotasking and no zoom, iw=2 
    809       ies = mig(1) + nlci-1 - 1  ! if monotasking and no zoom, ie=jpim1 
    810       iso = mjg(1) - 1 + 2         ! if monotasking and no zoom, is=2 
    811       ino = mjg(1) + nlcj-1 - 1  ! if monotasking and no zoom, in=jpjm1 
    812  
    813       ALLOCATE( nbondi_bdy(nb_bdy)) 
    814       ALLOCATE( nbondj_bdy(nb_bdy)) 
    815       nbondi_bdy(:)=2 
    816       nbondj_bdy(:)=2 
    817       ALLOCATE( nbondi_bdy_b(nb_bdy)) 
    818       ALLOCATE( nbondj_bdy_b(nb_bdy)) 
    819       nbondi_bdy_b(:)=2 
    820       nbondj_bdy_b(:)=2 
    821  
    822       ! Work out dimensions of boundary data on each neighbour process 
    823       IF(nbondi == 0) THEN 
    824          iw_b(1) = 1 + nimppt(nowe+1) 
    825          ie_b(1) = 1 + nimppt(nowe+1)+nlcit(nowe+1)-3 
    826          is_b(1) = 1 + njmppt(nowe+1) 
    827          in_b(1) = 1 + njmppt(nowe+1)+nlcjt(nowe+1)-3 
    828  
    829          iw_b(2) = 1 + nimppt(noea+1) 
    830          ie_b(2) = 1 + nimppt(noea+1)+nlcit(noea+1)-3 
    831          is_b(2) = 1 + njmppt(noea+1) 
    832          in_b(2) = 1 + njmppt(noea+1)+nlcjt(noea+1)-3 
    833       ELSEIF(nbondi == 1) THEN 
    834          iw_b(1) = 1 + nimppt(nowe+1) 
    835          ie_b(1) = 1 + nimppt(nowe+1)+nlcit(nowe+1)-3 
    836          is_b(1) = 1 + njmppt(nowe+1) 
    837          in_b(1) = 1 + njmppt(nowe+1)+nlcjt(nowe+1)-3 
    838       ELSEIF(nbondi == -1) THEN 
    839          iw_b(2) = 1 + nimppt(noea+1) 
    840          ie_b(2) = 1 + nimppt(noea+1)+nlcit(noea+1)-3 
    841          is_b(2) = 1 + njmppt(noea+1) 
    842          in_b(2) = 1 + njmppt(noea+1)+nlcjt(noea+1)-3 
    843       ENDIF 
    844  
    845       IF(nbondj == 0) THEN 
    846          iw_b(3) = 1 + nimppt(noso+1) 
    847          ie_b(3) = 1 + nimppt(noso+1)+nlcit(noso+1)-3 
    848          is_b(3) = 1 + njmppt(noso+1) 
    849          in_b(3) = 1 + njmppt(noso+1)+nlcjt(noso+1)-3 
    850  
    851          iw_b(4) = 1 + nimppt(nono+1) 
    852          ie_b(4) = 1 + nimppt(nono+1)+nlcit(nono+1)-3 
    853          is_b(4) = 1 + njmppt(nono+1) 
    854          in_b(4) = 1 + njmppt(nono+1)+nlcjt(nono+1)-3 
    855       ELSEIF(nbondj == 1) THEN 
    856          iw_b(3) = 1 + nimppt(noso+1) 
    857          ie_b(3) = 1 + nimppt(noso+1)+nlcit(noso+1)-3 
    858          is_b(3) = 1 + njmppt(noso+1) 
    859          in_b(3) = 1 + njmppt(noso+1)+nlcjt(noso+1)-3 
    860       ELSEIF(nbondj == -1) THEN 
    861          iw_b(4) = 1 + nimppt(nono+1) 
    862          ie_b(4) = 1 + nimppt(nono+1)+nlcit(nono+1)-3 
    863          is_b(4) = 1 + njmppt(nono+1) 
    864          in_b(4) = 1 + njmppt(nono+1)+nlcjt(nono+1)-3 
    865       ENDIF 
    866  
     478      ! 
     479      ! Find lenght of boundaries and rim on local mpi domain 
     480      !------------------------------------------------------ 
     481      ! 
     482      iwe = mig(1) 
     483      ies = mig(jpi) 
     484      iso = mjg(1)  
     485      ino = mjg(jpj)  
     486      ! 
    867487      DO ib_bdy = 1, nb_bdy 
    868488         DO igrd = 1, jpbgrd 
    869             icount  = 0 
    870             icountr = 0 
    871             idx_bdy(ib_bdy)%nblen(igrd)    = 0 
    872             idx_bdy(ib_bdy)%nblenrim(igrd) = 0 
     489            icount   = 0   ! initialization of local bdy length 
     490            icountr  = 0   ! initialization of local rim 0 and rim 1 bdy length 
     491            icountr0 = 0   ! initialization of local rim 0 bdy length 
     492            idx_bdy(ib_bdy)%nblen(igrd)     = 0 
     493            idx_bdy(ib_bdy)%nblenrim(igrd)  = 0 
     494            idx_bdy(ib_bdy)%nblenrim0(igrd) = 0 
    873495            DO ib = 1, nblendta(igrd,ib_bdy) 
    874496               ! check that data is in correct order in file 
    875                ibm1 = MAX(1,ib-1) 
    876                IF(lwp) THEN         ! Since all procs read global data only need to do this check on one proc... 
    877                   IF( nbrdta(ib,igrd,ib_bdy) < nbrdta(ibm1,igrd,ib_bdy) ) THEN 
     497               IF( ib > 1 ) THEN 
     498                  IF( nbrdta(ib,igrd,ib_bdy) < nbrdta(ib-1,igrd,ib_bdy) ) THEN 
    878499                     CALL ctl_stop('bdy_segs : ERROR : boundary data in file must be defined ', & 
    879                           &        ' in order of distance from edge nbr A utility for re-ordering ', & 
    880                           &        ' boundary coordinates and data files exists in the TOOLS/OBC directory') 
    881                   ENDIF     
     500                        &        ' in order of distance from edge nbr A utility for re-ordering ', & 
     501                        &        ' boundary coordinates and data files exists in the TOOLS/OBC directory') 
     502                  ENDIF 
    882503               ENDIF 
    883504               ! check if point is in local domain 
    … …  
    885506                  & nbjdta(ib,igrd,ib_bdy) >= iso .AND. nbjdta(ib,igrd,ib_bdy) <= ino      ) THEN 
    886507                  ! 
    887                   icount = icount  + 1 
    888                   ! 
    889                   IF( nbrdta(ib,igrd,ib_bdy) == 1 )   icountr = icountr+1 
     508                  icount = icount + 1 
     509                  IF( nbrdta(ib,igrd,ib_bdy) == 1 .OR. nbrdta(ib,igrd,ib_bdy) == 0 )   icountr = icountr + 1 
     510                  IF( nbrdta(ib,igrd,ib_bdy) == 0 )   icountr0 = icountr0 + 1 
    890511               ENDIF 
    891512            END DO 
    892             idx_bdy(ib_bdy)%nblenrim(igrd) = icountr !: length of rim boundary data on each proc 
    893             idx_bdy(ib_bdy)%nblen   (igrd) = icount  !: length of boundary data on each proc         
    894          END DO  ! igrd 
     513            idx_bdy(ib_bdy)%nblen    (igrd) = icount   !: length of boundary data on each proc 
     514            idx_bdy(ib_bdy)%nblenrim (igrd) = icountr  !: length of rim 0 and rim 1 boundary data on each proc    
     515            idx_bdy(ib_bdy)%nblenrim0(igrd) = icountr0 !: length of rim 0 boundary data on each proc      
     516         END DO   ! igrd 
    895517 
    896518         ! Allocate index arrays for this boundary set 
    … …  
    902524            &      idx_bdy(ib_bdy)%nbd   (ilen1,jpbgrd) ,   & 
    903525            &      idx_bdy(ib_bdy)%nbdout(ilen1,jpbgrd) ,   & 
     526            &      idx_bdy(ib_bdy)%ntreat(ilen1,jpbgrd) ,   & 
    904527            &      idx_bdy(ib_bdy)%nbmap (ilen1,jpbgrd) ,   & 
    905528            &      idx_bdy(ib_bdy)%nbw   (ilen1,jpbgrd) ,   & 
    … …  
    909532         ! Dispatch mapping indices and discrete distances on each processor 
    910533         ! ----------------------------------------------------------------- 
    911  
    912          com_east  = 0 
    913          com_west  = 0 
    914          com_south = 0 
    915          com_north = 0 
    916  
    917          com_east_b  = 0 
    918          com_west_b  = 0 
    919          com_south_b = 0 
    920          com_north_b = 0 
    921  
    922534         DO igrd = 1, jpbgrd 
    923535            icount  = 0 
    924             ! Loop on rimwidth to ensure outermost points come first in the local arrays. 
    925             DO ir=1, nn_rimwidth(ib_bdy) 
     536            ! Outer loop on rimwidth to ensure outermost points come first in the local arrays. 
     537            DO ir = 0, nn_rimwidth(ib_bdy) 
    926538               DO ib = 1, nblendta(igrd,ib_bdy) 
    927539                  ! check if point is in local domain and equals ir 
    … …  
    931543                     ! 
    932544                     icount = icount  + 1 
    933  
    934                      ! Rather assume that boundary data indices are given on global domain 
    935                      ! TO BE DISCUSSED ? 
    936 !                     idx_bdy(ib_bdy)%nbi(icount,igrd)   = nbidta(ib,igrd,ib_bdy)- mig(1)+1 
    937 !                     idx_bdy(ib_bdy)%nbj(icount,igrd)   = nbjdta(ib,igrd,ib_bdy)- mjg(1)+1 
    938                      idx_bdy(ib_bdy)%nbi(icount,igrd)   = nbidta(ib,igrd,ib_bdy)- mig(1)+1 
    939                      idx_bdy(ib_bdy)%nbj(icount,igrd)   = nbjdta(ib,igrd,ib_bdy)- mjg(1)+1 
    940                      ! check if point has to be sent 
    941                      ii = idx_bdy(ib_bdy)%nbi(icount,igrd) 
    942                      ij = idx_bdy(ib_bdy)%nbj(icount,igrd) 
    943                      if((com_east .ne. 1) .and. (ii == (nlci-1)) .and. (nbondi .le. 0)) then 
    944                         com_east = 1 
    945                      elseif((com_west .ne. 1) .and. (ii == 2) .and. (nbondi .ge. 0) .and. (nbondi .ne. 2)) then 
    946                         com_west = 1 
    947                      endif  
    948                      if((com_south .ne. 1) .and. (ij == 2) .and. (nbondj .ge. 0) .and. (nbondj .ne. 2)) then 
    949                         com_south = 1 
    950                      elseif((com_north .ne. 1) .and. (ij == (nlcj-1)) .and. (nbondj .le. 0)) then 
    951                         com_north = 1 
    952                      endif  
     545                     idx_bdy(ib_bdy)%nbi(icount,igrd)   = nbidta(ib,igrd,ib_bdy)- mig(1)+1   ! global to local indexes 
     546                     idx_bdy(ib_bdy)%nbj(icount,igrd)   = nbjdta(ib,igrd,ib_bdy)- mjg(1)+1   ! global to local indexes 
    953547                     idx_bdy(ib_bdy)%nbr(icount,igrd)   = nbrdta(ib,igrd,ib_bdy) 
    954548                     idx_bdy(ib_bdy)%nbmap(icount,igrd) = ib 
    955549                  ENDIF 
    956                   ! check if point has to be received from a neighbour 
    957                   IF(nbondi == 0) THEN 
    958                      IF( nbidta(ib,igrd,ib_bdy) >= iw_b(1) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(1) .AND.   & 
    959                        & nbjdta(ib,igrd,ib_bdy) >= is_b(1) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(1) .AND.   & 
    960                        & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
    961                        ii = nbidta(ib,igrd,ib_bdy)- iw_b(1)+2 
    962                        if((com_west_b .ne. 1) .and. (ii == (nlcit(nowe+1)-1))) then 
    963                           ij = nbjdta(ib,igrd,ib_bdy) - is_b(1)+2 
    964                           if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then 
    965                             com_south = 1 
    966                           elseif((ij == nlcjt(nowe+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then 
    967                             com_north = 1 
    968                           endif 
    969                           com_west_b = 1 
    970                        endif  
    971                      ENDIF 
    972                      IF( nbidta(ib,igrd,ib_bdy) >= iw_b(2) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(2) .AND.   & 
    973                        & nbjdta(ib,igrd,ib_bdy) >= is_b(2) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(2) .AND.   & 
    974                        & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
    975                        ii = nbidta(ib,igrd,ib_bdy)- iw_b(2)+2 
    976                        if((com_east_b .ne. 1) .and. (ii == 2)) then 
    977                           ij = nbjdta(ib,igrd,ib_bdy) - is_b(2)+2 
    978                           if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then 
    979                             com_south = 1 
    980                           elseif((ij == nlcjt(noea+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then 
    981                             com_north = 1 
    982                           endif 
    983                           com_east_b = 1 
    984                        endif  
    985                      ENDIF 
    986                   ELSEIF(nbondi == 1) THEN 
    987                      IF( nbidta(ib,igrd,ib_bdy) >= iw_b(1) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(1) .AND.   & 
    988                        & nbjdta(ib,igrd,ib_bdy) >= is_b(1) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(1) .AND.   & 
    989                        & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
    990                        ii = nbidta(ib,igrd,ib_bdy)- iw_b(1)+2 
    991                        if((com_west_b .ne. 1) .and. (ii == (nlcit(nowe+1)-1))) then 
    992                           ij = nbjdta(ib,igrd,ib_bdy) - is_b(1)+2 
    993                           if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then 
    994                             com_south = 1 
    995                           elseif((ij == nlcjt(nowe+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then 
    996                             com_north = 1 
    997                           endif 
    998                           com_west_b = 1 
    999                        endif  
    1000                      ENDIF 
    1001                   ELSEIF(nbondi == -1) THEN 
    1002                      IF( nbidta(ib,igrd,ib_bdy) >= iw_b(2) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(2) .AND.   & 
    1003                        & nbjdta(ib,igrd,ib_bdy) >= is_b(2) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(2) .AND.   & 
    1004                        & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
    1005                        ii = nbidta(ib,igrd,ib_bdy)- iw_b(2)+2 
    1006                        if((com_east_b .ne. 1) .and. (ii == 2)) then 
    1007                           ij = nbjdta(ib,igrd,ib_bdy) - is_b(2)+2 
    1008                           if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then 
    1009                             com_south = 1 
    1010                           elseif((ij == nlcjt(noea+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then 
    1011                             com_north = 1 
    1012                           endif 
    1013                           com_east_b = 1 
    1014                        endif  
    1015                      ENDIF 
    1016                   ENDIF 
    1017                   IF(nbondj == 0) THEN 
    1018                      IF(com_north_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(4)-1  & 
    1019                        & .OR. nbidta(ib,igrd,ib_bdy) == ie_b(4)+1) .AND. & 
    1020                        & nbjdta(ib,igrd,ib_bdy) == is_b(4) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 
    1021                        com_north_b = 1  
    1022                      ENDIF 
    1023                      IF(com_south_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(3)-1  & 
    1024                        &.OR. nbidta(ib,igrd,ib_bdy) == ie_b(3)+1) .AND. & 
    1025                        & nbjdta(ib,igrd,ib_bdy) == in_b(3) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 
    1026                        com_south_b = 1  
    1027                      ENDIF 
    1028                      IF( nbidta(ib,igrd,ib_bdy) >= iw_b(3) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(3) .AND.   & 
    1029                        & nbjdta(ib,igrd,ib_bdy) >= is_b(3) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(3) .AND.   & 
    1030                        & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
    1031                        ij = nbjdta(ib,igrd,ib_bdy)- is_b(3)+2 
    1032                        if((com_south_b .ne. 1) .and. (ij == (nlcjt(noso+1)-1))) then 
    1033                           com_south_b = 1 
    1034                        endif  
    1035                      ENDIF 
    1036                      IF( nbidta(ib,igrd,ib_bdy) >= iw_b(4) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(4) .AND.   & 
    1037                        & nbjdta(ib,igrd,ib_bdy) >= is_b(4) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(4) .AND.   & 
    1038                        & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
    1039                        ij = nbjdta(ib,igrd,ib_bdy)- is_b(4)+2 
    1040                        if((com_north_b .ne. 1) .and. (ij == 2)) then 
    1041                           com_north_b = 1 
    1042                        endif  
    1043                      ENDIF 
    1044                   ELSEIF(nbondj == 1) THEN 
    1045                      IF( com_south_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(3)-1 .OR. & 
    1046                        & nbidta(ib,igrd,ib_bdy) == ie_b(3)+1) .AND. & 
    1047                        & nbjdta(ib,igrd,ib_bdy) == in_b(3) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 
    1048                        com_south_b = 1  
    1049                      ENDIF 
    1050                      IF( nbidta(ib,igrd,ib_bdy) >= iw_b(3) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(3) .AND.   & 
    1051                        & nbjdta(ib,igrd,ib_bdy) >= is_b(3) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(3) .AND.   & 
    1052                        & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
    1053                        ij = nbjdta(ib,igrd,ib_bdy)- is_b(3)+2 
    1054                        if((com_south_b .ne. 1) .and. (ij == (nlcjt(noso+1)-1))) then 
    1055                           com_south_b = 1 
    1056                        endif  
    1057                      ENDIF 
    1058                   ELSEIF(nbondj == -1) THEN 
    1059                      IF(com_north_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(4)-1  & 
    1060                        & .OR. nbidta(ib,igrd,ib_bdy) == ie_b(4)+1) .AND. & 
    1061                        & nbjdta(ib,igrd,ib_bdy) == is_b(4) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 
    1062                        com_north_b = 1  
    1063                      ENDIF 
    1064                      IF( nbidta(ib,igrd,ib_bdy) >= iw_b(4) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(4) .AND.   & 
    1065                        & nbjdta(ib,igrd,ib_bdy) >= is_b(4) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(4) .AND.   & 
    1066                        & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
    1067                        ij = nbjdta(ib,igrd,ib_bdy)- is_b(4)+2 
    1068                        if((com_north_b .ne. 1) .and. (ij == 2)) then 
    1069                           com_north_b = 1 
    1070                        endif  
    1071                      ENDIF 
    1072                   ENDIF 
    1073                ENDDO 
    1074             ENDDO 
    1075          ENDDO  
    1076  
    1077          ! definition of the i- and j- direction local boundaries arrays used for sending the boundaries 
    1078          IF(     (com_east  == 1) .and. (com_west  == 1) ) THEN   ;   nbondi_bdy(ib_bdy) =  0 
    1079          ELSEIF( (com_east  == 1) .and. (com_west  == 0) ) THEN   ;   nbondi_bdy(ib_bdy) = -1 
    1080          ELSEIF( (com_east  == 0) .and. (com_west  == 1) ) THEN   ;   nbondi_bdy(ib_bdy) =  1 
    1081          ENDIF 
    1082          IF(     (com_north == 1) .and. (com_south == 1) ) THEN   ;   nbondj_bdy(ib_bdy) =  0 
    1083          ELSEIF( (com_north == 1) .and. (com_south == 0) ) THEN   ;   nbondj_bdy(ib_bdy) = -1 
    1084          ELSEIF( (com_north == 0) .and. (com_south == 1) ) THEN   ;   nbondj_bdy(ib_bdy) =  1 
    1085          ENDIF 
    1086  
    1087          ! definition of the i- and j- direction local boundaries arrays used for receiving the boundaries 
    1088          IF(     (com_east_b  == 1) .and. (com_west_b  == 1) ) THEN   ;   nbondi_bdy_b(ib_bdy) =  0 
    1089          ELSEIF( (com_east_b  == 1) .and. (com_west_b  == 0) ) THEN   ;   nbondi_bdy_b(ib_bdy) = -1 
    1090          ELSEIF( (com_east_b  == 0) .and. (com_west_b  == 1) ) THEN   ;   nbondi_bdy_b(ib_bdy) =  1 
    1091          ENDIF 
    1092          IF(     (com_north_b == 1) .and. (com_south_b == 1) ) THEN   ;   nbondj_bdy_b(ib_bdy) =  0 
    1093          ELSEIF( (com_north_b == 1) .and. (com_south_b == 0) ) THEN   ;   nbondj_bdy_b(ib_bdy) = -1 
    1094          ELSEIF( (com_north_b == 0) .and. (com_south_b == 1) ) THEN   ;   nbondj_bdy_b(ib_bdy) =  1 
    1095          ENDIF 
     550               END DO 
     551            END DO 
     552         END DO   ! igrd 
     553 
     554      END DO   ! ib_bdy 
     555 
     556      ! Initialize array indicating communications in bdy 
     557      ! ------------------------------------------------- 
     558      ALLOCATE( lsend_bdy(nb_bdy,jpbgrd,4,0:1), lrecv_bdy(nb_bdy,jpbgrd,4,0:1) ) 
     559      lsend_bdy(:,:,:,:) = .false. 
     560      lrecv_bdy(:,:,:,:) = .false.  
     561 
     562      DO ib_bdy = 1, nb_bdy 
     563         DO igrd = 1, jpbgrd 
     564            DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd)   ! only the rim triggers communications, see bdy routines 
     565               ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     566               ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     567               IF( ib .LE. idx_bdy(ib_bdy)%nblenrim0(igrd) ) THEN   ;   ir = 0 
     568               ELSE                                                 ;   ir = 1 
     569               END IF 
     570               ! 
     571               ! check if point has to be sent     to   a neighbour 
     572               ! W neighbour and on the inner left  side 
     573               IF( ii == 2     .and. (nbondi == 0 .or. nbondi ==  1) )   lsend_bdy(ib_bdy,igrd,1,ir) = .true. 
     574               ! E neighbour and on the inner right side 
     575               IF( ii == jpi-1 .and. (nbondi == 0 .or. nbondi == -1) )   lsend_bdy(ib_bdy,igrd,2,ir) = .true. 
     576               ! S neighbour and on the inner down side 
     577               IF( ij == 2     .and. (nbondj == 0 .or. nbondj ==  1) )   lsend_bdy(ib_bdy,igrd,3,ir) = .true. 
     578               ! N neighbour and on the inner up   side 
     579               IF( ij == jpj-1 .and. (nbondj == 0 .or. nbondj == -1) )   lsend_bdy(ib_bdy,igrd,4,ir) = .true. 
     580               ! 
     581               ! check if point has to be received from a neighbour 
     582               ! W neighbour and on the outter left  side 
     583               IF( ii == 1     .and. (nbondi == 0 .or. nbondi ==  1) )   lrecv_bdy(ib_bdy,igrd,1,ir) = .true. 
     584               ! E neighbour and on the outter right side 
     585               IF( ii == jpi   .and. (nbondi == 0 .or. nbondi == -1) )   lrecv_bdy(ib_bdy,igrd,2,ir) = .true. 
     586               ! S neighbour and on the outter down side 
     587               IF( ij == 1     .and. (nbondj == 0 .or. nbondj ==  1) )   lrecv_bdy(ib_bdy,igrd,3,ir) = .true. 
     588               ! N neighbour and on the outter up   side 
     589               IF( ij == jpj   .and. (nbondj == 0 .or. nbondj == -1) )   lrecv_bdy(ib_bdy,igrd,4,ir) = .true. 
     590               ! 
     591            END DO 
     592         END DO  ! igrd 
    1096593 
    1097594         ! Compute rim weights for FRS scheme 
    … …  
    1099596         DO igrd = 1, jpbgrd 
    1100597            DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) 
    1101                nbr => idx_bdy(ib_bdy)%nbr(ib,igrd) 
    1102                idx_bdy(ib_bdy)%nbw(ib,igrd) = 1.- TANH( REAL( nbr - 1 ) *0.5 )      ! tanh formulation 
    1103 !               idx_bdy(ib_bdy)%nbw(ib,igrd) = (REAL(nn_rimwidth(ib_bdy)+1-nbr)/REAL(nn_rimwidth(ib_bdy)))**2.  ! quadratic 
    1104 !               idx_bdy(ib_bdy)%nbw(ib,igrd) =  REAL(nn_rimwidth(ib_bdy)+1-nbr)/REAL(nn_rimwidth(ib_bdy))       ! linear 
    1105             END DO 
    1106          END DO  
     598               ir = MAX( 1, idx_bdy(ib_bdy)%nbr(ib,igrd) )   ! both rim 0 and rim 1 have the same weights 
     599               idx_bdy(ib_bdy)%nbw(ib,igrd) = 1.- TANH( REAL( ir - 1 ) *0.5 )      ! tanh formulation 
     600               !               idx_bdy(ib_bdy)%nbw(ib,igrd) = (REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy)))**2.  ! quadratic 
     601               !               idx_bdy(ib_bdy)%nbw(ib,igrd) =  REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy))       ! linear 
     602            END DO 
     603         END DO 
    1107604 
    1108605         ! Compute damping coefficients 
    … …  
    1110607         DO igrd = 1, jpbgrd 
    1111608            DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) 
    1112                nbr => idx_bdy(ib_bdy)%nbr(ib,igrd) 
     609               ir = MAX( 1, idx_bdy(ib_bdy)%nbr(ib,igrd) )   ! both rim 0 and rim 1 have the same damping coefficients 
    1113610               idx_bdy(ib_bdy)%nbd(ib,igrd) = 1. / ( rn_time_dmp(ib_bdy) * rday ) &  
    1114                & *(REAL(nn_rimwidth(ib_bdy)+1-nbr)/REAL(nn_rimwidth(ib_bdy)))**2.   ! quadratic 
     611                  & *(REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy)))**2.   ! quadratic 
    1115612               idx_bdy(ib_bdy)%nbdout(ib,igrd) = 1. / ( rn_time_dmp_out(ib_bdy) * rday ) &  
    1116                & *(REAL(nn_rimwidth(ib_bdy)+1-nbr)/REAL(nn_rimwidth(ib_bdy)))**2.   ! quadratic 
    1117             END DO 
    1118          END DO  
    1119  
    1120       END DO 
     613                  & *(REAL(nn_rimwidth(ib_bdy)+1-ir)/REAL(nn_rimwidth(ib_bdy)))**2.   ! quadratic 
     614            END DO 
     615         END DO 
     616 
     617      END DO ! ib_bdy 
    1121618 
    1122619      ! ------------------------------------------------------ 
    1123620      ! Initialise masks and find normal/tangential directions 
    1124621      ! ------------------------------------------------------ 
     622 
     623      ! ------------------------------------------ 
     624      ! handle rim0, do as if rim 1 was free ocean 
     625      ! ------------------------------------------ 
     626 
     627      ztmask(:,:) = tmask(:,:,1)   ;   zumask(:,:) = umask(:,:,1)   ;   zvmask(:,:) = vmask(:,:,1) 
     628      ! For the flagu/flagv calculation below we require a version of fmask without 
     629      ! the land boundary condition (shlat) included: 
     630      DO ij = 1, jpjm1 
     631         DO ii = 1, jpim1 
     632            zfmask(ii,ij) =  ztmask(ii,ij  ) * ztmask(ii+1,ij  )   & 
     633               &           * ztmask(ii,ij+1) * ztmask(ii+1,ij+1) 
     634         END DO 
     635      END DO 
     636      CALL lbc_lnk( 'bdyini', zfmask, 'F', 1. ) 
    1125637 
    1126638      ! Read global 2D mask at T-points: bdytmask 
    … …  
    1128640      ! bdytmask = 1  on the computational domain AND on open boundaries 
    1129641      !          = 0  elsewhere    
    1130   
     642 
    1131643      bdytmask(:,:) = ssmask(:,:) 
    1132644 
    1133645      ! Derive mask on U and V grid from mask on T grid 
    1134  
    1135       bdyumask(:,:) = 0._wp 
    1136       bdyvmask(:,:) = 0._wp 
    1137646      DO ij = 1, jpjm1 
    1138647         DO ii = 1, jpim1 
    1139             bdyumask(ii,ij) = bdytmask(ii,ij) * bdytmask(ii+1, ij ) 
     648            bdyumask(ii,ij) = bdytmask(ii,ij) * bdytmask(ii+1,ij ) 
    1140649            bdyvmask(ii,ij) = bdytmask(ii,ij) * bdytmask(ii  ,ij+1)   
    1141650         END DO 
    1142651      END DO 
    1143       CALL lbc_lnk_multi( 'bdyini', bdyumask, 'U', 1. , bdyvmask, 'V', 1. )   ! Lateral boundary cond.  
    1144  
    1145       ! bdy masks are now set to zero on boundary points: 
    1146       ! 
    1147       igrd = 1 
     652      CALL lbc_lnk_multi( 'bdyini', bdyumask, 'U', 1., bdyvmask, 'V', 1. )   ! Lateral boundary cond. 
     653 
     654      ! bdy masks are now set to zero on rim 0 points: 
    1148655      DO ib_bdy = 1, nb_bdy 
    1149         DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd)       
    1150           bdytmask(idx_bdy(ib_bdy)%nbi(ib,igrd), idx_bdy(ib_bdy)%nbj(ib,igrd)) = 0._wp 
    1151         END DO 
    1152       END DO 
    1153       ! 
    1154       igrd = 2 
     656         DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(1)   ! extent of rim 0 
     657            bdytmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp 
     658         END DO 
     659         DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(2)   ! extent of rim 0 
     660            bdyumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp 
     661         END DO 
     662         DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(3)   ! extent of rim 0 
     663            bdyvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp 
     664         END DO 
     665      END DO 
     666 
     667      CALL bdy_rim_treat( zumask, zvmask, zfmask, .true. )   ! compute flagu, flagv, ntreat on rim 0 
     668 
     669      ! ------------------------------------ 
     670      ! handle rim1, do as if rim 0 was land 
     671      ! ------------------------------------ 
     672       
     673      ! z[tuv]mask are now set to zero on rim 0 points: 
    1155674      DO ib_bdy = 1, nb_bdy 
    1156         DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 
    1157           bdyumask(idx_bdy(ib_bdy)%nbi(ib,igrd), idx_bdy(ib_bdy)%nbj(ib,igrd)) = 0._wp 
    1158         END DO 
    1159       END DO 
    1160       ! 
    1161       igrd = 3 
     675         DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(1)   ! extent of rim 0 
     676            ztmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp 
     677         END DO 
     678         DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(2)   ! extent of rim 0 
     679            zumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp 
     680         END DO 
     681         DO ib = 1, idx_bdy(ib_bdy)%nblenrim0(3)   ! extent of rim 0 
     682            zvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp 
     683         END DO 
     684      END DO 
     685 
     686      ! Recompute zfmask 
     687      DO ij = 1, jpjm1 
     688         DO ii = 1, jpim1 
     689            zfmask(ii,ij) =  ztmask(ii,ij  ) * ztmask(ii+1,ij  )   & 
     690               &           * ztmask(ii,ij+1) * ztmask(ii+1,ij+1) 
     691         END DO 
     692      END DO 
     693      CALL lbc_lnk( 'bdyini', zfmask, 'F', 1. ) 
     694 
     695      ! bdy masks are now set to zero on rim1 points: 
    1162696      DO ib_bdy = 1, nb_bdy 
    1163         DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 
    1164           bdyvmask(idx_bdy(ib_bdy)%nbi(ib,igrd), idx_bdy(ib_bdy)%nbj(ib,igrd)) = 0._wp 
    1165         END DO 
    1166       END DO 
    1167  
    1168       ! For the flagu/flagv calculation below we require a version of fmask without 
    1169       ! the land boundary condition (shlat) included: 
    1170       zfmask(:,:) = 0 
    1171       DO ij = 2, jpjm1 
    1172          DO ii = 2, jpim1 
    1173             zfmask(ii,ij) = tmask(ii,ij  ,1) * tmask(ii+1,ij  ,1)   & 
    1174            &              * tmask(ii,ij+1,1) * tmask(ii+1,ij+1,1) 
    1175          END DO       
    1176       END DO 
    1177  
    1178       ! Lateral boundary conditions 
    1179       CALL lbc_lnk( 'bdyini', zfmask, 'F', 1. )  
    1180       CALL lbc_lnk_multi( 'bdyini', bdyumask, 'U', 1. , bdyvmask, 'V', 1., bdytmask, 'T', 1. ) 
     697         DO ib = idx_bdy(ib_bdy)%nblenrim0(1) + 1,  idx_bdy(ib_bdy)%nblenrim(1)   ! extent of rim 1 
     698            bdytmask(idx_bdy(ib_bdy)%nbi(ib,1), idx_bdy(ib_bdy)%nbj(ib,1)) = 0._wp 
     699         END DO 
     700         DO ib = idx_bdy(ib_bdy)%nblenrim0(2) + 1,  idx_bdy(ib_bdy)%nblenrim(2)   ! extent of rim 1 
     701            bdyumask(idx_bdy(ib_bdy)%nbi(ib,2), idx_bdy(ib_bdy)%nbj(ib,2)) = 0._wp 
     702         END DO 
     703         DO ib = idx_bdy(ib_bdy)%nblenrim0(3) + 1,  idx_bdy(ib_bdy)%nblenrim(3)   ! extent of rim 1 
     704            bdyvmask(idx_bdy(ib_bdy)%nbi(ib,3), idx_bdy(ib_bdy)%nbj(ib,3)) = 0._wp 
     705         END DO 
     706      END DO 
     707 
     708      CALL bdy_rim_treat( zumask, zvmask, zfmask, .false. )   ! compute flagu, flagv, ntreat on rim 1 
     709      ! 
     710      ! Check which boundaries might need communication 
     711      ALLOCATE( lsend_bdyint(nb_bdy,jpbgrd,4,0:1), lrecv_bdyint(nb_bdy,jpbgrd,4,0:1) ) 
     712      lsend_bdyint(:,:,:,:) = .false. 
     713      lrecv_bdyint(:,:,:,:) = .false.  
     714      ALLOCATE( lsend_bdyext(nb_bdy,jpbgrd,4,0:1), lrecv_bdyext(nb_bdy,jpbgrd,4,0:1) ) 
     715      lsend_bdyext(:,:,:,:) = .false. 
     716      lrecv_bdyext(:,:,:,:) = .false. 
     717      ! 
     718      DO igrd = 1, jpbgrd 
     719         DO ib_bdy = 1, nb_bdy 
     720            DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 
     721               IF( idx_bdy(ib_bdy)%ntreat(ib,igrd) == -1 ) CYCLE 
     722               ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     723               ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     724               ir = idx_bdy(ib_bdy)%nbr(ib,igrd) 
     725               flagu = NINT(idx_bdy(ib_bdy)%flagu(ib,igrd)) 
     726               flagv = NINT(idx_bdy(ib_bdy)%flagv(ib,igrd)) 
     727               iibe = ii - flagu   ! neighbouring point towards the exterior of the computational domain 
     728               ijbe = ij - flagv 
     729               iibi = ii + flagu   ! neighbouring point towards the interior of the computational domain 
     730               ijbi = ij + flagv 
     731               CALL find_neib( ii, ij, idx_bdy(ib_bdy)%ntreat(ib,igrd), ii1, ij1, ii2, ij2, ii3, ij3 )   ! free ocean neighbours 
     732               ! 
     733               ! search neighbour in the  west/east  direction 
     734               ! Rim is on the halo and computed ocean is towards exterior of mpi domain   
     735               !      <--    (o exterior)     -->   
     736               ! (1)  o|x         OR    (2)   x|o 
     737               !       |___                 ___|  
     738               IF( iibi == 0     .OR. ii1 == 0     .OR. ii2 == 0     .OR. ii3 == 0     )   lrecv_bdyint(ib_bdy,igrd,1,ir) = .true. 
     739               IF( iibi == jpi+1 .OR. ii1 == jpi+1 .OR. ii2 == jpi+1 .OR. ii3 == jpi+1 )   lrecv_bdyint(ib_bdy,igrd,2,ir) = .true.   
     740               IF( iibe == 0                                                           )   lrecv_bdyext(ib_bdy,igrd,1,ir) = .true. 
     741               IF( iibe == jpi+1                                                       )   lrecv_bdyext(ib_bdy,igrd,2,ir) = .true.   
     742               ! Check if neighbour has its rim parallel to its mpi subdomain border and located next to its halo 
     743               ! :¨¨¨¨¨|¨¨-->    |                                             |    <--¨¨|¨¨¨¨¨:  
     744               ! :     |  x:o    |    neighbour limited by ... would need o    |    o:x  |     : 
     745               ! :.....|_._:_____|   (1) W neighbour         E neighbour (2)   |_____:_._|.....: 
     746               IF( ii == 2     .AND. ( nbondi ==  1 .OR. nbondi == 0 ) .AND. & 
     747                  & ( iibi == 3     .OR. ii1 == 3     .OR. ii2 == 3     .OR. ii3 == 3    ) )   lsend_bdyint(ib_bdy,igrd,1,ir)=.true. 
     748               IF( ii == jpi-1 .AND. ( nbondi == -1 .OR. nbondi == 0 ) .AND. & 
     749                  & ( iibi == jpi-2 .OR. ii1 == jpi-2 .OR. ii2 == jpi-2 .OR. ii3 == jpi-2) )   lsend_bdyint(ib_bdy,igrd,2,ir)=.true. 
     750               IF( ii == 2     .AND. ( nbondi ==  1 .OR. nbondi == 0 ) .AND. iibe == 3     )   lsend_bdyext(ib_bdy,igrd,1,ir)=.true. 
     751               IF( ii == jpi-1 .AND. ( nbondi == -1 .OR. nbondi == 0 ) .AND. iibe == jpi-2 )   lsend_bdyext(ib_bdy,igrd,2,ir)=.true. 
     752               ! 
     753               ! search neighbour in the north/south direction    
     754               ! Rim is on the halo and computed ocean is towards exterior of mpi domain 
     755               !(3)   |       |         ^   ___o___      
     756               !  |   |___x___|   OR    |  |   x   | 
     757               !  v       o           (4)  |       | 
     758               IF( ijbi == 0     .OR. ij1 == 0     .OR. ij2 == 0     .OR. ij3 == 0     )   lrecv_bdyint(ib_bdy,igrd,3,ir) = .true. 
     759               IF( ijbi == jpj+1 .OR. ij1 == jpj+1 .OR. ij2 == jpj+1 .OR. ij3 == jpj+1 )   lrecv_bdyint(ib_bdy,igrd,4,ir) = .true. 
     760               IF( ijbe == 0                                                           )   lrecv_bdyext(ib_bdy,igrd,3,ir) = .true. 
     761               IF( ijbe == jpj+1                                                       )   lrecv_bdyext(ib_bdy,igrd,4,ir) = .true. 
     762               ! Check if neighbour has its rim parallel to its mpi subdomain     _________  border and next to its halo 
     763               !   ^  |    o    |                                                :         :  
     764               !   |  |¨¨¨¨x¨¨¨¨|   neighbour limited by ... would need o     |  |....x....| 
     765               !      :_________:  (3) S neighbour          N neighbour (4)   v  |    o    |    
     766               IF( ij == 2     .AND. ( nbondj ==  1 .OR. nbondj == 0 ) .AND. & 
     767                  & ( ijbi == 3     .OR. ij1 == 3     .OR. ij2 == 3     .OR. ij3 == 3    ) )   lsend_bdyint(ib_bdy,igrd,3,ir)=.true. 
     768               IF( ij == jpj-1 .AND. ( nbondj == -1 .OR. nbondj == 0 ) .AND. & 
     769                  & ( ijbi == jpj-2 .OR. ij1 == jpj-2 .OR. ij2 == jpj-2 .OR. ij3 == jpj-2) )   lsend_bdyint(ib_bdy,igrd,4,ir)=.true. 
     770               IF( ij == 2     .AND. ( nbondj ==  1 .OR. nbondj == 0 ) .AND. ijbe == 3     )   lsend_bdyext(ib_bdy,igrd,3,ir)=.true. 
     771               IF( ij == jpj-1 .AND. ( nbondj == -1 .OR. nbondj == 0 ) .AND. ijbe == jpj-2 )   lsend_bdyext(ib_bdy,igrd,4,ir)=.true. 
     772            END DO 
     773         END DO 
     774      END DO 
     775 
     776      DO ib_bdy = 1,nb_bdy 
     777         IF(  cn_dyn2d(ib_bdy) == 'orlanski' .OR. cn_dyn2d(ib_bdy) == 'orlanski_npo' .OR. & 
     778            & cn_dyn3d(ib_bdy) == 'orlanski' .OR. cn_dyn3d(ib_bdy) == 'orlanski_npo' .OR. & 
     779            & cn_tra(ib_bdy)   == 'orlanski' .OR. cn_tra(ib_bdy)   == 'orlanski_npo'      ) THEN 
     780            DO igrd = 1, jpbgrd 
     781               DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 
     782                  ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     783                  ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     784                  IF(  mig(ii) > 2 .AND. mig(ii) < jpiglo-2 .AND. mjg(ij) > 2 .AND. mjg(ij) < jpjglo-2  ) THEN 
     785                     WRITE(ctmp1,*) ' Orlanski is not safe when the open boundaries are on the interior of the computational domain' 
     786                     CALL ctl_stop( ctmp1 ) 
     787                  END IF 
     788               END DO 
     789            END DO 
     790         END IF 
     791      END DO 
     792      ! 
     793      DEALLOCATE( nbidta, nbjdta, nbrdta ) 
     794      ! 
     795   END SUBROUTINE bdy_def 
     796 
     797 
     798   SUBROUTINE bdy_rim_treat( pumask, pvmask, pfmask, lrim0 ) 
     799      !!---------------------------------------------------------------------- 
     800      !!                 ***  ROUTINE bdy_rim_treat  *** 
     801      !! 
     802      !! ** Purpose :   Initialize structures ( flagu, flagv, ntreat ) indicating how rim points 
     803      !!                  are to be handled in the boundary condition treatment 
     804      !! 
     805      !! ** Method  :   - to handle rim 0 zmasks must indicate ocean points      (set at one on rim 0 and rim 1 and interior) 
     806      !!                            and bdymasks must be set at 0 on rim 0       (set at one on rim 1 and interior) 
     807      !!                    (as if rim 1 was free ocean) 
     808      !!                - to handle rim 1 zmasks must be set at 0 on rim 0       (set at one on rim 1 and interior) 
     809      !!                            and bdymasks must indicate free ocean points (set at one on interior) 
     810      !!                    (as if rim 0 was land) 
     811      !!                - we can then check in which direction the interior of the computational domain is with the difference 
     812      !!                         mask array values on both sides to compute flagu and flagv 
     813      !!                - and look at the ocean neighbours to compute ntreat 
     814      !!---------------------------------------------------------------------- 
     815      REAL(wp), TARGET, DIMENSION(jpi,jpj), INTENT (in   ) :: pfmask   ! temporary fmask excluding coastal boundary condition (shlat) 
     816      REAL(wp), TARGET, DIMENSION(jpi,jpj), INTENT (in   ) :: pumask, pvmask   ! temporary t/u/v mask array 
     817      LOGICAL                             , INTENT (in   ) :: lrim0    ! .true. -> rim 0   .false. -> rim 1 
     818      INTEGER  ::   ib_bdy, ii, ij, igrd, ib, icount       ! dummy loop indices 
     819      INTEGER  ::   i_offset, j_offset, inn                ! local integer 
     820      INTEGER  ::   ibeg, iend                             ! local integer 
     821      LOGICAL  ::   llnon, llson, llean, llwen             ! local logicals indicating the presence of a ocean neighbour 
     822      REAL(wp), POINTER, DIMENSION(:,:)       ::   zmask   ! pointer to 2D mask fields 
     823      REAL(wp) ::   zefl, zwfl, znfl, zsfl                 ! local scalars 
     824      CHARACTER(LEN=1), DIMENSION(jpbgrd)     ::   cgrid 
     825      REAL(wp)        , DIMENSION(jpi,jpj)    ::   ztmp 
     826      !!---------------------------------------------------------------------- 
     827 
     828      cgrid = (/'t','u','v'/) 
     829 
    1181830      DO ib_bdy = 1, nb_bdy       ! Indices and directions of rim velocity components 
    1182  
    1183          idx_bdy(ib_bdy)%flagu(:,:) = 0._wp 
    1184          idx_bdy(ib_bdy)%flagv(:,:) = 0._wp 
    1185          icount = 0  
    1186831 
    1187832         ! Calculate relationship of U direction to the local orientation of the boundary 
    … …  
    1189834         ! flagu =  0 : u is tangential 
    1190835         ! flagu =  1 : u is normal to the boundary and is direction is inward 
    1191    
    1192836         DO igrd = 1, jpbgrd  
    1193837            SELECT CASE( igrd ) 
    1194                CASE( 1 )   ;   pmask => umask   (:,:,1)   ;   i_offset = 0 
    1195                CASE( 2 )   ;   pmask => bdytmask(:,:)     ;   i_offset = 1 
    1196                CASE( 3 )   ;   pmask => zfmask  (:,:)     ;   i_offset = 0 
     838               CASE( 1 )   ;   zmask => pumask     ;   i_offset = 0 
     839               CASE( 2 )   ;   zmask => bdytmask   ;   i_offset = 1 
     840               CASE( 3 )   ;   zmask => pfmask     ;   i_offset = 0 
    1197841            END SELECT  
    1198842            icount = 0 
    1199             DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd)   
    1200                nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 
    1201                nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 
    1202                zefl = pmask(nbi+i_offset-1,nbj) 
    1203                zwfl = pmask(nbi+i_offset,nbj) 
     843            ztmp(:,:) = -999._wp 
     844            IF( lrim0 ) THEN   ! extent of rim 0 
     845               ibeg = 1                                     ;   iend = idx_bdy(ib_bdy)%nblenrim0(igrd) 
     846            ELSE               ! extent of rim 1 
     847               ibeg = idx_bdy(ib_bdy)%nblenrim0(igrd) + 1   ;   iend = idx_bdy(ib_bdy)%nblenrim(igrd) 
     848            END IF 
     849            DO ib = ibeg, iend  
     850               ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     851               ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     852               IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj )  CYCLE 
     853               zwfl = zmask(ii+i_offset-1,ij) 
     854               zefl = zmask(ii+i_offset  ,ij) 
    1204855               ! This error check only works if you are using the bdyXmask arrays 
    1205                IF( i_offset == 1 .and. zefl + zwfl == 2 ) THEN 
     856               IF( i_offset == 1 .and. zefl + zwfl == 2. ) THEN 
    1206857                  icount = icount + 1 
    1207                   IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(nbi),mjg(nbj) 
     858                  IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(ii),mjg(ij) 
    1208859               ELSE 
    1209                   idx_bdy(ib_bdy)%flagu(ib,igrd) = -zefl + zwfl 
     860                  ztmp(ii,ij) = -zwfl + zefl 
    1210861               ENDIF 
    1211862            END DO 
    1212863            IF( icount /= 0 ) THEN 
    1213                WRITE(ctmp1,*) ' E R R O R : Some ',cgrid(igrd),' grid points,',   & 
     864               WRITE(ctmp1,*) 'Some ',cgrid(igrd),' grid points,',   & 
    1214865                  ' are not boundary points (flagu calculation). Check nbi, nbj, indices for boundary set ',ib_bdy 
    1215                WRITE(ctmp2,*) ' ========== ' 
    1216                CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 
     866               CALL ctl_stop( ctmp1 ) 
    1217867            ENDIF  
     868            SELECT CASE( igrd ) 
     869               CASE( 1 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. )  
     870               CASE( 2 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. )  
     871               CASE( 3 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. )  
     872            END SELECT  
     873            DO ib = ibeg, iend 
     874               ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     875               ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     876               idx_bdy(ib_bdy)%flagu(ib,igrd) = ztmp(ii,ij) 
     877            END DO 
    1218878         END DO 
    1219879 
    … …  
    1222882         ! flagv =  0 : v is tangential 
    1223883         ! flagv =  1 : v is normal to the boundary and is direction is inward 
    1224  
    1225884         DO igrd = 1, jpbgrd  
    1226885            SELECT CASE( igrd ) 
    1227                CASE( 1 )   ;   pmask => vmask (:,:,1)   ;   j_offset = 0 
    1228                CASE( 2 )   ;   pmask => zfmask(:,:)     ;   j_offset = 0 
    1229                CASE( 3 )   ;   pmask => bdytmask        ;   j_offset = 1 
     886               CASE( 1 )   ;   zmask => pvmask     ;   j_offset = 0 
     887               CASE( 2 )   ;   zmask => pfmask     ;   j_offset = 0 
     888               CASE( 3 )   ;   zmask => bdytmask   ;   j_offset = 1 
    1230889            END SELECT  
    1231890            icount = 0 
    1232             DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd)   
    1233                nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 
    1234                nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 
    1235                znfl = pmask(nbi,nbj+j_offset-1) 
    1236                zsfl = pmask(nbi,nbj+j_offset  ) 
     891            ztmp(:,:) = -999._wp 
     892            IF( lrim0 ) THEN   ! extent of rim 0 
     893               ibeg = 1                                     ;   iend = idx_bdy(ib_bdy)%nblenrim0(igrd) 
     894            ELSE               ! extent of rim 1 
     895               ibeg = idx_bdy(ib_bdy)%nblenrim0(igrd) + 1   ;   iend = idx_bdy(ib_bdy)%nblenrim(igrd) 
     896            END IF 
     897            DO ib = ibeg, iend 
     898               ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     899               ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     900               IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj )  CYCLE 
     901               zsfl = zmask(ii,ij+j_offset-1) 
     902               znfl = zmask(ii,ij+j_offset  ) 
    1237903               ! This error check only works if you are using the bdyXmask arrays 
    1238                IF( j_offset == 1 .and. znfl + zsfl == 2 ) THEN 
    1239                   IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(nbi),mjg(nbj) 
     904               IF( j_offset == 1 .and. znfl + zsfl == 2. ) THEN 
     905                  IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(ii),mjg(ij) 
    1240906                  icount = icount + 1 
    1241907               ELSE 
    1242                   idx_bdy(ib_bdy)%flagv(ib,igrd) = -znfl + zsfl 
     908                  ztmp(ii,ij) = -zsfl + znfl 
    1243909               END IF 
    1244910            END DO 
    1245911            IF( icount /= 0 ) THEN 
    1246                WRITE(ctmp1,*) ' E R R O R : Some ',cgrid(igrd),' grid points,',   & 
     912               WRITE(ctmp1,*) 'Some ',cgrid(igrd),' grid points,',   & 
    1247913                  ' are not boundary points (flagv calculation). Check nbi, nbj, indices for boundary set ',ib_bdy 
    1248                WRITE(ctmp2,*) ' ========== ' 
    1249                CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 
    1250             ENDIF  
    1251          END DO 
    1252          ! 
    1253       END DO 
    1254       ! 
    1255       ! Tidy up 
    1256       !-------- 
    1257       IF( nb_bdy>0 )   DEALLOCATE( nbidta, nbjdta, nbrdta ) 
    1258       ! 
    1259    END SUBROUTINE bdy_segs 
    1260  
     914               CALL ctl_stop( ctmp1 ) 
     915            ENDIF 
     916            SELECT CASE( igrd ) 
     917               CASE( 1 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. )  
     918               CASE( 2 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. )  
     919               CASE( 3 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. )  
     920            END SELECT  
     921            DO ib = ibeg, iend 
     922               ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     923               ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     924               idx_bdy(ib_bdy)%flagv(ib,igrd) = ztmp(ii,ij) 
     925            END DO 
     926         END DO 
     927         ! 
     928      END DO ! ib_bdy 
     929       
     930      DO ib_bdy = 1, nb_bdy 
     931         DO igrd = 1, jpbgrd 
     932            SELECT CASE( igrd ) 
     933               CASE( 1 )   ;   zmask => bdytmask  
     934               CASE( 2 )   ;   zmask => bdyumask  
     935               CASE( 3 )   ;   zmask => bdyvmask  
     936            END SELECT 
     937            ztmp(:,:) = -999._wp 
     938            IF( lrim0 ) THEN   ! extent of rim 0 
     939               ibeg = 1                                     ;   iend = idx_bdy(ib_bdy)%nblenrim0(igrd) 
     940            ELSE               ! extent of rim 1 
     941               ibeg = idx_bdy(ib_bdy)%nblenrim0(igrd) + 1   ;   iend = idx_bdy(ib_bdy)%nblenrim(igrd) 
     942            END IF 
     943            DO ib = ibeg, iend 
     944               ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     945               ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     946               IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj )   CYCLE 
     947               llnon = zmask(ii  ,ij+1) == 1.   
     948               llson = zmask(ii  ,ij-1) == 1.  
     949               llean = zmask(ii+1,ij  ) == 1.  
     950               llwen = zmask(ii-1,ij  ) == 1.  
     951               inn  = COUNT( (/ llnon, llson, llean, llwen /) ) 
     952               IF( inn == 0 ) THEN   ! no neighbours -> interior of a corner  or  cluster of rim points 
     953                  !               !              !     _____     !     _____    !    __     __ 
     954                  !  1 |   o      !  2  o   |    !  3 | x        !  4     x |   !      |   |   -> error 
     955                  !    |_x_ _     !    _ _x_|    !    |   o      !      o   |   !      |x_x| 
     956                  IF(     zmask(ii+1,ij+1) == 1. ) THEN   ;   ztmp(ii,ij) = 1. 
     957                  ELSEIF( zmask(ii-1,ij+1) == 1. ) THEN   ;   ztmp(ii,ij) = 2. 
     958                  ELSEIF( zmask(ii+1,ij-1) == 1. ) THEN   ;   ztmp(ii,ij) = 3. 
     959                  ELSEIF( zmask(ii-1,ij-1) == 1. ) THEN   ;   ztmp(ii,ij) = 4. 
     960                  ELSE                                    ;   ztmp(ii,ij) = -1. 
     961                     WRITE(ctmp1,*) 'Problem with  ',cgrid(igrd) ,' grid point', ii, ij,   & 
     962                       ' on boundary set ', ib_bdy, ' has no free ocean neighbour' 
     963                     IF( lrim0 ) THEN 
     964                        WRITE(ctmp2,*) ' There seems to be a cluster of rim 0 points.' 
     965                     ELSE 
     966                        WRITE(ctmp2,*) ' There seems to be a cluster of rim 1 points.' 
     967                     END IF 
     968                     CALL ctl_warn( ctmp1, ctmp2 ) 
     969                  END IF 
     970               END IF 
     971               IF( inn == 1 ) THEN   ! middle of linear bdy  or incomplete corner  ! ___ o 
     972                  !    |         !         |   !      o     !    ______            !    |x___ 
     973                  ! 5  | x o     ! 6   o x |   ! 7  __x__   ! 8    x 
     974                  !    |         !         |   !            !      o 
     975                  IF( llean )   ztmp(ii,ij) = 5. 
     976                  IF( llwen )   ztmp(ii,ij) = 6. 
     977                  IF( llnon )   ztmp(ii,ij) = 7. 
     978                  IF( llson )   ztmp(ii,ij) = 8. 
     979               END IF 
     980               IF( inn == 2 ) THEN   ! exterior of a corner 
     981                  !        o      !        o      !    _____|       !       |_____   
     982                  !  9 ____x o    ! 10   o x___   ! 11     x o      ! 12   o x       
     983                  !         |     !       |       !        o        !        o  
     984                  IF( llnon .AND. llean )   ztmp(ii,ij) =  9. 
     985                  IF( llnon .AND. llwen )   ztmp(ii,ij) = 10. 
     986                  IF( llson .AND. llean )   ztmp(ii,ij) = 11. 
     987                  IF( llson .AND. llwen )   ztmp(ii,ij) = 12. 
     988               END IF 
     989               IF( inn == 3 ) THEN   ! 3 neighbours     __   __ 
     990                  !    |_  o      !        o  _|  !       |_|     !       o          
     991                  ! 13  _| x o    ! 14   o x |_   ! 15   o x o    ! 16  o x o        
     992                  !    |   o      !        o   |  !        o      !    __|¨|__     
     993                  IF( llnon .AND. llean .AND. llson )   ztmp(ii,ij) = 13. 
     994                  IF( llnon .AND. llwen .AND. llson )   ztmp(ii,ij) = 14. 
     995                  IF( llwen .AND. llson .AND. llean )   ztmp(ii,ij) = 15. 
     996                  IF( llwen .AND. llnon .AND. llean )   ztmp(ii,ij) = 16. 
     997               END IF 
     998               IF( inn == 4 ) THEN 
     999                  WRITE(ctmp1,*)  'Problem with  ',cgrid(igrd) ,' grid point', ii, ij,   & 
     1000                       ' on boundary set ', ib_bdy, ' have 4 neighbours' 
     1001                  CALL ctl_stop( ctmp1 ) 
     1002               END IF 
     1003            END DO 
     1004            SELECT CASE( igrd ) 
     1005               CASE( 1 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'T', 1. )  
     1006               CASE( 2 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. )  
     1007               CASE( 3 )   ;   CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. )  
     1008            END SELECT  
     1009            DO ib = ibeg, iend 
     1010               ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     1011               ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     1012               idx_bdy(ib_bdy)%ntreat(ib,igrd) = NINT(ztmp(ii,ij)) 
     1013            END DO 
     1014         END DO 
     1015      END DO 
     1016 
     1017    END SUBROUTINE bdy_rim_treat 
     1018 
     1019    
     1020    SUBROUTINE find_neib( ii, ij, itreat, ii1, ij1, ii2, ij2, ii3, ij3 ) 
     1021      !!---------------------------------------------------------------------- 
     1022      !!                 ***  ROUTINE find_neib  *** 
     1023      !! 
     1024      !! ** Purpose :   get ii1, ij1, ii2, ij2, ii3, ij3, the indices of 
     1025      !!               the free ocean neighbours of (ii,ij) for bdy treatment 
     1026      !! 
     1027      !! ** Method  :  use itreat input to select a case 
     1028      !!               N.B. ntreat is defined for all bdy points in routine bdy_rim_treat 
     1029      !! 
     1030      !!---------------------------------------------------------------------- 
     1031      INTEGER, INTENT(in   )      ::   ii, ij, itreat 
     1032      INTEGER, INTENT(  out)      ::   ii1, ij1, ii2, ij2, ii3, ij3 
     1033      !!---------------------------------------------------------------------- 
     1034      SELECT CASE( itreat )   ! points that will be used by bdy routines, -1 will be discarded 
     1035         !               !               !     _____     !     _____      
     1036         !  1 |   o      !  2  o   |     !  3 | x        !  4     x |     
     1037         !    |_x_ _     !    _ _x_|     !    |   o      !      o   | 
     1038      CASE( 1 )    ;   ii1 = ii+1   ;   ij1 = ij+1   ;   ii2 = -1     ;   ij2 = -1     ;   ii3 = -1     ;   ij3 = -1 
     1039      CASE( 2 )    ;   ii1 = ii-1   ;   ij1 = ij+1   ;   ii2 = -1     ;   ij2 = -1     ;   ii3 = -1     ;   ij3 = -1 
     1040      CASE( 3 )    ;   ii1 = ii+1   ;   ij1 = ij-1   ;   ii2 = -1     ;   ij2 = -1     ;   ii3 = -1     ;   ij3 = -1 
     1041      CASE( 4 )    ;   ii1 = ii-1   ;   ij1 = ij-1   ;   ii2 = -1     ;   ij2 = -1     ;   ii3 = -1     ;   ij3 = -1 
     1042         !    |          !         |     !      o        !    ______                   ! or incomplete corner 
     1043         ! 5  | x o      ! 6   o x |     ! 7  __x__      ! 8    x                      !  7  ____ o 
     1044         !    |          !         |     !               !      o                      !         |x___ 
     1045      CASE( 5 )    ;   ii1 = ii+1   ;   ij1 = ij     ;   ii2 = -1     ;   ij2 = -1     ;   ii3 = -1     ;   ij3 = -1 
     1046      CASE( 6 )    ;   ii1 = ii-1   ;   ij1 = ij     ;   ii2 = -1     ;   ij2 = -1     ;   ii3 = -1     ;   ij3 = -1 
     1047      CASE( 7 )    ;   ii1 = ii     ;   ij1 = ij+1   ;   ii2 = -1     ;   ij2 = -1     ;   ii3 = -1     ;   ij3 = -1 
     1048      CASE( 8 )    ;   ii1 = ii     ;   ij1 = ij-1   ;   ii2 = -1     ;   ij2 = -1     ;   ii3 = -1     ;   ij3 = -1 
     1049         !        o      !        o      !    _____|     !       |_____   
     1050         !  9 ____x o    ! 10   o x___   ! 11     x o    ! 12   o x       
     1051         !         |     !       |       !        o      !        o       
     1052      CASE( 9  )   ;   ii1 = ii     ;   ij1 = ij+1   ;   ii2 = ii+1   ;   ij2 = ij     ;   ii3 = -1     ;   ij3 = -1  
     1053      CASE( 10 )   ;   ii1 = ii     ;   ij1 = ij+1   ;   ii2 = ii-1   ;   ij2 = ij     ;   ii3 = -1     ;   ij3 = -1 
     1054      CASE( 11 )   ;   ii1 = ii     ;   ij1 = ij-1   ;   ii2 = ii+1   ;   ij2 = ij     ;   ii3 = -1     ;   ij3 = -1 
     1055      CASE( 12 )   ;   ii1 = ii     ;   ij1 = ij-1   ;   ii2 = ii-1   ;   ij2 = ij     ;   ii3 = -1     ;   ij3 = -1 
     1056         !    |_  o      !        o  _|  !     ¨¨|_|¨¨   !       o          
     1057         ! 13  _| x o    !  14  o x |_   !  15  o x o    ! 16  o x o        
     1058         !    |   o      !        o   |  !        o      !    __|¨|__  
     1059      CASE( 13 )   ;   ii1 = ii     ;   ij1 = ij+1   ;   ii2 = ii+1   ;   ij2 = ij     ;   ii3 = ii     ;   ij3 = ij-1    
     1060      CASE( 14 )   ;   ii1 = ii     ;   ij1 = ij+1   ;   ii2 = ii-1   ;   ij2 = ij     ;   ii3 = ii     ;   ij3 = ij-1  
     1061      CASE( 15 )   ;   ii1 = ii-1   ;   ij1 = ij     ;   ii2 = ii     ;   ij2 = ij-1   ;   ii3 = ii+1   ;   ij3 = ij    
     1062      CASE( 16 )   ;   ii1 = ii-1   ;   ij1 = ij     ;   ii2 = ii     ;   ij2 = ij+1   ;   ii3 = ii+1   ;   ij3 = ij 
     1063      END SELECT 
     1064   END SUBROUTINE find_neib 
     1065     
     1066 
     1067   SUBROUTINE bdy_read_seg( kb_bdy, knblendta )  
     1068      !!---------------------------------------------------------------------- 
     1069      !!                 ***  ROUTINE bdy_coords_seg  *** 
     1070      !! 
     1071      !! ** Purpose :  build bdy coordinates with segments defined in namelist 
     1072      !! 
     1073      !! ** Method  :  read namelist nambdy_index blocks 
     1074      !! 
     1075      !!---------------------------------------------------------------------- 
     1076      INTEGER                   , INTENT (in   ) ::   kb_bdy           ! bdy number 
     1077      INTEGER, DIMENSION(jpbgrd), INTENT (  out) ::   knblendta        ! length of index arrays  
     1078      !! 
     1079      INTEGER          ::   ios                 ! Local integer output status for namelist read 
     1080      INTEGER          ::   nbdyind, nbdybeg, nbdyend 
     1081      CHARACTER(LEN=1) ::   ctypebdy   !     -        -  
     1082      NAMELIST/nambdy_index/ ctypebdy, nbdyind, nbdybeg, nbdyend 
     1083      !!---------------------------------------------------------------------- 
     1084 
     1085      ! No REWIND here because may need to read more than one nambdy_index namelist. 
     1086      ! Read only namelist_cfg to avoid unseccessfull overwrite  
     1087      ! keep full control of the configuration namelist 
     1088      READ  ( numnam_cfg, nambdy_index, IOSTAT = ios, ERR = 904 ) 
     1089904   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambdy_index in configuration namelist' ) 
     1090      IF(lwm) WRITE ( numond, nambdy_index ) 
     1091       
     1092      SELECT CASE ( TRIM(ctypebdy) ) 
     1093      CASE( 'N' ) 
     1094         IF( nbdyind == -1 ) THEN  ! Automatic boundary definition: if nbdysegX = -1 
     1095            nbdyind  = jpjglo - 2  ! set boundary to whole side of model domain. 
     1096            nbdybeg  = 2 
     1097            nbdyend  = jpiglo - 1 
     1098         ENDIF 
     1099         nbdysegn = nbdysegn + 1 
     1100         npckgn(nbdysegn) = kb_bdy ! Save bdy package number 
     1101         jpjnob(nbdysegn) = nbdyind 
     1102         jpindt(nbdysegn) = nbdybeg 
     1103         jpinft(nbdysegn) = nbdyend 
     1104         ! 
     1105      CASE( 'S' ) 
     1106         IF( nbdyind == -1 ) THEN  ! Automatic boundary definition: if nbdysegX = -1 
     1107            nbdyind  = 2           ! set boundary to whole side of model domain. 
     1108            nbdybeg  = 2 
     1109            nbdyend  = jpiglo - 1 
     1110         ENDIF 
     1111         nbdysegs = nbdysegs + 1 
     1112         npckgs(nbdysegs) = kb_bdy ! Save bdy package number 
     1113         jpjsob(nbdysegs) = nbdyind 
     1114         jpisdt(nbdysegs) = nbdybeg 
     1115         jpisft(nbdysegs) = nbdyend 
     1116         ! 
     1117      CASE( 'E' ) 
     1118         IF( nbdyind == -1 ) THEN  ! Automatic boundary definition: if nbdysegX = -1 
     1119            nbdyind  = jpiglo - 2  ! set boundary to whole side of model domain. 
     1120            nbdybeg  = 2 
     1121            nbdyend  = jpjglo - 1 
     1122         ENDIF 
     1123         nbdysege = nbdysege + 1  
     1124         npckge(nbdysege) = kb_bdy ! Save bdy package number 
     1125         jpieob(nbdysege) = nbdyind 
     1126         jpjedt(nbdysege) = nbdybeg 
     1127         jpjeft(nbdysege) = nbdyend 
     1128         ! 
     1129      CASE( 'W' ) 
     1130         IF( nbdyind == -1 ) THEN  ! Automatic boundary definition: if nbdysegX = -1 
     1131            nbdyind  = 2           ! set boundary to whole side of model domain. 
     1132            nbdybeg  = 2 
     1133            nbdyend  = jpjglo - 1 
     1134         ENDIF 
     1135         nbdysegw = nbdysegw + 1 
     1136         npckgw(nbdysegw) = kb_bdy ! Save bdy package number 
     1137         jpiwob(nbdysegw) = nbdyind 
     1138         jpjwdt(nbdysegw) = nbdybeg 
     1139         jpjwft(nbdysegw) = nbdyend 
     1140         ! 
     1141      CASE DEFAULT   ;   CALL ctl_stop( 'ctypebdy must be N, S, E or W' ) 
     1142      END SELECT 
     1143       
     1144      ! For simplicity we assume that in case of straight bdy, arrays have the same length 
     1145      ! (even if it is true that last tangential velocity points 
     1146      ! are useless). This simplifies a little bit boundary data format (and agrees with format 
     1147      ! used so far in obc package) 
     1148       
     1149      knblendta(1:jpbgrd) =  (nbdyend - nbdybeg + 1) * nn_rimwidth(kb_bdy) 
     1150       
     1151   END SUBROUTINE bdy_read_seg 
     1152 
     1153    
    12611154   SUBROUTINE bdy_ctl_seg 
    12621155      !!---------------------------------------------------------------------- 
    … …  
    12881181            &(jpjnob(ib).le.1))        CALL ctl_stop( 'nbdyind out of domain' ) 
    12891182         IF (jpindt(ib).ge.jpinft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 
    1290          IF (jpindt(ib).le.1     )     CALL ctl_stop( 'Start index out of domain' ) 
    1291          IF (jpinft(ib).ge.jpiglo)     CALL ctl_stop( 'End index out of domain' ) 
     1183         IF (jpindt(ib).lt.1     )     CALL ctl_stop( 'Start index out of domain' ) 
     1184         IF (jpinft(ib).gt.jpiglo)     CALL ctl_stop( 'End index out of domain' ) 
    12921185      END DO 
    12931186      ! 
    … …  
    12971190            &(jpjsob(ib).le.1))        CALL ctl_stop( 'nbdyind out of domain' ) 
    12981191         IF (jpisdt(ib).ge.jpisft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 
    1299          IF (jpisdt(ib).le.1     )     CALL ctl_stop( 'Start index out of domain' ) 
    1300          IF (jpisft(ib).ge.jpiglo)     CALL ctl_stop( 'End index out of domain' ) 
     1192         IF (jpisdt(ib).lt.1     )     CALL ctl_stop( 'Start index out of domain' ) 
     1193         IF (jpisft(ib).gt.jpiglo)     CALL ctl_stop( 'End index out of domain' ) 
    13011194      END DO 
    13021195      ! 
    … …  
    13061199            &(jpieob(ib).le.1))        CALL ctl_stop( 'nbdyind out of domain' ) 
    13071200         IF (jpjedt(ib).ge.jpjeft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 
    1308          IF (jpjedt(ib).le.1     )     CALL ctl_stop( 'Start index out of domain' ) 
    1309          IF (jpjeft(ib).ge.jpjglo)     CALL ctl_stop( 'End index out of domain' ) 
     1201         IF (jpjedt(ib).lt.1     )     CALL ctl_stop( 'Start index out of domain' ) 
     1202         IF (jpjeft(ib).gt.jpjglo)     CALL ctl_stop( 'End index out of domain' ) 
    13101203      END DO 
    13111204      ! 
    … …  
    13151208            &(jpiwob(ib).le.1))        CALL ctl_stop( 'nbdyind out of domain' ) 
    13161209         IF (jpjwdt(ib).ge.jpjwft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 
    1317          IF (jpjwdt(ib).le.1     )     CALL ctl_stop( 'Start index out of domain' ) 
    1318          IF (jpjwft(ib).ge.jpjglo)     CALL ctl_stop( 'End index out of domain' ) 
     1210         IF (jpjwdt(ib).lt.1     )     CALL ctl_stop( 'Start index out of domain' ) 
     1211         IF (jpjwft(ib).gt.jpjglo)     CALL ctl_stop( 'End index out of domain' ) 
    13191212      ENDDO 
    13201213      ! 
    … …  
    13451238                     icorns(ib2,1) = npckgw(ib1) 
    13461239                  ELSEIF ((jpisft(ib2)==jpiwob(ib1)).AND.(jpjwft(ib1)==jpjsob(ib2))) THEN 
    1347                      WRITE(ctmp1,*) ' E R R O R : Found an acute open boundary corner at point (i,j)= ', & 
     1240                     WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & 
    13481241                        &                                     jpisft(ib2), jpjwft(ib1) 
    1349                      WRITE(ctmp2,*) ' ==========  Not allowed yet' 
    1350                      WRITE(ctmp3,*) '             Crossing problem with West segment: ',npckgw(ib1), &  
    1351                         &                                        ' and South segment: ',npckgs(ib2) 
    1352                      CALL ctl_stop( ' ', ctmp1, ctmp2, ctmp3, ' ' ) 
     1242                     WRITE(ctmp2,*) ' Not allowed yet' 
     1243                     WRITE(ctmp3,*) ' Crossing problem with West segment: ',npckgw(ib1), &  
     1244                        &                            ' and South segment: ',npckgs(ib2) 
     1245                     CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) 
    13531246                  ELSE 
    1354                      WRITE(ctmp1,*) ' E R R O R : Check South and West Open boundary indices' 
    1355                      WRITE(ctmp2,*) ' ==========  Crossing problem with West segment: ',npckgw(ib1) , & 
    1356                         &                                         ' and South segment: ',npckgs(ib2) 
    1357                      CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 
     1247                     WRITE(ctmp1,*) ' Check South and West Open boundary indices' 
     1248                     WRITE(ctmp2,*) ' Crossing problem with West segment: ',npckgw(ib1) , & 
     1249                        &                            ' and South segment: ',npckgs(ib2) 
     1250                     CALL ctl_stop( ctmp1, ctmp2 ) 
    13581251                  END IF 
    13591252               END IF 
    … …  
    13771270                     icorns(ib2,2) = npckge(ib1) 
    13781271                  ELSEIF ((jpjeft(ib1)==jpjsob(ib2)).AND.(jpisdt(ib2)==jpieob(ib1)+1)) THEN 
    1379                      WRITE(ctmp1,*) ' E R R O R : Found an acute open boundary corner at point (i,j)= ', & 
     1272                     WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & 
    13801273                        &                                     jpisdt(ib2), jpjeft(ib1) 
    1381                      WRITE(ctmp2,*) ' ==========  Not allowed yet' 
    1382                      WRITE(ctmp3,*) '             Crossing problem with East segment: ',npckge(ib1), & 
    1383                         &                                        ' and South segment: ',npckgs(ib2) 
    1384                      CALL ctl_stop( ' ', ctmp1, ctmp2, ctmp3, ' ' ) 
     1274                     WRITE(ctmp2,*) ' Not allowed yet' 
     1275                     WRITE(ctmp3,*) ' Crossing problem with East segment: ',npckge(ib1), & 
     1276                        &                            ' and South segment: ',npckgs(ib2) 
     1277                     CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) 
    13851278                  ELSE 
    1386                      WRITE(ctmp1,*) ' E R R O R : Check South and East Open boundary indices' 
    1387                      WRITE(ctmp2,*) ' ==========  Crossing problem with East segment: ',npckge(ib1), & 
    1388                      &                                           ' and South segment: ',npckgs(ib2) 
    1389                      CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 
     1279                     WRITE(ctmp1,*) ' Check South and East Open boundary indices' 
     1280                     WRITE(ctmp2,*) ' Crossing problem with East segment: ',npckge(ib1), & 
     1281                     &                               ' and South segment: ',npckgs(ib2) 
     1282                     CALL ctl_stop( ctmp1, ctmp2 ) 
    13901283                  END IF 
    13911284               END IF 
    … …  
    14091302                     icornn(ib2,1) = npckgw(ib1) 
    14101303                  ELSEIF ((jpjwdt(ib1)==jpjnob(ib2)+1).AND.(jpinft(ib2)==jpiwob(ib1))) THEN 
    1411                      WRITE(ctmp1,*) ' E R R O R : Found an acute open boundary corner at point (i,j)= ', & 
     1304                     WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & 
    14121305                     &                                     jpinft(ib2), jpjwdt(ib1) 
    1413                      WRITE(ctmp2,*) ' ==========  Not allowed yet' 
    1414                      WRITE(ctmp3,*) '             Crossing problem with West segment: ',npckgw(ib1), & 
    1415                      &                                                    ' and North segment: ',npckgn(ib2) 
    1416                      CALL ctl_stop( ' ', ctmp1, ctmp2, ctmp3, ' ' ) 
     1306                     WRITE(ctmp2,*) ' Not allowed yet' 
     1307                     WRITE(ctmp3,*) ' Crossing problem with West segment: ',npckgw(ib1), & 
     1308                     &                               ' and North segment: ',npckgn(ib2) 
     1309                     CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) 
    14171310                  ELSE 
    1418                      WRITE(ctmp1,*) ' E R R O R : Check North and West Open boundary indices' 
    1419                      WRITE(ctmp2,*) ' ==========  Crossing problem with West segment: ',npckgw(ib1), & 
    1420                      &                                                    ' and North segment: ',npckgn(ib2) 
    1421                      CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 
     1311                     WRITE(ctmp1,*) ' Check North and West Open boundary indices' 
     1312                     WRITE(ctmp2,*) ' Crossing problem with West segment: ',npckgw(ib1), & 
     1313                     &                               ' and North segment: ',npckgn(ib2) 
     1314                     CALL ctl_stop( ctmp1, ctmp2 ) 
    14221315                  END IF 
    14231316               END IF 
    … …  
    14411334                     icornn(ib2,2) = npckge(ib1) 
    14421335                  ELSEIF ((jpjedt(ib1)==jpjnob(ib2)+1).AND.(jpindt(ib2)==jpieob(ib1)+1)) THEN 
    1443                      WRITE(ctmp1,*) ' E R R O R : Found an acute open boundary corner at point (i,j)= ', & 
     1336                     WRITE(ctmp1,*) ' Found an acute open boundary corner at point (i,j)= ', & 
    14441337                     &                                     jpindt(ib2), jpjedt(ib1) 
    1445                      WRITE(ctmp2,*) ' ==========  Not allowed yet' 
    1446                      WRITE(ctmp3,*) '             Crossing problem with East segment: ',npckge(ib1), & 
    1447                      &                                           ' and North segment: ',npckgn(ib2) 
    1448                      CALL ctl_stop( ' ', ctmp1, ctmp2, ctmp3, ' ' ) 
     1338                     WRITE(ctmp2,*) ' Not allowed yet' 
     1339                     WRITE(ctmp3,*) ' Crossing problem with East segment: ',npckge(ib1), & 
     1340                     &                               ' and North segment: ',npckgn(ib2) 
     1341                     CALL ctl_stop( ctmp1, ctmp2, ctmp3 ) 
    14491342                  ELSE 
    1450                      WRITE(ctmp1,*) ' E R R O R : Check North and East Open boundary indices' 
    1451                      WRITE(ctmp2,*) ' ==========  Crossing problem with East segment: ',npckge(ib1), & 
    1452                      &                                           ' and North segment: ',npckgn(ib2) 
    1453                      CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 
     1343                     WRITE(ctmp1,*) ' Check North and East Open boundary indices' 
     1344                     WRITE(ctmp2,*) ' Crossing problem with East segment: ',npckge(ib1), & 
     1345                     &                               ' and North segment: ',npckgn(ib2) 
     1346                     CALL ctl_stop( ctmp1, ctmp2 ) 
    14541347                  END IF 
    14551348               END IF 
    … …  
    14771370         IF (ztestmask(1)==1) THEN  
    14781371            IF (icornw(ib,1)==0) THEN 
    1479                WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgw(ib) 
    1480                WRITE(ctmp2,*) ' ==========  does not start on land or on a corner'                                                   
    1481                CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 
     1372               WRITE(ctmp1,*) ' Open boundary segment ', npckgw(ib) 
     1373               CALL ctl_stop( ctmp1, ' does not start on land or on a corner' ) 
    14821374            ELSE 
    14831375               ! This is a corner 
    … …  
    14891381         IF (ztestmask(2)==1) THEN 
    14901382            IF (icornw(ib,2)==0) THEN 
    1491                WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgw(ib) 
    1492                WRITE(ctmp2,*) ' ==========  does not end on land or on a corner'                                                   
    1493                CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 
     1383               WRITE(ctmp1,*) ' Open boundary segment ', npckgw(ib) 
     1384               CALL ctl_stop( ' ', ctmp1, ' does not end on land or on a corner' ) 
    14941385            ELSE 
    14951386               ! This is a corner 
    … …  
    15171408         IF (ztestmask(1)==1) THEN 
    15181409            IF (icorne(ib,1)==0) THEN 
    1519                WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckge(ib) 
    1520                WRITE(ctmp2,*) ' ==========  does not start on land or on a corner'                                                   
    1521                CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 
     1410               WRITE(ctmp1,*) ' Open boundary segment ', npckge(ib) 
     1411               CALL ctl_stop( ctmp1, ' does not start on land or on a corner' ) 
    15221412            ELSE 
    15231413               ! This is a corner 
    … …  
    15291419         IF (ztestmask(2)==1) THEN 
    15301420            IF (icorne(ib,2)==0) THEN 
    1531                WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckge(ib) 
    1532                WRITE(ctmp2,*) ' ==========  does not end on land or on a corner'                                                   
    1533                CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 
     1421               WRITE(ctmp1,*) ' Open boundary segment ', npckge(ib) 
     1422               CALL ctl_stop( ctmp1, ' does not end on land or on a corner' ) 
    15341423            ELSE 
    15351424               ! This is a corner 
    … …  
    15561445 
    15571446         IF ((ztestmask(1)==1).AND.(icorns(ib,1)==0)) THEN 
    1558             WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgs(ib) 
    1559             WRITE(ctmp2,*) ' ==========  does not start on land or on a corner'                                                   
    1560             CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 
     1447            WRITE(ctmp1,*) ' Open boundary segment ', npckgs(ib) 
     1448            CALL ctl_stop( ctmp1, ' does not start on land or on a corner' ) 
    15611449         ENDIF 
    15621450         IF ((ztestmask(2)==1).AND.(icorns(ib,2)==0)) THEN 
    1563             WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgs(ib) 
    1564             WRITE(ctmp2,*) ' ==========  does not end on land or on a corner'                                                   
    1565             CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 
     1451            WRITE(ctmp1,*) ' Open boundary segment ', npckgs(ib) 
     1452            CALL ctl_stop( ctmp1, ' does not end on land or on a corner' ) 
    15661453         ENDIF 
    15671454      END DO 
    … …  
    15821469 
    15831470         IF ((ztestmask(1)==1).AND.(icornn(ib,1)==0)) THEN 
    1584             WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgn(ib) 
    1585             WRITE(ctmp2,*) ' ==========  does not start on land'                                                   
    1586             CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 
     1471            WRITE(ctmp1,*) ' Open boundary segment ', npckgn(ib) 
     1472            CALL ctl_stop( ctmp1, ' does not start on land' ) 
    15871473         ENDIF 
    15881474         IF ((ztestmask(2)==1).AND.(icornn(ib,2)==0)) THEN 
    1589             WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgn(ib) 
    1590             WRITE(ctmp2,*) ' ==========  does not end on land'                                                   
    1591             CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 
     1475            WRITE(ctmp1,*) ' Open boundary segment ', npckgn(ib) 
     1476            CALL ctl_stop( ctmp1, ' does not end on land' ) 
    15921477         ENDIF 
    15931478      END DO 
    … …  
    16021487   END SUBROUTINE bdy_ctl_seg 
    16031488 
    1604  
     1489    
     1490   SUBROUTINE bdy_coords_seg( nbidta, nbjdta, nbrdta )  
     1491      !!---------------------------------------------------------------------- 
     1492      !!                 ***  ROUTINE bdy_coords_seg  *** 
     1493      !! 
     1494      !! ** Purpose :  build nbidta, nbidta, nbrdta for bdy built with segments 
     1495      !! 
     1496      !! ** Method  :   
     1497      !! 
     1498      !!---------------------------------------------------------------------- 
     1499      INTEGER, DIMENSION(:,:,:), intent(  out)  ::   nbidta, nbjdta, nbrdta   ! Index arrays: i and j indices of bdy dta 
     1500      !! 
     1501      INTEGER  ::   ii, ij, ir, iseg 
     1502      INTEGER  ::   igrd         ! grid type (t=1, u=2, v=3) 
     1503      INTEGER  ::   icount       !  
     1504      INTEGER  ::   ib_bdy       ! bdy number 
     1505      !!---------------------------------------------------------------------- 
     1506 
     1507      ! East 
     1508      !----- 
     1509      DO iseg = 1, nbdysege 
     1510         ib_bdy = npckge(iseg) 
     1511         ! 
     1512         ! ------------ T points ------------- 
     1513         igrd=1 
     1514         icount=0 
     1515         DO ir = 1, nn_rimwidth(ib_bdy) 
     1516            DO ij = jpjedt(iseg), jpjeft(iseg) 
     1517               icount = icount + 1 
     1518               nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir 
     1519               nbjdta(icount, igrd, ib_bdy) = ij 
     1520               nbrdta(icount, igrd, ib_bdy) = ir 
     1521            ENDDO 
     1522         ENDDO 
     1523         ! 
     1524         ! ------------ U points ------------- 
     1525         igrd=2 
     1526         icount=0 
     1527         DO ir = 1, nn_rimwidth(ib_bdy) 
     1528            DO ij = jpjedt(iseg), jpjeft(iseg) 
     1529               icount = icount + 1 
     1530               nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 1 - ir 
     1531               nbjdta(icount, igrd, ib_bdy) = ij 
     1532               nbrdta(icount, igrd, ib_bdy) = ir 
     1533            ENDDO 
     1534         ENDDO 
     1535         ! 
     1536         ! ------------ V points ------------- 
     1537         igrd=3 
     1538         icount=0 
     1539         DO ir = 1, nn_rimwidth(ib_bdy) 
     1540            !            DO ij = jpjedt(iseg), jpjeft(iseg) - 1 
     1541            DO ij = jpjedt(iseg), jpjeft(iseg) 
     1542               icount = icount + 1 
     1543               nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir 
     1544               nbjdta(icount, igrd, ib_bdy) = ij 
     1545               nbrdta(icount, igrd, ib_bdy) = ir 
     1546            ENDDO 
     1547            nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
     1548            nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
     1549         ENDDO 
     1550      ENDDO 
     1551      ! 
     1552      ! West 
     1553      !----- 
     1554      DO iseg = 1, nbdysegw 
     1555         ib_bdy = npckgw(iseg) 
     1556         ! 
     1557         ! ------------ T points ------------- 
     1558         igrd=1 
     1559         icount=0 
     1560         DO ir = 1, nn_rimwidth(ib_bdy) 
     1561            DO ij = jpjwdt(iseg), jpjwft(iseg) 
     1562               icount = icount + 1 
     1563               nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 
     1564               nbjdta(icount, igrd, ib_bdy) = ij 
     1565               nbrdta(icount, igrd, ib_bdy) = ir 
     1566            ENDDO 
     1567         ENDDO 
     1568         ! 
     1569         ! ------------ U points ------------- 
     1570         igrd=2 
     1571         icount=0 
     1572         DO ir = 1, nn_rimwidth(ib_bdy) 
     1573            DO ij = jpjwdt(iseg), jpjwft(iseg) 
     1574               icount = icount + 1 
     1575               nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 
     1576               nbjdta(icount, igrd, ib_bdy) = ij 
     1577               nbrdta(icount, igrd, ib_bdy) = ir 
     1578            ENDDO 
     1579         ENDDO 
     1580         ! 
     1581         ! ------------ V points ------------- 
     1582         igrd=3 
     1583         icount=0 
     1584         DO ir = 1, nn_rimwidth(ib_bdy) 
     1585            !            DO ij = jpjwdt(iseg), jpjwft(iseg) - 1 
     1586            DO ij = jpjwdt(iseg), jpjwft(iseg) 
     1587               icount = icount + 1 
     1588               nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 
     1589               nbjdta(icount, igrd, ib_bdy) = ij 
     1590               nbrdta(icount, igrd, ib_bdy) = ir 
     1591            ENDDO 
     1592            nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
     1593            nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
     1594         ENDDO 
     1595      ENDDO 
     1596      ! 
     1597      ! North 
     1598      !----- 
     1599      DO iseg = 1, nbdysegn 
     1600         ib_bdy = npckgn(iseg) 
     1601         ! 
     1602         ! ------------ T points ------------- 
     1603         igrd=1 
     1604         icount=0 
     1605         DO ir = 1, nn_rimwidth(ib_bdy) 
     1606            DO ii = jpindt(iseg), jpinft(iseg) 
     1607               icount = icount + 1 
     1608               nbidta(icount, igrd, ib_bdy) = ii 
     1609               nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir  
     1610               nbrdta(icount, igrd, ib_bdy) = ir 
     1611            ENDDO 
     1612         ENDDO 
     1613         ! 
     1614         ! ------------ U points ------------- 
     1615         igrd=2 
     1616         icount=0 
     1617         DO ir = 1, nn_rimwidth(ib_bdy) 
     1618            !            DO ii = jpindt(iseg), jpinft(iseg) - 1 
     1619            DO ii = jpindt(iseg), jpinft(iseg) 
     1620               icount = icount + 1 
     1621               nbidta(icount, igrd, ib_bdy) = ii 
     1622               nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir 
     1623               nbrdta(icount, igrd, ib_bdy) = ir 
     1624            ENDDO 
     1625            nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
     1626            nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
     1627         ENDDO 
     1628         ! 
     1629         ! ------------ V points ------------- 
     1630         igrd=3 
     1631         icount=0 
     1632         DO ir = 1, nn_rimwidth(ib_bdy) 
     1633            DO ii = jpindt(iseg), jpinft(iseg) 
     1634               icount = icount + 1 
     1635               nbidta(icount, igrd, ib_bdy) = ii 
     1636               nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 1 - ir 
     1637               nbrdta(icount, igrd, ib_bdy) = ir 
     1638            ENDDO 
     1639         ENDDO 
     1640      ENDDO 
     1641      ! 
     1642      ! South 
     1643      !----- 
     1644      DO iseg = 1, nbdysegs 
     1645         ib_bdy = npckgs(iseg) 
     1646         ! 
     1647         ! ------------ T points ------------- 
     1648         igrd=1 
     1649         icount=0 
     1650         DO ir = 1, nn_rimwidth(ib_bdy) 
     1651            DO ii = jpisdt(iseg), jpisft(iseg) 
     1652               icount = icount + 1 
     1653               nbidta(icount, igrd, ib_bdy) = ii 
     1654               nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 
     1655               nbrdta(icount, igrd, ib_bdy) = ir 
     1656            ENDDO 
     1657         ENDDO 
     1658         ! 
     1659         ! ------------ U points ------------- 
     1660         igrd=2 
     1661         icount=0 
     1662         DO ir = 1, nn_rimwidth(ib_bdy) 
     1663            !            DO ii = jpisdt(iseg), jpisft(iseg) - 1 
     1664            DO ii = jpisdt(iseg), jpisft(iseg) 
     1665               icount = icount + 1 
     1666               nbidta(icount, igrd, ib_bdy) = ii 
     1667               nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 
     1668               nbrdta(icount, igrd, ib_bdy) = ir 
     1669            ENDDO 
     1670            nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
     1671            nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
     1672         ENDDO 
     1673         ! 
     1674         ! ------------ V points ------------- 
     1675         igrd=3 
     1676         icount=0 
     1677         DO ir = 1, nn_rimwidth(ib_bdy) 
     1678            DO ii = jpisdt(iseg), jpisft(iseg) 
     1679               icount = icount + 1 
     1680               nbidta(icount, igrd, ib_bdy) = ii 
     1681               nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 
     1682               nbrdta(icount, igrd, ib_bdy) = ir 
     1683            ENDDO 
     1684         ENDDO 
     1685      ENDDO 
     1686 
     1687       
     1688   END SUBROUTINE bdy_coords_seg 
     1689    
     1690    
    16051691   SUBROUTINE bdy_ctl_corn( ib1, ib2 ) 
    16061692      !!---------------------------------------------------------------------- 
    … …  
    16281714      ! 
    16291715      IF( itest>0 ) THEN 
    1630          WRITE(ctmp1,*) ' E R R O R : Segments ', ib1, 'and ', ib2 
    1631          WRITE(ctmp2,*) ' ==========  have different open bdy schemes'                                                   
    1632          CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 
     1716         WRITE(ctmp1,*) ' Segments ', ib1, 'and ', ib2 
     1717         CALL ctl_stop( ctmp1, ' have different open bdy schemes' ) 
    16331718      ENDIF 
    16341719      ! 
    16351720   END SUBROUTINE bdy_ctl_corn 
    16361721 
     1722 
     1723   SUBROUTINE bdy_meshwri() 
     1724      !!---------------------------------------------------------------------- 
     1725      !!                 ***  ROUTINE bdy_meshwri  *** 
     1726      !!          
     1727      !! ** Purpose :   write netcdf file with nbr, flagu, flagv, ntreat for T, U  
     1728      !!                and V points in 2D arrays for easier visualisation/control 
     1729      !! 
     1730      !! ** Method  :   use iom_rstput as in domwri.F 
     1731      !!----------------------------------------------------------------------       
     1732      INTEGER  ::   ib_bdy, ii, ij, igrd, ib     ! dummy loop indices 
     1733      INTEGER  ::   inum                                   !   -       - 
     1734      REAL(wp), POINTER, DIMENSION(:,:)     ::   zmask                   ! pointer to 2D mask fields 
     1735      REAL(wp)         , DIMENSION(jpi,jpj) ::   ztmp 
     1736      CHARACTER(LEN=1) , DIMENSION(jpbgrd)  ::   cgrid 
     1737      !!----------------------------------------------------------------------       
     1738      cgrid = (/'t','u','v'/) 
     1739      CALL iom_open( 'bdy_mesh', inum, ldwrt = .TRUE. ) 
     1740      DO igrd = 1, jpbgrd 
     1741         SELECT CASE( igrd ) 
     1742         CASE( 1 )   ;   zmask => tmask(:,:,1) 
     1743         CASE( 2 )   ;   zmask => umask(:,:,1) 
     1744         CASE( 3 )   ;   zmask => vmask(:,:,1) 
     1745         END SELECT 
     1746         ztmp(:,:) = zmask(:,:) 
     1747         DO ib_bdy = 1, nb_bdy 
     1748            DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd)      ! nbr deined for all rims 
     1749               ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     1750               ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     1751               ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%nbr(ib,igrd), wp) + 10. 
     1752               IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) 
     1753            END DO 
     1754         END DO 
     1755         CALL iom_rstput( 0, 0, inum, 'bdy_nbr_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) 
     1756         ztmp(:,:) = zmask(:,:) 
     1757         DO ib_bdy = 1, nb_bdy 
     1758            DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd)   ! flagu defined only for rims 0 and 1 
     1759               ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     1760               ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     1761               ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%flagu(ib,igrd), wp) + 10. 
     1762               IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) 
     1763            END DO 
     1764         END DO 
     1765         CALL iom_rstput( 0, 0, inum, 'flagu_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) 
     1766         ztmp(:,:) = zmask(:,:) 
     1767         DO ib_bdy = 1, nb_bdy 
     1768            DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd)   ! flagv defined only for rims 0 and 1 
     1769               ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     1770               ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     1771               ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%flagv(ib,igrd), wp) + 10. 
     1772               IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) 
     1773            END DO 
     1774         END DO 
     1775         CALL iom_rstput( 0, 0, inum, 'flagv_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) 
     1776         ztmp(:,:) = zmask(:,:) 
     1777         DO ib_bdy = 1, nb_bdy 
     1778            DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd)   ! ntreat defined only for rims 0 and 1 
     1779               ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
     1780               ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     1781               ztmp(ii,ij) = REAL(idx_bdy(ib_bdy)%ntreat(ib,igrd), wp) + 10. 
     1782               IF( zmask(ii,ij) == 0. ) ztmp(ii,ij) = - ztmp(ii,ij) 
     1783            END DO 
     1784         END DO 
     1785         CALL iom_rstput( 0, 0, inum, 'ntreat_'//cgrid(igrd), ztmp(:,:), ktype = jp_i4 ) 
     1786      END DO 
     1787      CALL iom_close( inum ) 
     1788 
     1789   END SUBROUTINE bdy_meshwri 
     1790    
    16371791   !!================================================================================= 
    16381792END MODULE bdyini 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/BDY/bdylib.F90

    r10957 r11822  
    1515   USE bdy_oce        ! ocean open boundary conditions 
    1616   USE phycst         ! physical constants 
     17   USE bdyini 
    1718   ! 
    1819   USE in_out_manager ! 
    … …  
    7576      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   phia  ! tracer trend 
    7677      !! 
    77       REAL(wp) ::   zwgt           ! boundary weight 
    7878      INTEGER  ::   ib, ik, igrd   ! dummy loop indices 
    7979      INTEGER  ::   ii, ij         ! 2D addresses 
    … …  
    9292 
    9393 
    94    SUBROUTINE bdy_orl( idx, phib, phia, dta, ll_npo ) 
     94   SUBROUTINE bdy_orl( idx, phib, phia, dta, lrim0, ll_npo ) 
    9595      !!---------------------------------------------------------------------- 
    9696      !!                 ***  SUBROUTINE bdy_orl  *** 
    … …  
    104104      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   phib  ! before tracer field 
    105105      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   phia  ! tracer trend 
     106      LOGICAL                 , OPTIONAL,  INTENT(in) ::   lrim0   ! indicate if rim 0 is treated 
    106107      LOGICAL,                             INTENT(in) ::   ll_npo  ! switch for NPO version 
    107108      !! 
    … …  
    111112      igrd = 1                       ! Everything is at T-points here 
    112113      ! 
    113       CALL bdy_orlanski_3d( idx, igrd, phib(:,:,:), phia(:,:,:), dta, ll_npo ) 
     114      CALL bdy_orlanski_3d( idx, igrd, phib(:,:,:), phia(:,:,:), dta, lrim0, ll_npo ) 
    114115      ! 
    115116   END SUBROUTINE bdy_orl 
    116117 
    117118 
    118    SUBROUTINE bdy_orlanski_2d( idx, igrd, phib, phia, phi_ext, ll_npo ) 
     119   SUBROUTINE bdy_orlanski_2d( idx, igrd, phib, phia, phi_ext, lrim0, ll_npo ) 
    119120      !!---------------------------------------------------------------------- 
    120121      !!                 ***  SUBROUTINE bdy_orlanski_2d  *** 
    … …  
    132133      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   phia     ! model after 2D field (to be updated) 
    133134      REAL(wp), DIMENSION(:)  , INTENT(in   ) ::   phi_ext  ! external forcing data 
     135      LOGICAL, OPTIONAL,        INTENT(in   ) ::   lrim0    ! indicate if rim 0 is treated 
    134136      LOGICAL ,                 INTENT(in   ) ::   ll_npo   ! switch for NPO version 
    135137      ! 
    … …  
    140142      INTEGER  ::   ii_offset, ij_offset                   ! offsets for mask indices 
    141143      INTEGER  ::   flagu, flagv                           ! short cuts 
     144      INTEGER  ::   ibeg, iend                             ! length of rim to be treated (rim 0 or rim 1 or both) 
    142145      REAL(wp) ::   zmask_x, zmask_y1, zmask_y2 
    143146      REAL(wp) ::   zex1, zex2, zey, zey1, zey2 
    … …  
    146149      REAL(wp) ::   zdy_1, zdy_2, zsign_ups 
    147150      REAL(wp), PARAMETER :: zepsilon = 1.e-30                 ! local small value 
    148       REAL(wp), POINTER, DIMENSION(:,:)          :: pmask      ! land/sea mask for field 
    149       REAL(wp), POINTER, DIMENSION(:,:)          :: pmask_xdif ! land/sea mask for x-derivatives 
    150       REAL(wp), POINTER, DIMENSION(:,:)          :: pmask_ydif ! land/sea mask for y-derivatives 
     151      REAL(wp), POINTER, DIMENSION(:,:)          :: zmask      ! land/sea mask for field 
     152      REAL(wp), POINTER, DIMENSION(:,:)          :: zmask_xdif ! land/sea mask for x-derivatives 
     153      REAL(wp), POINTER, DIMENSION(:,:)          :: zmask_ydif ! land/sea mask for y-derivatives 
    151154      REAL(wp), POINTER, DIMENSION(:,:)          :: pe_xdif    ! scale factors for x-derivatives 
    152155      REAL(wp), POINTER, DIMENSION(:,:)          :: pe_ydif    ! scale factors for y-derivatives 
    … …  
    159162      SELECT CASE(igrd) 
    160163         CASE(1) 
    161             pmask      => tmask(:,:,1) 
    162             pmask_xdif => umask(:,:,1) 
    163             pmask_ydif => vmask(:,:,1) 
     164            zmask      => tmask(:,:,1) 
     165            zmask_xdif => umask(:,:,1) 
     166            zmask_ydif => vmask(:,:,1) 
    164167            pe_xdif    => e1u(:,:) 
    165168            pe_ydif    => e2v(:,:) 
    … …  
    167170            ij_offset = 0 
    168171         CASE(2) 
    169             pmask      => umask(:,:,1) 
    170             pmask_xdif => tmask(:,:,1) 
    171             pmask_ydif => fmask(:,:,1) 
     172            zmask      => umask(:,:,1) 
     173            zmask_xdif => tmask(:,:,1) 
     174            zmask_ydif => fmask(:,:,1) 
    172175            pe_xdif    => e1t(:,:) 
    173176            pe_ydif    => e2f(:,:) 
    … …  
    175178            ij_offset = 0 
    176179         CASE(3) 
    177             pmask      => vmask(:,:,1) 
    178             pmask_xdif => fmask(:,:,1) 
    179             pmask_ydif => tmask(:,:,1) 
     180            zmask      => vmask(:,:,1) 
     181            zmask_xdif => fmask(:,:,1) 
     182            zmask_ydif => tmask(:,:,1) 
    180183            pe_xdif    => e1f(:,:) 
    181184            pe_ydif    => e2t(:,:) 
    … …  
    185188      END SELECT 
    186189      ! 
    187       DO jb = 1, idx%nblenrim(igrd) 
     190      IF( PRESENT(lrim0) ) THEN 
     191         IF( lrim0 ) THEN   ;   ibeg = 1                       ;   iend = idx%nblenrim0(igrd)   ! rim 0 
     192         ELSE               ;   ibeg = idx%nblenrim0(igrd)+1   ;   iend = idx%nblenrim(igrd)    ! rim 1 
     193         END IF 
     194      ELSE                  ;   ibeg = 1                       ;   iend = idx%nblenrim(igrd)    ! both 
     195      END IF 
     196      ! 
     197      DO jb = ibeg, iend 
    188198         ii  = idx%nbi(jb,igrd) 
    189199         ij  = idx%nbj(jb,igrd)  
     200         IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj )   CYCLE 
    190201         flagu = int( idx%flagu(jb,igrd) ) 
    191202         flagv = int( idx%flagv(jb,igrd) ) 
    … …  
    203214         ! 
    204215         ! Calculate scale factors for calculation of spatial derivatives.         
    205          zex1 = ( abs(iibm1-iibm2) * pe_xdif(iibm1+ii_offset,ijbm1          )         & 
    206         &       + abs(ijbm1-ijbm2) * pe_ydif(iibm1          ,ijbm1+ij_offset) )  
    207          zex2 = ( abs(iibm1-iibm2) * pe_xdif(iibm2+ii_offset,ijbm2          )         & 
    208         &       + abs(ijbm1-ijbm2) * pe_ydif(iibm2          ,ijbm2+ij_offset) )  
    209          zey1 = ( (iibm1-iibm1jm1) * pe_xdif(iibm1jm1+ii_offset,ijbm1jm1          )  &  
     216         zex1 = ( abs(iibm1-iibm2) * pe_xdif(iibm1   +ii_offset,ijbm1             )   & 
     217        &       + abs(ijbm1-ijbm2) * pe_ydif(iibm1             ,ijbm1   +ij_offset) )  
     218         zex2 = ( abs(iibm1-iibm2) * pe_xdif(iibm2   +ii_offset,ijbm2             )   & 
     219        &       + abs(ijbm1-ijbm2) * pe_ydif(iibm2             ,ijbm2   +ij_offset) )  
     220         zey1 = ( (iibm1-iibm1jm1) * pe_xdif(iibm1jm1+ii_offset,ijbm1jm1          )   &  
    210221        &      +  (ijbm1-ijbm1jm1) * pe_ydif(iibm1jm1          ,ijbm1jm1+ij_offset) )  
    211          zey2 = ( (iibm1jp1-iibm1) * pe_xdif(iibm1+ii_offset,ijbm1)                  & 
    212         &      +  (ijbm1jp1-ijbm1) * pe_ydif(iibm1          ,ijbm1+ij_offset) )  
     222         zey2 = ( (iibm1jp1-iibm1) * pe_xdif(iibm1   +ii_offset,ijbm1             )   & 
     223        &      +  (ijbm1jp1-ijbm1) * pe_ydif(iibm1             ,ijbm1   +ij_offset) )  
    213224         ! make sure scale factors are nonzero 
    214225         if( zey1 .lt. rsmall ) zey1 = zey2 
    … …  
    217228         zey1 = max(zey1,rsmall); zey2 = max(zey2,rsmall);  
    218229         ! 
    219          ! Calculate masks for calculation of spatial derivatives.         
    220          zmask_x = ( abs(iibm1-iibm2) * pmask_xdif(iibm2+ii_offset,ijbm2          )         & 
    221         &          + abs(ijbm1-ijbm2) * pmask_ydif(iibm2          ,ijbm2+ij_offset) )  
    222          zmask_y1 = ( (iibm1-iibm1jm1) * pmask_xdif(iibm1jm1+ii_offset,ijbm1jm1          )  &  
    223         &          +  (ijbm1-ijbm1jm1) * pmask_ydif(iibm1jm1          ,ijbm1jm1+ij_offset) )  
    224          zmask_y2 = ( (iibm1jp1-iibm1) * pmask_xdif(iibm1+ii_offset,ijbm1)                  & 
    225         &          +  (ijbm1jp1-ijbm1) * pmask_ydif(iibm1          ,ijbm1+ij_offset) )  
     230         ! Calculate masks for calculation of spatial derivatives. 
     231         zmask_x  = ( abs(iibm1-iibm2) * zmask_xdif(iibm2   +ii_offset,ijbm2               )   & 
     232        &           + abs(ijbm1-ijbm2) * zmask_ydif(iibm2             ,ijbm2   +ij_offset) )  
     233         zmask_y1 = ( (iibm1-iibm1jm1) * zmask_xdif(iibm1jm1+ii_offset,ijbm1jm1            )   &  
     234        &          +  (ijbm1-ijbm1jm1) * zmask_ydif(iibm1jm1          ,ijbm1jm1+ij_offset) )  
     235         zmask_y2 = ( (iibm1jp1-iibm1) * zmask_xdif(iibm1   +ii_offset,ijbm1               )   & 
     236        &          +  (ijbm1jp1-ijbm1) * zmask_ydif(iibm1             ,ijbm1   +ij_offset) )  
    226237 
    227238         ! Calculation of terms required for both versions of the scheme.  
    … …  
    231242         ! Note no rdt factor in expression for zdt because it cancels in the expressions for  
    232243         ! zrx and zry. 
    233          zdt = phia(iibm1,ijbm1) - phib(iibm1,ijbm1) 
    234          zdx = ( ( phia(iibm1,ijbm1) - phia(iibm2,ijbm2) ) / zex2 ) * zmask_x  
     244         zdt   =     phia(iibm1   ,ijbm1   ) - phib(iibm1   ,ijbm1   ) 
     245         zdx   = ( ( phia(iibm1   ,ijbm1   ) - phia(iibm2   ,ijbm2   ) ) / zex2 ) * zmask_x  
    235246         zdy_1 = ( ( phib(iibm1   ,ijbm1   ) - phib(iibm1jm1,ijbm1jm1) ) / zey1 ) * zmask_y1     
    236          zdy_2 = ( ( phib(iibm1jp1,ijbm1jp1) - phib(iibm1   ,ijbm1)    ) / zey2 ) * zmask_y2  
     247         zdy_2 = ( ( phib(iibm1jp1,ijbm1jp1) - phib(iibm1   ,ijbm1   ) ) / zey2 ) * zmask_y2  
    237248         zdy_centred = 0.5 * ( zdy_1 + zdy_2 ) 
    238249!!$         zdy_centred = phib(iibm1jp1,ijbm1jp1) - phib(iibm1jm1,ijbm1jm1) 
    … …  
    265276           &                    + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) / ( 1. + zrx )  
    266277         end if 
    267          phia(ii,ij) = phia(ii,ij) * pmask(ii,ij) 
     278         phia(ii,ij) = phia(ii,ij) * zmask(ii,ij) 
    268279      END DO 
    269280      ! 
    … …  
    271282 
    272283 
    273    SUBROUTINE bdy_orlanski_3d( idx, igrd, phib, phia, phi_ext, ll_npo ) 
     284   SUBROUTINE bdy_orlanski_3d( idx, igrd, phib, phia, phi_ext, lrim0, ll_npo ) 
    274285      !!---------------------------------------------------------------------- 
    275286      !!                 ***  SUBROUTINE bdy_orlanski_3d  *** 
    … …  
    287298      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   phia     ! model after 3D field (to be updated) 
    288299      REAL(wp), DIMENSION(:,:)  , INTENT(in   ) ::   phi_ext  ! external forcing data 
     300      LOGICAL, OPTIONAL,          INTENT(in   ) ::   lrim0    ! indicate if rim 0 is treated 
    289301      LOGICAL ,                   INTENT(in   ) ::   ll_npo   ! switch for NPO version 
    290302      ! 
    … …  
    295307      INTEGER  ::   ii_offset, ij_offset                   ! offsets for mask indices 
    296308      INTEGER  ::   flagu, flagv                           ! short cuts 
     309      INTEGER  ::   ibeg, iend                             ! length of rim to be treated (rim 0 or rim 1 or both) 
    297310      REAL(wp) ::   zmask_x, zmask_y1, zmask_y2 
    298311      REAL(wp) ::   zex1, zex2, zey, zey1, zey2 
    … …  
    301314      REAL(wp) ::   zdy_1, zdy_2,  zsign_ups 
    302315      REAL(wp), PARAMETER :: zepsilon = 1.e-30                 ! local small value 
    303       REAL(wp), POINTER, DIMENSION(:,:,:)        :: pmask      ! land/sea mask for field 
    304       REAL(wp), POINTER, DIMENSION(:,:,:)        :: pmask_xdif ! land/sea mask for x-derivatives 
    305       REAL(wp), POINTER, DIMENSION(:,:,:)        :: pmask_ydif ! land/sea mask for y-derivatives 
     316      REAL(wp), POINTER, DIMENSION(:,:,:)        :: zmask      ! land/sea mask for field 
     317      REAL(wp), POINTER, DIMENSION(:,:,:)        :: zmask_xdif ! land/sea mask for x-derivatives 
     318      REAL(wp), POINTER, DIMENSION(:,:,:)        :: zmask_ydif ! land/sea mask for y-derivatives 
    306319      REAL(wp), POINTER, DIMENSION(:,:)          :: pe_xdif    ! scale factors for x-derivatives 
    307320      REAL(wp), POINTER, DIMENSION(:,:)          :: pe_ydif    ! scale factors for y-derivatives 
    … …  
    314327      SELECT CASE(igrd) 
    315328         CASE(1) 
    316             pmask      => tmask(:,:,:) 
    317             pmask_xdif => umask(:,:,:) 
    318             pmask_ydif => vmask(:,:,:) 
     329            zmask      => tmask(:,:,:) 
     330            zmask_xdif => umask(:,:,:) 
     331            zmask_ydif => vmask(:,:,:) 
    319332            pe_xdif    => e1u(:,:) 
    320333            pe_ydif    => e2v(:,:) 
    … …  
    322335            ij_offset = 0 
    323336         CASE(2) 
    324             pmask      => umask(:,:,:) 
    325             pmask_xdif => tmask(:,:,:) 
    326             pmask_ydif => fmask(:,:,:) 
     337            zmask      => umask(:,:,:) 
     338            zmask_xdif => tmask(:,:,:) 
     339            zmask_ydif => fmask(:,:,:) 
    327340            pe_xdif    => e1t(:,:) 
    328341            pe_ydif    => e2f(:,:) 
    … …  
    330343            ij_offset = 0 
    331344         CASE(3) 
    332             pmask      => vmask(:,:,:) 
    333             pmask_xdif => fmask(:,:,:) 
    334             pmask_ydif => tmask(:,:,:) 
     345            zmask      => vmask(:,:,:) 
     346            zmask_xdif => fmask(:,:,:) 
     347            zmask_ydif => tmask(:,:,:) 
    335348            pe_xdif    => e1f(:,:) 
    336349            pe_ydif    => e2t(:,:) 
    … …  
    339352         CASE DEFAULT ;   CALL ctl_stop( 'unrecognised value for igrd in bdy_orlanksi_2d' ) 
    340353      END SELECT 
    341  
     354      ! 
     355      IF( PRESENT(lrim0) ) THEN 
     356         IF( lrim0 ) THEN   ;   ibeg = 1                       ;   iend = idx%nblenrim0(igrd)   ! rim 0 
     357         ELSE               ;   ibeg = idx%nblenrim0(igrd)+1   ;   iend = idx%nblenrim(igrd)    ! rim 1 
     358         END IF 
     359      ELSE                  ;   ibeg = 1                       ;   iend = idx%nblenrim(igrd)    ! both 
     360      END IF 
     361      ! 
    342362      DO jk = 1, jpk 
    343363         !             
    344          DO jb = 1, idx%nblenrim(igrd) 
     364         DO jb = ibeg, iend 
    345365            ii  = idx%nbi(jb,igrd) 
    346366            ij  = idx%nbj(jb,igrd)  
     367            IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj )   CYCLE 
    347368            flagu = int( idx%flagu(jb,igrd) ) 
    348369            flagv = int( idx%flagv(jb,igrd) ) 
    … …  
    360381            ! 
    361382            ! Calculate scale factors for calculation of spatial derivatives.         
    362             zex1 = ( abs(iibm1-iibm2) * pe_xdif(iibm1+ii_offset,ijbm1          )         & 
    363            &       + abs(ijbm1-ijbm2) * pe_ydif(iibm1          ,ijbm1+ij_offset) )  
    364             zex2 = ( abs(iibm1-iibm2) * pe_xdif(iibm2+ii_offset,ijbm2          )         & 
    365            &       + abs(ijbm1-ijbm2) * pe_ydif(iibm2          ,ijbm2+ij_offset) )  
    366             zey1 = ( (iibm1-iibm1jm1) * pe_xdif(iibm1jm1+ii_offset,ijbm1jm1          )  &  
     383            zex1 = ( abs(iibm1-iibm2) * pe_xdif(iibm1   +ii_offset,ijbm1             )   & 
     384           &       + abs(ijbm1-ijbm2) * pe_ydif(iibm1             ,ijbm1+ij_offset   ) )  
     385            zex2 = ( abs(iibm1-iibm2) * pe_xdif(iibm2   +ii_offset,ijbm2             )   & 
     386           &       + abs(ijbm1-ijbm2) * pe_ydif(iibm2             ,ijbm2+ij_offset   ) )  
     387            zey1 = ( (iibm1-iibm1jm1) * pe_xdif(iibm1jm1+ii_offset,ijbm1jm1          )   &  
    367388           &      +  (ijbm1-ijbm1jm1) * pe_ydif(iibm1jm1          ,ijbm1jm1+ij_offset) )  
    368             zey2 = ( (iibm1jp1-iibm1) * pe_xdif(iibm1+ii_offset,ijbm1)                  & 
    369            &      +  (ijbm1jp1-ijbm1) * pe_ydif(iibm1          ,ijbm1+ij_offset) )  
     389            zey2 = ( (iibm1jp1-iibm1) * pe_xdif(iibm1   +ii_offset,ijbm1             )   & 
     390           &      +  (ijbm1jp1-ijbm1) * pe_ydif(iibm1             ,ijbm1+ij_offset   ) )  
    370391            ! make sure scale factors are nonzero 
    371392            if( zey1 .lt. rsmall ) zey1 = zey2 
    … …  
    375396            ! 
    376397            ! Calculate masks for calculation of spatial derivatives.         
    377             zmask_x = ( abs(iibm1-iibm2) * pmask_xdif(iibm2+ii_offset,ijbm2          ,jk)          & 
    378            &          + abs(ijbm1-ijbm2) * pmask_ydif(iibm2          ,ijbm2+ij_offset,jk) )  
    379             zmask_y1 = ( (iibm1-iibm1jm1) * pmask_xdif(iibm1jm1+ii_offset,ijbm1jm1          ,jk)   &  
    380            &          +  (ijbm1-ijbm1jm1) * pmask_ydif(iibm1jm1          ,ijbm1jm1+ij_offset,jk) )  
    381             zmask_y2 = ( (iibm1jp1-iibm1) * pmask_xdif(iibm1+ii_offset,ijbm1          ,jk)         & 
    382            &          +  (ijbm1jp1-ijbm1) * pmask_ydif(iibm1          ,ijbm1+ij_offset,jk) )  
     398            zmask_x  = ( abs(iibm1-iibm2) * zmask_xdif(iibm2   +ii_offset,ijbm2             ,jk)   & 
     399           &           + abs(ijbm1-ijbm2) * zmask_ydif(iibm2             ,ijbm2   +ij_offset,jk) )  
     400            zmask_y1 = ( (iibm1-iibm1jm1) * zmask_xdif(iibm1jm1+ii_offset,ijbm1jm1          ,jk)   &  
     401           &          +  (ijbm1-ijbm1jm1) * zmask_ydif(iibm1jm1          ,ijbm1jm1+ij_offset,jk) )  
     402            zmask_y2 = ( (iibm1jp1-iibm1) * zmask_xdif(iibm1   +ii_offset,ijbm1             ,jk)   & 
     403           &          +  (ijbm1jp1-ijbm1) * zmask_ydif(iibm1             ,ijbm1   +ij_offset,jk) )  
    383404            ! 
    384405            ! Calculate normal (zrx) and tangential (zry) components of radiation velocities. 
    … …  
    386407            ! Centred derivative is calculated as average of "left" and "right" derivatives for  
    387408            ! this reason.  
    388             zdt = phia(iibm1,ijbm1,jk) - phib(iibm1,ijbm1,jk) 
    389             zdx = ( ( phia(iibm1,ijbm1,jk) - phia(iibm2,ijbm2,jk) ) / zex2 ) * zmask_x                   
     409            zdt   =     phia(iibm1   ,ijbm1   ,jk) - phib(iibm1   ,ijbm1   ,jk) 
     410            zdx   = ( ( phia(iibm1   ,ijbm1   ,jk) - phia(iibm2   ,ijbm2   ,jk) ) / zex2 ) * zmask_x                   
    390411            zdy_1 = ( ( phib(iibm1   ,ijbm1   ,jk) - phib(iibm1jm1,ijbm1jm1,jk) ) / zey1 ) * zmask_y1   
    391412            zdy_2 = ( ( phib(iibm1jp1,ijbm1jp1,jk) - phib(iibm1   ,ijbm1   ,jk) ) / zey2 ) * zmask_y2       
    … …  
    421442              &                       + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) / ( 1. + zrx )  
    422443            end if 
    423             phia(ii,ij,jk) = phia(ii,ij,jk) * pmask(ii,ij,jk) 
     444            phia(ii,ij,jk) = phia(ii,ij,jk) * zmask(ii,ij,jk) 
    424445         END DO 
    425446         ! 
    … …  
    428449   END SUBROUTINE bdy_orlanski_3d 
    429450 
    430    SUBROUTINE bdy_nmn( idx, igrd, phia ) 
     451   SUBROUTINE bdy_nmn( idx, igrd, phia, lrim0 ) 
    431452      !!---------------------------------------------------------------------- 
    432453      !!                 ***  SUBROUTINE bdy_nmn  *** 
    … …  
    434455      !! ** Purpose : Duplicate the value at open boundaries, zero gradient. 
    435456      !!  
    436       !!---------------------------------------------------------------------- 
    437       INTEGER,                    INTENT(in)     ::   igrd     ! grid index 
    438       REAL(wp), DIMENSION(:,:,:), INTENT(inout)  ::   phia     ! model after 3D field (to be updated) 
    439       TYPE(OBC_INDEX), INTENT(in) ::   idx  ! OBC indices 
     457      !! 
     458      !! ** Method  : - take the average of free ocean neighbours 
     459      !! 
     460      !!      ___   !   |_____|   !   ___|    !   __|x o   !   |_   _|     ! |       
     461      !!   __|x     !      x      !     x o   !      o     !     |_|       ! |x o    
     462      !!      o     !      o      !     o     !            !    o x o      ! |x_x_  
     463      !!                                                   !      o       
     464      !!---------------------------------------------------------------------- 
     465      INTEGER,                    INTENT(in   )  ::   igrd     ! grid index 
     466      REAL(wp), DIMENSION(:,:,:), INTENT(inout)  ::   phia     ! model after 3D field (to be updated), must be masked 
     467      TYPE(OBC_INDEX),            INTENT(in   )  ::   idx      ! OBC indices 
     468      LOGICAL, OPTIONAL,          INTENT(in   )  ::   lrim0    ! indicate if rim 0 is treated 
    440469      !!  
    441       REAL(wp) ::   zcoef, zcoef1, zcoef2 
    442       REAL(wp), POINTER, DIMENSION(:,:,:)        :: pmask      ! land/sea mask for field 
    443       REAL(wp), POINTER, DIMENSION(:,:)        :: bdypmask      ! land/sea mask for field 
     470      REAL(wp) ::   zweight 
     471      REAL(wp), POINTER, DIMENSION(:,:,:)      :: zmask         ! land/sea mask for field 
    444472      INTEGER  ::   ib, ik   ! dummy loop indices 
    445       INTEGER  ::   ii, ij, ip, jp   ! 2D addresses 
    446       !!---------------------------------------------------------------------- 
     473      INTEGER  ::   ii, ij   ! 2D addresses 
     474      INTEGER  ::   ipkm1    ! size of phia third dimension minus 1 
     475      INTEGER  ::   ibeg, iend                          ! length of rim to be treated (rim 0 or rim 1 or both) 
     476      INTEGER  ::   ii1, ii2, ii3, ij1, ij2, ij3, itreat 
     477      !!---------------------------------------------------------------------- 
     478      ! 
     479      ipkm1 = MAX( SIZE(phia,3) - 1, 1 )  
    447480      ! 
    448481      SELECT CASE(igrd) 
    449          CASE(1) 
    450             pmask => tmask(:,:,:) 
    451             bdypmask => bdytmask(:,:) 
    452          CASE(2) 
    453             pmask => umask(:,:,:) 
    454             bdypmask => bdyumask(:,:) 
    455          CASE(3) 
    456             pmask => vmask(:,:,:) 
    457             bdypmask => bdyvmask(:,:) 
     482         CASE(1)   ;   zmask => tmask(:,:,:) 
     483         CASE(2)   ;   zmask => umask(:,:,:) 
     484         CASE(3)   ;   zmask => vmask(:,:,:) 
    458485         CASE DEFAULT ;   CALL ctl_stop( 'unrecognised value for igrd in bdy_nmn' ) 
    459486      END SELECT 
    460       DO ib = 1, idx%nblenrim(igrd) 
     487      ! 
     488      IF( PRESENT(lrim0) ) THEN 
     489         IF( lrim0 ) THEN   ;   ibeg = 1                       ;   iend = idx%nblenrim0(igrd)   ! rim 0 
     490         ELSE               ;   ibeg = idx%nblenrim0(igrd)+1   ;   iend = idx%nblenrim(igrd)    ! rim 1 
     491         END IF 
     492      ELSE                  ;   ibeg = 1                       ;   iend = idx%nblenrim(igrd)    ! both 
     493      END IF 
     494      ! 
     495      DO ib = ibeg, iend 
    461496         ii = idx%nbi(ib,igrd) 
    462497         ij = idx%nbj(ib,igrd) 
    463          DO ik = 1, jpkm1 
    464             ! search the sense of the gradient 
    465             zcoef1 = bdypmask(ii-1,ij  )*pmask(ii-1,ij,ik) +  bdypmask(ii+1,ij  )*pmask(ii+1,ij,ik) 
    466             zcoef2 = bdypmask(ii  ,ij-1)*pmask(ii,ij-1,ik) +  bdypmask(ii  ,ij+1)*pmask(ii,ij+1,ik) 
    467             IF ( nint(zcoef1+zcoef2) == 0) THEN 
    468                ! corner **** we probably only want to set the tangentail component for the dynamics here 
    469                zcoef = pmask(ii-1,ij,ik) + pmask(ii+1,ij,ik) +  pmask(ii,ij-1,ik) +  pmask(ii,ij+1,ik) 
    470                IF (zcoef > .5_wp) THEN ! Only set none isolated points. 
    471                  phia(ii,ij,ik) = phia(ii-1,ij  ,ik) * pmask(ii-1,ij  ,ik) + & 
    472                    &              phia(ii+1,ij  ,ik) * pmask(ii+1,ij  ,ik) + & 
    473                    &              phia(ii  ,ij-1,ik) * pmask(ii  ,ij-1,ik) + & 
    474                    &              phia(ii  ,ij+1,ik) * pmask(ii  ,ij+1,ik) 
    475                  phia(ii,ij,ik) = ( phia(ii,ij,ik) / zcoef ) * pmask(ii,ij,ik) 
    476                ELSE 
    477                  phia(ii,ij,ik) = phia(ii,ij  ,ik) * pmask(ii,ij  ,ik) 
    478                ENDIF 
    479             ELSEIF ( nint(zcoef1+zcoef2) == 2) THEN 
    480                ! oblique corner **** we probably only want to set the normal component for the dynamics here 
    481                zcoef = pmask(ii-1,ij,ik)*bdypmask(ii-1,ij  ) + pmask(ii+1,ij,ik)*bdypmask(ii+1,ij  ) + & 
    482                    &   pmask(ii,ij-1,ik)*bdypmask(ii,ij -1 ) +  pmask(ii,ij+1,ik)*bdypmask(ii,ij+1  ) 
    483                phia(ii,ij,ik) = phia(ii-1,ij  ,ik) * pmask(ii-1,ij  ,ik)*bdypmask(ii-1,ij  ) + & 
    484                    &            phia(ii+1,ij  ,ik) * pmask(ii+1,ij  ,ik)*bdypmask(ii+1,ij  )  + & 
    485                    &            phia(ii  ,ij-1,ik) * pmask(ii  ,ij-1,ik)*bdypmask(ii,ij -1 ) + & 
    486                    &            phia(ii  ,ij+1,ik) * pmask(ii  ,ij+1,ik)*bdypmask(ii,ij+1  ) 
    487   
    488                phia(ii,ij,ik) = ( phia(ii,ij,ik) / MAX(1._wp, zcoef) ) * pmask(ii,ij,ik) 
    489             ELSE 
    490                ip = nint(bdypmask(ii+1,ij  )*pmask(ii+1,ij,ik) - bdypmask(ii-1,ij  )*pmask(ii-1,ij,ik)) 
    491                jp = nint(bdypmask(ii  ,ij+1)*pmask(ii,ij+1,ik) - bdypmask(ii  ,ij-1)*pmask(ii,ij-1,ik)) 
    492                phia(ii,ij,ik) = phia(ii+ip,ij+jp,ik) * pmask(ii+ip,ij+jp,ik) 
    493             ENDIF 
    494          END DO 
     498         itreat = idx%ntreat(ib,igrd) 
     499         CALL find_neib( ii, ij, itreat, ii1, ij1, ii2, ij2, ii3, ij3 )   ! find free ocean neighbours 
     500         SELECT CASE( itreat ) 
     501         CASE( 1:8 ) 
     502            IF( ii1 < 1 .OR. ii1 > jpi .OR. ij1 < 1 .OR. ij1 > jpj )   CYCLE 
     503            DO ik = 1, ipkm1 
     504               IF( zmask(ii1,ij1,ik) /= 0. )   phia(ii,ij,ik) = phia(ii1,ij1,ik)   
     505            END DO 
     506         CASE( 9:12 ) 
     507            IF( ii1 < 1 .OR. ii1 > jpi .OR. ij1 < 1 .OR. ij1 > jpj )   CYCLE 
     508            IF( ii2 < 1 .OR. ii2 > jpi .OR. ij2 < 1 .OR. ij2 > jpj )   CYCLE 
     509            DO ik = 1, ipkm1 
     510               zweight = zmask(ii1,ij1,ik) + zmask(ii2,ij2,ik) 
     511               IF( zweight /= 0. )   phia(ii,ij,ik) = ( phia(ii1,ij1,ik) + phia(ii2,ij2,ik) ) / zweight 
     512            END DO 
     513         CASE( 13:16 ) 
     514            IF( ii1 < 1 .OR. ii1 > jpi .OR. ij1 < 1 .OR. ij1 > jpj )   CYCLE 
     515            IF( ii2 < 1 .OR. ii2 > jpi .OR. ij2 < 1 .OR. ij2 > jpj )   CYCLE 
     516            IF( ii3 < 1 .OR. ii3 > jpi .OR. ij3 < 1 .OR. ij3 > jpj )   CYCLE 
     517            DO ik = 1, ipkm1 
     518               zweight = zmask(ii1,ij1,ik) + zmask(ii2,ij2,ik) + zmask(ii3,ij3,ik) 
     519               IF( zweight /= 0. )   phia(ii,ij,ik) = ( phia(ii1,ij1,ik) + phia(ii2,ij2,ik) + phia(ii3,ij3,ik) ) / zweight 
     520            END DO 
     521         END SELECT 
    495522      END DO 
    496523      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/BDY/bdytides.F90

    r10068 r11822  
    7070      INTEGER                                   ::   inum, igrd 
    7171      INTEGER, DIMENSION(3)                     ::   ilen0       !: length of boundary data (from OBC arrays) 
    72       INTEGER, POINTER, DIMENSION(:)            ::   nblen, nblenrim     ! short cuts 
    7372      INTEGER                                   ::   ios                 ! Local integer output status for namelist read 
    7473      CHARACTER(len=80)                         ::   clfile              !: full file name for tidal input file  
    … …  
    7776      !! 
    7877      TYPE(TIDES_DATA),  POINTER                ::   td                  !: local short cut    
    79       TYPE(MAP_POINTER), DIMENSION(jpbgrd)      ::   ibmap_ptr           !: array of pointers to nbmap 
    8078      !! 
    8179      NAMELIST/nambdy_tide/filtide, ln_bdytide_2ddta, ln_bdytide_conj 
    8280      !!---------------------------------------------------------------------- 
    8381      ! 
    84       IF (nb_bdy>0) THEN 
    85          IF(lwp) WRITE(numout,*) 
    86          IF(lwp) WRITE(numout,*) 'bdytide_init : initialization of tidal harmonic forcing at open boundaries' 
    87          IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 
    88       ENDIF 
     82      IF(lwp) WRITE(numout,*) 
     83      IF(lwp) WRITE(numout,*) 'bdytide_init : initialization of tidal harmonic forcing at open boundaries' 
     84      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 
    8985 
    9086      REWIND(numnam_cfg) 
    … …  
    9490            ! 
    9591            td => tides(ib_bdy) 
    96             nblen => idx_bdy(ib_bdy)%nblen 
    97             nblenrim => idx_bdy(ib_bdy)%nblenrim 
    9892 
    9993            ! Namelist nambdy_tide : tidal harmonic forcing at open boundaries 
    10094            filtide(:) = '' 
    10195 
     96            REWIND( numnam_ref ) 
     97            READ  ( numnam_ref, nambdy_tide, IOSTAT = ios, ERR = 901) 
     98901         IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambdy_tide in reference namelist' ) 
    10299            ! Don't REWIND here - may need to read more than one of these namelists.  
    103             READ  ( numnam_ref, nambdy_tide, IOSTAT = ios, ERR = 901) 
    104 901         IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambdy_tide in reference namelist', lwp ) 
    105100            READ  ( numnam_cfg, nambdy_tide, IOSTAT = ios, ERR = 902 ) 
    106 902         IF( ios >  0 )   CALL ctl_nam ( ios , 'nambdy_tide in configuration namelist', lwp ) 
     101902         IF( ios >  0 )   CALL ctl_nam ( ios , 'nambdy_tide in configuration namelist' ) 
    107102            IF(lwm) WRITE ( numond, nambdy_tide ) 
    108103            !                                               ! Parameter control and print 
    … …  
    125120            ! JC: If FRS scheme is used, we assume that tidal is needed over the whole 
    126121            ! relaxation area       
    127             IF( cn_dyn2d(ib_bdy) == 'frs' ) THEN   ;   ilen0(:) = nblen   (:) 
    128             ELSE                                   ;   ilen0(:) = nblenrim(:) 
     122            IF( cn_dyn2d(ib_bdy) == 'frs' ) THEN   ;   ilen0(:) = idx_bdy(ib_bdy)%nblen   (:) 
     123            ELSE                                   ;   ilen0(:) = idx_bdy(ib_bdy)%nblenrim(:) 
    129124            ENDIF 
    130125 
    … …  
    161156                     ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    162157                     ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     158                     IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj )  CYCLE   ! to remove? 
    163159                     td%ssh0(ib,itide,1) = ztr(ii,ij) 
    164160                     td%ssh0(ib,itide,2) = zti(ii,ij) 
    … …  
    177173                     ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    178174                     ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     175                     IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj )  CYCLE   ! to remove? 
    179176                     td%u0(ib,itide,1) = ztr(ii,ij) 
    180177                     td%u0(ib,itide,2) = zti(ii,ij) 
    … …  
    193190                     ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    194191                     ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
     192                     IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj )  CYCLE   ! to remove? 
    195193                     td%v0(ib,itide,1) = ztr(ii,ij) 
    196194                     td%v0(ib,itide,2) = zti(ii,ij) 
    … …  
    207205               ALLOCATE( dta_read( MAXVAL(ilen0(1:3)), 1, 1 ) ) 
    208206               ! 
    209                ! Set map structure 
    210                ibmap_ptr(1)%ptr => idx_bdy(ib_bdy)%nbmap(:,1)   ;   ibmap_ptr(1)%ll_unstruc = ln_coords_file(ib_bdy) 
    211                ibmap_ptr(2)%ptr => idx_bdy(ib_bdy)%nbmap(:,2)   ;   ibmap_ptr(2)%ll_unstruc = ln_coords_file(ib_bdy) 
    212                ibmap_ptr(3)%ptr => idx_bdy(ib_bdy)%nbmap(:,3)   ;   ibmap_ptr(3)%ll_unstruc = ln_coords_file(ib_bdy) 
    213  
    214207               ! Open files and read in tidal forcing data 
    215208               ! ----------------------------------------- 
    … …  
    219212                  clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_T.nc' 
    220213                  CALL iom_open( clfile, inum ) 
    221                   CALL fld_map( inum, 'z1' , dta_read(1:ilen0(1),1:1,1:1) , 1,  ibmap_ptr(1) ) 
     214                  CALL fld_map( inum, 'z1' , dta_read(1:ilen0(1),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) ) 
    222215                  td%ssh0(:,itide,1) = dta_read(1:ilen0(1),1,1) 
    223                   CALL fld_map( inum, 'z2' , dta_read(1:ilen0(1),1:1,1:1) , 1,  ibmap_ptr(1) ) 
     216                  CALL fld_map( inum, 'z2' , dta_read(1:ilen0(1),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) ) 
    224217                  td%ssh0(:,itide,2) = dta_read(1:ilen0(1),1,1) 
    225218                  CALL iom_close( inum ) 
    … …  
    227220                  clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_U.nc' 
    228221                  CALL iom_open( clfile, inum ) 
    229                   CALL fld_map( inum, 'u1' , dta_read(1:ilen0(2),1:1,1:1) , 1, ibmap_ptr(2) ) 
     222                  CALL fld_map( inum, 'u1' , dta_read(1:ilen0(2),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,2) ) 
    230223                  td%u0(:,itide,1) = dta_read(1:ilen0(2),1,1) 
    231                   CALL fld_map( inum, 'u2' , dta_read(1:ilen0(2),1:1,1:1) , 1, ibmap_ptr(2) ) 
     224                  CALL fld_map( inum, 'u2' , dta_read(1:ilen0(2),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,2) ) 
    232225                  td%u0(:,itide,2) = dta_read(1:ilen0(2),1,1) 
    233226                  CALL iom_close( inum ) 
    … …  
    235228                  clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_V.nc' 
    236229                  CALL iom_open( clfile, inum ) 
    237                   CALL fld_map( inum, 'v1' , dta_read(1:ilen0(3),1:1,1:1) , 1, ibmap_ptr(3) ) 
     230                  CALL fld_map( inum, 'v1' , dta_read(1:ilen0(3),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,3) ) 
    238231                  td%v0(:,itide,1) = dta_read(1:ilen0(3),1,1) 
    239                   CALL fld_map( inum, 'v2' , dta_read(1:ilen0(3),1:1,1:1) , 1, ibmap_ptr(3) ) 
     232                  CALL fld_map( inum, 'v2' , dta_read(1:ilen0(3),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,3) ) 
    240233                  td%v0(:,itide,2) = dta_read(1:ilen0(3),1,1) 
    241234                  CALL iom_close( inum ) 
    … …  
    269262 
    270263 
    271    SUBROUTINE bdytide_update( kt, idx, dta, td, jit, time_offset ) 
     264   SUBROUTINE bdytide_update( kt, idx, dta, td, kit, kt_offset ) 
    272265      !!---------------------------------------------------------------------- 
    273266      !!                 ***  SUBROUTINE bdytide_update  *** 
    … …  
    280273      TYPE(OBC_DATA)   , INTENT(inout) ::   dta         ! OBC external data 
    281274      TYPE(TIDES_DATA) , INTENT(inout) ::   td          ! tidal harmonics data 
    282       INTEGER, OPTIONAL, INTENT(in   ) ::   jit         ! Barotropic timestep counter (for timesplitting option) 
    283       INTEGER, OPTIONAL, INTENT(in   ) ::   time_offset ! time offset in units of timesteps. NB. if jit 
     275      INTEGER, OPTIONAL, INTENT(in   ) ::   kit         ! Barotropic timestep counter (for timesplitting option) 
     276      INTEGER, OPTIONAL, INTENT(in   ) ::   kt_offset   ! time offset in units of timesteps. NB. if kit 
    284277      !                                                 ! is present then units = subcycle timesteps. 
    285       !                                                 ! time_offset = 0  => get data at "now"    time level 
    286       !                                                 ! time_offset = -1 => get data at "before" time level 
    287       !                                                 ! time_offset = +1 => get data at "after"  time level 
     278      !                                                 ! kt_offset = 0  => get data at "now"    time level 
     279      !                                                 ! kt_offset = -1 => get data at "before" time level 
     280      !                                                 ! kt_offset = +1 => get data at "after"  time level 
    288281      !                                                 ! etc. 
    289282      ! 
    … …  
    300293 
    301294      zflag=1 
    302       IF ( PRESENT(jit) ) THEN 
    303         IF ( jit /= 1 ) zflag=0 
     295      IF ( PRESENT(kit) ) THEN 
     296        IF ( kit /= 1 ) zflag=0 
    304297      ENDIF 
    305298 
    … …  
    320313 
    321314      time_add = 0 
    322       IF( PRESENT(time_offset) ) THEN 
    323          time_add = time_offset 
     315      IF( PRESENT(kt_offset) ) THEN 
     316         time_add = kt_offset 
    324317      ENDIF 
    325318          
    326       IF( PRESENT(jit) ) THEN   
    327          z_arg = ((kt-kt_tide) * rdt + (jit+0.5_wp*(time_add-1)) * rdt / REAL(nn_baro,wp) ) 
     319      IF( PRESENT(kit) ) THEN   
     320         z_arg = ((kt-kt_tide) * rdt + (kit+0.5_wp*(time_add-1)) * rdt / REAL(nn_baro,wp) ) 
    328321      ELSE                               
    329322         z_arg = ((kt-kt_tide)+time_add) * rdt 
    … …  
    358351 
    359352 
    360    SUBROUTINE bdy_dta_tides( kt, kit, time_offset ) 
     353   SUBROUTINE bdy_dta_tides( kt, kit, kt_offset ) 
    361354      !!---------------------------------------------------------------------- 
    362355      !!                 ***  SUBROUTINE bdy_dta_tides  *** 
    … …  
    367360      INTEGER,           INTENT(in) ::   kt          ! Main timestep counter 
    368361      INTEGER, OPTIONAL, INTENT(in) ::   kit         ! Barotropic timestep counter (for timesplitting option) 
    369       INTEGER, OPTIONAL, INTENT(in) ::   time_offset ! time offset in units of timesteps. NB. if kit 
     362      INTEGER, OPTIONAL, INTENT(in) ::   kt_offset  ! time offset in units of timesteps. NB. if kit 
    370363      !                                              ! is present then units = subcycle timesteps. 
    371       !                                              ! time_offset = 0  => get data at "now"    time level 
    372       !                                              ! time_offset = -1 => get data at "before" time level 
    373       !                                              ! time_offset = +1 => get data at "after"  time level 
     364      !                                              ! kt_offset = 0  => get data at "now"    time level 
     365      !                                              ! kt_offset = -1 => get data at "before" time level 
     366      !                                              ! kt_offset = +1 => get data at "after"  time level 
    374367      !                                              ! etc. 
    375368      ! 
    … …  
    386379 
    387380      time_add = 0 
    388       IF( PRESENT(time_offset) ) THEN 
    389          time_add = time_offset 
     381      IF( PRESENT(kt_offset) ) THEN 
     382         time_add = kt_offset 
    390383      ENDIF 
    391384       
    … …  
    432425            ! If time splitting, initialize arrays from slow varying open boundary data: 
    433426            IF ( PRESENT(kit) ) THEN            
    434                IF ( dta_bdy(ib_bdy)%ll_ssh ) dta_bdy(ib_bdy)%ssh(1:ilen0(1)) = dta_bdy_s(ib_bdy)%ssh(1:ilen0(1)) 
    435                IF ( dta_bdy(ib_bdy)%ll_u2d ) dta_bdy(ib_bdy)%u2d(1:ilen0(2)) = dta_bdy_s(ib_bdy)%u2d(1:ilen0(2)) 
    436                IF ( dta_bdy(ib_bdy)%ll_v2d ) dta_bdy(ib_bdy)%v2d(1:ilen0(3)) = dta_bdy_s(ib_bdy)%v2d(1:ilen0(3)) 
     427               IF ( dta_bdy(ib_bdy)%lneed_ssh  ) dta_bdy(ib_bdy)%ssh(1:ilen0(1)) = dta_bdy_s(ib_bdy)%ssh(1:ilen0(1)) 
     428               IF ( dta_bdy(ib_bdy)%lneed_dyn2d ) dta_bdy(ib_bdy)%u2d(1:ilen0(2)) = dta_bdy_s(ib_bdy)%u2d(1:ilen0(2)) 
     429               IF ( dta_bdy(ib_bdy)%lneed_dyn2d ) dta_bdy(ib_bdy)%v2d(1:ilen0(3)) = dta_bdy_s(ib_bdy)%v2d(1:ilen0(3)) 
    437430            ENDIF 
    438431            ! 
    … …  
    444437               z_sist = zramp * SIN( z_sarg ) 
    445438               ! 
    446                IF ( dta_bdy(ib_bdy)%ll_ssh ) THEN 
     439               IF ( dta_bdy(ib_bdy)%lneed_ssh ) THEN 
    447440                  igrd=1                              ! SSH on tracer grid 
    448441                  DO ib = 1, ilen0(igrd) 
    … …  
    453446               ENDIF 
    454447               ! 
    455                IF ( dta_bdy(ib_bdy)%ll_u2d ) THEN 
     448               IF ( dta_bdy(ib_bdy)%lneed_dyn2d ) THEN 
    456449                  igrd=2                              ! U grid 
    457450                  DO ib = 1, ilen0(igrd) 
    … …  
    460453                        &                        tides(ib_bdy)%u(ib,itide,2)*z_sist ) 
    461454                  END DO 
    462                ENDIF 
    463                ! 
    464                IF ( dta_bdy(ib_bdy)%ll_v2d ) THEN 
    465455                  igrd=3                              ! V grid 
    466456                  DO ib = 1, ilen0(igrd)  

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/BDY/bdytra.F90

    r10957 r11822  
    5151      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts       ! tracer fields 
    5252      ! 
    53       INTEGER                        :: ib_bdy, jn, igrd   ! Loop indices 
    54       TYPE(ztrabdy), DIMENSION(jpts) :: zdta               ! Temporary data structure 
     53      INTEGER                        :: ib_bdy, jn, igrd, ir   ! Loop indeces 
     54      TYPE(ztrabdy), DIMENSION(jpts) :: zdta                   ! Temporary data structure 
     55      LOGICAL                        :: llrim0                 ! indicate if rim 0 is treated 
     56      LOGICAL, DIMENSION(4)          :: llsend1, llrecv1       ! indicate how communications are to be carried out 
    5557      !!---------------------------------------------------------------------- 
    5658      igrd = 1  
    57  
    58       DO ib_bdy=1, nb_bdy 
     59      llsend1(:) = .false.  ;   llrecv1(:) = .false. 
     60      DO ir = 1, 0, -1   ! treat rim 1 before rim 0 
     61         IF( ir == 0 ) THEN   ;   llrim0 = .TRUE. 
     62         ELSE                 ;   llrim0 = .FALSE. 
     63         END IF 
     64         DO ib_bdy=1, nb_bdy 
     65            ! 
     66            zdta(1)%tra => dta_bdy(ib_bdy)%tem 
     67            zdta(2)%tra => dta_bdy(ib_bdy)%sal 
     68            ! 
     69            DO jn = 1, jpts 
     70               ! 
     71               SELECT CASE( TRIM(cn_tra(ib_bdy)) ) 
     72               CASE('none'        )   ;   CYCLE 
     73               CASE('frs'         )   ! treat the whole boundary at once 
     74                  IF( ir == 0 ) CALL bdy_frs ( idx_bdy(ib_bdy),                pts(:,:,:,jn,Kaa), zdta(jn)%tra ) 
     75               CASE('specified'   )   ! treat the whole rim      at once 
     76                  IF( ir == 0 ) CALL bdy_spe ( idx_bdy(ib_bdy),                pts(:,:,:,jn,Kaa), zdta(jn)%tra ) 
     77               CASE('neumann'     )   ;   CALL bdy_nmn ( idx_bdy(ib_bdy), igrd         , pts(:,:,:,jn,Kaa), llrim0 )   ! tsa masked 
     78               CASE('orlanski'    )   ;   CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), & 
     79                    & zdta(jn)%tra, llrim0, ll_npo=.false. ) 
     80               CASE('orlanski_npo')   ;   CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), & 
     81                    & zdta(jn)%tra, llrim0, ll_npo=.true.  ) 
     82               CASE('runoff'      )   ;   CALL bdy_rnf ( idx_bdy(ib_bdy),                pts(:,:,:,jn,Kaa), jn, llrim0 ) 
     83               CASE DEFAULT           ;   CALL ctl_stop( 'bdy_tra : unrecognised option for open boundaries for T and S' ) 
     84               END SELECT 
     85               !  
     86            END DO 
     87         END DO 
    5988         ! 
    60          zdta(1)%tra => dta_bdy(ib_bdy)%tem 
    61          zdta(2)%tra => dta_bdy(ib_bdy)%sal 
     89         IF( nn_hls > 1 .AND. ir == 1 ) CYCLE   ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 
     90         IF( nn_hls == 1 ) THEN   ;   llsend1(:) = .false.   ;   llrecv1(:) = .false.   ;   END IF 
     91         DO ib_bdy=1, nb_bdy 
     92            SELECT CASE( TRIM(cn_tra(ib_bdy)) ) 
     93            CASE('neumann','runoff') 
     94               llsend1(:) = llsend1(:) .OR. lsend_bdyint(ib_bdy,1,:,ir)   ! possibly every direction, T points 
     95               llrecv1(:) = llrecv1(:) .OR. lrecv_bdyint(ib_bdy,1,:,ir)   ! possibly every direction, T points 
     96            CASE('orlanski', 'orlanski_npo') 
     97               llsend1(:) = llsend1(:) .OR. lsend_bdy(ib_bdy,1,:,ir)   ! possibly every direction, T points 
     98               llrecv1(:) = llrecv1(:) .OR. lrecv_bdy(ib_bdy,1,:,ir)   ! possibly every direction, T points 
     99            END SELECT 
     100         END DO 
     101         IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN   ! if need to send/recv in at least one direction 
     102            CALL lbc_lnk( 'bdytra', pts(:,:,:,jn,Kaa), 'T',  1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
     103         END IF 
    62104         ! 
    63          DO jn = 1, jpts 
    64             ! 
    65             SELECT CASE( TRIM(cn_tra(ib_bdy)) ) 
    66             CASE('none'        )   ;   CYCLE 
    67             CASE('frs'         )   ;   CALL bdy_frs ( idx_bdy(ib_bdy),                pts(:,:,:,jn,Kaa), zdta(jn)%tra ) 
    68             CASE('specified'   )   ;   CALL bdy_spe ( idx_bdy(ib_bdy),                pts(:,:,:,jn,Kaa), zdta(jn)%tra ) 
    69             CASE('neumann'     )   ;   CALL bdy_nmn ( idx_bdy(ib_bdy), igrd         , pts(:,:,:,jn,Kaa)               ) 
    70             CASE('orlanski'    )   ;   CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), zdta(jn)%tra, ll_npo=.false. ) 
    71             CASE('orlanski_npo')   ;   CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), zdta(jn)%tra, ll_npo=.true. ) 
    72             CASE('runoff'      )   ;   CALL bdy_rnf ( idx_bdy(ib_bdy),                pts(:,:,:,jn,Kaa),               jn ) 
    73             CASE DEFAULT           ;   CALL ctl_stop( 'bdy_tra : unrecognised option for open boundaries for T and S' ) 
    74             END SELECT 
    75             ! Boundary points should be updated 
    76             CALL lbc_bdy_lnk( 'bdytra', pts(:,:,:,jn,Kaa), 'T', 1., ib_bdy ) 
    77             !  
    78          END DO 
    79       END DO 
     105      END DO   ! ir 
    80106      ! 
    81107   END SUBROUTINE bdy_tra 
    82108 
    83109 
    84    SUBROUTINE bdy_rnf( idx, pt, jpa ) 
     110   SUBROUTINE bdy_rnf( idx, pt, jpa, llrim0 ) 
    85111      !!---------------------------------------------------------------------- 
    86112      !!                 ***  SUBROUTINE bdy_rnf  *** 
    … …  
    91117      !!  
    92118      !!---------------------------------------------------------------------- 
    93       TYPE(OBC_INDEX),                     INTENT(in) ::   idx  ! OBC indices 
    94       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt  ! tracer trend 
    95       INTEGER,                             INTENT(in) ::   jpa  ! TRA index 
     119      TYPE(OBC_INDEX),                     INTENT(in) ::   idx      ! OBC indices 
     120      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt       ! tracer trend 
     121      INTEGER,                             INTENT(in) ::   jpa      ! TRA index 
     122      LOGICAL,                             INTENT(in) ::   llrim0   ! indicate if rim 0 is treated 
    96123      ! 
    97       REAL(wp) ::   zwgt           ! boundary weight 
    98       INTEGER  ::   ib, ik, igrd   ! dummy loop indices 
    99       INTEGER  ::   ii, ij, ip, jp ! 2D addresses 
     124      INTEGER  ::   ib, ii, ij, igrd   ! dummy loop indices 
    100125      !!---------------------------------------------------------------------- 
    101126      ! 
    102127      igrd = 1                       ! Everything is at T-points here 
    103       DO ib = 1, idx%nblenrim(igrd) 
    104          ii = idx%nbi(ib,igrd) 
    105          ij = idx%nbj(ib,igrd) 
    106          DO ik = 1, jpkm1 
    107             ip = bdytmask(ii+1,ij  ) - bdytmask(ii-1,ij  ) 
    108             jp = bdytmask(ii  ,ij+1) - bdytmask(ii  ,ij-1) 
    109             if (jpa == jp_tem) pt(ii,ij,ik) = pt(ii+ip,ij+jp,ik) * tmask(ii,ij,ik) 
    110             if (jpa == jp_sal) pt(ii,ij,ik) =                 0.1 * tmask(ii,ij,ik) 
     128      IF(      jpa == jp_tem ) THEN 
     129         CALL bdy_nmn( idx, igrd, pt, llrim0 ) 
     130      ELSE IF( jpa == jp_sal ) THEN 
     131         IF( .NOT. llrim0 )   RETURN 
     132         DO ib = 1, idx%nblenrim(igrd)   ! if llrim0 then treat the whole rim 
     133            ii = idx%nbi(ib,igrd) 
     134            ij = idx%nbj(ib,igrd) 
     135            pt(ii,ij,1:jpkm1) = 0.1 * tmask(ii,ij,1:jpkm1) 
    111136         END DO 
    112       END DO 
     137      END IF 
    113138      ! 
    114139   END SUBROUTINE bdy_rnf 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/BDY/bdyvol.F90

    r10481 r11822  
    9999            ii = idx%nbi(jb,jgrd) 
    100100            ij = idx%nbj(jb,jgrd) 
     101            IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj )  CYCLE   ! sum : else halo couted twice 
    101102            zubtpecor = zubtpecor + idx%flagu(jb,jgrd) * pua2d(ii,ij) * e2u(ii,ij) * phu(ii,ij) * tmask_i(ii,ij) * tmask_i(ii+1,ij) 
    102103         END DO 
    … …  
    105106            ii = idx%nbi(jb,jgrd) 
    106107            ij = idx%nbj(jb,jgrd) 
     108            IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj )  CYCLE   ! sum : else halo couted twice 
    107109            zubtpecor = zubtpecor + idx%flagv(jb,jgrd) * pva2d(ii,ij) * e1v(ii,ij) * phv(ii,ij) * tmask_i(ii,ij) * tmask_i(ii,ij+1) 
    108110         END DO 
    … …  
    126128               ii = idx%nbi(jb,jgrd) 
    127129               ij = idx%nbj(jb,jgrd) 
     130               !IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj )  CYCLE   ! to remove ? 
    128131               pua2d(ii,ij) = pua2d(ii,ij) - idx%flagu(jb,jgrd) * zubtpecor * tmask_i(ii,ij) * tmask_i(ii+1,ij) 
    129132         END DO 
    … …  
    132135               ii = idx%nbi(jb,jgrd) 
    133136               ij = idx%nbj(jb,jgrd) 
     137               !IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj )  CYCLE   ! to remove ? 
    134138               pva2d(ii,ij) = pva2d(ii,ij) - idx%flagv(jb,jgrd) * zubtpecor * tmask_i(ii,ij) * tmask_i(ii,ij+1) 
    135139         END DO 
    … …  
    139143      ! Check the cumulated transport through unstructured OBC once barotropic velocities corrected 
    140144      ! ------------------------------------------------------ 
    141       IF( MOD( kt, nwrite ) == 0 .AND. ( kc == 1 ) ) THEN 
     145      IF( MOD( kt, nn_write ) == 0 .AND. ( kc == 1 ) ) THEN 
    142146         ! 
    143147         ! compute residual transport across boundary 
    … …  
    150154                  ii = idx%nbi(jb,jgrd) 
    151155                  ij = idx%nbj(jb,jgrd) 
     156                  IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj )  CYCLE 
    152157                  ztranst = ztranst + idx%flagu(jb,jgrd) * pua2d(ii,ij) * e2u(ii,ij) * phu(ii,ij) * tmask_i(ii,ij) * tmask_i(ii+1,ij) 
    153158            END DO 
    … …  
    156161                  ii = idx%nbi(jb,jgrd) 
    157162                  ij = idx%nbj(jb,jgrd) 
     163                  IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj )  CYCLE 
    158164                  ztranst = ztranst + idx%flagv(jb,jgrd) * pva2d(ii,ij) * e1v(ii,ij) * phv(ii,ij) * tmask_i(ii,ij) * tmask_i(ii,ij+1) 
    159165            END DO 
    … …  
    195201            nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 
    196202            nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 
     203            IF( nbi == 1 .OR. nbi == jpi .OR. nbj == 1 .OR. nbj == jpj )  CYCLE 
    197204            zflagu => idx_bdy(ib_bdy)%flagu(ib,igrd) 
    198205            bdy_segs_surf = bdy_segs_surf + phu(nbi, nbj)                              & 
    … …  
    207214            nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 
    208215            nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 
     216            IF( nbi == 1 .OR. nbi == jpi .OR. nbj == 1 .OR. nbj == jpj )  CYCLE 
    209217            zflagv => idx_bdy(ib_bdy)%flagv(ib,igrd) 
    210218            bdy_segs_surf = bdy_segs_surf + phv(nbi, nbj)                              & 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/C1D/c1d.F90

    r10068 r11822  
    5252      REWIND( numnam_ref )              ! Namelist namc1d in reference namelist : Tracer advection scheme 
    5353      READ  ( numnam_ref, namc1d, IOSTAT = ios, ERR = 901) 
    54 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namc1d in reference namelist', lwp ) 
     54901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namc1d in reference namelist' ) 
    5555      ! 
    5656      REWIND( numnam_cfg )              ! Namelist namtra_adv in configuration namelist : Tracer advection scheme 
    5757      READ  ( numnam_cfg, namc1d, IOSTAT = ios, ERR = 902 ) 
    58 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namc1d in configuration namelist', lwp ) 
     58902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namc1d in configuration namelist' ) 
    5959      IF(lwm) WRITE ( numond, namc1d ) 
    6060      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/C1D/dtauvd.F90

    r11001 r11822  
    6262      REWIND( numnam_ref )              ! Namelist namc1d_uvd in reference namelist :  
    6363      READ  ( numnam_ref, namc1d_uvd, IOSTAT = ios, ERR = 901) 
    64 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namc1d_uvd in reference namelist', lwp ) 
     64901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namc1d_uvd in reference namelist' ) 
    6565      ! 
    6666      REWIND( numnam_cfg )              ! Namelist namc1d_uvd in configuration namelist : Parameters of the run 
    6767      READ  ( numnam_cfg, namc1d_uvd, IOSTAT = ios, ERR = 902 ) 
    68 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namc1d_uvd in configuration namelist', lwp ) 
     68902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namc1d_uvd in configuration namelist' ) 
    6969      IF(lwm) WRITE ( numond, namc1d_uvd ) 
    7070 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/C1D/dyndmp.F90

    r11001 r11822  
    8181      REWIND( numnam_ref )              ! Namelist namc1d_dyndmp in reference namelist :  
    8282      READ  ( numnam_ref, namc1d_dyndmp, IOSTAT = ios, ERR = 901) 
    83 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namc1d_dyndmp in reference namelist', lwp ) 
     83901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namc1d_dyndmp in reference namelist' ) 
    8484      REWIND( numnam_cfg )              ! Namelist namc1d_dyndmp in configuration namelist : Parameters of the run 
    8585      READ  ( numnam_cfg, namc1d_dyndmp, IOSTAT = ios, ERR = 902 ) 
    86 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namc1d_dyndmp in configuration namelist', lwp ) 
     86902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namc1d_dyndmp in configuration namelist' ) 
    8787      IF(lwm) WRITE ( numond, namc1d_dyndmp ) 
    8888      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/CRS/README.rst

    r10279 r11822  
    22On line biogeochemistry coarsening 
    33********************************** 
     4 
     5.. todo:: 
     6 
     7 
    48 
    59.. contents:: 
    … …  
    6367                              ! 1, MAX of KZ 
    6468                              ! 2, MIN of KZ 
    65                               ! 3, 10^(MEAN(LOG(KZ))  
    66                               ! 4, MEDIANE of KZ  
     69                              ! 3, 10^(MEAN(LOG(KZ)) 
     70                              ! 4, MEDIANE of KZ 
    6771      ln_crs_wn   = .false.   ! wn coarsened (T) or computed using horizontal divergence ( F ) 
    6872                              !                           ! 
    … …  
    7377  the north-fold lateral boundary condition (ORCA025, ORCA12, ORCA36, ...). 
    7478- ``nn_msh_crs = 1`` will activate the generation of the coarsened grid meshmask. 
    75 - ``nn_crs_kz`` is the operator to coarsen the vertical mixing coefficient.  
     79- ``nn_crs_kz`` is the operator to coarsen the vertical mixing coefficient. 
    7680- ``ln_crs_wn`` 
    7781 
    … …  
    8084  - when ``key_vvl`` is not activated, 
    8185 
    82     - coarsened vertical velocities are computed using horizontal divergence (``ln_crs_wn = .false.``)  
     86    - coarsened vertical velocities are computed using horizontal divergence (``ln_crs_wn = .false.``) 
    8387    - or coarsened vertical velocities are computed with an average operator (``ln_crs_wn = .true.``) 
    8488- ``ln_crs_top = .true.``: should be activated to run BCG model in coarsened space; 
    … …  
    97101 
    98102In the [attachment:iodef.xml iodef.xml]  file, a "nemo" context is defined and 
    99 some variable defined in [attachment:file_def.xml file_def.xml] are writted on the ocean-dynamic grid.   
     103some variable defined in [attachment:file_def.xml file_def.xml] are writted on the ocean-dynamic grid. 
    100104To write variables on the coarsened grid, and in particular the passive tracers, 
    101105a "nemo_crs" context should be defined in [attachment:iodef.xml iodef.xml] and 
    … …  
    111115  interpolated `on-the-fly <http://forge.ipsl.jussieu.fr/nemo/wiki/Users/SetupNewConfiguration/Weight-creator>`_. 
    112116  Example of namelist for PISCES : 
    113    
     117 
    114118   .. code-block:: fortran 
    115119 
    … …  
    134138         rn_trfac(14)  =   1.0e-06  !  -      -      -     - 
    135139         rn_trfac(23)  =   7.6e-06  !  -      -      -     - 
    136        
     140 
    137141         cn_dir        =  './'      !  root directory for the location of the data files 
    138142 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/CRS/crsdom.F90

    r10068 r11822  
    296296      ENDDO 
    297297 
    298       CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0, pval=1.0 ) 
    299       CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0, pval=1.0 ) 
     298      CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0, pfillval=1.0 ) 
     299      CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0, pfillval=1.0 ) 
    300300 
    301301   END SUBROUTINE crs_dom_hgr 
    … …  
    579579                  ENDDO   
    580580               CASE DEFAULT 
    581                     STOP 
     581                  CALL ctl_stop( 'STOP', 'error from crs_dom_ope_3d, you should not be there...' ) 
    582582               END SELECT 
    583583 
    … …  
    17481748       ENDDO 
    17491749                   
    1750        CALL crs_lbc_lnk( p_e3_crs    , cd_type, 1.0, pval=1.0 )   
    1751        CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0, pval=1.0 )   
     1750       CALL crs_lbc_lnk( p_e3_crs    , cd_type, 1.0, pfillval=1.0 )   
     1751       CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0, pfillval=1.0 )   
    17521752       !               
    17531753       ! 
    … …  
    18571857      ENDDO    
    18581858 
    1859       CALL crs_lbc_lnk( p_surf_crs    , cd_type, 1.0, pval=1.0 ) 
    1860       CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0, pval=1.0 ) 
     1859      CALL crs_lbc_lnk( p_surf_crs    , cd_type, 1.0, pfillval=1.0 ) 
     1860      CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0, pfillval=1.0 ) 
    18611861 
    18621862   END SUBROUTINE crs_dom_sfc 
    … …  
    19471947                 
    19481948              CASE DEFAULT 
    1949                  STOP 
     1949                 CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (1) ...' ) 
    19501950           END SELECT 
    19511951           IF( nlcjt_crs(jn) > jpj_crs )     jpj_crs = jpj_crs + 1 
    … …  
    19961996 
    19971997              CASE DEFAULT 
    1998                  STOP 
     1998                 CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (2) ...' ) 
    19991999           END SELECT 
    20002000 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/CRS/crsini.F90

    r10970 r11822  
    8484      REWIND( numnam_ref )              ! Namelist namrun in reference namelist : Parameters of the run 
    8585      READ  ( numnam_ref, namcrs, IOSTAT = ios, ERR = 901) 
    86 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namcrs in reference namelist', lwp ) 
     86901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namcrs in reference namelist' ) 
    8787      REWIND( numnam_cfg )              ! Namelist namrun in configuration namelist : Parameters of the run 
    8888      READ  ( numnam_cfg, namcrs, IOSTAT = ios, ERR = 902 ) 
    89 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namcrs in configuration namelist', lwp ) 
     89902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namcrs in configuration namelist' ) 
    9090      IF(lwm) WRITE ( numond, namcrs ) 
    9191 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/CRS/crslbclnk.F90

    r10425 r11822  
    2727CONTAINS 
    2828 
    29    SUBROUTINE crs_lbc_lnk_3d( pt3d1, cd_type1, psgn, cd_mpp, pval ) 
     29   SUBROUTINE crs_lbc_lnk_3d( pt3d1, cd_type1, psgn, kfillmode, pfillval ) 
    3030      !!--------------------------------------------------------------------- 
    3131      !!                  ***  SUBROUTINE crs_lbc_lnk  *** 
    … …  
    4040      REAL(wp)                                , INTENT(in   ) ::   psgn     ! control of the sign 
    4141      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) ::   pt3d1    ! 3D array on which the lbc is applied 
    42       REAL(wp)                      , OPTIONAL, INTENT(in   ) ::   pval     ! valeur sur les halo 
    43       CHARACTER(len=3)              , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! MPP only (here do nothing) 
     42      INTEGER                     , OPTIONAL  , INTENT(in   ) ::   kfillmode   ! filling method for halo over land (default = cst) 
     43      REAL(wp)                    , OPTIONAL  , INTENT(in   ) ::   pfillval    ! background value (used at closed boundaries) 
    4444      ! 
    4545      LOGICAL  ::   ll_grid_crs 
    46       REAL(wp) ::   zval   ! valeur sur les halo 
    4746      !!---------------------------------------------------------------------- 
    4847      ! 
    4948      ll_grid_crs = ( jpi == jpi_crs ) 
    5049      ! 
    51       IF( PRESENT(pval) ) THEN   ;   zval = pval 
    52       ELSE                       ;   zval = 0._wp 
    53       ENDIF 
    54       ! 
    5550      IF( .NOT.ll_grid_crs )   CALL dom_grid_crs   ! Save the parent grid information  & Switch to coarse grid domain 
    5651      ! 
    57       IF( PRESENT( cd_mpp ) ) THEN   ;   CALL lbc_lnk( 'crslbclnk', pt3d1, cd_type1, psgn, cd_mpp, pval=zval  ) 
    58       ELSE                           ;   CALL lbc_lnk( 'crslbclnk', pt3d1, cd_type1, psgn        , pval=zval  ) 
    59       ENDIF 
     52      CALL lbc_lnk( 'crslbclnk', pt3d1, cd_type1, psgn, kfillmode, pfillval ) 
    6053      ! 
    6154      IF( .NOT.ll_grid_crs )   CALL dom_grid_glo   ! Return to parent grid domain 
    … …  
    6457    
    6558    
    66    SUBROUTINE crs_lbc_lnk_2d(pt2d, cd_type, psgn, cd_mpp, pval) 
     59   SUBROUTINE crs_lbc_lnk_2d(pt2d, cd_type, psgn, kfillmode, pfillval ) 
    6760      !!--------------------------------------------------------------------- 
    6861      !!                  ***  SUBROUTINE crs_lbc_lnk  *** 
    … …  
    7770      REAL(wp)                            , INTENT(in   ) ::   psgn     ! control of the sign 
    7871      REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(inout) ::   pt2d     ! 2D array on which the lbc is applied 
    79       REAL(wp)                  , OPTIONAL, INTENT(in   ) ::   pval     ! valeur sur les halo 
    80       CHARACTER(len=3)          , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! MPP only (here do nothing) 
     72      INTEGER                 , OPTIONAL  , INTENT(in   ) ::   kfillmode   ! filling method for halo over land (default = constant) 
     73      REAL(wp)                , OPTIONAL  , INTENT(in   ) ::   pfillval    ! background value (used at closed boundaries) 
    8174      !       
    8275      LOGICAL  ::   ll_grid_crs 
    83       REAL(wp) ::   zval     ! valeur sur les halo 
    8476      !!---------------------------------------------------------------------- 
    8577      ! 
    8678      ll_grid_crs = ( jpi == jpi_crs ) 
    8779      ! 
    88       IF( PRESENT(pval) ) THEN   ;   zval = pval 
    89       ELSE                       ;   zval = 0._wp 
    90       ENDIF 
    91       ! 
    9280      IF( .NOT.ll_grid_crs )   CALL dom_grid_crs   ! Save the parent grid information  & Switch to coarse grid domain 
    9381      ! 
    94       IF( PRESENT( cd_mpp ) ) THEN   ;   CALL lbc_lnk( 'crslbclnk', pt2d, cd_type, psgn, cd_mpp, pval=zval  ) 
    95       ELSE                           ;   CALL lbc_lnk( 'crslbclnk', pt2d, cd_type, psgn        , pval=zval  ) 
    96       ENDIF 
     82      CALL lbc_lnk( 'crslbclnk', pt2d, cd_type, psgn, kfillmode, pfillval ) 
    9783      ! 
    9884      IF( .NOT.ll_grid_crs )   CALL dom_grid_glo   ! Return to parent grid domain 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DIA/dia25h.F90

    r10965 r11822  
    5757      REWIND ( numnam_ref )              ! Read Namelist nam_dia25h in reference namelist : 25hour mean diagnostics 
    5858      READ   ( numnam_ref, nam_dia25h, IOSTAT=ios, ERR= 901 ) 
    59 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nam_dia25h in reference namelist', lwp ) 
     59901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nam_dia25h in reference namelist' ) 
    6060      REWIND( numnam_cfg )              ! Namelist nam_dia25h in configuration namelist  25hour diagnostics 
    6161      READ  ( numnam_cfg, nam_dia25h, IOSTAT = ios, ERR = 902 ) 
    62 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nam_dia25h in configuration namelist', lwp ) 
     62902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nam_dia25h in configuration namelist' ) 
    6363      IF(lwm) WRITE ( numond, nam_dia25h ) 
    6464 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DIA/diacfl.F90

    r10965 r11822  
    1717   USE lbclnk          ! ocean lateral boundary condition (or mpp link) 
    1818   USE in_out_manager  ! I/O manager 
     19   USE iom             !  
    1920   USE timing          ! Performance output 
    2021 
    … …  
    2728   INTEGER, DIMENSION(3) ::   nCu_loc, nCv_loc, nCw_loc   ! U, V, and W run max locations in the global domain 
    2829   REAL(wp)              ::   rCu_max, rCv_max, rCw_max   ! associated run max Courant number  
    29  
    30 !!gm CAUTION: need to declare these arrays here, otherwise the calculation fails in multi-proc ! 
    31 !!gm          I don't understand why. 
    32    REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   zCu_cfl, zCv_cfl, zCw_cfl         ! workspace 
    33 !!gm end 
    3430 
    3531   PUBLIC   dia_cfl       ! routine called by step.F90 
    … …  
    5551      INTEGER, INTENT(in) ::   Kmm  ! ocean time level index 
    5652      ! 
    57       INTEGER                ::   ji, jj, jk                            ! dummy loop indices 
    58       REAL(wp)               ::   z2dt, zCu_max, zCv_max, zCw_max       ! local scalars 
    59       INTEGER , DIMENSION(3) ::   iloc_u , iloc_v , iloc_w , iloc       ! workspace 
    60 !!gm this does not work      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zCu_cfl, zCv_cfl, zCw_cfl         ! workspace 
     53      INTEGER                          ::   ji, jj, jk                       ! dummy loop indices 
     54      REAL(wp)                         ::   z2dt, zCu_max, zCv_max, zCw_max  ! local scalars 
     55      INTEGER , DIMENSION(3)           ::   iloc_u , iloc_v , iloc_w , iloc  ! workspace 
     56      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zCu_cfl, zCv_cfl, zCw_cfl        ! workspace 
    6157      !!---------------------------------------------------------------------- 
    6258      ! 
    … …  
    7167      DO jk = 1, jpk       ! calculate Courant numbers 
    7268         DO jj = 1, jpj 
    73             DO ji = 1, fs_jpim1   ! vector opt. 
     69            DO ji = 1, jpi 
    7470               zCu_cfl(ji,jj,jk) = ABS( uu(ji,jj,jk,Kmm) ) * z2dt / e1u  (ji,jj)      ! for i-direction 
    7571               zCv_cfl(ji,jj,jk) = ABS( vv(ji,jj,jk,Kmm) ) * z2dt / e2v  (ji,jj)      ! for j-direction 
    … …  
    7975      END DO 
    8076      ! 
     77      ! write outputs 
     78      IF( iom_use('cfl_cu') )   CALL iom_put( 'cfl_cu', MAXVAL( zCu_cfl, dim=3 ) ) 
     79      IF( iom_use('cfl_cv') )   CALL iom_put( 'cfl_cv', MAXVAL( zCv_cfl, dim=3 ) ) 
     80      IF( iom_use('cfl_cw') )   CALL iom_put( 'cfl_cw', MAXVAL( zCw_cfl, dim=3 ) ) 
     81 
    8182      !                    ! calculate maximum values and locations 
    8283      IF( lk_mpp ) THEN 
    … …  
    106107      !                    ! write out to file 
    107108      IF( lwp ) THEN 
    108          WRITE(numcfl,FMT='(2x,i4,5x,a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') kt, 'Max Cu', zCu_max, iloc_u(1), iloc_u(2), iloc_u(3) 
     109         WRITE(numcfl,FMT='(2x,i6,3x,a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') kt, 'Max Cu', zCu_max, iloc_u(1), iloc_u(2), iloc_u(3) 
    109110         WRITE(numcfl,FMT='(11x,     a6,4x,f7.4,1x,i4,1x,i4,1x,i4)')     'Max Cv', zCv_max, iloc_v(1), iloc_v(2), iloc_v(3) 
    110111         WRITE(numcfl,FMT='(11x,     a6,4x,f7.4,1x,i4,1x,i4,1x,i4)')     'Max Cw', zCw_max, iloc_w(1), iloc_w(2), iloc_w(3) 
    … …  
    167168      rCw_max = 0._wp 
    168169      ! 
    169 !!gm required to work 
    170       ALLOCATE ( zCu_cfl(jpi,jpj,jpk), zCv_cfl(jpi,jpj,jpk), zCw_cfl(jpi,jpj,jpk) ) 
    171 !!gm end 
    172       !       
    173170   END SUBROUTINE dia_cfl_init 
    174171 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DIA/diadct.F90

    r10965 r11822  
    1111   !!            3.4  ! 09/2011 (C Bricaud) 
    1212   !!---------------------------------------------------------------------- 
    13 #if defined key_diadct 
    14    !!---------------------------------------------------------------------- 
    15    !!   'key_diadct' : 
    16    !!---------------------------------------------------------------------- 
     13   !! does not work with agrif 
     14#if ! defined key_agrif 
    1715   !!---------------------------------------------------------------------- 
    1816   !!   dia_dct      :  Compute the transport through a sec. 
    … …  
    4240 
    4341   PUBLIC   dia_dct      ! routine called by step.F90 
    44    PUBLIC   dia_dct_init ! routine called by opa.F90 
    45    PUBLIC   diadct_alloc ! routine called by nemo_init in nemogcm.F90  
    46    PRIVATE  readsec 
    47    PRIVATE  removepoints 
    48    PRIVATE  transport 
    49    PRIVATE  dia_dct_wri 
    50  
    51    LOGICAL, PUBLIC, PARAMETER ::   lk_diadct = .TRUE.   !: model-data diagnostics flag 
    52  
    53    INTEGER :: nn_dct        ! Frequency of computation 
    54    INTEGER :: nn_dctwri     ! Frequency of output 
    55    INTEGER :: nn_secdebug   ! Number of the section to debug 
     42   PUBLIC   dia_dct_init ! routine called by nemogcm.F90 
     43 
     44   !                         !!** namelist variables ** 
     45   LOGICAL, PUBLIC ::   ln_diadct     !: Calculate transport thru a section or not 
     46   INTEGER         ::   nn_dct        !  Frequency of computation 
     47   INTEGER         ::   nn_dctwri     !  Frequency of output 
     48   INTEGER         ::   nn_secdebug   !  Number of the section to debug 
    5649    
    5750   INTEGER, PARAMETER :: nb_class_max  = 10 
    … …  
    10497CONTAINS 
    10598  
    106   INTEGER FUNCTION diadct_alloc()  
    107      !!----------------------------------------------------------------------  
    108      !!                   ***  FUNCTION diadct_alloc  ***  
    109      !!----------------------------------------------------------------------  
    110      INTEGER :: ierr(2)  
    111      !!----------------------------------------------------------------------  
    112  
    113      ALLOCATE(transports_3d(nb_3d_vars,nb_sec_max,nb_point_max,jpk), STAT=ierr(1) )  
    114      ALLOCATE(transports_2d(nb_2d_vars,nb_sec_max,nb_point_max)    , STAT=ierr(2) )  
    115  
    116      diadct_alloc = MAXVAL( ierr )  
    117      IF( diadct_alloc /= 0 )   CALL ctl_stop( 'STOP', 'diadct_alloc: failed to allocate arrays' )  
    118   
    119   END FUNCTION diadct_alloc  
    120  
     99   INTEGER FUNCTION diadct_alloc()  
     100      !!----------------------------------------------------------------------  
     101      !!                   ***  FUNCTION diadct_alloc  ***  
     102      !!----------------------------------------------------------------------  
     103 
     104      ALLOCATE( transports_3d(nb_3d_vars,nb_sec_max,nb_point_max,jpk), & 
     105         &      transports_2d(nb_2d_vars,nb_sec_max,nb_point_max)    , STAT=diadct_alloc )  
     106 
     107      CALL mpp_sum( 'diadct', diadct_alloc )  
     108      IF( diadct_alloc /= 0 )   CALL ctl_stop( 'STOP', 'diadct_alloc: failed to allocate arrays' )  
     109 
     110   END FUNCTION diadct_alloc 
    121111 
    122112   SUBROUTINE dia_dct_init 
    … …  
    130120      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    131121      !! 
    132       NAMELIST/namdct/nn_dct,nn_dctwri,nn_secdebug 
     122      NAMELIST/nam_diadct/ln_diadct, nn_dct, nn_dctwri, nn_secdebug 
    133123      !!--------------------------------------------------------------------- 
    134124 
    135      REWIND( numnam_ref )              ! Namelist namdct in reference namelist : Diagnostic: transport through sections 
    136      READ  ( numnam_ref, namdct, IOSTAT = ios, ERR = 901) 
    137 901  IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdct in reference namelist', lwp ) 
    138  
    139      REWIND( numnam_cfg )              ! Namelist namdct in configuration namelist : Diagnostic: transport through sections 
    140      READ  ( numnam_cfg, namdct, IOSTAT = ios, ERR = 902 ) 
    141 902  IF( ios >  0 ) CALL ctl_nam ( ios , 'namdct in configuration namelist', lwp ) 
    142      IF(lwm) WRITE ( numond, namdct ) 
     125     REWIND( numnam_ref )              ! Namelist nam_diadct in reference namelist : Diagnostic: transport through sections 
     126     READ  ( numnam_ref, nam_diadct, IOSTAT = ios, ERR = 901) 
     127901  IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diadct in reference namelist' ) 
     128 
     129     REWIND( numnam_cfg )              ! Namelist nam_diadct in configuration namelist : Diagnostic: transport through sections 
     130     READ  ( numnam_cfg, nam_diadct, IOSTAT = ios, ERR = 902 ) 
     131902  IF( ios >  0 ) CALL ctl_nam ( ios , 'nam_diadct in configuration namelist' ) 
     132     IF(lwm) WRITE ( numond, nam_diadct ) 
    143133 
    144134     IF( lwp ) THEN 
    … …  
    146136        WRITE(numout,*) "diadct_init: compute transports through sections " 
    147137        WRITE(numout,*) "~~~~~~~~~~~~~~~~~~~~~" 
    148         WRITE(numout,*) "       Frequency of computation: nn_dct    = ",nn_dct 
    149         WRITE(numout,*) "       Frequency of write:       nn_dctwri = ",nn_dctwri 
     138        WRITE(numout,*) "       Calculate transport thru sections: ln_diadct = ", ln_diadct 
     139        WRITE(numout,*) "       Frequency of computation:          nn_dct    = ", nn_dct 
     140        WRITE(numout,*) "       Frequency of write:                nn_dctwri = ", nn_dctwri 
    150141 
    151142        IF      ( nn_secdebug .GE. 1 .AND. nn_secdebug .LE. nb_sec_max )THEN 
    … …  
    155146        ELSE                              ; WRITE(numout,*)"       Wrong value for nn_secdebug : ",nn_secdebug 
    156147        ENDIF 
    157  
     148     ENDIF 
     149 
     150     IF( ln_diadct ) THEN 
     151        ! control 
    158152        IF(nn_dct .GE. nn_dctwri .AND. MOD(nn_dct,nn_dctwri) .NE. 0)  & 
    159           &  CALL ctl_stop( 'diadct: nn_dct should be smaller and a multiple of nn_dctwri' ) 
    160  
     153           &  CALL ctl_stop( 'diadct: nn_dct should be smaller and a multiple of nn_dctwri' ) 
     154 
     155        ! allocate dia_dct arrays 
     156        IF( diadct_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'diadct_alloc: failed to allocate arrays' ) 
     157 
     158        !Read section_ijglobal.diadct 
     159        CALL readsec 
     160 
     161        !open output file 
     162        IF( lwm ) THEN 
     163           CALL ctl_opn( numdct_vol,  'volume_transport', 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout,  .FALSE. ) 
     164           CALL ctl_opn( numdct_heat, 'heat_transport'  , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout,  .FALSE. ) 
     165           CALL ctl_opn( numdct_salt, 'salt_transport'  , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout,  .FALSE. ) 
     166        ENDIF 
     167 
     168        ! Initialise arrays to zero  
     169        transports_3d(:,:,:,:)=0.0  
     170        transports_2d(:,:,:)  =0.0  
     171        ! 
    161172     ENDIF 
    162  
    163      !Read section_ijglobal.diadct 
    164      CALL readsec 
    165  
    166      !open output file 
    167      IF( lwm ) THEN 
    168         CALL ctl_opn( numdct_vol,  'volume_transport', 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout,  .FALSE. ) 
    169         CALL ctl_opn( numdct_heat, 'heat_transport'  , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout,  .FALSE. ) 
    170         CALL ctl_opn( numdct_salt, 'salt_transport'  , 'NEW', 'FORMATTED', 'SEQUENTIAL', -1, numout,  .FALSE. ) 
    171      ENDIF 
    172  
    173      ! Initialise arrays to zero  
    174      transports_3d(:,:,:,:)=0.0  
    175      transports_2d(:,:,:)  =0.0  
    176173     ! 
    177174  END SUBROUTINE dia_dct_init 
    … …  
    12451242#else 
    12461243   !!---------------------------------------------------------------------- 
    1247    !!   Default option :                                       Dummy module 
     1244   !!   Dummy module                                              
    12481245   !!---------------------------------------------------------------------- 
    1249    LOGICAL, PUBLIC, PARAMETER ::   lk_diadct = .FALSE.    !: diamht flag 
    1250    PUBLIC  
    1251    !! $Id$ 
     1246   LOGICAL, PUBLIC ::   ln_diadct = .FALSE. 
    12521247CONTAINS 
    1253  
    1254    SUBROUTINE dia_dct_init          ! Dummy routine 
     1248   SUBROUTINE dia_dct_init 
    12551249      IMPLICIT NONE 
    1256       WRITE(*,*) 'dia_dct_init: You should not have seen this print! error?' 
    12571250   END SUBROUTINE dia_dct_init 
    12581251 
    … …  
    12631256      WRITE(*,*) 'dia_dct: You should not have seen this print! error?', kt 
    12641257   END SUBROUTINE dia_dct 
     1258   ! 
    12651259#endif 
    12661260 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DIA/diaharm.F90

    r10965 r11822  
    55   !!====================================================================== 
    66   !! History :  3.1  !  2007  (O. Le Galloudec, J. Chanut)  Original code 
    7    !!---------------------------------------------------------------------- 
    8 #if defined key_diaharm 
    9    !!---------------------------------------------------------------------- 
    10    !!   'key_diaharm' 
    117   !!---------------------------------------------------------------------- 
    128   USE oce             ! ocean dynamics and tracers variables 
    … …  
    2622   IMPLICIT NONE 
    2723   PRIVATE 
    28  
    29    LOGICAL, PUBLIC, PARAMETER :: lk_diaharm  = .TRUE. 
    3024    
    3125   INTEGER, PARAMETER :: jpincomax    = 2.*jpmax_harmo 
    … …  
    3327 
    3428   !                         !!** namelist variables ** 
    35    INTEGER ::   nit000_han    ! First time step used for harmonic analysis 
    36    INTEGER ::   nitend_han    ! Last time step used for harmonic analysis 
    37    INTEGER ::   nstep_han     ! Time step frequency for harmonic analysis 
    38    INTEGER ::   nb_ana        ! Number of harmonics to analyse 
     29   LOGICAL, PUBLIC ::   ln_diaharm    ! Choose tidal harmonic output or not 
     30   INTEGER         ::   nit000_han    ! First time step used for harmonic analysis 
     31   INTEGER         ::   nitend_han    ! Last time step used for harmonic analysis 
     32   INTEGER         ::   nstep_han     ! Time step frequency for harmonic analysis 
     33   INTEGER         ::   nb_ana        ! Number of harmonics to analyse 
    3934 
    4035   INTEGER , ALLOCATABLE, DIMENSION(:)       ::   name 
    … …  
    5348   CHARACTER (LEN=4), DIMENSION(jpmax_harmo) ::   tname   ! Names of tidal constituents ('M2', 'K1',...) 
    5449 
    55    PUBLIC   dia_harm   ! routine called by step.F90 
     50   PUBLIC   dia_harm        ! routine called by step.F90 
     51   PUBLIC   dia_harm_init   ! routine called by nemogcm.F90 
    5652 
    5753   !!---------------------------------------------------------------------- 
    … …  
    7167      !! 
    7268      !!-------------------------------------------------------------------- 
    73       INTEGER :: jh, nhan, jk, ji 
     69      INTEGER ::   jh, nhan, ji 
    7470      INTEGER ::   ios                 ! Local integer output status for namelist read 
    7571 
    76       NAMELIST/nam_diaharm/ nit000_han, nitend_han, nstep_han, tname 
     72      NAMELIST/nam_diaharm/ ln_diaharm, nit000_han, nitend_han, nstep_han, tname 
    7773      !!---------------------------------------------------------------------- 
    7874 
    … …  
    8379      ENDIF 
    8480      ! 
    85       IF( .NOT. ln_tide )   CALL ctl_stop( 'dia_harm_init : ln_tide must be true for harmonic analysis') 
    86       ! 
    87       CALL tide_init_Wave 
    88       ! 
    8981      REWIND( numnam_ref )              ! Namelist nam_diaharm in reference namelist : Tidal harmonic analysis 
    9082      READ  ( numnam_ref, nam_diaharm, IOSTAT = ios, ERR = 901) 
    91 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nam_diaharm in reference namelist', lwp ) 
     83901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nam_diaharm in reference namelist' ) 
    9284      REWIND( numnam_cfg )              ! Namelist nam_diaharm in configuration namelist : Tidal harmonic analysis 
    9385      READ  ( numnam_cfg, nam_diaharm, IOSTAT = ios, ERR = 902 ) 
    94 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nam_diaharm in configuration namelist', lwp ) 
     86902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nam_diaharm in configuration namelist' ) 
    9587      IF(lwm) WRITE ( numond, nam_diaharm ) 
    9688      ! 
    9789      IF(lwp) THEN 
    98          WRITE(numout,*) 'First time step used for analysis:  nit000_han= ', nit000_han 
    99          WRITE(numout,*) 'Last  time step used for analysis:  nitend_han= ', nitend_han 
    100          WRITE(numout,*) 'Time step frequency for harmonic analysis:  nstep_han= ', nstep_han 
     90         WRITE(numout,*) 'Tidal diagnostics = ', ln_diaharm 
     91         WRITE(numout,*) '   First time step used for analysis:         nit000_han= ', nit000_han 
     92         WRITE(numout,*) '   Last  time step used for analysis:         nitend_han= ', nitend_han 
     93         WRITE(numout,*) '   Time step frequency for harmonic analysis: nstep_han = ', nstep_han 
    10194      ENDIF 
    10295 
    103       ! Basic checks on harmonic analysis time window: 
    104       ! ---------------------------------------------- 
    105       IF( nit000 > nit000_han )   CALL ctl_stop( 'dia_harm_init : nit000_han must be greater than nit000',   & 
    106          &                                       ' restart capability not implemented' ) 
    107       IF( nitend < nitend_han )   CALL ctl_stop( 'dia_harm_init : nitend_han must be lower than nitend',   & 
    108          &                                       'restart capability not implemented' ) 
    109  
    110       IF( MOD( nitend_han-nit000_han+1 , nstep_han ) /= 0 )   & 
    111          &                        CALL ctl_stop( 'dia_harm_init : analysis time span must be a multiple of nstep_han' ) 
    112  
    113       nb_ana = 0 
    114       DO jk=1,jpmax_harmo 
    115          DO ji=1,jpmax_harmo 
    116             IF(TRIM(tname(jk)) == Wave(ji)%cname_tide) THEN 
    117                nb_ana=nb_ana+1 
    118             ENDIF 
    119          END DO 
    120       END DO 
    121       ! 
    122       IF(lwp) THEN 
    123          WRITE(numout,*) '        Namelist nam_diaharm' 
    124          WRITE(numout,*) '        nb_ana    = ', nb_ana 
    125          CALL flush(numout) 
     96      IF( ln_diaharm .AND. .NOT.ln_tide )   CALL ctl_stop( 'dia_harm_init : ln_tide must be true for harmonic analysis') 
     97 
     98      IF( ln_diaharm ) THEN 
     99 
     100         CALL tide_init_Wave 
     101         ! 
     102         ! Basic checks on harmonic analysis time window: 
     103         ! ---------------------------------------------- 
     104         IF( nit000 > nit000_han )   CALL ctl_stop( 'dia_harm_init : nit000_han must be greater than nit000',   & 
     105            &                                       ' restart capability not implemented' ) 
     106         IF( nitend < nitend_han )   CALL ctl_stop( 'dia_harm_init : nitend_han must be lower than nitend',   & 
     107            &                                       'restart capability not implemented' ) 
     108 
     109         IF( MOD( nitend_han-nit000_han+1 , nstep_han ) /= 0 )   & 
     110            &                        CALL ctl_stop( 'dia_harm_init : analysis time span must be a multiple of nstep_han' ) 
     111         ! 
     112         nb_ana = 0 
     113         DO jh=1,jpmax_harmo 
     114            DO ji=1,jpmax_harmo 
     115               IF(TRIM(tname(jh)) == Wave(ji)%cname_tide) THEN 
     116                  nb_ana=nb_ana+1 
     117               ENDIF 
     118            END DO 
     119         END DO 
     120         ! 
     121         IF(lwp) THEN 
     122            WRITE(numout,*) '        Namelist nam_diaharm' 
     123            WRITE(numout,*) '        nb_ana    = ', nb_ana 
     124            CALL flush(numout) 
     125         ENDIF 
     126         ! 
     127         IF (nb_ana > jpmax_harmo) THEN 
     128            WRITE(ctmp1,*) ' nb_ana must be lower than jpmax_harmo' 
     129            WRITE(ctmp2,*) ' jpmax_harmo= ', jpmax_harmo 
     130            CALL ctl_stop( 'dia_harm_init', ctmp1, ctmp2 ) 
     131         ENDIF 
     132 
     133         ALLOCATE(name    (nb_ana)) 
     134         DO jh=1,nb_ana 
     135            DO ji=1,jpmax_harmo 
     136               IF (TRIM(tname(jh)) ==  Wave(ji)%cname_tide) THEN 
     137                  name(jh) = ji 
     138                  EXIT 
     139               END IF 
     140            END DO 
     141         END DO 
     142 
     143         ! Initialize frequency array: 
     144         ! --------------------------- 
     145         ALLOCATE( ana_freq(nb_ana), ut(nb_ana), vt(nb_ana), ft(nb_ana) ) 
     146 
     147         CALL tide_harmo( ana_freq, vt, ut, ft, name, nb_ana ) 
     148 
     149         IF(lwp) WRITE(numout,*) 'Analysed frequency  : ',nb_ana ,'Frequency ' 
     150 
     151         DO jh = 1, nb_ana 
     152            IF(lwp) WRITE(numout,*) '                    : ',tname(jh),' ',ana_freq(jh) 
     153         END DO 
     154 
     155         ! Initialize temporary arrays: 
     156         ! ---------------------------- 
     157         ALLOCATE( ana_temp(jpi,jpj,2*nb_ana,3) ) 
     158         ana_temp(:,:,:,:) = 0._wp 
     159 
    126160      ENDIF 
    127       ! 
    128       IF (nb_ana > jpmax_harmo) THEN 
    129          WRITE(ctmp1,*) 'Can not use XIOS in iom_g0d, file: '//TRIM(clname)//', var:'//TRIM(cdvar) 
    130          WRITE(ctmp2,*) ' jpmax_harmo= ', jpmax_harmo 
    131          CALL ctl_stop( 'dia_harm_init', ctmp1, ctmp2 ) 
    132       ENDIF 
    133  
    134       ALLOCATE(name    (nb_ana)) 
    135       DO jk=1,nb_ana 
    136        DO ji=1,jpmax_harmo 
    137           IF (TRIM(tname(jk)) ==  Wave(ji)%cname_tide) THEN 
    138              name(jk) = ji 
    139              EXIT 
    140           END IF 
    141        END DO 
    142       END DO 
    143  
    144       ! Initialize frequency array: 
    145       ! --------------------------- 
    146       ALLOCATE( ana_freq(nb_ana), ut(nb_ana), vt(nb_ana), ft(nb_ana) ) 
    147  
    148       CALL tide_harmo( ana_freq, vt, ut, ft, name, nb_ana ) 
    149  
    150       IF(lwp) WRITE(numout,*) 'Analysed frequency  : ',nb_ana ,'Frequency ' 
    151  
    152       DO jh = 1, nb_ana 
    153         IF(lwp) WRITE(numout,*) '                    : ',tname(jh),' ',ana_freq(jh) 
    154       END DO 
    155  
    156       ! Initialize temporary arrays: 
    157       ! ---------------------------- 
    158       ALLOCATE( ana_temp(jpi,jpj,2*nb_ana,3) ) 
    159       ana_temp(:,:,:,:) = 0._wp 
    160161 
    161162   END SUBROUTINE dia_harm_init 
    … …  
    178179      !!-------------------------------------------------------------------- 
    179180      IF( ln_timing )   CALL timing_start('dia_harm') 
    180       ! 
    181       IF( kt == nit000 )   CALL dia_harm_init 
    182181      ! 
    183182      IF( kt >= nit000_han .AND. kt <= nitend_han .AND. MOD(kt,nstep_han) == 0 ) THEN 
    … …  
    423422      INTEGER, INTENT(in) ::   init  
    424423      ! 
    425       INTEGER                         :: ji_sd, jj_sd, ji1_sd, ji2_sd, jk1_sd, jk2_sd 
     424      INTEGER                         :: ji_sd, jj_sd, ji1_sd, ji2_sd, jh1_sd, jh2_sd 
    426425      REAL(wp)                        :: zval1, zval2, zx1 
    427426      REAL(wp), DIMENSION(jpincomax) :: ztmpx, zcol1, zcol2 
    … …  
    435434         ztmp3(:,:) = 0._wp 
    436435         ! 
    437          DO jk1_sd = 1, nsparse 
    438             DO jk2_sd = 1, nsparse 
    439                nisparse(jk2_sd) = nisparse(jk2_sd) 
    440                njsparse(jk2_sd) = njsparse(jk2_sd) 
    441                IF( nisparse(jk2_sd) == nisparse(jk1_sd) ) THEN 
    442                   ztmp3(njsparse(jk1_sd),njsparse(jk2_sd)) = ztmp3(njsparse(jk1_sd),njsparse(jk2_sd))  & 
    443                      &                                     + valuesparse(jk1_sd)*valuesparse(jk2_sd) 
     436         DO jh1_sd = 1, nsparse 
     437            DO jh2_sd = 1, nsparse 
     438               nisparse(jh2_sd) = nisparse(jh2_sd) 
     439               njsparse(jh2_sd) = njsparse(jh2_sd) 
     440               IF( nisparse(jh2_sd) == nisparse(jh1_sd) ) THEN 
     441                  ztmp3(njsparse(jh1_sd),njsparse(jh2_sd)) = ztmp3(njsparse(jh1_sd),njsparse(jh2_sd))  & 
     442                     &                                     + valuesparse(jh1_sd)*valuesparse(jh2_sd) 
    444443               ENDIF 
    445444            END DO 
    … …  
    516515   END SUBROUTINE SUR_DETERMINE 
    517516 
    518 #else 
    519    !!---------------------------------------------------------------------- 
    520    !!   Default case :   Empty module 
    521    !!---------------------------------------------------------------------- 
    522    LOGICAL, PUBLIC, PARAMETER ::   lk_diaharm = .FALSE. 
    523 CONTAINS 
    524    SUBROUTINE dia_harm ( kt, Kmm )     ! Empty routine 
    525       INTEGER, INTENT( IN ) :: kt   
    526       INTEGER, INTENT( IN ) :: Kmm   
    527       WRITE(*,*) 'dia_harm: you should not have seen this print' 
    528    END SUBROUTINE dia_harm 
    529 #endif 
    530  
    531517   !!====================================================================== 
    532518END MODULE diaharm 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DIA/diahsb.F90

    r10965 r11822  
    366366      REWIND( numnam_ref )              ! Namelist namhsb in reference namelist 
    367367      READ  ( numnam_ref, namhsb, IOSTAT = ios, ERR = 901) 
    368 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namhsb in reference namelist', lwp ) 
     368901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namhsb in reference namelist' ) 
    369369      REWIND( numnam_cfg )              ! Namelist namhsb in configuration namelist 
    370370      READ  ( numnam_cfg, namhsb, IOSTAT = ios, ERR = 902 ) 
    371 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namhsb in configuration namelist', lwp ) 
     371902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namhsb in configuration namelist' ) 
    372372      IF(lwm) WRITE( numond, namhsb ) 
    373373 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DIA/diaptr.F90

    r10965 r11822  
    394394      REWIND( numnam_ref )              ! Namelist namptr in reference namelist : Poleward transport 
    395395      READ  ( numnam_ref, namptr, IOSTAT = ios, ERR = 901) 
    396 901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in reference namelist', lwp ) 
     396901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in reference namelist' ) 
    397397 
    398398      REWIND( numnam_cfg )              ! Namelist namptr in configuration namelist : Poleward transport 
    399399      READ  ( numnam_cfg, namptr, IOSTAT = ios, ERR = 902 ) 
    400 902   IF( ios >  0 ) CALL ctl_nam ( ios , 'namptr in configuration namelist', lwp ) 
     400902   IF( ios >  0 ) CALL ctl_nam ( ios , 'namptr in configuration namelist' ) 
    401401      IF(lwm) WRITE ( numond, namptr ) 
    402402 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DIA/diatmb.F90

    r10965 r11822  
    4343      REWIND( numnam_ref )              ! Read Namelist nam_diatmb in reference namelist : TMB diagnostics 
    4444      READ  ( numnam_ref, nam_diatmb, IOSTAT=ios, ERR= 901 ) 
    45 901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diatmb in reference namelist', lwp ) 
     45901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diatmb in reference namelist' ) 
    4646  
    4747      REWIND( numnam_cfg )              ! Namelist nam_diatmb in configuration namelist  TMB diagnostics 
    4848      READ  ( numnam_cfg, nam_diatmb, IOSTAT = ios, ERR = 902 ) 
    49 902   IF( ios >  0 ) CALL ctl_nam ( ios , 'nam_diatmb in configuration namelist', lwp ) 
     49902   IF( ios >  0 ) CALL ctl_nam ( ios , 'nam_diatmb in configuration namelist' ) 
    5050      IF(lwm) WRITE ( numond, nam_diatmb ) 
    5151 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DIA/diawri.F90

    r11027 r11822  
    211211      ENDIF 
    212212 
     213      IF( ln_zad_Aimp ) ww = ww + wi               ! Recombine explicit and implicit parts of vertical velocity for diagnostic output 
     214      ! 
    213215      CALL iom_put( "woce", ww )                   ! vertical velocity 
    214216      IF( iom_use('w_masstr') .OR. iom_use('w_masstr2') ) THEN   ! vertical mass transport & its square value 
    … …  
    221223         IF( iom_use('w_masstr2') )   CALL iom_put( "w_masstr2", z3d(:,:,:) * z3d(:,:,:) ) 
    222224      ENDIF 
     225      ! 
     226      IF( ln_zad_Aimp ) ww = ww - wi               ! Remove implicit part of vertical velocity that was added for diagnostic output 
    223227 
    224228      CALL iom_put( "avt" , avt )                  ! T vert. eddy diff. coef. 
    … …  
    427431      !!      define all the NETCDF files and fields 
    428432      !!      At each time step call histdef to compute the mean if ncessary 
    429       !!      Each nwrite time step, output the instantaneous or mean fields 
     433      !!      Each nn_write time step, output the instantaneous or mean fields 
    430434      !!---------------------------------------------------------------------- 
    431435      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
    … …  
    444448      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zw3d       ! 3D workspace 
    445449      !!---------------------------------------------------------------------- 
    446       !  
    447       IF( ln_timing )   CALL timing_start('dia_wri') 
    448450      ! 
    449451      IF( ninist == 1 ) THEN     !==  Output the initial state and forcings  ==! 
    … …  
    452454      ENDIF 
    453455      ! 
     456      IF( nn_write == -1 )   RETURN   ! we will never do any output 
     457      !  
     458      IF( ln_timing )   CALL timing_start('dia_wri') 
     459      ! 
    454460      ! 0. Initialisation 
    455461      ! ----------------- 
    … …  
    461467      clop = "x"         ! no use of the mask value (require less cpu time and otherwise the model crashes) 
    462468#if defined key_diainstant 
    463       zsto = nwrite * rdt 
     469      zsto = nn_write * rdt 
    464470      clop = "inst("//TRIM(clop)//")" 
    465471#else 
    … …  
    467473      clop = "ave("//TRIM(clop)//")" 
    468474#endif 
    469       zout = nwrite * rdt 
     475      zout = nn_write * rdt 
    470476      zmax = ( nitend - nit000 + 1 ) * rdt 
    471477 
    … …  
    498504         ! WRITE root name in date.file for use by postpro 
    499505         IF(lwp) THEN 
    500             CALL dia_nam( clhstnam, nwrite,' ' ) 
     506            CALL dia_nam( clhstnam, nn_write,' ' ) 
    501507            CALL ctl_opn( inum, 'date.file', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
    502508            WRITE(inum,*) clhstnam 
    … …  
    506512         ! Define the T grid FILE ( nid_T ) 
    507513 
    508          CALL dia_nam( clhstnam, nwrite, 'grid_T' ) 
     514         CALL dia_nam( clhstnam, nn_write, 'grid_T' ) 
    509515         IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam    ! filename 
    510516         CALL histbeg( clhstnam, jpi, glamt, jpj, gphit,           &  ! Horizontal grid: glamt and gphit 
    … …  
    542548         ! Define the U grid FILE ( nid_U ) 
    543549 
    544          CALL dia_nam( clhstnam, nwrite, 'grid_U' ) 
     550         CALL dia_nam( clhstnam, nn_write, 'grid_U' ) 
    545551         IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam    ! filename 
    546552         CALL histbeg( clhstnam, jpi, glamu, jpj, gphiu,           &  ! Horizontal grid: glamu and gphiu 
    … …  
    555561         ! Define the V grid FILE ( nid_V ) 
    556562 
    557          CALL dia_nam( clhstnam, nwrite, 'grid_V' )                   ! filename 
     563         CALL dia_nam( clhstnam, nn_write, 'grid_V' )                   ! filename 
    558564         IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam 
    559565         CALL histbeg( clhstnam, jpi, glamv, jpj, gphiv,           &  ! Horizontal grid: glamv and gphiv 
    … …  
    568574         ! Define the W grid FILE ( nid_W ) 
    569575 
    570          CALL dia_nam( clhstnam, nwrite, 'grid_W' )                   ! filename 
     576         CALL dia_nam( clhstnam, nn_write, 'grid_W' )                   ! filename 
    571577         IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam 
    572578         CALL histbeg( clhstnam, jpi, glamt, jpj, gphit,           &  ! Horizontal grid: glamt and gphit 
    … …  
    659665         ENDIF 
    660666 
    661          IF( .NOT. ln_cpl ) THEN 
     667         IF( ln_ssr ) THEN 
    662668            CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping"         , "W/m2"   ,   &  ! qrp 
    663669               &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
    … …  
    667673               &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
    668674         ENDIF 
    669  
    670          IF( ln_cpl .AND. nn_ice <= 1 ) THEN 
    671             CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping"         , "W/m2"   ,   &  ! qrp 
    672                &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
    673             CALL histdef( nid_T, "sowafldp", "Surface Water Flux: Damping"        , "Kg/m2/s",   &  ! erp 
    674                &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
    675             CALL histdef( nid_T, "sosafldp", "Surface salt flux: Damping"         , "Kg/m2/s",   &  ! erp * sn 
    676                &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
    677          ENDIF 
    678           
     675        
    679676         clmx ="l_max(only(x))"    ! max index on a period 
    680677!         CALL histdef( nid_T, "sobowlin", "Bowl Index"                         , "W-point",   &  ! bowl INDEX  
    … …  
    752749      ! donne le nombre d'elements, et ndex la liste des indices a sortir 
    753750 
    754       IF( lwp .AND. MOD( itmod, nwrite ) == 0 ) THEN  
     751      IF( lwp .AND. MOD( itmod, nn_write ) == 0 ) THEN  
    755752         WRITE(numout,*) 'dia_wri : write model outputs in NetCDF files at ', kt, 'time-step' 
    756753         WRITE(numout,*) '~~~~~~ ' 
    … …  
    816813      ENDIF 
    817814 
    818       IF( .NOT. ln_cpl ) THEN 
     815      IF( ln_ssr ) THEN 
    819816         CALL histwrite( nid_T, "sohefldp", it, qrp           , ndim_hT, ndex_hT )   ! heat flux damping 
    820817         CALL histwrite( nid_T, "sowafldp", it, erp           , ndim_hT, ndex_hT )   ! freshwater flux damping 
    821          IF( ln_ssr ) zw2d(:,:) = erp(:,:) * ts(:,:,1,jp_sal,Kmm) * tmask(:,:,1) 
    822          CALL histwrite( nid_T, "sosafldp", it, zw2d          , ndim_hT, ndex_hT )   ! salt flux damping 
    823       ENDIF 
    824       IF( ln_cpl .AND. nn_ice <= 1 ) THEN 
    825          CALL histwrite( nid_T, "sohefldp", it, qrp           , ndim_hT, ndex_hT )   ! heat flux damping 
    826          CALL histwrite( nid_T, "sowafldp", it, erp           , ndim_hT, ndex_hT )   ! freshwater flux damping 
    827          IF( ln_ssr ) zw2d(:,:) = erp(:,:) * ts(:,:,1,jp_sal,Kmm) * tmask(:,:,1) 
     818         zw2d(:,:) = erp(:,:) * ts(:,:,1,jp_sal,Kmm) * tmask(:,:,1) 
    828819         CALL histwrite( nid_T, "sosafldp", it, zw2d          , ndim_hT, ndex_hT )   ! salt flux damping 
    829820      ENDIF 
    … …  
    844835      CALL histwrite( nid_V, "sometauy", it, vtau          , ndim_hV, ndex_hV )   ! j-wind stress 
    845836 
    846       CALL histwrite( nid_W, "vovecrtz", it, ww             , ndim_T, ndex_T )    ! vert. current 
     837      IF( ln_zad_Aimp ) THEN 
     838         CALL histwrite( nid_W, "vovecrtz", it, ww + wi     , ndim_T, ndex_T )    ! vert. current 
     839      ELSE 
     840         CALL histwrite( nid_W, "vovecrtz", it, ww          , ndim_T, ndex_T )    ! vert. current 
     841      ENDIF 
    847842      CALL histwrite( nid_W, "votkeavt", it, avt            , ndim_T, ndex_T )    ! T vert. eddy diff. coef. 
    848843      CALL histwrite( nid_W, "votkeavm", it, avm            , ndim_T, ndex_T )    ! T vert. eddy visc. coef. 
    … …  
    906901      CALL iom_rstput( 0, 0, inum, 'vozocrtx', uu(:,:,:,Kmm)                )    ! now i-velocity 
    907902      CALL iom_rstput( 0, 0, inum, 'vomecrty', vv(:,:,:,Kmm)                )    ! now j-velocity 
    908       CALL iom_rstput( 0, 0, inum, 'vovecrtz', ww                )    ! now k-velocity 
     903      IF( ln_zad_Aimp ) THEN 
     904         CALL iom_rstput( 0, 0, inum, 'vovecrtz', ww + wi        )    ! now k-velocity 
     905      ELSE 
     906         CALL iom_rstput( 0, 0, inum, 'vovecrtz', ww             )    ! now k-velocity 
     907      ENDIF 
    909908      IF( ALLOCATED(ahtu) ) THEN 
    910909         CALL iom_rstput( 0, 0, inum,  'ahtu', ahtu              )    ! aht at u-point 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DIU/diu_bulk.F90

    r10989 r11822  
    5454      REWIND( numnam_ref ) 
    5555      READ  ( numnam_ref, namdiu, IOSTAT = ios, ERR = 901 ) 
    56 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdiu in reference namelist', lwp ) 
     56901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdiu in reference namelist' ) 
    5757      REWIND( numnam_cfg ) 
    5858      READ  ( numnam_cfg, namdiu, IOSTAT = ios, ERR = 902 ) 
    59 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdiu in configuration namelist', lwp )       
     59902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdiu in configuration namelist' )       
    6060      ! 
    6161      IF( ln_diurnal_only .AND. ( .NOT. ln_diurnal ) ) THEN 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DOM/domain.F90

    r11480 r11822  
    103103         CASE( 0 )   ;   WRITE(numout,*) '         (i.e. closed)' 
    104104         CASE( 1 )   ;   WRITE(numout,*) '         (i.e. cyclic east-west)' 
    105          CASE( 2 )   ;   WRITE(numout,*) '         (i.e. equatorial symmetric)' 
     105         CASE( 2 )   ;   WRITE(numout,*) '         (i.e. cyclic north-south)' 
    106106         CASE( 3 )   ;   WRITE(numout,*) '         (i.e. north fold with T-point pivot)' 
    107107         CASE( 4 )   ;   WRITE(numout,*) '         (i.e. cyclic east-west and north fold with T-point pivot)' 
    … …  
    310310      REWIND( numnam_ref )              ! Namelist namrun in reference namelist : Parameters of the run 
    311311      READ  ( numnam_ref, namrun, IOSTAT = ios, ERR = 901) 
    312 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namrun in reference namelist', lwp ) 
     312901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namrun in reference namelist' ) 
    313313      REWIND( numnam_cfg )              ! Namelist namrun in configuration namelist : Parameters of the run 
    314314      READ  ( numnam_cfg, namrun, IOSTAT = ios, ERR = 902 ) 
    315 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namrun in configuration namelist', lwp ) 
     315902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namrun in configuration namelist' ) 
    316316      IF(lwm) WRITE ( numond, namrun ) 
    317317      ! 
    … …  
    338338            WRITE(numout,*) '      frequency of restart file       nn_stock        = ', nn_stock 
    339339         ENDIF 
     340#if ! defined key_iomput 
    340341         WRITE(numout,*) '      frequency of output file        nn_write        = ', nn_write 
     342#endif 
    341343         WRITE(numout,*) '      mask land points                ln_mskland      = ', ln_mskland 
    342344         WRITE(numout,*) '      additional CF standard metadata ln_cfmeta       = ', ln_cfmeta 
    … …  
    360362      nleapy = nn_leapy 
    361363      ninist = nn_istate 
    362       nstock = nn_stock 
    363       nstocklist = nn_stocklist 
    364       nwrite = nn_write 
    365364      neuler = nn_euler 
    366365      IF( neuler == 1 .AND. .NOT. ln_rstart ) THEN 
    … …  
    371370      ENDIF 
    372371      !                             ! control of output frequency 
    373       IF( nstock == 0 .OR. nstock > nitend ) THEN 
    374          WRITE(ctmp1,*) 'nstock = ', nstock, ' it is forced to ', nitend 
     372      IF( .NOT. ln_rst_list ) THEN     ! we use nn_stock 
     373         IF( nn_stock == -1 )   CALL ctl_warn( 'nn_stock = -1 --> no restart will be done' ) 
     374         IF( nn_stock == 0 .OR. nn_stock > nitend ) THEN 
     375            WRITE(ctmp1,*) 'nn_stock = ', nn_stock, ' it is forced to ', nitend 
     376            CALL ctl_warn( ctmp1 ) 
     377            nn_stock = nitend 
     378         ENDIF 
     379      ENDIF 
     380#if ! defined key_iomput 
     381      IF( nn_write == -1 )   CALL ctl_warn( 'nn_write = -1 --> no output files will be done' ) 
     382      IF ( nn_write == 0 ) THEN 
     383         WRITE(ctmp1,*) 'nn_write = ', nn_write, ' it is forced to ', nitend 
    375384         CALL ctl_warn( ctmp1 ) 
    376          nstock = nitend 
    377       ENDIF 
    378       IF ( nwrite == 0 ) THEN 
    379          WRITE(ctmp1,*) 'nwrite = ', nwrite, ' it is forced to ', nitend 
    380          CALL ctl_warn( ctmp1 ) 
    381          nwrite = nitend 
    382       ENDIF 
     385         nn_write = nitend 
     386      ENDIF 
     387#endif 
    383388 
    384389#if defined key_agrif 
    … …  
    403408      REWIND( numnam_ref )              ! Namelist namdom in reference namelist : space & time domain (bathymetry, mesh, timestep) 
    404409      READ  ( numnam_ref, namdom, IOSTAT = ios, ERR = 903) 
    405 903   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdom in reference namelist', lwp ) 
     410903   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdom in reference namelist' ) 
    406411      REWIND( numnam_cfg )              ! Namelist namdom in configuration namelist : space & time domain (bathymetry, mesh, timestep) 
    407412      READ  ( numnam_cfg, namdom, IOSTAT = ios, ERR = 904 ) 
    408 904   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdom in configuration namelist', lwp ) 
     413904   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdom in configuration namelist' ) 
    409414      IF(lwm) WRITE( numond, namdom ) 
    410415      ! 
    … …  
    435440      REWIND( numnam_ref )              ! Namelist namnc4 in reference namelist : NETCDF 
    436441      READ  ( numnam_ref, namnc4, IOSTAT = ios, ERR = 907) 
    437 907   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namnc4 in reference namelist', lwp ) 
     442907   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namnc4 in reference namelist' ) 
    438443      REWIND( numnam_cfg )              ! Namelist namnc4 in configuration namelist : NETCDF 
    439444      READ  ( numnam_cfg, namnc4, IOSTAT = ios, ERR = 908 ) 
    440 908   IF( ios >  0 )   CALL ctl_nam ( ios , 'namnc4 in configuration namelist', lwp ) 
     445908   IF( ios >  0 )   CALL ctl_nam ( ios , 'namnc4 in configuration namelist' ) 
    441446      IF(lwm) WRITE( numond, namnc4 ) 
    442447 
    … …  
    513518 
    514519 
    515    SUBROUTINE domain_cfg( ldtxt, cd_cfg, kk_cfg, kpi, kpj, kpk, kperio ) 
     520   SUBROUTINE domain_cfg( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio ) 
    516521      !!---------------------------------------------------------------------- 
    517522      !!                     ***  ROUTINE dom_nam  *** 
    … …  
    521526      !! ** Method  :   read the cn_domcfg NetCDF file 
    522527      !!---------------------------------------------------------------------- 
    523       CHARACTER(len=*), DIMENSION(:), INTENT(out) ::   ldtxt           ! stored print information 
    524528      CHARACTER(len=*)              , INTENT(out) ::   cd_cfg          ! configuration name 
    525529      INTEGER                       , INTENT(out) ::   kk_cfg          ! configuration resolution 
    … …  
    527531      INTEGER                       , INTENT(out) ::   kperio          ! lateral global domain b.c.  
    528532      ! 
    529       INTEGER ::   inum, ii   ! local integer 
     533      INTEGER ::   inum   ! local integer 
    530534      REAL(wp) ::   zorca_res                     ! local scalars 
    531       REAL(wp) ::   ziglo, zjglo, zkglo, zperio   !   -      - 
    532       !!---------------------------------------------------------------------- 
    533       ! 
    534       ii = 1 
    535       WRITE(ldtxt(ii),*) '           '                                                    ;   ii = ii+1 
    536       WRITE(ldtxt(ii),*) 'domain_cfg : domain size read in ', TRIM( cn_domcfg ), ' file'  ;   ii = ii+1 
    537       WRITE(ldtxt(ii),*) '~~~~~~~~~~ '                                                    ;   ii = ii+1 
     535      REAL(wp) ::   zperio                        !   -      - 
     536      INTEGER, DIMENSION(4) ::   idvar, idimsz    ! size   of dimensions 
     537      !!---------------------------------------------------------------------- 
     538      ! 
     539      IF(lwp) THEN 
     540         WRITE(numout,*) '           ' 
     541         WRITE(numout,*) 'domain_cfg : domain size read in ', TRIM( cn_domcfg ), ' file' 
     542         WRITE(numout,*) '~~~~~~~~~~ ' 
     543      ENDIF 
    538544      ! 
    539545      CALL iom_open( cn_domcfg, inum ) 
    … …  
    546552         CALL iom_get( inum, 'ORCA_index', zorca_res )   ;   kk_cfg = NINT( zorca_res ) 
    547553         ! 
    548          WRITE(ldtxt(ii),*) '   .'                                                     ;   ii = ii+1 
    549          WRITE(ldtxt(ii),*) '   ==>>>   ORCA configuration '                           ;   ii = ii+1 
    550          WRITE(ldtxt(ii),*) '   .'                                                     ;   ii = ii+1 
     554         IF(lwp) THEN 
     555            WRITE(numout,*) '   .' 
     556            WRITE(numout,*) '   ==>>>   ORCA configuration ' 
     557            WRITE(numout,*) '   .' 
     558         ENDIF 
    551559         ! 
    552560      ELSE                                !- cd_cfg & k_cfg are not used 
    … …  
    561569         ! 
    562570      ENDIF 
    563       ! 
    564       CALL iom_get( inum, 'jpiglo', ziglo  )   ;   kpi = NINT( ziglo ) 
    565       CALL iom_get( inum, 'jpjglo', zjglo  )   ;   kpj = NINT( zjglo ) 
    566       CALL iom_get( inum, 'jpkglo', zkglo  )   ;   kpk = NINT( zkglo ) 
     571       ! 
     572      idvar = iom_varid( inum, 'e3t_0', kdimsz = idimsz )   ! use e3t_0, that must exist, to get jp(ijk)glo 
     573      kpi = idimsz(1) 
     574      kpj = idimsz(2) 
     575      kpk = idimsz(3) 
    567576      CALL iom_get( inum, 'jperio', zperio )   ;   kperio = NINT( zperio ) 
    568577      CALL iom_close( inum ) 
    569578      ! 
    570       WRITE(ldtxt(ii),*) '      cn_cfg = ', TRIM(cd_cfg), '   nn_cfg = ', kk_cfg             ;   ii = ii+1 
    571       WRITE(ldtxt(ii),*) '      jpiglo = ', kpi                                              ;   ii = ii+1 
    572       WRITE(ldtxt(ii),*) '      jpjglo = ', kpj                                              ;   ii = ii+1 
    573       WRITE(ldtxt(ii),*) '      jpkglo = ', kpk                                              ;   ii = ii+1 
    574       WRITE(ldtxt(ii),*) '      type of global domain lateral boundary   jperio = ', kperio  ;   ii = ii+1 
     579      IF(lwp) THEN 
     580         WRITE(numout,*) '      cn_cfg = ', TRIM(cd_cfg), '   nn_cfg = ', kk_cfg 
     581         WRITE(numout,*) '      jpiglo = ', kpi 
     582         WRITE(numout,*) '      jpjglo = ', kpj 
     583         WRITE(numout,*) '      jpkglo = ', kpk 
     584         WRITE(numout,*) '      type of global domain lateral boundary   jperio = ', kperio 
     585      ENDIF 
    575586      !         
    576587   END SUBROUTINE domain_cfg 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DOM/dommsk.F90

    r10425 r11822  
    100100         &             ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & 
    101101         &             cn_ice, nn_ice_dta,                                     & 
    102          &             rn_ice_tem, rn_ice_sal, rn_ice_age,                     & 
    103          &             ln_vol, nn_volctl, nn_rimwidth, nb_jpk_bdy 
     102         &             ln_vol, nn_volctl, nn_rimwidth 
    104103      !!--------------------------------------------------------------------- 
    105104      ! 
    106105      REWIND( numnam_ref )              ! Namelist namlbc in reference namelist : Lateral momentum boundary condition 
    107106      READ  ( numnam_ref, namlbc, IOSTAT = ios, ERR = 901 ) 
    108 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namlbc in reference namelist', lwp ) 
     107901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namlbc in reference namelist' ) 
    109108      REWIND( numnam_cfg )              ! Namelist namlbc in configuration namelist : Lateral momentum boundary condition 
    110109      READ  ( numnam_cfg, namlbc, IOSTAT = ios, ERR = 902 ) 
    111 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namlbc in configuration namelist', lwp ) 
     110902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namlbc in configuration namelist' ) 
    112111      IF(lwm) WRITE ( numond, namlbc ) 
    113112       
    … …  
    142141            ENDIF 
    143142         END DO   
    144       END DO   
    145 !SF  add here lbc_lnk: bug not still understood : cause now domain configuration is read ! 
    146 !!gm I don't understand why...   
     143      END DO 
     144      ! 
     145      ! the following call is mandatory 
     146      ! it masks boundaries (bathy=0) where needed depending on the configuration (closed, periodic...)   
    147147      CALL lbc_lnk( 'dommsk', tmask  , 'T', 1._wp )      ! Lateral boundary conditions 
    148148 
    … …  
    150150      REWIND( numnam_ref )              ! Namelist nambdy in reference namelist :Unstructured open boundaries 
    151151      READ  ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) 
    152 903   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambdy in reference namelist', lwp ) 
     152903   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambdy in reference namelist' ) 
    153153      REWIND( numnam_cfg )              ! Namelist nambdy in configuration namelist :Unstructured open boundaries 
    154154      READ  ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 ) 
    155 904   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambdy in configuration namelist', lwp ) 
     155904   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambdy in configuration namelist' ) 
    156156      ! ------------------------ 
    157157      IF ( ln_bdy .AND. ln_mask_file ) THEN 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DOM/domvvl.F90

    r11483 r11822  
    331331      END DO 
    332332      ! 
    333       IF( ln_vvl_ztilde .OR. ln_vvl_layer .AND. ll_do_bclinic ) THEN   ! z_tilde or layer coordinate ! 
    334          !                                                            ! ------baroclinic part------ ! 
     333      IF( (ln_vvl_ztilde .OR. ln_vvl_layer) .AND. ll_do_bclinic ) THEN   ! z_tilde or layer coordinate ! 
     334         !                                                               ! ------baroclinic part------ ! 
    335335         ! I - initialization 
    336336         ! ================== 
    … …  
    989989      REWIND( numnam_ref )              ! Namelist nam_vvl in reference namelist :  
    990990      READ  ( numnam_ref, nam_vvl, IOSTAT = ios, ERR = 901) 
    991 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nam_vvl in reference namelist', lwp ) 
     991901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nam_vvl in reference namelist' ) 
    992992      REWIND( numnam_cfg )              ! Namelist nam_vvl in configuration namelist : Parameters of the run 
    993993      READ  ( numnam_cfg, nam_vvl, IOSTAT = ios, ERR = 902 ) 
    994 902   IF( ios >  0 ) CALL ctl_nam ( ios , 'nam_vvl in configuration namelist', lwp ) 
     994902   IF( ios >  0 ) CALL ctl_nam ( ios , 'nam_vvl in configuration namelist' ) 
    995995      IF(lwm) WRITE ( numond, nam_vvl ) 
    996996      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DOM/domwri.F90

    r10425 r11822  
    162162      CALL iom_rstput( 0, 0, inum, 'isfdraft', zprt, ktype = jp_r8 )   !    ! nb of ocean T-points 
    163163      !                                                         ! vertical mesh 
    164       CALL iom_rstput( 0, 0, inum, 'e3t_0', e3t_0, ktype = jp_r8  )    !    ! scale factors 
    165       CALL iom_rstput( 0, 0, inum, 'e3u_0', e3u_0, ktype = jp_r8  ) 
    166       CALL iom_rstput( 0, 0, inum, 'e3v_0', e3v_0, ktype = jp_r8  ) 
    167       CALL iom_rstput( 0, 0, inum, 'e3w_0', e3w_0, ktype = jp_r8  ) 
     164      CALL iom_rstput( 0, 0, inum, 'e3t_1d', e3t_1d, ktype = jp_r8  )    !    ! scale factors 
     165      CALL iom_rstput( 0, 0, inum, 'e3w_1d', e3w_1d, ktype = jp_r8  ) 
     166       
     167      CALL iom_rstput( 0, 0, inum, 'e3t_0' , e3t_0 , ktype = jp_r8  ) 
     168      CALL iom_rstput( 0, 0, inum, 'e3u_0' , e3u_0 , ktype = jp_r8  ) 
     169      CALL iom_rstput( 0, 0, inum, 'e3v_0' , e3v_0 , ktype = jp_r8  ) 
     170      CALL iom_rstput( 0, 0, inum, 'e3f_0' , e3f_0 , ktype = jp_r8  ) 
     171      CALL iom_rstput( 0, 0, inum, 'e3w_0' , e3w_0 , ktype = jp_r8  ) 
     172      CALL iom_rstput( 0, 0, inum, 'e3uw_0', e3uw_0, ktype = jp_r8  ) 
     173      CALL iom_rstput( 0, 0, inum, 'e3vw_0', e3vw_0, ktype = jp_r8  ) 
    168174      ! 
    169175      CALL iom_rstput( 0, 0, inum, 'gdept_1d' , gdept_1d , ktype = jp_r8 )  ! stretched system 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DOM/dtatsd.F90

    r10213 r11822  
    6767      REWIND( numnam_ref )              ! Namelist namtsd in reference namelist :  
    6868      READ  ( numnam_ref, namtsd, IOSTAT = ios, ERR = 901) 
    69 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtsd in reference namelist', lwp ) 
     69901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtsd in reference namelist' ) 
    7070      REWIND( numnam_cfg )              ! Namelist namtsd in configuration namelist : Parameters of the run 
    7171      READ  ( numnam_cfg, namtsd, IOSTAT = ios, ERR = 902 ) 
    72 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtsd in configuration namelist', lwp ) 
     72902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtsd in configuration namelist' ) 
    7373      IF(lwm) WRITE ( numond, namtsd ) 
    7474 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DOM/iscplhsb.F90

    r10978 r11822  
    187187!      CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1.) 
    188188!      CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1.) 
    189       STOP ' iscpl_cons:   please modify this module !' 
     189      CALL ctl_stop( 'STOP', ' iscpl_cons:   please modify this MODULE !' ) 
    190190!!gm end 
    191191      ! if no neighbour wet cell in case of 2close a cell", need to find the nearest wet point  

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DOM/iscplini.F90

    r10425 r11822  
    6464      REWIND( numnam_ref )              ! Namelist namsbc_iscpl in reference namelist : Ice sheet coupling 
    6565      READ  ( numnam_ref, namsbc_iscpl, IOSTAT = ios, ERR = 901) 
    66 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_iscpl in reference namelist', lwp ) 
     66901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_iscpl in reference namelist' ) 
    6767      REWIND( numnam_cfg )              ! Namelist namsbc_iscpl in configuration namelist : Ice Sheet coupling 
    6868      READ  ( numnam_cfg, namsbc_iscpl, IOSTAT = ios, ERR = 902 ) 
    69 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_iscpl in configuration namelist', lwp ) 
     69902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_iscpl in configuration namelist' ) 
    7070      IF(lwm) WRITE ( numond, namsbc_iscpl ) 
    7171      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DYN/dynadv.F90

    r10893 r11822  
    108108      REWIND( numnam_ref )              ! Namelist namdyn_adv in reference namelist : Momentum advection scheme 
    109109      READ  ( numnam_ref, namdyn_adv, IOSTAT = ios, ERR = 901) 
    110 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_adv in reference namelist', lwp ) 
     110901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_adv in reference namelist' ) 
    111111      REWIND( numnam_cfg )              ! Namelist namdyn_adv in configuration namelist : Momentum advection scheme 
    112112      READ  ( numnam_cfg, namdyn_adv, IOSTAT = ios, ERR = 902 ) 
    113 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_adv in configuration namelist', lwp ) 
     113902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_adv in configuration namelist' ) 
    114114      IF(lwm) WRITE ( numond, namdyn_adv ) 
    115115 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DYN/dynhpg.F90

    r10946 r11822  
    3737   USE trd_oce         ! trends: ocean variables 
    3838   USE trddyn          ! trend manager: dynamics 
    39 !jc   USE zpshde          ! partial step: hor. derivative     (zps_hde routine) 
     39   USE zpshde          ! partial step: hor. derivative     (zps_hde routine) 
    4040   ! 
    4141   USE in_out_manager  ! I/O manager 
    … …  
    157157      REWIND( numnam_ref )              ! Namelist namdyn_hpg in reference namelist : Hydrostatic pressure gradient 
    158158      READ  ( numnam_ref, namdyn_hpg, IOSTAT = ios, ERR = 901) 
    159 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_hpg in reference namelist', lwp ) 
     159901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_hpg in reference namelist' ) 
    160160      ! 
    161161      REWIND( numnam_cfg )              ! Namelist namdyn_hpg in configuration namelist : Hydrostatic pressure gradient 
    162162      READ  ( numnam_cfg, namdyn_hpg, IOSTAT = ios, ERR = 902 ) 
    163 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_hpg in configuration namelist', lwp ) 
     163902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_hpg in configuration namelist' ) 
    164164      IF(lwm) WRITE ( numond, namdyn_hpg ) 
    165165      ! 
    … …  
    347347      REAL(wp) ::   zcoef0, zcoef1, zcoef2, zcoef3   ! temporary scalars 
    348348      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zhpi, zhpj 
     349      REAL(wp), DIMENSION(jpi,jpj) :: zgtsu, zgtsv, zgru, zgrv 
    349350      !!---------------------------------------------------------------------- 
    350351      ! 
    … …  
    355356      ENDIF 
    356357 
    357       ! Partial steps: bottom before horizontal gradient of t, s, rd at the last ocean level 
    358 !jc      CALL zps_hde    ( kt, jpts, ts(:,:,:,:,Kmm), gtsu, gtsv, rhd, gru , grv ) 
     358      ! Partial steps: Compute NOW horizontal gradient of t, s, rd at the last ocean level 
     359      CALL zps_hde( kt, Kmm, jpts, ts(:,:,:,:,Kmm), zgtsu, zgtsv, rhd, zgru , zgrv ) 
    359360 
    360361      ! Local constant initialization 
    … …  
    394395      END DO 
    395396 
    396       ! partial steps correction at the last level  (use gru & grv computed in zpshde.F90) 
     397      ! partial steps correction at the last level  (use zgru & zgrv computed in zpshde.F90) 
    397398      DO jj = 2, jpjm1 
    398399         DO ji = 2, jpim1 
    … …  
    404405               puu  (ji,jj,iku,Krhs) = puu(ji,jj,iku,Krhs) - zhpi(ji,jj,iku)         ! subtract old value 
    405406               zhpi(ji,jj,iku) = zhpi(ji,jj,iku-1)                   &   ! compute the new one 
    406                   &            + zcoef2 * ( rhd(ji+1,jj,iku-1) - rhd(ji,jj,iku-1) + gru(ji,jj) ) * r1_e1u(ji,jj) 
     407                  &            + zcoef2 * ( rhd(ji+1,jj,iku-1) - rhd(ji,jj,iku-1) + zgru(ji,jj) ) * r1_e1u(ji,jj) 
    407408               puu  (ji,jj,iku,Krhs) = puu(ji,jj,iku,Krhs) + zhpi(ji,jj,iku)         ! add the new one to the general momentum trend 
    408409            ENDIF 
    … …  
    410411               pvv  (ji,jj,ikv,Krhs) = pvv(ji,jj,ikv,Krhs) - zhpj(ji,jj,ikv)         ! subtract old value 
    411412               zhpj(ji,jj,ikv) = zhpj(ji,jj,ikv-1)                   &   ! compute the new one 
    412                   &            + zcoef3 * ( rhd(ji,jj+1,ikv-1) - rhd(ji,jj,ikv-1) + grv(ji,jj) ) * r1_e2v(ji,jj) 
     413                  &            + zcoef3 * ( rhd(ji,jj+1,ikv-1) - rhd(ji,jj,ikv-1) + zgrv(ji,jj) ) * r1_e2v(ji,jj) 
    413414               pvv  (ji,jj,ikv,Krhs) = pvv(ji,jj,ikv,Krhs) + zhpj(ji,jj,ikv)         ! add the new one to the general momentum trend 
    414415            ENDIF 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DYN/dynkeg.F90

    r10946 r11822  
    7676      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) ::  puu, pvv         ! ocean velocities and RHS of momentum equation 
    7777      ! 
    78       INTEGER  ::   ji, jj, jk, jb    ! dummy loop indices 
    79       INTEGER  ::   ii, ifu, ib_bdy   ! local integers 
    80       INTEGER  ::   ij, ifv, igrd     !   -       - 
    81       REAL(wp) ::   zu, zv            ! local scalars 
     78      INTEGER  ::   ji, jj, jk             ! dummy loop indices 
     79      REAL(wp) ::   zu, zv                   ! local scalars 
    8280      REAL(wp), DIMENSION(jpi,jpj,jpk)        ::   zhke 
    8381      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdu, ztrdv  
    … …  
    9997       
    10098      zhke(:,:,jpk) = 0._wp 
    101        
    102       IF (ln_bdy) THEN 
    103          ! Maria Luneva & Fred Wobus: July-2016 
    104          ! compensate for lack of turbulent kinetic energy on liquid bdy points 
    105          DO ib_bdy = 1, nb_bdy 
    106             IF( cn_dyn3d(ib_bdy) /= 'none' ) THEN 
    107                igrd = 2           ! Copying normal velocity into points outside bdy 
    108                DO jb = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 
    109                   DO jk = 1, jpkm1 
    110                      ii   = idx_bdy(ib_bdy)%nbi(jb,igrd) 
    111                      ij   = idx_bdy(ib_bdy)%nbj(jb,igrd) 
    112                      ifu   = NINT( idx_bdy(ib_bdy)%flagu(jb,igrd) ) 
    113                      puu(ii-ifu,ij,jk,Kmm) = puu(ii,ij,jk,Kmm) * umask(ii,ij,jk) 
    114                   END DO 
    115                END DO 
    116                ! 
    117                igrd = 3           ! Copying normal velocity into points outside bdy 
    118                DO jb = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 
    119                   DO jk = 1, jpkm1 
    120                      ii   = idx_bdy(ib_bdy)%nbi(jb,igrd) 
    121                      ij   = idx_bdy(ib_bdy)%nbj(jb,igrd) 
    122                      ifv   = NINT( idx_bdy(ib_bdy)%flagv(jb,igrd) ) 
    123                      pvv(ii,ij-ifv,jk,Kmm) = pvv(ii,ij,jk,Kmm) * vmask(ii,ij,jk) 
    124                   END DO 
    125                END DO 
    126             ENDIF 
    127          ENDDO   
    128       ENDIF  
    12999 
    130100      SELECT CASE ( kscheme )             !== Horizontal kinetic energy at T-point  ==! 
    … …  
    142112            END DO 
    143113         END DO 
    144          ! 
    145114      CASE ( nkeg_HW )                          !--  Hollingsworth scheme  --! 
    146115         DO jk = 1, jpkm1 
    … …  
    162131         CALL lbc_lnk( 'dynkeg', zhke, 'T', 1. ) 
    163132         ! 
    164       END SELECT 
    165  
    166       IF (ln_bdy) THEN 
    167          ! restore velocity masks at points outside boundary 
    168          puu(:,:,:,Kmm) = puu(:,:,:,Kmm) * umask(:,:,:) 
    169          pvv(:,:,:,Kmm) = pvv(:,:,:,Kmm) * vmask(:,:,:) 
    170       ENDIF       
    171  
     133      END SELECT  
    172134      ! 
    173135      DO jk = 1, jpkm1                    !==  grad( KE ) added to the general momentum trends  ==! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DYN/dynspg.F90

    r10946 r11822  
    205205      REWIND( numnam_ref )              ! Namelist namdyn_spg in reference namelist : Free surface 
    206206      READ  ( numnam_ref, namdyn_spg, IOSTAT = ios, ERR = 901) 
    207 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_spg in reference namelist', lwp ) 
     207901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_spg in reference namelist' ) 
    208208      ! 
    209209      REWIND( numnam_cfg )              ! Namelist namdyn_spg in configuration namelist : Free surface 
    210210      READ  ( numnam_cfg, namdyn_spg, IOSTAT = ios, ERR = 902 ) 
    211 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_spg in configuration namelist', lwp ) 
     211902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_spg in configuration namelist' ) 
    212212      IF(lwm) WRITE ( numond, namdyn_spg ) 
    213213      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DYN/dynspg_ts.F90

    r11480 r11822  
    6464   USE diatmb          ! Top,middle,bottom output 
    6565 
     66   USE iom   ! to remove 
     67 
    6668   IMPLICIT NONE 
    6769   PRIVATE 
    … …  
    104106      ! 
    105107      ALLOCATE( wgtbtp1(3*nn_baro), wgtbtp2(3*nn_baro), zwz(jpi,jpj), STAT=ierr(1) ) 
    106       ! 
    107108      IF( ln_dynvor_een .OR. ln_dynvor_eeT )   & 
    108          &     ALLOCATE( ftnw(jpi,jpj) , ftne(jpi,jpj) , &  
    109          &               ftsw(jpi,jpj) , ftse(jpi,jpj) , STAT=ierr(2) ) 
     109         &     ALLOCATE( ftnw(jpi,jpj) , ftne(jpi,jpj) , ftsw(jpi,jpj) , ftse(jpi,jpj), STAT=ierr(2)   ) 
    110110         ! 
    111111      ALLOCATE( un_adv(jpi,jpj), vn_adv(jpi,jpj)                    , STAT=ierr(3) ) 
    … …  
    152152      LOGICAL  ::   ll_fw_start           ! =T : forward integration  
    153153      LOGICAL  ::   ll_init               ! =T : special startup of 2d equations 
    154       LOGICAL  ::   ll_tmp1, ll_tmp2      ! local logical variables used in W/D 
    155       INTEGER  ::   ikbu, iktu, noffset   ! local integers 
    156       INTEGER  ::   ikbv, iktv            !   -      - 
    157       REAL(wp) ::   r1_2dt_b, z2dt_bf               ! local scalars 
    158       REAL(wp) ::   zx1, zx2, zu_spg, zhura, z1_hu  !   -      - 
    159       REAL(wp) ::   zy1, zy2, zv_spg, zhvra, z1_hv  !   -      - 
     154      INTEGER  ::   noffset               ! local integers  : time offset for bdy update 
     155      REAL(wp) ::   r1_2dt_b, z1_hu, z1_hv          ! local scalars 
    160156      REAL(wp) ::   za0, za1, za2, za3              !   -      - 
    161       REAL(wp) ::   zmdi, zztmp            , z1_ht  !   -      - 
    162       REAL(wp), DIMENSION(jpi,jpj) :: zsshp2_e, zhf 
    163       REAL(wp), DIMENSION(jpi,jpj) :: zwx, zu_trd, zu_frc, zssh_frc 
    164       REAL(wp), DIMENSION(jpi,jpj) :: zwy, zv_trd, zv_frc, zhdiv 
    165       REAL(wp), DIMENSION(jpi,jpj) :: zsshu_a, zhup2_e, zhust_e, zhtp2_e 
    166       REAL(wp), DIMENSION(jpi,jpj) :: zsshv_a, zhvp2_e, zhvst_e 
     157      REAL(wp) ::   zmdi, zztmp, zldg               !   -      - 
     158      REAL(wp) ::   zhu_bck, zhv_bck, zhdiv         !   -      - 
     159      REAL(wp) ::   zun_save, zvn_save              !   -      - 
     160      REAL(wp), DIMENSION(jpi,jpj) :: zu_trd, zu_frc, zu_spg, zssh_frc 
     161      REAL(wp), DIMENSION(jpi,jpj) :: zv_trd, zv_frc, zv_spg 
     162      REAL(wp), DIMENSION(jpi,jpj) :: zsshu_a, zhup2_e, zhtp2_e 
     163      REAL(wp), DIMENSION(jpi,jpj) :: zsshv_a, zhvp2_e, zsshp2_e 
    167164      REAL(wp), DIMENSION(jpi,jpj) :: zCdU_u, zCdU_v   ! top/bottom stress at u- & v-points 
     165      REAL(wp), DIMENSION(jpi,jpj) :: zhU, zhV         ! fluxes 
    168166      ! 
    169167      REAL(wp) ::   zwdramp                     ! local scalar - only used if ln_wd_dl = .True.  
    … …  
    185183      zwdramp = r_rn_wdmin1               ! simplest ramp  
    186184!     zwdramp = 1._wp / (rn_wdmin2 - rn_wdmin1) ! more general ramp 
    187       !                                         ! reciprocal of baroclinic time step  
    188       IF( kt == nit000 .AND. neuler == 0 ) THEN   ;   z2dt_bf =          rdt 
    189       ELSE                                        ;   z2dt_bf = 2.0_wp * rdt 
    190       ENDIF 
    191       r1_2dt_b = 1.0_wp / z2dt_bf  
     185      !                                         ! inverse of baroclinic time step  
     186      IF( kt == nit000 .AND. neuler == 0 ) THEN   ;   r1_2dt_b = 1._wp / (         rdt ) 
     187      ELSE                                        ;   r1_2dt_b = 1._wp / ( 2._wp * rdt ) 
     188      ENDIF 
    192189      ! 
    193190      ll_init     = ln_bt_av                    ! if no time averaging, then no specific restart  
    … …  
    213210            ll_fw_start =.FALSE. 
    214211         ENDIF 
    215          ! 
    216          ! Set averaging weights and cycle length: 
     212         !                    ! Set averaging weights and cycle length: 
    217213         CALL ts_wgt( ln_bt_av, ll_fw_start, icycle, wgtbtp1, wgtbtp2 ) 
    218214         ! 
    219       ENDIF 
    220       ! 
    221       IF( ln_isfcav ) THEN    ! top+bottom friction (ocean cavities) 
    222          DO jj = 2, jpjm1 
    223             DO ji = fs_2, fs_jpim1   ! vector opt. 
    224                zCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) + rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) 
    225                zCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) + rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) 
    226             END DO 
    227          END DO 
    228       ELSE                    ! bottom friction only 
    229          DO jj = 2, jpjm1 
    230             DO ji = fs_2, fs_jpim1   ! vector opt. 
    231                zCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) 
    232                zCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) 
    233             END DO 
    234          END DO 
    235       ENDIF 
    236       ! 
    237       ! Set arrays to remove/compute coriolis trend. 
    238       ! Do it once at kt=nit000 if volume is fixed, else at each long time step. 
    239       ! Note that these arrays are also used during barotropic loop. These are however frozen 
    240       ! although they should be updated in the variable volume case. Not a big approximation. 
    241       ! To remove this approximation, copy lines below inside barotropic loop 
    242       ! and update depths at T-F points (ht and zhf resp.) at each barotropic time step 
    243       ! 
    244       IF( kt == nit000 .OR. .NOT.ln_linssh ) THEN 
    245          ! 
    246          SELECT CASE( nvor_scheme ) 
    247          CASE( np_EEN )                != EEN scheme using e3f (energy & enstrophy scheme) 
    248             SELECT CASE( nn_een_e3f )              !* ff_f/e3 at F-point 
    249             CASE ( 0 )                                   ! original formulation  (masked averaging of e3t divided by 4) 
    250                DO jj = 1, jpjm1 
    251                   DO ji = 1, jpim1 
    252                      zwz(ji,jj) =   ( ht(ji  ,jj+1) + ht(ji+1,jj+1) +                    & 
    253                         &             ht(ji  ,jj  ) + ht(ji+1,jj  )   ) * 0.25_wp   
    254                      IF( zwz(ji,jj) /= 0._wp )   zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 
    255                   END DO 
    256                END DO 
    257             CASE ( 1 )                                   ! new formulation  (masked averaging of e3t divided by the sum of mask) 
    258                DO jj = 1, jpjm1 
    259                   DO ji = 1, jpim1 
    260                      zwz(ji,jj) =             (  ht  (ji  ,jj+1) + ht  (ji+1,jj+1)      & 
    261                         &                      + ht  (ji  ,jj  ) + ht  (ji+1,jj  )  )   & 
    262                         &       / ( MAX( 1._wp,  ssmask(ji  ,jj+1) + ssmask(ji+1,jj+1)      & 
    263                         &                      + ssmask(ji  ,jj  ) + ssmask(ji+1,jj  )  )   ) 
    264                      IF( zwz(ji,jj) /= 0._wp )   zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 
    265                   END DO 
    266                END DO 
    267             END SELECT 
    268             CALL lbc_lnk( 'dynspg_ts', zwz, 'F', 1._wp ) 
    269             ! 
    270             ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 
    271             DO jj = 2, jpj 
    272                DO ji = 2, jpi 
    273                   ftne(ji,jj) = zwz(ji-1,jj  ) + zwz(ji  ,jj  ) + zwz(ji  ,jj-1) 
    274                   ftnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj  ) + zwz(ji  ,jj  ) 
    275                   ftse(ji,jj) = zwz(ji  ,jj  ) + zwz(ji  ,jj-1) + zwz(ji-1,jj-1) 
    276                   ftsw(ji,jj) = zwz(ji  ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj  ) 
    277                END DO 
    278             END DO 
    279             ! 
    280          CASE( np_EET )                  != EEN scheme using e3t (energy conserving scheme) 
    281             ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 
    282             DO jj = 2, jpj 
    283                DO ji = 2, jpi 
    284                   z1_ht = ssmask(ji,jj) / ( ht(ji,jj) + 1._wp - ssmask(ji,jj) ) 
    285                   ftne(ji,jj) = ( ff_f(ji-1,jj  ) + ff_f(ji  ,jj  ) + ff_f(ji  ,jj-1) ) * z1_ht 
    286                   ftnw(ji,jj) = ( ff_f(ji-1,jj-1) + ff_f(ji-1,jj  ) + ff_f(ji  ,jj  ) ) * z1_ht 
    287                   ftse(ji,jj) = ( ff_f(ji  ,jj  ) + ff_f(ji  ,jj-1) + ff_f(ji-1,jj-1) ) * z1_ht 
    288                   ftsw(ji,jj) = ( ff_f(ji  ,jj-1) + ff_f(ji-1,jj-1) + ff_f(ji-1,jj  ) ) * z1_ht 
    289                END DO 
    290             END DO 
    291             ! 
    292          CASE( np_ENE, np_ENS , np_MIX )  != all other schemes (ENE, ENS, MIX) except ENT ! 
    293             ! 
    294             zwz(:,:) = 0._wp 
    295             zhf(:,:) = 0._wp 
    296              
    297 !!gm  assume 0 in both cases (which is almost surely WRONG ! ) as hvatf has been removed  
    298 !!gm    A priori a better value should be something like : 
    299 !!gm          zhf(i,j) = masked sum of  ht(i,j) , ht(i+1,j) , ht(i,j+1) , (i+1,j+1)  
    300 !!gm                     divided by the sum of the corresponding mask  
    301 !!gm  
    302 !!             
    303             IF( .NOT.ln_sco ) THEN 
    304    
    305    !!gm  agree the JC comment  : this should be done in a much clear way 
    306    
    307    ! JC: It not clear yet what should be the depth at f-points over land in z-coordinate case 
    308    !     Set it to zero for the time being  
    309    !              IF( rn_hmin < 0._wp ) THEN    ;   jk = - INT( rn_hmin )                                      ! from a nb of level 
    310    !              ELSE                          ;   jk = MINLOC( gdepw_0, mask = gdepw_0 > rn_hmin, dim = 1 )  ! from a depth 
    311    !              ENDIF 
    312    !              zhf(:,:) = gdepw_0(:,:,jk+1) 
    313                ! 
    314             ELSE 
    315                ! 
    316                !zhf(:,:) = hbatf(:,:) 
    317                DO jj = 1, jpjm1 
    318                   DO ji = 1, jpim1 
    319                      zhf(ji,jj) =    (   ht_0  (ji,jj  ) + ht_0  (ji+1,jj  )          & 
    320                         &              + ht_0  (ji,jj+1) + ht_0  (ji+1,jj+1)   )      & 
    321                         &       / MAX(   ssmask(ji,jj  ) + ssmask(ji+1,jj  )          & 
    322                         &              + ssmask(ji,jj+1) + ssmask(ji+1,jj+1) , 1._wp  ) 
    323                   END DO 
    324                END DO 
    325             ENDIF 
    326             ! 
    327             DO jj = 1, jpjm1 
    328                zhf(:,jj) = zhf(:,jj) * (1._wp- umask(:,jj,1) * umask(:,jj+1,1)) 
    329             END DO 
    330             ! 
    331             DO jk = 1, jpkm1 
    332                DO jj = 1, jpjm1 
    333                   zhf(:,jj) = zhf(:,jj) + e3f(:,jj,jk) * umask(:,jj,jk) * umask(:,jj+1,jk) 
    334                END DO 
    335             END DO 
    336             CALL lbc_lnk( 'dynspg_ts', zhf, 'F', 1._wp ) 
    337             ! JC: TBC. hf should be greater than 0  
    338             DO jj = 1, jpj 
    339                DO ji = 1, jpi 
    340                   IF( zhf(ji,jj) /= 0._wp )   zwz(ji,jj) = 1._wp / zhf(ji,jj) ! zhf is actually hf here but it saves an array 
    341                END DO 
    342             END DO 
    343             zwz(:,:) = ff_f(:,:) * zwz(:,:) 
    344          END SELECT 
    345215      ENDIF 
    346216      ! 
    … …  
    351221         CALL ts_wgt( ln_bt_av, ll_fw_start, icycle, wgtbtp1, wgtbtp2 ) 
    352222      ENDIF 
     223      ! 
    353224                           
    354225      ! ----------------------------------------------------------------------------- 
    … …  
    357228      !       
    358229      ! 
    359       !                                   !* e3*d/dt(Ua) (Vertically integrated) 
    360       !                                   ! -------------------------------------------------- 
    361       zu_frc(:,:) = 0._wp 
    362       zv_frc(:,:) = 0._wp 
    363       ! 
    364       DO jk = 1, jpkm1 
    365          zu_frc(:,:) = zu_frc(:,:) + e3u(:,:,jk,Kmm) * puu(:,:,jk,Krhs) * umask(:,:,jk) 
    366          zv_frc(:,:) = zv_frc(:,:) + e3v(:,:,jk,Kmm) * pvv(:,:,jk,Krhs) * vmask(:,:,jk)          
    367       END DO 
    368       ! 
    369       zu_frc(:,:) = zu_frc(:,:) * r1_hu(:,:,Kmm) 
    370       zv_frc(:,:) = zv_frc(:,:) * r1_hv(:,:,Kmm) 
    371       ! 
    372       ! 
    373       !                                   !* baroclinic momentum trend (remove the vertical mean trend) 
    374       DO jk = 1, jpkm1                    ! ----------------------------------------------------------- 
    375          DO jj = 2, jpjm1 
    376             DO ji = fs_2, fs_jpim1   ! vector opt. 
    377                puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - zu_frc(ji,jj) * umask(ji,jj,jk) 
    378                pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - zv_frc(ji,jj) * vmask(ji,jj,jk) 
    379             END DO 
    380          END DO 
     230      !                                   !=  zu_frc =  1/H e3*d/dt(Ua)  =!  (Vertical mean of Ua, the 3D trends) 
     231      !                                   !  ---------------------------  ! 
     232      zu_frc(:,:) = SUM( e3u(:,:,:,Kmm) * uu(:,:,:,Krhs) * umask(:,:,:) , DIM=3 ) * r1_hu(:,:,Kmm) 
     233      zv_frc(:,:) = SUM( e3v(:,:,:,Kmm) * vv(:,:,:,Krhs) * vmask(:,:,:) , DIM=3 ) * r1_hv(:,:,Kmm) 
     234      ! 
     235      ! 
     236      !                                   !=  U(Krhs) => baroclinic trend  =!   (remove its vertical mean) 
     237      DO jk = 1, jpkm1                    !  -----------------------------  ! 
     238         uu(:,:,jk,Krhs) = ( uu(:,:,jk,Krhs) - zu_frc(:,:) ) * umask(:,:,jk) 
     239         vv(:,:,jk,Krhs) = ( vv(:,:,jk,Krhs) - zv_frc(:,:) ) * vmask(:,:,jk) 
    381240      END DO 
    382241       
    … …  
    384243!!gm  Is it correct to do so ?   I think so... 
    385244       
    386        
    387       !                                   !* barotropic Coriolis trends (vorticity scheme dependent) 
    388       !                                   ! -------------------------------------------------------- 
    389       ! 
    390       zwx(:,:) = puu_b(:,:,Kmm) * hu(:,:,Kmm) * e2u(:,:)        ! now fluxes  
    391       zwy(:,:) = pvv_b(:,:,Kmm) * hv(:,:,Kmm) * e1v(:,:) 
    392       ! 
    393       SELECT CASE( nvor_scheme ) 
    394       CASE( np_ENT )                ! enstrophy conserving scheme (f-point) 
    395          DO jj = 2, jpjm1 
    396             DO ji = 2, jpim1   ! vector opt. 
    397                zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * r1_hu(ji,jj,Kmm)                    & 
    398                   &               * (  e1e2t(ji+1,jj)*ht(ji+1,jj)*ff_t(ji+1,jj) * ( pvv_b(ji+1,jj,Kmm) + pvv_b(ji+1,jj-1,Kmm) )   & 
    399                   &                  + e1e2t(ji  ,jj)*ht(ji  ,jj)*ff_t(ji  ,jj) * ( pvv_b(ji  ,jj,Kmm) + pvv_b(ji  ,jj-1,Kmm) )   ) 
    400                   ! 
    401                zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * r1_hv(ji,jj,Kmm)                    & 
    402                   &               * (  e1e2t(ji,jj+1)*ht(ji,jj+1)*ff_t(ji,jj+1) * ( puu_b(ji,jj+1,Kmm) + puu_b(ji-1,jj+1,Kmm) )   &  
    403                   &                  + e1e2t(ji,jj  )*ht(ji,jj  )*ff_t(ji,jj  ) * ( puu_b(ji,jj  ,Kmm) + puu_b(ji-1,jj  ,Kmm) )   )  
    404             END DO   
    405          END DO   
    406          !          
    407       CASE( np_ENE , np_MIX )        ! energy conserving scheme (t-point) ENE or MIX 
    408          DO jj = 2, jpjm1 
    409             DO ji = fs_2, fs_jpim1   ! vector opt. 
    410                zy1 = ( zwy(ji,jj-1) + zwy(ji+1,jj-1) ) * r1_e1u(ji,jj) 
    411                zy2 = ( zwy(ji,jj  ) + zwy(ji+1,jj  ) ) * r1_e1u(ji,jj) 
    412                zx1 = ( zwx(ji-1,jj) + zwx(ji-1,jj+1) ) * r1_e2v(ji,jj) 
    413                zx2 = ( zwx(ji  ,jj) + zwx(ji  ,jj+1) ) * r1_e2v(ji,jj) 
    414                ! energy conserving formulation for planetary vorticity term 
    415                zu_trd(ji,jj) =   r1_4 * ( zwz(ji  ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 
    416                zv_trd(ji,jj) = - r1_4 * ( zwz(ji-1,jj  ) * zx1 + zwz(ji,jj) * zx2 ) 
    417             END DO 
    418          END DO 
    419          ! 
    420       CASE( np_ENS )                ! enstrophy conserving scheme (f-point) 
    421          DO jj = 2, jpjm1 
    422             DO ji = fs_2, fs_jpim1   ! vector opt. 
    423                zy1 =   r1_8 * ( zwy(ji  ,jj-1) + zwy(ji+1,jj-1) & 
    424                  &            + zwy(ji  ,jj  ) + zwy(ji+1,jj  ) ) * r1_e1u(ji,jj) 
    425                zx1 = - r1_8 * ( zwx(ji-1,jj  ) + zwx(ji-1,jj+1) & 
    426                  &            + zwx(ji  ,jj  ) + zwx(ji  ,jj+1) ) * r1_e2v(ji,jj) 
    427                zu_trd(ji,jj)  = zy1 * ( zwz(ji  ,jj-1) + zwz(ji,jj) ) 
    428                zv_trd(ji,jj)  = zx1 * ( zwz(ji-1,jj  ) + zwz(ji,jj) ) 
    429             END DO 
    430          END DO 
    431          ! 
    432       CASE( np_EET , np_EEN )      ! energy & enstrophy scheme (using e3t or e3f)          
    433          DO jj = 2, jpjm1 
    434             DO ji = fs_2, fs_jpim1   ! vector opt. 
    435                zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * (  ftne(ji,jj  ) * zwy(ji  ,jj  ) & 
    436                 &                                         + ftnw(ji+1,jj) * zwy(ji+1,jj  ) & 
    437                 &                                         + ftse(ji,jj  ) * zwy(ji  ,jj-1) & 
    438                 &                                         + ftsw(ji+1,jj) * zwy(ji+1,jj-1) ) 
    439                zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * (  ftsw(ji,jj+1) * zwx(ji-1,jj+1) & 
    440                 &                                         + ftse(ji,jj+1) * zwx(ji  ,jj+1) & 
    441                 &                                         + ftnw(ji,jj  ) * zwx(ji-1,jj  ) & 
    442                 &                                         + ftne(ji,jj  ) * zwx(ji  ,jj  ) ) 
    443             END DO 
    444          END DO 
    445          ! 
    446       END SELECT 
    447       ! 
    448       !                                   !* Right-Hand-Side of the barotropic momentum equation 
    449       !                                   ! ---------------------------------------------------- 
    450       IF( .NOT.ln_linssh ) THEN                 ! Variable volume : remove surface pressure gradient 
    451          IF( ln_wd_il ) THEN                        ! Calculating and applying W/D gravity filters 
     245      !                                   !=  remove 2D Coriolis and pressure gradient trends  =! 
     246      !                                   !  -------------------------------------------------  ! 
     247      ! 
     248      IF( kt == nit000 .OR. .NOT. ln_linssh )   CALL dyn_cor_2D_init( Kmm )   ! Set zwz, the barotropic Coriolis force coefficient 
     249      !       ! recompute zwz = f/depth  at every time step for (.NOT.ln_linssh) as the water colomn height changes 
     250      ! 
     251      !                                         !* 2D Coriolis trends 
     252      zhU(:,:) = puu_b(:,:,Kmm) * hu(:,:,Kmm) * e2u(:,:)        ! now fluxes  
     253      zhV(:,:) = pvv_b(:,:,Kmm) * hv(:,:,Kmm) * e1v(:,:)        ! NB: FULL domain : put a value in last row and column 
     254      ! 
     255      CALL dyn_cor_2d( hu(:,:,Kmm), hv(:,:,Kmm), puu_b(:,:,Kmm), pvv_b(:,:,Kmm), zhU, zhV,  &   ! <<== in 
     256         &                                                                     zu_trd, zv_trd   )   ! ==>> out 
     257      ! 
     258      IF( .NOT.ln_linssh ) THEN                 !* surface pressure gradient   (variable volume only) 
     259         ! 
     260         IF( ln_wd_il ) THEN                       ! W/D : limiter applied to spgspg 
     261            CALL wad_spg( pssh(:,:,Kmm), zcpx, zcpy )          ! Calculating W/D gravity filters, zcpx and zcpy 
    452262            DO jj = 2, jpjm1 
    453                DO ji = 2, jpim1  
    454                   ll_tmp1 = MIN(  pssh(ji,jj,Kmm)               ,  pssh(ji+1,jj,Kmm) ) >                & 
    455                      &      MAX( -ht_0(ji,jj)               , -ht_0(ji+1,jj) ) .AND.            & 
    456                      &      MAX(  pssh(ji,jj,Kmm) + ht_0(ji,jj) ,  pssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) )  & 
    457                      &                                                         > rn_wdmin1 + rn_wdmin2 
    458                   ll_tmp2 = ( ABS( pssh(ji+1,jj,Kmm)            -  pssh(ji  ,jj,Kmm))  > 1.E-12 ).AND.( & 
    459                      &      MAX(   pssh(ji,jj,Kmm)              ,  pssh(ji+1,jj,Kmm) ) >                & 
    460                      &      MAX(  -ht_0(ji,jj)              , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 
    461                   IF(ll_tmp1) THEN 
    462                      zcpx(ji,jj) = 1.0_wp 
    463                   ELSEIF(ll_tmp2) THEN 
    464                      ! no worries about  pssh(ji+1,jj,Kmm) -  pssh(ji  ,jj,Kmm) = 0, it won't happen ! here 
    465                      zcpx(ji,jj) = ABS( (pssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) - pssh(ji,jj,Kmm) - ht_0(ji,jj)) & 
    466                                  &    / (pssh(ji+1,jj,Kmm) - pssh(ji  ,jj,Kmm)) ) 
    467                      zcpx(ji,jj) = max(min( zcpx(ji,jj) , 1.0_wp),0.0_wp) 
    468                   ELSE 
    469                      zcpx(ji,jj) = 0._wp 
    470                   ENDIF 
    471                   ! 
    472                   ll_tmp1 = MIN(  pssh(ji,jj,Kmm)               ,  pssh(ji,jj+1,Kmm) ) >                & 
    473                      &      MAX( -ht_0(ji,jj)               , -ht_0(ji,jj+1) ) .AND.            & 
    474                      &      MAX(  pssh(ji,jj,Kmm) + ht_0(ji,jj) ,  pssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) )  & 
    475                      &                                                       > rn_wdmin1 + rn_wdmin2 
    476                   ll_tmp2 = ( ABS( pssh(ji,jj,Kmm)              -  pssh(ji,jj+1,Kmm))  > 1.E-12 ).AND.( & 
    477                      &      MAX(   pssh(ji,jj,Kmm)              ,  pssh(ji,jj+1,Kmm) ) >                & 
    478                      &      MAX(  -ht_0(ji,jj)              , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 
    479    
    480                   IF(ll_tmp1) THEN 
    481                      zcpy(ji,jj) = 1.0_wp 
    482                   ELSE IF(ll_tmp2) THEN 
    483                      ! no worries about  pssh(ji,jj+1,Kmm) -  pssh(ji,jj  ,Kmm) = 0, it won't happen ! here 
    484                      zcpy(ji,jj) = ABS( (pssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) - pssh(ji,jj,Kmm) - ht_0(ji,jj)) & 
    485                         &             / (pssh(ji,jj+1,Kmm) - pssh(ji,jj  ,Kmm)) ) 
    486                      zcpy(ji,jj) = MAX(  0._wp , MIN( zcpy(ji,jj) , 1.0_wp )  ) 
    487                   ELSE 
    488                      zcpy(ji,jj) = 0._wp 
    489                   ENDIF 
    490                END DO 
    491             END DO 
    492             ! 
    493             DO jj = 2, jpjm1 
    494                DO ji = 2, jpim1 
     263               DO ji = 2, jpim1                ! SPG with the application of W/D gravity filters 
    495264                  zu_trd(ji,jj) = zu_trd(ji,jj) - grav * ( pssh(ji+1,jj  ,Kmm) - pssh(ji  ,jj ,Kmm) )   & 
    496265                     &                          * r1_e1u(ji,jj) * zcpx(ji,jj)  * wdrampu(ji,jj)  !jth 
    … …  
    499268               END DO 
    500269            END DO 
    501             ! 
    502          ELSE 
    503             ! 
     270         ELSE                                      ! now suface pressure gradient 
    504271            DO jj = 2, jpjm1 
    505272               DO ji = fs_2, fs_jpim1   ! vector opt. 
    … …  
    519286      END DO  
    520287      ! 
    521       !                                         ! Add bottom stress contribution from baroclinic velocities:       
    522       IF (ln_bt_fw) THEN 
    523          DO jj = 2, jpjm1                           
    524             DO ji = fs_2, fs_jpim1   ! vector opt. 
    525                ikbu = mbku(ji,jj)        
    526                ikbv = mbkv(ji,jj)     
    527                zwx(ji,jj) = puu(ji,jj,ikbu,Kmm) - puu_b(ji,jj,Kmm) ! NOW bottom baroclinic velocities 
    528                zwy(ji,jj) = pvv(ji,jj,ikbv,Kmm) - pvv_b(ji,jj,Kmm) 
    529             END DO 
    530          END DO 
    531       ELSE 
    532          DO jj = 2, jpjm1 
    533             DO ji = fs_2, fs_jpim1   ! vector opt. 
    534                ikbu = mbku(ji,jj)        
    535                ikbv = mbkv(ji,jj)     
    536                zwx(ji,jj) = puu(ji,jj,ikbu,Kbb) - puu_b(ji,jj,Kbb) ! BEFORE bottom baroclinic velocities 
    537                zwy(ji,jj) = pvv(ji,jj,ikbv,Kbb) - pvv_b(ji,jj,Kbb) 
    538             END DO 
    539          END DO 
    540       ENDIF 
    541       ! 
    542       ! Note that the "unclipped" bottom friction parameter is used even with explicit drag 
    543       IF( ln_wd_il ) THEN 
    544          zztmp = -1._wp / rdtbt 
    545          DO jj = 2, jpjm1 
    546             DO ji = fs_2, fs_jpim1   ! vector opt. 
    547                zu_frc(ji,jj) = zu_frc(ji,jj) + &  
    548                & MAX(r1_hu(ji,jj,Kmm) * r1_2 * ( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ), zztmp ) * zwx(ji,jj) *  wdrampu(ji,jj) 
    549                zv_frc(ji,jj) = zv_frc(ji,jj) + &  
    550                & MAX(r1_hv(ji,jj,Kmm) * r1_2 * ( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ), zztmp ) * zwy(ji,jj) *  wdrampv(ji,jj) 
    551             END DO 
    552          END DO 
    553       ELSE 
    554          DO jj = 2, jpjm1 
    555             DO ji = fs_2, fs_jpim1   ! vector opt. 
    556                zu_frc(ji,jj) = zu_frc(ji,jj) + r1_hu(ji,jj,Kmm) * r1_2 * ( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * zwx(ji,jj) 
    557                zv_frc(ji,jj) = zv_frc(ji,jj) + r1_hv(ji,jj,Kmm) * r1_2 * ( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * zwy(ji,jj) 
    558             END DO 
    559          END DO 
    560       END IF 
    561       ! 
    562       IF( ln_isfcav ) THEN       ! Add TOP stress contribution from baroclinic velocities:       
    563          IF( ln_bt_fw ) THEN 
    564             DO jj = 2, jpjm1 
     288      !                                   !=  Add bottom stress contribution from baroclinic velocities  =! 
     289      !                                   !  -----------------------------------------------------------  ! 
     290      CALL dyn_drg_init( Kbb, Kmm, puu, pvv, puu_b ,pvv_b, zu_frc, zv_frc,  zCdU_u, zCdU_v )      ! also provide the barotropic drag coefficients 
     291      !                                   !=  Add atmospheric pressure forcing  =! 
     292      !                                   !  ----------------------------------  ! 
     293      IF( ln_apr_dyn ) THEN 
     294         IF( ln_bt_fw ) THEN                          ! FORWARD integration: use kt+1/2 pressure (NOW+1/2) 
     295            DO jj = 2, jpjm1               
    565296               DO ji = fs_2, fs_jpim1   ! vector opt. 
    566                   iktu = miku(ji,jj) 
    567                   iktv = mikv(ji,jj) 
    568                   zwx(ji,jj) = puu(ji,jj,iktu,Kmm) - puu_b(ji,jj,Kmm) ! NOW top baroclinic velocities 
    569                   zwy(ji,jj) = pvv(ji,jj,iktv,Kmm) - pvv_b(ji,jj,Kmm) 
    570                END DO 
    571             END DO 
    572          ELSE 
    573             DO jj = 2, jpjm1 
     297                  zu_frc(ji,jj) = zu_frc(ji,jj) + grav * (  ssh_ib (ji+1,jj  ) - ssh_ib (ji,jj) ) * r1_e1u(ji,jj) 
     298                  zv_frc(ji,jj) = zv_frc(ji,jj) + grav * (  ssh_ib (ji  ,jj+1) - ssh_ib (ji,jj) ) * r1_e2v(ji,jj) 
     299               END DO 
     300            END DO 
     301         ELSE                                         ! CENTRED integration: use kt-1/2 + kt+1/2 pressure (NOW) 
     302            zztmp = grav * r1_2 
     303            DO jj = 2, jpjm1               
    574304               DO ji = fs_2, fs_jpim1   ! vector opt. 
    575                   iktu = miku(ji,jj) 
    576                   iktv = mikv(ji,jj) 
    577                   zwx(ji,jj) = puu(ji,jj,iktu,Kbb) - puu_b(ji,jj,Kbb) ! BEFORE top baroclinic velocities 
    578                   zwy(ji,jj) = pvv(ji,jj,iktv,Kbb) - pvv_b(ji,jj,Kbb) 
    579                END DO 
    580             END DO 
    581          ENDIF 
    582          ! 
    583          ! Note that the "unclipped" top friction parameter is used even with explicit drag 
    584          DO jj = 2, jpjm1               
    585             DO ji = fs_2, fs_jpim1   ! vector opt. 
    586                zu_frc(ji,jj) = zu_frc(ji,jj) + r1_hu(ji,jj,Kmm) * r1_2 * ( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * zwx(ji,jj) 
    587                zv_frc(ji,jj) = zv_frc(ji,jj) + r1_hv(ji,jj,Kmm) * r1_2 * ( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * zwy(ji,jj) 
    588             END DO 
    589          END DO 
    590       ENDIF 
    591       !        
     305                  zu_frc(ji,jj) = zu_frc(ji,jj) + zztmp * (  ssh_ib (ji+1,jj  ) - ssh_ib (ji,jj)  & 
     306                       &                                   + ssh_ibb(ji+1,jj  ) - ssh_ibb(ji,jj)  ) * r1_e1u(ji,jj) 
     307                  zv_frc(ji,jj) = zv_frc(ji,jj) + zztmp * (  ssh_ib (ji  ,jj+1) - ssh_ib (ji,jj)  & 
     308                       &                                   + ssh_ibb(ji  ,jj+1) - ssh_ibb(ji,jj)  ) * r1_e2v(ji,jj) 
     309               END DO 
     310            END DO 
     311         ENDIF 
     312      ENDIF 
     313      ! 
     314      !                                   !=  Add atmospheric pressure forcing  =! 
     315      !                                   !  ----------------------------------  ! 
    592316      IF( ln_bt_fw ) THEN                        ! Add wind forcing 
    593317         DO jj = 2, jpjm1 
    … …  
    607331      ENDIF   
    608332      ! 
    609       IF( ln_apr_dyn ) THEN                     ! Add atm pressure forcing 
    610          IF( ln_bt_fw ) THEN 
    611             DO jj = 2, jpjm1               
    612                DO ji = fs_2, fs_jpim1   ! vector opt. 
    613                   zu_spg =  grav * (  ssh_ib (ji+1,jj  ) - ssh_ib (ji,jj) ) * r1_e1u(ji,jj) 
    614                   zv_spg =  grav * (  ssh_ib (ji  ,jj+1) - ssh_ib (ji,jj) ) * r1_e2v(ji,jj) 
    615                   zu_frc(ji,jj) = zu_frc(ji,jj) + zu_spg 
    616                   zv_frc(ji,jj) = zv_frc(ji,jj) + zv_spg 
    617                END DO 
    618             END DO 
    619          ELSE 
    620             zztmp = grav * r1_2 
    621             DO jj = 2, jpjm1               
    622                DO ji = fs_2, fs_jpim1   ! vector opt. 
    623                   zu_spg = zztmp * (  ssh_ib (ji+1,jj  ) - ssh_ib (ji,jj)    & 
    624                       &             + ssh_ibb(ji+1,jj  ) - ssh_ibb(ji,jj)  ) * r1_e1u(ji,jj) 
    625                   zv_spg = zztmp * (  ssh_ib (ji  ,jj+1) - ssh_ib (ji,jj)    & 
    626                       &             + ssh_ibb(ji  ,jj+1) - ssh_ibb(ji,jj)  ) * r1_e2v(ji,jj) 
    627                   zu_frc(ji,jj) = zu_frc(ji,jj) + zu_spg 
    628                   zv_frc(ji,jj) = zv_frc(ji,jj) + zv_spg 
    629                END DO 
    630             END DO 
    631          ENDIF  
    632       ENDIF 
    633       !                                   !* Right-Hand-Side of the barotropic ssh equation 
    634       !                                   ! ----------------------------------------------- 
    635       !                                         ! Surface net water flux and rivers 
    636       IF (ln_bt_fw) THEN 
    637          zssh_frc(:,:) = r1_rau0 * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) ) 
    638       ELSE 
     333      !              !----------------! 
     334      !              !==  sssh_frc  ==!   Right-Hand-Side of the barotropic ssh equation   (over the FULL domain) 
     335      !              !----------------! 
     336      !                                   !=  Net water flux forcing applied to a water column  =! 
     337      !                                   ! ---------------------------------------------------  ! 
     338      IF (ln_bt_fw) THEN                          ! FORWARD integration: use kt+1/2 fluxes (NOW+1/2) 
     339         zssh_frc(:,:) = r1_rau0 * ( emp(:,:)             - rnf(:,:)              + fwfisf(:,:)                  ) 
     340      ELSE                                        ! CENTRED integration: use kt-1/2 + kt+1/2 fluxes (NOW) 
    639341         zztmp = r1_rau0 * r1_2 
    640          zssh_frc(:,:) = zztmp * (  emp(:,:) + emp_b(:,:) - rnf(:,:) - rnf_b(:,:)   & 
    641                 &                 + fwfisf(:,:) + fwfisf_b(:,:)                     ) 
    642       ENDIF 
    643       ! 
    644       IF( ln_sdw ) THEN                         ! Stokes drift divergence added if necessary 
     342         zssh_frc(:,:) = zztmp * (  emp(:,:) + emp_b(:,:) - rnf(:,:) - rnf_b(:,:) + fwfisf(:,:) + fwfisf_b(:,:)  ) 
     343      ENDIF 
     344      !                                   !=  Add Stokes drift divergence  =!   (if exist) 
     345      IF( ln_sdw ) THEN                   !  -----------------------------  ! 
    645346         zssh_frc(:,:) = zssh_frc(:,:) + div_sd(:,:) 
    646347      ENDIF 
    647348      ! 
    648349#if defined key_asminc 
    649       !                                         ! Include the IAU weighted SSH increment 
     350      !                                   !=  Add the IAU weighted SSH increment  =! 
     351      !                                   !  ------------------------------------  ! 
    650352      IF( lk_asminc .AND. ln_sshinc .AND. ln_asmiau ) THEN 
    651353         zssh_frc(:,:) = zssh_frc(:,:) - ssh_iau(:,:) 
    652354      ENDIF 
    653355#endif 
    654       !                                   !* Fill boundary data arrays for AGRIF 
     356      !                                   != Fill boundary data arrays for AGRIF 
    655357      !                                   ! ------------------------------------ 
    656358#if defined key_agrif 
    … …  
    674376         vb_e   (:,:) = 0._wp 
    675377      ENDIF 
    676  
     378      ! 
     379      IF( ln_linssh ) THEN    ! mid-step ocean depth is fixed (hup2_e=hu_n=hu_0) 
     380         zhup2_e(:,:) = hu(:,:,Kmm) 
     381         zhvp2_e(:,:) = hv(:,:,Kmm) 
     382         zhtp2_e(:,:) = ht(:,:) 
     383      ENDIF 
    677384      ! 
    678385      IF (ln_bt_fw) THEN                  ! FORWARD integration: start from NOW fields                     
    … …  
    696403      ENDIF 
    697404      ! 
    698       ! 
    699       ! 
    700405      ! Initialize sums: 
    701406      puu_b  (:,:,Kaa) = 0._wp       ! After barotropic velocities (or transport if flux form)           
    … …  
    717422         ! 
    718423         l_full_nf_update = jn == icycle   ! false: disable full North fold update (performances) for jn = 1 to icycle-1 
    719          !                                                !  ------------------ 
    720          !                                                !* Update the forcing (BDY and tides) 
    721          !                                                !  ------------------ 
    722          ! Update only tidal forcing at open boundaries 
    723          IF( ln_bdy      .AND. ln_tide )   CALL bdy_dta_tides( kt, kit=jn, time_offset= noffset+1 ) 
    724          IF( ln_tide_pot .AND. ln_tide )   CALL upd_tide     ( kt, kit=jn, time_offset= noffset   ) 
    725          ! 
    726          ! Set extrapolation coefficients for predictor step: 
     424         ! 
     425         !                    !==  Update the forcing ==! (BDY and tides) 
     426         ! 
     427         IF( ln_bdy      .AND. ln_tide )   CALL bdy_dta_tides( kt, kit=jn, kt_offset= noffset+1 ) 
     428         IF( ln_tide_pot .AND. ln_tide )   CALL upd_tide     ( kt, kit=jn, kt_offset= noffset   ) 
     429         ! 
     430         !                    !==  extrapolation at mid-step  ==!   (jn+1/2) 
     431         ! 
     432         !                       !* Set extrapolation coefficients for predictor step: 
    727433         IF ((jn<3).AND.ll_init) THEN      ! Forward            
    728434           za1 = 1._wp                                           
    … …  
    734440           za3 =  0.281105_wp              ! za3 = bet 
    735441         ENDIF 
    736  
    737          ! Extrapolate barotropic velocities at step jit+0.5: 
     442         ! 
     443         !                       !* Extrapolate barotropic velocities at mid-step (jn+1/2) 
     444         !--        m+1/2               m                m-1           m-2       --! 
     445         !--       u      = (3/2+beta) u   -(1/2+2beta) u      + beta u          --! 
     446         !-------------------------------------------------------------------------! 
    738447         ua_e(:,:) = za1 * un_e(:,:) + za2 * ub_e(:,:) + za3 * ubb_e(:,:) 
    739448         va_e(:,:) = za1 * vn_e(:,:) + za2 * vb_e(:,:) + za3 * vbb_e(:,:) 
    … …  
    742451            !                                             !  ------------------ 
    743452            ! Extrapolate Sea Level at step jit+0.5: 
     453            !--         m+1/2                 m                  m-1             m-2       --! 
     454            !--      ssh      = (3/2+beta) ssh   -(1/2+2beta) ssh      + beta ssh          --! 
     455            !--------------------------------------------------------------------------------! 
    744456            zsshp2_e(:,:) = za1 * sshn_e(:,:)  + za2 * sshb_e(:,:) + za3 * sshbb_e(:,:) 
    745457             
    746             ! set wetting & drying mask at tracer points for this barotropic sub-step  
    747             IF ( ln_wd_dl ) THEN  
    748                ! 
    749                IF ( ln_wd_dl_rmp ) THEN  
    750                   DO jj = 1, jpj                                  
    751                      DO ji = 1, jpi   ! vector opt.   
    752                         IF ( zsshp2_e(ji,jj) + ht_0(ji,jj) >  2._wp * rn_wdmin1 ) THEN  
    753 !                        IF ( zsshp2_e(ji,jj) + ht_0(ji,jj) >  rn_wdmin2 ) THEN  
    754                            ztwdmask(ji,jj) = 1._wp 
    755                         ELSE IF ( zsshp2_e(ji,jj) + ht_0(ji,jj) >  rn_wdmin1 ) THEN 
    756                            ztwdmask(ji,jj) = (tanh(50._wp*( ( zsshp2_e(ji,jj) + ht_0(ji,jj) -  rn_wdmin1 )*r_rn_wdmin1)) )  
    757                         ELSE  
    758                            ztwdmask(ji,jj) = 0._wp 
    759                         END IF 
    760                      END DO 
    761                   END DO 
    762                ELSE 
    763                   DO jj = 1, jpj                                  
    764                      DO ji = 1, jpi   ! vector opt.   
    765                         IF ( zsshp2_e(ji,jj) + ht_0(ji,jj) >  rn_wdmin1 ) THEN  
    766                            ztwdmask(ji,jj) = 1._wp 
    767                         ELSE  
    768                            ztwdmask(ji,jj) = 0._wp 
    769                         ENDIF 
    770                      END DO 
    771                   END DO 
    772                ENDIF  
    773                ! 
    774             ENDIF  
     458            ! set wetting & drying mask at tracer points for this barotropic mid-step 
     459            IF( ln_wd_dl )   CALL wad_tmsk( zsshp2_e, ztwdmask ) 
    775460            ! 
    776             DO jj = 2, jpjm1                                    ! Sea Surface Height at u- & v-points 
    777                DO ji = 2, fs_jpim1   ! Vector opt. 
    778                   zwx(ji,jj) = r1_2 * ssumask(ji,jj)  * r1_e1e2u(ji,jj)     & 
    779                      &              * ( e1e2t(ji  ,jj) * zsshp2_e(ji  ,jj)  & 
    780                      &              +   e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) 
    781                   zwy(ji,jj) = r1_2 * ssvmask(ji,jj)  * r1_e1e2v(ji,jj)     & 
    782                      &              * ( e1e2t(ji,jj  ) * zsshp2_e(ji,jj  )  & 
    783                      &              +   e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) 
    784                END DO 
    785             END DO 
    786             CALL lbc_lnk_multi( 'dynspg_ts', zwx, 'U', 1._wp, zwy, 'V', 1._wp ) 
     461            !                          ! ocean t-depth at mid-step 
     462            zhtp2_e(:,:) = ht_0(:,:) + zsshp2_e(:,:) 
    787463            ! 
    788             zhup2_e(:,:) = hu_0(:,:) + zwx(:,:)                ! Ocean depth at U- and V-points 
    789             zhvp2_e(:,:) = hv_0(:,:) + zwy(:,:) 
    790             zhtp2_e(:,:) = ht_0(:,:) + zsshp2_e(:,:) 
    791          ELSE 
    792             zhup2_e(:,:) = hu(:,:,Kmm) 
    793             zhvp2_e(:,:) = hv(:,:,Kmm) 
    794             zhtp2_e(:,:) = ht(:,:) 
    795          ENDIF 
    796          !                                                !* after ssh 
    797          !                                                !  ----------- 
    798          ! 
    799          ! Enforce volume conservation at open boundaries: 
     464            !                          ! ocean u- and v-depth at mid-step   (separate DO-loops remove the need of a lbc_lnk) 
     465            DO jj = 1, jpj 
     466               DO ji = 1, jpim1   ! not jpi-column 
     467                  zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * r1_e1e2u(ji,jj)                        & 
     468                       &                              * (  e1e2t(ji  ,jj) * zsshp2_e(ji  ,jj)  & 
     469                       &                                 + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj)  ) * ssumask(ji,jj) 
     470               END DO 
     471            END DO 
     472            DO jj = 1, jpjm1        ! not jpj-row 
     473               DO ji = 1, jpi 
     474                  zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * r1_e1e2v(ji,jj)                        & 
     475                       &                              * (  e1e2t(ji,jj  ) * zsshp2_e(ji,jj  )  & 
     476                       &                                 + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1)  ) * ssvmask(ji,jj) 
     477               END DO 
     478            END DO 
     479            ! 
     480         ENDIF 
     481         ! 
     482         !                    !==  after SSH  ==!   (jn+1) 
     483         ! 
     484         !                             ! update (ua_e,va_e) to enforce volume conservation at open boundaries 
     485         !                             ! values of zhup2_e and zhvp2_e on the halo are not needed in bdy_vol2d 
    800486         IF( ln_bdy .AND. ln_vol ) CALL bdy_vol2d( kt, jn, ua_e, va_e, zhup2_e, zhvp2_e ) 
    801487         ! 
    802          zwx(:,:) = e2u(:,:) * ua_e(:,:) * zhup2_e(:,:)         ! fluxes at jn+0.5 
    803          zwy(:,:) = e1v(:,:) * va_e(:,:) * zhvp2_e(:,:) 
     488         !                             ! resulting flux at mid-step (not over the full domain) 
     489         zhU(1:jpim1,1:jpj  ) = e2u(1:jpim1,1:jpj  ) * ua_e(1:jpim1,1:jpj  ) * zhup2_e(1:jpim1,1:jpj  )   ! not jpi-column 
     490         zhV(1:jpi  ,1:jpjm1) = e1v(1:jpi  ,1:jpjm1) * va_e(1:jpi  ,1:jpjm1) * zhvp2_e(1:jpi  ,1:jpjm1)   ! not jpj-row 
    804491         ! 
    805492#if defined key_agrif 
    … …  
    808495            IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    809496               DO jj = 1, jpj 
    810                   zwx(2:nbghostcells+1,jj) = ubdy_w(1:nbghostcells,jj) * e2u(2:nbghostcells+1,jj) 
    811                   zwy(2:nbghostcells+1,jj) = vbdy_w(1:nbghostcells,jj) * e1v(2:nbghostcells+1,jj) 
     497                  zhU(2:nbghostcells+1,jj) = ubdy_w(1:nbghostcells,jj) * e2u(2:nbghostcells+1,jj) 
     498                  zhV(2:nbghostcells+1,jj) = vbdy_w(1:nbghostcells,jj) * e1v(2:nbghostcells+1,jj) 
    812499               END DO 
    813500            ENDIF 
    814501            IF((nbondi ==  1).OR.(nbondi == 2)) THEN 
    815502               DO jj=1,jpj 
    816                   zwx(nlci-nbghostcells-1:nlci-2,jj) = ubdy_e(1:nbghostcells,jj) * e2u(nlci-nbghostcells-1:nlci-2,jj) 
    817                   zwy(nlci-nbghostcells  :nlci-1,jj) = vbdy_e(1:nbghostcells,jj) * e1v(nlci-nbghostcells  :nlci-1,jj) 
     503                  zhU(nlci-nbghostcells-1:nlci-2,jj) = ubdy_e(1:nbghostcells,jj) * e2u(nlci-nbghostcells-1:nlci-2,jj) 
     504                  zhV(nlci-nbghostcells  :nlci-1,jj) = vbdy_e(1:nbghostcells,jj) * e1v(nlci-nbghostcells  :nlci-1,jj) 
    818505               END DO 
    819506            ENDIF 
    820507            IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    821508               DO ji=1,jpi 
    822                   zwy(ji,2:nbghostcells+1) = vbdy_s(ji,1:nbghostcells) * e1v(ji,2:nbghostcells+1) 
    823                   zwx(ji,2:nbghostcells+1) = ubdy_s(ji,1:nbghostcells) * e2u(ji,2:nbghostcells+1) 
     509                  zhV(ji,2:nbghostcells+1) = vbdy_s(ji,1:nbghostcells) * e1v(ji,2:nbghostcells+1) 
     510                  zhU(ji,2:nbghostcells+1) = ubdy_s(ji,1:nbghostcells) * e2u(ji,2:nbghostcells+1) 
    824511               END DO 
    825512            ENDIF 
    826513            IF((nbondj ==  1).OR.(nbondj == 2)) THEN 
    827514               DO ji=1,jpi 
    828                   zwy(ji,nlcj-nbghostcells-1:nlcj-2) = vbdy_n(ji,1:nbghostcells) * e1v(ji,nlcj-nbghostcells-1:nlcj-2) 
    829                   zwx(ji,nlcj-nbghostcells  :nlcj-1) = ubdy_n(ji,1:nbghostcells) * e2u(ji,nlcj-nbghostcells  :nlcj-1) 
     515                  zhV(ji,nlcj-nbghostcells-1:nlcj-2) = vbdy_n(ji,1:nbghostcells) * e1v(ji,nlcj-nbghostcells-1:nlcj-2) 
     516                  zhU(ji,nlcj-nbghostcells  :nlcj-1) = ubdy_n(ji,1:nbghostcells) * e2u(ji,nlcj-nbghostcells  :nlcj-1) 
    830517               END DO 
    831518            ENDIF 
    832519         ENDIF 
    833520#endif 
    834          IF( ln_wd_il )   CALL wad_lmt_bt(zwx, zwy, sshn_e, zssh_frc, rdtbt) 
    835  
    836          IF ( ln_wd_dl ) THEN  
    837             ! 
    838             ! un_e and vn_e are set to zero at faces where the direction of the flow is from dry cells  
    839             ! 
    840             DO jj = 1, jpjm1                                  
    841                DO ji = 1, jpim1    
    842                   IF ( zwx(ji,jj) > 0.0 ) THEN  
    843                      zuwdmask(ji, jj) = ztwdmask(ji  ,jj)  
    844                   ELSE  
    845                      zuwdmask(ji, jj) = ztwdmask(ji+1,jj)   
    846                   END IF  
    847                   zwx(ji, jj) = zuwdmask(ji,jj)*zwx(ji, jj) 
    848                   un_e(ji,jj) = zuwdmask(ji,jj)*un_e(ji,jj) 
    849  
    850                   IF ( zwy(ji,jj) > 0.0 ) THEN 
    851                      zvwdmask(ji, jj) = ztwdmask(ji, jj  ) 
    852                   ELSE  
    853                      zvwdmask(ji, jj) = ztwdmask(ji, jj+1)   
    854                   END IF  
    855                   zwy(ji, jj) = zvwdmask(ji,jj)*zwy(ji,jj)  
    856                   vn_e(ji,jj) = zvwdmask(ji,jj)*vn_e(ji,jj) 
    857                END DO 
    858             END DO 
     521         IF( ln_wd_il )   CALL wad_lmt_bt(zhU, zhV, sshn_e, zssh_frc, rdtbt)    !!gm wad_lmt_bt use of lbc_lnk on zhU, zhV 
     522 
     523         IF( ln_wd_dl ) THEN           ! un_e and vn_e are set to zero at faces where  
     524            !                          ! the direction of the flow is from dry cells 
     525            CALL wad_Umsk( ztwdmask, zhU, zhV, un_e, vn_e, zuwdmask, zvwdmask )   ! not jpi colomn for U, not jpj row for V 
    859526            ! 
    860527         ENDIF     
    861           
    862          ! Sum over sub-time-steps to compute advective velocities 
    863          za2 = wgtbtp2(jn) 
    864          un_adv(:,:) = un_adv(:,:) + za2 * zwx(:,:) * r1_e2u(:,:) 
    865          vn_adv(:,:) = vn_adv(:,:) + za2 * zwy(:,:) * r1_e1v(:,:) 
    866           
    867          ! sum over sub-time-steps to decide which baroclinic velocities to set to zero (zuwdav2 is only used when ln_wd_dl_bc = True)  
     528         ! 
     529         ! 
     530         !     Compute Sea Level at step jit+1 
     531         !--           m+1        m                               m+1/2          --! 
     532         !--        ssh    =  ssh   - delta_t' * [ frc + div( flux      ) ]      --! 
     533         !-------------------------------------------------------------------------! 
     534         DO jj = 2, jpjm1        ! INNER domain                              
     535            DO ji = 2, jpim1 
     536               zhdiv = (   zhU(ji,jj) - zhU(ji-1,jj) + zhV(ji,jj) - zhV(ji,jj-1)   ) * r1_e1e2t(ji,jj) 
     537               ssha_e(ji,jj) = (  sshn_e(ji,jj) - rdtbt * ( zssh_frc(ji,jj) + zhdiv )  ) * ssmask(ji,jj) 
     538            END DO 
     539         END DO 
     540         ! 
     541         CALL lbc_lnk_multi( 'dynspg_ts', ssha_e, 'T', 1._wp,  zhU, 'U', -1._wp,  zhV, 'V', -1._wp ) 
     542         ! 
     543         !                             ! Sum over sub-time-steps to compute advective velocities 
     544         za2 = wgtbtp2(jn)             ! zhU, zhV hold fluxes extrapolated at jn+0.5 
     545         un_adv(:,:) = un_adv(:,:) + za2 * zhU(:,:) * r1_e2u(:,:) 
     546         vn_adv(:,:) = vn_adv(:,:) + za2 * zhV(:,:) * r1_e1v(:,:) 
     547         ! sum over sub-time-steps to decide which baroclinic velocities to set to zero (zuwdav2 is only used when ln_wd_dl_bc=True)  
    868548         IF ( ln_wd_dl_bc ) THEN 
    869             zuwdav2(:,:) = zuwdav2(:,:) + za2 * zuwdmask(:,:) 
    870             zvwdav2(:,:) = zvwdav2(:,:) + za2 * zvwdmask(:,:) 
    871          END IF  
    872  
    873          ! Set next sea level: 
    874          DO jj = 2, jpjm1                                  
    875             DO ji = fs_2, fs_jpim1   ! vector opt. 
    876                zhdiv(ji,jj) = (   zwx(ji,jj) - zwx(ji-1,jj)   & 
    877                   &             + zwy(ji,jj) - zwy(ji,jj-1)   ) * r1_e1e2t(ji,jj) 
    878             END DO 
    879          END DO 
    880          ssha_e(:,:) = (  sshn_e(:,:) - rdtbt * ( zssh_frc(:,:) + zhdiv(:,:) )  ) * ssmask(:,:) 
    881           
    882          CALL lbc_lnk( 'dynspg_ts', ssha_e, 'T',  1._wp ) 
    883  
     549            zuwdav2(1:jpim1,1:jpj  ) = zuwdav2(1:jpim1,1:jpj  ) + za2 * zuwdmask(1:jpim1,1:jpj  )   ! not jpi-column 
     550            zvwdav2(1:jpi  ,1:jpjm1) = zvwdav2(1:jpi  ,1:jpjm1) + za2 * zvwdmask(1:jpi  ,1:jpjm1)   ! not jpj-row 
     551         END IF 
     552         ! 
    884553         ! Duplicate sea level across open boundaries (this is only cosmetic if linssh=T) 
    885554         IF( ln_bdy )   CALL bdy_ssh( ssha_e ) 
    … …  
    890559         ! Sea Surface Height at u-,v-points (vvl case only) 
    891560         IF( .NOT.ln_linssh ) THEN                                 
    892             DO jj = 2, jpjm1 
     561            DO jj = 2, jpjm1   ! INNER domain, will be extended to whole domain later 
    893562               DO ji = 2, jpim1      ! NO Vector Opt. 
    894563                  zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj)    & 
    … …  
    900569               END DO 
    901570            END DO 
    902             CALL lbc_lnk_multi( 'dynspg_ts', zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) 
    903571         ENDIF    
    904          !                                  
    905          ! Half-step back interpolation of SSH for surface pressure computation: 
    906          !---------------------------------------------------------------------- 
    907          IF ((jn==1).AND.ll_init) THEN 
    908            za0=1._wp                        ! Forward-backward 
    909            za1=0._wp                            
    910            za2=0._wp 
    911            za3=0._wp 
    912          ELSEIF ((jn==2).AND.ll_init) THEN  ! AB2-AM3 Coefficients; bet=0 ; gam=-1/6 ; eps=1/12 
    913            za0= 1.0833333333333_wp          ! za0 = 1-gam-eps 
    914            za1=-0.1666666666666_wp          ! za1 = gam 
    915            za2= 0.0833333333333_wp          ! za2 = eps 
    916            za3= 0._wp               
    917          ELSE                               ! AB3-AM4 Coefficients; bet=0.281105 ; eps=0.013 ; gam=0.0880  
    918             IF (rn_bt_alpha==0._wp) THEN 
    919                za0=0.614_wp                 ! za0 = 1/2 +   gam + 2*eps 
    920                za1=0.285_wp                 ! za1 = 1/2 - 2*gam - 3*eps 
    921                za2=0.088_wp                 ! za2 = gam 
    922                za3=0.013_wp                 ! za3 = eps 
    923             ELSE 
    924                zepsilon = 0.00976186_wp - 0.13451357_wp * rn_bt_alpha 
    925                zgamma = 0.08344500_wp - 0.51358400_wp * rn_bt_alpha 
    926                za0 = 0.5_wp + zgamma + 2._wp * rn_bt_alpha + 2._wp * zepsilon 
    927                za1 = 1._wp - za0 - zgamma - zepsilon 
    928                za2 = zgamma 
    929                za3 = zepsilon 
    930             ENDIF  
    931          ENDIF 
    932          ! 
     572         !          
     573         ! Half-step back interpolation of SSH for surface pressure computation at step jit+1/2 
     574         !--            m+1/2           m+1              m               m-1              m-2     --! 
     575         !--        ssh'    =  za0 * ssh     +  za1 * ssh   +  za2 * ssh      +  za3 * ssh        --! 
     576         !------------------------------------------------------------------------------------------! 
     577         CALL ts_bck_interp( jn, ll_init, za0, za1, za2, za3 )   ! coeficients of the interpolation 
    933578         zsshp2_e(:,:) = za0 *  ssha_e(:,:) + za1 *  sshn_e (:,:)   & 
    934579            &          + za2 *  sshb_e(:,:) + za3 *  sshbb_e(:,:) 
    935           
    936          IF( ln_wd_il ) THEN                   ! Calculating and applying W/D gravity filters 
    937            DO jj = 2, jpjm1 
    938               DO ji = 2, jpim1  
    939                 ll_tmp1 = MIN( zsshp2_e(ji,jj)               , zsshp2_e(ji+1,jj) ) >                & 
    940                      &    MAX(    -ht_0(ji,jj)               ,    -ht_0(ji+1,jj) ) .AND.            & 
    941                      &    MAX( zsshp2_e(ji,jj) + ht_0(ji,jj) , zsshp2_e(ji+1,jj) + ht_0(ji+1,jj) ) & 
    942                      &                                                             > rn_wdmin1 + rn_wdmin2 
    943                 ll_tmp2 = (ABS(zsshp2_e(ji,jj)               - zsshp2_e(ji+1,jj))  > 1.E-12 ).AND.( & 
    944                      &    MAX( zsshp2_e(ji,jj)               , zsshp2_e(ji+1,jj) ) >                & 
    945                      &    MAX(    -ht_0(ji,jj)               ,    -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 
    946     
    947                 IF(ll_tmp1) THEN 
    948                   zcpx(ji,jj) = 1.0_wp 
    949                 ELSE IF(ll_tmp2) THEN 
    950                   ! no worries about  zsshp2_e(ji+1,jj) - zsshp2_e(ji  ,jj) = 0, it won't happen ! here 
    951                   zcpx(ji,jj) = ABS( (zsshp2_e(ji+1,jj) +     ht_0(ji+1,jj) - zsshp2_e(ji,jj) - ht_0(ji,jj)) & 
    952                               &    / (zsshp2_e(ji+1,jj) - zsshp2_e(ji  ,jj)) ) 
    953                 ELSE 
    954                   zcpx(ji,jj) = 0._wp 
    955                 ENDIF 
    956                 ! 
    957                 ll_tmp1 = MIN( zsshp2_e(ji,jj)               , zsshp2_e(ji,jj+1) ) >                & 
    958                      &    MAX(    -ht_0(ji,jj)               ,    -ht_0(ji,jj+1) ) .AND.            & 
    959                      &    MAX( zsshp2_e(ji,jj) + ht_0(ji,jj) , zsshp2_e(ji,jj+1) + ht_0(ji,jj+1) ) & 
    960                      &                                                             > rn_wdmin1 + rn_wdmin2 
    961                 ll_tmp2 = (ABS(zsshp2_e(ji,jj)               - zsshp2_e(ji,jj+1))  > 1.E-12 ).AND.( & 
    962                      &    MAX( zsshp2_e(ji,jj)               , zsshp2_e(ji,jj+1) ) >                & 
    963                      &    MAX(    -ht_0(ji,jj)               ,    -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 
    964     
    965                 IF(ll_tmp1) THEN 
    966                   zcpy(ji,jj) = 1.0_wp 
    967                 ELSEIF(ll_tmp2) THEN 
    968                   ! no worries about  zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj  ) = 0, it won't happen ! here 
    969                   zcpy(ji,jj) = ABS( (zsshp2_e(ji,jj+1) +     ht_0(ji,jj+1) - zsshp2_e(ji,jj) - ht_0(ji,jj)) & 
    970                               &    / (zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj  )) ) 
    971                 ELSE 
    972                   zcpy(ji,jj) = 0._wp 
    973                 ENDIF 
    974               END DO 
    975            END DO 
    976          ENDIF 
    977          ! 
    978          ! Compute associated depths at U and V points: 
    979          IF( .NOT.ln_linssh  .AND. .NOT.ln_dynadv_vec ) THEN     !* Vector form 
    980             !                                         
    981             DO jj = 2, jpjm1                             
    982                DO ji = 2, jpim1 
    983                   zx1 = r1_2 * ssumask(ji  ,jj) *  r1_e1e2u(ji  ,jj)    & 
    984                      &      * ( e1e2t(ji  ,jj  ) * zsshp2_e(ji  ,jj)    & 
    985                      &      +   e1e2t(ji+1,jj  ) * zsshp2_e(ji+1,jj  ) ) 
    986                   zy1 = r1_2 * ssvmask(ji  ,jj) *  r1_e1e2v(ji  ,jj  )  & 
    987                      &       * ( e1e2t(ji ,jj  ) * zsshp2_e(ji  ,jj  )  & 
    988                      &       +   e1e2t(ji ,jj+1) * zsshp2_e(ji  ,jj+1) ) 
    989                   zhust_e(ji,jj) = hu_0(ji,jj) + zx1  
    990                   zhvst_e(ji,jj) = hv_0(ji,jj) + zy1 
    991                END DO 
    992             END DO 
    993             ! 
     580         ! 
     581         !                             ! Surface pressure gradient 
     582         zldg = ( 1._wp - rn_scal_load ) * grav    ! local factor 
     583         DO jj = 2, jpjm1                             
     584            DO ji = 2, jpim1 
     585               zu_spg(ji,jj) = - zldg * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj) 
     586               zv_spg(ji,jj) = - zldg * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj) 
     587            END DO 
     588         END DO 
     589         IF( ln_wd_il ) THEN        ! W/D : gravity filters applied on pressure gradient 
     590            CALL wad_spg( zsshp2_e, zcpx, zcpy )   ! Calculating W/D gravity filters 
     591            zu_spg(2:jpim1,2:jpjm1) = zu_spg(2:jpim1,2:jpjm1) * zcpx(2:jpim1,2:jpjm1) 
     592            zv_spg(2:jpim1,2:jpjm1) = zv_spg(2:jpim1,2:jpjm1) * zcpy(2:jpim1,2:jpjm1) 
    994593         ENDIF 
    995594         ! 
    … …  
    997596         ! zwz array below or triads normally depend on sea level with ln_linssh=F and should be updated 
    998597         ! at each time step. We however keep them constant here for optimization. 
    999          ! Recall that zwx and zwy arrays hold fluxes at this stage: 
    1000          ! zwx(:,:) = e2u(:,:) * ua_e(:,:) * zhup2_e(:,:)   ! fluxes at jn+0.5 
    1001          ! zwy(:,:) = e1v(:,:) * va_e(:,:) * zhvp2_e(:,:) 
    1002          ! 
    1003          SELECT CASE( nvor_scheme ) 
    1004          CASE( np_ENT )             ! energy conserving scheme (t-point) 
    1005          DO jj = 2, jpjm1 
    1006             DO ji = 2, jpim1   ! vector opt. 
    1007  
    1008                z1_hu = ssumask(ji,jj) / ( hu_0(ji,jj) + zhup2_e(ji,jj) + 1._wp - ssumask(ji,jj) ) 
    1009                z1_hv = ssvmask(ji,jj) / ( hv_0(ji,jj) + zhvp2_e(ji,jj) + 1._wp - ssvmask(ji,jj) ) 
    1010              
    1011                zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * z1_hu                   & 
    1012                   &               * (  e1e2t(ji+1,jj)*zhtp2_e(ji+1,jj)*ff_t(ji+1,jj) * ( va_e(ji+1,jj) + va_e(ji+1,jj-1) )   & 
    1013                   &                  + e1e2t(ji  ,jj)*zhtp2_e(ji  ,jj)*ff_t(ji  ,jj) * ( va_e(ji  ,jj) + va_e(ji  ,jj-1) )   ) 
    1014                   ! 
    1015                zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * z1_hv                    & 
    1016                   &               * (  e1e2t(ji,jj+1)*zhtp2_e(ji,jj+1)*ff_t(ji,jj+1) * ( ua_e(ji,jj+1) + ua_e(ji-1,jj+1) )   &  
    1017                   &                  + e1e2t(ji,jj  )*zhtp2_e(ji,jj  )*ff_t(ji,jj  ) * ( ua_e(ji,jj  ) + ua_e(ji-1,jj  ) )   )  
    1018             END DO   
    1019          END DO   
    1020          !          
    1021          CASE( np_ENE, np_MIX )     ! energy conserving scheme (f-point) 
    1022             DO jj = 2, jpjm1 
    1023                DO ji = fs_2, fs_jpim1   ! vector opt. 
    1024                   zy1 = ( zwy(ji  ,jj-1) + zwy(ji+1,jj-1) ) * r1_e1u(ji,jj) 
    1025                   zy2 = ( zwy(ji  ,jj  ) + zwy(ji+1,jj  ) ) * r1_e1u(ji,jj) 
    1026                   zx1 = ( zwx(ji-1,jj  ) + zwx(ji-1,jj+1) ) * r1_e2v(ji,jj) 
    1027                   zx2 = ( zwx(ji  ,jj  ) + zwx(ji  ,jj+1) ) * r1_e2v(ji,jj) 
    1028                   zu_trd(ji,jj) = r1_4 * ( zwz(ji  ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 
    1029                   zv_trd(ji,jj) =-r1_4 * ( zwz(ji-1,jj  ) * zx1 + zwz(ji,jj) * zx2 ) 
    1030                END DO 
    1031             END DO 
    1032             ! 
    1033          CASE( np_ENS )             ! enstrophy conserving scheme (f-point) 
    1034             DO jj = 2, jpjm1 
    1035                DO ji = fs_2, fs_jpim1   ! vector opt. 
    1036                   zy1 =   r1_8 * ( zwy(ji  ,jj-1) + zwy(ji+1,jj-1) & 
    1037                    &             + zwy(ji  ,jj  ) + zwy(ji+1,jj  ) ) * r1_e1u(ji,jj) 
    1038                   zx1 = - r1_8 * ( zwx(ji-1,jj  ) + zwx(ji-1,jj+1) & 
    1039                    &             + zwx(ji  ,jj  ) + zwx(ji  ,jj+1) ) * r1_e2v(ji,jj) 
    1040                   zu_trd(ji,jj)  = zy1 * ( zwz(ji  ,jj-1) + zwz(ji,jj) ) 
    1041                   zv_trd(ji,jj)  = zx1 * ( zwz(ji-1,jj  ) + zwz(ji,jj) ) 
    1042                END DO 
    1043             END DO 
    1044             ! 
    1045          CASE( np_EET , np_EEN )   ! energy & enstrophy scheme (using e3t or e3f) 
    1046             DO jj = 2, jpjm1 
    1047                DO ji = fs_2, fs_jpim1   ! vector opt. 
    1048                   zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * (  ftne(ji,jj  ) * zwy(ji  ,jj  )  & 
    1049                      &                                       + ftnw(ji+1,jj) * zwy(ji+1,jj  )  & 
    1050                      &                                       + ftse(ji,jj  ) * zwy(ji  ,jj-1)  &  
    1051                      &                                       + ftsw(ji+1,jj) * zwy(ji+1,jj-1)  ) 
    1052                   zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * (  ftsw(ji,jj+1) * zwx(ji-1,jj+1)  &  
    1053                      &                                       + ftse(ji,jj+1) * zwx(ji  ,jj+1)  & 
    1054                      &                                       + ftnw(ji,jj  ) * zwx(ji-1,jj  )  &  
    1055                      &                                       + ftne(ji,jj  ) * zwx(ji  ,jj  )  ) 
    1056                END DO 
    1057             END DO 
    1058             !  
    1059          END SELECT 
     598         ! Recall that zhU and zhV hold fluxes at jn+0.5 (extrapolated not backward interpolated) 
     599         CALL dyn_cor_2d( zhup2_e, zhvp2_e, ua_e, va_e, zhU, zhV,    zu_trd, zv_trd   ) 
    1060600         ! 
    1061601         ! Add tidal astronomical forcing if defined 
    … …  
    1063603            DO jj = 2, jpjm1 
    1064604               DO ji = fs_2, fs_jpim1   ! vector opt. 
    1065                   zu_spg = grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) 
    1066                   zv_spg = grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj) 
    1067                   zu_trd(ji,jj) = zu_trd(ji,jj) + zu_spg 
    1068                   zv_trd(ji,jj) = zv_trd(ji,jj) + zv_spg 
     605                  zu_trd(ji,jj) = zu_trd(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) 
     606                  zv_trd(ji,jj) = zv_trd(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj) 
    1069607               END DO 
    1070608            END DO 
    … …  
    1080618               END DO 
    1081619            END DO 
    1082          ENDIF  
    1083          ! 
    1084          ! Surface pressure trend: 
    1085          IF( ln_wd_il ) THEN 
    1086            DO jj = 2, jpjm1 
    1087               DO ji = 2, jpim1  
    1088                  ! Add surface pressure gradient 
    1089                  zu_spg = - grav * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj) 
    1090                  zv_spg = - grav * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj) 
    1091                  zwx(ji,jj) = (1._wp - rn_scal_load) * zu_spg * zcpx(ji,jj)  
    1092                  zwy(ji,jj) = (1._wp - rn_scal_load) * zv_spg * zcpy(ji,jj) 
    1093               END DO 
    1094            END DO 
    1095          ELSE 
    1096            DO jj = 2, jpjm1 
    1097               DO ji = fs_2, fs_jpim1   ! vector opt. 
    1098                  ! Add surface pressure gradient 
    1099                  zu_spg = - grav * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj) 
    1100                  zv_spg = - grav * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj) 
    1101                  zwx(ji,jj) = (1._wp - rn_scal_load) * zu_spg 
    1102                  zwy(ji,jj) = (1._wp - rn_scal_load) * zv_spg 
    1103               END DO 
    1104            END DO 
    1105          END IF 
    1106  
     620         ENDIF 
    1107621         ! 
    1108622         ! Set next velocities: 
     623         !     Compute barotropic speeds at step jit+1    (h : total height of the water colomn) 
     624         !--                              VECTOR FORM 
     625         !--   m+1                 m               /                                                       m+1/2           \    --! 
     626         !--  u     =             u   + delta_t' * \         (1-r)*g * grad_x( ssh') -         f * k vect u      +     frc /    --! 
     627         !--                                                                                                                    --! 
     628         !--                             FLUX FORM                                                                              --! 
     629         !--  m+1   __1__  /  m    m               /  m+1/2                             m+1/2              m+1/2    n      \ \  --! 
     630         !-- u    =   m+1 |  h  * u   + delta_t' * \ h     * (1-r)*g * grad_x( ssh') - h     * f * k vect u      + h * frc /  | --! 
     631         !--         h     \                                                                                                 /  --! 
     632         !------------------------------------------------------------------------------------------------------------------------! 
    1109633         IF( ln_dynadv_vec .OR. ln_linssh ) THEN      !* Vector form 
    1110634            DO jj = 2, jpjm1 
    1111635               DO ji = fs_2, fs_jpim1   ! vector opt. 
    1112636                  ua_e(ji,jj) = (                                 un_e(ji,jj)   &  
    1113                             &     + rdtbt * (                      zwx(ji,jj)   & 
     637                            &     + rdtbt * (                   zu_spg(ji,jj)   & 
    1114638                            &                                 + zu_trd(ji,jj)   & 
    1115639                            &                                 + zu_frc(ji,jj) ) &  
    … …  
    1117641 
    1118642                  va_e(ji,jj) = (                                 vn_e(ji,jj)   & 
    1119                             &     + rdtbt * (                      zwy(ji,jj)   & 
     643                            &     + rdtbt * (                   zv_spg(ji,jj)   & 
    1120644                            &                                 + zv_trd(ji,jj)   & 
    1121645                            &                                 + zv_frc(ji,jj) ) & 
    1122646                            &   ) * ssvmask(ji,jj) 
    1123   
    1124647               END DO 
    1125648            END DO 
    … …  
    1127650         ELSE                           !* Flux form 
    1128651            DO jj = 2, jpjm1 
    1129                DO ji = fs_2, fs_jpim1   ! vector opt. 
    1130  
    1131                   zhura = hu_0(ji,jj) + zsshu_a(ji,jj) 
    1132                   zhvra = hv_0(ji,jj) + zsshv_a(ji,jj) 
    1133  
    1134                   zhura = ssumask(ji,jj)/(zhura + 1._wp - ssumask(ji,jj)) 
    1135                   zhvra = ssvmask(ji,jj)/(zhvra + 1._wp - ssvmask(ji,jj)) 
    1136  
    1137                   ua_e(ji,jj) = (                hu_e(ji,jj)  *   un_e(ji,jj)   &  
    1138                             &     + rdtbt * ( zhust_e(ji,jj)  *    zwx(ji,jj)   &  
    1139                             &               + zhup2_e(ji,jj)  * zu_trd(ji,jj)   & 
    1140                             &               +    hu(ji,jj,Kmm)  * zu_frc(ji,jj) ) & 
    1141                             &   ) * zhura 
    1142  
    1143                   va_e(ji,jj) = (                hv_e(ji,jj)  *   vn_e(ji,jj)   & 
    1144                             &     + rdtbt * ( zhvst_e(ji,jj)  *    zwy(ji,jj)   & 
    1145                             &               + zhvp2_e(ji,jj)  * zv_trd(ji,jj)   & 
    1146                             &               +    hv(ji,jj,Kmm)  * zv_frc(ji,jj) ) & 
    1147                             &   ) * zhvra 
     652               DO ji = 2, jpim1 
     653                  !                    ! hu_e, hv_e hold depth at jn,  zhup2_e, zhvp2_e hold extrapolated depth at jn+1/2 
     654                  !                    ! backward interpolated depth used in spg terms at jn+1/2 
     655                  zhu_bck = hu_0(ji,jj) + r1_2*r1_e1e2u(ji,jj) * (  e1e2t(ji  ,jj) * zsshp2_e(ji  ,jj)    & 
     656                       &                                          + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj)  ) * ssumask(ji,jj) 
     657                  zhv_bck = hv_0(ji,jj) + r1_2*r1_e1e2v(ji,jj) * (  e1e2t(ji,jj  ) * zsshp2_e(ji,jj  )    & 
     658                       &                                          + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1)  ) * ssvmask(ji,jj) 
     659                  !                    ! inverse depth at jn+1 
     660                  z1_hu = ssumask(ji,jj) / ( hu_0(ji,jj) + zsshu_a(ji,jj) + 1._wp - ssumask(ji,jj) ) 
     661                  z1_hv = ssvmask(ji,jj) / ( hv_0(ji,jj) + zsshv_a(ji,jj) + 1._wp - ssvmask(ji,jj) ) 
     662                  ! 
     663                  ua_e(ji,jj) = (               hu_e  (ji,jj) *   un_e (ji,jj)      &  
     664                       &            + rdtbt * (  zhu_bck        * zu_spg (ji,jj)  &   ! 
     665                       &                       + zhup2_e(ji,jj) * zu_trd (ji,jj)  &   ! 
     666                       &                       +  hu(ji,jj,Kmm) * zu_frc (ji,jj)  )   ) * z1_hu 
     667                  ! 
     668                  va_e(ji,jj) = (               hv_e  (ji,jj) *   vn_e (ji,jj)      & 
     669                       &            + rdtbt * (  zhv_bck        * zv_spg (ji,jj)  &   ! 
     670                       &                       + zhvp2_e(ji,jj) * zv_trd (ji,jj)  &   ! 
     671                       &                       +  hv(ji,jj,Kmm) * zv_frc (ji,jj)  )   ) * z1_hv 
    1148672               END DO 
    1149673            END DO 
    … …  
    1158682            END DO 
    1159683         ENDIF 
    1160  
    1161           
    1162          IF( .NOT.ln_linssh ) THEN                     !* Update ocean depth (variable volume case only) 
    1163             hu_e (:,:) = hu_0(:,:) + zsshu_a(:,:) 
    1164             hv_e (:,:) = hv_0(:,:) + zsshv_a(:,:) 
    1165             hur_e(:,:) = ssumask(:,:) / ( hu_e(:,:) + 1._wp - ssumask(:,:) ) 
    1166             hvr_e(:,:) = ssvmask(:,:) / ( hv_e(:,:) + 1._wp - ssvmask(:,:) ) 
    1167             ! 
    1168          ENDIF 
    1169          !                                             !* domain lateral boundary 
    1170          CALL lbc_lnk_multi( 'dynspg_ts', ua_e, 'U', -1._wp, va_e , 'V', -1._wp ) 
     684        
     685         IF( .NOT.ln_linssh ) THEN   !* Update ocean depth (variable volume case only) 
     686            hu_e (2:jpim1,2:jpjm1) = hu_0(2:jpim1,2:jpjm1) + zsshu_a(2:jpim1,2:jpjm1) 
     687            hur_e(2:jpim1,2:jpjm1) = ssumask(2:jpim1,2:jpjm1) / ( hu_e(2:jpim1,2:jpjm1) + 1._wp - ssumask(2:jpim1,2:jpjm1) ) 
     688            hv_e (2:jpim1,2:jpjm1) = hv_0(2:jpim1,2:jpjm1) + zsshv_a(2:jpim1,2:jpjm1) 
     689            hvr_e(2:jpim1,2:jpjm1) = ssvmask(2:jpim1,2:jpjm1) / ( hv_e(2:jpim1,2:jpjm1) + 1._wp - ssvmask(2:jpim1,2:jpjm1) ) 
     690            CALL lbc_lnk_multi( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp  & 
     691                 &                         , hu_e , 'U', -1._wp, hv_e , 'V', -1._wp  & 
     692                 &                         , hur_e, 'U', -1._wp, hvr_e, 'V', -1._wp  ) 
     693         ELSE 
     694            CALL lbc_lnk_multi( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp  ) 
     695         ENDIF 
     696         ! 
    1171697         ! 
    1172698         !                                                 ! open boundaries 
    … …  
    1216742      ! Set advection velocity correction: 
    1217743      IF (ln_bt_fw) THEN 
    1218          zwx(:,:) = un_adv(:,:) 
    1219          zwy(:,:) = vn_adv(:,:) 
    1220744         IF( .NOT.( kt == nit000 .AND. neuler==0 ) ) THEN 
    1221             un_adv(:,:) = r1_2 * ( ub2_b(:,:) + zwx(:,:) - atfp * un_bf(:,:) ) 
    1222             vn_adv(:,:) = r1_2 * ( vb2_b(:,:) + zwy(:,:) - atfp * vn_bf(:,:) ) 
    1223             ! 
    1224             ! Update corrective fluxes for next time step: 
    1225             un_bf(:,:)  = atfp * un_bf(:,:) + (zwx(:,:) - ub2_b(:,:)) 
    1226             vn_bf(:,:)  = atfp * vn_bf(:,:) + (zwy(:,:) - vb2_b(:,:)) 
     745            DO jj = 1, jpj 
     746               DO ji = 1, jpi 
     747                  zun_save = un_adv(ji,jj) 
     748                  zvn_save = vn_adv(ji,jj) 
     749                  !                          ! apply the previously computed correction  
     750                  un_adv(ji,jj) = r1_2 * ( ub2_b(ji,jj) + zun_save - atfp * un_bf(ji,jj) ) 
     751                  vn_adv(ji,jj) = r1_2 * ( vb2_b(ji,jj) + zvn_save - atfp * vn_bf(ji,jj) ) 
     752                  !                          ! Update corrective fluxes for next time step 
     753                  un_bf(ji,jj)  = atfp * un_bf(ji,jj) + ( zun_save - ub2_b(ji,jj) ) 
     754                  vn_bf(ji,jj)  = atfp * vn_bf(ji,jj) + ( zvn_save - vb2_b(ji,jj) ) 
     755                  !                          ! Save integrated transport for next computation 
     756                  ub2_b(ji,jj) = zun_save 
     757                  vb2_b(ji,jj) = zvn_save 
     758               END DO 
     759            END DO 
    1227760         ELSE 
    1228             un_bf(:,:) = 0._wp 
    1229             vn_bf(:,:) = 0._wp  
    1230          END IF          
    1231          ! Save integrated transport for next computation 
    1232          ub2_b(:,:) = zwx(:,:) 
    1233          vb2_b(:,:) = zwy(:,:) 
     761            un_bf(:,:) = 0._wp            ! corrective fluxes for next time step set to zero 
     762            vn_bf(:,:) = 0._wp 
     763            ub2_b(:,:) = un_adv(:,:)      ! Save integrated transport for next computation 
     764            vb2_b(:,:) = vn_adv(:,:) 
     765         END IF 
    1234766      ENDIF 
    1235767 
    … …  
    1307839      ! 
    1308840      IF( ln_diatmb ) THEN 
    1309          CALL iom_put( "baro_u" , uu_b(:,:,Kmm)*ssumask(:,:)+zmdi*(1.-ssumask(:,:) ) )  ! Barotropic  U Velocity 
    1310          CALL iom_put( "baro_v" , vv_b(:,:,Kmm)*ssvmask(:,:)+zmdi*(1.-ssvmask(:,:) ) )  ! Barotropic  V Velocity 
     841         CALL iom_put( "baro_u" , puu_b(:,:,Kmm)*ssumask(:,:)+zmdi*(1.-ssumask(:,:) ) )  ! Barotropic  U Velocity 
     842         CALL iom_put( "baro_v" , pvv_b(:,:,Kmm)*ssvmask(:,:)+zmdi*(1.-ssvmask(:,:) ) )  ! Barotropic  V Velocity 
    1311843      ENDIF 
    1312844      ! 
    … …  
    15821114   END SUBROUTINE dyn_spg_ts_init 
    15831115 
     1116    
     1117   SUBROUTINE dyn_cor_2D_init( Kmm ) 
     1118      !!--------------------------------------------------------------------- 
     1119      !!                   ***  ROUTINE dyn_cor_2D_init  *** 
     1120      !! 
     1121      !! ** Purpose : Set time splitting options 
     1122      !! Set arrays to remove/compute coriolis trend. 
     1123      !! Do it once during initialization if volume is fixed, else at each long time step. 
     1124      !! Note that these arrays are also used during barotropic loop. These are however frozen 
     1125      !! although they should be updated in the variable volume case. Not a big approximation. 
     1126      !! To remove this approximation, copy lines below inside barotropic loop 
     1127      !! and update depths at T-F points (ht and zhf resp.) at each barotropic time step 
     1128      !! 
     1129      !! Compute zwz = f / ( height of the water colomn ) 
     1130      !!---------------------------------------------------------------------- 
     1131      INTEGER,  INTENT(in)         ::  Kmm  ! Time index 
     1132      INTEGER  ::   ji ,jj, jk              ! dummy loop indices 
     1133      REAL(wp) ::   z1_ht 
     1134      REAL(wp), DIMENSION(jpi,jpj) :: zhf 
     1135      !!---------------------------------------------------------------------- 
     1136      ! 
     1137      SELECT CASE( nvor_scheme ) 
     1138      CASE( np_EEN )                != EEN scheme using e3f (energy & enstrophy scheme) 
     1139         SELECT CASE( nn_een_e3f )              !* ff_f/e3 at F-point 
     1140         CASE ( 0 )                                   ! original formulation  (masked averaging of e3t divided by 4) 
     1141            DO jj = 1, jpjm1 
     1142               DO ji = 1, jpim1 
     1143                  zwz(ji,jj) =   ( ht(ji  ,jj+1) + ht(ji+1,jj+1) +                    & 
     1144                       &           ht(ji  ,jj  ) + ht(ji+1,jj  )   ) * 0.25_wp   
     1145                  IF( zwz(ji,jj) /= 0._wp )   zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 
     1146               END DO 
     1147            END DO 
     1148         CASE ( 1 )                                   ! new formulation  (masked averaging of e3t divided by the sum of mask) 
     1149            DO jj = 1, jpjm1 
     1150               DO ji = 1, jpim1 
     1151                  zwz(ji,jj) =             (  ht  (ji  ,jj+1) + ht  (ji+1,jj+1)      & 
     1152                       &                    + ht  (ji  ,jj  ) + ht  (ji+1,jj  )  )   & 
     1153                       &       / ( MAX( 1._wp,  ssmask(ji  ,jj+1) + ssmask(ji+1,jj+1)      & 
     1154                       &                      + ssmask(ji  ,jj  ) + ssmask(ji+1,jj  )  )   ) 
     1155                  IF( zwz(ji,jj) /= 0._wp )   zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 
     1156               END DO 
     1157            END DO 
     1158         END SELECT 
     1159         CALL lbc_lnk( 'dynspg_ts', zwz, 'F', 1._wp ) 
     1160         ! 
     1161         ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 
     1162         DO jj = 2, jpj 
     1163            DO ji = 2, jpi 
     1164               ftne(ji,jj) = zwz(ji-1,jj  ) + zwz(ji  ,jj  ) + zwz(ji  ,jj-1) 
     1165               ftnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj  ) + zwz(ji  ,jj  ) 
     1166               ftse(ji,jj) = zwz(ji  ,jj  ) + zwz(ji  ,jj-1) + zwz(ji-1,jj-1) 
     1167               ftsw(ji,jj) = zwz(ji  ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj  ) 
     1168            END DO 
     1169         END DO 
     1170         ! 
     1171      CASE( np_EET )                  != EEN scheme using e3t (energy conserving scheme) 
     1172         ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 
     1173         DO jj = 2, jpj 
     1174            DO ji = 2, jpi 
     1175               z1_ht = ssmask(ji,jj) / ( ht(ji,jj) + 1._wp - ssmask(ji,jj) ) 
     1176               ftne(ji,jj) = ( ff_f(ji-1,jj  ) + ff_f(ji  ,jj  ) + ff_f(ji  ,jj-1) ) * z1_ht 
     1177               ftnw(ji,jj) = ( ff_f(ji-1,jj-1) + ff_f(ji-1,jj  ) + ff_f(ji  ,jj  ) ) * z1_ht 
     1178               ftse(ji,jj) = ( ff_f(ji  ,jj  ) + ff_f(ji  ,jj-1) + ff_f(ji-1,jj-1) ) * z1_ht 
     1179               ftsw(ji,jj) = ( ff_f(ji  ,jj-1) + ff_f(ji-1,jj-1) + ff_f(ji-1,jj  ) ) * z1_ht 
     1180            END DO 
     1181         END DO 
     1182         ! 
     1183      CASE( np_ENE, np_ENS , np_MIX )  != all other schemes (ENE, ENS, MIX) except ENT ! 
     1184         ! 
     1185         zwz(:,:) = 0._wp 
     1186         zhf(:,:) = 0._wp 
     1187          
     1188         !!gm  assume 0 in both cases (which is almost surely WRONG ! ) as hvatf has been removed  
     1189!!gm    A priori a better value should be something like : 
     1190!!gm          zhf(i,j) = masked sum of  ht(i,j) , ht(i+1,j) , ht(i,j+1) , (i+1,j+1)  
     1191!!gm                     divided by the sum of the corresponding mask  
     1192!!gm  
     1193!!             
     1194         IF( .NOT.ln_sco ) THEN 
     1195   
     1196   !!gm  agree the JC comment  : this should be done in a much clear way 
     1197   
     1198   ! JC: It not clear yet what should be the depth at f-points over land in z-coordinate case 
     1199   !     Set it to zero for the time being  
     1200   !              IF( rn_hmin < 0._wp ) THEN    ;   jk = - INT( rn_hmin )                                      ! from a nb of level 
     1201   !              ELSE                          ;   jk = MINLOC( gdepw_0, mask = gdepw_0 > rn_hmin, dim = 1 )  ! from a depth 
     1202   !              ENDIF 
     1203   !              zhf(:,:) = gdepw_0(:,:,jk+1) 
     1204            ! 
     1205         ELSE 
     1206            ! 
     1207            !zhf(:,:) = hbatf(:,:) 
     1208            DO jj = 1, jpjm1 
     1209               DO ji = 1, jpim1 
     1210                  zhf(ji,jj) =    (   ht_0  (ji,jj  ) + ht_0  (ji+1,jj  )          & 
     1211                       &            + ht_0  (ji,jj+1) + ht_0  (ji+1,jj+1)   )      & 
     1212                       &     / MAX(   ssmask(ji,jj  ) + ssmask(ji+1,jj  )          & 
     1213                       &            + ssmask(ji,jj+1) + ssmask(ji+1,jj+1) , 1._wp  ) 
     1214               END DO 
     1215            END DO 
     1216         ENDIF 
     1217         ! 
     1218         DO jj = 1, jpjm1 
     1219            zhf(:,jj) = zhf(:,jj) * (1._wp- umask(:,jj,1) * umask(:,jj+1,1)) 
     1220         END DO 
     1221         ! 
     1222         DO jk = 1, jpkm1 
     1223            DO jj = 1, jpjm1 
     1224               zhf(:,jj) = zhf(:,jj) + e3f(:,jj,jk) * umask(:,jj,jk) * umask(:,jj+1,jk) 
     1225            END DO 
     1226         END DO 
     1227         CALL lbc_lnk( 'dynspg_ts', zhf, 'F', 1._wp ) 
     1228         ! JC: TBC. hf should be greater than 0  
     1229         DO jj = 1, jpj 
     1230            DO ji = 1, jpi 
     1231               IF( zhf(ji,jj) /= 0._wp )   zwz(ji,jj) = 1._wp / zhf(ji,jj) 
     1232            END DO 
     1233         END DO 
     1234         zwz(:,:) = ff_f(:,:) * zwz(:,:) 
     1235      END SELECT 
     1236       
     1237   END SUBROUTINE dyn_cor_2d_init 
     1238 
     1239 
     1240 
     1241   SUBROUTINE dyn_cor_2d( phu, phv, punb, pvnb, zhU, zhV,    zu_trd, zv_trd   ) 
     1242      !!--------------------------------------------------------------------- 
     1243      !!                   ***  ROUTINE dyn_cor_2d  *** 
     1244      !! 
     1245      !! ** Purpose : Compute u and v coriolis trends 
     1246      !!---------------------------------------------------------------------- 
     1247      INTEGER  ::   ji ,jj                             ! dummy loop indices 
     1248      REAL(wp) ::   zx1, zx2, zy1, zy2, z1_hu, z1_hv   !   -      - 
     1249      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: phu, phv, punb, pvnb, zhU, zhV 
     1250      REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) :: zu_trd, zv_trd 
     1251      !!---------------------------------------------------------------------- 
     1252      SELECT CASE( nvor_scheme ) 
     1253      CASE( np_ENT )                ! enstrophy conserving scheme (f-point) 
     1254         DO jj = 2, jpjm1 
     1255            DO ji = 2, jpim1 
     1256               z1_hu = ssumask(ji,jj) / ( phu(ji,jj) + 1._wp - ssumask(ji,jj) ) 
     1257               z1_hv = ssvmask(ji,jj) / ( phv(ji,jj) + 1._wp - ssvmask(ji,jj) ) 
     1258               zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * z1_hu                    & 
     1259                  &               * (  e1e2t(ji+1,jj)*ht(ji+1,jj)*ff_t(ji+1,jj) * ( pvnb(ji+1,jj) + pvnb(ji+1,jj-1) )   & 
     1260                  &                  + e1e2t(ji  ,jj)*ht(ji  ,jj)*ff_t(ji  ,jj) * ( pvnb(ji  ,jj) + pvnb(ji  ,jj-1) )   ) 
     1261                  ! 
     1262               zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * z1_hv                    & 
     1263                  &               * (  e1e2t(ji,jj+1)*ht(ji,jj+1)*ff_t(ji,jj+1) * ( punb(ji,jj+1) + punb(ji-1,jj+1) )   &  
     1264                  &                  + e1e2t(ji,jj  )*ht(ji,jj  )*ff_t(ji,jj  ) * ( punb(ji,jj  ) + punb(ji-1,jj  ) )   )  
     1265            END DO   
     1266         END DO   
     1267         !          
     1268      CASE( np_ENE , np_MIX )        ! energy conserving scheme (t-point) ENE or MIX 
     1269         DO jj = 2, jpjm1 
     1270            DO ji = fs_2, fs_jpim1   ! vector opt. 
     1271               zy1 = ( zhV(ji,jj-1) + zhV(ji+1,jj-1) ) * r1_e1u(ji,jj) 
     1272               zy2 = ( zhV(ji,jj  ) + zhV(ji+1,jj  ) ) * r1_e1u(ji,jj) 
     1273               zx1 = ( zhU(ji-1,jj) + zhU(ji-1,jj+1) ) * r1_e2v(ji,jj) 
     1274               zx2 = ( zhU(ji  ,jj) + zhU(ji  ,jj+1) ) * r1_e2v(ji,jj) 
     1275               ! energy conserving formulation for planetary vorticity term 
     1276               zu_trd(ji,jj) =   r1_4 * ( zwz(ji  ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 
     1277               zv_trd(ji,jj) = - r1_4 * ( zwz(ji-1,jj  ) * zx1 + zwz(ji,jj) * zx2 ) 
     1278            END DO 
     1279         END DO 
     1280         ! 
     1281      CASE( np_ENS )                ! enstrophy conserving scheme (f-point) 
     1282         DO jj = 2, jpjm1 
     1283            DO ji = fs_2, fs_jpim1   ! vector opt. 
     1284               zy1 =   r1_8 * ( zhV(ji  ,jj-1) + zhV(ji+1,jj-1) & 
     1285                 &            + zhV(ji  ,jj  ) + zhV(ji+1,jj  ) ) * r1_e1u(ji,jj) 
     1286               zx1 = - r1_8 * ( zhU(ji-1,jj  ) + zhU(ji-1,jj+1) & 
     1287                 &            + zhU(ji  ,jj  ) + zhU(ji  ,jj+1) ) * r1_e2v(ji,jj) 
     1288               zu_trd(ji,jj)  = zy1 * ( zwz(ji  ,jj-1) + zwz(ji,jj) ) 
     1289               zv_trd(ji,jj)  = zx1 * ( zwz(ji-1,jj  ) + zwz(ji,jj) ) 
     1290            END DO 
     1291         END DO 
     1292         ! 
     1293      CASE( np_EET , np_EEN )      ! energy & enstrophy scheme (using e3t or e3f)          
     1294         DO jj = 2, jpjm1 
     1295            DO ji = fs_2, fs_jpim1   ! vector opt. 
     1296               zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * (  ftne(ji,jj  ) * zhV(ji  ,jj  ) & 
     1297                &                                         + ftnw(ji+1,jj) * zhV(ji+1,jj  ) & 
     1298                &                                         + ftse(ji,jj  ) * zhV(ji  ,jj-1) & 
     1299                &                                         + ftsw(ji+1,jj) * zhV(ji+1,jj-1) ) 
     1300               zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * (  ftsw(ji,jj+1) * zhU(ji-1,jj+1) & 
     1301                &                                         + ftse(ji,jj+1) * zhU(ji  ,jj+1) & 
     1302                &                                         + ftnw(ji,jj  ) * zhU(ji-1,jj  ) & 
     1303                &                                         + ftne(ji,jj  ) * zhU(ji  ,jj  ) ) 
     1304            END DO 
     1305         END DO 
     1306         ! 
     1307      END SELECT 
     1308      ! 
     1309   END SUBROUTINE dyn_cor_2D 
     1310 
     1311 
     1312   SUBROUTINE wad_tmsk( pssh, ptmsk ) 
     1313      !!---------------------------------------------------------------------- 
     1314      !!                  ***  ROUTINE wad_lmt  *** 
     1315      !!                     
     1316      !! ** Purpose :   set wetting & drying mask at tracer points  
     1317      !!              for the current barotropic sub-step  
     1318      !! 
     1319      !! ** Method  :   ???  
     1320      !! 
     1321      !! ** Action  :  ptmsk : wetting & drying t-mask 
     1322      !!---------------------------------------------------------------------- 
     1323      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   pssh    ! 
     1324      REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) ::   ptmsk   ! 
     1325      ! 
     1326      INTEGER  ::   ji, jj   ! dummy loop indices 
     1327      !!---------------------------------------------------------------------- 
     1328      ! 
     1329      IF( ln_wd_dl_rmp ) THEN      
     1330         DO jj = 1, jpj 
     1331            DO ji = 1, jpi                     
     1332               IF    ( pssh(ji,jj) + ht_0(ji,jj) >  2._wp * rn_wdmin1 ) THEN  
     1333                  !           IF    ( pssh(ji,jj) + ht_0(ji,jj) >          rn_wdmin2 ) THEN  
     1334                  ptmsk(ji,jj) = 1._wp 
     1335               ELSEIF( pssh(ji,jj) + ht_0(ji,jj) >          rn_wdmin1 ) THEN 
     1336                  ptmsk(ji,jj) = TANH( 50._wp*( ( pssh(ji,jj) + ht_0(ji,jj) -  rn_wdmin1 )*r_rn_wdmin1) ) 
     1337               ELSE  
     1338                  ptmsk(ji,jj) = 0._wp 
     1339               ENDIF 
     1340            END DO 
     1341         END DO 
     1342      ELSE   
     1343         DO jj = 1, jpj 
     1344            DO ji = 1, jpi                               
     1345               IF ( pssh(ji,jj) + ht_0(ji,jj) >  rn_wdmin1 ) THEN   ;   ptmsk(ji,jj) = 1._wp 
     1346               ELSE                                                 ;   ptmsk(ji,jj) = 0._wp 
     1347               ENDIF 
     1348            END DO 
     1349         END DO 
     1350      ENDIF 
     1351      ! 
     1352   END SUBROUTINE wad_tmsk 
     1353 
     1354 
     1355   SUBROUTINE wad_Umsk( pTmsk, phU, phV, pu, pv, pUmsk, pVmsk ) 
     1356      !!---------------------------------------------------------------------- 
     1357      !!                  ***  ROUTINE wad_lmt  *** 
     1358      !!                     
     1359      !! ** Purpose :   set wetting & drying mask at tracer points  
     1360      !!              for the current barotropic sub-step  
     1361      !! 
     1362      !! ** Method  :   ???  
     1363      !! 
     1364      !! ** Action  :  ptmsk : wetting & drying t-mask 
     1365      !!---------------------------------------------------------------------- 
     1366      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   pTmsk              ! W & D t-mask 
     1367      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   phU, phV, pu, pv   ! ocean velocities and transports 
     1368      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pUmsk, pVmsk       ! W & D u- and v-mask 
     1369      ! 
     1370      INTEGER  ::   ji, jj   ! dummy loop indices 
     1371      !!---------------------------------------------------------------------- 
     1372      ! 
     1373      DO jj = 1, jpj 
     1374         DO ji = 1, jpim1   ! not jpi-column 
     1375            IF ( phU(ji,jj) > 0._wp ) THEN   ;   pUmsk(ji,jj) = pTmsk(ji  ,jj)  
     1376            ELSE                             ;   pUmsk(ji,jj) = pTmsk(ji+1,jj)   
     1377            ENDIF 
     1378            phU(ji,jj) = pUmsk(ji,jj)*phU(ji,jj) 
     1379            pu (ji,jj) = pUmsk(ji,jj)*pu (ji,jj) 
     1380         END DO 
     1381      END DO 
     1382      ! 
     1383      DO jj = 1, jpjm1   ! not jpj-row 
     1384         DO ji = 1, jpi 
     1385            IF ( phV(ji,jj) > 0._wp ) THEN   ;   pVmsk(ji,jj) = pTmsk(ji,jj  ) 
     1386            ELSE                             ;   pVmsk(ji,jj) = pTmsk(ji,jj+1)   
     1387            ENDIF 
     1388            phV(ji,jj) = pVmsk(ji,jj)*phV(ji,jj)  
     1389            pv (ji,jj) = pVmsk(ji,jj)*pv (ji,jj) 
     1390         END DO 
     1391      END DO 
     1392      ! 
     1393   END SUBROUTINE wad_Umsk 
     1394 
     1395 
     1396   SUBROUTINE wad_spg( pshn, zcpx, zcpy ) 
     1397      !!--------------------------------------------------------------------- 
     1398      !!                   ***  ROUTINE  wad_sp  *** 
     1399      !! 
     1400      !! ** Purpose :  
     1401      !!---------------------------------------------------------------------- 
     1402      INTEGER  ::   ji ,jj               ! dummy loop indices 
     1403      LOGICAL  ::   ll_tmp1, ll_tmp2 
     1404      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: pshn 
     1405      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: zcpx, zcpy 
     1406      !!---------------------------------------------------------------------- 
     1407      DO jj = 2, jpjm1 
     1408         DO ji = 2, jpim1  
     1409            ll_tmp1 = MIN(  pshn(ji,jj)               ,  pshn(ji+1,jj) ) >                & 
     1410                 &      MAX( -ht_0(ji,jj)               , -ht_0(ji+1,jj) ) .AND.            & 
     1411                 &      MAX(  pshn(ji,jj) + ht_0(ji,jj) ,  pshn(ji+1,jj) + ht_0(ji+1,jj) )  & 
     1412                 &                                                         > rn_wdmin1 + rn_wdmin2 
     1413            ll_tmp2 = ( ABS( pshn(ji+1,jj)            -  pshn(ji  ,jj))  > 1.E-12 ).AND.( & 
     1414                 &      MAX(   pshn(ji,jj)              ,  pshn(ji+1,jj) ) >                & 
     1415                 &      MAX(  -ht_0(ji,jj)              , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 
     1416            IF(ll_tmp1) THEN 
     1417               zcpx(ji,jj) = 1.0_wp 
     1418            ELSEIF(ll_tmp2) THEN 
     1419               ! no worries about  pshn(ji+1,jj) -  pshn(ji  ,jj) = 0, it won't happen ! here 
     1420               zcpx(ji,jj) = ABS( (pshn(ji+1,jj) + ht_0(ji+1,jj) - pshn(ji,jj) - ht_0(ji,jj)) & 
     1421                    &           / (pshn(ji+1,jj) - pshn(ji  ,jj)) ) 
     1422               zcpx(ji,jj) = max(min( zcpx(ji,jj) , 1.0_wp),0.0_wp) 
     1423            ELSE 
     1424               zcpx(ji,jj) = 0._wp 
     1425            ENDIF 
     1426            ! 
     1427            ll_tmp1 = MIN(  pshn(ji,jj)               ,  pshn(ji,jj+1) ) >                & 
     1428                 &      MAX( -ht_0(ji,jj)               , -ht_0(ji,jj+1) ) .AND.            & 
     1429                 &      MAX(  pshn(ji,jj) + ht_0(ji,jj) ,  pshn(ji,jj+1) + ht_0(ji,jj+1) )  & 
     1430                 &                                                       > rn_wdmin1 + rn_wdmin2 
     1431            ll_tmp2 = ( ABS( pshn(ji,jj)              -  pshn(ji,jj+1))  > 1.E-12 ).AND.( & 
     1432                 &      MAX(   pshn(ji,jj)              ,  pshn(ji,jj+1) ) >                & 
     1433                 &      MAX(  -ht_0(ji,jj)              , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 
     1434             
     1435            IF(ll_tmp1) THEN 
     1436               zcpy(ji,jj) = 1.0_wp 
     1437            ELSE IF(ll_tmp2) THEN 
     1438               ! no worries about  pshn(ji,jj+1) -  pshn(ji,jj  ) = 0, it won't happen ! here 
     1439               zcpy(ji,jj) = ABS( (pshn(ji,jj+1) + ht_0(ji,jj+1) - pshn(ji,jj) - ht_0(ji,jj)) & 
     1440                    &           / (pshn(ji,jj+1) - pshn(ji,jj  )) ) 
     1441               zcpy(ji,jj) = MAX(  0._wp , MIN( zcpy(ji,jj) , 1.0_wp )  ) 
     1442            ELSE 
     1443               zcpy(ji,jj) = 0._wp 
     1444            ENDIF 
     1445         END DO 
     1446      END DO 
     1447             
     1448   END SUBROUTINE wad_spg 
     1449      
     1450 
     1451 
     1452   SUBROUTINE dyn_drg_init( Kbb, Kmm, puu, pvv, puu_b ,pvv_b, pu_RHSi, pv_RHSi, pCdU_u, pCdU_v ) 
     1453      !!---------------------------------------------------------------------- 
     1454      !!                  ***  ROUTINE dyn_drg_init  *** 
     1455      !!                     
     1456      !! ** Purpose : - add the baroclinic top/bottom drag contribution to  
     1457      !!              the baroclinic part of the barotropic RHS 
     1458      !!              - compute the barotropic drag coefficients 
     1459      !! 
     1460      !! ** Method  :   computation done over the INNER domain only  
     1461      !!---------------------------------------------------------------------- 
     1462      INTEGER                             , INTENT(in   ) ::  Kbb, Kmm           ! ocean time level indices 
     1463      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(in   ) ::  puu, pvv           ! ocean velocities and RHS of momentum equation 
     1464      REAL(wp), DIMENSION(jpi,jpj,jpt)    , INTENT(in   ) ::  puu_b, pvv_b       ! barotropic velocities at main time levels 
     1465      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(inout) ::  pu_RHSi, pv_RHSi   ! baroclinic part of the barotropic RHS 
     1466      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(  out) ::  pCdU_u , pCdU_v    ! barotropic drag coefficients 
     1467      ! 
     1468      INTEGER  ::   ji, jj   ! dummy loop indices 
     1469      INTEGER  ::   ikbu, ikbv, iktu, iktv 
     1470      REAL(wp) ::   zztmp 
     1471      REAL(wp), DIMENSION(jpi,jpj) ::   zu_i, zv_i 
     1472      !!---------------------------------------------------------------------- 
     1473      ! 
     1474      !                    !==  Set the barotropic drag coef.  ==! 
     1475      ! 
     1476      IF( ln_isfcav ) THEN          ! top+bottom friction (ocean cavities) 
     1477          
     1478         DO jj = 2, jpjm1 
     1479            DO ji = 2, jpim1     ! INNER domain 
     1480               pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) + rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) 
     1481               pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) + rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) 
     1482            END DO 
     1483         END DO 
     1484      ELSE                          ! bottom friction only 
     1485         DO jj = 2, jpjm1 
     1486            DO ji = 2, jpim1  ! INNER domain 
     1487               pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) 
     1488               pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) 
     1489            END DO 
     1490         END DO 
     1491      ENDIF 
     1492      ! 
     1493      !                    !==  BOTTOM stress contribution from baroclinic velocities  ==! 
     1494      ! 
     1495      IF( ln_bt_fw ) THEN                 ! FORWARD integration: use NOW bottom baroclinic velocities 
     1496          
     1497         DO jj = 2, jpjm1 
     1498            DO ji = 2, jpim1  ! INNER domain 
     1499               ikbu = mbku(ji,jj)        
     1500               ikbv = mbkv(ji,jj)     
     1501               zu_i(ji,jj) = puu(ji,jj,ikbu,Kmm) - puu_b(ji,jj,Kmm) 
     1502               zv_i(ji,jj) = pvv(ji,jj,ikbv,Kmm) - pvv_b(ji,jj,Kmm) 
     1503            END DO 
     1504         END DO 
     1505      ELSE                                ! CENTRED integration: use BEFORE bottom baroclinic velocities 
     1506          
     1507         DO jj = 2, jpjm1 
     1508            DO ji = 2, jpim1   ! INNER domain 
     1509               ikbu = mbku(ji,jj)        
     1510               ikbv = mbkv(ji,jj)     
     1511               zu_i(ji,jj) = puu(ji,jj,ikbu,Kbb) - puu_b(ji,jj,Kbb) 
     1512               zv_i(ji,jj) = pvv(ji,jj,ikbv,Kbb) - pvv_b(ji,jj,Kbb) 
     1513            END DO 
     1514         END DO 
     1515      ENDIF 
     1516      ! 
     1517      IF( ln_wd_il ) THEN      ! W/D : use the "clipped" bottom friction   !!gm   explain WHY, please ! 
     1518         zztmp = -1._wp / rdtbt 
     1519         DO jj = 2, jpjm1 
     1520            DO ji = 2, jpim1    ! INNER domain 
     1521               pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + zu_i(ji,jj) *  wdrampu(ji,jj) * MAX(                                 &  
     1522                    &                              r1_hu(ji,jj,Kmm) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) , zztmp  ) 
     1523               pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + zv_i(ji,jj) *  wdrampv(ji,jj) * MAX(                                 &  
     1524                    &                              r1_hv(ji,jj,Kmm) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) , zztmp  ) 
     1525            END DO 
     1526         END DO 
     1527      ELSE                    ! use "unclipped" drag (even if explicit friction is used in 3D calculation) 
     1528          
     1529         DO jj = 2, jpjm1 
     1530            DO ji = 2, jpim1    ! INNER domain 
     1531               pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu(ji,jj,Kmm) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * zu_i(ji,jj) 
     1532               pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv(ji,jj,Kmm) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * zv_i(ji,jj) 
     1533            END DO 
     1534         END DO 
     1535      END IF 
     1536      ! 
     1537      !                    !==  TOP stress contribution from baroclinic velocities  ==!   (no W/D case) 
     1538      ! 
     1539      IF( ln_isfcav ) THEN 
     1540         ! 
     1541         IF( ln_bt_fw ) THEN                ! FORWARD integration: use NOW top baroclinic velocity 
     1542             
     1543            DO jj = 2, jpjm1 
     1544               DO ji = 2, jpim1   ! INNER domain 
     1545                  iktu = miku(ji,jj) 
     1546                  iktv = mikv(ji,jj) 
     1547                  zu_i(ji,jj) = puu(ji,jj,iktu,Kmm) - puu_b(ji,jj,Kmm) 
     1548                  zv_i(ji,jj) = pvv(ji,jj,iktv,Kmm) - pvv_b(ji,jj,Kmm) 
     1549               END DO 
     1550            END DO 
     1551         ELSE                                ! CENTRED integration: use BEFORE top baroclinic velocity 
     1552             
     1553            DO jj = 2, jpjm1 
     1554               DO ji = 2, jpim1      ! INNER domain 
     1555                  iktu = miku(ji,jj) 
     1556                  iktv = mikv(ji,jj) 
     1557                  zu_i(ji,jj) = puu(ji,jj,iktu,Kbb) - puu_b(ji,jj,Kbb) 
     1558                  zv_i(ji,jj) = pvv(ji,jj,iktv,Kbb) - pvv_b(ji,jj,Kbb) 
     1559               END DO 
     1560            END DO 
     1561         ENDIF 
     1562         ! 
     1563         !                    ! use "unclipped" top drag (even if explicit friction is used in 3D calculation) 
     1564          
     1565         DO jj = 2, jpjm1 
     1566            DO ji = 2, jpim1    ! INNER domain 
     1567               pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu(ji,jj,Kmm) * r1_2*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * zu_i(ji,jj) 
     1568               pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv(ji,jj,Kmm) * r1_2*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * zv_i(ji,jj) 
     1569            END DO 
     1570         END DO 
     1571         ! 
     1572      ENDIF 
     1573      ! 
     1574   END SUBROUTINE dyn_drg_init 
     1575 
     1576   SUBROUTINE ts_bck_interp( jn, ll_init,       &   ! <== in 
     1577      &                      za0, za1, za2, za3 )   ! ==> out 
     1578      !!---------------------------------------------------------------------- 
     1579      INTEGER ,INTENT(in   ) ::   jn                   ! index of sub time step 
     1580      LOGICAL ,INTENT(in   ) ::   ll_init              ! 
     1581      REAL(wp),INTENT(  out) ::   za0, za1, za2, za3   ! Half-step back interpolation coefficient 
     1582      ! 
     1583      REAL(wp) ::   zepsilon, zgamma                   !   -      - 
     1584      !!---------------------------------------------------------------------- 
     1585      !                             ! set Half-step back interpolation coefficient 
     1586      IF    ( jn==1 .AND. ll_init ) THEN   !* Forward-backward 
     1587         za0 = 1._wp                         
     1588         za1 = 0._wp                            
     1589         za2 = 0._wp 
     1590         za3 = 0._wp 
     1591      ELSEIF( jn==2 .AND. ll_init ) THEN   !* AB2-AM3 Coefficients; bet=0 ; gam=-1/6 ; eps=1/12 
     1592         za0 = 1.0833333333333_wp                 ! za0 = 1-gam-eps 
     1593         za1 =-0.1666666666666_wp                 ! za1 = gam 
     1594         za2 = 0.0833333333333_wp                 ! za2 = eps 
     1595         za3 = 0._wp               
     1596      ELSE                                 !* AB3-AM4 Coefficients; bet=0.281105 ; eps=0.013 ; gam=0.0880  
     1597         IF( rn_bt_alpha == 0._wp ) THEN      ! Time diffusion   
     1598            za0 = 0.614_wp                        ! za0 = 1/2 +   gam + 2*eps 
     1599            za1 = 0.285_wp                        ! za1 = 1/2 - 2*gam - 3*eps 
     1600            za2 = 0.088_wp                        ! za2 = gam 
     1601            za3 = 0.013_wp                        ! za3 = eps 
     1602         ELSE                                 ! no time diffusion 
     1603            zepsilon = 0.00976186_wp - 0.13451357_wp * rn_bt_alpha 
     1604            zgamma   = 0.08344500_wp - 0.51358400_wp * rn_bt_alpha 
     1605            za0 = 0.5_wp + zgamma + 2._wp * rn_bt_alpha + 2._wp * zepsilon 
     1606            za1 = 1._wp - za0 - zgamma - zepsilon 
     1607            za2 = zgamma 
     1608            za3 = zepsilon 
     1609         ENDIF  
     1610      ENDIF 
     1611   END SUBROUTINE ts_bck_interp 
     1612 
     1613 
    15841614   !!====================================================================== 
    15851615END MODULE dynspg_ts 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DYN/dynvor.F90

    r10946 r11822  
    858858      REWIND( numnam_ref )              ! Namelist namdyn_vor in reference namelist : Vorticity scheme options 
    859859      READ  ( numnam_ref, namdyn_vor, IOSTAT = ios, ERR = 901) 
    860 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_vor in reference namelist', lwp ) 
     860901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_vor in reference namelist' ) 
    861861      REWIND( numnam_cfg )              ! Namelist namdyn_vor in configuration namelist : Vorticity scheme options 
    862862      READ  ( numnam_cfg, namdyn_vor, IOSTAT = ios, ERR = 902 ) 
    863 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_vor in configuration namelist', lwp ) 
     863902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_vor in configuration namelist' ) 
    864864      IF(lwm) WRITE ( numond, namdyn_vor ) 
    865865      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DYN/dynzdf.F90

    r10946 r11822  
    172172                     zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) + akzu(ji,jj,jk+1) )   & 
    173173                        &         / ( ze3ua * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1) 
    174                      zWui = 0.5_wp * ( wi(ji,jj,jk  ) + wi(ji+1,jj,jk  ) ) 
    175                      zWus = 0.5_wp * ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) 
     174                     zWui = ( wi(ji,jj,jk  ) + wi(ji+1,jj,jk  ) ) / ze3ua 
     175                     zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) / ze3ua 
    176176                     zwi(ji,jj,jk) = zzwi + zdt * MIN( zWui, 0._wp )  
    177177                     zws(ji,jj,jk) = zzws - zdt * MAX( zWus, 0._wp ) 
    … …  
    187187                     zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) ) / ( ze3ua * e3uw(ji,jj,jk  ,Kmm) ) * wumask(ji,jj,jk  ) 
    188188                     zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) / ( ze3ua * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1) 
    189                      zWui = 0.5_wp * ( wi(ji,jj,jk  ) + wi(ji+1,jj,jk  ) ) 
    190                      zWus = 0.5_wp * ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) 
     189                     zWui = ( wi(ji,jj,jk  ) + wi(ji+1,jj,jk  ) ) / ze3ua 
     190                     zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) / ze3ua 
    191191                     zwi(ji,jj,jk) = zzwi + zdt * MIN( zWui, 0._wp ) 
    192192                     zws(ji,jj,jk) = zzws - zdt * MAX( zWus, 0._wp ) 
    … …  
    201201               ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,1,Kmm) + r_vvl * e3u(ji,jj,1,Kaa) 
    202202               zzws = - zdt * ( avm(ji+1,jj,2) + avm(ji  ,jj,2) ) / ( ze3ua * e3uw(ji,jj,2,Kmm) ) * wumask(ji,jj,2) 
    203                zWus = 0.5_wp * ( wi(ji  ,jj,2) +  wi(ji+1,jj,2) ) 
     203               zWus = ( wi(ji  ,jj,2) +  wi(ji+1,jj,2) ) / ze3ua 
    204204               zws(ji,jj,1 ) = zzws - zdt * MAX( zWus, 0._wp ) 
    205205               zwd(ji,jj,1 ) = 1._wp - zzws - zdt * ( MIN( zWus, 0._wp ) ) 
    … …  
    338338                     zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) + akzv(ji,jj,jk+1) )   & 
    339339                        &         / ( ze3va * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1) 
    340                      zWvi = 0.5_wp * ( wi(ji,jj,jk  ) + wi(ji,jj+1,jk  ) ) * wvmask(ji,jj,jk  ) 
    341                      zWvs = 0.5_wp * ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) * wvmask(ji,jj,jk+1) 
     340                     zWvi = ( wi(ji,jj,jk  ) + wi(ji,jj+1,jk  ) ) / ze3va 
     341                     zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) / ze3va 
    342342                     zwi(ji,jj,jk) = zzwi + zdt * MIN( zWvi, 0._wp ) 
    343343                     zws(ji,jj,jk) = zzws - zdt * MAX( zWvs, 0._wp ) 
    … …  
    353353                     zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) ) / ( ze3va * e3vw(ji,jj,jk  ,Kmm) ) * wvmask(ji,jj,jk  ) 
    354354                     zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) / ( ze3va * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1) 
    355                      zWvi = 0.5_wp * ( wi(ji,jj,jk  ) + wi(ji,jj+1,jk  ) ) * wvmask(ji,jj,jk  ) 
    356                      zWvs = 0.5_wp * ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) * wvmask(ji,jj,jk+1) 
     355                     zWvi = ( wi(ji,jj,jk  ) + wi(ji,jj+1,jk  ) ) / ze3va 
     356                     zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) / ze3va 
    357357                     zwi(ji,jj,jk) = zzwi  + zdt * MIN( zWvi, 0._wp ) 
    358358                     zws(ji,jj,jk) = zzws  - zdt * MAX( zWvs, 0._wp ) 
    … …  
    367367               ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,1,Kmm) + r_vvl * e3v(ji,jj,1,Kaa) 
    368368               zzws = - zdt * ( avm(ji,jj+1,2) + avm(ji,jj,2) ) / ( ze3va * e3vw(ji,jj,2,Kmm) ) * wvmask(ji,jj,2) 
    369                zWvs = 0.5_wp * ( wi(ji,jj  ,2) +  wi(ji,jj+1,2) ) 
     369               zWvs = ( wi(ji,jj  ,2) +  wi(ji,jj+1,2) ) / ze3va 
    370370               zws(ji,jj,1 ) = zzws - zdt * MAX( zWvs, 0._wp ) 
    371371               zwd(ji,jj,1 ) = 1._wp - zzws - zdt * ( MIN( zWvs, 0._wp ) ) 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DYN/sshwzv.F90

    r11480 r11822  
    99   !!             -   !  2010-09  (D.Storkey and E.O'Dea) bug fixes for BDY module 
    1010   !!            3.3  !  2011-10  (M. Leclair) split former ssh_wzv routine and remove all vvl related work 
     11   !!            4.0  !  2018-12  (A. Coward) add mixed implicit/explicit advection 
    1112   !!            4.1  !  2019-08  (A. Coward, D. Storkey) Rename ssh_nxt -> ssh_atf. Now only does time filtering. 
    1213   !!---------------------------------------------------------------------- 
    … …  
    278279      !!            :   wi      : now vertical velocity (for implicit treatment) 
    279280      !! 
    280       !! Reference  : Leclair, M., and G. Madec, 2009, Ocean Modelling. 
     281      !! Reference  : Shchepetkin, A. F. (2015): An adaptive, Courant-number-dependent 
     282      !!              implicit scheme for vertical advection in oceanic modeling.  
     283      !!              Ocean Modelling, 91, 38-69. 
    281284      !!---------------------------------------------------------------------- 
    282285      INTEGER, INTENT(in) ::   kt   ! time step 
    … …  
    284287      ! 
    285288      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    286       REAL(wp)             ::   zCu, zcff, z1_e3w                     ! local scalars 
     289      REAL(wp)             ::   zCu, zcff, z1_e3t                     ! local scalars 
    287290      REAL(wp) , PARAMETER ::   Cu_min = 0.15_wp                      ! local parameters 
    288       REAL(wp) , PARAMETER ::   Cu_max = 0.27                         ! local parameters 
     291      REAL(wp) , PARAMETER ::   Cu_max = 0.30_wp                      ! local parameters 
    289292      REAL(wp) , PARAMETER ::   Cu_cut = 2._wp*Cu_max - Cu_min        ! local parameters 
    290293      REAL(wp) , PARAMETER ::   Fcu    = 4._wp*Cu_max*(Cu_max-Cu_min) ! local parameters 
    … …  
    297300         IF(lwp) WRITE(numout,*) 'wAimp : Courant number-based partitioning of now vertical velocity ' 
    298301         IF(lwp) WRITE(numout,*) '~~~~~ ' 
    299          ! 
    300          Cu_adv(:,:,jpk) = 0._wp              ! bottom value : Cu_adv=0 (set once for all) 
    301       ENDIF 
    302       ! 
    303       DO jk = 1, jpkm1            ! calculate Courant numbers 
    304          DO jj = 2, jpjm1 
    305             DO ji = 2, fs_jpim1   ! vector opt. 
    306                z1_e3w = 1._wp / e3w(ji,jj,jk,Kmm) 
    307                Cu_adv(ji,jj,jk) = r2dt * ( ( MAX( ww(ji,jj,jk) , 0._wp ) - MIN( ww(ji,jj,jk+1) , 0._wp ) )    & 
    308                   &                      + ( MAX( e2u(ji  ,jj)*e3uw(ji  ,jj,jk,Kmm)*uu(ji  ,jj,jk,Kmm), 0._wp ) -   & 
    309                   &                          MIN( e2u(ji-1,jj)*e3uw(ji-1,jj,jk,Kmm)*uu(ji-1,jj,jk,Kmm), 0._wp ) )   & 
    310                   &                        * r1_e1e2t(ji,jj)                                                  & 
    311                   &                      + ( MAX( e1v(ji,jj  )*e3vw(ji,jj  ,jk,Kmm)*vv(ji,jj  ,jk,Kmm), 0._wp ) -   & 
    312                   &                          MIN( e1v(ji,jj-1)*e3vw(ji,jj-1,jk,Kmm)*vv(ji,jj-1,jk,Kmm), 0._wp ) )   & 
    313                   &                        * r1_e1e2t(ji,jj)                                                  & 
    314                   &                      ) * z1_e3w 
     302         wi(:,:,:) = 0._wp 
     303      ENDIF 
     304      ! 
     305      ! Calculate Courant numbers 
     306      IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN 
     307         DO jk = 1, jpkm1 
     308            DO jj = 2, jpjm1 
     309               DO ji = 2, fs_jpim1   ! vector opt. 
     310                  z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm) 
     311                  ! 2*rdt and not r2dt (for restartability) 
     312                  Cu_adv(ji,jj,jk) = 2._wp * rdt * ( ( MAX( ww(ji,jj,jk) , 0._wp ) - MIN( ww(ji,jj,jk+1) , 0._wp ) )                       &   
     313                     &                             + ( MAX( e2u(ji  ,jj)*e3u(ji  ,jj,jk,Kmm)*uu(ji  ,jj,jk,Kmm) + un_td(ji  ,jj,jk), 0._wp ) -   & 
     314                     &                                 MIN( e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kmm)*uu(ji-1,jj,jk,Kmm) + un_td(ji-1,jj,jk), 0._wp ) )   & 
     315                     &                               * r1_e1e2t(ji,jj)                                                                     & 
     316                     &                             + ( MAX( e1v(ji,jj  )*e3v(ji,jj  ,jk,Kmm)*vv(ji,jj  ,jk,Kmm) + vn_td(ji,jj  ,jk), 0._wp ) -   & 
     317                     &                                 MIN( e1v(ji,jj-1)*e3v(ji,jj-1,jk,Kmm)*vv(ji,jj-1,jk,Kmm) + vn_td(ji,jj-1,jk), 0._wp ) )   & 
     318                     &                               * r1_e1e2t(ji,jj)                                                                     & 
     319                     &                             ) * z1_e3t 
     320               END DO 
    315321            END DO 
    316322         END DO 
    317       END DO 
     323      ELSE 
     324         DO jk = 1, jpkm1 
     325            DO jj = 2, jpjm1 
     326               DO ji = 2, fs_jpim1   ! vector opt. 
     327                  z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm) 
     328                  ! 2*rdt and not r2dt (for restartability) 
     329                  Cu_adv(ji,jj,jk) = 2._wp * rdt * ( ( MAX( ww(ji,jj,jk) , 0._wp ) - MIN( ww(ji,jj,jk+1) , 0._wp ) )   &  
     330                     &                             + ( MAX( e2u(ji  ,jj)*e3u(ji  ,jj,jk,Kmm)*uu(ji  ,jj,jk,Kmm), 0._wp ) -   & 
     331                     &                                 MIN( e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kmm)*uu(ji-1,jj,jk,Kmm), 0._wp ) )   & 
     332                     &                               * r1_e1e2t(ji,jj)                                                 & 
     333                     &                             + ( MAX( e1v(ji,jj  )*e3v(ji,jj  ,jk,Kmm)*vv(ji,jj  ,jk,Kmm), 0._wp ) -   & 
     334                     &                                 MIN( e1v(ji,jj-1)*e3v(ji,jj-1,jk,Kmm)*vv(ji,jj-1,jk,Kmm), 0._wp ) )   & 
     335                     &                               * r1_e1e2t(ji,jj)                                                 & 
     336                     &                             ) * z1_e3t 
     337               END DO 
     338            END DO 
     339         END DO 
     340      ENDIF 
     341      CALL lbc_lnk( 'sshwzv', Cu_adv, 'T', 1. ) 
    318342      ! 
    319343      CALL iom_put("Courant",Cu_adv) 
    320344      ! 
    321       wi(:,:,:) = 0._wp                                 ! Includes top and bottom values set to zero 
    322345      IF( MAXVAL( Cu_adv(:,:,:) ) > Cu_min ) THEN       ! Quick check if any breaches anywhere 
    323          DO jk = 1, jpkm1                               ! or scan Courant criterion and partition 
    324             DO jj = 2, jpjm1                            ! w where necessary 
    325                DO ji = 2, fs_jpim1   ! vector opt. 
     346         DO jk = jpkm1, 2, -1                           ! or scan Courant criterion and partition 
     347            DO jj = 1, jpj                              ! w where necessary 
     348               DO ji = 1, jpi 
    326349                  ! 
    327                   zCu = MAX( Cu_adv(ji,jj,jk) , Cu_adv(ji,jj,jk+1) ) 
     350                  zCu = MAX( Cu_adv(ji,jj,jk) , Cu_adv(ji,jj,jk-1) ) 
     351! alt: 
     352!                  IF ( wn(ji,jj,jk) > 0._wp ) THEN  
     353!                     zCu =  Cu_adv(ji,jj,jk)  
     354!                  ELSE 
     355!                     zCu =  Cu_adv(ji,jj,jk-1) 
     356!                  ENDIF  
    328357                  ! 
    329                   IF( zCu < Cu_min ) THEN               !<-- Fully explicit 
     358                  IF( zCu <= Cu_min ) THEN              !<-- Fully explicit 
    330359                     zcff = 0._wp 
    331360                  ELSEIF( zCu < Cu_cut ) THEN           !<-- Mixed explicit 
    … …  
    340369                  ww(ji,jj,jk) = ( 1._wp - zcff ) * ww(ji,jj,jk) 
    341370                  ! 
    342                   Cu_adv(ji,jj,jk) = zcff               ! Reuse array to output coefficient 
     371                  Cu_adv(ji,jj,jk) = zcff               ! Reuse array to output coefficient below and in stp_ctl 
    343372               END DO 
    344373            END DO 
    345374         END DO 
     375         Cu_adv(:,:,1) = 0._wp  
    346376      ELSE 
    347377         ! Fully explicit everywhere 
    348          Cu_adv = 0.0_wp                                ! Reuse array to output coefficient 
     378         Cu_adv(:,:,:) = 0._wp                          ! Reuse array to output coefficient below and in stp_ctl 
     379         wi    (:,:,:) = 0._wp 
    349380      ENDIF 
    350381      CALL iom_put("wimp",wi)  

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/DYN/wet_dry.F90

    r11027 r11822  
    8181      REWIND( numnam_ref )              ! Namelist namwad in reference namelist : Parameters for Wetting/Drying 
    8282      READ  ( numnam_ref, namwad, IOSTAT = ios, ERR = 905) 
    83 905   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namwad in reference namelist', .TRUE.)  
     83905   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namwad in reference namelist' )  
    8484      REWIND( numnam_cfg )              ! Namelist namwad in configuration namelist : Parameters for Wetting/Drying 
    8585      READ  ( numnam_cfg, namwad, IOSTAT = ios, ERR = 906) 
    86 906   IF( ios >  0 )   CALL ctl_nam ( ios , 'namwad in configuration namelist', .TRUE. ) 
     86906   IF( ios >  0 )   CALL ctl_nam ( ios , 'namwad in configuration namelist' ) 
    8787      IF(lwm) WRITE ( numond, namwad ) 
    8888      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/FLO/flo4rk.F90

    r10970 r11822  
    44   !! Ocean floats :   trajectory computation using a 4th order Runge-Kutta 
    55   !!====================================================================== 
    6 #if   defined key_floats 
    7    !!---------------------------------------------------------------------- 
    8    !!   'key_floats'                                     float trajectories 
     6   !! 
    97   !!---------------------------------------------------------------------- 
    108   !!   flo_4rk        : Compute the geographical position of floats 
    … …  
    448446   END SUBROUTINE flo_interp 
    449447 
    450 #  else 
    451    !!---------------------------------------------------------------------- 
    452    !!   No floats                                              Dummy module 
    453    !!---------------------------------------------------------------------- 
    454 #endif 
    455     
    456448   !!====================================================================== 
    457449END MODULE flo4rk 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/FLO/flo_oce.F90

    r10425 r11822  
    66   !! History :   OPA  ! 1999-10  (CLIPPER projet) 
    77   !!   NEMO      1.0  ! 2002-11  (G. Madec, A. Bozec)  F90: Free form and module 
    8    !!---------------------------------------------------------------------- 
    9 #if   defined   key_floats 
    10    !!---------------------------------------------------------------------- 
    11    !!   'key_floats'                                        drifting floats 
    128   !!---------------------------------------------------------------------- 
    139   USE par_oce         ! ocean parameters 
    … …  
    2016   PUBLIC   flo_oce_alloc   ! Routine called in floats.F90 
    2117 
    22    LOGICAL, PUBLIC, PARAMETER ::   lk_floats = .TRUE.    !: float flag 
    23  
    2418   !! float parameters 
    2519   !! ---------------- 
     20   LOGICAL, PUBLIC ::   ln_floats   !: Activate floats or not 
    2621   INTEGER, PUBLIC ::   jpnfl       !: total number of floats during the run 
    2722   INTEGER, PUBLIC ::   jpnnewflo   !: number of floats added in a new run 
    … …  
    6863   END FUNCTION flo_oce_alloc 
    6964 
    70 #else 
    71    !!---------------------------------------------------------------------- 
    72    !!   Default option :                                 NO drifting floats 
    73    !!---------------------------------------------------------------------- 
    74    LOGICAL, PUBLIC, PARAMETER ::   lk_floats = .FALSE.   !: float flag 
    75 #endif 
    76  
    7765   !!====================================================================== 
    7866END MODULE flo_oce 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/FLO/floats.F90

    r10970 r11822  
    77   !!   NEMO     1.0  ! 2002-06  (A. Bozec)  F90, Free form and module 
    88   !!---------------------------------------------------------------------- 
    9 #if   defined   key_floats 
    10    !!---------------------------------------------------------------------- 
    11    !!   'key_floats'                                     float trajectories 
     9   !! 
    1210   !!---------------------------------------------------------------------- 
    1311   !!   flo_stp   : float trajectories computation 
    … …  
    3028 
    3129   PUBLIC   flo_stp    ! routine called by step.F90 
    32    PUBLIC   flo_init   ! routine called by opa.F90 
     30   PUBLIC   flo_init   ! routine called by nemogcm.F90 
    3331 
    3432   !!---------------------------------------------------------------------- 
    … …  
    8482      INTEGER ::   ios                 ! Local integer output status for namelist read 
    8583      ! 
    86       NAMELIST/namflo/ jpnfl, jpnnewflo, ln_rstflo, nn_writefl, nn_stockfl, ln_argo, ln_flork4, ln_ariane, ln_flo_ascii 
     84      NAMELIST/namflo/ ln_floats, jpnfl, jpnnewflo, ln_rstflo, nn_writefl, nn_stockfl, ln_argo, ln_flork4, ln_ariane, ln_flo_ascii 
    8785      !!--------------------------------------------------------------------- 
    8886      ! 
    … …  
    9391      REWIND( numnam_ref )              ! Namelist namflo in reference namelist : Floats 
    9492      READ  ( numnam_ref, namflo, IOSTAT = ios, ERR = 901) 
    95 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namflo in reference namelist', lwp ) 
     93901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namflo in reference namelist' ) 
    9694 
    9795      REWIND( numnam_cfg )              ! Namelist namflo in configuration namelist : Floats 
    9896      READ  ( numnam_cfg, namflo, IOSTAT = ios, ERR = 902 ) 
    99 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namflo in configuration namelist', lwp ) 
     97902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namflo in configuration namelist' ) 
    10098      IF(lwm) WRITE ( numond, namflo ) 
    10199      ! 
    … …  
    103101         WRITE(numout,*) 
    104102         WRITE(numout,*) '         Namelist floats :' 
    105          WRITE(numout,*) '            number of floats                      jpnfl        = ', jpnfl 
    106          WRITE(numout,*) '            number of new floats                  jpnflnewflo  = ', jpnnewflo 
    107          WRITE(numout,*) '            restart                               ln_rstflo    = ', ln_rstflo 
    108          WRITE(numout,*) '            frequency of float output file        nn_writefl   = ', nn_writefl 
    109          WRITE(numout,*) '            frequency of float restart file       nn_stockfl   = ', nn_stockfl 
    110          WRITE(numout,*) '            Argo type floats                      ln_argo      = ', ln_argo 
    111          WRITE(numout,*) '            Computation of T trajectories         ln_flork4    = ', ln_flork4 
    112          WRITE(numout,*) '            Use of ariane convention              ln_ariane    = ', ln_ariane 
    113          WRITE(numout,*) '            ascii output (T) or netcdf output (F) ln_flo_ascii = ', ln_flo_ascii 
     103         WRITE(numout,*) '            Activate floats or not                   ln_floats    = ', ln_floats 
     104         WRITE(numout,*) '               number of floats                      jpnfl        = ', jpnfl 
     105         WRITE(numout,*) '               number of new floats                  jpnflnewflo  = ', jpnnewflo 
     106         WRITE(numout,*) '               restart                               ln_rstflo    = ', ln_rstflo 
     107         WRITE(numout,*) '               frequency of float output file        nn_writefl   = ', nn_writefl 
     108         WRITE(numout,*) '               frequency of float restart file       nn_stockfl   = ', nn_stockfl 
     109         WRITE(numout,*) '               Argo type floats                      ln_argo      = ', ln_argo 
     110         WRITE(numout,*) '               Computation of T trajectories         ln_flork4    = ', ln_flork4 
     111         WRITE(numout,*) '               Use of ariane convention              ln_ariane    = ', ln_ariane 
     112         WRITE(numout,*) '               ascii output (T) or netcdf output (F) ln_flo_ascii = ', ln_flo_ascii 
    114113 
    115114      ENDIF 
    116115      ! 
    117       !                             ! allocate floats arrays 
    118       IF( flo_oce_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'flo_init : unable to allocate arrays' ) 
    119       ! 
    120       !                             ! allocate flodom arrays 
    121       IF( flo_dom_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'flo_dom : unable to allocate arrays' ) 
    122       ! 
    123       !                             ! allocate flowri arrays 
    124       IF( flo_wri_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'flo_wri : unable to allocate arrays' ) 
    125       ! 
    126       !                             ! allocate florst arrays 
    127       IF( flo_rst_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'flo_rst : unable to allocate arrays' ) 
    128       ! 
    129       jpnrstflo = jpnfl-jpnnewflo   ! memory allocation  
    130       ! 
    131       DO jfl = 1, jpnfl             ! vertical axe for netcdf IOM ouput 
    132          nfloat(jfl) = jfl  
    133       END DO 
    134       ! 
    135       CALL flo_dom( Kmm )           ! compute/read initial position of floats 
    136       ! 
    137       wb(:,:,:) = ww(:,:,:)         ! set wb for computation of floats trajectories at the first time step 
    138       ! 
     116      IF( ln_floats ) THEN 
     117         !                             ! allocate floats arrays 
     118         IF( flo_oce_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'flo_init : unable to allocate arrays' ) 
     119         ! 
     120         !                             ! allocate flodom arrays 
     121         IF( flo_dom_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'flo_dom : unable to allocate arrays' ) 
     122         ! 
     123         !                             ! allocate flowri arrays 
     124         IF( flo_wri_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'flo_wri : unable to allocate arrays' ) 
     125         ! 
     126         !                             ! allocate florst arrays 
     127         IF( flo_rst_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'flo_rst : unable to allocate arrays' ) 
     128         ! 
     129         jpnrstflo = jpnfl-jpnnewflo   ! memory allocation  
     130         ! 
     131         DO jfl = 1, jpnfl             ! vertical axe for netcdf IOM ouput 
     132            nfloat(jfl) = jfl  
     133         END DO 
     134         ! 
     135         CALL flo_dom( Kmm )           ! compute/read initial position of floats 
     136         ! 
     137         wb(:,:,:) = ww(:,:,:)         ! set wb for computation of floats trajectories at the first time step 
     138         ! 
     139      ENDIF 
    139140   END SUBROUTINE flo_init 
    140  
    141 #  else 
    142    !!---------------------------------------------------------------------- 
    143    !!   Default option :                                       Empty module 
    144    !!---------------------------------------------------------------------- 
    145 CONTAINS 
    146    SUBROUTINE flo_stp( kt, Kbb, Kmm )  ! Empty routine 
    147       IMPLICIT NONE 
    148       INTEGER, INTENT( in ) :: kt 
    149       INTEGER, INTENT( in ) :: Kbb, Kmm 
    150       WRITE(*,*) 'flo_stp: You should not have seen this print! error?', kt 
    151    END SUBROUTINE flo_stp 
    152    SUBROUTINE flo_init( Kmm )          ! Empty routine 
    153       IMPLICIT NONE 
    154       INTEGER, INTENT( in ) :: Kmm 
    155    END SUBROUTINE flo_init 
    156 #endif 
    157141 
    158142   !!====================================================================== 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/FLO/floblk.F90

    r10970 r11822  
    44   !! Ocean floats :   trajectory computation 
    55   !!====================================================================== 
    6 #if   defined key_floats 
    7    !!---------------------------------------------------------------------- 
    8    !!   'key_floats'                                     float trajectories 
     6   !! 
    97   !!---------------------------------------------------------------------- 
    108   !!    flotblk     : compute float trajectories with Blanke algorithme 
    … …  
    370368   END SUBROUTINE flo_blk 
    371369 
    372 #  else 
    373    !!---------------------------------------------------------------------- 
    374    !!   Default option                                         Empty module 
    375    !!---------------------------------------------------------------------- 
    376 CONTAINS 
    377    SUBROUTINE flo_blk                  ! Empty routine 
    378    END SUBROUTINE flo_blk  
    379 #endif 
    380     
    381370   !!====================================================================== 
    382371END MODULE floblk  

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/FLO/flodom.F90

    r10970 r11822  
    66   !! History :  OPA  ! 1998-07 (Y.Drillet, CLIPPER)  Original code 
    77   !!  NEMO      3.3  ! 2011-09 (C.Bricaud,S.Law-Chune Mercator-Ocean): add ARIANE convention + comsecitc changes 
    8    !!---------------------------------------------------------------------- 
    9 #if   defined key_floats 
    10    !!---------------------------------------------------------------------- 
    11    !!   'key_floats'                                     float trajectories 
    128   !!---------------------------------------------------------------------- 
    139   !!   flo_dom               : initialization of floats 
    … …  
    458454   END FUNCTION flo_dom_alloc 
    459455 
    460  
    461 #else 
    462    !!---------------------------------------------------------------------- 
    463    !!   Default option                                         Empty module 
    464    !!---------------------------------------------------------------------- 
    465 CONTAINS 
    466    SUBROUTINE flo_dom                 ! Empty routine 
    467          WRITE(*,*) 'flo_dom: : You should not have seen this print! error?' 
    468    END SUBROUTINE flo_dom 
    469 #endif 
    470  
    471456   !!====================================================================== 
    472457END MODULE flodom 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/FLO/florst.F90

    r10425 r11822  
    88   !!   NEMO      1.0  !  2002-10  (A. Bozec)  F90 : Free form and module 
    99   !!             3.2  !  2010-08  (slaw, cbricaud): netcdf outputs and others  
    10    !!---------------------------------------------------------------------- 
    11 #if   defined key_floats 
    12    !!---------------------------------------------------------------------- 
    13    !!   'key_floats'                                     float trajectories 
    1410   !!---------------------------------------------------------------------- 
    1511   USE flo_oce         ! ocean drifting floats 
    … …  
    125121   END SUBROUTINE flo_rst 
    126122 
    127 #  else 
    128    !!---------------------------------------------------------------------- 
    129    !!   Default option                                         Empty module 
    130    !!---------------------------------------------------------------------- 
    131 CONTAINS 
    132    SUBROUTINE flo_rst                 ! Empty routine 
    133    END SUBROUTINE flo_rst 
    134 #endif 
    135  
    136123   !!======================================================================= 
    137124END MODULE florst 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/FLO/flowri.F90

    r10970 r11822  
    1010   !!   NEMO      1.0  !  2002-10  (A. Bozec)  F90 : Free form and module 
    1111   !!             3.2  !  2010-08  (slaw, cbricaud): netcdf outputs and others  
    12    !!---------------------------------------------------------------------- 
    13 #if   defined key_floats 
    14    !!---------------------------------------------------------------------- 
    15    !!   'key_floats'                                     float trajectories 
    1612   !!---------------------------------------------------------------------- 
    1713   USE flo_oce         ! ocean drifting floats 
    … …  
    180176               CALL ctl_opn( numflo, 'trajec_float', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) 
    181177               irecflo = NINT( (nitend-nn_it000) / FLOAT(nn_writefl) ) 
    182                WRITE(numflo,*)cexper,no,irecflo,jpnfl,nn_writefl 
     178               WRITE(numflo,*) cexper, irecflo, jpnfl, nn_writefl 
    183179            ENDIF 
    184180 
    … …  
    256252 
    257253               istart = (/jfl,irec/) 
    258                icfl   = INT( tpkfl(jfl) )            ! K-index of the nearest point before 
    259  
    260                CALL flioputv( numflo , 'traj_lon'    , zlon(jfl)        , start=istart ) 
    261                CALL flioputv( numflo , 'traj_lat'    , zlat(jfl)        , start=istart )   
    262                CALL flioputv( numflo , 'traj_depth'  , zdep(jfl)        , start=istart )   
    263                CALL flioputv( numflo , 'traj_temp'   , ztemp(icfl,jfl)  , start=istart )   
    264                CALL flioputv( numflo , 'traj_salt'   , zsal(icfl,jfl)   , start=istart )   
    265                CALL flioputv( numflo , 'traj_dens'   , zrho(icfl,jfl)   , start=istart )   
     254 
     255               CALL flioputv( numflo , 'traj_lon'    , zlon(jfl), start=istart ) 
     256               CALL flioputv( numflo , 'traj_lat'    , zlat(jfl), start=istart )   
     257               CALL flioputv( numflo , 'traj_depth'  , zdep(jfl), start=istart )   
     258               CALL flioputv( numflo , 'traj_temp'   , ztem(jfl), start=istart )   
     259               CALL flioputv( numflo , 'traj_salt'   , zsal(jfl), start=istart )   
     260               CALL flioputv( numflo , 'traj_dens'   , zrho(jfl), start=istart )   
    266261 
    267262            ENDDO 
    … …  
    278273   END SUBROUTINE flo_wri 
    279274 
    280  
    281 #  else 
    282    !!---------------------------------------------------------------------- 
    283    !!   Default option                                         Empty module 
    284    !!---------------------------------------------------------------------- 
    285 CONTAINS 
    286    SUBROUTINE flo_wri                 ! Empty routine 
    287    END SUBROUTINE flo_wri 
    288 #endif 
    289  
    290275   !!======================================================================= 
    291276END MODULE flowri 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/ICB/icbini.F90

    r10702 r11822  
    406406      REWIND( numnam_ref )              ! Namelist namberg in reference namelist : Iceberg parameters 
    407407      READ  ( numnam_ref, namberg, IOSTAT = ios, ERR = 901) 
    408 901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namberg in reference namelist', lwp ) 
     408901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namberg in reference namelist' ) 
    409409      REWIND( numnam_cfg )              ! Namelist namberg in configuration namelist : Iceberg parameters 
    410410      READ  ( numnam_cfg, namberg, IOSTAT = ios, ERR = 902 ) 
    411 902   IF( ios >  0 ) CALL ctl_nam ( ios , 'namberg in configuration namelist', lwp ) 
     411902   IF( ios >  0 ) CALL ctl_nam ( ios , 'namberg in configuration namelist' ) 
    412412      IF(lwm) WRITE ( numond, namberg ) 
    413413      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/ICB/icblbc.F90

    r10570 r11822  
    278278         CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req1) 
    279279         CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) 
    280          IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 
     280         CALL mpi_wait( iml_req1, iml_stat, iml_err ) 
    281281         ibergs_rcvd_from_e = INT( zewbergs(2) ) 
    282282      CASE(  0 ) 
    … …  
    287287         CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) 
    288288         CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) 
    289          IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 
    290          IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 
     289         CALL mpi_wait( iml_req2, iml_stat, iml_err ) 
     290         CALL mpi_wait( iml_req3, iml_stat, iml_err ) 
    291291         ibergs_rcvd_from_e = INT( zewbergs(2) ) 
    292292         ibergs_rcvd_from_w = INT( zwebergs(2) ) 
    … …  
    295295         CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req4) 
    296296         CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) 
    297          IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 
     297         CALL mpi_wait( iml_req4, iml_stat, iml_err ) 
    298298         ibergs_rcvd_from_w = INT( zwebergs(2) ) 
    299299      END SELECT 
    … …  
    310310            CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width ) 
    311311         ENDIF 
    312          IF( ibergs_to_send_e > 0 .AND. l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 
     312         IF( ibergs_to_send_e > 0 ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 
    313313         DO i = 1, ibergs_rcvd_from_e 
    314314            IF( nn_verbose_level >= 4 ) THEN 
    … …  
    329329            CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width ) 
    330330         ENDIF 
    331          IF( ibergs_to_send_w > 0 .AND. l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 
    332          IF( ibergs_to_send_e > 0 .AND. l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 
     331         IF( ibergs_to_send_w > 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 
     332         IF( ibergs_to_send_e > 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 
    333333         DO i = 1, ibergs_rcvd_from_e 
    334334            IF( nn_verbose_level >= 4 ) THEN 
    … …  
    351351            CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width ) 
    352352         ENDIF 
    353          IF( ibergs_to_send_w > 0 .AND. l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 
     353         IF( ibergs_to_send_w > 0 ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 
    354354         DO i = 1, ibergs_rcvd_from_w 
    355355            IF( nn_verbose_level >= 4 ) THEN 
    … …  
    409409         CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req1) 
    410410         CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) 
    411          IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 
     411         CALL mpi_wait( iml_req1, iml_stat, iml_err ) 
    412412         ibergs_rcvd_from_n = INT( znsbergs(2) ) 
    413413      CASE(  0 ) 
    … …  
    418418         CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) 
    419419         CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) 
    420          IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 
    421          IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 
     420         CALL mpi_wait( iml_req2, iml_stat, iml_err ) 
     421         CALL mpi_wait( iml_req3, iml_stat, iml_err ) 
    422422         ibergs_rcvd_from_n = INT( znsbergs(2) ) 
    423423         ibergs_rcvd_from_s = INT( zsnbergs(2) ) 
    … …  
    426426         CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req4) 
    427427         CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) 
    428          IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 
     428         CALL mpi_wait( iml_req4, iml_stat, iml_err ) 
    429429         ibergs_rcvd_from_s = INT( zsnbergs(2) ) 
    430430      END SELECT 
    … …  
    441441            CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width ) 
    442442         ENDIF 
    443          IF( ibergs_to_send_n > 0 .AND. l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 
     443         IF( ibergs_to_send_n > 0 ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 
    444444         DO i = 1, ibergs_rcvd_from_n 
    445445            IF( nn_verbose_level >= 4 ) THEN 
    … …  
    460460            CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width ) 
    461461         ENDIF 
    462          IF( ibergs_to_send_s > 0 .AND. l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 
    463          IF( ibergs_to_send_n > 0 .AND. l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 
     462         IF( ibergs_to_send_s > 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 
     463         IF( ibergs_to_send_n > 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 
    464464         DO i = 1, ibergs_rcvd_from_n 
    465465            IF( nn_verbose_level >= 4 ) THEN 
    … …  
    482482            CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width ) 
    483483         ENDIF 
    484          IF( ibergs_to_send_s > 0 .AND. l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 
     484         IF( ibergs_to_send_s > 0 ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 
    485485         DO i = 1, ibergs_rcvd_from_s 
    486486            IF( nn_verbose_level >= 4 ) THEN 
    … …  
    669669            ifldproc = nicbfldproc(jn) 
    670670            IF( ifldproc == narea ) CYCLE 
    671  
    672             IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) 
     671            CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) 
    673672         ENDIF 
    674673         ! 
    … …  
    770769            ifldproc = nicbfldproc(jn) 
    771770            IF( ifldproc == narea ) CYCLE 
    772  
    773             IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) 
     771            CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) 
    774772         ENDIF 
    775773         ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/ICB/icbrst.F90

    r10425 r11822  
    131131      CALL iom_get( ncid, jpdom_unknown, 'kount' , zdata(:) ) 
    132132      num_bergs(:) = INT(zdata(:)) 
    133       ! Close file 
    134       CALL iom_close( ncid ) 
    135133      ! 
    136134 
    … …  
    146144      IF( lwp )   WRITE(numout,'(a,i5,a,i5,a)') 'icebergs, icb_rst_read: there were',ibergs_in_file,   & 
    147145         &                                    ' bergs in the restart file and', jn,' bergs have been read' 
     146      ! Close file 
     147      CALL iom_close( ncid ) 
    148148      ! 
    149149      ! Confirm that all areas have a suitable base for assigning new iceberg 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/ICB/icbstp.F90

    r10570 r11822  
    8686      !                                   !* write out time 
    8787      ll_verbose = .FALSE. 
    88       IF( nn_verbose_write > 0 .AND. MOD( kt-1 , nn_verbose_write ) == 0 )   ll_verbose = ( nn_verbose_level >= 0 ) 
     88      IF( nn_verbose_write > 0 .AND. MOD( kt-1 , nn_verbose_write ) == 0 )   ll_verbose = ( nn_verbose_level > 0 ) 
    8989      ! 
    9090      IF( ll_verbose )   WRITE(numicb,9100) nktberg, ndastp, nsec_day 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/IOM/in_out_manager.F90

    r10601 r11822  
    8080   INTEGER       ::   nleapy                      !: Leap year calendar flag (0/1 or 30) 
    8181   INTEGER       ::   ninist                      !: initial state output flag (0/1) 
    82    INTEGER       ::   nwrite                      !: model standard output frequency 
    83    INTEGER       ::   nstock                      !: restart file frequency 
    84    INTEGER, DIMENSION(10) :: nstocklist           !: restart dump times 
    8582 
    8683   !!---------------------------------------------------------------------- 
    … …  
    119116      INTEGER :: ptimincr  = 1        !: timestep increment to output (time.step and run.stat) 
    120117   END TYPE 
    121    TYPE(sn_ctl) :: sn_cfctl     !: run control structure for selective output 
     118   TYPE(sn_ctl), SAVE :: sn_cfctl     !: run control structure for selective output, must have SAVE for default init. of sn_ctl 
    122119   LOGICAL ::   ln_timing        !: run control for timing 
    123120   LOGICAL ::   ln_diacfl        !: flag whether to create CFL diagnostics 
    … …  
    167164   CHARACTER(lc) ::   ctmp7, ctmp8, ctmp9   !: temporary characters 7 to 9 
    168165   CHARACTER(lc) ::   ctmp10                !: temporary character 10 
    169    CHARACTER(lc) ::   cform_err = "(/,' ===>>> : E R R O R',     /,'         ===========',/)"       !: 
    170    CHARACTER(lc) ::   cform_war = "(/,' ===>>> : W A R N I N G', /,'         ===============',/)"   !: 
    171166   LOGICAL       ::   lwm      = .FALSE.    !: boolean : true on the 1st processor only (always) 
    172167   LOGICAL       ::   lwp      = .FALSE.    !: boolean : true on the 1st processor only .OR. ln_ctl 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/IOM/iom.F90

    r11504 r11822  
    5757   PUBLIC iom_init, iom_swap, iom_open, iom_close, iom_setkt, iom_varid, iom_get 
    5858   PUBLIC iom_chkatt, iom_getatt, iom_putatt, iom_getszuld, iom_rstput, iom_delay_rst, iom_put 
    59    PUBLIC iom_use, iom_context_finalize 
     59   PUBLIC iom_use, iom_context_finalize, iom_miss_val 
    6060 
    6161   PRIVATE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d 
    … …  
    211211          CALL iom_set_axis_attr( "depthv", bounds=zw_bnds ) 
    212212          CALL iom_set_axis_attr( "depthw", bounds=zt_bnds ) 
    213           ! 
    214 # if defined key_floats 
    215213          CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) ) 
    216 # endif 
    217214# if defined key_si3 
    218215          CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) 
    … …  
    221218# endif 
    222219#if defined key_top 
    223           CALL iom_set_axis_attr( "profsed", paxis = profsed ) 
     220          IF( ALLOCATED(profsed) ) CALL iom_set_axis_attr( "profsed", paxis = profsed ) 
    224221#endif 
    225222          CALL iom_set_axis_attr( "icbcla", class_num ) 
    226           CALL iom_set_axis_attr( "iax_20C", (/ REAL(20,wp) /) ) 
    227           CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) ) 
     223          CALL iom_set_axis_attr( "iax_20C", (/ REAL(20,wp) /) )   ! strange syntaxe and idea... 
     224          CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) )   ! strange syntaxe and idea... 
    228225      ENDIF 
    229226      ! 
    … …  
    696693      clname   = trim(cdname) 
    697694      IF ( .NOT. Agrif_Root() .AND. .NOT. lliof ) THEN 
    698          iln    = INDEX(clname,'/')  
     695!FUS         iln    = INDEX(clname,'/')  
     696         iln    = INDEX(clname,'/',BACK=.true.)  ! FUS: to insert the nest index at the right location within the string, the last / has to be found (search from the right to left) 
    699697         cltmpn = clname(1:iln) 
    700698         clname = clname(iln+1:LEN_TRIM(clname)) 
    … …  
    834832 
    835833 
    836    FUNCTION iom_varid ( kiomid, cdvar, kdimsz, kndims, ldstop )   
     834   FUNCTION iom_varid ( kiomid, cdvar, kdimsz, kndims, lduld, ldstop )   
    837835      !!----------------------------------------------------------------------- 
    838836      !!                  ***  FUNCTION  iom_varid  *** 
    … …  
    843841      CHARACTER(len=*)     , INTENT(in   )           ::   cdvar    ! name of the variable 
    844842      INTEGER, DIMENSION(:), INTENT(  out), OPTIONAL ::   kdimsz   ! size of each dimension 
    845       INTEGER,               INTENT(  out), OPTIONAL ::   kndims   ! size of the dimensions 
     843      INTEGER              , INTENT(  out), OPTIONAL ::   kndims   ! number of dimensions 
     844      LOGICAL              , INTENT(  out), OPTIONAL ::   lduld    ! true if the last dimension is unlimited (time) 
    846845      LOGICAL              , INTENT(in   ), OPTIONAL ::   ldstop   ! stop if looking for non-existing variable (default = .TRUE.) 
    847846      ! 
    … …  
    873872               iiv = iiv + 1 
    874873               IF( iiv <= jpmax_vars ) THEN 
    875                   iom_varid = iom_nf90_varid( kiomid, cdvar, iiv, kdimsz, kndims ) 
     874                  iom_varid = iom_nf90_varid( kiomid, cdvar, iiv, kdimsz, kndims, lduld ) 
    876875               ELSE 
    877876                  CALL ctl_stop( trim(clinfo), 'Too many variables in the file '//iom_file(kiomid)%name,   & 
    … …  
    891890               ENDIF 
    892891               IF( PRESENT(kndims) )  kndims = iom_file(kiomid)%ndims(iiv) 
     892               IF( PRESENT( lduld) )  lduld  = iom_file(kiomid)%luld( iiv) 
    893893            ENDIF 
    894894         ENDIF 
    … …  
    12691269               !--- overlap areas and extra hallows (mpp) 
    12701270               IF(     PRESENT(pv_r2d) .AND. idom /= jpdom_unknown ) THEN 
    1271                   CALL lbc_lnk( 'iom', pv_r2d,'Z',-999.,'no0' ) 
     1271                  CALL lbc_lnk( 'iom', pv_r2d,'Z', -999., kfillmode = jpfillnothing ) 
    12721272               ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown ) THEN 
    12731273                  ! this if could be simplified with the new lbc_lnk that works with any size of the 3rd dimension 
    12741274                  IF( icnt(3) == inlev ) THEN 
    1275                      CALL lbc_lnk( 'iom', pv_r3d,'Z',-999.,'no0' ) 
     1275                     CALL lbc_lnk( 'iom', pv_r3d,'Z', -999., kfillmode = jpfillnothing ) 
    12761276                  ELSE   ! put some arbitrary value (a call to lbc_lnk will be done later...) 
    12771277                     DO jj = nlcj+1, jpj   ;   pv_r3d(1:nlci, jj, :) = pv_r3d(1:nlci, nlej, :)   ;   END DO 
    … …  
    12981298            CALL xios_recv_field( trim(cdvar), pv_r3d) 
    12991299            IF(idom /= jpdom_unknown ) then 
    1300                 CALL lbc_lnk( 'iom', pv_r3d,'Z',-999.,'no0' ) 
     1300                CALL lbc_lnk( 'iom', pv_r3d,'Z', -999., kfillmode = jpfillnothing) 
    13011301            ENDIF 
    13021302         ELSEIF( PRESENT(pv_r2d) ) THEN 
    … …  
    13051305            CALL xios_recv_field( trim(cdvar), pv_r2d) 
    13061306            IF(idom /= jpdom_unknown ) THEN 
    1307                 CALL lbc_lnk('iom', pv_r2d,'Z',-999.,'no0') 
     1307                CALL lbc_lnk('iom', pv_r2d,'Z',-999., kfillmode = jpfillnothing) 
    13081308            ENDIF 
    13091309         ELSEIF( PRESENT(pv_r1d) ) THEN 
    … …  
    16681668      CHARACTER(LEN=*), INTENT(in) ::   cdname 
    16691669      REAL(wp)        , INTENT(in) ::   pfield0d 
    1670       REAL(wp)        , DIMENSION(jpi,jpj) ::   zz     ! masson 
     1670!!      REAL(wp)        , DIMENSION(jpi,jpj) ::   zz     ! masson 
    16711671#if defined key_iomput 
    1672       zz(:,:)=pfield0d 
    1673       CALL xios_send_field(cdname, zz) 
    1674       !CALL xios_send_field(cdname, (/pfield0d/))  
     1672!!clem      zz(:,:)=pfield0d 
     1673!!clem      CALL xios_send_field(cdname, zz) 
     1674      CALL xios_send_field(cdname, (/pfield0d/))  
    16751675#else 
    16761676      IF( .FALSE. )   WRITE(numout,*) cdname, pfield0d   ! useless test to avoid compilation warnings 
    … …  
    19781978      ! Cell vertices on boundries 
    19791979      DO jn = 1, 4 
    1980          CALL lbc_lnk( 'iom', z_bnds(jn,:,:,1), cdgrd, 1., pval=999._wp ) 
    1981          CALL lbc_lnk( 'iom', z_bnds(jn,:,:,2), cdgrd, 1., pval=999._wp ) 
     1980         CALL lbc_lnk( 'iom', z_bnds(jn,:,:,1), cdgrd, 1., pfillval=999._wp ) 
     1981         CALL lbc_lnk( 'iom', z_bnds(jn,:,:,2), cdgrd, 1., pfillval=999._wp ) 
    19821982      END DO 
    19831983      ! 
    … …  
    22382238      CHARACTER(LEN=20)  ::   clfreq 
    22392239      CHARACTER(LEN=20)  ::   cldate 
     2240      CHARACTER(LEN=256) ::   cltmpn                 !FUS needed for correct path with AGRIF 
     2241      INTEGER            ::   iln                    !FUS needed for correct path with AGRIF 
    22402242      INTEGER            ::   idx 
    22412243      INTEGER            ::   jn 
    … …  
    23202322            END DO 
    23212323            ! 
    2322             IF( jn == 1 .AND. TRIM(Agrif_CFixed()) /= '0' )   clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) 
     2324!FUS            IF( jn == 1 .AND. TRIM(Agrif_CFixed()) /= '0' )   clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) 
     2325!FUS see comment line 700  
     2326            IF( jn == 1 .AND. TRIM(Agrif_CFixed()) /= '0' ) THEN 
     2327             iln    = INDEX(clname,'/',BACK=.true.) 
     2328             cltmpn = clname(1:iln) 
     2329             clname = clname(iln+1:LEN_TRIM(clname)) 
     2330             clname = TRIM(cltmpn)//TRIM(Agrif_CFixed())//'_'//TRIM(clname) 
     2331            ENDIF 
     2332!FUS  
    23232333            IF( jn == 1 )   CALL iom_set_file_attr( cdid, name        = clname ) 
    23242334            IF( jn == 2 )   CALL iom_set_file_attr( cdid, name_suffix = clname ) 
    … …  
    23882398   !!   NOT 'key_iomput'                               a few dummy routines 
    23892399   !!---------------------------------------------------------------------- 
    2390  
    23912400   SUBROUTINE iom_setkt( kt, cdname ) 
    23922401      INTEGER         , INTENT(in)::   kt  
    … …  
    24032412 
    24042413   LOGICAL FUNCTION iom_use( cdname ) 
    2405       !!---------------------------------------------------------------------- 
    2406       !!---------------------------------------------------------------------- 
    24072414      CHARACTER(LEN=*), INTENT(in) ::   cdname 
    2408       !!---------------------------------------------------------------------- 
    24092415#if defined key_iomput 
    24102416      iom_use = xios_field_is_active( cdname ) 
    … …  
    24132419#endif 
    24142420   END FUNCTION iom_use 
    2415     
     2421 
     2422   SUBROUTINE iom_miss_val( cdname, pmiss_val ) 
     2423      CHARACTER(LEN=*), INTENT(in ) ::   cdname 
     2424      REAL(wp)        , INTENT(out) ::   pmiss_val    
     2425#if defined key_iomput 
     2426      ! get missing value 
     2427      CALL xios_get_field_attr( cdname, default_value = pmiss_val ) 
     2428#else 
     2429      IF( .FALSE. )   WRITE(numout,*) cdname, pmiss_val   ! useless test to avoid compilation warnings 
     2430#endif 
     2431   END SUBROUTINE iom_miss_val 
     2432   
    24162433   !!====================================================================== 
    24172434END MODULE iom 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/IOM/iom_nf90.F90

    r10522 r11822  
    187187 
    188188 
    189    FUNCTION iom_nf90_varid ( kiomid, cdvar, kiv, kdimsz, kndims )   
     189   FUNCTION iom_nf90_varid ( kiomid, cdvar, kiv, kdimsz, kndims, lduld )   
    190190      !!----------------------------------------------------------------------- 
    191191      !!                  ***  FUNCTION  iom_varid  *** 
    … …  
    198198      INTEGER, DIMENSION(:), INTENT(  out), OPTIONAL ::   kdimsz   ! size of the dimensions 
    199199      INTEGER,               INTENT(  out), OPTIONAL ::   kndims   ! size of the dimensions 
     200      LOGICAL              , INTENT(  out), OPTIONAL ::   lduld    ! true if the last dimension is unlimited (time) 
    200201      ! 
    201202      INTEGER                        ::   iom_nf90_varid   ! iom variable Id 
    … …  
    251252         ENDIF 
    252253         IF( PRESENT(kndims) )  kndims = iom_file(kiomid)%ndims(kiv) 
     254         IF( PRESENT( lduld) )  lduld  = iom_file(kiomid)%luld(kiv) 
    253255      ELSE   
    254256         iom_nf90_varid = -1   !   variable not found, return error code: -1 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/IOM/restart.F90

    r11027 r11822  
    7070         IF( ln_rst_list ) THEN 
    7171            nrst_lst = 1 
    72             nitrst = nstocklist( nrst_lst ) 
     72            nitrst = nn_stocklist( nrst_lst ) 
    7373         ELSE 
    7474            nitrst = nitend 
    7575         ENDIF 
    7676      ENDIF 
     77       
     78      IF( .NOT. ln_rst_list .AND. nn_stock == -1 )   RETURN   ! we will never do any restart 
    7779 
    7880      ! frequency-based restart dumping (nn_stock) 
    79       IF( .NOT. ln_rst_list .AND. MOD( kt - 1, nstock ) == 0 ) THEN    
     81      IF( .NOT. ln_rst_list .AND. MOD( kt - 1, nn_stock ) == 0 ) THEN    
    8082         ! we use kt - 1 and not kt - nit000 to keep the same periodicity from the beginning of the experiment 
    81          nitrst = kt + nstock - 1                  ! define the next value of nitrst for restart writing 
     83         nitrst = kt + nn_stock - 1                  ! define the next value of nitrst for restart writing 
    8284         IF( nitrst > nitend )   nitrst = nitend   ! make sure we write a restart at the end of the run 
    8385      ENDIF 
    … …  
    8587      ! we open and define the ocean restart file one time step before writing the data (-> at nitrst - 1) 
    8688      ! except if we write ocean restart files every time step or if an ocean restart file was writen at nitend - 1 
    87       IF( kt == nitrst - 1 .OR. nstock == 1 .OR. ( kt == nitend .AND. .NOT. lrst_oce ) ) THEN 
     89      IF( kt == nitrst - 1 .OR. nn_stock == 1 .OR. ( kt == nitend .AND. .NOT. lrst_oce ) ) THEN 
    8890         IF( nitrst <= nitend .AND. nitrst > 0 ) THEN  
    8991            ! beware of the format used to write kt (default is i8.8, that should be large enough...) 
    … …  
    185187         lrst_oce = .FALSE. 
    186188            IF( ln_rst_list ) THEN 
    187                nrst_lst = MIN(nrst_lst + 1, SIZE(nstocklist,1)) 
    188                nitrst = nstocklist( nrst_lst ) 
     189               nrst_lst = MIN(nrst_lst + 1, SIZE(nn_stocklist,1)) 
     190               nitrst = nn_stocklist( nrst_lst ) 
    189191            ENDIF 
    190192      ENDIF 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/LBC/lbc_lnk_multi_generic.h90

    r10425 r11822  
    1414#   define PTR_ptab              pt4d 
    1515#endif 
    16    SUBROUTINE ROUTINE_MULTI( cdname                                                    & 
    17       &                    , pt1, cdna1, psgn1, pt2, cdna2, psgn2, pt3, cdna3, psgn3   & 
    18       &                    , pt4, cdna4, psgn4, pt5, cdna5, psgn5, pt6, cdna6, psgn6   & 
    19       &                    , pt7, cdna7, psgn7, pt8, cdna8, psgn8, pt9, cdna9, psgn9, cd_mpp, pval) 
     16 
     17   SUBROUTINE ROUTINE_MULTI( cdname                                                                             & 
     18      &                    , pt1, cdna1, psgn1, pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4, cdna4, psgn4   & 
     19      &                    , pt5, cdna5, psgn5, pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8, cdna8, psgn8   & 
     20      &                    , pt9, cdna9, psgn9, pt10, cdna10, psgn10, pt11, cdna11, psgn11                      & 
     21      &                    , kfillmode, pfillval, lsend, lrecv, ihlcom ) 
    2022      !!--------------------------------------------------------------------- 
    21       CHARACTER(len=*)   ,                   INTENT(in   ) ::   cdname  ! name of the calling subroutine 
    22       ARRAY_TYPE(:,:,:,:)          , TARGET, INTENT(inout) ::   pt1     ! arrays on which the lbc is applied 
    23       ARRAY_TYPE(:,:,:,:), OPTIONAL, TARGET, INTENT(inout) ::   pt2  ,  pt3  , pt4  , pt5  , pt6  , pt7  , pt8  , pt9 
    24       CHARACTER(len=1)                     , INTENT(in   ) ::   cdna1   ! nature of pt2D. array grid-points 
    25       CHARACTER(len=1)   , OPTIONAL        , INTENT(in   ) ::   cdna2,  cdna3, cdna4, cdna5, cdna6, cdna7, cdna8, cdna9 
    26       REAL(wp)                             , INTENT(in   ) ::   psgn1   ! sign used across the north fold 
    27       REAL(wp)           , OPTIONAL        , INTENT(in   ) ::   psgn2,  psgn3, psgn4, psgn5, psgn6, psgn7, psgn8, psgn9    
    28       CHARACTER(len=3)   , OPTIONAL        , INTENT(in   ) ::   cd_mpp  ! fill the overlap area only 
    29       REAL(wp)           , OPTIONAL        , INTENT(in   ) ::   pval    ! background value (used at closed boundaries) 
     23      CHARACTER(len=*)   ,                   INTENT(in   ) :: cdname  ! name of the calling subroutine 
     24      ARRAY_TYPE(:,:,:,:)          , TARGET, INTENT(inout) :: pt1     ! arrays on which the lbc is applied 
     25      ARRAY_TYPE(:,:,:,:), OPTIONAL, TARGET, INTENT(inout) :: pt2  , pt3  , pt4  , pt5  , pt6  , pt7  , pt8  , pt9  , pt10  , pt11 
     26      CHARACTER(len=1)                     , INTENT(in   ) :: cdna1   ! nature of pt2D. array grid-points 
     27      CHARACTER(len=1)   , OPTIONAL        , INTENT(in   ) :: cdna2, cdna3, cdna4, cdna5, cdna6, cdna7, cdna8, cdna9, cdna10, cdna11 
     28      REAL(wp)                             , INTENT(in   ) :: psgn1   ! sign used across the north fold 
     29      REAL(wp)           , OPTIONAL        , INTENT(in   ) :: psgn2, psgn3, psgn4, psgn5, psgn6, psgn7, psgn8, psgn9, psgn10, psgn11 
     30      INTEGER            , OPTIONAL        , INTENT(in   ) :: kfillmode   ! filling method for halo over land (default = constant) 
     31      REAL(wp)           , OPTIONAL        , INTENT(in   ) :: pfillval    ! background value (used at closed boundaries) 
     32      LOGICAL, DIMENSION(4), OPTIONAL      , INTENT(in   ) :: lsend, lrecv   ! indicate how communications are to be carried out 
     33      INTEGER            , OPTIONAL        , INTENT(in   ) :: ihlcom         ! number of ranks and rows to be communicated 
    3034      !! 
    31       INTEGER                         ::   kfld        ! number of elements that will be attributed 
    32       PTR_TYPE         , DIMENSION(9) ::   ptab_ptr    ! pointer array 
    33       CHARACTER(len=1) , DIMENSION(9) ::   cdna_ptr    ! nature of ptab_ptr grid-points 
    34       REAL(wp)         , DIMENSION(9) ::   psgn_ptr    ! sign used across the north fold boundary 
     35      INTEGER                          ::   kfld        ! number of elements that will be attributed 
     36      PTR_TYPE         , DIMENSION(11) ::   ptab_ptr    ! pointer array 
     37      CHARACTER(len=1) , DIMENSION(11) ::   cdna_ptr    ! nature of ptab_ptr grid-points 
     38      REAL(wp)         , DIMENSION(11) ::   psgn_ptr    ! sign used across the north fold boundary 
    3539      !!--------------------------------------------------------------------- 
    3640      ! 
    … …  
    4145      ! 
    4246      !                 ! Look if more arrays are added 
    43       IF( PRESENT(psgn2) )   CALL ROUTINE_LOAD( pt2, cdna2, psgn2, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    44       IF( PRESENT(psgn3) )   CALL ROUTINE_LOAD( pt3, cdna3, psgn3, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    45       IF( PRESENT(psgn4) )   CALL ROUTINE_LOAD( pt4, cdna4, psgn4, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    46       IF( PRESENT(psgn5) )   CALL ROUTINE_LOAD( pt5, cdna5, psgn5, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    47       IF( PRESENT(psgn6) )   CALL ROUTINE_LOAD( pt6, cdna6, psgn6, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    48       IF( PRESENT(psgn7) )   CALL ROUTINE_LOAD( pt7, cdna7, psgn7, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    49       IF( PRESENT(psgn8) )   CALL ROUTINE_LOAD( pt8, cdna8, psgn8, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    50       IF( PRESENT(psgn9) )   CALL ROUTINE_LOAD( pt9, cdna9, psgn9, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     47      IF( PRESENT(psgn2 ) )   CALL ROUTINE_LOAD( pt2 , cdna2 , psgn2 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     48      IF( PRESENT(psgn3 ) )   CALL ROUTINE_LOAD( pt3 , cdna3 , psgn3 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     49      IF( PRESENT(psgn4 ) )   CALL ROUTINE_LOAD( pt4 , cdna4 , psgn4 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     50      IF( PRESENT(psgn5 ) )   CALL ROUTINE_LOAD( pt5 , cdna5 , psgn5 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     51      IF( PRESENT(psgn6 ) )   CALL ROUTINE_LOAD( pt6 , cdna6 , psgn6 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     52      IF( PRESENT(psgn7 ) )   CALL ROUTINE_LOAD( pt7 , cdna7 , psgn7 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     53      IF( PRESENT(psgn8 ) )   CALL ROUTINE_LOAD( pt8 , cdna8 , psgn8 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     54      IF( PRESENT(psgn9 ) )   CALL ROUTINE_LOAD( pt9 , cdna9 , psgn9 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     55      IF( PRESENT(psgn10) )   CALL ROUTINE_LOAD( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     56      IF( PRESENT(psgn11) )   CALL ROUTINE_LOAD( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    5157      ! 
    52       CALL lbc_lnk_ptr( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, cd_mpp, pval ) 
     58      CALL lbc_lnk_ptr    ( cdname,               ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv, ihlcom ) 
    5359      ! 
    5460   END SUBROUTINE ROUTINE_MULTI 
    … …  
    7278      ! 
    7379   END SUBROUTINE ROUTINE_LOAD 
     80 
    7481#undef ARRAY_TYPE 
    7582#undef PTR_TYPE 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/LBC/lbc_nfd_nogather_generic.h90

    r10425 r11822  
    7474      ! 
    7575      ! Security check for further developments 
    76       IF ( ipf > 1 ) THEN 
    77         write(6,*) 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation'  
    78         write(6,*) 'You should not be there...'  
    79         STOP 
    80       ENDIF 
     76      IF ( ipf > 1 ) CALL ctl_stop( 'STOP', 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation...' ) 
    8177      ! 
    8278      ijpj   = 1    ! index of first modified line  

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/LBC/lbclnk.F90

    r10425 r11822  
    1414   !!             -   ! 2017-05  (G. Madec) create generic.h90 files to generate all lbc and north fold routines 
    1515   !!---------------------------------------------------------------------- 
    16 #if defined key_mpp_mpi 
    17    !!---------------------------------------------------------------------- 
    18    !!   'key_mpp_mpi'             MPI massively parallel processing library 
    19    !!---------------------------------------------------------------------- 
    2016   !!           define the generic interfaces of lib_mpp routines 
    2117   !!---------------------------------------------------------------------- 
    … …  
    2319   !!   lbc_bdy_lnk   : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp 
    2420   !!---------------------------------------------------------------------- 
    25    USE par_oce        ! ocean dynamics and tracers    
     21   USE dom_oce        ! ocean space and time domain 
    2622   USE lib_mpp        ! distributed memory computing library 
    2723   USE lbcnfd         ! north fold 
     24   USE in_out_manager ! I/O manager 
     25 
     26   IMPLICIT NONE 
     27   PRIVATE 
    2828 
    2929   INTERFACE lbc_lnk 
    … …  
    3737   END INTERFACE 
    3838   ! 
    39    INTERFACE lbc_bdy_lnk 
    40       MODULE PROCEDURE mpp_lnk_bdy_2d, mpp_lnk_bdy_3d, mpp_lnk_bdy_4d 
    41    END INTERFACE 
    42    ! 
    4339   INTERFACE lbc_lnk_icb 
    4440      MODULE PROCEDURE mpp_lnk_2d_icb 
    4541   END INTERFACE 
    4642 
     43   INTERFACE mpp_nfd 
     44      MODULE PROCEDURE   mpp_nfd_2d    , mpp_nfd_3d    , mpp_nfd_4d 
     45      MODULE PROCEDURE   mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 
     46   END INTERFACE 
     47 
    4748   PUBLIC   lbc_lnk       ! ocean/ice lateral boundary conditions 
    4849   PUBLIC   lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 
    49    PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
    5050   PUBLIC   lbc_lnk_icb   ! iceberg lateral boundary conditions 
     51 
     52#if   defined key_mpp_mpi 
     53!$AGRIF_DO_NOT_TREAT 
     54   INCLUDE 'mpif.h' 
     55!$AGRIF_END_DO_NOT_TREAT 
     56#endif 
     57 
     58   INTEGER, PUBLIC, PARAMETER ::   jpfillnothing = 1 
     59   INTEGER, PUBLIC, PARAMETER ::   jpfillcst     = 2 
     60   INTEGER, PUBLIC, PARAMETER ::   jpfillcopy    = 3 
     61   INTEGER, PUBLIC, PARAMETER ::   jpfillperio   = 4 
     62   INTEGER, PUBLIC, PARAMETER ::   jpfillmpi     = 5 
    5163 
    5264   !!---------------------------------------------------------------------- 
    … …  
    5668   !!---------------------------------------------------------------------- 
    5769CONTAINS 
    58  
    59 #else 
    60    !!---------------------------------------------------------------------- 
    61    !!   Default option                              shared memory computing 
    62    !!---------------------------------------------------------------------- 
    63    !!                routines setting the appropriate values 
    64    !!         on first and last row and column of the global domain 
    65    !!---------------------------------------------------------------------- 
    66    !!   lbc_lnk_sum_3d: compute sum over the halos on a 3D variable on ocean mesh 
    67    !!   lbc_lnk_sum_3d: compute sum over the halos on a 2D variable on ocean mesh 
    68    !!   lbc_lnk       : generic interface for lbc_lnk_3d and lbc_lnk_2d 
    69    !!   lbc_lnk_3d    : set the lateral boundary condition on a 3D variable on ocean mesh 
    70    !!   lbc_lnk_2d    : set the lateral boundary condition on a 2D variable on ocean mesh 
    71    !!   lbc_bdy_lnk   : set the lateral BDY boundary condition 
    72    !!---------------------------------------------------------------------- 
    73    USE oce            ! ocean dynamics and tracers    
    74    USE dom_oce        ! ocean space and time domain  
    75    USE in_out_manager ! I/O manager 
    76    USE lbcnfd         ! north fold 
    77  
    78    IMPLICIT NONE 
    79    PRIVATE 
    80  
    81    INTERFACE lbc_lnk 
    82       MODULE PROCEDURE   lbc_lnk_2d      , lbc_lnk_3d      , lbc_lnk_4d 
    83    END INTERFACE 
    84    INTERFACE lbc_lnk_ptr 
    85       MODULE PROCEDURE   lbc_lnk_2d_ptr  , lbc_lnk_3d_ptr  , lbc_lnk_4d_ptr 
    86    END INTERFACE 
    87    INTERFACE lbc_lnk_multi 
    88       MODULE PROCEDURE   lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi 
    89    END INTERFACE 
    90    ! 
    91    INTERFACE lbc_bdy_lnk 
    92       MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d, lbc_bdy_lnk_4d 
    93    END INTERFACE 
    94    ! 
    95    INTERFACE lbc_lnk_icb 
    96       MODULE PROCEDURE lbc_lnk_2d_icb 
    97    END INTERFACE 
    98     
    99    PUBLIC   lbc_lnk       ! ocean/ice  lateral boundary conditions 
    100    PUBLIC   lbc_lnk_multi ! modified ocean/ice lateral boundary conditions 
    101    PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
    102    PUBLIC   lbc_lnk_icb   ! iceberg lateral boundary conditions 
    103     
    104    !!---------------------------------------------------------------------- 
    105    !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    106    !! $Id$ 
    107    !! Software governed by the CeCILL license (see ./LICENSE) 
    108    !!---------------------------------------------------------------------- 
    109 CONTAINS 
    110  
    111    !!====================================================================== 
    112    !!   Default option                           3D shared memory computing 
    113    !!====================================================================== 
    114    !!          routines setting land point, or east-west cyclic, 
    115    !!             or north-south cyclic, or north fold values 
    116    !!         on first and last row and column of the global domain 
    117    !!---------------------------------------------------------------------- 
    118  
    119    !!---------------------------------------------------------------------- 
    120    !!                   ***  routine lbc_lnk_(2,3,4)d  *** 
    121    !! 
    122    !!   * Argument : dummy argument use in lbc_lnk_... routines 
    123    !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
    124    !!                cd_nat :   nature of array grid-points 
    125    !!                psgn   :   sign used across the north fold boundary 
    126    !!                kfld   :   optional, number of pt3d arrays 
    127    !!                cd_mpp :   optional, fill the overlap area only 
    128    !!                pval   :   optional, background value (used at closed boundaries) 
    129    !!---------------------------------------------------------------------- 
    130    ! 
    131    !                       !==  2D array and array of 2D pointer  ==! 
    132    ! 
    133 #  define DIM_2d 
    134 #     define ROUTINE_LNK           lbc_lnk_2d 
    135 #     include "lbc_lnk_generic.h90" 
    136 #     undef ROUTINE_LNK 
    137 #     define MULTI 
    138 #     define ROUTINE_LNK           lbc_lnk_2d_ptr 
    139 #     include "lbc_lnk_generic.h90" 
    140 #     undef ROUTINE_LNK 
    141 #     undef MULTI 
    142 #  undef DIM_2d 
    143    ! 
    144    !                       !==  3D array and array of 3D pointer  ==! 
    145    ! 
    146 #  define DIM_3d 
    147 #     define ROUTINE_LNK           lbc_lnk_3d 
    148 #     include "lbc_lnk_generic.h90" 
    149 #     undef ROUTINE_LNK 
    150 #     define MULTI 
    151 #     define ROUTINE_LNK           lbc_lnk_3d_ptr 
    152 #     include "lbc_lnk_generic.h90" 
    153 #     undef ROUTINE_LNK 
    154 #     undef MULTI 
    155 #  undef DIM_3d 
    156    ! 
    157    !                       !==  4D array and array of 4D pointer  ==! 
    158    ! 
    159 #  define DIM_4d 
    160 #     define ROUTINE_LNK           lbc_lnk_4d 
    161 #     include "lbc_lnk_generic.h90" 
    162 #     undef ROUTINE_LNK 
    163 #     define MULTI 
    164 #     define ROUTINE_LNK           lbc_lnk_4d_ptr 
    165 #     include "lbc_lnk_generic.h90" 
    166 #     undef ROUTINE_LNK 
    167 #     undef MULTI 
    168 #  undef DIM_4d 
    169     
    170    !!====================================================================== 
    171    !!   identical routines in both C1D and shared memory computing 
    172    !!====================================================================== 
    173  
    174    !!---------------------------------------------------------------------- 
    175    !!                   ***  routine lbc_bdy_lnk_(2,3,4)d  *** 
    176    !! 
    177    !!   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used 
    178    !!   to maintain the same interface with regards to the mpp case 
    179    !!---------------------------------------------------------------------- 
    180     
    181    SUBROUTINE lbc_bdy_lnk_4d( cdname, pt4d, cd_type, psgn, ib_bdy ) 
    182       !!---------------------------------------------------------------------- 
    183       CHARACTER(len=*)          , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    184       REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) ::   pt4d      ! 3D array on which the lbc is applied 
    185       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    186       REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across north fold  
    187       INTEGER                   , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
    188       !!---------------------------------------------------------------------- 
    189       CALL lbc_lnk_4d( cdname, pt4d, cd_type, psgn) 
    190    END SUBROUTINE lbc_bdy_lnk_4d 
    191  
    192    SUBROUTINE lbc_bdy_lnk_3d( cdname, pt3d, cd_type, psgn, ib_bdy ) 
    193       !!---------------------------------------------------------------------- 
    194       CHARACTER(len=*)          , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    195       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the lbc is applied 
    196       CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    197       REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across north fold  
    198       INTEGER                   , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
    199       !!---------------------------------------------------------------------- 
    200       CALL lbc_lnk_3d( cdname, pt3d, cd_type, psgn) 
    201    END SUBROUTINE lbc_bdy_lnk_3d 
    202  
    203  
    204    SUBROUTINE lbc_bdy_lnk_2d( cdname, pt2d, cd_type, psgn, ib_bdy ) 
    205       !!---------------------------------------------------------------------- 
    206       CHARACTER(len=*)        , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    207       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 3D array on which the lbc is applied 
    208       CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    209       REAL(wp)                , INTENT(in   ) ::   psgn      ! sign used across north fold  
    210       INTEGER                 , INTENT(in   ) ::   ib_bdy    ! BDY boundary set 
    211       !!---------------------------------------------------------------------- 
    212       CALL lbc_lnk_2d( cdname, pt2d, cd_type, psgn) 
    213    END SUBROUTINE lbc_bdy_lnk_2d 
    214  
    215  
    216 !!gm  This routine should be removed with an optional halos size added in argument of generic routines 
    217  
    218    SUBROUTINE lbc_lnk_2d_icb( cdname, pt2d, cd_type, psgn, ki, kj ) 
    219       !!---------------------------------------------------------------------- 
    220       CHARACTER(len=*)        , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    221       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 2D array on which the lbc is applied 
    222       CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    223       REAL(wp)                , INTENT(in   ) ::   psgn      ! sign used across north fold  
    224       INTEGER                 , INTENT(in   ) ::   ki, kj    ! sizes of extra halo (not needed in non-mpp) 
    225       !!---------------------------------------------------------------------- 
    226       CALL lbc_lnk_2d( cdname, pt2d, cd_type, psgn ) 
    227    END SUBROUTINE lbc_lnk_2d_icb 
    228 !!gm end 
    229  
    230 #endif 
    231  
    232    !!====================================================================== 
    233    !!   identical routines in both distributed and shared memory computing 
    234    !!====================================================================== 
    23570 
    23671   !!---------------------------------------------------------------------- 
    … …  
    25691 
    25792#  define DIM_2d 
     93#     define ROUTINE_LOAD           load_ptr_2d 
    25894#     define ROUTINE_MULTI          lbc_lnk_2d_multi 
    259 #     define ROUTINE_LOAD           load_ptr_2d 
    26095#     include "lbc_lnk_multi_generic.h90" 
    26196#     undef ROUTINE_MULTI 
    … …  
    26398#  undef DIM_2d 
    26499 
    265  
    266100#  define DIM_3d 
     101#     define ROUTINE_LOAD           load_ptr_3d 
    267102#     define ROUTINE_MULTI          lbc_lnk_3d_multi 
    268 #     define ROUTINE_LOAD           load_ptr_3d 
    269103#     include "lbc_lnk_multi_generic.h90" 
    270104#     undef ROUTINE_MULTI 
    … …  
    272106#  undef DIM_3d 
    273107 
    274  
    275108#  define DIM_4d 
     109#     define ROUTINE_LOAD           load_ptr_4d 
    276110#     define ROUTINE_MULTI          lbc_lnk_4d_multi 
    277 #     define ROUTINE_LOAD           load_ptr_4d 
    278111#     include "lbc_lnk_multi_generic.h90" 
    279112#     undef ROUTINE_MULTI 
    … …  
    281114#  undef DIM_4d 
    282115 
     116   !!---------------------------------------------------------------------- 
     117   !!                   ***  routine mpp_lnk_(2,3,4)d  *** 
     118   !! 
     119   !!   * Argument : dummy argument use in mpp_lnk_... routines 
     120   !!                ptab      :   array or pointer of arrays on which the boundary condition is applied 
     121   !!                cd_nat    :   nature of array grid-points 
     122   !!                psgn      :   sign used across the north fold boundary 
     123   !!                kfld      :   optional, number of pt3d arrays 
     124   !!                kfillmode :   optional, method to be use to fill the halos (see jpfill* variables) 
     125   !!                pfillval  :   optional, background value (used with jpfillcopy) 
     126   !!---------------------------------------------------------------------- 
     127   ! 
     128   !                       !==  2D array and array of 2D pointer  ==! 
     129   ! 
     130#  define DIM_2d 
     131#     define ROUTINE_LNK           mpp_lnk_2d 
     132#     include "mpp_lnk_generic.h90" 
     133#     undef ROUTINE_LNK 
     134#     define MULTI 
     135#     define ROUTINE_LNK           mpp_lnk_2d_ptr 
     136#     include "mpp_lnk_generic.h90" 
     137#     undef ROUTINE_LNK 
     138#     undef MULTI 
     139#  undef DIM_2d 
     140   ! 
     141   !                       !==  3D array and array of 3D pointer  ==! 
     142   ! 
     143#  define DIM_3d 
     144#     define ROUTINE_LNK           mpp_lnk_3d 
     145#     include "mpp_lnk_generic.h90" 
     146#     undef ROUTINE_LNK 
     147#     define MULTI 
     148#     define ROUTINE_LNK           mpp_lnk_3d_ptr 
     149#     include "mpp_lnk_generic.h90" 
     150#     undef ROUTINE_LNK 
     151#     undef MULTI 
     152#  undef DIM_3d 
     153   ! 
     154   !                       !==  4D array and array of 4D pointer  ==! 
     155   ! 
     156#  define DIM_4d 
     157#     define ROUTINE_LNK           mpp_lnk_4d 
     158#     include "mpp_lnk_generic.h90" 
     159#     undef ROUTINE_LNK 
     160#     define MULTI 
     161#     define ROUTINE_LNK           mpp_lnk_4d_ptr 
     162#     include "mpp_lnk_generic.h90" 
     163#     undef ROUTINE_LNK 
     164#     undef MULTI 
     165#  undef DIM_4d 
     166 
     167   !!---------------------------------------------------------------------- 
     168   !!                   ***  routine mpp_nfd_(2,3,4)d  *** 
     169   !! 
     170   !!   * Argument : dummy argument use in mpp_nfd_... routines 
     171   !!                ptab      :   array or pointer of arrays on which the boundary condition is applied 
     172   !!                cd_nat    :   nature of array grid-points 
     173   !!                psgn      :   sign used across the north fold boundary 
     174   !!                kfld      :   optional, number of pt3d arrays 
     175   !!                kfillmode :   optional, method to be use to fill the halos (see jpfill* variables) 
     176   !!                pfillval  :   optional, background value (used with jpfillcopy) 
     177   !!---------------------------------------------------------------------- 
     178   ! 
     179   !                       !==  2D array and array of 2D pointer  ==! 
     180   ! 
     181#  define DIM_2d 
     182#     define ROUTINE_NFD           mpp_nfd_2d 
     183#     include "mpp_nfd_generic.h90" 
     184#     undef ROUTINE_NFD 
     185#     define MULTI 
     186#     define ROUTINE_NFD           mpp_nfd_2d_ptr 
     187#     include "mpp_nfd_generic.h90" 
     188#     undef ROUTINE_NFD 
     189#     undef MULTI 
     190#  undef DIM_2d 
     191   ! 
     192   !                       !==  3D array and array of 3D pointer  ==! 
     193   ! 
     194#  define DIM_3d 
     195#     define ROUTINE_NFD           mpp_nfd_3d 
     196#     include "mpp_nfd_generic.h90" 
     197#     undef ROUTINE_NFD 
     198#     define MULTI 
     199#     define ROUTINE_NFD           mpp_nfd_3d_ptr 
     200#     include "mpp_nfd_generic.h90" 
     201#     undef ROUTINE_NFD 
     202#     undef MULTI 
     203#  undef DIM_3d 
     204   ! 
     205   !                       !==  4D array and array of 4D pointer  ==! 
     206   ! 
     207#  define DIM_4d 
     208#     define ROUTINE_NFD           mpp_nfd_4d 
     209#     include "mpp_nfd_generic.h90" 
     210#     undef ROUTINE_NFD 
     211#     define MULTI 
     212#     define ROUTINE_NFD           mpp_nfd_4d_ptr 
     213#     include "mpp_nfd_generic.h90" 
     214#     undef ROUTINE_NFD 
     215#     undef MULTI 
     216#  undef DIM_4d 
     217 
     218 
    283219   !!====================================================================== 
     220 
     221 
     222 
     223   SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj) 
     224      !!--------------------------------------------------------------------- 
     225      !!                   ***  routine mpp_lbc_north_icb  *** 
     226      !! 
     227      !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
     228      !!              in mpp configuration in case of jpn1 > 1 and for 2d 
     229      !!              array with outer extra halo 
     230      !! 
     231      !! ** Method  :   North fold condition and mpp with more than one proc 
     232      !!              in i-direction require a specific treatment. We gather 
     233      !!              the 4+kextj northern lines of the global domain on 1 
     234      !!              processor and apply lbc north-fold on this sub array. 
     235      !!              Then we scatter the north fold array back to the processors. 
     236      !!              This routine accounts for an extra halo with icebergs 
     237      !!              and assumes ghost rows and columns have been suppressed. 
     238      !! 
     239      !!---------------------------------------------------------------------- 
     240      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
     241      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points 
     242      !                                                     !   = T ,  U , V , F or W -points 
     243      REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the 
     244      !!                                                    ! north fold, =  1. otherwise 
     245      INTEGER                 , INTENT(in   ) ::   kextj    ! Extra halo width at north fold 
     246      ! 
     247      INTEGER ::   ji, jj, jr 
     248      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
     249      INTEGER ::   ipj, ij, iproc 
     250      ! 
     251      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e 
     252      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e 
     253      !!---------------------------------------------------------------------- 
     254#if defined key_mpp_mpi 
     255      ! 
     256      ipj=4 
     257      ALLOCATE(        ztab_e(jpiglo, 1-kextj:ipj+kextj)       ,       & 
     258     &            znorthloc_e(jpimax, 1-kextj:ipj+kextj)       ,       & 
     259     &          znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni)    ) 
     260      ! 
     261      ztab_e(:,:)      = 0._wp 
     262      znorthloc_e(:,:) = 0._wp 
     263      ! 
     264      ij = 1 - kextj 
     265      ! put the last ipj+2*kextj lines of pt2d into znorthloc_e  
     266      DO jj = jpj - ipj + 1 - kextj , jpj + kextj 
     267         znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) 
     268         ij = ij + 1 
     269      END DO 
     270      ! 
     271      itaille = jpimax * ( ipj + 2*kextj ) 
     272      ! 
     273      IF( ln_timing ) CALL tic_tac(.TRUE.) 
     274      CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj)    , itaille, MPI_DOUBLE_PRECISION,    & 
     275         &                znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION,    & 
     276         &                ncomm_north, ierr ) 
     277      ! 
     278      IF( ln_timing ) CALL tic_tac(.FALSE.) 
     279      ! 
     280      DO jr = 1, ndim_rank_north            ! recover the global north array 
     281         iproc = nrank_north(jr) + 1 
     282         ildi = nldit (iproc) 
     283         ilei = nleit (iproc) 
     284         iilb = nimppt(iproc) 
     285         DO jj = 1-kextj, ipj+kextj 
     286            DO ji = ildi, ilei 
     287               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 
     288            END DO 
     289         END DO 
     290      END DO 
     291 
     292      ! 2. North-Fold boundary conditions 
     293      ! ---------------------------------- 
     294      CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) 
     295 
     296      ij = 1 - kextj 
     297      !! Scatter back to pt2d 
     298      DO jj = jpj - ipj + 1 - kextj , jpj + kextj 
     299         DO ji= 1, jpi 
     300            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 
     301         END DO 
     302         ij  = ij +1 
     303      END DO 
     304      ! 
     305      DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 
     306      ! 
     307#endif 
     308   END SUBROUTINE mpp_lbc_north_icb 
     309 
     310 
     311   SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj ) 
     312      !!---------------------------------------------------------------------- 
     313      !!                  ***  routine mpp_lnk_2d_icb  *** 
     314      !! 
     315      !! ** Purpose :   Message passing management for 2d array (with extra halo for icebergs) 
     316      !!                This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj) 
     317      !!                array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. 
     318      !! 
     319      !! ** Method  :   Use mppsend and mpprecv function for passing mask 
     320      !!      between processors following neighboring subdomains. 
     321      !!            domain parameters 
     322      !!                    jpi    : first dimension of the local subdomain 
     323      !!                    jpj    : second dimension of the local subdomain 
     324      !!                    kexti  : number of columns for extra outer halo 
     325      !!                    kextj  : number of rows for extra outer halo 
     326      !!                    nbondi : mark for "east-west local boundary" 
     327      !!                    nbondj : mark for "north-south local boundary" 
     328      !!                    noea   : number for local neighboring processors 
     329      !!                    nowe   : number for local neighboring processors 
     330      !!                    noso   : number for local neighboring processors 
     331      !!                    nono   : number for local neighboring processors 
     332      !!---------------------------------------------------------------------- 
     333      CHARACTER(len=*)                                        , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
     334      REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
     335      CHARACTER(len=1)                                        , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
     336      REAL(wp)                                                , INTENT(in   ) ::   psgn     ! sign used across the north fold 
     337      INTEGER                                                 , INTENT(in   ) ::   kexti    ! extra i-halo width 
     338      INTEGER                                                 , INTENT(in   ) ::   kextj    ! extra j-halo width 
     339      ! 
     340      INTEGER  ::   jl   ! dummy loop indices 
     341      INTEGER  ::   imigr, iihom, ijhom        ! local integers 
     342      INTEGER  ::   ipreci, iprecj             !   -       - 
     343      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
     344      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
     345      !! 
     346      REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) ::   r2dns, r2dsn 
     347      REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) ::   r2dwe, r2dew 
     348      !!---------------------------------------------------------------------- 
     349 
     350      ipreci = nn_hls + kexti      ! take into account outer extra 2D overlap area 
     351      iprecj = nn_hls + kextj 
     352 
     353      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) 
     354 
     355      ! 1. standard boundary treatment 
     356      ! ------------------------------ 
     357      ! Order matters Here !!!! 
     358      ! 
     359      !                                      ! East-West boundaries 
     360      !                                           !* Cyclic east-west 
     361      IF( l_Iperio ) THEN 
     362         pt2d(1-kexti:     1   ,:) = pt2d(jpim1-kexti: jpim1 ,:)       ! east 
     363         pt2d(  jpi  :jpi+kexti,:) = pt2d(     2     :2+kexti,:)       ! west 
     364         ! 
     365      ELSE                                        !* closed 
     366         IF( .NOT. cd_type == 'F' )   pt2d(  1-kexti   :nn_hls   ,:) = 0._wp    ! east except at F-point 
     367                                      pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp    ! west 
     368      ENDIF 
     369      !                                      ! North-South boundaries 
     370      IF( l_Jperio ) THEN                         !* cyclic (only with no mpp j-split) 
     371         pt2d(:,1-kextj:     1   ) = pt2d(:,jpjm1-kextj:  jpjm1)       ! north 
     372         pt2d(:,  jpj  :jpj+kextj) = pt2d(:,     2     :2+kextj)       ! south 
     373      ELSE                                        !* closed 
     374         IF( .NOT. cd_type == 'F' )   pt2d(:,  1-kextj   :nn_hls   ) = 0._wp    ! north except at F-point 
     375                                      pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp    ! south 
     376      ENDIF 
     377      ! 
     378 
     379      ! north fold treatment 
     380      ! ----------------------- 
     381      IF( npolj /= 0 ) THEN 
     382         ! 
     383         SELECT CASE ( jpni ) 
     384                   CASE ( 1 )     ;   CALL lbc_nfd          ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
     385                   CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
     386         END SELECT 
     387         ! 
     388      ENDIF 
     389 
     390      ! 2. East and west directions exchange 
     391      ! ------------------------------------ 
     392      ! we play with the neigbours AND the row number because of the periodicity 
     393      ! 
     394      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
     395      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     396         iihom = jpi-nreci-kexti 
     397         DO jl = 1, ipreci 
     398            r2dew(:,jl,1) = pt2d(nn_hls+jl,:) 
     399            r2dwe(:,jl,1) = pt2d(iihom +jl,:) 
     400         END DO 
     401      END SELECT 
     402      ! 
     403      !                           ! Migrations 
     404      imigr = ipreci * ( jpj + 2*kextj ) 
     405      ! 
     406      IF( ln_timing ) CALL tic_tac(.TRUE.) 
     407      ! 
     408      SELECT CASE ( nbondi ) 
     409      CASE ( -1 ) 
     410         CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 
     411         CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
     412         CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     413      CASE ( 0 ) 
     414         CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
     415         CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 
     416         CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
     417         CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
     418         CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     419         CALL mpi_wait(ml_req2,ml_stat,ml_err) 
     420      CASE ( 1 ) 
     421         CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
     422         CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
     423         CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     424      END SELECT 
     425      ! 
     426      IF( ln_timing ) CALL tic_tac(.FALSE.) 
     427      ! 
     428      !                           ! Write Dirichlet lateral conditions 
     429      iihom = jpi - nn_hls 
     430      ! 
     431      SELECT CASE ( nbondi ) 
     432      CASE ( -1 ) 
     433         DO jl = 1, ipreci 
     434            pt2d(iihom+jl,:) = r2dew(:,jl,2) 
     435         END DO 
     436      CASE ( 0 ) 
     437         DO jl = 1, ipreci 
     438            pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
     439            pt2d(iihom+jl,:) = r2dew(:,jl,2) 
     440         END DO 
     441      CASE ( 1 ) 
     442         DO jl = 1, ipreci 
     443            pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
     444         END DO 
     445      END SELECT 
     446 
     447 
     448      ! 3. North and south directions 
     449      ! ----------------------------- 
     450      ! always closed : we play only with the neigbours 
     451      ! 
     452      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
     453         ijhom = jpj-nrecj-kextj 
     454         DO jl = 1, iprecj 
     455            r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 
     456            r2dns(:,jl,1) = pt2d(:,nn_hls+jl) 
     457         END DO 
     458      ENDIF 
     459      ! 
     460      !                           ! Migrations 
     461      imigr = iprecj * ( jpi + 2*kexti ) 
     462      ! 
     463      IF( ln_timing ) CALL tic_tac(.TRUE.) 
     464      ! 
     465      SELECT CASE ( nbondj ) 
     466      CASE ( -1 ) 
     467         CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 
     468         CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
     469         CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     470      CASE ( 0 ) 
     471         CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
     472         CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 
     473         CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
     474         CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
     475         CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     476         CALL mpi_wait(ml_req2,ml_stat,ml_err) 
     477      CASE ( 1 ) 
     478         CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
     479         CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
     480         CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     481      END SELECT 
     482      ! 
     483      IF( ln_timing ) CALL tic_tac(.FALSE.) 
     484      ! 
     485      !                           ! Write Dirichlet lateral conditions 
     486      ijhom = jpj - nn_hls 
     487      ! 
     488      SELECT CASE ( nbondj ) 
     489      CASE ( -1 ) 
     490         DO jl = 1, iprecj 
     491            pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
     492         END DO 
     493      CASE ( 0 ) 
     494         DO jl = 1, iprecj 
     495            pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
     496            pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
     497         END DO 
     498      CASE ( 1 ) 
     499         DO jl = 1, iprecj 
     500            pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
     501         END DO 
     502      END SELECT 
     503      ! 
     504   END SUBROUTINE mpp_lnk_2d_icb 
     505    
    284506END MODULE lbclnk 
    285507 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/LBC/lbcnfd.F90

    r10425 r11822  
    2020   USE dom_oce        ! ocean space and time domain  
    2121   USE in_out_manager ! I/O manager 
     22   USE lib_mpp        ! MPP library 
    2223 
    2324   IMPLICIT NONE 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/LBC/lib_mpp.F90

    r11504 r11822  
    3232   !!   ctl_opn       : Open file and check if required file is available. 
    3333   !!   ctl_nam       : Prints informations when an error occurs while reading a namelist 
    34    !!   get_unit      : give the index of an unused logical unit 
    35    !!---------------------------------------------------------------------- 
    36 #if   defined key_mpp_mpi 
    37    !!---------------------------------------------------------------------- 
    38    !!   'key_mpp_mpi'             MPI massively parallel processing library 
    39    !!---------------------------------------------------------------------- 
    40    !!   lib_mpp_alloc : allocate mpp arrays 
    41    !!   mynode        : indentify the processor unit 
     34   !!---------------------------------------------------------------------- 
     35   !!---------------------------------------------------------------------- 
     36   !!   mpp_start     : get local communicator its size and rank 
    4237   !!   mpp_lnk       : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) 
    4338   !!   mpp_lnk_icb   : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) 
    … …  
    5752   !!---------------------------------------------------------------------- 
    5853   USE dom_oce        ! ocean space and time domain 
    59    USE lbcnfd         ! north fold treatment 
    6054   USE in_out_manager ! I/O manager 
    6155 
    6256   IMPLICIT NONE 
    6357   PRIVATE 
    64  
    65    INTERFACE mpp_nfd 
    66       MODULE PROCEDURE   mpp_nfd_2d    , mpp_nfd_3d    , mpp_nfd_4d 
    67       MODULE PROCEDURE   mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 
    68    END INTERFACE 
    69  
    70    ! Interface associated to the mpp_lnk_... routines is defined in lbclnk 
    71    PUBLIC   mpp_lnk_2d    , mpp_lnk_3d    , mpp_lnk_4d 
    72    PUBLIC   mpp_lnk_2d_ptr, mpp_lnk_3d_ptr, mpp_lnk_4d_ptr 
    7358   ! 
    74 !!gm  this should be useless 
    75    PUBLIC   mpp_nfd_2d    , mpp_nfd_3d    , mpp_nfd_4d 
    76    PUBLIC   mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr 
    77 !!gm end 
    78    ! 
    79    PUBLIC   ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam 
    80    PUBLIC   mynode, mppstop, mppsync, mpp_comm_free 
     59   PUBLIC   ctl_stop, ctl_warn, ctl_opn, ctl_nam 
     60   PUBLIC   mpp_start, mppstop, mppsync, mpp_comm_free 
    8161   PUBLIC   mpp_ini_north 
    82    PUBLIC   mpp_lnk_2d_icb 
    83    PUBLIC   mpp_lbc_north_icb 
    8462   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
    8563   PUBLIC   mpp_delay_max, mpp_delay_sum, mpp_delay_rcv 
    … …  
    8765   PUBLIC   mpp_ini_znl 
    8866   PUBLIC   mppsend, mpprecv                          ! needed by TAM and ICB routines 
    89    PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d, mpp_lnk_bdy_4d 
     67   PUBLIC   mpp_report 
     68   PUBLIC   tic_tac 
     69#if ! defined key_mpp_mpi 
     70   PUBLIC MPI_Wtime 
     71#endif 
    9072    
    9173   !! * Interfaces 
    … …  
    11395   !!  MPI  variable definition !! 
    11496   !! ========================= !! 
     97#if   defined key_mpp_mpi 
    11598!$AGRIF_DO_NOT_TREAT 
    11699   INCLUDE 'mpif.h' 
    117100!$AGRIF_END_DO_NOT_TREAT 
    118  
    119101   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .TRUE.    !: mpp flag 
     102#else    
     103   INTEGER, PUBLIC, PARAMETER ::   MPI_STATUS_SIZE = 1 
     104   INTEGER, PUBLIC, PARAMETER ::   MPI_DOUBLE_PRECISION = 8 
     105   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.    !: mpp flag 
     106#endif 
    120107 
    121108   INTEGER, PARAMETER         ::   nprocmax = 2**10   ! maximun dimension (required to be a power of 2) 
    … …  
    146133   INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_north   !: dimension ndim_rank_north 
    147134 
    148    ! Type of send : standard, buffered, immediate 
    149    CHARACTER(len=1), PUBLIC ::   cn_mpi_send        !: type od mpi send/recieve (S=standard, B=bsend, I=isend) 
    150    LOGICAL         , PUBLIC ::   l_isend = .FALSE.  !: isend use indicator (T if cn_mpi_send='I') 
    151    INTEGER         , PUBLIC ::   nn_buffer          !: size of the buffer in case of mpi_bsend 
    152  
    153135   ! Communications summary report 
    154136   CHARACTER(len=128), DIMENSION(:), ALLOCATABLE ::   crname_lbc                   !: names of lbc_lnk calling routines 
    … …  
    159141   INTEGER, PUBLIC                               ::   ncom_freq                    !: frequency of comm diagnostic 
    160142   INTEGER, PUBLIC , DIMENSION(:,:), ALLOCATABLE ::   ncomm_sequence               !: size of communicated arrays (halos) 
    161    INTEGER, PARAMETER, PUBLIC                    ::   ncom_rec_max = 3000          !: max number of communication record 
     143   INTEGER, PARAMETER, PUBLIC                    ::   ncom_rec_max = 5000          !: max number of communication record 
    162144   INTEGER, PUBLIC                               ::   n_sequence_lbc = 0           !: # of communicated arraysvia lbc 
    163145   INTEGER, PUBLIC                               ::   n_sequence_glb = 0           !: # of global communications 
    … …  
    175157      COMPLEX(wp), POINTER, DIMENSION(:) ::  y1d => NULL() 
    176158   END TYPE DELAYARR 
    177    TYPE( DELAYARR ), DIMENSION(nbdelay), PUBLIC  ::   todelay               
    178    INTEGER,          DIMENSION(nbdelay), PUBLIC  ::   ndelayid = -1     !: mpi request id of the delayed operations 
     159   TYPE( DELAYARR ), DIMENSION(nbdelay), PUBLIC, SAVE  ::   todelay         !: must have SAVE for default initialization of DELAYARR 
     160   INTEGER,          DIMENSION(nbdelay), PUBLIC        ::   ndelayid = -1   !: mpi request id of the delayed operations 
    179161 
    180162   ! timing summary report 
    … …  
    186168   LOGICAL, PUBLIC ::   ln_nnogather                !: namelist control of northfold comms 
    187169   LOGICAL, PUBLIC ::   l_north_nogather = .FALSE.  !: internal control of northfold comms 
    188  
     170    
    189171   !!---------------------------------------------------------------------- 
    190172   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    194176CONTAINS 
    195177 
    196    FUNCTION mynode( ldtxt, ldname, kumnam_ref, kumnam_cfg, kumond, kstop, localComm ) 
    197       !!---------------------------------------------------------------------- 
    198       !!                  ***  routine mynode  *** 
    199       !! 
    200       !! ** Purpose :   Find processor unit 
    201       !!---------------------------------------------------------------------- 
    202       CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt        ! 
    203       CHARACTER(len=*)             , INTENT(in   ) ::   ldname       ! 
    204       INTEGER                      , INTENT(in   ) ::   kumnam_ref   ! logical unit for reference namelist 
    205       INTEGER                      , INTENT(in   ) ::   kumnam_cfg   ! logical unit for configuration namelist 
    206       INTEGER                      , INTENT(inout) ::   kumond       ! logical unit for namelist output 
    207       INTEGER                      , INTENT(inout) ::   kstop        ! stop indicator 
     178   SUBROUTINE mpp_start( localComm ) 
     179      !!---------------------------------------------------------------------- 
     180      !!                  ***  routine mpp_start  *** 
     181      !! 
     182      !! ** Purpose :   get mpi_comm_oce, mpprank and mppsize 
     183      !!---------------------------------------------------------------------- 
    208184      INTEGER         , OPTIONAL   , INTENT(in   ) ::   localComm    ! 
    209185      ! 
    210       INTEGER ::   mynode, ierr, code, ji, ii, ios 
    211       LOGICAL ::   mpi_was_called 
    212       ! 
    213       NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, ln_nnogather 
    214       !!---------------------------------------------------------------------- 
    215       ! 
    216       ii = 1 
    217       WRITE(ldtxt(ii),*)                                                                  ;   ii = ii + 1 
    218       WRITE(ldtxt(ii),*) 'mynode : mpi initialisation'                                    ;   ii = ii + 1 
    219       WRITE(ldtxt(ii),*) '~~~~~~ '                                                        ;   ii = ii + 1 
    220       ! 
    221       REWIND( kumnam_ref )              ! Namelist nammpp in reference namelist: mpi variables 
    222       READ  ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901) 
    223 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp ) 
    224       ! 
    225       REWIND( kumnam_cfg )              ! Namelist nammpp in configuration namelist: mpi variables 
    226       READ  ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 
    227 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp ) 
    228       ! 
    229       !                              ! control print 
    230       WRITE(ldtxt(ii),*) '   Namelist nammpp'                                             ;   ii = ii + 1 
    231       WRITE(ldtxt(ii),*) '      mpi send type          cn_mpi_send = ', cn_mpi_send       ;   ii = ii + 1 
    232       WRITE(ldtxt(ii),*) '      size exported buffer   nn_buffer   = ', nn_buffer,' bytes';   ii = ii + 1 
    233       ! 
    234       IF( jpni < 1 .OR. jpnj < 1  ) THEN 
    235          WRITE(ldtxt(ii),*) '      jpni and jpnj will be calculated automatically' ;   ii = ii + 1 
    236       ELSE 
    237          WRITE(ldtxt(ii),*) '      processor grid extent in i         jpni = ',jpni       ;   ii = ii + 1 
    238          WRITE(ldtxt(ii),*) '      processor grid extent in j         jpnj = ',jpnj       ;   ii = ii + 1 
    239       ENDIF 
    240  
    241       WRITE(ldtxt(ii),*) '      avoid use of mpi_allgather at the north fold  ln_nnogather = ', ln_nnogather  ; ii = ii + 1 
    242  
    243       CALL mpi_initialized ( mpi_was_called, code ) 
    244       IF( code /= MPI_SUCCESS ) THEN 
    245          DO ji = 1, SIZE(ldtxt) 
    246             IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    247          END DO 
    248          WRITE(*, cform_err) 
    249          WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized' 
    250          CALL mpi_abort( mpi_comm_world, code, ierr ) 
    251       ENDIF 
    252  
    253       IF( mpi_was_called ) THEN 
    254          ! 
    255          SELECT CASE ( cn_mpi_send ) 
    256          CASE ( 'S' )                ! Standard mpi send (blocking) 
    257             WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'             ;   ii = ii + 1 
    258          CASE ( 'B' )                ! Buffer mpi send (blocking) 
    259             WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'              ;   ii = ii + 1 
    260             IF( Agrif_Root() )   CALL mpi_init_oce( ldtxt, ii, ierr ) 
    261          CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
    262             WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'           ;   ii = ii + 1 
    263             l_isend = .TRUE. 
    264          CASE DEFAULT 
    265             WRITE(ldtxt(ii),cform_err)                                                    ;   ii = ii + 1 
    266             WRITE(ldtxt(ii),*) '           bad value for cn_mpi_send = ', cn_mpi_send     ;   ii = ii + 1 
    267             kstop = kstop + 1 
    268          END SELECT 
    269          ! 
    270       ELSEIF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN 
    271          WRITE(ldtxt(ii),cform_err)                                                    ;   ii = ii + 1 
    272          WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator '          ;   ii = ii + 1 
    273          WRITE(ldtxt(ii),*) '          without calling MPI_Init before ! '                ;   ii = ii + 1 
    274          kstop = kstop + 1 
    275       ELSE 
    276          SELECT CASE ( cn_mpi_send ) 
    277          CASE ( 'S' )                ! Standard mpi send (blocking) 
    278             WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'             ;   ii = ii + 1 
    279             CALL mpi_init( ierr ) 
    280          CASE ( 'B' )                ! Buffer mpi send (blocking) 
    281             WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'              ;   ii = ii + 1 
    282             IF( Agrif_Root() )   CALL mpi_init_oce( ldtxt, ii, ierr ) 
    283          CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
    284             WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'           ;   ii = ii + 1 
    285             l_isend = .TRUE. 
    286             CALL mpi_init( ierr ) 
    287          CASE DEFAULT 
    288             WRITE(ldtxt(ii),cform_err)                                                    ;   ii = ii + 1 
    289             WRITE(ldtxt(ii),*) '           bad value for cn_mpi_send = ', cn_mpi_send     ;   ii = ii + 1 
    290             kstop = kstop + 1 
    291          END SELECT 
    292          ! 
    293       ENDIF 
    294  
     186      INTEGER ::   ierr 
     187      LOGICAL ::   llmpi_init 
     188      !!---------------------------------------------------------------------- 
     189#if defined key_mpp_mpi 
     190      ! 
     191      CALL mpi_initialized ( llmpi_init, ierr ) 
     192      IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_initialized' ) 
     193 
     194      IF( .NOT. llmpi_init ) THEN 
     195         IF( PRESENT(localComm) ) THEN 
     196            WRITE(ctmp1,*) ' lib_mpp: You cannot provide a local communicator ' 
     197            WRITE(ctmp2,*) '          without calling MPI_Init before ! ' 
     198            CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) 
     199         ENDIF 
     200         CALL mpi_init( ierr ) 
     201         IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_init' ) 
     202      ENDIF 
     203        
    295204      IF( PRESENT(localComm) ) THEN 
    296205         IF( Agrif_Root() ) THEN 
    … …  
    298207         ENDIF 
    299208      ELSE 
    300          CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code) 
    301          IF( code /= MPI_SUCCESS ) THEN 
    302             DO ji = 1, SIZE(ldtxt) 
    303                IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    304             END DO 
    305             WRITE(*, cform_err) 
    306             WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' 
    307             CALL mpi_abort( mpi_comm_world, code, ierr ) 
    308          ENDIF 
    309       ENDIF 
    310  
    311 #if defined key_agrif 
     209         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, ierr) 
     210         IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_comm_dup' ) 
     211      ENDIF 
     212 
     213# if defined key_agrif 
    312214      IF( Agrif_Root() ) THEN 
    313215         CALL Agrif_MPI_Init(mpi_comm_oce) 
    … …  
    315217         CALL Agrif_MPI_set_grid_comm(mpi_comm_oce) 
    316218      ENDIF 
    317 #endif 
     219# endif 
    318220 
    319221      CALL mpi_comm_rank( mpi_comm_oce, mpprank, ierr ) 
    320222      CALL mpi_comm_size( mpi_comm_oce, mppsize, ierr ) 
    321       mynode = mpprank 
    322  
    323       IF( mynode == 0 ) THEN 
    324          CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 
    325          WRITE(kumond, nammpp)       
    326       ENDIF 
    327223      ! 
    328224      CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr) 
    329225      ! 
    330    END FUNCTION mynode 
    331  
    332    !!---------------------------------------------------------------------- 
    333    !!                   ***  routine mpp_lnk_(2,3,4)d  *** 
    334    !! 
    335    !!   * Argument : dummy argument use in mpp_lnk_... routines 
    336    !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
    337    !!                cd_nat :   nature of array grid-points 
    338    !!                psgn   :   sign used across the north fold boundary 
    339    !!                kfld   :   optional, number of pt3d arrays 
    340    !!                cd_mpp :   optional, fill the overlap area only 
    341    !!                pval   :   optional, background value (used at closed boundaries) 
    342    !!---------------------------------------------------------------------- 
    343    ! 
    344    !                       !==  2D array and array of 2D pointer  ==! 
    345    ! 
    346 #  define DIM_2d 
    347 #     define ROUTINE_LNK           mpp_lnk_2d 
    348 #     include "mpp_lnk_generic.h90" 
    349 #     undef ROUTINE_LNK 
    350 #     define MULTI 
    351 #     define ROUTINE_LNK           mpp_lnk_2d_ptr 
    352 #     include "mpp_lnk_generic.h90" 
    353 #     undef ROUTINE_LNK 
    354 #     undef MULTI 
    355 #  undef DIM_2d 
    356    ! 
    357    !                       !==  3D array and array of 3D pointer  ==! 
    358    ! 
    359 #  define DIM_3d 
    360 #     define ROUTINE_LNK           mpp_lnk_3d 
    361 #     include "mpp_lnk_generic.h90" 
    362 #     undef ROUTINE_LNK 
    363 #     define MULTI 
    364 #     define ROUTINE_LNK           mpp_lnk_3d_ptr 
    365 #     include "mpp_lnk_generic.h90" 
    366 #     undef ROUTINE_LNK 
    367 #     undef MULTI 
    368 #  undef DIM_3d 
    369    ! 
    370    !                       !==  4D array and array of 4D pointer  ==! 
    371    ! 
    372 #  define DIM_4d 
    373 #     define ROUTINE_LNK           mpp_lnk_4d 
    374 #     include "mpp_lnk_generic.h90" 
    375 #     undef ROUTINE_LNK 
    376 #     define MULTI 
    377 #     define ROUTINE_LNK           mpp_lnk_4d_ptr 
    378 #     include "mpp_lnk_generic.h90" 
    379 #     undef ROUTINE_LNK 
    380 #     undef MULTI 
    381 #  undef DIM_4d 
    382  
    383    !!---------------------------------------------------------------------- 
    384    !!                   ***  routine mpp_nfd_(2,3,4)d  *** 
    385    !! 
    386    !!   * Argument : dummy argument use in mpp_nfd_... routines 
    387    !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
    388    !!                cd_nat :   nature of array grid-points 
    389    !!                psgn   :   sign used across the north fold boundary 
    390    !!                kfld   :   optional, number of pt3d arrays 
    391    !!                cd_mpp :   optional, fill the overlap area only 
    392    !!                pval   :   optional, background value (used at closed boundaries) 
    393    !!---------------------------------------------------------------------- 
    394    ! 
    395    !                       !==  2D array and array of 2D pointer  ==! 
    396    ! 
    397 #  define DIM_2d 
    398 #     define ROUTINE_NFD           mpp_nfd_2d 
    399 #     include "mpp_nfd_generic.h90" 
    400 #     undef ROUTINE_NFD 
    401 #     define MULTI 
    402 #     define ROUTINE_NFD           mpp_nfd_2d_ptr 
    403 #     include "mpp_nfd_generic.h90" 
    404 #     undef ROUTINE_NFD 
    405 #     undef MULTI 
    406 #  undef DIM_2d 
    407    ! 
    408    !                       !==  3D array and array of 3D pointer  ==! 
    409    ! 
    410 #  define DIM_3d 
    411 #     define ROUTINE_NFD           mpp_nfd_3d 
    412 #     include "mpp_nfd_generic.h90" 
    413 #     undef ROUTINE_NFD 
    414 #     define MULTI 
    415 #     define ROUTINE_NFD           mpp_nfd_3d_ptr 
    416 #     include "mpp_nfd_generic.h90" 
    417 #     undef ROUTINE_NFD 
    418 #     undef MULTI 
    419 #  undef DIM_3d 
    420    ! 
    421    !                       !==  4D array and array of 4D pointer  ==! 
    422    ! 
    423 #  define DIM_4d 
    424 #     define ROUTINE_NFD           mpp_nfd_4d 
    425 #     include "mpp_nfd_generic.h90" 
    426 #     undef ROUTINE_NFD 
    427 #     define MULTI 
    428 #     define ROUTINE_NFD           mpp_nfd_4d_ptr 
    429 #     include "mpp_nfd_generic.h90" 
    430 #     undef ROUTINE_NFD 
    431 #     undef MULTI 
    432 #  undef DIM_4d 
    433  
    434  
    435    !!---------------------------------------------------------------------- 
    436    !!                   ***  routine mpp_lnk_bdy_(2,3,4)d  *** 
    437    !! 
    438    !!   * Argument : dummy argument use in mpp_lnk_... routines 
    439    !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
    440    !!                cd_nat :   nature of array grid-points 
    441    !!                psgn   :   sign used across the north fold boundary 
    442    !!                kb_bdy :   BDY boundary set 
    443    !!                kfld   :   optional, number of pt3d arrays 
    444    !!---------------------------------------------------------------------- 
    445    ! 
    446    !                       !==  2D array and array of 2D pointer  ==! 
    447    ! 
    448 #  define DIM_2d 
    449 #     define ROUTINE_BDY           mpp_lnk_bdy_2d 
    450 #     include "mpp_bdy_generic.h90" 
    451 #     undef ROUTINE_BDY 
    452 #  undef DIM_2d 
    453    ! 
    454    !                       !==  3D array and array of 3D pointer  ==! 
    455    ! 
    456 #  define DIM_3d 
    457 #     define ROUTINE_BDY           mpp_lnk_bdy_3d 
    458 #     include "mpp_bdy_generic.h90" 
    459 #     undef ROUTINE_BDY 
    460 #  undef DIM_3d 
    461    ! 
    462    !                       !==  4D array and array of 4D pointer  ==! 
    463    ! 
    464 #  define DIM_4d 
    465 #     define ROUTINE_BDY           mpp_lnk_bdy_4d 
    466 #     include "mpp_bdy_generic.h90" 
    467 #     undef ROUTINE_BDY 
    468 #  undef DIM_4d 
    469  
    470    !!---------------------------------------------------------------------- 
    471    !! 
    472    !!   load_array  &   mpp_lnk_2d_9    à generaliser a 3D et 4D 
    473     
    474     
    475    !!    mpp_lnk_sum_2d et 3D   ====>>>>>>   à virer du code !!!! 
    476     
    477     
    478    !!---------------------------------------------------------------------- 
    479  
     226#else 
     227      IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 
     228      mppsize = 1 
     229      mpprank = 0 
     230#endif 
     231   END SUBROUTINE mpp_start 
    480232 
    481233 
    … …  
    496248      !!---------------------------------------------------------------------- 
    497249      ! 
    498       SELECT CASE ( cn_mpi_send ) 
    499       CASE ( 'S' )                ! Standard mpi send (blocking) 
    500          CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce        , iflag ) 
    501       CASE ( 'B' )                ! Buffer mpi send (blocking) 
    502          CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce        , iflag ) 
    503       CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
    504          ! be carefull, one more argument here : the mpi request identifier.. 
    505          CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 
    506       END SELECT 
     250#if defined key_mpp_mpi 
     251      CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 
     252#endif 
    507253      ! 
    508254   END SUBROUTINE mppsend 
    … …  
    526272      !!---------------------------------------------------------------------- 
    527273      ! 
     274#if defined key_mpp_mpi 
    528275      ! If a specific process number has been passed to the receive call, 
    529276      ! use that one. Default is to use mpi_any_source 
    … …  
    532279      ! 
    533280      CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 
     281#endif 
    534282      ! 
    535283   END SUBROUTINE mpprecv 
    … …  
    552300      ! 
    553301      itaille = jpi * jpj 
     302#if defined key_mpp_mpi 
    554303      CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille     ,   & 
    555304         &                            mpi_double_precision, kp , mpi_comm_oce, ierror ) 
     305#else 
     306      pio(:,:,1) = ptab(:,:) 
     307#endif 
    556308      ! 
    557309   END SUBROUTINE mppgather 
    … …  
    575327      itaille = jpi * jpj 
    576328      ! 
     329#if defined key_mpp_mpi 
    577330      CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille     ,   & 
    578331         &                            mpi_double_precision, kp  , mpi_comm_oce, ierror ) 
     332#else 
     333      ptab(:,:) = pio(:,:,1) 
     334#endif 
    579335      ! 
    580336   END SUBROUTINE mppscatter 
    … …  
    600356      COMPLEX(wp), ALLOCATABLE, DIMENSION(:) ::   ytmp 
    601357      !!---------------------------------------------------------------------- 
     358#if defined key_mpp_mpi 
    602359      ilocalcomm = mpi_comm_oce 
    603360      IF( PRESENT(kcom) )   ilocalcomm = kcom 
    … …  
    638395 
    639396      ! send y_in into todelay(idvar)%y1d with a non-blocking communication 
    640 #if defined key_mpi2 
     397# if defined key_mpi2 
    641398      IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 
    642399      CALL  mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 
    643400      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 
     401# else 
     402      CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 
     403# endif 
    644404#else 
    645       CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 
     405      pout(:) = REAL(y_in(:), wp) 
    646406#endif 
    647407 
    … …  
    667427      INTEGER ::   ierr, ilocalcomm 
    668428      !!---------------------------------------------------------------------- 
     429#if defined key_mpp_mpi 
    669430      ilocalcomm = mpi_comm_oce 
    670431      IF( PRESENT(kcom) )   ilocalcomm = kcom 
    … …  
    701462 
    702463      ! send p_in into todelay(idvar)%z1d with a non-blocking communication 
    703 #if defined key_mpi2 
     464# if defined key_mpi2 
    704465      IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 
    705466      CALL  mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
    706467      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 
     468# else 
     469      CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
     470# endif 
    707471#else 
    708       CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
     472      pout(:) = p_in(:) 
    709473#endif 
    710474 
    … …  
    722486      INTEGER ::   ierr 
    723487      !!---------------------------------------------------------------------- 
     488#if defined key_mpp_mpi 
    724489      IF( ndelayid(kid) /= -2 ) THEN   
    725490#if ! defined key_mpi2 
    … …  
    731496         ndelayid(kid) = -2   ! add flag to know that mpi_wait was already called on kid 
    732497      ENDIF 
     498#endif 
    733499   END SUBROUTINE mpp_delay_rcv 
    734500 
    … …  
    889655      !!----------------------------------------------------------------------- 
    890656      ! 
     657#if defined key_mpp_mpi 
    891658      CALL mpi_barrier( mpi_comm_oce, ierror ) 
     659#endif 
    892660      ! 
    893661   END SUBROUTINE mppsync 
    894662 
    895663 
    896    SUBROUTINE mppstop( ldfinal, ld_force_abort )  
     664   SUBROUTINE mppstop( ld_abort )  
    897665      !!---------------------------------------------------------------------- 
    898666      !!                  ***  routine mppstop  *** 
    … …  
    901669      !! 
    902670      !!---------------------------------------------------------------------- 
    903       LOGICAL, OPTIONAL, INTENT(in) :: ldfinal    ! source process number 
    904       LOGICAL, OPTIONAL, INTENT(in) :: ld_force_abort    ! source process number 
    905       LOGICAL ::   llfinal, ll_force_abort 
     671      LOGICAL, OPTIONAL, INTENT(in) :: ld_abort    ! source process number 
     672      LOGICAL ::   ll_abort 
    906673      INTEGER ::   info 
    907674      !!---------------------------------------------------------------------- 
    908       llfinal = .FALSE. 
    909       IF( PRESENT(ldfinal) ) llfinal = ldfinal 
    910       ll_force_abort = .FALSE. 
    911       IF( PRESENT(ld_force_abort) ) ll_force_abort = ld_force_abort 
    912       ! 
    913       IF(ll_force_abort) THEN 
     675      ll_abort = .FALSE. 
     676      IF( PRESENT(ld_abort) ) ll_abort = ld_abort 
     677      ! 
     678#if defined key_mpp_mpi 
     679      IF(ll_abort) THEN 
    914680         CALL mpi_abort( MPI_COMM_WORLD ) 
    915681      ELSE 
    … …  
    917683         CALL mpi_finalize( info ) 
    918684      ENDIF 
    919       IF( .NOT. llfinal ) STOP 123456 
     685#endif 
     686      IF( ll_abort ) STOP 123 
    920687      ! 
    921688   END SUBROUTINE mppstop 
    … …  
    929696      !!---------------------------------------------------------------------- 
    930697      ! 
     698#if defined key_mpp_mpi 
    931699      CALL MPI_COMM_FREE(kcom, ierr) 
     700#endif 
    932701      ! 
    933702   END SUBROUTINE mpp_comm_free 
    … …  
    959728      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kwork 
    960729      !!---------------------------------------------------------------------- 
     730#if defined key_mpp_mpi 
    961731      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world     : ', ngrp_world 
    962732      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world 
    … …  
    964734      ! 
    965735      ALLOCATE( kwork(jpnij), STAT=ierr ) 
    966       IF( ierr /= 0 ) THEN 
    967          WRITE(kumout, cform_err) 
    968          WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij' 
    969          CALL mppstop 
    970       ENDIF 
     736      IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_ini_znl : failed to allocate 1D array of length jpnij') 
    971737 
    972738      IF( jpnj == 1 ) THEN 
    … …  
    1030796 
    1031797      DEALLOCATE(kwork) 
     798#endif 
    1032799 
    1033800   END SUBROUTINE mpp_ini_znl 
    … …  
    1061828      !!---------------------------------------------------------------------- 
    1062829      ! 
     830#if defined key_mpp_mpi 
    1063831      njmppmax = MAXVAL( njmppt ) 
    1064832      ! 
    … …  
    1092860      CALL MPI_COMM_CREATE( mpi_comm_oce, ngrp_north, ncomm_north, ierr ) 
    1093861      ! 
     862#endif 
    1094863   END SUBROUTINE mpp_ini_north 
    1095  
    1096  
    1097    SUBROUTINE mpi_init_oce( ldtxt, ksft, code ) 
    1098       !!--------------------------------------------------------------------- 
    1099       !!                   ***  routine mpp_init.opa  *** 
    1100       !! 
    1101       !! ** Purpose :: export and attach a MPI buffer for bsend 
    1102       !! 
    1103       !! ** Method  :: define buffer size in namelist, if 0 no buffer attachment 
    1104       !!            but classical mpi_init 
    1105       !! 
    1106       !! History :: 01/11 :: IDRIS initial version for IBM only 
    1107       !!            08/04 :: R. Benshila, generalisation 
    1108       !!--------------------------------------------------------------------- 
    1109       CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt 
    1110       INTEGER                      , INTENT(inout) ::   ksft 
    1111       INTEGER                      , INTENT(  out) ::   code 
    1112       INTEGER                                      ::   ierr, ji 
    1113       LOGICAL                                      ::   mpi_was_called 
    1114       !!--------------------------------------------------------------------- 
    1115       ! 
    1116       CALL mpi_initialized( mpi_was_called, code )      ! MPI initialization 
    1117       IF ( code /= MPI_SUCCESS ) THEN 
    1118          DO ji = 1, SIZE(ldtxt) 
    1119             IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    1120          END DO 
    1121          WRITE(*, cform_err) 
    1122          WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized' 
    1123          CALL mpi_abort( mpi_comm_world, code, ierr ) 
    1124       ENDIF 
    1125       ! 
    1126       IF( .NOT. mpi_was_called ) THEN 
    1127          CALL mpi_init( code ) 
    1128          CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code ) 
    1129          IF ( code /= MPI_SUCCESS ) THEN 
    1130             DO ji = 1, SIZE(ldtxt) 
    1131                IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    1132             END DO 
    1133             WRITE(*, cform_err) 
    1134             WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' 
    1135             CALL mpi_abort( mpi_comm_world, code, ierr ) 
    1136          ENDIF 
    1137       ENDIF 
    1138       ! 
    1139       IF( nn_buffer > 0 ) THEN 
    1140          WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of  : ', nn_buffer   ;   ksft = ksft + 1 
    1141          ! Buffer allocation and attachment 
    1142          ALLOCATE( tampon(nn_buffer), stat = ierr ) 
    1143          IF( ierr /= 0 ) THEN 
    1144             DO ji = 1, SIZE(ldtxt) 
    1145                IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    1146             END DO 
    1147             WRITE(*, cform_err) 
    1148             WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr 
    1149             CALL mpi_abort( mpi_comm_world, code, ierr ) 
    1150          END IF 
    1151          CALL mpi_buffer_attach( tampon, nn_buffer, code ) 
    1152       ENDIF 
    1153       ! 
    1154    END SUBROUTINE mpi_init_oce 
    1155864 
    1156865 
    … …  
    1186895 
    1187896 
    1188    SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj) 
    1189       !!--------------------------------------------------------------------- 
    1190       !!                   ***  routine mpp_lbc_north_icb  *** 
    1191       !! 
    1192       !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
    1193       !!              in mpp configuration in case of jpn1 > 1 and for 2d 
    1194       !!              array with outer extra halo 
    1195       !! 
    1196       !! ** Method  :   North fold condition and mpp with more than one proc 
    1197       !!              in i-direction require a specific treatment. We gather 
    1198       !!              the 4+kextj northern lines of the global domain on 1 
    1199       !!              processor and apply lbc north-fold on this sub array. 
    1200       !!              Then we scatter the north fold array back to the processors. 
    1201       !!              This routine accounts for an extra halo with icebergs 
    1202       !!              and assumes ghost rows and columns have been suppressed. 
    1203       !! 
    1204       !!---------------------------------------------------------------------- 
    1205       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    1206       CHARACTER(len=1)        , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points 
    1207       !                                                     !   = T ,  U , V , F or W -points 
    1208       REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the 
    1209       !!                                                    ! north fold, =  1. otherwise 
    1210       INTEGER                 , INTENT(in   ) ::   kextj    ! Extra halo width at north fold 
    1211       ! 
    1212       INTEGER ::   ji, jj, jr 
    1213       INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    1214       INTEGER ::   ipj, ij, iproc 
    1215       ! 
    1216       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e 
    1217       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e 
    1218       !!---------------------------------------------------------------------- 
    1219       ! 
    1220       ipj=4 
    1221       ALLOCATE(        ztab_e(jpiglo, 1-kextj:ipj+kextj)       ,       & 
    1222      &            znorthloc_e(jpimax, 1-kextj:ipj+kextj)       ,       & 
    1223      &          znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni)    ) 
    1224       ! 
    1225       ztab_e(:,:)      = 0._wp 
    1226       znorthloc_e(:,:) = 0._wp 
    1227       ! 
    1228       ij = 1 - kextj 
    1229       ! put the last ipj+2*kextj lines of pt2d into znorthloc_e  
    1230       DO jj = jpj - ipj + 1 - kextj , jpj + kextj 
    1231          znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) 
    1232          ij = ij + 1 
    1233       END DO 
    1234       ! 
    1235       itaille = jpimax * ( ipj + 2*kextj ) 
    1236       ! 
    1237       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    1238       CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj)    , itaille, MPI_DOUBLE_PRECISION,    & 
    1239          &                znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION,    & 
    1240          &                ncomm_north, ierr ) 
    1241       ! 
    1242       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    1243       ! 
    1244       DO jr = 1, ndim_rank_north            ! recover the global north array 
    1245          iproc = nrank_north(jr) + 1 
    1246          ildi = nldit (iproc) 
    1247          ilei = nleit (iproc) 
    1248          iilb = nimppt(iproc) 
    1249          DO jj = 1-kextj, ipj+kextj 
    1250             DO ji = ildi, ilei 
    1251                ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 
    1252             END DO 
    1253          END DO 
    1254       END DO 
    1255  
    1256       ! 2. North-Fold boundary conditions 
    1257       ! ---------------------------------- 
    1258       CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) 
    1259  
    1260       ij = 1 - kextj 
    1261       !! Scatter back to pt2d 
    1262       DO jj = jpj - ipj + 1 - kextj , jpj + kextj 
    1263          DO ji= 1, jpi 
    1264             pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 
    1265          END DO 
    1266          ij  = ij +1 
    1267       END DO 
    1268       ! 
    1269       DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 
    1270       ! 
    1271    END SUBROUTINE mpp_lbc_north_icb 
    1272  
    1273  
    1274    SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj ) 
    1275       !!---------------------------------------------------------------------- 
    1276       !!                  ***  routine mpp_lnk_2d_icb  *** 
    1277       !! 
    1278       !! ** Purpose :   Message passing management for 2d array (with extra halo for icebergs) 
    1279       !!                This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj) 
    1280       !!                array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. 
    1281       !! 
    1282       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    1283       !!      between processors following neighboring subdomains. 
    1284       !!            domain parameters 
    1285       !!                    jpi    : first dimension of the local subdomain 
    1286       !!                    jpj    : second dimension of the local subdomain 
    1287       !!                    kexti  : number of columns for extra outer halo 
    1288       !!                    kextj  : number of rows for extra outer halo 
    1289       !!                    nbondi : mark for "east-west local boundary" 
    1290       !!                    nbondj : mark for "north-south local boundary" 
    1291       !!                    noea   : number for local neighboring processors 
    1292       !!                    nowe   : number for local neighboring processors 
    1293       !!                    noso   : number for local neighboring processors 
    1294       !!                    nono   : number for local neighboring processors 
    1295       !!---------------------------------------------------------------------- 
    1296       CHARACTER(len=*)                                        , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    1297       REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    1298       CHARACTER(len=1)                                        , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
    1299       REAL(wp)                                                , INTENT(in   ) ::   psgn     ! sign used across the north fold 
    1300       INTEGER                                                 , INTENT(in   ) ::   kexti    ! extra i-halo width 
    1301       INTEGER                                                 , INTENT(in   ) ::   kextj    ! extra j-halo width 
    1302       ! 
    1303       INTEGER  ::   jl   ! dummy loop indices 
    1304       INTEGER  ::   imigr, iihom, ijhom        ! local integers 
    1305       INTEGER  ::   ipreci, iprecj             !   -       - 
    1306       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    1307       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    1308       !! 
    1309       REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) ::   r2dns, r2dsn 
    1310       REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) ::   r2dwe, r2dew 
    1311       !!---------------------------------------------------------------------- 
    1312  
    1313       ipreci = nn_hls + kexti      ! take into account outer extra 2D overlap area 
    1314       iprecj = nn_hls + kextj 
    1315  
    1316       IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) 
    1317  
    1318       ! 1. standard boundary treatment 
    1319       ! ------------------------------ 
    1320       ! Order matters Here !!!! 
    1321       ! 
    1322       !                                      ! East-West boundaries 
    1323       !                                           !* Cyclic east-west 
    1324       IF( l_Iperio ) THEN 
    1325          pt2d(1-kexti:     1   ,:) = pt2d(jpim1-kexti: jpim1 ,:)       ! east 
    1326          pt2d(  jpi  :jpi+kexti,:) = pt2d(     2     :2+kexti,:)       ! west 
    1327          ! 
    1328       ELSE                                        !* closed 
    1329          IF( .NOT. cd_type == 'F' )   pt2d(  1-kexti   :nn_hls   ,:) = 0._wp    ! east except at F-point 
    1330                                       pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp    ! west 
    1331       ENDIF 
    1332       !                                      ! North-South boundaries 
    1333       IF( l_Jperio ) THEN                         !* cyclic (only with no mpp j-split) 
    1334          pt2d(:,1-kextj:     1   ) = pt2d(:,jpjm1-kextj:  jpjm1)       ! north 
    1335          pt2d(:,  jpj  :jpj+kextj) = pt2d(:,     2     :2+kextj)       ! south 
    1336       ELSE                                        !* closed 
    1337          IF( .NOT. cd_type == 'F' )   pt2d(:,  1-kextj   :nn_hls   ) = 0._wp    ! north except at F-point 
    1338                                       pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp    ! south 
    1339       ENDIF 
    1340       ! 
    1341  
    1342       ! north fold treatment 
    1343       ! ----------------------- 
    1344       IF( npolj /= 0 ) THEN 
    1345          ! 
    1346          SELECT CASE ( jpni ) 
    1347                    CASE ( 1 )     ;   CALL lbc_nfd          ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
    1348                    CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
    1349          END SELECT 
    1350          ! 
    1351       ENDIF 
    1352  
    1353       ! 2. East and west directions exchange 
    1354       ! ------------------------------------ 
    1355       ! we play with the neigbours AND the row number because of the periodicity 
    1356       ! 
    1357       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    1358       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    1359          iihom = jpi-nreci-kexti 
    1360          DO jl = 1, ipreci 
    1361             r2dew(:,jl,1) = pt2d(nn_hls+jl,:) 
    1362             r2dwe(:,jl,1) = pt2d(iihom +jl,:) 
    1363          END DO 
    1364       END SELECT 
    1365       ! 
    1366       !                           ! Migrations 
    1367       imigr = ipreci * ( jpj + 2*kextj ) 
    1368       ! 
    1369       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    1370       ! 
    1371       SELECT CASE ( nbondi ) 
    1372       CASE ( -1 ) 
    1373          CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 
    1374          CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
    1375          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1376       CASE ( 0 ) 
    1377          CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
    1378          CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 
    1379          CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
    1380          CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
    1381          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1382          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    1383       CASE ( 1 ) 
    1384          CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
    1385          CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
    1386          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1387       END SELECT 
    1388       ! 
    1389       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    1390       ! 
    1391       !                           ! Write Dirichlet lateral conditions 
    1392       iihom = jpi - nn_hls 
    1393       ! 
    1394       SELECT CASE ( nbondi ) 
    1395       CASE ( -1 ) 
    1396          DO jl = 1, ipreci 
    1397             pt2d(iihom+jl,:) = r2dew(:,jl,2) 
    1398          END DO 
    1399       CASE ( 0 ) 
    1400          DO jl = 1, ipreci 
    1401             pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
    1402             pt2d(iihom+jl,:) = r2dew(:,jl,2) 
    1403          END DO 
    1404       CASE ( 1 ) 
    1405          DO jl = 1, ipreci 
    1406             pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
    1407          END DO 
    1408       END SELECT 
    1409  
    1410  
    1411       ! 3. North and south directions 
    1412       ! ----------------------------- 
    1413       ! always closed : we play only with the neigbours 
    1414       ! 
    1415       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    1416          ijhom = jpj-nrecj-kextj 
    1417          DO jl = 1, iprecj 
    1418             r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 
    1419             r2dns(:,jl,1) = pt2d(:,nn_hls+jl) 
    1420          END DO 
    1421       ENDIF 
    1422       ! 
    1423       !                           ! Migrations 
    1424       imigr = iprecj * ( jpi + 2*kexti ) 
    1425       ! 
    1426       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    1427       ! 
    1428       SELECT CASE ( nbondj ) 
    1429       CASE ( -1 ) 
    1430          CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 
    1431          CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
    1432          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1433       CASE ( 0 ) 
    1434          CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
    1435          CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 
    1436          CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
    1437          CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
    1438          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1439          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    1440       CASE ( 1 ) 
    1441          CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
    1442          CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
    1443          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1444       END SELECT 
    1445       ! 
    1446       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    1447       ! 
    1448       !                           ! Write Dirichlet lateral conditions 
    1449       ijhom = jpj - nn_hls 
    1450       ! 
    1451       SELECT CASE ( nbondj ) 
    1452       CASE ( -1 ) 
    1453          DO jl = 1, iprecj 
    1454             pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
    1455          END DO 
    1456       CASE ( 0 ) 
    1457          DO jl = 1, iprecj 
    1458             pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
    1459             pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
    1460          END DO 
    1461       CASE ( 1 ) 
    1462          DO jl = 1, iprecj 
    1463             pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
    1464          END DO 
    1465       END SELECT 
    1466       ! 
    1467    END SUBROUTINE mpp_lnk_2d_icb 
    1468  
    1469  
    1470897   SUBROUTINE mpp_report( cdname, kpk, kpl, kpf, ld_lbc, ld_glb, ld_dlg ) 
    1471898      !!---------------------------------------------------------------------- 
    … …  
    1479906      LOGICAL         , OPTIONAL, INTENT(in   ) ::   ld_lbc, ld_glb, ld_dlg 
    1480907      !! 
     908      CHARACTER(len=128)                        ::   ccountname  ! name of a subroutine to count communications 
    1481909      LOGICAL ::   ll_lbc, ll_glb, ll_dlg 
    1482       INTEGER ::    ji,  jj,  jk,  jh, jf   ! dummy loop indices 
    1483       !!---------------------------------------------------------------------- 
     910      INTEGER ::    ji,  jj,  jk,  jh, jf, jcount   ! dummy loop indices 
     911      !!---------------------------------------------------------------------- 
     912#if defined key_mpp_mpi 
    1484913      ! 
    1485914      ll_lbc = .FALSE. 
    … …  
    1536965         WRITE(numcom,*) ' ' 
    1537966         WRITE(numcom,*) ' lbc_lnk called' 
    1538          jj = 1 
    1539          DO ji = 2, n_sequence_lbc 
    1540             IF( crname_lbc(ji-1) /= crname_lbc(ji) ) THEN 
    1541                WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_lbc(ji-1)) 
    1542                jj = 0 
     967         DO ji = 1, n_sequence_lbc - 1 
     968            IF ( crname_lbc(ji) /= 'already counted' ) THEN 
     969               ccountname = crname_lbc(ji) 
     970               crname_lbc(ji) = 'already counted' 
     971               jcount = 1 
     972               DO jj = ji + 1, n_sequence_lbc 
     973                  IF ( ccountname ==  crname_lbc(jj) ) THEN 
     974                     jcount = jcount + 1 
     975                     crname_lbc(jj) = 'already counted' 
     976                  END IF 
     977               END DO 
     978               WRITE(numcom,'(A, I4, A, A)') ' - ', jcount,' times by subroutine ', TRIM(ccountname) 
    1543979            END IF 
    1544             jj = jj + 1  
    1545980         END DO 
    1546          WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_lbc(n_sequence_lbc)) 
     981         IF ( crname_lbc(n_sequence_lbc) /= 'already counted' ) THEN 
     982            WRITE(numcom,'(A, I4, A, A)') ' - ', 1,' times by subroutine ', TRIM(crname_lbc(ncom_rec_max)) 
     983         END IF 
    1547984         WRITE(numcom,*) ' ' 
    1548985         IF ( n_sequence_glb > 0 ) THEN 
    … …  
    15831020         DEALLOCATE(crname_lbc) 
    15841021      ENDIF 
     1022#endif 
    15851023   END SUBROUTINE mpp_report 
    15861024 
    … …  
    15931031    REAL(wp),               SAVE :: tic_ct = 0._wp 
    15941032    INTEGER :: ii 
     1033#if defined key_mpp_mpi 
    15951034 
    15961035    IF( ncom_stp <= nit000 ) RETURN 
    … …  
    16081047       tic_ct = MPI_Wtime()                                                        ! start count tac->tic (waiting time) 
    16091048    ENDIF 
     1049#endif 
    16101050     
    16111051   END SUBROUTINE tic_tac 
    16121052 
     1053#if ! defined key_mpp_mpi 
     1054   SUBROUTINE mpi_wait(request, status, ierror) 
     1055      INTEGER                            , INTENT(in   ) ::   request 
     1056      INTEGER, DIMENSION(MPI_STATUS_SIZE), INTENT(  out) ::   status 
     1057      INTEGER                            , INTENT(  out) ::   ierror 
     1058   END SUBROUTINE mpi_wait 
     1059 
    16131060    
    1614 #else 
    1615    !!---------------------------------------------------------------------- 
    1616    !!   Default case:            Dummy module        share memory computing 
    1617    !!---------------------------------------------------------------------- 
    1618    USE in_out_manager 
    1619  
    1620    INTERFACE mpp_sum 
    1621       MODULE PROCEDURE mppsum_int, mppsum_a_int, mppsum_real, mppsum_a_real, mppsum_realdd, mppsum_a_realdd 
    1622    END INTERFACE 
    1623    INTERFACE mpp_max 
    1624       MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real 
    1625    END INTERFACE 
    1626    INTERFACE mpp_min 
    1627       MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real 
    1628    END INTERFACE 
    1629    INTERFACE mpp_minloc 
    1630       MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d 
    1631    END INTERFACE 
    1632    INTERFACE mpp_maxloc 
    1633       MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
    1634    END INTERFACE 
    1635  
    1636    LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag 
    1637    LOGICAL, PUBLIC            ::   ln_nnogather          !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used) 
    1638    INTEGER, PUBLIC            ::   mpi_comm_oce          ! opa local communicator 
    1639  
    1640    INTEGER, PARAMETER, PUBLIC               ::   nbdelay = 0   ! make sure we don't enter loops: DO ji = 1, nbdelay 
    1641    CHARACTER(len=32), DIMENSION(1), PUBLIC  ::   c_delaylist = 'empty' 
    1642    CHARACTER(len=32), DIMENSION(1), PUBLIC  ::   c_delaycpnt = 'empty' 
    1643    LOGICAL, PUBLIC                          ::   l_full_nf_update = .TRUE. 
    1644    TYPE ::   DELAYARR 
    1645       REAL(   wp), POINTER, DIMENSION(:) ::  z1d => NULL() 
    1646       COMPLEX(wp), POINTER, DIMENSION(:) ::  y1d => NULL() 
    1647    END TYPE DELAYARR 
    1648    TYPE( DELAYARR ), DIMENSION(1), PUBLIC  ::   todelay               
    1649    INTEGER,  PUBLIC, DIMENSION(1)           ::   ndelayid = -1 
    1650    !!---------------------------------------------------------------------- 
    1651 CONTAINS 
    1652  
    1653    INTEGER FUNCTION lib_mpp_alloc(kumout)          ! Dummy function 
    1654       INTEGER, INTENT(in) ::   kumout 
    1655       lib_mpp_alloc = 0 
    1656    END FUNCTION lib_mpp_alloc 
    1657  
    1658    FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg,  kumond , kstop, localComm ) RESULT (function_value) 
    1659       INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm 
    1660       CHARACTER(len=*),DIMENSION(:) ::   ldtxt 
    1661       CHARACTER(len=*) ::   ldname 
    1662       INTEGER ::   kumnam_ref, knumnam_cfg , kumond , kstop 
    1663       IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 
    1664       function_value = 0 
    1665       IF( .FALSE. )   ldtxt(:) = 'never done' 
    1666       CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 
    1667    END FUNCTION mynode 
    1668  
    1669    SUBROUTINE mppsync                       ! Dummy routine 
    1670    END SUBROUTINE mppsync 
    1671  
    1672    !!---------------------------------------------------------------------- 
    1673    !!    ***  mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real  *** 
    1674    !!    
    1675    !!---------------------------------------------------------------------- 
    1676    !! 
    1677 #  define OPERATION_MAX 
    1678 #  define INTEGER_TYPE 
    1679 #  define DIM_0d 
    1680 #     define ROUTINE_ALLREDUCE           mppmax_int 
    1681 #     include "mpp_allreduce_generic.h90" 
    1682 #     undef ROUTINE_ALLREDUCE 
    1683 #  undef DIM_0d 
    1684 #  define DIM_1d 
    1685 #     define ROUTINE_ALLREDUCE           mppmax_a_int 
    1686 #     include "mpp_allreduce_generic.h90" 
    1687 #     undef ROUTINE_ALLREDUCE 
    1688 #  undef DIM_1d 
    1689 #  undef INTEGER_TYPE 
    1690 ! 
    1691 #  define REAL_TYPE 
    1692 #  define DIM_0d 
    1693 #     define ROUTINE_ALLREDUCE           mppmax_real 
    1694 #     include "mpp_allreduce_generic.h90" 
    1695 #     undef ROUTINE_ALLREDUCE 
    1696 #  undef DIM_0d 
    1697 #  define DIM_1d 
    1698 #     define ROUTINE_ALLREDUCE           mppmax_a_real 
    1699 #     include "mpp_allreduce_generic.h90" 
    1700 #     undef ROUTINE_ALLREDUCE 
    1701 #  undef DIM_1d 
    1702 #  undef REAL_TYPE 
    1703 #  undef OPERATION_MAX 
    1704    !!---------------------------------------------------------------------- 
    1705    !!    ***  mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real  *** 
    1706    !!    
    1707    !!---------------------------------------------------------------------- 
    1708    !! 
    1709 #  define OPERATION_MIN 
    1710 #  define INTEGER_TYPE 
    1711 #  define DIM_0d 
    1712 #     define ROUTINE_ALLREDUCE           mppmin_int 
    1713 #     include "mpp_allreduce_generic.h90" 
    1714 #     undef ROUTINE_ALLREDUCE 
    1715 #  undef DIM_0d 
    1716 #  define DIM_1d 
    1717 #     define ROUTINE_ALLREDUCE           mppmin_a_int 
    1718 #     include "mpp_allreduce_generic.h90" 
    1719 #     undef ROUTINE_ALLREDUCE 
    1720 #  undef DIM_1d 
    1721 #  undef INTEGER_TYPE 
    1722 ! 
    1723 #  define REAL_TYPE 
    1724 #  define DIM_0d 
    1725 #     define ROUTINE_ALLREDUCE           mppmin_real 
    1726 #     include "mpp_allreduce_generic.h90" 
    1727 #     undef ROUTINE_ALLREDUCE 
    1728 #  undef DIM_0d 
    1729 #  define DIM_1d 
    1730 #     define ROUTINE_ALLREDUCE           mppmin_a_real 
    1731 #     include "mpp_allreduce_generic.h90" 
    1732 #     undef ROUTINE_ALLREDUCE 
    1733 #  undef DIM_1d 
    1734 #  undef REAL_TYPE 
    1735 #  undef OPERATION_MIN 
    1736  
    1737    !!---------------------------------------------------------------------- 
    1738    !!    ***  mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real  *** 
    1739    !!    
    1740    !!   Global sum of 1D array or a variable (integer, real or complex) 
    1741    !!---------------------------------------------------------------------- 
    1742    !! 
    1743 #  define OPERATION_SUM 
    1744 #  define INTEGER_TYPE 
    1745 #  define DIM_0d 
    1746 #     define ROUTINE_ALLREDUCE           mppsum_int 
    1747 #     include "mpp_allreduce_generic.h90" 
    1748 #     undef ROUTINE_ALLREDUCE 
    1749 #  undef DIM_0d 
    1750 #  define DIM_1d 
    1751 #     define ROUTINE_ALLREDUCE           mppsum_a_int 
    1752 #     include "mpp_allreduce_generic.h90" 
    1753 #     undef ROUTINE_ALLREDUCE 
    1754 #  undef DIM_1d 
    1755 #  undef INTEGER_TYPE 
    1756 ! 
    1757 #  define REAL_TYPE 
    1758 #  define DIM_0d 
    1759 #     define ROUTINE_ALLREDUCE           mppsum_real 
    1760 #     include "mpp_allreduce_generic.h90" 
    1761 #     undef ROUTINE_ALLREDUCE 
    1762 #  undef DIM_0d 
    1763 #  define DIM_1d 
    1764 #     define ROUTINE_ALLREDUCE           mppsum_a_real 
    1765 #     include "mpp_allreduce_generic.h90" 
    1766 #     undef ROUTINE_ALLREDUCE 
    1767 #  undef DIM_1d 
    1768 #  undef REAL_TYPE 
    1769 #  undef OPERATION_SUM 
    1770  
    1771 #  define OPERATION_SUM_DD 
    1772 #  define COMPLEX_TYPE 
    1773 #  define DIM_0d 
    1774 #     define ROUTINE_ALLREDUCE           mppsum_realdd 
    1775 #     include "mpp_allreduce_generic.h90" 
    1776 #     undef ROUTINE_ALLREDUCE 
    1777 #  undef DIM_0d 
    1778 #  define DIM_1d 
    1779 #     define ROUTINE_ALLREDUCE           mppsum_a_realdd 
    1780 #     include "mpp_allreduce_generic.h90" 
    1781 #     undef ROUTINE_ALLREDUCE 
    1782 #  undef DIM_1d 
    1783 #  undef COMPLEX_TYPE 
    1784 #  undef OPERATION_SUM_DD 
    1785  
    1786    !!---------------------------------------------------------------------- 
    1787    !!    ***  mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d 
    1788    !!    
    1789    !!---------------------------------------------------------------------- 
    1790    !! 
    1791 #  define OPERATION_MINLOC 
    1792 #  define DIM_2d 
    1793 #     define ROUTINE_LOC           mpp_minloc2d 
    1794 #     include "mpp_loc_generic.h90" 
    1795 #     undef ROUTINE_LOC 
    1796 #  undef DIM_2d 
    1797 #  define DIM_3d 
    1798 #     define ROUTINE_LOC           mpp_minloc3d 
    1799 #     include "mpp_loc_generic.h90" 
    1800 #     undef ROUTINE_LOC 
    1801 #  undef DIM_3d 
    1802 #  undef OPERATION_MINLOC 
    1803  
    1804 #  define OPERATION_MAXLOC 
    1805 #  define DIM_2d 
    1806 #     define ROUTINE_LOC           mpp_maxloc2d 
    1807 #     include "mpp_loc_generic.h90" 
    1808 #     undef ROUTINE_LOC 
    1809 #  undef DIM_2d 
    1810 #  define DIM_3d 
    1811 #     define ROUTINE_LOC           mpp_maxloc3d 
    1812 #     include "mpp_loc_generic.h90" 
    1813 #     undef ROUTINE_LOC 
    1814 #  undef DIM_3d 
    1815 #  undef OPERATION_MAXLOC 
    1816  
    1817    SUBROUTINE mpp_delay_sum( cdname, cdelay, y_in, pout, ldlast, kcom ) 
    1818       CHARACTER(len=*), INTENT(in   )               ::   cdname  ! name of the calling subroutine 
    1819       CHARACTER(len=*), INTENT(in   )               ::   cdelay  ! name (used as id) of the delayed operation 
    1820       COMPLEX(wp),      INTENT(in   ), DIMENSION(:) ::   y_in 
    1821       REAL(wp),         INTENT(  out), DIMENSION(:) ::   pout 
    1822       LOGICAL,          INTENT(in   )               ::   ldlast  ! true if this is the last time we call this routine 
    1823       INTEGER,          INTENT(in   ), OPTIONAL     ::   kcom 
    1824       ! 
    1825       pout(:) = REAL(y_in(:), wp) 
    1826    END SUBROUTINE mpp_delay_sum 
    1827  
    1828    SUBROUTINE mpp_delay_max( cdname, cdelay, p_in, pout, ldlast, kcom ) 
    1829       CHARACTER(len=*), INTENT(in   )               ::   cdname  ! name of the calling subroutine 
    1830       CHARACTER(len=*), INTENT(in   )               ::   cdelay  ! name (used as id) of the delayed operation 
    1831       REAL(wp),         INTENT(in   ), DIMENSION(:) ::   p_in 
    1832       REAL(wp),         INTENT(  out), DIMENSION(:) ::   pout 
    1833       LOGICAL,          INTENT(in   )               ::   ldlast  ! true if this is the last time we call this routine 
    1834       INTEGER,          INTENT(in   ), OPTIONAL     ::   kcom 
    1835       ! 
    1836       pout(:) = p_in(:) 
    1837    END SUBROUTINE mpp_delay_max 
    1838  
    1839    SUBROUTINE mpp_delay_rcv( kid ) 
    1840       INTEGER,INTENT(in   )      ::  kid  
    1841       WRITE(*,*) 'mpp_delay_rcv: You should not have seen this print! error?', kid 
    1842    END SUBROUTINE mpp_delay_rcv 
    1843     
    1844    SUBROUTINE mppstop( ldfinal, ld_force_abort ) 
    1845       LOGICAL, OPTIONAL, INTENT(in) :: ldfinal    ! source process number 
    1846       LOGICAL, OPTIONAL, INTENT(in) :: ld_force_abort    ! source process number 
    1847       STOP      ! non MPP case, just stop the run 
    1848    END SUBROUTINE mppstop 
    1849  
    1850    SUBROUTINE mpp_ini_znl( knum ) 
    1851       INTEGER :: knum 
    1852       WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?', knum 
    1853    END SUBROUTINE mpp_ini_znl 
    1854  
    1855    SUBROUTINE mpp_comm_free( kcom ) 
    1856       INTEGER :: kcom 
    1857       WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom 
    1858    END SUBROUTINE mpp_comm_free 
    1859     
    1860 #endif 
    1861  
    1862    !!---------------------------------------------------------------------- 
    1863    !!   All cases:         ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam   routines 
     1061   FUNCTION MPI_Wtime() 
     1062      REAL(wp) ::  MPI_Wtime 
     1063      MPI_Wtime = -1. 
     1064   END FUNCTION MPI_Wtime 
     1065#endif 
     1066 
     1067   !!---------------------------------------------------------------------- 
     1068   !!   ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam   routines 
    18641069   !!---------------------------------------------------------------------- 
    18651070 
    … …  
    18721077      !!                increment the error number (nstop) by one. 
    18731078      !!---------------------------------------------------------------------- 
    1874       CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5 
    1875       CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10 
     1079      CHARACTER(len=*), INTENT(in   )           ::   cd1 
     1080      CHARACTER(len=*), INTENT(in   ), OPTIONAL ::        cd2, cd3, cd4, cd5 
     1081      CHARACTER(len=*), INTENT(in   ), OPTIONAL ::   cd6, cd7, cd8, cd9, cd10 
    18761082      !!---------------------------------------------------------------------- 
    18771083      ! 
    18781084      nstop = nstop + 1 
    1879  
    1880       ! force to open ocean.output file 
     1085      ! 
     1086      ! force to open ocean.output file if not already opened 
    18811087      IF( numout == 6 ) CALL ctl_opn( numout, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 
    1882         
    1883       WRITE(numout,cform_err) 
    1884       IF( PRESENT(cd1 ) )   WRITE(numout,*) TRIM(cd1) 
     1088      ! 
     1089                            WRITE(numout,*) 
     1090                            WRITE(numout,*) ' ===>>> : E R R O R' 
     1091                            WRITE(numout,*) 
     1092                            WRITE(numout,*) '         ===========' 
     1093                            WRITE(numout,*) 
     1094                            WRITE(numout,*) TRIM(cd1) 
    18851095      IF( PRESENT(cd2 ) )   WRITE(numout,*) TRIM(cd2) 
    18861096      IF( PRESENT(cd3 ) )   WRITE(numout,*) TRIM(cd3) 
    … …  
    18921102      IF( PRESENT(cd9 ) )   WRITE(numout,*) TRIM(cd9) 
    18931103      IF( PRESENT(cd10) )   WRITE(numout,*) TRIM(cd10) 
    1894  
     1104                            WRITE(numout,*) 
     1105      ! 
    18951106                               CALL FLUSH(numout    ) 
    18961107      IF( numstp     /= -1 )   CALL FLUSH(numstp    ) 
    … …  
    18991110      ! 
    19001111      IF( cd1 == 'STOP' ) THEN 
     1112         WRITE(numout,*)   
    19011113         WRITE(numout,*)  'huge E-R-R-O-R : immediate stop' 
    1902          CALL mppstop(ld_force_abort = .true.) 
     1114         WRITE(numout,*)   
     1115         CALL mppstop( ld_abort = .true. ) 
    19031116      ENDIF 
    19041117      ! 
    … …  
    19191132      ! 
    19201133      nwarn = nwarn + 1 
     1134      ! 
    19211135      IF(lwp) THEN 
    1922          WRITE(numout,cform_war) 
    1923          IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) 
    1924          IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 
    1925          IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) 
    1926          IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4) 
    1927          IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5) 
    1928          IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6) 
    1929          IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7) 
    1930          IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8) 
    1931          IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 
    1932          IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 
     1136                               WRITE(numout,*) 
     1137                               WRITE(numout,*) ' ===>>> : W A R N I N G' 
     1138                               WRITE(numout,*) 
     1139                               WRITE(numout,*) '         ===============' 
     1140                               WRITE(numout,*) 
     1141         IF( PRESENT(cd1 ) )   WRITE(numout,*) TRIM(cd1) 
     1142         IF( PRESENT(cd2 ) )   WRITE(numout,*) TRIM(cd2) 
     1143         IF( PRESENT(cd3 ) )   WRITE(numout,*) TRIM(cd3) 
     1144         IF( PRESENT(cd4 ) )   WRITE(numout,*) TRIM(cd4) 
     1145         IF( PRESENT(cd5 ) )   WRITE(numout,*) TRIM(cd5) 
     1146         IF( PRESENT(cd6 ) )   WRITE(numout,*) TRIM(cd6) 
     1147         IF( PRESENT(cd7 ) )   WRITE(numout,*) TRIM(cd7) 
     1148         IF( PRESENT(cd8 ) )   WRITE(numout,*) TRIM(cd8) 
     1149         IF( PRESENT(cd9 ) )   WRITE(numout,*) TRIM(cd9) 
     1150         IF( PRESENT(cd10) )   WRITE(numout,*) TRIM(cd10) 
     1151                               WRITE(numout,*) 
    19331152      ENDIF 
    19341153      CALL FLUSH(numout) 
    … …  
    19731192      IF( TRIM(cdfile) == '/dev/null' )   clfile = TRIM(cdfile)   ! force the use of /dev/null 
    19741193      ! 
    1975       iost=0 
    1976       IF( cdacce(1:6) == 'DIRECT' )  THEN         ! cdacce has always more than 6 characters 
     1194      IF(       cdacce(1:6) == 'DIRECT' )  THEN   ! cdacce has always more than 6 characters 
    19771195         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh         , ERR=100, IOSTAT=iost ) 
    19781196      ELSE IF( TRIM(cdstat) == 'APPEND' )  THEN   ! cdstat can have less than 6 characters 
    … …  
    19951213100   CONTINUE 
    19961214      IF( iost /= 0 ) THEN 
    1997          IF(ldwp) THEN 
    1998             WRITE(kout,*) 
    1999             WRITE(kout,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 
    2000             WRITE(kout,*) ' =======   ===  ' 
    2001             WRITE(kout,*) '           unit   = ', knum 
    2002             WRITE(kout,*) '           status = ', cdstat 
    2003             WRITE(kout,*) '           form   = ', cdform 
    2004             WRITE(kout,*) '           access = ', cdacce 
    2005             WRITE(kout,*) '           iostat = ', iost 
    2006             WRITE(kout,*) '           we stop. verify the file ' 
    2007             WRITE(kout,*) 
    2008          ELSE  !!! Force writing to make sure we get the information - at least once - in this violent STOP!! 
    2009             WRITE(*,*) 
    2010             WRITE(*,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 
    2011             WRITE(*,*) ' =======   ===  ' 
    2012             WRITE(*,*) '           unit   = ', knum 
    2013             WRITE(*,*) '           status = ', cdstat 
    2014             WRITE(*,*) '           form   = ', cdform 
    2015             WRITE(*,*) '           access = ', cdacce 
    2016             WRITE(*,*) '           iostat = ', iost 
    2017             WRITE(*,*) '           we stop. verify the file ' 
    2018             WRITE(*,*) 
    2019          ENDIF 
    2020          CALL FLUSH( kout )  
    2021          STOP 'ctl_opn bad opening' 
     1215         WRITE(ctmp1,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 
     1216         WRITE(ctmp2,*) ' =======   ===  ' 
     1217         WRITE(ctmp3,*) '           unit   = ', knum 
     1218         WRITE(ctmp4,*) '           status = ', cdstat 
     1219         WRITE(ctmp5,*) '           form   = ', cdform 
     1220         WRITE(ctmp6,*) '           access = ', cdacce 
     1221         WRITE(ctmp7,*) '           iostat = ', iost 
     1222         WRITE(ctmp8,*) '           we stop. verify the file ' 
     1223         CALL ctl_stop( 'STOP', ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 ) 
    20221224      ENDIF 
    20231225      ! 
    … …  
    20251227 
    20261228 
    2027    SUBROUTINE ctl_nam ( kios, cdnam, ldwp ) 
     1229   SUBROUTINE ctl_nam ( kios, cdnam ) 
    20281230      !!---------------------------------------------------------------------- 
    20291231      !!                  ***  ROUTINE ctl_nam  *** 
    … …  
    20331235      !! ** Method  :   Fortan open 
    20341236      !!---------------------------------------------------------------------- 
    2035       INTEGER         , INTENT(inout) ::   kios    ! IO status after reading the namelist 
    2036       CHARACTER(len=*), INTENT(in   ) ::   cdnam   ! group name of namelist for which error occurs 
    2037       CHARACTER(len=5)                ::   clios   ! string to convert iostat in character for print 
    2038       LOGICAL         , INTENT(in   ) ::   ldwp    ! boolean term for print 
     1237      INTEGER                                , INTENT(inout) ::   kios    ! IO status after reading the namelist 
     1238      CHARACTER(len=*)                       , INTENT(in   ) ::   cdnam   ! group name of namelist for which error occurs 
     1239      ! 
     1240      CHARACTER(len=5) ::   clios   ! string to convert iostat in character for print 
    20391241      !!---------------------------------------------------------------------- 
    20401242      ! 
    … …  
    20501252      ENDIF 
    20511253      kios = 0 
    2052       RETURN 
    20531254      ! 
    20541255   END SUBROUTINE ctl_nam 
    … …  
    20711272      END DO 
    20721273      IF( (get_unit == 999) .AND. llopn ) THEN 
    2073          CALL ctl_stop( 'get_unit: All logical units until 999 are used...' ) 
    2074          get_unit = -1 
     1274         CALL ctl_stop( 'STOP', 'get_unit: All logical units until 999 are used...' ) 
    20751275      ENDIF 
    20761276      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/LBC/mpp_lnk_generic.h90

    r10542 r11822  
    4646 
    4747#if defined MULTI 
    48    SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, cd_mpp, pval ) 
    49       INTEGER                     , INTENT(in   ) ::   kfld        ! number of pt3d arrays 
     48   SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ihlcom ) 
     49      INTEGER             , INTENT(in   ) ::   kfld        ! number of pt3d arrays 
    5050#else 
    51    SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn      , cd_mpp, pval ) 
     51   SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn      , kfillmode, pfillval, lsend, lrecv, ihlcom ) 
    5252#endif 
    5353      ARRAY_TYPE(:,:,:,:,:)                                        ! array or pointer of arrays on which the boundary condition is applied 
    54       CHARACTER(len=*)            , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    55       CHARACTER(len=1)            , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points 
    56       REAL(wp)                    , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary 
    57       CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp      ! fill the overlap area only 
    58       REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval        ! background value (used at closed boundaries) 
    59       ! 
    60       INTEGER  ::    ji,  jj,  jk,  jl, jh, jf   ! dummy loop indices 
     54      CHARACTER(len=*)              , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
     55      CHARACTER(len=1)              , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points 
     56      REAL(wp)                      , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary 
     57      INTEGER ,             OPTIONAL, INTENT(in   ) ::   kfillmode   ! filling method for halo over land (default = constant) 
     58      REAL(wp),             OPTIONAL, INTENT(in   ) ::   pfillval    ! background value (used at closed boundaries) 
     59      LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in   ) ::   lsend, lrecv  ! communication with other 4 proc 
     60      INTEGER              ,OPTIONAL, INTENT(in   ) ::   ihlcom        ! number of ranks and rows to be communicated 
     61      ! 
     62      INTEGER  ::    ji,  jj,  jk,  jl,  jf      ! dummy loop indices 
    6163      INTEGER  ::   ipi, ipj, ipk, ipl, ipf      ! dimension of the input array 
    62       INTEGER  ::   imigr, iihom, ijhom          ! local integers 
    63       INTEGER  ::   ml_req1, ml_req2, ml_err     ! for key_mpi_isend 
     64      INTEGER  ::   isize, ishift, ishift2       ! local integers 
     65      INTEGER  ::   ireq_we, ireq_ea, ireq_so, ireq_no     ! mpi_request id 
    6466      INTEGER  ::   ierr 
     67      INTEGER  ::   ifill_we, ifill_ea, ifill_so, ifill_no 
     68      INTEGER  ::   ihl                          ! number of ranks and rows to be communicated  
    6569      REAL(wp) ::   zland 
    66       INTEGER , DIMENSION(MPI_STATUS_SIZE)      ::   ml_stat        ! for key_mpi_isend 
    67       REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! north-south & south-north  halos 
    68       REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! east -west  & west - east  halos 
     70      INTEGER , DIMENSION(MPI_STATUS_SIZE)        ::   istat          ! for mpi_isend 
     71      REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zsnd_we, zrcv_we, zsnd_ea, zrcv_ea   ! east -west  & west - east  halos 
     72      REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zsnd_so, zrcv_so, zsnd_no, zrcv_no   ! north-south & south-north  halos 
     73      LOGICAL  ::   llsend_we, llsend_ea, llsend_no, llsend_so       ! communication send 
     74      LOGICAL  ::   llrecv_we, llrecv_ea, llrecv_no, llrecv_so       ! communication receive  
     75      LOGICAL  ::   lldo_nfd                                     ! do north pole folding 
    6976      !!---------------------------------------------------------------------- 
     77      ! 
     78      ! ----------------------------------------- ! 
     79      !     0. local variables initialization     ! 
     80      ! ----------------------------------------- ! 
    7081      ! 
    7182      ipk = K_SIZE(ptab)   ! 3rd dimension 
    … …  
    7384      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers) 
    7485      ! 
     86      IF( PRESENT(ihlcom) ) THEN   ;   ihl = ihlcom 
     87      ELSE                         ;   ihl = 1 
     88      END IF 
     89      ! 
    7590      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) 
    7691      ! 
    77       IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value 
    78       ELSE                         ;   zland = 0._wp     ! zero by default 
    79       ENDIF 
    80  
    81       ! ------------------------------- ! 
    82       !   standard boundary treatment   !    ! CAUTION: semi-column notation is often impossible 
    83       ! ------------------------------- ! 
    84       ! 
    85       IF( .NOT. PRESENT( cd_mpp ) ) THEN     !==  standard close or cyclic treatment  ==! 
    86          ! 
    87          DO jf = 1, ipf                      ! number of arrays to be treated 
    88             ! 
    89             !                                ! East-West boundaries 
    90             IF( l_Iperio ) THEN                    !* cyclic 
    91                ARRAY_IN( 1 ,:,:,:,jf) = ARRAY_IN(jpim1,:,:,:,jf) 
    92                ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN(  2  ,:,:,:,jf) 
    93             ELSE                                   !* closed 
    94                IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(     1       :nn_hls,:,:,:,jf) = zland    ! east except F-point 
    95                                                ARRAY_IN(nlci-nn_hls+1:jpi   ,:,:,:,jf) = zland    ! west 
    96             ENDIF 
    97             !                                ! North-South boundaries 
    98             IF( l_Jperio ) THEN                    !* cyclic (only with no mpp j-split) 
    99                ARRAY_IN(:, 1 ,:,:,jf) = ARRAY_IN(:, jpjm1,:,:,jf) 
    100                ARRAY_IN(:,jpj,:,:,jf) = ARRAY_IN(:,   2  ,:,:,jf) 
    101             ELSE                                   !* closed 
    102                IF( .NOT. NAT_IN(jf) == 'F' )   ARRAY_IN(:,     1       :nn_hls,:,:,jf) = zland    ! south except F-point 
    103                                                ARRAY_IN(:,nlcj-nn_hls+1:jpj   ,:,:,jf) = zland    ! north 
     92      IF     ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN 
     93         llsend_we = lsend(1)   ;   llsend_ea = lsend(2)   ;   llsend_so = lsend(3)   ;   llsend_no = lsend(4) 
     94         llrecv_we = lrecv(1)   ;   llrecv_ea = lrecv(2)   ;   llrecv_so = lrecv(3)   ;   llrecv_no = lrecv(4) 
     95      ELSE IF( PRESENT(lsend) .OR.  PRESENT(lrecv) ) THEN 
     96         WRITE(ctmp1,*) ' E R R O R : Routine ', cdname, '  is calling lbc_lnk with only one of the two arguments lsend or lrecv' 
     97         WRITE(ctmp2,*) ' ========== ' 
     98         CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 
     99      ELSE   ! send and receive with every neighbour 
     100         llsend_we = nbondi ==  1 .OR. nbondi == 0   ! keep for compatibility, should be defined in mppini 
     101         llsend_ea = nbondi == -1 .OR. nbondi == 0   ! keep for compatibility, should be defined in mppini 
     102         llsend_so = nbondj ==  1 .OR. nbondj == 0   ! keep for compatibility, should be defined in mppini 
     103         llsend_no = nbondj == -1 .OR. nbondj == 0   ! keep for compatibility, should be defined in mppini 
     104         llrecv_we = llsend_we   ;   llrecv_ea = llsend_ea   ;   llrecv_so = llsend_so   ;   llrecv_no = llsend_no 
     105      END IF 
     106          
     107          
     108      lldo_nfd = npolj /= 0                      ! keep for compatibility, should be defined in mppini 
     109 
     110      zland = 0._wp                                     ! land filling value: zero by default 
     111      IF( PRESENT( pfillval ) )   zland = pfillval      ! set land value 
     112 
     113      ! define the method we will use to fill the halos in each direction 
     114      IF(              llrecv_we ) THEN   ;   ifill_we = jpfillmpi 
     115      ELSEIF(           l_Iperio ) THEN   ;   ifill_we = jpfillperio 
     116      ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill_we = kfillmode 
     117      ELSE                                ;   ifill_we = jpfillcst 
     118      END IF 
     119      ! 
     120      IF(              llrecv_ea ) THEN   ;   ifill_ea = jpfillmpi 
     121      ELSEIF(           l_Iperio ) THEN   ;   ifill_ea = jpfillperio 
     122      ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill_ea = kfillmode 
     123      ELSE                                ;   ifill_ea = jpfillcst 
     124      END IF 
     125      ! 
     126      IF(              llrecv_so ) THEN   ;   ifill_so = jpfillmpi 
     127      ELSEIF(           l_Jperio ) THEN   ;   ifill_so = jpfillperio 
     128      ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill_so = kfillmode 
     129      ELSE                                ;   ifill_so = jpfillcst 
     130      END IF 
     131      ! 
     132      IF(              llrecv_no ) THEN   ;   ifill_no = jpfillmpi 
     133      ELSEIF(           l_Jperio ) THEN   ;   ifill_no = jpfillperio 
     134      ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill_no = kfillmode 
     135      ELSE                                ;   ifill_no = jpfillcst 
     136      END IF 
     137      ! 
     138#if defined PRINT_CAUTION 
     139      ! 
     140      ! ================================================================================== ! 
     141      ! CAUTION: semi-column notation is often impossible because of the cpp preprocessing ! 
     142      ! ================================================================================== ! 
     143      ! 
     144#endif 
     145      ! 
     146      ! -------------------------------------------------- ! 
     147      !     1. Do east and west MPI exchange if needed     ! 
     148      ! -------------------------------------------------- ! 
     149      ! 
     150      ! Must exchange the whole column (from 1 to jpj) to get the corners if we have no south/north neighbourg 
     151      isize = ihl * jpj * ipk * ipl * ipf       
     152      ! 
     153      ! Allocate local temporary arrays to be sent/received. Fill arrays to be sent 
     154      IF( llsend_we )   ALLOCATE( zsnd_we(ihl,jpj,ipk,ipl,ipf) ) 
     155      IF( llsend_ea )   ALLOCATE( zsnd_ea(ihl,jpj,ipk,ipl,ipf) ) 
     156      IF( llrecv_we )   ALLOCATE( zrcv_we(ihl,jpj,ipk,ipl,ipf) ) 
     157      IF( llrecv_ea )   ALLOCATE( zrcv_ea(ihl,jpj,ipk,ipl,ipf) ) 
     158      ! 
     159      IF( llsend_we ) THEN   ! copy western side of the inner mpi domain in local temporary array to be sent by MPI 
     160         ishift = ihl 
     161         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
     162            zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf)   ! ihl + 1 -> 2*ihl 
     163         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
     164      ENDIF 
     165      ! 
     166      IF(llsend_ea  ) THEN   ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 
     167         ishift = jpi - 2 * ihl 
     168         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
     169            zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf)   ! jpi - 2*ihl + 1 -> jpi - ihl 
     170         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
     171      ENDIF 
     172      ! 
     173      IF( ln_timing ) CALL tic_tac(.TRUE.) 
     174      ! 
     175      ! non-blocking send of the western/eastern side using local temporary arrays 
     176      IF( llsend_we )   CALL mppsend( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we ) 
     177      IF( llsend_ea )   CALL mppsend( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea ) 
     178      ! blocking receive of the western/eastern halo in local temporary arrays 
     179      IF( llrecv_we )   CALL mpprecv( 2, zrcv_we(1,1,1,1,1), isize, nowe ) 
     180      IF( llrecv_ea )   CALL mpprecv( 1, zrcv_ea(1,1,1,1,1), isize, noea ) 
     181      ! 
     182      IF( ln_timing ) CALL tic_tac(.FALSE.) 
     183      ! 
     184      ! 
     185      ! ----------------------------------- ! 
     186      !     2. Fill east and west halos     ! 
     187      ! ----------------------------------- ! 
     188      ! 
     189      ! 2.1 fill weastern halo 
     190      ! ---------------------- 
     191      ! ishift = 0                         ! fill halo from ji = 1 to ihl 
     192      SELECT CASE ( ifill_we ) 
     193      CASE ( jpfillnothing )               ! no filling  
     194      CASE ( jpfillmpi   )                 ! use data received by MPI  
     195         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
     196            ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf)   ! 1 -> ihl 
     197         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
     198      CASE ( jpfillperio )                 ! use east-weast periodicity 
     199         ishift2 = jpi - 2 * ihl 
     200         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
     201            ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 
     202         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
     203      CASE ( jpfillcopy  )                 ! filling with inner domain values 
     204         DO jf = 1, ipf                               ! number of arrays to be treated 
     205            IF( .NOT. NAT_IN(jf) == 'F' ) THEN        ! do nothing for F point 
     206               DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
     207                  ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ihl+1,jj,jk,jl,jf) 
     208               END DO   ;   END DO   ;   END DO   ;   END DO 
    104209            ENDIF 
    105210         END DO 
    106          ! 
    107       ENDIF 
    108  
    109       ! ------------------------------- ! 
    110       !      East and west exchange     ! 
    111       ! ------------------------------- ! 
    112       ! we play with the neigbours AND the row number because of the periodicity 
    113       ! 
    114       IF( ABS(nbondi) == 1 ) ALLOCATE( zt3ew(jpj,nn_hls,ipk,ipl,ipf,1), zt3we(jpj,nn_hls,ipk,ipl,ipf,1) ) 
    115       IF(     nbondi  == 0 ) ALLOCATE( zt3ew(jpj,nn_hls,ipk,ipl,ipf,2), zt3we(jpj,nn_hls,ipk,ipl,ipf,2) ) 
    116       ! 
    117       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    118       CASE ( -1 ) 
    119          iihom = nlci-nreci 
    120          DO jf = 1, ipf 
    121             DO jl = 1, ipl 
    122                DO jk = 1, ipk 
    123                   DO jh = 1, nn_hls 
    124                      zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf) 
    125                   END DO 
    126                END DO 
    127             END DO 
    128          END DO 
    129       CASE ( 0 ) 
    130          iihom = nlci-nreci 
    131          DO jf = 1, ipf 
    132             DO jl = 1, ipl 
    133                DO jk = 1, ipk 
    134                   DO jh = 1, nn_hls 
    135                      zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf) 
    136                      zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf) 
    137                   END DO 
    138                END DO 
    139             END DO 
    140          END DO 
    141       CASE ( 1 ) 
    142          iihom = nlci-nreci 
    143          DO jf = 1, ipf 
    144             DO jl = 1, ipl 
    145                DO jk = 1, ipk 
    146                   DO jh = 1, nn_hls 
    147                      zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf) 
    148                   END DO 
    149                END DO 
    150             END DO 
     211      CASE ( jpfillcst   )                 ! filling with constant value 
     212         DO jf = 1, ipf                               ! number of arrays to be treated 
     213            IF( .NOT. NAT_IN(jf) == 'F' ) THEN        ! do nothing for F point 
     214               DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
     215                  ARRAY_IN(ji,jj,jk,jl,jf) = zland 
     216               END DO;   END DO   ;   END DO   ;   END DO 
     217            ENDIF 
    151218         END DO 
    152219      END SELECT 
    153       !                           ! Migrations 
    154       imigr = nn_hls * jpj * ipk * ipl * ipf       
    155       ! 
    156       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    157       ! 
    158       SELECT CASE ( nbondi ) 
    159       CASE ( -1 ) 
    160          CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req1 ) 
    161          CALL mpprecv( 1, zt3ew(1,1,1,1,1,1), imigr, noea ) 
    162          IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    163       CASE ( 0 ) 
    164          CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 ) 
    165          CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req2 ) 
    166          CALL mpprecv( 1, zt3ew(1,1,1,1,1,2), imigr, noea ) 
    167          CALL mpprecv( 2, zt3we(1,1,1,1,1,2), imigr, nowe ) 
    168          IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err) 
    169          IF(l_isend)   CALL mpi_wait(ml_req2, ml_stat, ml_err) 
    170       CASE ( 1 ) 
    171          CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 ) 
    172          CALL mpprecv( 2, zt3we(1,1,1,1,1,1), imigr, nowe ) 
    173          IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
     220      ! 
     221      ! 2.2 fill eastern halo 
     222      ! --------------------- 
     223      ishift = jpi - ihl                ! fill halo from ji = jpi-ihl+1 to jpi  
     224      SELECT CASE ( ifill_ea ) 
     225      CASE ( jpfillnothing )               ! no filling  
     226      CASE ( jpfillmpi   )                 ! use data received by MPI  
     227         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
     228            ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf)   ! jpi - ihl + 1 -> jpi 
     229         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
     230      CASE ( jpfillperio )                 ! use east-weast periodicity 
     231         ishift2 = ihl 
     232         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
     233            ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 
     234         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
     235      CASE ( jpfillcopy  )                 ! filling with inner domain values 
     236         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
     237            ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf) 
     238         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
     239      CASE ( jpfillcst   )                 ! filling with constant value 
     240         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
     241            ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland 
     242         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
    174243      END SELECT 
    175       ! 
    176       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    177       ! 
    178       !                           ! Write Dirichlet lateral conditions 
    179       iihom = nlci-nn_hls 
    180       ! 
    181       SELECT CASE ( nbondi ) 
    182       CASE ( -1 ) 
    183          DO jf = 1, ipf 
    184             DO jl = 1, ipl 
    185                DO jk = 1, ipk 
    186                   DO jh = 1, nn_hls 
    187                      ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,1) 
    188                   END DO 
    189                END DO 
    190             END DO 
    191          END DO 
    192       CASE ( 0 ) 
    193          DO jf = 1, ipf 
    194             DO jl = 1, ipl 
    195                DO jk = 1, ipk 
    196                   DO jh = 1, nn_hls 
    197                      ARRAY_IN(jh      ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2) 
    198                      ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2) 
    199                   END DO 
    200                END DO 
    201             END DO 
    202          END DO 
    203       CASE ( 1 ) 
    204          DO jf = 1, ipf 
    205             DO jl = 1, ipl 
    206                DO jk = 1, ipk 
    207                   DO jh = 1, nn_hls 
    208                      ARRAY_IN(jh      ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,1) 
    209                   END DO 
    210                END DO 
    211             END DO 
    212          END DO 
    213       END SELECT 
    214       ! 
    215       IF( nbondi /= 2 ) DEALLOCATE( zt3ew, zt3we ) 
    216244      ! 
    217245      ! ------------------------------- ! 
    218246      !     3. north fold treatment     ! 
    219247      ! ------------------------------- ! 
     248      ! 
    220249      ! do it before south directions so concerned processes can do it without waiting for the comm with the sourthern neighbor 
    221       IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     250      ! 
     251      IF( lldo_nfd .AND. ifill_no /= jpfillnothing ) THEN 
    222252         ! 
    223253         SELECT CASE ( jpni ) 
    … …  
    226256         END SELECT 
    227257         ! 
    228       ENDIF 
    229       ! 
    230       ! ------------------------------- ! 
    231       !  4. North and south directions  ! 
    232       ! ------------------------------- ! 
    233       ! always closed : we play only with the neigbours 
    234       ! 
    235       IF( ABS(nbondj) == 1 ) ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,1), zt3sn(jpi,nn_hls,ipk,ipl,ipf,1) ) 
    236       IF(     nbondj  == 0 ) ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,2), zt3sn(jpi,nn_hls,ipk,ipl,ipf,2) ) 
    237       ! 
    238       SELECT CASE ( nbondj ) 
    239       CASE ( -1 ) 
    240          ijhom = nlcj-nrecj 
    241          DO jf = 1, ipf 
    242             DO jl = 1, ipl 
    243                DO jk = 1, ipk 
    244                   DO jh = 1, nn_hls 
    245                      zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf) 
    246                   END DO 
    247                END DO 
    248             END DO 
     258         ifill_no = jpfillnothing  ! force to do nothing for the northern halo as we just done the north pole folding 
     259         ! 
     260      ENDIF 
     261      ! 
     262      ! ---------------------------------------------------- ! 
     263      !     4. Do north and south MPI exchange if needed     ! 
     264      ! ---------------------------------------------------- ! 
     265      ! 
     266      IF( llsend_so )   ALLOCATE( zsnd_so(jpi,ihl,ipk,ipl,ipf) ) 
     267      IF( llsend_no )   ALLOCATE( zsnd_no(jpi,ihl,ipk,ipl,ipf) ) 
     268      IF( llrecv_so )   ALLOCATE( zrcv_so(jpi,ihl,ipk,ipl,ipf) ) 
     269      IF( llrecv_no )   ALLOCATE( zrcv_no(jpi,ihl,ipk,ipl,ipf) ) 
     270      ! 
     271      isize = jpi * ihl * ipk * ipl * ipf       
     272 
     273      ! allocate local temporary arrays to be sent/received. Fill arrays to be sent 
     274      IF( llsend_so ) THEN   ! copy sourhern side of the inner mpi domain in local temporary array to be sent by MPI 
     275         ishift = ihl 
     276         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
     277            zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf)   ! ihl+1 -> 2*ihl 
     278         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
     279      ENDIF 
     280      ! 
     281      IF( llsend_no ) THEN   ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 
     282         ishift = jpj - 2 * ihl 
     283         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
     284            zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf)   ! jpj-2*ihl+1 -> jpj-ihl 
     285         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
     286      ENDIF 
     287      ! 
     288      IF( ln_timing ) CALL tic_tac(.TRUE.) 
     289      ! 
     290      ! non-blocking send of the southern/northern side 
     291      IF( llsend_so )   CALL mppsend( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so ) 
     292      IF( llsend_no )   CALL mppsend( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no ) 
     293      ! blocking receive of the southern/northern halo 
     294      IF( llrecv_so )   CALL mpprecv( 4, zrcv_so(1,1,1,1,1), isize, noso ) 
     295      IF( llrecv_no )   CALL mpprecv( 3, zrcv_no(1,1,1,1,1), isize, nono ) 
     296      ! 
     297      IF( ln_timing ) CALL tic_tac(.FALSE.) 
     298      ! 
     299      ! ------------------------------------- ! 
     300      !     5. Fill south and north halos     ! 
     301      ! ------------------------------------- ! 
     302      ! 
     303      ! 5.1 fill southern halo 
     304      ! ---------------------- 
     305      ! ishift = 0                         ! fill halo from jj = 1 to ihl 
     306      SELECT CASE ( ifill_so ) 
     307      CASE ( jpfillnothing )               ! no filling  
     308      CASE ( jpfillmpi   )                 ! use data received by MPI  
     309         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
     310            ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf)   ! 1 -> ihl 
     311         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
     312      CASE ( jpfillperio )                 ! use north-south periodicity 
     313         ishift2 = jpj - 2 * ihl 
     314         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
     315            ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 
     316         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
     317      CASE ( jpfillcopy  )                 ! filling with inner domain values 
     318         DO jf = 1, ipf                               ! number of arrays to be treated 
     319            IF( .NOT. NAT_IN(jf) == 'F' ) THEN        ! do nothing for F point 
     320               DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
     321                  ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ihl+1,jk,jl,jf) 
     322               END DO   ;   END DO   ;   END DO   ;   END DO 
     323            ENDIF 
    249324         END DO 
    250       CASE ( 0 ) 
    251          ijhom = nlcj-nrecj 
    252          DO jf = 1, ipf 
    253             DO jl = 1, ipl 
    254                DO jk = 1, ipk 
    255                   DO jh = 1, nn_hls 
    256                      zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf) 
    257                      zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf) 
    258                   END DO 
    259                END DO 
    260             END DO 
    261          END DO 
    262       CASE ( 1 ) 
    263          ijhom = nlcj-nrecj 
    264          DO jf = 1, ipf 
    265             DO jl = 1, ipl 
    266                DO jk = 1, ipk 
    267                   DO jh = 1, nn_hls 
    268                      zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf) 
    269                   END DO 
    270                END DO 
    271             END DO 
     325      CASE ( jpfillcst   )                 ! filling with constant value 
     326         DO jf = 1, ipf                               ! number of arrays to be treated 
     327            IF( .NOT. NAT_IN(jf) == 'F' ) THEN        ! do nothing for F point 
     328               DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi  
     329                  ARRAY_IN(ji,jj,jk,jl,jf) = zland 
     330               END DO;   END DO   ;   END DO   ;   END DO 
     331            ENDIF 
    272332         END DO 
    273333      END SELECT 
    274334      ! 
    275       !                           ! Migrations 
    276       imigr = nn_hls * jpi * ipk * ipl * ipf 
    277       ! 
    278       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    279       !  
    280       SELECT CASE ( nbondj ) 
    281       CASE ( -1 ) 
    282          CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req1 ) 
    283          CALL mpprecv( 3, zt3ns(1,1,1,1,1,1), imigr, nono ) 
    284          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
    285       CASE ( 0 ) 
    286          CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 ) 
    287          CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req2 ) 
    288          CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono ) 
    289          CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso ) 
    290          IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
    291          IF(l_isend)   CALL mpi_wait(ml_req2, ml_stat, ml_err ) 
    292       CASE ( 1 ) 
    293          CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 ) 
    294          CALL mpprecv( 4, zt3sn(1,1,1,1,1,1), imigr, noso ) 
    295          IF(l_isend)   CALL mpi_wait(ml_req1, ml_stat, ml_err ) 
     335      ! 5.2 fill northern halo 
     336      ! ---------------------- 
     337      ishift = jpj - ihl                ! fill halo from jj = jpj-ihl+1 to jpj  
     338      SELECT CASE ( ifill_no ) 
     339      CASE ( jpfillnothing )               ! no filling  
     340      CASE ( jpfillmpi   )                 ! use data received by MPI  
     341         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
     342            ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf)   ! jpj-ihl+1 -> jpj 
     343         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
     344      CASE ( jpfillperio )                 ! use north-south periodicity 
     345         ishift2 = ihl 
     346         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
     347            ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 
     348         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
     349      CASE ( jpfillcopy  )                 ! filling with inner domain values 
     350         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
     351            ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf) 
     352         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
     353      CASE ( jpfillcst   )                 ! filling with constant value 
     354         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
     355            ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland 
     356         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
    296357      END SELECT 
    297358      ! 
    298       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    299       !                           ! Write Dirichlet lateral conditions 
    300       ijhom = nlcj-nn_hls 
    301       ! 
    302       SELECT CASE ( nbondj ) 
    303       CASE ( -1 ) 
    304          DO jf = 1, ipf 
    305             DO jl = 1, ipl 
    306                DO jk = 1, ipk 
    307                   DO jh = 1, nn_hls 
    308                      ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,1) 
    309                   END DO 
    310                END DO 
    311             END DO 
    312          END DO 
    313       CASE ( 0 ) 
    314          DO jf = 1, ipf 
    315             DO jl = 1, ipl 
    316                DO jk = 1, ipk 
    317                   DO jh = 1, nn_hls 
    318                      ARRAY_IN(:,      jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2) 
    319                      ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2) 
    320                   END DO 
    321                END DO 
    322             END DO 
    323          END DO 
    324       CASE ( 1 ) 
    325          DO jf = 1, ipf 
    326             DO jl = 1, ipl 
    327                DO jk = 1, ipk 
    328                   DO jh = 1, nn_hls 
    329                      ARRAY_IN(:,jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,1) 
    330                   END DO 
    331                END DO 
    332             END DO 
    333          END DO 
    334       END SELECT 
    335       ! 
    336       IF( nbondj /= 2 ) DEALLOCATE( zt3ns, zt3sn ) 
     359      ! -------------------------------------------- ! 
     360      !     6. deallocate local temporary arrays     ! 
     361      ! -------------------------------------------- ! 
     362      ! 
     363      IF( llsend_we ) THEN 
     364         CALL mpi_wait(ireq_we, istat, ierr ) 
     365         DEALLOCATE( zsnd_we ) 
     366      ENDIF 
     367      IF( llsend_ea )  THEN 
     368         CALL mpi_wait(ireq_ea, istat, ierr ) 
     369         DEALLOCATE( zsnd_ea ) 
     370      ENDIF 
     371      IF( llsend_so ) THEN 
     372         CALL mpi_wait(ireq_so, istat, ierr ) 
     373         DEALLOCATE( zsnd_so ) 
     374      ENDIF 
     375      IF( llsend_no ) THEN 
     376         CALL mpi_wait(ireq_no, istat, ierr ) 
     377         DEALLOCATE( zsnd_no ) 
     378      ENDIF 
     379      ! 
     380      IF( llrecv_we )   DEALLOCATE( zrcv_we ) 
     381      IF( llrecv_ea )   DEALLOCATE( zrcv_ea ) 
     382      IF( llrecv_so )   DEALLOCATE( zrcv_so ) 
     383      IF( llrecv_no )   DEALLOCATE( zrcv_no ) 
    337384      ! 
    338385   END SUBROUTINE ROUTINE_LNK 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/LBC/mpp_nfd_generic.h90

    r10440 r11822  
    7676      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers) 
    7777      ! 
    78       IF( l_north_nogather ) THEN      !==  ????  ==! 
     78      IF( l_north_nogather ) THEN      !==  no allgather exchanges  ==! 
    7979 
    8080         ALLOCATE(ipj_s(ipf)) 
    … …  
    200200            ENDIF 
    201201         END DO 
    202          IF( l_isend ) THEN 
    203             DO jr = 1,nsndto 
    204                IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    205                   CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 
    206                ENDIF 
    207             END DO 
    208          ENDIF 
     202         DO jr = 1,nsndto 
     203            IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
     204               CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 
     205            ENDIF 
     206         END DO 
    209207         ! 
    210208         IF( ln_timing ) CALL tic_tac(.FALSE.) 
    … …  
    213211         ! 
    214212         DO jf = 1, ipf 
    215             CALL lbc_nfd_nogather(ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) 
    216          END DO 
    217          ! 
    218          DEALLOCATE( zfoldwk ) 
    219          DEALLOCATE( ztabr )  
    220          DEALLOCATE( jj_s )  
    221          DEALLOCATE( ipj_s )  
    222       ELSE                             !==  ????  ==! 
     213            CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) 
     214         END DO 
     215         ! 
     216         DEALLOCATE( zfoldwk, ztabr, jj_s, ipj_s ) 
     217         ! 
     218      ELSE                             !==  allgather exchanges  ==! 
    223219         ! 
    224220         ipj   = 4            ! 2nd dimension of message transfers (last j-lines) 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/LBC/mppini.F90

    r10615 r11822  
    8484      nbondj = 2 
    8585      nidom  = FLIO_DOM_NONE 
    86       npolj = jperio 
     86      npolj = 0 
     87      IF( jperio == 3 .OR. jperio == 4 )   npolj = 3 
     88      IF( jperio == 5 .OR. jperio == 6 )   npolj = 5 
    8789      l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7) 
    8890      l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7) 
    … …  
    152154      LOGICAL ::   llbest, llauto 
    153155      LOGICAL ::   llwrtlay 
     156      LOGICAL ::   ln_listonly 
    154157      INTEGER, ALLOCATABLE, DIMENSION(:)     ::   iin, ii_nono, ii_noea          ! 1D workspace 
    155158      INTEGER, ALLOCATABLE, DIMENSION(:)     ::   ijn, ii_noso, ii_nowe          !  -     - 
    … …  
    164167           &             ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & 
    165168           &             cn_ice, nn_ice_dta,                                     & 
    166            &             rn_ice_tem, rn_ice_sal, rn_ice_age,                     & 
    167            &             ln_vol, nn_volctl, nn_rimwidth, nb_jpk_bdy 
    168       !!---------------------------------------------------------------------- 
    169  
     169           &             ln_vol, nn_volctl, nn_rimwidth 
     170      NAMELIST/nammpp/ jpni, jpnj, ln_nnogather, ln_listonly 
     171      !!---------------------------------------------------------------------- 
     172      ! 
    170173      llwrtlay = lwp .OR. ln_ctl .OR. sn_cfctl%l_layout 
     174      ! 
     175      !  0. read namelists parameters 
     176      ! ----------------------------------- 
     177      ! 
     178      REWIND( numnam_ref )              ! Namelist nammpp in reference namelist 
     179      READ  ( numnam_ref, nammpp, IOSTAT = ios, ERR = 901 ) 
     180901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nammpp in reference namelist' ) 
     181      REWIND( numnam_cfg )              ! Namelist nammpp in confguration namelist 
     182      READ  ( numnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 
     183902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nammpp in configuration namelist' )    
     184      ! 
     185      IF(lwp) THEN 
     186            WRITE(numout,*) '   Namelist nammpp' 
     187         IF( jpni < 1 .OR. jpnj < 1  ) THEN 
     188            WRITE(numout,*) '      jpni and jpnj will be calculated automatically' 
     189         ELSE 
     190            WRITE(numout,*) '      processor grid extent in i                            jpni = ', jpni 
     191            WRITE(numout,*) '      processor grid extent in j                            jpnj = ', jpnj 
     192         ENDIF 
     193            WRITE(numout,*) '      avoid use of mpi_allgather at the north fold  ln_nnogather = ', ln_nnogather 
     194      ENDIF 
     195      ! 
     196      IF(lwm)   WRITE( numond, nammpp ) 
     197 
    171198      ! do we need to take into account bdy_msk? 
    172199      REWIND( numnam_ref )              ! Namelist nambdy in reference namelist : BDY 
    173200      READ  ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) 
    174 903   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambdy in reference namelist (mppini)', lwp ) 
     201903   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambdy in reference namelist (mppini)' ) 
    175202      REWIND( numnam_cfg )              ! Namelist nambdy in configuration namelist : BDY 
    176203      READ  ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 ) 
    177 904   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambdy in configuration namelist (mppini)', lwp ) 
     204904   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambdy in configuration namelist (mppini)' ) 
    178205      ! 
    179206      IF(               ln_read_cfg ) CALL iom_open( cn_domcfg,    numbot ) 
    180207      IF( ln_bdy .AND. ln_mask_file ) CALL iom_open( cn_mask_file, numbdy ) 
     208      ! 
     209      IF( ln_listonly )   CALL mpp_init_bestpartition( MAX(mppsize,jpni*jpnj), ldlist = .TRUE. )   ! must be done by all core 
    181210      ! 
    182211      !  1. Dimension arrays for subdomains 
    … …  
    241270         CALL ctl_stop( ctmp1, ctmp2, ctmp3, ' ', ctmp4, ' ' ) 
    242271         CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. )   ! must be done by all core 
    243          CALL ctl_stop( 'STOP' ) 
    244272      ENDIF 
    245273 
    … …  
    266294         ENDIF 
    267295         CALL mpp_init_bestpartition( mppsize, ldlist = .TRUE. )   ! must be done by all core 
    268          CALL ctl_stop( 'STOP' ) 
    269296      ENDIF 
    270297 
    … …  
    511538 9401    FORMAT('              '   ,20('   ',i3,'          ') ) 
    512539 9402    FORMAT('       ',i3,' *  ',20(i3,'  x',i3,'   *   ') ) 
    513  9404    FORMAT('           *  '   ,20('      ',i3,'   *   ') ) 
     540 9404    FORMAT('           *  '   ,20('     ' ,i4,'   *   ') ) 
    514541      ENDIF 
    515542          
    … …  
    669696      ! 
    670697      CALL mpp_init_ioipsl       ! Prepare NetCDF output file (if necessary) 
    671       ! 
    672       IF( ln_nnogather ) THEN 
     698      !       
     699      IF (( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ).AND.( ln_nnogather )) THEN 
    673700         CALL mpp_init_nfdcom     ! northfold neighbour lists 
    674701         IF (llwrtlay) THEN 
    … …  
    816843      INTEGER :: isziref, iszjref 
    817844      INTEGER :: inbij, iszij 
    818       INTEGER :: inbimax, inbjmax, inbijmax 
     845      INTEGER :: inbimax, inbjmax, inbijmax, inbijold 
    819846      INTEGER :: isz0, isz1 
    820847      INTEGER, DIMENSION(  :), ALLOCATABLE :: indexok 
    … …  
    941968      DEALLOCATE( indexok, inbi1, inbj1, iszi1, iszj1 ) 
    942969 
    943       IF( llist ) THEN  ! we print about 21 best partitions 
     970      IF( llist ) THEN 
    944971         IF(lwp) THEN 
    945972            WRITE(numout,*) 
    946             WRITE(numout,         *) '                  For your information:' 
    947             WRITE(numout,'(a,i5,a)') '  list of the best partitions around ',   knbij, ' mpi processes' 
    948             WRITE(numout,         *) '  --------------------------------------', '-----', '--------------' 
     973            WRITE(numout,*) '                  For your information:' 
     974            WRITE(numout,*) '  list of the best partitions including land supression' 
     975            WRITE(numout,*) '  -----------------------------------------------------' 
    949976            WRITE(numout,*) 
    950977         END IF 
    951          iitarget = MINLOC( inbi0(:)*inbj0(:), mask = inbi0(:)*inbj0(:) >= knbij, dim = 1 ) 
    952          DO ji = MAX(1,iitarget-10), MIN(isz0,iitarget+10) 
     978         ji = isz0   ! initialization with the largest value 
     979         ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 
     980         CALL mpp_init_isoce( inbi0(ji), inbj0(ji), llisoce ) ! Warning: must be call by all cores (call mpp_sum) 
     981         inbijold = COUNT(llisoce) 
     982         DEALLOCATE( llisoce ) 
     983         DO ji =isz0-1,1,-1 
    953984            ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 
    954985            CALL mpp_init_isoce( inbi0(ji), inbj0(ji), llisoce ) ! Warning: must be call by all cores (call mpp_sum) 
    955986            inbij = COUNT(llisoce) 
    956987            DEALLOCATE( llisoce ) 
    957             IF(lwp) WRITE(numout,'(a, i5, a, i5, a, i4, a, i4, a, i9, a, i5, a, i5, a)')    & 
    958                &     'nb_cores ' , inbij,' oce + ', inbi0(ji)*inbj0(ji) - inbij             & 
    959                &                                , ' land ( ', inbi0(ji),' x ', inbj0(ji),   & 
    960                & ' ), nb_points ', iszi0(ji)*iszj0(ji),' ( ', iszi0(ji),' x ', iszj0(ji),' )' 
     988            IF(lwp .AND. inbij < inbijold) THEN 
     989               WRITE(numout,'(a, i6, a, i6, a, f4.1, a, i9, a, i6, a, i6, a)')                                 & 
     990                  &   'nb_cores oce: ', inbij, ', land domains excluded: ', inbi0(ji)*inbj0(ji) - inbij,       & 
     991                  &   ' (', REAL(inbi0(ji)*inbj0(ji) - inbij,wp) / REAL(inbi0(ji)*inbj0(ji),wp) *100.,         & 
     992                  &   '%), largest oce domain: ', iszi0(ji)*iszj0(ji), ' ( ', iszi0(ji),' x ', iszj0(ji), ' )' 
     993               inbijold = inbij 
     994            END IF 
    961995         END DO 
    962996         DEALLOCATE( inbi0, inbj0, iszi0, iszj0 ) 
    963          RETURN 
     997         IF(lwp) THEN 
     998            WRITE(numout,*) 
     999            WRITE(numout,*)  '  -----------------------------------------------------------' 
     1000         ENDIF 
     1001         CALL mppsync 
     1002         CALL mppstop( ld_abort = .TRUE. ) 
    9641003      ENDIF 
    9651004       

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/LDF/ldfdyn.F90

    r10922 r11822  
    6262 
    6363   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ahmt, ahmf   !: eddy viscosity coef. at T- and F-points [m2/s or m4/s] 
    64    REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:)  ::   dtensq       !: horizontal tension squared         (Smagorinsky only) 
    65    REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:)  ::   dshesq       !: horizontal shearing strain squared (Smagorinsky only) 
     64   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   dtensq       !: horizontal tension squared         (Smagorinsky only) 
     65   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   dshesq       !: horizontal shearing strain squared (Smagorinsky only) 
    6666   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   esqt, esqf   !: Square of the local gridscale (e1e2/(e1+e2))**2            
    6767 
    … …  
    117117      REWIND( numnam_ref )              ! Namelist namdyn_ldf in reference namelist : Lateral physics 
    118118      READ  ( numnam_ref, namdyn_ldf, IOSTAT = ios, ERR = 901) 
    119 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_ldf in reference namelist', lwp ) 
     119901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_ldf in reference namelist' ) 
    120120 
    121121      REWIND( numnam_cfg )              ! Namelist namdyn_ldf in configuration namelist : Lateral physics 
    122122      READ  ( numnam_cfg, namdyn_ldf, IOSTAT = ios, ERR = 902 ) 
    123 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_ldf in configuration namelist', lwp ) 
     123902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_ldf in configuration namelist' ) 
    124124      IF(lwm) WRITE ( numond, namdyn_ldf ) 
    125125 
    … …  
    242242         IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'ldf_dyn_init: failed to allocate arrays') 
    243243         ! 
    244          ahmt(:,:,jpk) = 0._wp                     ! last level always 0  
    245          ahmf(:,:,jpk) = 0._wp 
     244         ahmt(:,:,:) = 0._wp                       ! init to 0 needed  
     245         ahmf(:,:,:) = 0._wp 
    246246         ! 
    247247         !                                         ! value of lap/blp eddy mixing coef. 
    … …  
    310310            ! 
    311311            !                          ! allocate arrays used in ldf_dyn.  
    312             ALLOCATE( dtensq(jpi,jpj) , dshesq(jpi,jpj) , esqt(jpi,jpj) , esqf(jpi,jpj) , STAT=ierr ) 
     312            ALLOCATE( dtensq(jpi,jpj,jpk) , dshesq(jpi,jpj,jpk) , esqt(jpi,jpj) , esqf(jpi,jpj) , STAT=ierr ) 
    313313            IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'ldf_dyn_init: failed to allocate Smagorinsky arrays') 
    314314            ! 
    315             DO jj = 2, jpjm1           ! Set local gridscale values 
    316                DO ji = fs_2, fs_jpim1 
    317                   esqt(ji,jj) = ( e1e2t(ji,jj) /( e1t(ji,jj) + e2t(ji,jj) ) )**2  
    318                   esqf(ji,jj) = ( e1e2f(ji,jj) /( e1f(ji,jj) + e2f(ji,jj) ) )**2  
     315            DO jj = 1, jpj             ! Set local gridscale values 
     316               DO ji = 1, jpi 
     317                  esqt(ji,jj) = ( 2._wp * e1e2t(ji,jj) / ( e1t(ji,jj) + e2t(ji,jj) ) )**2  
     318                  esqf(ji,jj) = ( 2._wp * e1e2f(ji,jj) / ( e1f(ji,jj) + e2f(ji,jj) ) )**2  
    319319               END DO 
    320320            END DO 
    … …  
    360360      ! 
    361361      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    362       REAL(wp) ::   zu2pv2_ij_p1, zu2pv2_ij, zu2pv2_ij_m1, zetmax, zefmax   ! local scalar 
    363       REAL(wp) ::   zcmsmag, zstabf_lo, zstabf_up, zdelta, zdb              ! local scalar 
     362      REAL(wp) ::   zu2pv2_ij_p1, zu2pv2_ij, zu2pv2_ij_m1, zemax   ! local scalar (option 31) 
     363      REAL(wp) ::   zcmsmag, zstabf_lo, zstabf_up, zdelta, zdb     ! local scalar (option 32) 
    364364      !!---------------------------------------------------------------------- 
    365365      ! 
    … …  
    374374               DO jj = 2, jpjm1 
    375375                  DO ji = fs_2, fs_jpim1 
    376                      zu2pv2_ij_p1 = uu(ji  ,jj+1,jk,Kbb) * uu(ji  ,jj+1,jk,Kbb) + vv(ji+1,jj  ,jk,Kbb) * vv(ji+1,jj  ,jk,Kbb) 
    377376                     zu2pv2_ij    = uu(ji  ,jj  ,jk,Kbb) * uu(ji  ,jj  ,jk,Kbb) + vv(ji  ,jj  ,jk,Kbb) * vv(ji  ,jj  ,jk,Kbb) 
    378377                     zu2pv2_ij_m1 = uu(ji-1,jj  ,jk,Kbb) * uu(ji-1,jj  ,jk,Kbb) + vv(ji  ,jj-1,jk,Kbb) * vv(ji  ,jj-1,jk,Kbb) 
    379                      zetmax = MAX( e1t(ji,jj) , e2t(ji,jj) ) 
    380                      zefmax = MAX( e1f(ji,jj) , e2f(ji,jj) ) 
    381                      ahmt(ji,jj,jk) = SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * r1_288 ) * zetmax * tmask(ji,jj,jk)      ! 288= 12*12 * 2 
    382                      ahmf(ji,jj,jk) = SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * r1_288 ) * zefmax * fmask(ji,jj,jk) 
     378                     zemax = MAX( e1t(ji,jj) , e2t(ji,jj) ) 
     379                     ahmt(ji,jj,jk) = SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * r1_288 ) * zemax * tmask(ji,jj,jk)      ! 288= 12*12 * 2 
     380                  END DO 
     381               END DO 
     382               DO jj = 1, jpjm1 
     383                  DO ji = 1, fs_jpim1 
     384                     zu2pv2_ij_p1 = uu(ji  ,jj+1,jk, Kbb) * uu(ji  ,jj+1,jk, Kbb) + vv(ji+1,jj  ,jk, Kbb) * vv(ji+1,jj  ,jk, Kbb) 
     385                     zu2pv2_ij    = uu(ji  ,jj  ,jk, Kbb) * uu(ji  ,jj  ,jk, Kbb) + vv(ji  ,jj  ,jk, Kbb) * vv(ji  ,jj  ,jk, Kbb) 
     386                     zemax = MAX( e1f(ji,jj) , e2f(ji,jj) ) 
     387                     ahmf(ji,jj,jk) = SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * r1_288 ) * zemax * fmask(ji,jj,jk)      ! 288= 12*12 * 2 
    383388                  END DO 
    384389               END DO 
    … …  
    388393               DO jj = 2, jpjm1 
    389394                  DO ji = fs_2, fs_jpim1 
    390                      zu2pv2_ij_p1 = uu(ji  ,jj+1,jk,Kbb) * uu(ji  ,jj+1,jk,Kbb) + vv(ji+1,jj  ,jk,Kbb) * vv(ji+1,jj  ,jk,Kbb) 
    391395                     zu2pv2_ij    = uu(ji  ,jj  ,jk,Kbb) * uu(ji  ,jj  ,jk,Kbb) + vv(ji  ,jj  ,jk,Kbb) * vv(ji  ,jj  ,jk,Kbb) 
    392396                     zu2pv2_ij_m1 = uu(ji-1,jj  ,jk,Kbb) * uu(ji-1,jj  ,jk,Kbb) + vv(ji  ,jj-1,jk,Kbb) * vv(ji  ,jj-1,jk,Kbb) 
    393                      zetmax = MAX( e1t(ji,jj) , e2t(ji,jj) ) 
    394                      zefmax = MAX( e1f(ji,jj) , e2f(ji,jj) ) 
    395                      ahmt(ji,jj,jk) = SQRT(  SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * r1_288 ) * zetmax  ) * zetmax * tmask(ji,jj,jk) 
    396                      ahmf(ji,jj,jk) = SQRT(  SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * r1_288 ) * zefmax  ) * zefmax * fmask(ji,jj,jk) 
     397                     zemax = MAX( e1t(ji,jj) , e2t(ji,jj) ) 
     398                     ahmt(ji,jj,jk) = SQRT(  SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * r1_288 ) * zemax  ) * zemax * tmask(ji,jj,jk) 
     399                  END DO 
     400               END DO 
     401               DO jj = 1, jpjm1 
     402                  DO ji = 1, fs_jpim1 
     403                     zu2pv2_ij_p1 = uu(ji  ,jj+1,jk, Kbb) * uu(ji  ,jj+1,jk, Kbb) + vv(ji+1,jj  ,jk, Kbb) * vv(ji+1,jj  ,jk, Kbb) 
     404                     zu2pv2_ij    = uu(ji  ,jj  ,jk, Kbb) * uu(ji  ,jj  ,jk, Kbb) + vv(ji  ,jj  ,jk, Kbb) * vv(ji  ,jj  ,jk, Kbb) 
     405                     zemax = MAX( e1f(ji,jj) , e2f(ji,jj) ) 
     406                     ahmf(ji,jj,jk) = SQRT(  SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * r1_288 ) * zemax  ) * zemax * fmask(ji,jj,jk) 
    397407                  END DO 
    398408               END DO 
    … …  
    407417         IF( ln_dynldf_lap .OR. ln_dynldf_blp  ) THEN        ! laplacian operator : (C_smag/pi)^2 L^2 |D| 
    408418            ! 
    409             zcmsmag = (rn_csmc/rpi)**2                                              ! (C_smag/pi)^2 
    410             zstabf_lo  = rn_minfac * rn_minfac / ( 2._wp * 4._wp * zcmsmag )        ! lower limit stability factor scaling 
    411             zstabf_up  = rn_maxfac / ( 4._wp * zcmsmag * 2._wp * rdt )              ! upper limit stability factor scaling 
     419            zcmsmag   = (rn_csmc/rpi)**2                                            ! (C_smag/pi)^2 
     420            zstabf_lo = rn_minfac * rn_minfac / ( 2._wp * 4._wp * zcmsmag )         ! lower limit stability factor scaling 
     421            zstabf_up = rn_maxfac / ( 4._wp * zcmsmag * 2._wp * rdt )               ! upper limit stability factor scaling 
    412422            IF( ln_dynldf_blp ) zstabf_lo = ( 16._wp / 9._wp ) * zstabf_lo          ! provide |U|L^3/12 lower limit instead  
    413423            !                                                                       ! of |U|L^3/16 in blp case 
    414424            DO jk = 1, jpkm1 
    415425               ! 
    416                DO jj = 2, jpj 
    417                   DO ji = 2, jpi 
    418                      zdb = ( ( uu(ji,jj,jk,Kbb) * r1_e2u(ji,jj) -  uu(ji-1,jj,jk,Kbb) * r1_e2u(ji-1,jj) )  & 
    419                           &                  * r1_e1t(ji,jj) * e2t(ji,jj)                           & 
     426               DO jj = 2, jpjm1 
     427                  DO ji = 2, jpim1 
     428                     zdb =    ( uu(ji,jj,jk,Kbb) * r1_e2u(ji,jj) -  uu(ji-1,jj,jk,Kbb) * r1_e2u(ji-1,jj) )  & 
     429                          &                      * r1_e1t(ji,jj) * e2t(ji,jj)                           & 
    420430                          & - ( vv(ji,jj,jk,Kbb) * r1_e1v(ji,jj) -  vv(ji,jj-1,jk,Kbb) * r1_e1v(ji,jj-1) )  & 
    421                           &                  * r1_e2t(ji,jj) * e1t(ji,jj)    ) * tmask(ji,jj,jk) 
    422                      dtensq(ji,jj) = zdb * zdb 
     431                          &                      * r1_e2t(ji,jj) * e1t(ji,jj) 
     432                     dtensq(ji,jj,jk) = zdb * zdb * tmask(ji,jj,jk) 
    423433                  END DO 
    424434               END DO 
    … …  
    426436               DO jj = 1, jpjm1 
    427437                  DO ji = 1, jpim1 
    428                      zdb = ( (  uu(ji,jj+1,jk,Kbb) * r1_e1u(ji,jj+1) -  uu(ji,jj,jk,Kbb) * r1_e1u(ji,jj) )  & 
    429                           &                    * r1_e2f(ji,jj)   * e1f(ji,jj)                       & 
     438                     zdb =   (  uu(ji,jj+1,jk,Kbb) * r1_e1u(ji,jj+1) -  uu(ji,jj,jk,Kbb) * r1_e1u(ji,jj) )  & 
     439                          &                        * r1_e2f(ji,jj)   * e1f(ji,jj)                       & 
    430440                          & + ( vv(ji+1,jj,jk,Kbb) * r1_e2v(ji+1,jj) -  vv(ji,jj,jk,Kbb) * r1_e2v(ji,jj) )  & 
    431                           &                    * r1_e1f(ji,jj)   * e2f(ji,jj)  ) * fmask(ji,jj,jk) 
    432                      dshesq(ji,jj) = zdb * zdb 
     441                          &                        * r1_e1f(ji,jj)   * e2f(ji,jj) 
     442                     dshesq(ji,jj,jk) = zdb * zdb * fmask(ji,jj,jk) 
    433443                  END DO 
    434444               END DO 
    435445               ! 
    436                DO jj = 2, jpjm1 
     446            END DO 
     447            ! 
     448            CALL lbc_lnk_multi( 'ldfdyn', dtensq, 'T', 1. )  ! lbc_lnk on dshesq not needed 
     449            ! 
     450            DO jk = 1, jpkm1 
     451              ! 
     452               DO jj = 2, jpjm1                                ! T-point value 
    437453                  DO ji = fs_2, fs_jpim1 
    438454                     ! 
    439                      zu2pv2_ij_p1 = uu(ji  ,jj+1,jk,Kbb) * uu(ji  ,jj+1,jk,Kbb) + vv(ji+1,jj  ,jk,Kbb) * vv(ji+1,jj  ,jk,Kbb) 
    440455                     zu2pv2_ij    = uu(ji  ,jj  ,jk,Kbb) * uu(ji  ,jj  ,jk,Kbb) + vv(ji  ,jj  ,jk,Kbb) * vv(ji  ,jj  ,jk,Kbb) 
    441456                     zu2pv2_ij_m1 = uu(ji-1,jj  ,jk,Kbb) * uu(ji-1,jj  ,jk,Kbb) + vv(ji  ,jj-1,jk,Kbb) * vv(ji  ,jj-1,jk,Kbb) 
    442                                                      ! T-point value 
     457                     ! 
    443458                     zdelta         = zcmsmag * esqt(ji,jj)                                        ! L^2 * (C_smag/pi)^2 
    444                      ahmt(ji,jj,jk) = zdelta * sqrt(          dtensq(ji,jj)   +                        & 
    445                                      &               r1_4 * ( dshesq(ji,jj)   + dshesq(ji,jj-1)   +    & 
    446                                      &                        dshesq(ji-1,jj) + dshesq(ji-1,jj-1) ) ) 
    447                      ahmt(ji,jj,jk) =   MAX( ahmt(ji,jj,jk),   & 
    448                                      &   SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * zdelta * zstabf_lo ) ) ! Impose lower limit == minfac  * |U|L/2 
    449                      ahmt(ji,jj,jk) = MIN( ahmt(ji,jj,jk), zdelta * zstabf_up )                    ! Impose upper limit == maxfac  * L^2/(4*2dt) 
    450                                                      ! F-point value 
     459                     ahmt(ji,jj,jk) = zdelta * SQRT(          dtensq(ji  ,jj,jk) +                         & 
     460                        &                            r1_4 * ( dshesq(ji  ,jj,jk) + dshesq(ji  ,jj-1,jk) +  & 
     461                        &                                     dshesq(ji-1,jj,jk) + dshesq(ji-1,jj-1,jk) ) ) 
     462                     ahmt(ji,jj,jk) = MAX( ahmt(ji,jj,jk), SQRT( (zu2pv2_ij + zu2pv2_ij_m1) * zdelta * zstabf_lo ) ) ! Impose lower limit == minfac  * |U|L/2 
     463                     ahmt(ji,jj,jk) = MIN( ahmt(ji,jj,jk),                                    zdelta * zstabf_up )   ! Impose upper limit == maxfac  * L^2/(4*2dt) 
     464                     ! 
     465                  END DO 
     466               END DO 
     467               ! 
     468               DO jj = 1, jpjm1                                ! F-point value 
     469                  DO ji = 1, fs_jpim1 
     470                     ! 
     471                     zu2pv2_ij_p1 = uu(ji  ,jj+1,jk, kbb) * uu(ji  ,jj+1,jk, kbb) + vv(ji+1,jj  ,jk, kbb) * vv(ji+1,jj  ,jk, kbb) 
     472                     zu2pv2_ij    = uu(ji  ,jj  ,jk, kbb) * uu(ji  ,jj  ,jk, kbb) + vv(ji  ,jj  ,jk, kbb) * vv(ji  ,jj  ,jk, kbb) 
     473                     ! 
    451474                     zdelta         = zcmsmag * esqf(ji,jj)                                        ! L^2 * (C_smag/pi)^2 
    452                      ahmf(ji,jj,jk) = zdelta * sqrt(          dshesq(ji,jj)   +                        & 
    453                                      &               r1_4 * ( dtensq(ji,jj)   + dtensq(ji,jj+1)   +    & 
    454                                      &                        dtensq(ji+1,jj) + dtensq(ji+1,jj+1) ) ) 
    455                      ahmf(ji,jj,jk) =   MAX( ahmf(ji,jj,jk),   & 
    456                                      &   SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * zdelta * zstabf_lo ) ) ! Impose lower limit == minfac  * |U|L/2 
    457                      ahmf(ji,jj,jk) = MIN( ahmf(ji,jj,jk), zdelta * zstabf_up )                    ! Impose upper limit == maxfac  * L^2/(4*2dt) 
     475                     ahmf(ji,jj,jk) = zdelta * SQRT(          dshesq(ji  ,jj,jk) +                         & 
     476                        &                            r1_4 * ( dtensq(ji  ,jj,jk) + dtensq(ji  ,jj+1,jk) +  & 
     477                        &                                     dtensq(ji+1,jj,jk) + dtensq(ji+1,jj+1,jk) ) ) 
     478                     ahmf(ji,jj,jk) = MAX( ahmf(ji,jj,jk), SQRT( (zu2pv2_ij + zu2pv2_ij_p1) * zdelta * zstabf_lo ) ) ! Impose lower limit == minfac  * |U|L/2 
     479                     ahmf(ji,jj,jk) = MIN( ahmf(ji,jj,jk),                                    zdelta * zstabf_up )   ! Impose upper limit == maxfac  * L^2/(4*2dt) 
    458480                     ! 
    459481                  END DO 
    460482               END DO 
     483               ! 
    461484            END DO 
    462485            ! 
    … …  
    471494                  DO ji = fs_2, fs_jpim1 
    472495                     ahmt(ji,jj,jk) = SQRT( r1_8 * esqt(ji,jj) * ahmt(ji,jj,jk) ) 
     496                  END DO 
     497               END DO 
     498               DO jj = 1, jpjm1 
     499                  DO ji = 1, fs_jpim1 
    473500                     ahmf(ji,jj,jk) = SQRT( r1_8 * esqf(ji,jj) * ahmf(ji,jj,jk) ) 
    474501                  END DO 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/LDF/ldftra.F90

    r10946 r11822  
    154154      REWIND( numnam_ref )              ! Namelist namtra_ldf in reference namelist : Lateral physics on tracers 
    155155      READ  ( numnam_ref, namtra_ldf, IOSTAT = ios, ERR = 901) 
    156 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_ldf in reference namelist', lwp ) 
     156901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_ldf in reference namelist' ) 
    157157      REWIND( numnam_cfg )              ! Namelist namtra_ldf in configuration namelist : Lateral physics on tracers 
    158158      READ  ( numnam_cfg, namtra_ldf, IOSTAT = ios, ERR = 902 ) 
    159 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_ldf in configuration namelist', lwp ) 
     159902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_ldf in configuration namelist' ) 
    160160      IF(lwm) WRITE( numond, namtra_ldf ) 
    161161      ! 
    … …  
    513513      REWIND( numnam_ref )              ! Namelist namtra_eiv in reference namelist : eddy induced velocity param. 
    514514      READ  ( numnam_ref, namtra_eiv, IOSTAT = ios, ERR = 901) 
    515 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_eiv in reference namelist', lwp ) 
     515901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_eiv in reference namelist' ) 
    516516      ! 
    517517      REWIND( numnam_cfg )              ! Namelist namtra_eiv in configuration namelist : eddy induced velocity param. 
    518518      READ  ( numnam_cfg, namtra_eiv, IOSTAT = ios, ERR = 902 ) 
    519 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_eiv in configuration namelist', lwp ) 
     519902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_eiv in configuration namelist' ) 
    520520      IF(lwm)  WRITE ( numond, namtra_eiv ) 
    521521 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/OBS/diaobs.F90

    r11027 r11822  
    204204      REWIND( numnam_ref )   ! Namelist namobs in reference namelist 
    205205      READ  ( numnam_ref, namobs, IOSTAT = ios, ERR = 901) 
    206 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namobs in reference namelist', lwp ) 
     206901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namobs in reference namelist' ) 
    207207      REWIND( numnam_cfg )   ! Namelist namobs in configuration namelist 
    208208      READ  ( numnam_cfg, namobs, IOSTAT = ios, ERR = 902 ) 
    209 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namobs in configuration namelist', lwp ) 
     209902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namobs in configuration namelist' ) 
    210210      IF(lwm) WRITE ( numond, namobs ) 
    211211 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/SBC/fldread.F90

    r11480 r11822  
    4646   PUBLIC   fld_clopn 
    4747 
    48    INTEGER :: nfld_Nnn = 1 
    4948   TYPE, PUBLIC ::   FLD_N      !: Namelist field informations 
    5049      CHARACTER(len = 256) ::   clname      ! generic name of the NetCDF flux file 
    51       REAL(wp)             ::   nfreqh      ! frequency of each flux file 
     50      REAL(wp)             ::   freqh       ! frequency of each flux file 
    5251      CHARACTER(len = 34)  ::   clvar       ! generic name of the variable in the NetCDF flux file 
    5352      LOGICAL              ::   ln_tint     ! time interpolation or not (T/F) 
    … …  
    6564      CHARACTER(len = 256)            ::   clrootname   ! generic name of the NetCDF file 
    6665      CHARACTER(len = 256)            ::   clname       ! current name of the NetCDF file 
    67       REAL(wp)                        ::   nfreqh       ! frequency of each flux file 
     66      REAL(wp)                        ::   freqh        ! frequency of each flux file 
    6867      CHARACTER(len = 34)             ::   clvar        ! generic name of the variable in the NetCDF flux file 
    6968      LOGICAL                         ::   ln_tint      ! time interpolation or not (T/F) 
    … …  
    8180      INTEGER                         ::   nreclast     ! last record to be read in the current file 
    8281      CHARACTER(len = 256)            ::   lsmname      ! current name of the NetCDF mask file acting as a key 
    83       INTEGER                         ::   igrd         ! grid type for bdy data 
    84       INTEGER                         ::   ibdy         ! bdy set id number 
     82      !                                                 !  
     83      !                                                 ! Variables related to BDY 
     84      INTEGER                         ::   igrd         !   grid type for bdy data 
     85      INTEGER                         ::   ibdy         !   bdy set id number 
     86      INTEGER, POINTER, DIMENSION(:)  ::   imap         !   Array of integer pointers to 1D arrays 
     87      LOGICAL                         ::   ltotvel      !   total velocity or not (T/F) 
     88      LOGICAL                         ::   lzint        !   T if it requires a vertical interpolation 
    8589   END TYPE FLD 
    86  
    87    TYPE, PUBLIC ::   MAP_POINTER      !: Map from input data file to local domain 
    88       INTEGER, POINTER, DIMENSION(:)  ::  ptr           ! Array of integer pointers to 1D arrays 
    89       LOGICAL                         ::  ll_unstruc    ! Unstructured (T) or structured (F) boundary data file 
    90    END TYPE MAP_POINTER 
    9190 
    9291!$AGRIF_DO_NOT_TREAT 
    … …  
    130129CONTAINS 
    131130 
    132    SUBROUTINE fld_read( kt, kn_fsbc, sd, map, kit, kt_offset, jpk_bdy, fvl, Kmm ) 
     131   SUBROUTINE fld_read( kt, kn_fsbc, sd, kit, kt_offset, Kmm ) 
    133132      !!--------------------------------------------------------------------- 
    134133      !!                    ***  ROUTINE fld_read  *** 
    … …  
    145144      INTEGER  , INTENT(in   )               ::   kn_fsbc   ! sbc computation period (in time step)  
    146145      TYPE(FLD), INTENT(inout), DIMENSION(:) ::   sd        ! input field related variables 
    147       TYPE(MAP_POINTER),INTENT(in), OPTIONAL, DIMENSION(:) ::   map   ! global-to-local mapping indices 
    148146      INTEGER  , INTENT(in   ), OPTIONAL     ::   kit       ! subcycle timestep for timesplitting option 
    149147      INTEGER  , INTENT(in   ), OPTIONAL     ::   kt_offset ! provide fields at time other than "now" 
    … …  
    151149      !                                                     !   kt_offset = +1 => fields at "after"  time level 
    152150      !                                                     !   etc. 
    153       INTEGER  , INTENT(in   ), OPTIONAL     ::   jpk_bdy   ! number of vertical levels in the BDY data 
    154       LOGICAL  , INTENT(in   ), OPTIONAL     ::   fvl   ! number of vertical levels in the BDY data 
    155151      INTEGER  , INTENT(in   ), OPTIONAL     ::   Kmm   ! ocean time level index 
    156152      !! 
    … …  
    168164      REAL(wp) ::   ztintb       ! ratio applied to before records when doing time interpolation 
    169165      CHARACTER(LEN=1000) ::   clfmt  ! write format 
    170       TYPE(MAP_POINTER)   ::   imap   ! global-to-local mapping indices 
    171166      !!--------------------------------------------------------------------- 
    172167      ll_firstcall = kt == nit000 
    … …  
    177172      ENDIF 
    178173      IF( PRESENT(kt_offset) )   it_offset = kt_offset 
    179  
    180       imap%ptr => NULL() 
    181174 
    182175      ! Note that shifting time to be centrered in the middle of sbc time step impacts only nsec_* variables of the calendar  
    … …  
    190183      IF( ll_firstcall ) THEN                      ! initialization 
    191184         DO jf = 1, imf  
    192             IF( PRESENT(map) ) imap = map(jf) 
    193                IF( PRESENT(jpk_bdy) ) THEN 
    194                   CALL fld_init( kn_fsbc, sd(jf), imap, jpk_bdy, fvl )  ! read each before field (put them in after as they will be swapped) 
    195                ELSE 
    196                   CALL fld_init( kn_fsbc, sd(jf), imap )  ! read each before field (put them in after as they will be swapped) 
    197                ENDIF 
     185            IF( TRIM(sd(jf)%clrootname) == 'NOT USED' )   CYCLE 
     186            CALL fld_init( kn_fsbc, sd(jf) )       ! read each before field (put them in after as they will be swapped) 
    198187         END DO 
    199188         IF( lwp ) CALL wgt_print()                ! control print 
    … …  
    204193         ! 
    205194         DO jf = 1, imf                            ! ---   loop over field   --- ! 
    206              
     195 
     196            IF( TRIM(sd(jf)%clrootname) == 'NOT USED' )   CYCLE 
     197                       
    207198            IF( isecsbc > sd(jf)%nrec_a(2) .OR. ll_firstcall ) THEN    ! read/update the after data? 
    208  
    209                IF( PRESENT(map) )   imap = map(jf)   ! temporary definition of map 
    210199 
    211200               sd(jf)%nrec_b(:) = sd(jf)%nrec_a(:)                                  ! swap before record informations 
    … …  
    215204               CALL fld_rec( kn_fsbc, sd(jf), kt_offset = it_offset, kit = kit )    ! update after record informations 
    216205 
    217                ! if kn_fsbc*rdt is larger than nfreqh (which is kind of odd), 
     206               ! if kn_fsbc*rdt is larger than freqh (which is kind of odd), 
    218207               ! it is possible that the before value is no more the good one... we have to re-read it 
    219208               ! if before is not the last record of the file currently opened and after is the first record to be read 
    … …  
    224213                  itmp = sd(jf)%nrec_a(1)                       ! temporary storage 
    225214                  sd(jf)%nrec_a(1) = sd(jf)%nreclast            ! read the last record of the file currently opened 
    226                   CALL fld_get( sd(jf), imap )                  ! read after data 
     215                  CALL fld_get( sd(jf) )                        ! read after data 
    227216                  sd(jf)%fdta(:,:,:,1) = sd(jf)%fdta(:,:,:,2)   ! re-swap before record field 
    228217                  sd(jf)%nrec_b(1) = sd(jf)%nrec_a(1)           ! update before record informations 
    229                   sd(jf)%nrec_b(2) = sd(jf)%nrec_a(2) - NINT( sd(jf)%nfreqh * 3600 )  ! assume freq to be in hours in this case 
     218                  sd(jf)%nrec_b(2) = sd(jf)%nrec_a(2) - NINT( sd(jf)%freqh * 3600. )  ! assume freq to be in hours in this case 
    230219                  sd(jf)%rotn(1)   = sd(jf)%rotn(2)             ! update before rotate informations 
    231220                  sd(jf)%nrec_a(1) = itmp                       ! move back to after record  
    … …  
    236225               IF( sd(jf)%ln_tint ) THEN 
    237226                   
    238                   ! if kn_fsbc*rdt is larger than nfreqh (which is kind of odd), 
     227                  ! if kn_fsbc*rdt is larger than freqh (which is kind of odd), 
    239228                  ! it is possible that the before value is no more the good one... we have to re-read it 
    240229                  ! if before record is not just just before the after record... 
    … …  
    242231                     &                   .AND. sd(jf)%nrec_b(1) /= sd(jf)%nrec_a(1) - 1 ) THEN    
    243232                     sd(jf)%nrec_a(1) = sd(jf)%nrec_a(1) - 1       ! move back to before record 
    244                      CALL fld_get( sd(jf), imap )                  ! read after data 
     233                     CALL fld_get( sd(jf) )                        ! read after data 
    245234                     sd(jf)%fdta(:,:,:,1) = sd(jf)%fdta(:,:,:,2)   ! re-swap before record field 
    246235                     sd(jf)%nrec_b(1) = sd(jf)%nrec_a(1)           ! update before record informations 
    247                      sd(jf)%nrec_b(2) = sd(jf)%nrec_a(2) - NINT( sd(jf)%nfreqh * 3600 )  ! assume freq to be in hours in this case 
     236                     sd(jf)%nrec_b(2) = sd(jf)%nrec_a(2) - NINT( sd(jf)%freqh * 3600. )  ! assume freq to be in hours in this case 
    248237                     sd(jf)%rotn(1)   = sd(jf)%rotn(2)             ! update before rotate informations 
    249238                     sd(jf)%nrec_a(1) = sd(jf)%nrec_a(1) + 1       ! move back to after record 
    … …  
    270259                     ! year/month/week/day, next year/month/week/day file must exist 
    271260                     isecend = nsec_year + nsec1jan000 + (nitend - kt) * NINT(rdt)   ! second at the end of the run 
    272                      llstop = isecend > sd(jf)%nrec_a(2)                                   ! read more than 1 record of next year 
     261                     llstop = isecend > sd(jf)%nrec_a(2)                             ! read more than 1 record of next year 
    273262                     ! we suppose that the date of next file is next day (should be ok even for weekly files...) 
    274263                     CALL fld_clopn( sd(jf), nyear  + COUNT((/llnxtyr /))                                           ,         & 
    … …  
    279268                        CALL ctl_warn('next year/month/week/day file: '//TRIM(sd(jf)%clname)//     & 
    280269                           &     ' not present -> back to current year/month/day') 
    281                         CALL fld_clopn( sd(jf) )       ! back to the current year/month/day 
     270                        CALL fld_clopn( sd(jf) )               ! back to the current year/month/day 
    282271                        sd(jf)%nrec_a(1) = sd(jf)%nreclast     ! force to read the last record in the current year file 
    283272                     ENDIF 
    … …  
    287276                   
    288277               ! read after data 
    289                IF( PRESENT(jpk_bdy) ) THEN 
    290                   CALL fld_get( sd(jf), imap, jpk_bdy, fvl, Kmm ) 
    291                ELSE 
    292                   CALL fld_get( sd(jf), imap ) 
    293                ENDIF 
     278 
     279               CALL fld_get( sd(jf), Kmm ) 
     280                
    294281            ENDIF   ! read new data? 
    295282         END DO                                    ! --- end loop over field --- ! 
    … …  
    298285 
    299286         DO jf = 1, imf                            ! ---   loop over field   --- ! 
     287            ! 
     288            IF( TRIM(sd(jf)%clrootname) == 'NOT USED' )   CYCLE 
    300289            ! 
    301290            IF( sd(jf)%ln_tint ) THEN              ! temporal interpolation 
    … …  
    329318 
    330319 
    331    SUBROUTINE fld_init( kn_fsbc, sdjf, map , jpk_bdy, fvl) 
     320   SUBROUTINE fld_init( kn_fsbc, sdjf ) 
    332321      !!--------------------------------------------------------------------- 
    333322      !!                    ***  ROUTINE fld_init  *** 
    … …  
    338327      INTEGER  , INTENT(in   ) ::   kn_fsbc      ! sbc computation period (in time step)  
    339328      TYPE(FLD), INTENT(inout) ::   sdjf         ! input field related variables 
    340       TYPE(MAP_POINTER),INTENT(in) ::   map      ! global-to-local mapping indices 
    341       INTEGER  , INTENT(in), OPTIONAL :: jpk_bdy ! number of vertical levels in the BDY data 
    342       LOGICAL  , INTENT(in), OPTIONAL :: fvl     ! number of vertical levels in the BDY data 
    343329      !! 
    344330      LOGICAL :: llprevyr              ! are we reading previous year  file? 
    … …  
    353339      CHARACTER(LEN=1000) ::   clfmt   ! write format 
    354340      !!--------------------------------------------------------------------- 
     341      ! 
    355342      llprevyr   = .FALSE. 
    356343      llprevmth  = .FALSE. 
    … …  
    367354         ! 
    368355         IF( sdjf%nrec_a(1) == 0  ) THEN   ! we redefine record sdjf%nrec_a(1) with the last record of previous year file 
    369             IF    ( sdjf%nfreqh == -12 ) THEN   ! yearly mean 
     356            IF    ( NINT(sdjf%freqh) == -12 ) THEN   ! yearly mean 
    370357               IF( sdjf%cltype == 'yearly' ) THEN             ! yearly file 
    371358                  sdjf%nrec_a(1) = 1                                                       ! force to read the unique record 
    … …  
    374361                  CALL ctl_stop( "fld_init: yearly mean file must be in a yearly type of file: "//TRIM(sdjf%clrootname) ) 
    375362               ENDIF 
    376             ELSEIF( sdjf%nfreqh ==  -1 ) THEN   ! monthly mean 
     363            ELSEIF( NINT(sdjf%freqh) ==  -1 ) THEN   ! monthly mean 
    377364               IF( sdjf%cltype == 'monthly' ) THEN            ! monthly file 
    378365                  sdjf%nrec_a(1) = 1                                                       ! force to read the unique record 
    … …  
    383370                  llprevyr = .NOT. sdjf%ln_clim                                            ! use previous year  file? 
    384371               ENDIF 
    385             ELSE                                ! higher frequency mean (in hours)  
     372            ELSE                                     ! higher frequency mean (in hours)  
    386373               IF    ( sdjf%cltype      == 'monthly' ) THEN   ! monthly file 
    387                   sdjf%nrec_a(1) = NINT( 24 * nmonth_len(nmonth-1) / sdjf%nfreqh )         ! last record of previous month 
     374                  sdjf%nrec_a(1) = NINT( 24. * REAL(nmonth_len(nmonth-1),wp) / sdjf%freqh )! last record of previous month 
    388375                  llprevmth = .TRUE.                                                       ! use previous month file? 
    389376                  llprevyr  = llprevmth .AND. nmonth == 1                                  ! use previous year  file? 
    390377               ELSEIF( sdjf%cltype(1:4) == 'week'    ) THEN   ! weekly file 
    391378                  llprevweek = .TRUE.                                                      ! use previous week  file? 
    392                   sdjf%nrec_a(1) = NINT( 24 * 7 / sdjf%nfreqh )                            ! last record of previous week 
     379                  sdjf%nrec_a(1) = NINT( 24. * 7. / sdjf%freqh )                           ! last record of previous week 
    393380                  isec_week = NINT(rday) * 7                                               ! add a shift toward previous week 
    394381               ELSEIF( sdjf%cltype      == 'daily'   ) THEN   ! daily file 
    395                   sdjf%nrec_a(1) = NINT( 24 / sdjf%nfreqh )                                ! last record of previous day 
     382                  sdjf%nrec_a(1) = NINT( 24. / sdjf%freqh )                                ! last record of previous day 
    396383                  llprevday = .TRUE.                                                       ! use previous day   file? 
    397384                  llprevmth = llprevday .AND. nday   == 1                                  ! use previous month file? 
    398385                  llprevyr  = llprevmth .AND. nmonth == 1                                  ! use previous year  file? 
    399386               ELSE                                           ! yearly file 
    400                   sdjf%nrec_a(1) = NINT( 24 * nyear_len(0) / sdjf%nfreqh )                 ! last record of previous year  
     387                  sdjf%nrec_a(1) = NINT( 24. * REAL(nyear_len(0),wp) / sdjf%freqh )        ! last record of previous year  
    401388                  llprevyr = .NOT. sdjf%ln_clim                                            ! use previous year  file? 
    402389               ENDIF 
    … …  
    435422         ! 
    436423         ! read before data in after arrays(as we will swap it later) 
    437          IF( PRESENT(jpk_bdy) ) THEN 
    438             CALL fld_get( sdjf, map, jpk_bdy, fvl ) 
    439          ELSE 
    440             CALL fld_get( sdjf, map ) 
    441          ENDIF 
     424         CALL fld_get( sdjf ) 
    442425         ! 
    443426         clfmt = "('   fld_init : time-interpolation for ', a, ' read previous record = ', i6, ' at time = ', f7.2, ' days')" 
    … …  
    458441      !!              if sdjf%ln_tint = .FALSE. 
    459442      !!                  nrec_a(1): record number 
    460       !!                  nrec_b(2) and nrec_a(2): time of the beginning and end of the record (for print only) 
     443      !!                  nrec_b(2) and nrec_a(2): time of the beginning and end of the record 
    461444      !!---------------------------------------------------------------------- 
    462445      INTEGER  , INTENT(in   )           ::   kn_fsbc   ! sbc computation period (in time step)  
    … …  
    486469      ELSE                                      ;   it_offset = 0 
    487470      ENDIF 
    488       IF( PRESENT(kt_offset) )   it_offset = kt_offset 
     471      IF( PRESENT(kt_offset) )      it_offset = kt_offset 
    489472      IF( PRESENT(kit) ) THEN   ;   it_offset = ( kit + it_offset ) * NINT( rdt/REAL(nn_baro,wp) ) 
    490473      ELSE                      ;   it_offset =         it_offset   * NINT(       rdt            ) 
    491474      ENDIF 
    492475      ! 
    493       !                                      ! =========== ! 
    494       IF    ( sdjf%nfreqh == -12 ) THEN      ! yearly mean 
    495          !                                   ! =========== ! 
    496          ! 
    497          IF( sdjf%ln_tint ) THEN                 ! time interpolation, shift by 1/2 record 
     476      !                                           ! =========== ! 
     477      IF    ( NINT(sdjf%freqh) == -12 ) THEN      ! yearly mean 
     478         !                                        ! =========== ! 
     479         ! 
     480         IF( sdjf%ln_tint ) THEN                  ! time interpolation, shift by 1/2 record 
    498481            ! 
    499482            !                  INT( ztmp ) 
    … …  
    507490            !       forcing record :    1  
    508491            !                             
    509             ztmp = REAL( nsec_year, wp ) / ( REAL( nyear_len(1), wp ) * rday ) + 0.5 & 
    510            &       + REAL( it_offset, wp ) / ( REAL( nyear_len(1), wp ) * rday ) 
     492            ztmp =  REAL( nsec_year, wp ) / ( REAL( nyear_len(1), wp ) * rday ) + 0.5 & 
     493               &  + REAL( it_offset, wp ) / ( REAL( nyear_len(1), wp ) * rday ) 
    511494            sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/)) 
    512495            ! swap at the middle of the year 
    … …  
    516499                                    & INT(ztmp) * INT(rday) * nyear_len(1) + INT(ztmp) * NINT( 0.5 * rday) * nyear_len(2)  
    517500            ENDIF 
    518          ELSE                                    ! no time interpolation 
     501         ELSE                                     ! no time interpolation 
    519502            sdjf%nrec_a(1) = 1 
    520503            sdjf%nrec_a(2) = NINT(rday) * nyear_len(1) + nsec1jan000   ! swap at the end    of the year 
    … …  
    522505         ENDIF 
    523506         ! 
    524          !                                   ! ============ ! 
    525       ELSEIF( sdjf%nfreqh ==  -1 ) THEN      ! monthly mean ! 
    526          !                                   ! ============ ! 
    527          ! 
    528          IF( sdjf%ln_tint ) THEN                 ! time interpolation, shift by 1/2 record 
     507         !                                        ! ============ ! 
     508      ELSEIF( NINT(sdjf%freqh) ==  -1 ) THEN      ! monthly mean ! 
     509         !                                        ! ============ ! 
     510         ! 
     511         IF( sdjf%ln_tint ) THEN                  ! time interpolation, shift by 1/2 record 
    529512            ! 
    530513            !                  INT( ztmp ) 
    … …  
    538521            !       forcing record :  nmonth  
    539522            !                             
    540             ztmp = REAL( nsec_month, wp ) / ( REAL( nmonth_len(nmonth), wp ) * rday ) + 0.5 & 
    541            &       + REAL( it_offset, wp ) / ( REAL( nmonth_len(nmonth), wp ) * rday ) 
     523            ztmp =  REAL( nsec_month, wp ) / ( REAL( nmonth_len(nmonth), wp ) * rday ) + 0.5 & 
     524           &      + REAL( it_offset, wp ) / ( REAL( nmonth_len(nmonth), wp ) * rday ) 
    542525            imth = nmonth + INT( ztmp ) - COUNT((/llbefore/)) 
    543526            IF( sdjf%cltype == 'monthly' ) THEN   ;   sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/)) 
    … …  
    553536         ENDIF 
    554537         ! 
    555          !                                   ! ================================ ! 
    556       ELSE                                   ! higher frequency mean (in hours) 
    557          !                                   ! ================================ ! 
    558          ! 
    559          ifreq_sec = NINT( sdjf%nfreqh * 3600 )                                         ! frequency mean (in seconds) 
     538         !                                        ! ================================ ! 
     539      ELSE                                        ! higher frequency mean (in hours) 
     540         !                                        ! ================================ ! 
     541         ! 
     542         ifreq_sec = NINT( sdjf%freqh * 3600. )                                         ! frequency mean (in seconds) 
    560543         IF( sdjf%cltype(1:4) == 'week' )   isec_week = ksec_week( sdjf%cltype(6:8) )   ! since the first day of the current week 
    561544         ! number of second since the beginning of the file 
    … …  
    567550         ztmp = ztmp + 0.5 * REAL(kn_fsbc - 1, wp) * rdt + REAL( it_offset, wp )        ! centrered in the middle of sbc time step 
    568551         ztmp = ztmp + 0.01 * rdt                                                       ! avoid truncation error  
    569          IF( sdjf%ln_tint ) THEN                ! time interpolation, shift by 1/2 record 
     552         IF( sdjf%ln_tint ) THEN                 ! time interpolation, shift by 1/2 record 
    570553            ! 
    571554            !          INT( ztmp/ifreq_sec + 0.5 ) 
    … …  
    581564            !                    
    582565            ztmp= ztmp / REAL(ifreq_sec, wp) + 0.5 
    583          ELSE                                   ! no time interpolation 
     566         ELSE                                    ! no time interpolation 
    584567            ! 
    585568            !           INT( ztmp/ifreq_sec ) 
    … …  
    612595      ENDIF 
    613596      ! 
     597      IF( .NOT. sdjf%ln_tint ) sdjf%nrec_a(2) = sdjf%nrec_a(2) - 1   ! last second belongs to bext record : *----( 
     598      ! 
    614599   END SUBROUTINE fld_rec 
    615600 
    616601 
    617    SUBROUTINE fld_get( sdjf, map, jpk_bdy, fvl, Kmm ) 
     602   SUBROUTINE fld_get( sdjf, Kmm ) 
    618603      !!--------------------------------------------------------------------- 
    619604      !!                    ***  ROUTINE fld_get  *** 
    … …  
    622607      !!---------------------------------------------------------------------- 
    623608      TYPE(FLD)        , INTENT(inout) ::   sdjf   ! input field related variables 
    624       TYPE(MAP_POINTER), INTENT(in   ) ::   map    ! global-to-local mapping indices 
    625       INTEGER  , INTENT(in), OPTIONAL  ::   jpk_bdy ! number of vertical levels in the bdy data 
    626       LOGICAL  , INTENT(in), OPTIONAL  ::   fvl     ! number of vertical levels in the bdy data 
    627609      INTEGER  , INTENT(in), OPTIONAL  ::   Kmm     ! ocean time level index 
    628610      ! 
    … …  
    637619      ipk = SIZE( sdjf%fnow, 3 ) 
    638620      ! 
    639       IF( ASSOCIATED(map%ptr) ) THEN 
    640          IF( PRESENT(jpk_bdy) ) THEN 
    641             IF( sdjf%ln_tint ) THEN   ;   CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2),                & 
    642                                                         sdjf%nrec_a(1), map, sdjf%igrd, sdjf%ibdy, jpk_bdy, fvl, Kmm ) 
    643             ELSE                      ;   CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,:  ),                & 
    644                                                         sdjf%nrec_a(1), map, sdjf%igrd, sdjf%ibdy, jpk_bdy, fvl, Kmm ) 
    645             ENDIF 
    646          ELSE 
    647             IF( sdjf%ln_tint ) THEN   ;   CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), map ) 
    648             ELSE                      ;   CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,:  ), sdjf%nrec_a(1), map ) 
    649             ENDIF 
    650          ENDIF         
     621      IF( ASSOCIATED(sdjf%imap) ) THEN 
     622         IF( sdjf%ln_tint ) THEN   ;   CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1),   & 
     623            &                                        sdjf%imap, sdjf%igrd, sdjf%ibdy, sdjf%ltotvel, sdjf%lzint ) 
     624         ELSE                      ;   CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,:  ), sdjf%nrec_a(1),   & 
     625            &                                        sdjf%imap, sdjf%igrd, sdjf%ibdy, sdjf%ltotvel, sdjf%lzint ) 
     626         ENDIF 
    651627      ELSE IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN 
    652628         CALL wgt_list( sdjf, iw ) 
    … …  
    703679   END SUBROUTINE fld_get 
    704680 
    705    SUBROUTINE fld_map( num, clvar, dta, nrec, map, igrd, ibdy, jpk_bdy, fvl, Kmm ) 
     681   SUBROUTINE fld_map( knum, cdvar, pdta, krec, kmap, kgrd, kbdy, ldtotvel, ldzint, Kmm ) 
    706682      !!--------------------------------------------------------------------- 
    707683      !!                    ***  ROUTINE fld_map  *** 
    … …  
    710686      !!                using a general mapping (for open boundaries) 
    711687      !!---------------------------------------------------------------------- 
    712  
    713       USE bdy_oce, ONLY: ln_bdy, idx_bdy, dta_global, dta_global_z, dta_global_dz, dta_global2, dta_global2_z, dta_global2_dz                 ! workspace to read in global data arrays 
    714  
    715       INTEGER                   , INTENT(in ) ::   num     ! stream number 
    716       CHARACTER(LEN=*)          , INTENT(in ) ::   clvar   ! variable name 
    717       REAL(wp), DIMENSION(:,:,:), INTENT(out) ::   dta     ! output field on model grid (2 dimensional) 
    718       INTEGER                   , INTENT(in ) ::   nrec    ! record number to read (ie time slice) 
    719       TYPE(MAP_POINTER)         , INTENT(in ) ::   map     ! global-to-local mapping indices 
    720       INTEGER  , INTENT(in), OPTIONAL         ::   igrd, ibdy, jpk_bdy  ! grid type, set number and number of vertical levels in the bdy data 
    721       LOGICAL  , INTENT(in), OPTIONAL         ::   fvl     ! grid type, set number and number of vertical levels in the bdy data 
    722       INTEGER  , INTENT(in), OPTIONAL         ::   Kmm     ! ocean time level index  
    723       INTEGER                                 ::   jpkm1_bdy! number of vertical levels in the bdy data minus 1 
    724       !! 
    725       INTEGER                                 ::   ipi      ! length of boundary data on local process 
    726       INTEGER                                 ::   ipj      ! length of dummy dimension ( = 1 ) 
    727       INTEGER                                 ::   ipk      ! number of vertical levels of dta ( 2D: ipk=1 ; 3D: ipk=jpk ) 
    728       INTEGER                                 ::   ilendta  ! length of data in file 
    729       INTEGER                                 ::   idvar    ! variable ID 
    730       INTEGER                                 ::   ib, ik, ji, jj   ! loop counters 
    731       INTEGER                                 ::   ierr 
    732       REAL(wp)                                ::   fv          ! fillvalue  
    733       REAL(wp), POINTER, DIMENSION(:,:,:)     ::   dta_read    ! work space for global data 
    734       REAL(wp), POINTER, DIMENSION(:,:,:)     ::   dta_read_z  ! work space for global data 
    735       REAL(wp), POINTER, DIMENSION(:,:,:)     ::   dta_read_dz ! work space for global data 
    736       !!--------------------------------------------------------------------- 
    737       ! 
    738       ipi = SIZE( dta, 1 ) 
    739       ipj = 1 
    740       ipk = SIZE( dta, 3 ) 
    741       ! 
    742       idvar   = iom_varid( num, clvar ) 
    743       ilendta = iom_file(num)%dimsz(1,idvar) 
    744  
    745       IF ( ln_bdy ) THEN 
    746          ipj = iom_file(num)%dimsz(2,idvar) 
    747          IF( map%ll_unstruc) THEN   ! unstructured open boundary data file 
    748             dta_read => dta_global 
    749             IF( PRESENT(jpk_bdy) ) THEN 
    750                IF( jpk_bdy>0 ) THEN 
    751                   dta_read_z => dta_global_z 
    752                   dta_read_dz => dta_global_dz 
    753                   jpkm1_bdy = jpk_bdy-1 
    754                ENDIF 
    755             ENDIF 
    756          ELSE                       ! structured open boundary file 
    757             dta_read => dta_global2 
    758             IF( PRESENT(jpk_bdy) ) THEN 
    759                IF( jpk_bdy>0 ) THEN 
    760                   dta_read_z => dta_global2_z 
    761                   dta_read_dz => dta_global2_dz 
    762                   jpkm1_bdy = jpk_bdy-1 
    763                ENDIF 
    764             ENDIF 
    765          ENDIF 
    766       ENDIF 
    767  
    768       IF(lwp) WRITE(numout,*) 'Dim size for ',        TRIM(clvar),' is ', ilendta 
    769       IF(lwp) WRITE(numout,*) 'Number of levels for ',TRIM(clvar),' is ', ipk 
    770       ! 
    771       SELECT CASE( ipk ) 
    772       CASE(1)        ;    
    773       CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1    ), nrec ) 
    774          IF ( map%ll_unstruc) THEN ! unstructured open boundary data file 
    775             DO ib = 1, ipi 
    776               DO ik = 1, ipk 
    777                 dta(ib,1,ik) =  dta_read(map%ptr(ib),1,ik) 
    778               END DO 
    779             END DO 
    780          ELSE ! we assume that this is a structured open boundary file 
    781             DO ib = 1, ipi 
    782                jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 
    783                ji=map%ptr(ib)-(jj-1)*ilendta 
    784                DO ik = 1, ipk 
    785                   dta(ib,1,ik) =  dta_read(ji,jj,ik) 
    786                END DO 
    787             END DO 
    788          ENDIF 
     688      INTEGER                   , INTENT(in   ) ::   knum         ! stream number 
     689      CHARACTER(LEN=*)          , INTENT(in   ) ::   cdvar        ! variable name 
     690      REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   pdta         ! bdy output field on model grid 
     691      INTEGER                   , INTENT(in   ) ::   krec         ! record number to read (ie time slice) 
     692      INTEGER , DIMENSION(:)    , INTENT(in   ) ::   kmap         ! global-to-local bdy mapping indices 
     693      ! optional variables used for vertical interpolation: 
     694      INTEGER, OPTIONAL         , INTENT(in   ) ::   kgrd         ! grid type (t, u, v) 
     695      INTEGER, OPTIONAL         , INTENT(in   ) ::   kbdy         ! bdy number 
     696      LOGICAL, OPTIONAL         , INTENT(in   ) ::   ldtotvel     ! true if total ( = barotrop + barocline) velocity 
     697      LOGICAL, OPTIONAL         , INTENT(in   ) ::   ldzint       ! true if 3D variable requires a vertical interpolation 
     698      INTEGER, OPTIONAL         , INTENT(in   ) ::   Kmm          ! ocean time level index  
     699      !! 
     700      INTEGER                                   ::   ipi          ! length of boundary data on local process 
     701      INTEGER                                   ::   ipj          ! length of dummy dimension ( = 1 ) 
     702      INTEGER                                   ::   ipk          ! number of vertical levels of pdta ( 2D: ipk=1 ; 3D: ipk=jpk ) 
     703      INTEGER                                   ::   ipkb         ! number of vertical levels in boundary data file 
     704      INTEGER                                   ::   idvar        ! variable ID 
     705      INTEGER                                   ::   indims       ! number of dimensions of the variable 
     706      INTEGER, DIMENSION(4)                     ::   idimsz       ! size of variable dimensions  
     707      REAL(wp)                                  ::   zfv          ! fillvalue  
     708      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   ::   zz_read      ! work space for global boundary data 
     709      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   ::   zdta_read    ! work space local data requiring vertical interpolation 
     710      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   ::   zdta_read_z  ! work space local data requiring vertical interpolation 
     711      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   ::   zdta_read_dz ! work space local data requiring vertical interpolation 
     712      CHARACTER(LEN=1),DIMENSION(3)             ::   clgrid 
     713      LOGICAL                                   ::   lluld        ! is the variable using the unlimited dimension 
     714      LOGICAL                                   ::   llzint       ! local value of ldzint 
     715      !!--------------------------------------------------------------------- 
     716      ! 
     717      clgrid = (/'t','u','v'/) 
     718      ! 
     719      ipi = SIZE( pdta, 1 ) 
     720      ipj = SIZE( pdta, 2 )   ! must be equal to 1 
     721      ipk = SIZE( pdta, 3 ) 
     722      ! 
     723      llzint = .FALSE. 
     724      IF( PRESENT(ldzint) )   llzint = ldzint 
     725      ! 
     726      idvar = iom_varid( knum, cdvar, kndims = indims, kdimsz = idimsz, lduld = lluld  ) 
     727      IF( indims == 4 .OR. ( indims == 3 .AND. .NOT. lluld ) ) THEN   ;   ipkb = idimsz(3)   ! xy(zl)t or xy(zl) 
     728      ELSE                                                            ;   ipkb = 1           ! xy or xyt 
     729      ENDIF 
     730      ! 
     731      ALLOCATE( zz_read( idimsz(1), idimsz(2), ipkb ) )  ! ++++++++ !!! this can be very big...          
     732      ! 
     733      IF( ipk == 1 ) THEN 
     734 
     735         IF( ipkb /= 1 ) CALL ctl_stop( 'fld_map : we must have ipkb = 1 to read surface data' ) 
     736         CALL iom_get ( knum, jpdom_unknown, cdvar, zz_read(:,:,1), krec )   ! call iom_get with a 2D file 
     737         CALL fld_map_core( zz_read, kmap, pdta ) 
    789738 
    790739      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    791740      ! Do we include something here to adjust barotropic velocities ! 
    792741      ! in case of a depth difference between bdy files and          ! 
    793       ! bathymetry in the case ln_full_vel = .false. and jpk_bdy>0?  ! 
     742      ! bathymetry in the case ln_totvel = .false. and ipkb>0?       ! 
    794743      ! [as the enveloping and parital cells could change H]         ! 
    795744      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    796745 
    797       CASE DEFAULT   ; 
    798  
    799       IF( PRESENT(jpk_bdy) .AND. jpk_bdy>0 ) THEN       ! boundary data not on model grid: vertical interpolation 
    800          CALL iom_getatt(num, '_FillValue', fv, cdvar=clvar ) 
    801          dta_read(:,:,:) = -ABS(fv) 
    802          dta_read_z(:,:,:) = 0._wp 
    803          dta_read_dz(:,:,:) = 0._wp 
    804          CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1:jpk_bdy), nrec ) 
    805          SELECT CASE( igrd )                   
    806             CASE(1) 
    807                CALL iom_get ( num, jpdom_unknown, 'gdept', dta_read_z(1:ilendta,1:ipj,1:jpk_bdy) ) 
    808                CALL iom_get ( num, jpdom_unknown, 'e3t',  dta_read_dz(1:ilendta,1:ipj,1:jpk_bdy) ) 
    809             CASE(2)   
    810                CALL iom_get ( num, jpdom_unknown, 'gdepu', dta_read_z(1:ilendta,1:ipj,1:jpk_bdy) ) 
    811                CALL iom_get ( num, jpdom_unknown, 'e3u',  dta_read_dz(1:ilendta,1:ipj,1:jpk_bdy) ) 
    812             CASE(3) 
    813                CALL iom_get ( num, jpdom_unknown, 'gdepv', dta_read_z(1:ilendta,1:ipj,1:jpk_bdy) ) 
    814                CALL iom_get ( num, jpdom_unknown, 'e3v',  dta_read_dz(1:ilendta,1:ipj,1:jpk_bdy) ) 
    815          END SELECT 
    816  
    817       IF ( ln_bdy ) &  
    818          CALL fld_bdy_interp(dta_read, dta_read_z, dta_read_dz, map, jpk_bdy, igrd, ibdy, fv, dta, fvl, ilendta, Kmm) 
    819  
    820       ELSE ! boundary data assumed to be on model grid 
    821           
    822          CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1:ipk), nrec )                     
    823          IF ( map%ll_unstruc) THEN ! unstructured open boundary data file 
    824             DO ib = 1, ipi 
    825               DO ik = 1, ipk 
    826                 dta(ib,1,ik) =  dta_read(map%ptr(ib),1,ik) 
    827               END DO 
     746      ELSE 
     747         ! 
     748         CALL iom_get ( knum, jpdom_unknown, cdvar, zz_read(:,:,:), krec )   ! call iom_get with a 3D file 
     749         ! 
     750         IF( ipkb /= ipk .OR. llzint ) THEN   ! boundary data not on model vertical grid : vertical interpolation 
     751            ! 
     752            IF( ipk == jpk .AND. iom_varid(knum,'gdep'//clgrid(kgrd)) /= -1 .AND. iom_varid(knum,'e3'//clgrid(kgrd)) /= -1 ) THEN 
     753                
     754               ALLOCATE( zdta_read(ipi,ipj,ipkb), zdta_read_z(ipi,ipj,ipkb), zdta_read_dz(ipi,ipj,ipkb) ) 
     755                 
     756               CALL fld_map_core( zz_read, kmap, zdta_read ) 
     757               CALL iom_get ( knum, jpdom_unknown, 'gdep'//clgrid(kgrd), zz_read )   ! read only once? Potential temporal evolution? 
     758               CALL fld_map_core( zz_read, kmap, zdta_read_z ) 
     759               CALL iom_get ( knum, jpdom_unknown,   'e3'//clgrid(kgrd), zz_read )   ! read only once? Potential temporal evolution? 
     760               CALL fld_map_core( zz_read, kmap, zdta_read_dz ) 
     761                
     762               CALL iom_getatt(knum, '_FillValue', zfv, cdvar=cdvar ) 
     763               CALL fld_bdy_interp(zdta_read, zdta_read_z, zdta_read_dz, pdta, kgrd, kbdy, zfv, ldtotvel) 
     764               DEALLOCATE( zdta_read, zdta_read_z, zdta_read_dz ) 
     765                
     766            ELSE 
     767               IF( ipk /= jpk ) CALL ctl_stop( 'fld_map : this should be an impossible case...' ) 
     768               WRITE(ctmp1,*) 'fld_map : vertical interpolation for bdy variable '//TRIM(cdvar)//' requires '  
     769               IF( iom_varid(knum, 'gdep'//clgrid(kgrd)) == -1 ) CALL ctl_stop( ctmp1//'gdep'//clgrid(kgrd)//' variable' ) 
     770               IF( iom_varid(knum,   'e3'//clgrid(kgrd)) == -1 ) CALL ctl_stop( ctmp1//  'e3'//clgrid(kgrd)//' variable' ) 
     771 
     772            ENDIF 
     773            ! 
     774         ELSE                            ! bdy data assumed to be the same levels as bdy variables 
     775            ! 
     776            CALL fld_map_core( zz_read, kmap, pdta ) 
     777            ! 
     778         ENDIF   ! ipkb /= ipk 
     779      ENDIF   ! ipk == 1 
     780       
     781      DEALLOCATE( zz_read ) 
     782 
     783   END SUBROUTINE fld_map 
     784 
     785      
     786   SUBROUTINE fld_map_core( pdta_read, kmap, pdta_bdy ) 
     787      !!--------------------------------------------------------------------- 
     788      !!                    ***  ROUTINE fld_map_core  *** 
     789      !! 
     790      !! ** Purpose :  inner core of fld_map 
     791      !!---------------------------------------------------------------------- 
     792      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pdta_read    ! global boundary data 
     793      INTEGER,  DIMENSION(:    ), INTENT(in   ) ::   kmap         ! global-to-local bdy mapping indices 
     794      REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   pdta_bdy     ! bdy output field on model grid 
     795      !! 
     796      INTEGER,  DIMENSION(3) ::   idim_read,  idim_bdy            ! arrays dimensions 
     797      INTEGER                ::   ji, jj, jk, jb                  ! loop counters 
     798      INTEGER                ::   im1 
     799      !!--------------------------------------------------------------------- 
     800      ! 
     801      idim_read = SHAPE( pdta_read ) 
     802      idim_bdy  = SHAPE( pdta_bdy  ) 
     803      ! 
     804      ! in all cases: idim_bdy(2) == 1 .AND. idim_read(1) * idim_read(2) == idim_bdy(1) 
     805      ! structured BDY with rimwidth > 1                     : idim_read(2) == rimwidth /= 1 
     806      ! structured BDY with rimwidth == 1 or unstructured BDY: idim_read(2) == 1 
     807      ! 
     808      IF( idim_read(2) > 1 ) THEN    ! structured BDY with rimwidth > 1   
     809         DO jk = 1, idim_bdy(3) 
     810            DO jb = 1, idim_bdy(1) 
     811               im1 = kmap(jb) - 1 
     812               jj = im1 / idim_read(1) + 1 
     813               ji = MOD( im1, idim_read(1) ) + 1 
     814               pdta_bdy(jb,1,jk) =  pdta_read(ji,jj,jk) 
    828815            END DO 
    829          ELSE ! we assume that this is a structured open boundary file 
    830             DO ib = 1, ipi 
    831                jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 
    832                ji=map%ptr(ib)-(jj-1)*ilendta 
    833                DO ik = 1, ipk 
    834                   dta(ib,1,ik) =  dta_read(ji,jj,ik) 
    835                END DO 
     816         END DO 
     817      ELSE 
     818         DO jk = 1, idim_bdy(3) 
     819            DO jb = 1, idim_bdy(1)   ! horizontal remap of bdy data on the local bdy  
     820               pdta_bdy(jb,1,jk) = pdta_read(kmap(jb),1,jk) 
    836821            END DO 
    837          ENDIF 
    838       ENDIF ! PRESENT(jpk_bdy) 
    839       END SELECT 
    840  
    841    END SUBROUTINE fld_map 
     822         END DO 
     823      ENDIF 
     824       
     825   END SUBROUTINE fld_map_core 
    842826    
    843    SUBROUTINE fld_bdy_interp(dta_read, dta_read_z, dta_read_dz, map, jpk_bdy, igrd, ibdy, fv, dta, fvl, ilendta, Kmm) 
    844  
     827   SUBROUTINE fld_bdy_interp(pdta_read, pdta_read_z, pdta_read_dz, pdta, kgrd, kbdy, pfv, ldtotvel, Kmm ) 
    845828      !!--------------------------------------------------------------------- 
    846829      !!                    ***  ROUTINE fld_bdy_interp  *** 
    … …  
    851834      USE bdy_oce, ONLY:  idx_bdy         ! indexing for map <-> ij transformation 
    852835 
    853       REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(in )     ::   dta_read      ! work space for global data 
    854       REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(in )     ::   dta_read_z    ! work space for global data 
    855       REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(in )     ::   dta_read_dz   ! work space for global data 
    856       REAL(wp) , INTENT(in)                                ::   fv            ! fillvalue and alternative -ABS(fv) 
    857       REAL(wp), DIMENSION(:,:,:), INTENT(out) ::   dta                        ! output field on model grid (2 dimensional) 
    858       TYPE(MAP_POINTER)         , INTENT(in ) ::   map                        ! global-to-local mapping indices 
    859       LOGICAL  , INTENT(in), OPTIONAL         ::   fvl                        ! grid type, set number and number of vertical levels in the bdy data 
    860       INTEGER  , INTENT(in)                   ::   igrd, ibdy, jpk_bdy        ! number of levels in bdy data 
    861       INTEGER  , INTENT(in)                   ::   ilendta                    ! length of data in file 
    862       INTEGER  , INTENT(in), OPTIONAL         ::   Kmm                        ! ocean time level index 
    863       !! 
    864       INTEGER                                 ::   ipi                        ! length of boundary data on local process 
    865       INTEGER                                 ::   ipj                        ! length of dummy dimension ( = 1 ) 
    866       INTEGER                                 ::   ipk                        ! number of vertical levels of dta ( 2D: ipk=1 ; 3D: ipk=jpk ) 
    867       INTEGER                                 ::   jpkm1_bdy                  ! number of levels in bdy data minus 1 
    868       INTEGER                                 ::   ib, ik, ikk                ! loop counters 
    869       INTEGER                                 ::   ji, jj, zij, zjj           ! temporary indices 
    870       REAL(wp)                                ::   zl, zi, zh                 ! tmp variable for current depth and interpolation factor 
    871       REAL(wp)                                ::   fv_alt, ztrans, ztrans_new ! fillvalue and alternative -ABS(fv) 
    872       CHARACTER (LEN=10)                      ::   ibstr 
     836      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pdta_read       ! data read in bdy file 
     837      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pdta_read_z     ! depth of the data read in bdy file 
     838      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pdta_read_dz    ! thickness of the levels in bdy file 
     839      REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   pdta            ! output field on model grid (2 dimensional) 
     840      REAL(wp)                  , INTENT(in   ) ::   pfv             ! fillvalue of the data read in bdy file 
     841      LOGICAL                   , INTENT(in   ) ::   ldtotvel        ! true if toal ( = barotrop + barocline) velocity 
     842      INTEGER                   , INTENT(in   ) ::   kgrd            ! grid type (t, u, v) 
     843      INTEGER                   , INTENT(in   ) ::   kbdy            ! bdy number 
     844      INTEGER, OPTIONAL         , INTENT(in   ) ::   Kmm             ! ocean time level index 
     845      !! 
     846      INTEGER                                   ::   ipi             ! length of boundary data on local process 
     847      INTEGER                                   ::   ipkb            ! number of vertical levels in boundary data file 
     848      INTEGER                                   ::   jb, ji, jj, jk, jkb   ! loop counters 
     849      REAL(wp)                                  ::   zcoef 
     850      REAL(wp)                                  ::   zl, zi, zh      ! tmp variable for current depth and interpolation factor 
     851      REAL(wp)                                  ::   zfv_alt, ztrans, ztrans_new ! fillvalue and alternative -ABS(pfv) 
     852      REAL(wp), DIMENSION(jpk)                  ::   zdepth, zdhalf  ! level and half-level depth 
    873853      !!--------------------------------------------------------------------- 
    874854      
    875  
    876       ipi       = SIZE( dta, 1 ) 
    877       ipj       = SIZE( dta_read, 2 ) 
    878       ipk       = SIZE( dta, 3 ) 
    879       jpkm1_bdy = jpk_bdy-1 
     855      ipi  = SIZE( pdta, 1 ) 
     856      ipkb = SIZE( pdta_read, 3 ) 
    880857       
    881       fv_alt = -ABS(fv)  ! set _FillValue < 0 as we make use of MAXVAL and MAXLOC later 
    882       DO ib = 1, ipi 
    883             zij = idx_bdy(ibdy)%nbi(ib,igrd) 
    884             zjj = idx_bdy(ibdy)%nbj(ib,igrd) 
    885          IF(narea==2) WRITE(*,*) 'MAPI', ib, igrd, map%ptr(ib), narea-1, zij, zjj 
    886       ENDDO 
    887       ! 
    888       IF ( map%ll_unstruc ) THEN                            ! unstructured open boundary data file 
    889  
    890          DO ib = 1, ipi 
    891             DO ik = 1, jpk_bdy 
    892                IF( ( dta_read(map%ptr(ib),1,ik) == fv ) ) THEN 
    893                   dta_read_z(map%ptr(ib),1,ik)  = fv_alt ! safety: put fillvalue into external depth field so consistent with data 
    894                   dta_read_dz(map%ptr(ib),1,ik) = 0._wp  ! safety: put 0._wp into external thickness factors to ensure transport is correct 
     858      zfv_alt = -ABS(pfv)  ! set _FillValue < 0 as we make use of MAXVAL and MAXLOC later 
     859      ! 
     860      WHERE( pdta_read == pfv ) 
     861         pdta_read_z  = zfv_alt ! safety: put fillvalue into external depth field so consistent with data 
     862         pdta_read_dz = 0._wp   ! safety: put 0._wp into external thickness factors to ensure transport is correct 
     863      ENDWHERE 
     864       
     865      DO jb = 1, ipi 
     866         ji = idx_bdy(kbdy)%nbi(jb,kgrd) 
     867         jj = idx_bdy(kbdy)%nbj(jb,kgrd) 
     868         zh  = SUM(pdta_read_dz(jb,1,:) ) 
     869         ! 
     870         ! Warnings to flag differences in the input and model topgraphy - is this useful/necessary? 
     871         SELECT CASE( kgrd )                          
     872         CASE(1) 
     873            IF( ABS( (zh - ht(ji,jj)) / ht(ji,jj)) * tmask(ji,jj,1) > 0.01_wp ) THEN 
     874               WRITE(ctmp1,"(I10.10)") jb  
     875               CALL ctl_warn('fld_bdy_interp: T depths differ between grids at BDY point '//TRIM(ctmp1)//' by more than 1%') 
     876               !   IF(lwp) WRITE(numout,*) 'DEPTHT', zh, sum(e3t(ji,jj,:,Kmm), mask=tmask(ji,jj,:)==1),  ht(ji,jj), jb, jb, ji, jj 
     877            ENDIF 
     878         CASE(2) 
     879            IF( ABS( (zh - hu(ji,jj,Kmm)) * r1_hu(ji,jj,Kmm)) * umask(ji,jj,1) > 0.01_wp ) THEN 
     880               WRITE(ctmp1,"(I10.10)") jb  
     881               CALL ctl_warn('fld_bdy_interp: U depths differ between grids at BDY point '//TRIM(ctmp1)//' by more than 1%') 
     882               !   IF(lwp) WRITE(numout,*) 'DEPTHU', zh, SUM(e3u(ji,jj,:,Kmm), mask=umask(ji,jj,:)==1),  SUM(umask(ji,jj,:)), & 
     883               !      &                hu(ji,jj,Kmm), jb, jb, ji, jj, narea-1, pdta_read(jb,1,:) 
     884            ENDIF 
     885         CASE(3) 
     886            IF( ABS( (zh - hv(ji,jj,Kmm)) * r1_hv(ji,jj,Kmm)) * vmask(ji,jj,1) > 0.01_wp ) THEN 
     887               WRITE(ctmp1,"(I10.10)") jb 
     888               CALL ctl_warn('fld_bdy_interp: V depths differ between grids at BDY point '//TRIM(ctmp1)//' by more than 1%') 
     889            ENDIF 
     890         END SELECT 
     891         ! 
     892         SELECT CASE( kgrd )                          
     893         CASE(1) 
     894            ! depth of T points: 
     895            zdepth(:) = gdept(ji,jj,:,Kmm) 
     896         CASE(2) 
     897            ! depth of U points: we must not use gdept_n as we don't want to do a communication 
     898            !   --> copy what is done for gdept_n in domvvl... 
     899            zdhalf(1) = 0.0_wp 
     900            zdepth(1) = 0.5_wp * e3uw(ji,jj,1,Kmm) 
     901            DO jk = 2, jpk                               ! vertical sum 
     902               !    zcoef = umask - wumask    ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 
     903               !                              ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) 
     904               !                              ! 0.5 where jk = mikt      
     905               !!gm ???????   BUG ?  gdept_n as well as gde3w_n  does not include the thickness of ISF ?? 
     906               zcoef = ( umask(ji,jj,jk) - wumask(ji,jj,jk) ) 
     907               zdhalf(jk) = zdhalf(jk-1) + e3u(ji,jj,jk-1,Kmm) 
     908               zdepth(jk) =      zcoef  * ( zdhalf(jk  ) + 0.5 * e3uw(ji,jj,jk,Kmm))  & 
     909                  &         + (1-zcoef) * ( zdepth(jk-1) + e3uw(ji,jj,jk,Kmm)) 
     910            END DO 
     911         CASE(3) 
     912            ! depth of V points: we must not use gdept_n as we don't want to do a communication 
     913            !   --> copy what is done for gdept_n in domvvl... 
     914            zdhalf(1) = 0.0_wp 
     915            zdepth(1) = 0.5_wp * e3vw(ji,jj,1,Kmm) 
     916            DO jk = 2, jpk                               ! vertical sum 
     917               !    zcoef = vmask - wvmask    ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 
     918               !                              ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) 
     919               !                              ! 0.5 where jk = mikt      
     920               !!gm ???????   BUG ?  gdept_n as well as gde3w_n  does not include the thickness of ISF ?? 
     921               zcoef = ( vmask(ji,jj,jk) - wvmask(ji,jj,jk) ) 
     922               zdhalf(jk) = zdhalf(jk-1) + e3v(ji,jj,jk-1,Kmm) 
     923               zdepth(jk) =      zcoef  * ( zdhalf(jk  ) + 0.5 * e3vw(ji,jj,jk,Kmm))  & 
     924                  &         + (1-zcoef) * ( zdepth(jk-1) + e3vw(ji,jj,jk,Kmm)) 
     925            END DO 
     926         END SELECT 
     927         ! 
     928         DO jk = 1, jpk                       
     929            IF(     zdepth(jk) < pdta_read_z(jb,1,          1) ) THEN                ! above the first level of external data 
     930               pdta(jb,1,jk) =  pdta_read(jb,1,1) 
     931            ELSEIF( zdepth(jk) > pdta_read_z(jb,1,ipkb) ) THEN                       ! below the last level of external data  
     932               pdta(jb,1,jk) =  pdta_read(jb,1,MAXLOC(pdta_read_z(jb,1,:),1)) 
     933            ELSE                                                             ! inbetween: vertical interpolation between jkb & jkb+1 
     934               DO jkb = 1, ipkb-1                                            ! when  gdept_n(jkb) < zdepth(jk) < gdept_n(jkb+1) 
     935                  IF( ( ( zdepth(jk) - pdta_read_z(jb,1,jkb) ) * ( zdepth(jk) - pdta_read_z(jb,1,jkb+1) ) <= 0._wp ) & 
     936                     &    .AND. ( pdta_read_z(jb,1,jkb+1) /= zfv_alt) ) THEN   ! linear interpolation between 2 levels 
     937                     zi = ( zdepth(jk) - pdta_read_z(jb,1,jkb) ) / ( pdta_read_z(jb,1,jkb+1) - pdta_read_z(jb,1,jkb) ) 
     938                     pdta(jb,1,jk) = pdta_read(jb,1,jkb) + ( pdta_read  (jb,1,jkb+1) - pdta_read  (jb,1,jkb) ) * zi 
     939                  ENDIF 
     940               END DO 
     941            ENDIF 
     942         END DO   ! jpk 
     943         ! 
     944      END DO   ! ipi 
     945       
     946      IF(kgrd == 2) THEN                                  ! do we need to adjust the transport term? 
     947         DO jb = 1, ipi 
     948            ji = idx_bdy(kbdy)%nbi(jb,kgrd) 
     949            jj = idx_bdy(kbdy)%nbj(jb,kgrd) 
     950            zh  = SUM(pdta_read_dz(jb,1,:) ) 
     951            ztrans = 0._wp 
     952            ztrans_new = 0._wp 
     953            DO jkb = 1, ipkb                              ! calculate transport on input grid 
     954               ztrans     = ztrans     + pdta_read(jb,1,jkb) * pdta_read_dz(jb, 1,jkb) 
     955            ENDDO 
     956            DO jk = 1, jpk                                ! calculate transport on model grid 
     957               ztrans_new = ztrans_new +      pdta(jb,1,jk ) *        e3u(ji,jj,jk,Kmm ) * umask(ji,jj,jk) 
     958            ENDDO 
     959            DO jk = 1, jpk                                ! make transport correction 
     960               IF(ldtotvel) THEN ! bdy data are total velocity so adjust bt transport term to match input data 
     961                  pdta(jb,1,jk) = ( pdta(jb,1,jk) + ( ztrans - ztrans_new ) * r1_hu(ji,jj,Kmm) ) * umask(ji,jj,jk) 
     962               ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 
     963                  pdta(jb,1,jk) =   pdta(jb,1,jk) + (  0._wp - ztrans_new ) * r1_hu(ji,jj,Kmm)   * umask(ji,jj,jk) 
    895964               ENDIF 
    896965            ENDDO 
    897          ENDDO  
    898  
    899          DO ib = 1, ipi 
    900             zij = idx_bdy(ibdy)%nbi(ib,igrd) 
    901             zjj = idx_bdy(ibdy)%nbj(ib,igrd) 
    902             zh  = SUM(dta_read_dz(map%ptr(ib),1,:) ) 
    903             ! Warnings to flag differences in the input and model topgraphy - is this useful/necessary? 
    904             SELECT CASE( igrd )                          
    905                CASE(1) 
    906                   IF( ABS( (zh - ht(zij,zjj)) / ht(zij,zjj)) * tmask(zij,zjj,1) > 0.01_wp ) THEN 
    907                      WRITE(ibstr,"(I10.10)") map%ptr(ib)  
    908                      CALL ctl_warn('fld_bdy_interp: T depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 
    909                  !   IF(lwp) WRITE(*,*) 'DEPTHT', zh, sum(e3t(zij,zjj,:,Kmm), mask=tmask(zij,zjj,:)==1),  ht(zij,zjj), map%ptr(ib), ib, zij, zjj 
    910                   ENDIF 
    911                CASE(2) 
    912                   IF( ABS( (zh - hu(zij,zjj,Kmm)) * r1_hu(zij,zjj,Kmm)) * umask(zij,zjj,1) > 0.01_wp ) THEN 
    913                      WRITE(ibstr,"(I10.10)") map%ptr(ib)  
    914                      CALL ctl_warn('fld_bdy_interp: U depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 
    915                      IF(lwp) WRITE(*,*) 'DEPTHU', zh, sum(e3u(zij,zjj,:,Kmm), mask=umask(zij,zjj,:)==1),  sum(umask(zij,zjj,:)), & 
    916                        &                hu(zij,zjj,Kmm), map%ptr(ib), ib, zij, zjj, narea-1  , & 
    917                         &                dta_read(map%ptr(ib),1,:) 
    918                   ENDIF 
    919                CASE(3) 
    920                   IF( ABS( (zh - hv(zij,zjj,Kmm)) * r1_hv(zij,zjj,Kmm)) * vmask(zij,zjj,1) > 0.01_wp ) THEN 
    921                      WRITE(ibstr,"(I10.10)") map%ptr(ib)  
    922                      CALL ctl_warn('fld_bdy_interp: V depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 
    923                   ENDIF 
    924             END SELECT 
    925             DO ik = 1, ipk                       
    926                SELECT CASE( igrd )                        
    927                   CASE(1) 
    928                      zl =  gdept(zij,zjj,ik,Kmm)                                          ! if using in step could use fsdept instead of gdept_n? 
    929                   CASE(2) 
    930                      IF(ln_sco) THEN 
    931                         zl =  ( gdept(zij,zjj,ik,Kmm) + gdept(zij+1,zjj,ik,Kmm) ) * 0.5_wp  ! if using in step could use fsdept instead of gdept_n? 
    932                      ELSE 
    933                         zl =  MIN( gdept(zij,zjj,ik,Kmm), gdept(zij+1,zjj,ik,Kmm) )  
    934                      ENDIF 
    935                   CASE(3) 
    936                      IF(ln_sco) THEN 
    937                         zl =  ( gdept(zij,zjj,ik,Kmm) + gdept(zij,zjj+1,ik,Kmm) ) * 0.5_wp  ! if using in step could use fsdept instead of gdept_n? 
    938                      ELSE 
    939                         zl =  MIN( gdept(zij,zjj,ik,Kmm), gdept(zij,zjj+1,ik,Kmm) ) 
    940                      ENDIF 
    941                END SELECT 
    942                IF( zl < dta_read_z(map%ptr(ib),1,1) ) THEN                                         ! above the first level of external data 
    943                   dta(ib,1,ik) =  dta_read(map%ptr(ib),1,1) 
    944                ELSEIF( zl > MAXVAL(dta_read_z(map%ptr(ib),1,:),1) ) THEN                           ! below the last level of external data  
    945                   dta(ib,1,ik) =  dta_read(map%ptr(ib),1,MAXLOC(dta_read_z(map%ptr(ib),1,:),1)) 
    946                ELSE                                                                                ! inbetween : vertical interpolation between ikk & ikk+1 
    947                   DO ikk = 1, jpkm1_bdy                                                            ! when  gdept(ikk,Kmm) < zl < gdept(ikk+1,Kmm) 
    948                      IF( ( (zl-dta_read_z(map%ptr(ib),1,ikk)) * (zl-dta_read_z(map%ptr(ib),1,ikk+1)) <= 0._wp) & 
    949                     &    .AND. (dta_read_z(map%ptr(ib),1,ikk+1) /= fv_alt)) THEN 
    950                         zi           = ( zl - dta_read_z(map%ptr(ib),1,ikk) ) / & 
    951                        &               ( dta_read_z(map%ptr(ib),1,ikk+1) - dta_read_z(map%ptr(ib),1,ikk) ) 
    952                         dta(ib,1,ik) = dta_read(map%ptr(ib),1,ikk) + & 
    953                        &               ( dta_read(map%ptr(ib),1,ikk+1) - dta_read(map%ptr(ib),1,ikk) ) * zi 
    954                      ENDIF 
    955                   END DO 
    956                ENDIF 
    957             END DO 
    958          END DO 
    959  
    960          IF(igrd == 2) THEN                                 ! do we need to adjust the transport term? 
    961             DO ib = 1, ipi 
    962               zij = idx_bdy(ibdy)%nbi(ib,igrd) 
    963               zjj = idx_bdy(ibdy)%nbj(ib,igrd) 
    964               zh  = SUM(dta_read_dz(map%ptr(ib),1,:) ) 
    965               ztrans = 0._wp 
    966               ztrans_new = 0._wp 
    967               DO ik = 1, jpk_bdy                            ! calculate transport on input grid 
    968                   ztrans     = ztrans     + dta_read(map%ptr(ib),1,ik) * dta_read_dz(map%ptr(ib),1,ik) 
    969               ENDDO 
    970               DO ik = 1, ipk                                ! calculate transport on model grid 
    971                   ztrans_new = ztrans_new + dta(ib,1,ik) * e3u(zij,zjj,ik,Kmm) * umask(zij,zjj,ik) 
    972               ENDDO 
    973               DO ik = 1, ipk                                ! make transport correction 
    974                  IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data 
    975                     dta(ib,1,ik) = ( dta(ib,1,ik) + ( ztrans - ztrans_new ) * r1_hu(zij,zjj,Kmm) ) * umask(zij,zjj,ik) 
    976                  ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 
    977                     IF( ABS(ztrans * r1_hu(zij,zjj,Kmm)) > 0.01_wp ) & 
    978                    &   CALL ctl_warn('fld_bdy_interp: barotropic component of > 0.01 ms-1 found in baroclinic velocities at') 
    979                     dta(ib,1,ik) = dta(ib,1,ik) + ( 0._wp - ztrans_new ) * r1_hu(zij,zjj,Kmm) * umask(zij,zjj,ik) 
    980                  ENDIF 
    981               ENDDO 
     966         ENDDO 
     967      ENDIF 
     968       
     969      IF(kgrd == 3) THEN                                  ! do we need to adjust the transport term? 
     970         DO jb = 1, ipi 
     971            ji = idx_bdy(kbdy)%nbi(jb,kgrd) 
     972            jj = idx_bdy(kbdy)%nbj(jb,kgrd) 
     973            zh  = SUM(pdta_read_dz(jb,1,:) ) 
     974            ztrans = 0._wp 
     975            ztrans_new = 0._wp 
     976            DO jkb = 1, ipkb                              ! calculate transport on input grid 
     977               ztrans     = ztrans     + pdta_read(jb,1,jkb) * pdta_read_dz(jb, 1,jkb) 
    982978            ENDDO 
    983          ENDIF 
    984  
    985          IF(igrd == 3) THEN                                 ! do we need to adjust the transport term? 
    986             DO ib = 1, ipi 
    987               zij = idx_bdy(ibdy)%nbi(ib,igrd) 
    988               zjj = idx_bdy(ibdy)%nbj(ib,igrd) 
    989               zh  = SUM(dta_read_dz(map%ptr(ib),1,:) ) 
    990               ztrans = 0._wp 
    991               ztrans_new = 0._wp 
    992               DO ik = 1, jpk_bdy                            ! calculate transport on input grid 
    993                   ztrans     = ztrans     + dta_read(map%ptr(ib),1,ik) * dta_read_dz(map%ptr(ib),1,ik) 
    994               ENDDO 
    995               DO ik = 1, ipk                                ! calculate transport on model grid 
    996                   ztrans_new = ztrans_new + dta(ib,1,ik) * e3v(zij,zjj,ik,Kmm) * vmask(zij,zjj,ik) 
    997               ENDDO 
    998               DO ik = 1, ipk                                ! make transport correction 
    999                  IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data 
    1000                     dta(ib,1,ik) = ( dta(ib,1,ik) + ( ztrans - ztrans_new ) * r1_hv(zij,zjj,Kmm) ) * vmask(zij,zjj,ik) 
    1001                  ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 
    1002                     dta(ib,1,ik) = dta(ib,1,ik) + ( 0._wp - ztrans_new ) * r1_hv(zij,zjj,Kmm) * vmask(zij,zjj,ik) 
    1003                  ENDIF 
    1004               ENDDO 
     979            DO jk = 1, jpk                                ! calculate transport on model grid 
     980               ztrans_new = ztrans_new +      pdta(jb,1,jk ) *        e3v(ji,jj,jk,Kmm ) * vmask(ji,jj,jk) 
    1005981            ENDDO 
    1006          ENDIF 
    1007    
    1008       ELSE ! structured open boundary file 
    1009  
    1010          DO ib = 1, ipi 
    1011             jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 
    1012             ji=map%ptr(ib)-(jj-1)*ilendta 
    1013             DO ik = 1, jpk_bdy                       
    1014                IF( ( dta_read(ji,jj,ik) == fv ) ) THEN 
    1015                   dta_read_z(ji,jj,ik)  = fv_alt ! safety: put fillvalue into external depth field so consistent with data 
    1016                   dta_read_dz(ji,jj,ik) = 0._wp  ! safety: put 0._wp into external thickness factors to ensure transport is correct 
     982            DO jk = 1, jpk                                ! make transport correction 
     983               IF(ldtotvel) THEN ! bdy data are total velocity so adjust bt transport term to match input data 
     984                  pdta(jb,1,jk) = ( pdta(jb,1,jk) + ( ztrans - ztrans_new ) * r1_hv(ji,jj,Kmm) ) * vmask(ji,jj,jk) 
     985               ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 
     986                  pdta(jb,1,jk) =   pdta(jb,1,jk) + (  0._wp - ztrans_new ) * r1_hv(ji,jj,Kmm)   * vmask(ji,jj,jk) 
    1017987               ENDIF 
    1018988            ENDDO 
    1019          ENDDO  
    1020         
    1021  
    1022          DO ib = 1, ipi 
    1023             jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 
    1024             ji=map%ptr(ib)-(jj-1)*ilendta 
    1025             zij = idx_bdy(ibdy)%nbi(ib,igrd) 
    1026             zjj = idx_bdy(ibdy)%nbj(ib,igrd) 
    1027             zh  = SUM(dta_read_dz(ji,jj,:) ) 
    1028             ! Warnings to flag differences in the input and model topgraphy - is this useful/necessary? 
    1029             SELECT CASE( igrd )                          
    1030                CASE(1) 
    1031                   IF( ABS( (zh - ht(zij,zjj)) / ht(zij,zjj)) * tmask(zij,zjj,1) > 0.01_wp ) THEN 
    1032                      WRITE(ibstr,"(I10.10)") map%ptr(ib)  
    1033                      CALL ctl_warn('fld_bdy_interp: T depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 
    1034                  !   IF(lwp) WRITE(*,*) 'DEPTHT', zh, sum(e3t(zij,zjj,:,Kmm), mask=tmask(zij,zjj,:)==1),  ht(zij,zjj), map%ptr(ib), ib, zij, zjj 
    1035                   ENDIF 
    1036                CASE(2) 
    1037                   IF( ABS( (zh - hu(zij,zjj,Kmm)) * r1_hu(zij,zjj,Kmm)) * umask(zij,zjj,1) > 0.01_wp ) THEN 
    1038                      WRITE(ibstr,"(I10.10)") map%ptr(ib)  
    1039                      CALL ctl_warn('fld_bdy_interp: U depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 
    1040                   ENDIF 
    1041                CASE(3) 
    1042                   IF( ABS( (zh - hv(zij,zjj,Kmm)) * r1_hv(zij,zjj,Kmm)) * vmask(zij,zjj,1) > 0.01_wp ) THEN 
    1043                      WRITE(ibstr,"(I10.10)") map%ptr(ib)  
    1044                      CALL ctl_warn('fld_bdy_interp: V depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 
    1045                   ENDIF 
    1046             END SELECT 
    1047             DO ik = 1, ipk                       
    1048                SELECT CASE( igrd )                          ! coded for sco - need zco and zps option using min 
    1049                   CASE(1) 
    1050                      zl =  gdept(zij,zjj,ik,Kmm)              ! if using in step could use fsdept instead of gdept_n? 
    1051                   CASE(2) 
    1052                      IF(ln_sco) THEN 
    1053                         zl =  ( gdept(zij,zjj,ik,Kmm) + gdept(zij+1,zjj,ik,Kmm) ) * 0.5_wp  ! if using in step could use fsdept instead of gdept_n? 
    1054                      ELSE 
    1055                         zl =  MIN( gdept(zij,zjj,ik,Kmm), gdept(zij+1,zjj,ik,Kmm) ) 
    1056                      ENDIF 
    1057                   CASE(3) 
    1058                      IF(ln_sco) THEN 
    1059                         zl =  ( gdept(zij,zjj,ik,Kmm) + gdept(zij,zjj+1,ik,Kmm) ) * 0.5_wp  ! if using in step could use fsdept instead of gdept_n? 
    1060                      ELSE 
    1061                         zl =  MIN( gdept(zij,zjj,ik,Kmm), gdept(zij,zjj+1,ik,Kmm) ) 
    1062                      ENDIF 
    1063                END SELECT 
    1064                IF( zl < dta_read_z(ji,jj,1) ) THEN                                      ! above the first level of external data 
    1065                   dta(ib,1,ik) =  dta_read(ji,jj,1) 
    1066                ELSEIF( zl > MAXVAL(dta_read_z(ji,jj,:),1) ) THEN                        ! below the last level of external data  
    1067                   dta(ib,1,ik) =  dta_read(ji,jj,MAXLOC(dta_read_z(ji,jj,:),1)) 
    1068                ELSE                                                                     ! inbetween : vertical interpolation between ikk & ikk+1 
    1069                   DO ikk = 1, jpkm1_bdy                                                 ! when  gdept(ikk,Kmm) < zl < gdept(ikk+1,Kmm) 
    1070                      IF( ( (zl-dta_read_z(ji,jj,ikk)) * (zl-dta_read_z(ji,jj,ikk+1)) <= 0._wp) & 
    1071                     &    .AND. (dta_read_z(ji,jj,ikk+1) /= fv_alt)) THEN 
    1072                         zi           = ( zl - dta_read_z(ji,jj,ikk) ) / & 
    1073                        &               ( dta_read_z(ji,jj,ikk+1) - dta_read_z(ji,jj,ikk) ) 
    1074                         dta(ib,1,ik) = dta_read(ji,jj,ikk) + & 
    1075                        &               ( dta_read(ji,jj,ikk+1) - dta_read(ji,jj,ikk) ) * zi 
    1076                      ENDIF 
    1077                   END DO 
    1078                ENDIF 
    1079             END DO 
    1080          END DO 
    1081  
    1082          IF(igrd == 2) THEN                                 ! do we need to adjust the transport term? 
    1083             DO ib = 1, ipi 
    1084                jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 
    1085                ji=map%ptr(ib)-(jj-1)*ilendta 
    1086                zij = idx_bdy(ibdy)%nbi(ib,igrd) 
    1087                zjj = idx_bdy(ibdy)%nbj(ib,igrd) 
    1088                zh = SUM(dta_read_dz(ji,jj,:) ) 
    1089                ztrans = 0._wp 
    1090                ztrans_new = 0._wp 
    1091                DO ik = 1, jpk_bdy                            ! calculate transport on input grid 
    1092                   ztrans = ztrans + dta_read(ji,jj,ik) * dta_read_dz(ji,jj,ik) 
    1093                ENDDO 
    1094                DO ik = 1, ipk                                ! calculate transport on model grid 
    1095                   ztrans_new = ztrans_new + dta(ib,1,ik) * e3u(zij,zjj,ik,Kmm) * umask(zij,zjj,ik) 
    1096                ENDDO 
    1097                DO ik = 1, ipk                                ! make transport correction 
    1098                   IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data 
    1099                      dta(ib,1,ik) = ( dta(ib,1,ik) + ( ztrans - ztrans_new ) * r1_hu(zij,zjj,Kmm) ) * umask(zij,zjj,ik) 
    1100                   ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 
    1101                      dta(ib,1,ik) = ( dta(ib,1,ik) + ( 0._wp  - ztrans_new ) * r1_hu(zij,zjj,Kmm) ) * umask(zij,zjj,ik) 
    1102                   ENDIF 
    1103                ENDDO 
    1104             ENDDO 
    1105          ENDIF 
    1106  
    1107          IF(igrd == 3) THEN                                 ! do we need to adjust the transport term? 
    1108             DO ib = 1, ipi 
    1109                jj  = 1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 
    1110                ji  = map%ptr(ib)-(jj-1)*ilendta 
    1111                zij = idx_bdy(ibdy)%nbi(ib,igrd) 
    1112                zjj = idx_bdy(ibdy)%nbj(ib,igrd) 
    1113                zh  = SUM(dta_read_dz(ji,jj,:) ) 
    1114                ztrans = 0._wp 
    1115                ztrans_new = 0._wp 
    1116                DO ik = 1, jpk_bdy                            ! calculate transport on input grid 
    1117                   ztrans     = ztrans     + dta_read(ji,jj,ik) * dta_read_dz(ji,jj,ik) 
    1118                ENDDO 
    1119                DO ik = 1, ipk                                ! calculate transport on model grid 
    1120                   ztrans_new = ztrans_new + dta(ib,1,ik) * e3v(zij,zjj,ik,Kmm) * vmask(zij,zjj,ik) 
    1121                ENDDO 
    1122                DO ik = 1, ipk                                ! make transport correction 
    1123                   IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data 
    1124                      dta(ib,1,ik) = ( dta(ib,1,ik) + ( ztrans - ztrans_new ) * r1_hv(zij,zjj,Kmm) ) * vmask(zij,zjj,ik) 
    1125                   ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 
    1126                      dta(ib,1,ik) = ( dta(ib,1,ik) + ( 0._wp  - ztrans_new ) * r1_hv(zij,zjj,Kmm) ) * vmask(zij,zjj,ik) 
    1127                   ENDIF 
    1128                ENDDO 
    1129             ENDDO 
    1130          ENDIF 
    1131  
    1132       ENDIF ! endif unstructured or structured 
    1133  
     989         ENDDO 
     990      ENDIF 
     991       
    1134992   END SUBROUTINE fld_bdy_interp 
    1135993 
    … …  
    11561014      imf = SIZE( sd ) 
    11571015      DO ju = 1, imf 
     1016         IF( TRIM(sd(ju)%clrootname) == 'NOT USED' )   CYCLE 
    11581017         ill = LEN_TRIM( sd(ju)%vcomp ) 
    11591018         DO jn = 2-COUNT((/sd(ju)%ln_tint/)), 2 
    … …  
    11641023                  iv = -1 
    11651024                  DO jv = 1, imf 
     1025                     IF( TRIM(sd(jv)%clrootname) == 'NOT USED' )   CYCLE 
    11661026                     IF( TRIM(sd(jv)%vcomp) == TRIM(clcomp) )   iv = jv 
    11671027                  END DO 
    … …  
    12021062      LOGICAL, OPTIONAL, INTENT(in   ) ::   ldstop   ! stop if open to read a non-existing file (default = .TRUE.) 
    12031063      ! 
    1204       LOGICAL :: llprevyr              ! are we reading previous year  file? 
    1205       LOGICAL :: llprevmth             ! are we reading previous month file? 
    1206       INTEGER :: iyear, imonth, iday   ! first day of the current file in yyyy mm dd 
    1207       INTEGER :: isec_week             ! number of seconds since start of the weekly file 
    1208       INTEGER :: indexyr               ! year undex (O/1/2: previous/current/next) 
    1209       INTEGER :: iyear_len, imonth_len ! length (days) of iyear and imonth             !  
    1210       CHARACTER(len = 256)::   clname  ! temporary file name 
     1064      LOGICAL  :: llprevyr              ! are we reading previous year  file? 
     1065      LOGICAL  :: llprevmth             ! are we reading previous month file? 
     1066      INTEGER  :: iyear, imonth, iday   ! first day of the current file in yyyy mm dd 
     1067      INTEGER  :: isec_week             ! number of seconds since start of the weekly file 
     1068      INTEGER  :: indexyr               ! year undex (O/1/2: previous/current/next) 
     1069      REAL(wp) :: zyear_len, zmonth_len ! length (days) of iyear and imonth             !  
     1070      CHARACTER(len = 256) ::   clname  ! temporary file name 
    12111071      !!---------------------------------------------------------------------- 
    12121072      IF( PRESENT(kyear) ) THEN                             ! use given values  
    … …  
    12591119         ! find the last record to be read -> update sdjf%nreclast 
    12601120         indexyr = iyear - nyear + 1 
    1261          iyear_len = nyear_len( indexyr ) 
     1121         zyear_len = REAL(nyear_len( indexyr ), wp) 
    12621122         SELECT CASE ( indexyr ) 
    1263          CASE ( 0 )   ;   imonth_len = 31   ! previous year -> imonth = 12 
    1264          CASE ( 1 )   ;   imonth_len = nmonth_len(imonth)  
    1265          CASE ( 2 )   ;   imonth_len = 31   ! next     year -> imonth = 1 
     1123         CASE ( 0 )   ;   zmonth_len = 31.   ! previous year -> imonth = 12 
     1124         CASE ( 1 )   ;   zmonth_len = REAL(nmonth_len(imonth), wp) 
     1125         CASE ( 2 )   ;   zmonth_len = 31.   ! next     year -> imonth = 1 
    12661126         END SELECT 
    12671127         ! 
    12681128         ! last record to be read in the current file 
    1269          IF    ( sdjf%nfreqh == -12 ) THEN                 ;   sdjf%nreclast = 1    !  yearly mean 
    1270          ELSEIF( sdjf%nfreqh ==  -1 ) THEN                                          ! monthly mean 
     1129         IF    ( sdjf%freqh == -12. ) THEN                 ;   sdjf%nreclast = 1    !  yearly mean 
     1130         ELSEIF( sdjf%freqh ==  -1. ) THEN                                          ! monthly mean 
    12711131            IF(     sdjf%cltype      == 'monthly' ) THEN   ;   sdjf%nreclast = 1 
    12721132            ELSE                                           ;   sdjf%nreclast = 12 
    12731133            ENDIF 
    12741134         ELSE                                                                       ! higher frequency mean (in hours) 
    1275             IF(     sdjf%cltype      == 'monthly' ) THEN   ;   sdjf%nreclast = NINT( 24 * imonth_len / sdjf%nfreqh ) 
    1276             ELSEIF( sdjf%cltype(1:4) == 'week'    ) THEN   ;   sdjf%nreclast = NINT( 24 * 7          / sdjf%nfreqh ) 
    1277             ELSEIF( sdjf%cltype      == 'daily'   ) THEN   ;   sdjf%nreclast = NINT( 24              / sdjf%nfreqh ) 
    1278             ELSE                                           ;   sdjf%nreclast = NINT( 24 * iyear_len  / sdjf%nfreqh ) 
     1135            IF(     sdjf%cltype      == 'monthly' ) THEN   ;   sdjf%nreclast = NINT( 24. * zmonth_len / sdjf%freqh ) 
     1136            ELSEIF( sdjf%cltype(1:4) == 'week'    ) THEN   ;   sdjf%nreclast = NINT( 24. * 7.         / sdjf%freqh ) 
     1137            ELSEIF( sdjf%cltype      == 'daily'   ) THEN   ;   sdjf%nreclast = NINT( 24.              / sdjf%freqh ) 
     1138            ELSE                                           ;   sdjf%nreclast = NINT( 24. * zyear_len  / sdjf%freqh ) 
    12791139            ENDIF 
    12801140         ENDIF 
    … …  
    13041164      ! 
    13051165      DO jf = 1, SIZE(sdf) 
    1306          sdf(jf)%clrootname = TRIM( cdir )//TRIM( sdf_n(jf)%clname ) 
     1166         sdf(jf)%clrootname = sdf_n(jf)%clname 
     1167         IF( TRIM(sdf_n(jf)%clname) /= 'NOT USED' )   sdf(jf)%clrootname = TRIM( cdir )//sdf(jf)%clrootname 
    13071168         sdf(jf)%clname     = "not yet defined" 
    1308          sdf(jf)%nfreqh     = sdf_n(jf)%nfreqh 
     1169         sdf(jf)%freqh      = sdf_n(jf)%freqh 
    13091170         sdf(jf)%clvar      = sdf_n(jf)%clvar 
    13101171         sdf(jf)%ln_tint    = sdf_n(jf)%ln_tint 
    … …  
    13131174         sdf(jf)%num        = -1 
    13141175         sdf(jf)%wgtname    = " " 
    1315          IF( LEN( TRIM(sdf_n(jf)%wname) ) > 0 )   sdf(jf)%wgtname = TRIM( cdir )//TRIM( sdf_n(jf)%wname ) 
     1176         IF( LEN( TRIM(sdf_n(jf)%wname) ) > 0 )   sdf(jf)%wgtname = TRIM( cdir )//sdf_n(jf)%wname 
    13161177         sdf(jf)%lsmname = " " 
    1317          IF( LEN( TRIM(sdf_n(jf)%lname) ) > 0 )   sdf(jf)%lsmname = TRIM( cdir )//TRIM( sdf_n(jf)%lname ) 
     1178         IF( LEN( TRIM(sdf_n(jf)%lname) ) > 0 )   sdf(jf)%lsmname = TRIM( cdir )//sdf_n(jf)%lname 
    13181179         sdf(jf)%vcomp      = sdf_n(jf)%vcomp 
    13191180         sdf(jf)%rotn(:)    = .TRUE.   ! pretend to be rotated -> won't try to rotate data before the first call to fld_get 
    … …  
    13221183         IF( sdf(jf)%cltype(1:4) == 'week' .AND. sdf(jf)%ln_clim )   & 
    13231184            &   CALL ctl_stop('fld_clopn: weekly file ('//TRIM(sdf(jf)%clrootname)//') needs ln_clim = .FALSE.') 
    1324          sdf(jf)%nreclast = -1 ! Set to non zero default value to avoid errors, is updated to meaningful value during fld_clopn 
     1185         sdf(jf)%nreclast   = -1 ! Set to non zero default value to avoid errors, is updated to meaningful value during fld_clopn 
     1186         sdf(jf)%igrd       = 0 
     1187         sdf(jf)%ibdy       = 0 
     1188         sdf(jf)%imap       => NULL() 
     1189         sdf(jf)%ltotvel    = .FALSE. 
     1190         sdf(jf)%lzint      = .FALSE. 
    13251191      END DO 
    13261192      ! 
    … …  
    13361202         DO jf = 1, SIZE(sdf) 
    13371203            WRITE(numout,*) '      root filename: '  , TRIM( sdf(jf)%clrootname ), '   variable name: ', TRIM( sdf(jf)%clvar ) 
    1338             WRITE(numout,*) '         frequency: '      ,       sdf(jf)%nfreqh      ,   & 
     1204            WRITE(numout,*) '         frequency: '      ,       sdf(jf)%freqh       ,   & 
    13391205               &                  '   time interp: '    ,       sdf(jf)%ln_tint     ,   & 
    13401206               &                  '   climatology: '    ,       sdf(jf)%ln_clim 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/SBC/sbc_oce.F90

    r10425 r11822  
    119119   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qns_tot           !: total non solar heat flux (over sea and ice) [W/m2] 
    120120   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   emp    , emp_b    !: freshwater budget: volume flux               [Kg/m2/s] 
    121    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx    , sfx_b    !: salt flux                                    [PSU/m2/s] 
     121   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx    , sfx_b    !: salt flux                                    [PSS.kg/m2/s] 
    122122   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   emp_tot           !: total E-P over ocean and ice                 [Kg/m2/s] 
    123123   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fmmflx            !: freshwater budget: freezing/melting          [Kg/m2/s] 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/SBC/sbcapr.F90

    r10425 r11822  
    2626   PUBLIC   sbc_apr_init  ! routine called in sbcmod 
    2727    
    28    !                                !!* namsbc_apr namelist (Atmospheric PRessure) * 
    29    LOGICAL, PUBLIC ::   ln_apr_obc   !: inverse barometer added to OBC ssh data  
    30    LOGICAL, PUBLIC ::   ln_ref_apr   !: ref. pressure: global mean Patm (F) or a constant (F) 
    31    REAL(wp)        ::   rn_pref      !  reference atmospheric pressure   [N/m2] 
     28   !                                          !!* namsbc_apr namelist (Atmospheric PRessure) * 
     29   LOGICAL, PUBLIC ::   ln_apr_obc = .false.   !: inverse barometer added to OBC ssh data  
     30   LOGICAL, PUBLIC ::   ln_ref_apr             !: ref. pressure: global mean Patm (F) or a constant (F) 
     31   REAL(wp)        ::   rn_pref                !  reference atmospheric pressure   [N/m2] 
    3232 
    3333   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) ::   ssh_ib    ! Inverse barometer now    sea surface height   [m] 
    … …  
    7171      REWIND( numnam_ref )              ! Namelist namsbc_apr in reference namelist : File for atmospheric pressure forcing 
    7272      READ  ( numnam_ref, namsbc_apr, IOSTAT = ios, ERR = 901) 
    73 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_apr in reference namelist', lwp ) 
     73901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_apr in reference namelist' ) 
    7474 
    7575      REWIND( numnam_cfg )              ! Namelist namsbc_apr in configuration namelist : File for atmospheric pressure forcing 
    7676      READ  ( numnam_cfg, namsbc_apr, IOSTAT = ios, ERR = 902 ) 
    77 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_apr in configuration namelist', lwp ) 
     77902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_apr in configuration namelist' ) 
    7878      IF(lwm) WRITE ( numond, namsbc_apr ) 
    7979      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/SBC/sbcblk.F90

    r10535 r11822  
    182182      REWIND( numnam_ref )                !* Namelist namsbc_blk in reference namelist : bulk parameters 
    183183      READ  ( numnam_ref, namsbc_blk, IOSTAT = ios, ERR = 901) 
    184 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_blk in reference namelist', lwp ) 
     184901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_blk in reference namelist' ) 
    185185      ! 
    186186      REWIND( numnam_cfg )                !* Namelist namsbc_blk in configuration namelist : bulk parameters 
    187187      READ  ( numnam_cfg, namsbc_blk, IOSTAT = ios, ERR = 902 ) 
    188 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_blk in configuration namelist', lwp ) 
     188902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_blk in configuration namelist' ) 
    189189      ! 
    190190      IF(lwm) WRITE( numond, namsbc_blk ) 
    … …  
    201201      ! 
    202202      IF( ln_dm2dc ) THEN                 !* check: diurnal cycle on Qsr 
    203          IF( sn_qsr%nfreqh /= 24 )   CALL ctl_stop( 'sbc_blk_init: ln_dm2dc=T only with daily short-wave input' ) 
     203         IF( sn_qsr%freqh /= 24. )   CALL ctl_stop( 'sbc_blk_init: ln_dm2dc=T only with daily short-wave input' ) 
    204204         IF( sn_qsr%ln_tint ) THEN  
    205205            CALL ctl_warn( 'sbc_blk_init: ln_dm2dc=T daily qsr time interpolation done by sbcdcy module',   & 
    … …  
    225225         ALLOCATE( sf(ifpr)%fnow(jpi,jpj,1) ) 
    226226         IF( slf_i(ifpr)%ln_tint )   ALLOCATE( sf(ifpr)%fdta(jpi,jpj,1,2) ) 
    227          IF( slf_i(ifpr)%nfreqh > 0. .AND. MOD( 3600. * slf_i(ifpr)%nfreqh , REAL(nn_fsbc) * rdt) /= 0. )   & 
     227         IF( slf_i(ifpr)%freqh > 0. .AND. MOD( NINT(3600. * slf_i(ifpr)%freqh), nn_fsbc * NINT(rdt) ) /= 0 )   & 
    228228            &  CALL ctl_warn( 'sbc_blk_init: sbcmod timestep rdt*nn_fsbc is NOT a submultiple of atmospheric forcing frequency.',   & 
    229229            &                 '               This is not ideal. You should consider changing either rdt or nn_fsbc value...' ) 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/SBC/sbccpl.F90

    r11027 r11822  
    266266      REWIND( numnam_ref )              ! Namelist namsbc_cpl in reference namelist : Variables for OASIS coupling 
    267267      READ  ( numnam_ref, namsbc_cpl, IOSTAT = ios, ERR = 901) 
    268 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_cpl in reference namelist', lwp ) 
     268901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_cpl in reference namelist' ) 
    269269      ! 
    270270      REWIND( numnam_cfg )              ! Namelist namsbc_cpl in configuration namelist : Variables for OASIS coupling 
    271271      READ  ( numnam_cfg, namsbc_cpl, IOSTAT = ios, ERR = 902 ) 
    272 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_cpl in configuration namelist', lwp ) 
     272902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_cpl in configuration namelist' ) 
    273273      IF(lwm) WRITE ( numond, namsbc_cpl ) 
    274274      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/SBC/sbcflx.F90

    r10425 r11822  
    9393         REWIND( numnam_ref )              ! Namelist namsbc_flx in reference namelist : Files for fluxes 
    9494         READ  ( numnam_ref, namsbc_flx, IOSTAT = ios, ERR = 901) 
    95 901      IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_flx in reference namelist', lwp ) 
     95901      IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_flx in reference namelist' ) 
    9696 
    9797         REWIND( numnam_cfg )              ! Namelist namsbc_flx in configuration namelist : Files for fluxes 
    9898         READ  ( numnam_cfg, namsbc_flx, IOSTAT = ios, ERR = 902 ) 
    99 902      IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_flx in configuration namelist', lwp ) 
     99902      IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_flx in configuration namelist' ) 
    100100         IF(lwm) WRITE ( numond, namsbc_flx )  
    101101         ! 
    102102         !                                         ! check: do we plan to use ln_dm2dc with non-daily forcing? 
    103          IF( ln_dm2dc .AND. sn_qsr%nfreqh /= 24 )   & 
     103         IF( ln_dm2dc .AND. sn_qsr%freqh /= 24. )   & 
    104104            &   CALL ctl_stop( 'sbc_blk_core: ln_dm2dc can be activated only with daily short-wave forcing' )  
    105105         ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/SBC/sbcice_cice.F90

    r11027 r11822  
    765765         REWIND( numnam_ref )              ! Namelist namsbc_cice in reference namelist :  
    766766         READ  ( numnam_ref, namsbc_cice, IOSTAT = ios, ERR = 901) 
    767 901      IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_cice in reference namelist', lwp ) 
     767901      IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_cice in reference namelist' ) 
    768768 
    769769         REWIND( numnam_cfg )              ! Namelist namsbc_cice in configuration namelist : Parameters of the run 
    770770         READ  ( numnam_cfg, namsbc_cice, IOSTAT = ios, ERR = 902 ) 
    771 902      IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_cice in configuration namelist', lwp ) 
     771902      IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_cice in configuration namelist' ) 
    772772         IF(lwm) WRITE ( numond, namsbc_cice ) 
    773773 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/SBC/sbcice_if.F90

    r10922 r11822  
    7777         REWIND( numnam_ref )              ! Namelist namsbc_iif in reference namelist : Ice if file 
    7878         READ  ( numnam_ref, namsbc_iif, IOSTAT = ios, ERR = 901) 
    79 901      IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_iif in reference namelist', lwp ) 
     79901      IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_iif in reference namelist' ) 
    8080 
    8181         REWIND( numnam_cfg )              ! Namelist Namelist namsbc_iif in configuration namelist : Ice if file 
    8282         READ  ( numnam_cfg, namsbc_iif, IOSTAT = ios, ERR = 902 ) 
    83 902      IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_iif in configuration namelist', lwp ) 
     83902      IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_iif in configuration namelist' ) 
    8484         IF(lwm) WRITE ( numond, namsbc_iif ) 
    8585 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/SBC/sbcisf.F90

    r11027 r11822  
    280280      REWIND( numnam_ref )              ! Namelist namsbc_rnf in reference namelist : Runoffs  
    281281      READ  ( numnam_ref, namsbc_isf, IOSTAT = ios, ERR = 901) 
    282 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_isf in reference namelist', lwp ) 
     282901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_isf in reference namelist' ) 
    283283 
    284284      REWIND( numnam_cfg )              ! Namelist namsbc_rnf in configuration namelist : Runoffs 
    285285      READ  ( numnam_cfg, namsbc_isf, IOSTAT = ios, ERR = 902 ) 
    286 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_isf in configuration namelist', lwp ) 
     286902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_isf in configuration namelist' ) 
    287287      IF(lwm) WRITE ( numond, namsbc_isf ) 
    288288 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/SBC/sbcmod.F90

    r11480 r11822  
    111111      REWIND( numnam_ref )          !* Namelist namsbc in reference namelist : Surface boundary 
    112112      READ  ( numnam_ref, namsbc, IOSTAT = ios, ERR = 901) 
    113 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc in reference namelist', lwp ) 
     113901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc in reference namelist' ) 
    114114      REWIND( numnam_cfg )          !* Namelist namsbc in configuration namelist : Parameters of the run 
    115115      READ  ( numnam_cfg, namsbc, IOSTAT = ios, ERR = 902 ) 
    116 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc in configuration namelist', lwp ) 
     116902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc in configuration namelist' ) 
    117117      IF(lwm) WRITE( numond, namsbc ) 
    118118      ! 
    … …  
    309309      ! 
    310310      !                             !* check consistency between model timeline and nn_fsbc 
    311       IF( MOD( nitend - nit000 + 1, nn_fsbc) /= 0 .OR.   & 
    312           MOD( nstock             , nn_fsbc) /= 0 ) THEN 
    313          WRITE(ctmp1,*) 'sbc_init : experiment length (', nitend - nit000 + 1, ') or nstock (', nstock,   & 
    314             &           ' is NOT a multiple of nn_fsbc (', nn_fsbc, ')' 
    315          CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' ) 
     311      IF( ln_rst_list .OR. nn_stock /= -1 ) THEN   ! we will do restart files 
     312         IF( MOD( nitend - nit000 + 1, nn_fsbc) /= 0 ) THEN 
     313            WRITE(ctmp1,*) 'sbc_init : experiment length (', nitend - nit000 + 1, ') is NOT a multiple of nn_fsbc (', nn_fsbc, ')' 
     314            CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' ) 
     315         ENDIF 
     316         IF( .NOT. ln_rst_list .AND. MOD( nn_stock, nn_fsbc) /= 0 ) THEN   ! we don't use nn_stock if ln_rst_list 
     317            WRITE(ctmp1,*) 'sbc_init : nn_stock (', nn_stock, ') is NOT a multiple of nn_fsbc (', nn_fsbc, ')' 
     318            CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' ) 
     319         ENDIF 
    316320      ENDIF 
    317321      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/SBC/sbcrnf.F90

    r10922 r11822  
    269269      REWIND( numnam_ref )              ! Namelist namsbc_rnf in reference namelist : Runoffs  
    270270      READ  ( numnam_ref, namsbc_rnf, IOSTAT = ios, ERR = 901) 
    271 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_rnf in reference namelist', lwp ) 
     271901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_rnf in reference namelist' ) 
    272272 
    273273      REWIND( numnam_cfg )              ! Namelist namsbc_rnf in configuration namelist : Runoffs 
    274274      READ  ( numnam_cfg, namsbc_rnf, IOSTAT = ios, ERR = 902 ) 
    275 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_rnf in configuration namelist', lwp ) 
     275902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_rnf in configuration namelist' ) 
    276276      IF(lwm) WRITE ( numond, namsbc_rnf ) 
    277277      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/SBC/sbcssr.F90

    r10068 r11822  
    166166      REWIND( numnam_ref )              ! Namelist namsbc_ssr in reference namelist :  
    167167      READ  ( numnam_ref, namsbc_ssr, IOSTAT = ios, ERR = 901) 
    168 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_ssr in reference namelist', lwp ) 
     168901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_ssr in reference namelist' ) 
    169169 
    170170      REWIND( numnam_cfg )              ! Namelist namsbc_ssr in configuration namelist : 
    171171      READ  ( numnam_cfg, namsbc_ssr, IOSTAT = ios, ERR = 902 ) 
    172 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_ssr in configuration namelist', lwp ) 
     172902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_ssr in configuration namelist' ) 
    173173      IF(lwm) WRITE ( numond, namsbc_ssr ) 
    174174 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/SBC/sbcwave.F90

    r10922 r11822  
    399399      REWIND( numnam_ref )              ! Namelist namsbc_wave in reference namelist : File for drag coeff. from wave model 
    400400      READ  ( numnam_ref, namsbc_wave, IOSTAT = ios, ERR = 901) 
    401 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_wave in reference namelist', lwp ) 
     401901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_wave in reference namelist' ) 
    402402          
    403403      REWIND( numnam_cfg )              ! Namelist namsbc_wave in configuration namelist : File for drag coeff. from wave model 
    404404      READ  ( numnam_cfg, namsbc_wave, IOSTAT = ios, ERR = 902 ) 
    405 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_wave in configuration namelist', lwp ) 
     405902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_wave in configuration namelist' ) 
    406406      IF(lwm) WRITE ( numond, namsbc_wave ) 
    407407      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/SBC/tideini.F90

    r10068 r11822  
    6060      REWIND( numnam_ref )              ! Namelist nam_tide in reference namelist : Tides 
    6161      READ  ( numnam_ref, nam_tide, IOSTAT = ios, ERR = 901) 
    62 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nam_tide in reference namelist', lwp ) 
     62901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nam_tide in reference namelist' ) 
    6363      ! 
    6464      REWIND( numnam_cfg )              ! Namelist nam_tide in configuration namelist : Tides 
    6565      READ  ( numnam_cfg, nam_tide, IOSTAT = ios, ERR = 902 ) 
    66 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nam_tide in configuration namelist', lwp ) 
     66902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nam_tide in configuration namelist' ) 
    6767      IF(lwm) WRITE ( numond, nam_tide ) 
    6868      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/SBC/updtide.F90

    r10068 r11822  
    2727CONTAINS 
    2828 
    29    SUBROUTINE upd_tide( kt, kit, time_offset ) 
     29   SUBROUTINE upd_tide( kt, kit, kt_offset ) 
    3030      !!---------------------------------------------------------------------- 
    3131      !!                 ***  ROUTINE upd_tide  *** 
    … …  
    3939      INTEGER, INTENT(in)           ::   kt      ! ocean time-step index 
    4040      INTEGER, INTENT(in), OPTIONAL ::   kit     ! external mode sub-time-step index (lk_dynspg_ts=T) 
    41       INTEGER, INTENT(in), OPTIONAL ::   time_offset ! time offset in number  
     41      INTEGER, INTENT(in), OPTIONAL ::   kt_offset ! time offset in number  
    4242                                                     ! of internal steps             (lk_dynspg_ts=F) 
    4343                                                     ! of external steps             (lk_dynspg_ts=T) 
    4444      ! 
    45       INTEGER  ::   joffset      ! local integer 
     45      INTEGER  ::   ioffset      ! local integer 
    4646      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    4747      REAL(wp) ::   zt, zramp    ! local scalar 
    … …  
    5252      zt = ( kt - kt_tide ) * rdt 
    5353      ! 
    54       joffset = 0 
    55       IF( PRESENT( time_offset ) )   joffset = time_offset 
     54      ioffset = 0 
     55      IF( PRESENT( kt_offset ) )   ioffset = kt_offset 
    5656      ! 
    5757      IF( PRESENT( kit ) )   THEN 
    58          zt = zt + ( kit +  joffset - 1 ) * rdt / REAL( nn_baro, wp ) 
     58         zt = zt + ( kit +  ioffset - 1 ) * rdt / REAL( nn_baro, wp ) 
    5959      ELSE 
    60          zt = zt + joffset * rdt 
     60         zt = zt + ioffset * rdt 
    6161      ENDIF 
    6262      ! 
    … …  
    7070      IF( ln_tide_ramp ) THEN         ! linear increase if asked 
    7171         zt = ( kt - nit000 ) * rdt 
    72          IF( PRESENT( kit ) )   zt = zt + ( kit + joffset -1) * rdt / REAL( nn_baro, wp ) 
     72         IF( PRESENT( kit ) )   zt = zt + ( kit + ioffset -1) * rdt / REAL( nn_baro, wp ) 
    7373         zramp = MIN(  MAX( zt / (rdttideramp*rday) , 0._wp ) , 1._wp  ) 
    7474         pot_astro(:,:) = zramp * pot_astro(:,:) 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/STO/stopar.F90

    r10425 r11822  
    263263      REWIND( numnam_ref )              ! Namelist namdyn_adv in reference namelist : Momentum advection scheme 
    264264      READ  ( numnam_ref, namsto, IOSTAT = ios, ERR = 901) 
    265 901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsto in reference namelist', lwp ) 
     265901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsto in reference namelist' ) 
    266266 
    267267      REWIND( numnam_cfg )              ! Namelist namdyn_adv in configuration namelist : Momentum advection scheme 
    268268      READ  ( numnam_cfg, namsto, IOSTAT = ios, ERR = 902 ) 
    269 902   IF( ios >  0 ) CALL ctl_nam ( ios , 'namsto in configuration namelist', lwp ) 
     269902   IF( ios >  0 ) CALL ctl_nam ( ios , 'namsto in configuration namelist' ) 
    270270      IF(lwm) WRITE ( numond, namsto ) 
    271271 
    272       IF( .NOT.ln_rststo ) THEN   ! no use of stochastic parameterization 
     272      IF( .NOT.ln_sto_eos ) THEN   ! no use of stochastic parameterization 
    273273         IF(lwp) THEN 
    274274            WRITE(numout,*) 
    … …  
    750750      CHARACTER(LEN=9)    ::   clsto3d='sto3d_000' ! stochastic parameter variable name 
    751751      CHARACTER(LEN=10)   ::   clseed='seed0_0000' ! seed variable name 
    752  
     752      !!---------------------------------------------------------------------- 
     753 
     754      IF( .NOT. ln_rst_list .AND. nn_stock == -1 ) RETURN   ! we will never do any restart 
     755       
    753756      IF ( jpsto2d > 0 .OR. jpsto3d > 0 ) THEN 
    754757 
    … …  
    790793         ! Open the restart file one timestep before writing restart 
    791794         IF( kt < nitend) THEN 
    792          IF( kt == nitrst - 1 .OR. nstock == 1 .OR. kt == nitend-1 ) THEN 
     795         IF( kt == nitrst - 1 .OR. nn_stock == 1 .OR. kt == nitend-1 ) THEN 
    793796            ! create the filename 
    794797            IF( nitrst > 999999999 ) THEN   ;   WRITE(clkt, *       ) nitrst 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/TRA/eosbn2.F90

    r10954 r11822  
    3030   !!   eos_insitu_2d : Compute the in situ density for 2d fields 
    3131   !!   bn2           : Compute the Brunt-Vaisala frequency 
     32   !!   bn2           : compute the Brunt-Vaisala frequency 
     33   !!   eos_pt_from_ct: compute the potential temperature from the Conservative Temperature 
    3234   !!   eos_rab       : generic interface of in situ thermal/haline expansion ratio  
    3335   !!   eos_rab_3d    : compute in situ thermal/haline expansion ratio 
    … …  
    7476 
    7577   !                               !!** Namelist nameos ** 
    76    LOGICAL , PUBLIC ::   ln_TEOS10   ! determine if eos_pt_from_ct is used to compute sst_m 
    77    LOGICAL , PUBLIC ::   ln_EOS80   ! determine if eos_pt_from_ct is used to compute sst_m 
    78    LOGICAL , PUBLIC ::   ln_SEOS   ! determine if eos_pt_from_ct is used to compute sst_m 
     78   LOGICAL , PUBLIC ::   ln_TEOS10 
     79   LOGICAL , PUBLIC ::   ln_EOS80 
     80   LOGICAL , PUBLIC ::   ln_SEOS 
    7981 
    8082   ! Parameters 
    … …  
    12401242      REWIND( numnam_ref )              ! Namelist nameos in reference namelist : equation of state 
    12411243      READ  ( numnam_ref, nameos, IOSTAT = ios, ERR = 901 ) 
    1242 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nameos in reference namelist', lwp ) 
     1244901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nameos in reference namelist' ) 
    12431245      ! 
    12441246      REWIND( numnam_cfg )              ! Namelist nameos in configuration namelist : equation of state 
    12451247      READ  ( numnam_cfg, nameos, IOSTAT = ios, ERR = 902 ) 
    1246 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nameos in configuration namelist', lwp ) 
     1248902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nameos in configuration namelist' ) 
    12471249      IF(lwm) WRITE( numond, nameos ) 
    12481250      ! 
    … …  
    16521654         ! 
    16531655      CASE( np_seos )                        !==  Simplified EOS     ==! 
     1656 
     1657         r1_S0  = 0.875_wp/35.16504_wp   ! Used to convert CT in potential temperature when using bulk formulae (eos_pt_from_ct) 
     1658          
    16541659         IF(lwp) THEN 
    16551660            WRITE(numout,*) 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/TRA/traadv.F90

    r10965 r11822  
    198198      REWIND( numnam_ref )                   ! Namelist namtra_adv in reference namelist : Tracer advection scheme 
    199199      READ  ( numnam_ref, namtra_adv, IOSTAT = ios, ERR = 901) 
    200 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_adv in reference namelist', lwp ) 
     200901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_adv in reference namelist' ) 
    201201      ! 
    202202      REWIND( numnam_cfg )                   ! Namelist namtra_adv in configuration namelist : Tracer advection scheme 
    203203      READ  ( numnam_cfg, namtra_adv, IOSTAT = ios, ERR = 902 ) 
    204 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_adv in configuration namelist', lwp ) 
     204902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_adv in configuration namelist' ) 
    205205      IF(lwm) WRITE( numond, namtra_adv ) 
    206206      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/TRA/traadv_fct.F90

    r10946 r11822  
    2121   USE diaar5         ! AR5 diagnostics 
    2222   USE phycst  , ONLY : rau0_rcp 
     23   USE zdf_oce , ONLY : ln_zad_Aimp 
    2324   ! 
    2425   USE in_out_manager ! I/O manager 
    … …  
    8687      REAL(wp), DIMENSION(jpi,jpj,jpk)        ::   zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw 
    8788      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztrdx, ztrdy, ztrdz, zptry 
     89      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   zwinf, zwdia, zwsup 
     90      LOGICAL  ::   ll_zAimp                                 ! flag to apply adaptive implicit vertical advection 
    8891      !!---------------------------------------------------------------------- 
    8992      ! 
    … …  
    97100      l_hst = .FALSE. 
    98101      l_ptr = .FALSE. 
     102      ll_zAimp = .FALSE. 
    99103      IF( ( cdtype =='TRA' .AND. l_trdtra  ) .OR. ( cdtype =='TRC' .AND. l_trdtrc ) )       l_trd = .TRUE. 
    100104      IF(   cdtype =='TRA' .AND. ln_diaptr )                                                l_ptr = .TRUE.  
    … …  
    116120      ! 
    117121      zwi(:,:,:) = 0._wp         
     122      ! 
     123      ! If adaptive vertical advection, check if it is needed on this PE at this time 
     124      IF( ln_zad_Aimp ) THEN 
     125         IF( MAXVAL( ABS( wi(:,:,:) ) ) > 0._wp ) ll_zAimp = .TRUE. 
     126      END IF 
     127      ! If active adaptive vertical advection, build tridiagonal matrix 
     128      IF( ll_zAimp ) THEN 
     129         ALLOCATE(zwdia(jpi,jpj,jpk), zwinf(jpi,jpj,jpk),zwsup(jpi,jpj,jpk)) 
     130         DO jk = 1, jpkm1 
     131            DO jj = 2, jpjm1 
     132               DO ji = fs_2, fs_jpim1   ! vector opt. (ensure same order of calculation as below if wi=0.) 
     133                  zwdia(ji,jj,jk) =  1._wp + p2dt * ( MAX( wi(ji,jj,jk  ) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) ) / e3t(ji,jj,jk,Krhs) 
     134                  zwinf(ji,jj,jk) =  p2dt * MIN( wi(ji,jj,jk  ) , 0._wp ) / e3t(ji,jj,jk,Krhs) 
     135                  zwsup(ji,jj,jk) = -p2dt * MAX( wi(ji,jj,jk+1) , 0._wp ) / e3t(ji,jj,jk,Krhs) 
     136               END DO 
     137            END DO 
     138         END DO 
     139      END IF 
    118140      ! 
    119141      DO jn = 1, kjpt            !==  loop over the tracers  ==! 
    … …  
    169191            END DO 
    170192         END DO 
     193          
     194         IF ( ll_zAimp ) THEN 
     195            CALL tridia_solver( zwdia, zwsup, zwinf, zwi, zwi , 0 ) 
     196            ! 
     197            ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp ; 
     198            DO jk = 2, jpkm1        ! Interior value ( multiplied by wmask) 
     199               DO jj = 2, jpjm1 
     200                  DO ji = fs_2, fs_jpim1   ! vector opt.   
     201                     zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 
     202                     zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 
     203                     ztw(ji,jj,jk) =  0.5 * e1e2t(ji,jj) * ( zfp_wk * zwi(ji,jj,jk) + zfm_wk * zwi(ji,jj,jk-1) ) * wmask(ji,jj,jk) 
     204                     zwz(ji,jj,jk) = zwz(ji,jj,jk) + ztw(ji,jj,jk) ! update vertical fluxes 
     205                  END DO 
     206               END DO 
     207            END DO 
     208            DO jk = 1, jpkm1 
     209               DO jj = 2, jpjm1 
     210                  DO ji = fs_2, fs_jpim1   ! vector opt.   
     211                     pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji  ,jj  ,jk+1) ) & 
     212                        &                                        * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     213                  END DO 
     214               END DO 
     215            END DO 
     216            ! 
     217         END IF 
    171218         !                 
    172219         IF( l_trd .OR. l_hst )  THEN             ! trend diagnostics (contribution of upstream fluxes) 
    … …  
    277324            zwz(:,:,1) = 0._wp   ! only ocean surface as interior zwz values have been w-masked 
    278325         ENDIF 
     326         !          
     327         IF ( ll_zAimp ) THEN 
     328            DO jk = 1, jpkm1     !* trend and after field with monotonic scheme 
     329               DO jj = 2, jpjm1 
     330                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     331                     !                             ! total intermediate advective trends 
     332                     ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     333                        &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
     334                        &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) * r1_e1e2t(ji,jj) 
     335                     ztw(ji,jj,jk)  = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) 
     336                  END DO 
     337               END DO 
     338            END DO 
     339            ! 
     340            CALL tridia_solver( zwdia, zwsup, zwinf, ztw, ztw , 0 ) 
     341            ! 
     342            DO jk = 2, jpkm1        ! Interior value ( multiplied by wmask) 
     343               DO jj = 2, jpjm1 
     344                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     345                     zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 
     346                     zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 
     347                     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) 
     348                  END DO 
     349               END DO 
     350            END DO 
     351         END IF 
    279352         ! 
    280353         CALL lbc_lnk_multi( 'traadv_fct', zwi, 'T', 1., zwx, 'U', -1. , zwy, 'V', -1.,  zwz, 'W',  1. ) 
    … …  
    289362            DO jj = 2, jpjm1 
    290363               DO ji = fs_2, fs_jpim1   ! vector opt.   
    291                   pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
    292                      &                                   + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
    293                      &                                   + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) & 
    294                      &                                * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    295                END DO 
    296             END DO 
    297          END DO 
     364                  ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     365                     &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
     366                     &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) * r1_e1e2t(ji,jj) 
     367                  pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra / e3t(ji,jj,jk,Kmm) 
     368                  zwi(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) 
     369               END DO 
     370            END DO 
     371         END DO 
     372         ! 
     373         IF ( ll_zAimp ) THEN 
     374            ! 
     375            ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp 
     376            DO jk = 2, jpkm1        ! Interior value ( multiplied by wmask) 
     377               DO jj = 2, jpjm1 
     378                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     379                     zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 
     380                     zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 
     381                     ztw(ji,jj,jk) = - 0.5 * e1e2t(ji,jj) * ( zfp_wk * zwi(ji,jj,jk) + zfm_wk * zwi(ji,jj,jk-1) ) * wmask(ji,jj,jk) 
     382                     zwz(ji,jj,jk) = zwz(ji,jj,jk) + ztw(ji,jj,jk) ! Update vertical fluxes for trend diagnostic 
     383                  END DO 
     384               END DO 
     385            END DO 
     386            DO jk = 1, jpkm1 
     387               DO jj = 2, jpjm1 
     388                  DO ji = fs_2, fs_jpim1   ! vector opt.   
     389                     pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji  ,jj  ,jk+1) ) & 
     390                        &                                        * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     391                  END DO 
     392               END DO 
     393            END DO 
     394         END IF          
    298395         ! 
    299396         IF( l_trd .OR. l_hst ) THEN   ! trend diagnostics // heat/salt transport 
    … …  
    318415      END DO                     ! end of tracer loop 
    319416      ! 
     417      IF ( ll_zAimp ) THEN 
     418         DEALLOCATE( zwdia, zwinf, zwsup ) 
     419      ENDIF 
    320420      IF( l_trd .OR. l_hst ) THEN  
    321421         DEALLOCATE( ztrdx, ztrdy, ztrdz ) 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/TRA/trabbc.F90

    r10985 r11822  
    137137      REWIND( numnam_ref )              ! Namelist nambbc in reference namelist : Bottom momentum boundary condition 
    138138      READ  ( numnam_ref, nambbc, IOSTAT = ios, ERR = 901) 
    139 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambbc in reference namelist', lwp ) 
     139901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambbc in reference namelist' ) 
    140140      ! 
    141141      REWIND( numnam_cfg )              ! Namelist nambbc in configuration namelist : Bottom momentum boundary condition 
    142142      READ  ( numnam_cfg, nambbc, IOSTAT = ios, ERR = 902 ) 
    143 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambbc in configuration namelist', lwp ) 
     143902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambbc in configuration namelist' ) 
    144144      IF(lwm) WRITE ( numond, nambbc ) 
    145145      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/TRA/trabbl.F90

    r10985 r11822  
    490490      REWIND( numnam_ref )              ! Namelist nambbl in reference namelist : Bottom boundary layer scheme 
    491491      READ  ( numnam_ref, nambbl, IOSTAT = ios, ERR = 901) 
    492 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambbl in reference namelist', lwp ) 
     492901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambbl in reference namelist' ) 
    493493      ! 
    494494      REWIND( numnam_cfg )              ! Namelist nambbl in configuration namelist : Bottom boundary layer scheme 
    495495      READ  ( numnam_cfg, nambbl, IOSTAT = ios, ERR = 902 ) 
    496 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambbl in configuration namelist', lwp ) 
     496902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambbl in configuration namelist' ) 
    497497      IF(lwm) WRITE ( numond, nambbl ) 
    498498      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/TRA/tradmp.F90

    r10985 r11822  
    182182      REWIND( numnam_ref )   ! Namelist namtra_dmp in reference namelist : T & S relaxation 
    183183      READ  ( numnam_ref, namtra_dmp, IOSTAT = ios, ERR = 901) 
    184 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_dmp in reference namelist', lwp ) 
     184901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_dmp in reference namelist' ) 
    185185      ! 
    186186      REWIND( numnam_cfg )   ! Namelist namtra_dmp in configuration namelist : T & S relaxation 
    187187      READ  ( numnam_cfg, namtra_dmp, IOSTAT = ios, ERR = 902 ) 
    188 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_dmp in configuration namelist', lwp ) 
     188902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_dmp in configuration namelist' ) 
    189189      IF(lwm) WRITE ( numond, namtra_dmp ) 
    190190      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/TRA/traldf_iso.F90

    r10980 r11822  
    290290         !!---------------------------------------------------------------------- 
    291291         ! 
    292          ztfw(1,:,:) = 0._wp     ;     ztfw(jpi,:,:) = 0._wp 
     292         ztfw(fs_2:1,:,:) = 0._wp     ;     ztfw(jpi:fs_jpim1,:,:) = 0._wp   ! avoid to potentially manipulate NaN values 
    293293         ! 
    294294         ! Vertical fluxes 
    … …  
    324324         IF( ln_traldf_lap ) THEN               ! laplacian case: eddy coef = ah_wslp2 - akz 
    325325            DO jk = 2, jpkm1        
    326                DO jj = 1, jpjm1 
     326               DO jj = 2, jpjm1 
    327327                  DO ji = fs_2, fs_jpim1 
    328328                     ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk)   & 
    … …  
    337337            CASE(  1  )                            ! 1st pass : eddy coef = ah_wslp2 
    338338               DO jk = 2, jpkm1  
    339                   DO jj = 1, jpjm1 
     339                  DO jj = 2, jpjm1 
    340340                     DO ji = fs_2, fs_jpim1 
    341341                        ztfw(ji,jj,jk) = ztfw(ji,jj,jk)                       & 
    … …  
    347347            CASE(  2  )                         ! 2nd pass : eddy flux = ah_wslp2 and akz applied on pt  and pt2 gradients, resp. 
    348348               DO jk = 2, jpkm1  
    349                   DO jj = 1, jpjm1 
     349                  DO jj = 2, jpjm1 
    350350                     DO ji = fs_2, fs_jpim1 
    351351                        ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk)                  & 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/TRA/tramle.F90

    r10954 r11822  
    269269      REWIND( numnam_ref )              ! Namelist namtra_mle in reference namelist : Tracer advection scheme 
    270270      READ  ( numnam_ref, namtra_mle, IOSTAT = ios, ERR = 901) 
    271 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_mle in reference namelist', lwp ) 
     271901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_mle in reference namelist' ) 
    272272 
    273273      REWIND( numnam_cfg )              ! Namelist namtra_mle in configuration namelist : Tracer advection scheme 
    274274      READ  ( numnam_cfg, namtra_mle, IOSTAT = ios, ERR = 902 ) 
    275 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_mle in configuration namelist', lwp ) 
     275902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_mle in configuration namelist' ) 
    276276      IF(lwm) WRITE ( numond, namtra_mle ) 
    277277 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/TRA/traqsr.F90

    r10985 r11822  
    170170               DO jj = 2, jpjm1                       ! Separation in R-G-B depending of the surface Chl 
    171171                  DO ji = fs_2, fs_jpim1 
    172                      zchl    = sf_chl(1)%fnow(ji,jj,1) 
     172                     zchl    = MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) 
    173173                     zCtot   = 40.6  * zchl**0.459 
    174174                     zze     = 568.2 * zCtot**(-0.746) 
    … …  
    340340      REWIND( numnam_ref )              ! Namelist namtra_qsr in reference     namelist 
    341341      READ  ( numnam_ref, namtra_qsr, IOSTAT = ios, ERR = 901) 
    342 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_qsr in reference namelist', lwp ) 
     342901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_qsr in reference namelist' ) 
    343343      ! 
    344344      REWIND( numnam_cfg )              ! Namelist namtra_qsr in configuration namelist 
    345345      READ  ( numnam_cfg, namtra_qsr, IOSTAT = ios, ERR = 902 ) 
    346 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_qsr in configuration namelist', lwp ) 
     346902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_qsr in configuration namelist' ) 
    347347      IF(lwm) WRITE ( numond, namtra_qsr ) 
    348348      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/TRD/trdini.F90

    r10946 r11822  
    4949      REWIND( numnam_ref )              ! Namelist namtrd in reference namelist : trends diagnostic 
    5050      READ  ( numnam_ref, namtrd, IOSTAT = ios, ERR = 901 ) 
    51 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtrd in reference namelist', lwp ) 
     51901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtrd in reference namelist' ) 
    5252      ! 
    5353      REWIND( numnam_cfg )              ! Namelist namtrd in configuration namelist : trends diagnostic 
    5454      READ  ( numnam_cfg, namtrd, IOSTAT = ios, ERR = 902 ) 
    55 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtrd in configuration namelist', lwp ) 
     55902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtrd in configuration namelist' ) 
    5656      IF(lwm) WRITE( numond, namtrd ) 
    5757      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/TRD/trdmxl.F90

    r10946 r11822  
    735735      REWIND( numnam_ref )              ! Namelist namtrd_mxl in reference namelist : mixed layer trends diagnostic 
    736736      READ  ( numnam_ref, namtrd_mxl, IOSTAT = ios, ERR = 901 ) 
    737 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtrd_mxl in reference namelist', lwp ) 
     737901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtrd_mxl in reference namelist' ) 
    738738 
    739739      REWIND( numnam_cfg )              ! Namelist namtrd_mxl in configuration namelist : mixed layer trends diagnostic 
    740740      READ  ( numnam_cfg, namtrd_mxl, IOSTAT = ios, ERR = 902 ) 
    741 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtrd_mxl in configuration namelist', lwp ) 
     741902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtrd_mxl in configuration namelist' ) 
    742742      IF(lwm) WRITE( numond, namtrd_mxl ) 
    743743      ! 
    … …  
    765765 
    766766      IF( MOD( nitend, nn_trd ) /= 0 ) THEN 
    767          WRITE(numout,cform_err) 
    768          WRITE(numout,*) '                Your nitend parameter, nitend = ', nitend 
    769          WRITE(numout,*) '                is no multiple of the trends diagnostics frequency        ' 
    770          WRITE(numout,*) '                          you defined, nn_trd   = ', nn_trd 
    771          WRITE(numout,*) '                This will not allow you to restart from this simulation.  ' 
    772          WRITE(numout,*) '                You should reconsider this choice.                        '  
    773          WRITE(numout,*)  
    774          WRITE(numout,*) '                N.B. the nitend parameter is also constrained to be a     ' 
    775          WRITE(numout,*) '                     multiple of the nn_fsbc parameter ' 
    776          CALL ctl_stop( 'trd_mxl_init: see comment just above' ) 
     767         WRITE(ctmp1,*) '                Your nitend parameter, nitend = ', nitend 
     768         WRITE(ctmp2,*) '                is no multiple of the trends diagnostics frequency        ' 
     769         WRITE(ctmp3,*) '                          you defined, nn_trd   = ', nn_trd 
     770         WRITE(ctmp4,*) '                This will not allow you to restart from this simulation.  ' 
     771         WRITE(ctmp5,*) '                You should reconsider this choice.                        '  
     772         WRITE(ctmp6,*)  
     773         WRITE(ctmp7,*) '                N.B. the nitend parameter is also constrained to be a     ' 
     774         WRITE(ctmp8,*) '                     multiple of the nn_fsbc parameter ' 
     775         CALL ctl_stop( ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 ) 
    777776      END IF 
    778777 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/TRD/trdmxl_rst.F90

    r10425 r11822  
    4747      !!-------------------------------------------------------------------------------- 
    4848 
     49      IF( .NOT. ln_rst_list .AND. nn_stock == -1 )   RETURN   ! we will never do any restart 
     50 
    4951      ! to get better performances with NetCDF format: 
    5052      ! we open and define the ocean restart_mxl file one time step before writing the data (-> at nitrst - 1) 
    5153      ! except if we write ocean restart_mxl files every time step or if an ocean restart_mxl file was writen at nitend - 1 
    52       IF( kt == nitrst - 1 .OR. nstock == 1 .OR. ( kt == nitend .AND. MOD( nitend - 1, nstock ) == 0 ) ) THEN 
     54      IF( kt == nitrst - 1 .OR. nn_stock == 1 .OR. ( kt == nitend .AND. MOD( nitend - 1, nn_stock ) == 0 ) ) THEN 
    5355         ! beware of the format used to write kt (default is i8.8, that should be large enough...) 
    5456         IF( nitrst > 999999999 ) THEN   ;   WRITE(clkt, *       ) nitrst 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/TRD/trdvor.F90

    r11480 r11822  
    4646   REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   vor_avr      ! average 
    4747   REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   vor_avrb     ! before vorticity (kt-1) 
    48    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   vor_avrbb    ! vorticity at begining of the nwrite-1 timestep averaging period 
     48   REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   vor_avrbb    ! vorticity at begining of the nn_write-1 timestep averaging period 
    4949   REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   vor_avrbn    ! after vorticity at time step after the 
    50    REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   rotot        ! begining of the NWRITE-1 timesteps 
     50   REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   rotot        ! begining of the NN_WRITE-1 timesteps 
    5151   REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   vor_avrtot   ! 
    5252   REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   vor_avrres   ! 
    … …  
    130130      !!              from ocean surface down to control surface (NetCDF output) 
    131131      !! 
    132       !! ** Method/usage :   integration done over nwrite-1 time steps 
     132      !! ** Method/usage :   integration done over nn_write-1 time steps 
    133133      !! 
    134134      !! ** Action :   trends : 
    … …  
    144144      !!                  vortrd (,,10) = forcing term 
    145145      !!                  vortrd (,,11) = bottom friction term 
    146       !!                  rotot(,) : total cumulative trends over nwrite-1 time steps 
     146      !!                  rotot(,) : total cumulative trends over nn_write-1 time steps 
    147147      !!                  vor_avrtot(,) : first membre of vrticity equation 
    148148      !!                  vor_avrres(,) : residual = dh/dt entrainment 
    … …  
    216216      !!              from ocean surface down to control surface (NetCDF output) 
    217217      !! 
    218       !! ** Method/usage :   integration done over nwrite-1 time steps 
     218      !! ** Method/usage :   integration done over nn_write-1 time steps 
    219219      !! 
    220220      !! ** Action :     trends : 
    … …  
    230230      !!                  vortrd (,,10) = forcing term 
    231231      !!      vortrd (,,11) = bottom friction term 
    232       !!                  rotot(,) : total cumulative trends over nwrite-1 time steps 
     232      !!                  rotot(,) : total cumulative trends over nn_write-1 time steps 
    233233      !!                  vor_avrtot(,) : first membre of vrticity equation 
    234234      !!                  vor_avrres(,) : residual = dh/dt entrainment 
    … …  
    364364      ENDIF 
    365365 
    366       ! II.2 cumulated trends over analysis period (kt=2 to nwrite) 
     366      ! II.2 cumulated trends over analysis period (kt=2 to nn_write) 
    367367      ! ---------------------- 
    368       ! trends cumulated over nwrite-2 time steps 
     368      ! trends cumulated over nn_write-2 time steps 
    369369 
    370370      IF( kt >= nit000+2 ) THEN 
    … …  
    380380      !   III. Output in netCDF + residual computation 
    381381      !  ============================================= 
    382  
     382       
    383383      ! define time axis 
    384384      it    = kt 
    … …  
    508508      ENDIF 
    509509#if defined key_diainstant 
    510       zsto = nwrite*rdt 
     510      zsto = nn_write*rdt 
    511511      clop = "inst("//TRIM(clop)//")" 
    512512#else 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/USR/usrdef_nam.F90

    r10069 r11822  
    3737CONTAINS 
    3838 
    39    SUBROUTINE usr_def_nam( ldtxt, ldnam, cd_cfg, kk_cfg, kpi, kpj, kpk, kperio ) 
     39   SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio ) 
    4040      !!---------------------------------------------------------------------- 
    4141      !!                     ***  ROUTINE dom_nam  *** 
    … …  
    4949      !! ** input   : - namusr_def namelist found in namelist_cfg 
    5050      !!---------------------------------------------------------------------- 
    51       CHARACTER(len=*), DIMENSION(:), INTENT(out) ::   ldtxt, ldnam    ! stored print information 
    52       CHARACTER(len=*)              , INTENT(out) ::   cd_cfg          ! configuration name 
    53       INTEGER                       , INTENT(out) ::   kk_cfg          ! configuration resolution 
    54       INTEGER                       , INTENT(out) ::   kpi, kpj, kpk   ! global domain sizes  
    55       INTEGER                       , INTENT(out) ::   kperio          ! lateral global domain b.c.  
     51      CHARACTER(len=*), INTENT(out) ::   cd_cfg          ! configuration name 
     52      INTEGER         , INTENT(out) ::   kk_cfg          ! configuration resolution 
     53      INTEGER         , INTENT(out) ::   kpi, kpj, kpk   ! global domain sizes  
     54      INTEGER         , INTENT(out) ::   kperio          ! lateral global domain b.c.  
    5655      ! 
    57       INTEGER ::   ios, ii   ! Local integer 
     56      INTEGER ::   ios   ! Local integer 
    5857      !! 
    5958      NAMELIST/namusr_def/ nn_GYRE, ln_bench, jpkglo 
    6059      !!---------------------------------------------------------------------- 
    6160      ! 
    62       ii = 1 
    63       ! 
    6461      REWIND( numnam_cfg )          ! Namelist namusr_def (exist in namelist_cfg only) 
    6562      READ  ( numnam_cfg, namusr_def, IOSTAT = ios, ERR = 902 ) 
    66 902   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namusr_def in configuration namelist', .TRUE. ) 
     63902   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namusr_def in configuration namelist' ) 
    6764      ! 
    68       WRITE( ldnam(:), namusr_def ) 
     65      IF(lwm)   WRITE( numond, namusr_def ) 
    6966      ! 
    7067      cd_cfg = 'GYRE'               ! name & resolution (not used) 
    … …  
    8380#endif 
    8481      kpk = jpkglo 
    85       ! 
    86       !                             ! control print 
    87       WRITE(ldtxt(ii),*) '   '                                                                            ;   ii = ii + 1 
    88       WRITE(ldtxt(ii),*) 'usr_def_nam  : read the user defined namelist (namusr_def) in namelist_cfg'     ;   ii = ii + 1 
    89       WRITE(ldtxt(ii),*) '~~~~~~~~~~~ '                                                                   ;   ii = ii + 1 
    90       WRITE(ldtxt(ii),*) '   Namelist namusr_def : GYRE case'                                             ;   ii = ii + 1 
    91       WRITE(ldtxt(ii),*) '      GYRE used as Benchmark (=T)                      ln_bench  = ', ln_bench  ;   ii = ii + 1 
    92       WRITE(ldtxt(ii),*) '      inverse resolution & implied domain size         nn_GYRE   = ', nn_GYRE   ;   ii = ii + 1 
    93 #if defined key_agrif 
    94       IF( Agrif_Root() ) THEN 
    95 #endif 
    96       WRITE(ldtxt(ii),*) '         jpiglo = 30*nn_GYRE+2                            jpiglo = ', kpi       ;   ii = ii + 1 
    97       WRITE(ldtxt(ii),*) '         jpjglo = 20*nn_GYRE+2                            jpjglo = ', kpj       ;   ii = ii + 1 
    98 #if defined key_agrif 
    99       ENDIF 
    100 #endif 
    101       WRITE(ldtxt(ii),*) '      number of model levels                              jpkglo = ', kpk       ;   ii = ii + 1 
    102       ! 
    10382      !                             ! Set the lateral boundary condition of the global domain 
    10483      kperio = 0                    ! GYRE configuration : closed domain 
    10584      ! 
    106       WRITE(ldtxt(ii),*) '   '                                                                            ;   ii = ii + 1 
    107       WRITE(ldtxt(ii),*) '   Lateral b.c. of the global domain set to closed     jperio = ', kperio       ;   ii = ii + 1 
     85      !                             ! control print 
     86      IF(lwp) THEN 
     87         WRITE(numout,*) '   ' 
     88         WRITE(numout,*) 'usr_def_nam  : read the user defined namelist (namusr_def) in namelist_cfg' 
     89         WRITE(numout,*) '~~~~~~~~~~~ ' 
     90         WRITE(numout,*) '   Namelist namusr_def : GYRE case' 
     91         WRITE(numout,*) '      GYRE used as Benchmark (=T)                      ln_bench  = ', ln_bench 
     92         WRITE(numout,*) '      inverse resolution & implied domain size         nn_GYRE   = ', nn_GYRE 
     93#if defined key_agrif 
     94         IF( Agrif_Root() ) THEN 
     95#endif 
     96         WRITE(numout,*) '         jpiglo = 30*nn_GYRE+2                            jpiglo = ', kpi 
     97         WRITE(numout,*) '         jpjglo = 20*nn_GYRE+2                            jpjglo = ', kpj 
     98#if defined key_agrif 
     99         ENDIF 
     100#endif 
     101         WRITE(numout,*) '      number of model levels                              jpkglo = ', kpk 
     102         WRITE(numout,*) '   ' 
     103         WRITE(numout,*) '   Lateral b.c. of the global domain set to closed        jperio = ', kperio 
     104      ENDIF 
    108105      ! 
    109106   END SUBROUTINE usr_def_nam 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/ZDF/zdfdrg.F90

    r10955 r11822  
    240240      REWIND( numnam_ref )                   ! Namelist namdrg in reference namelist 
    241241      READ  ( numnam_ref, namdrg, IOSTAT = ios, ERR = 901) 
    242 901   IF( ios /= 0 )   CALL ctl_nam( ios , 'namdrg in reference namelist', lwp ) 
     242901   IF( ios /= 0 )   CALL ctl_nam( ios , 'namdrg in reference namelist' ) 
    243243      REWIND( numnam_cfg )                   ! Namelist namdrg in configuration namelist 
    244244      READ  ( numnam_cfg, namdrg, IOSTAT = ios, ERR = 902 ) 
    245 902   IF( ios >  0 )   CALL ctl_nam( ios , 'namdrg in configuration namelist', lwp ) 
     245902   IF( ios >  0 )   CALL ctl_nam( ios , 'namdrg in configuration namelist' ) 
    246246      IF(lwm) WRITE ( numond, namdrg ) 
    247247      ! 
    … …  
    340340      IF(ll_top)   READ  ( numnam_ref, namdrg_top, IOSTAT = ios, ERR = 901) 
    341341      IF(ll_bot)   READ  ( numnam_ref, namdrg_bot, IOSTAT = ios, ERR = 901) 
    342 901   IF( ios /= 0 )   CALL ctl_nam( ios , TRIM(cl_namref), lwp ) 
     342901   IF( ios /= 0 )   CALL ctl_nam( ios , TRIM(cl_namref) ) 
    343343      REWIND( numnam_cfg )                   ! Namelist cd_namdrg in configuration namelist 
    344344      IF(ll_top)   READ  ( numnam_cfg, namdrg_top, IOSTAT = ios, ERR = 902 ) 
    345345      IF(ll_bot)   READ  ( numnam_cfg, namdrg_bot, IOSTAT = ios, ERR = 902 ) 
    346 902   IF( ios >  0 )   CALL ctl_nam( ios , TRIM(cl_namcfg), lwp ) 
     346902   IF( ios >  0 )   CALL ctl_nam( ios , TRIM(cl_namcfg) ) 
    347347      IF(lwm .AND. ll_top)   WRITE ( numond, namdrg_top ) 
    348348      IF(lwm .AND. ll_bot)   WRITE ( numond, namdrg_bot ) 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/ZDF/zdfgls.F90

    r10883 r11822  
    860860      REWIND( numnam_ref )              ! Namelist namzdf_gls in reference namelist : Vertical eddy diffivity and viscosity using gls turbulent closure scheme 
    861861      READ  ( numnam_ref, namzdf_gls, IOSTAT = ios, ERR = 901) 
    862 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namzdf_gls in reference namelist', lwp ) 
     862901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namzdf_gls in reference namelist' ) 
    863863 
    864864      REWIND( numnam_cfg )              ! Namelist namzdf_gls in configuration namelist : Vertical eddy diffivity and viscosity using gls turbulent closure scheme 
    865865      READ  ( numnam_cfg, namzdf_gls, IOSTAT = ios, ERR = 902 ) 
    866 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namzdf_gls in configuration namelist', lwp ) 
     866902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namzdf_gls in configuration namelist' ) 
    867867      IF(lwm) WRITE ( numond, namzdf_gls ) 
    868868 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/ZDF/zdfiwm.F90

    r10955 r11822  
    425425      REWIND( numnam_ref )              ! Namelist namzdf_iwm in reference namelist : Wave-driven mixing 
    426426      READ  ( numnam_ref, namzdf_iwm, IOSTAT = ios, ERR = 901) 
    427 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namzdf_iwm in reference namelist', lwp ) 
     427901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namzdf_iwm in reference namelist' ) 
    428428      ! 
    429429      REWIND( numnam_cfg )              ! Namelist namzdf_iwm in configuration namelist : Wave-driven mixing 
    430430      READ  ( numnam_cfg, namzdf_iwm, IOSTAT = ios, ERR = 902 ) 
    431 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namzdf_iwm in configuration namelist', lwp ) 
     431902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namzdf_iwm in configuration namelist' ) 
    432432      IF(lwm) WRITE ( numond, namzdf_iwm ) 
    433433      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/ZDF/zdfosm.F90

    r11480 r11822  
    13891389     REWIND( numnam_ref )              ! Namelist namzdf_osm in reference namelist : Osmosis ML model 
    13901390     READ  ( numnam_ref, namzdf_osm, IOSTAT = ios, ERR = 901) 
    1391 901  IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_osm in reference namelist', lwp ) 
     1391901  IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_osm in reference namelist' ) 
    13921392 
    13931393     REWIND( numnam_cfg )              ! Namelist namzdf_tke in configuration namelist : Turbulent Kinetic Energy 
    13941394     READ  ( numnam_cfg, namzdf_osm, IOSTAT = ios, ERR = 902 ) 
    1395 902  IF( ios >  0 ) CALL ctl_nam ( ios , 'namzdf_osm in configuration namelist', lwp ) 
     1395902  IF( ios >  0 ) CALL ctl_nam ( ios , 'namzdf_osm in configuration namelist' ) 
    13961396     IF(lwm) WRITE ( numond, namzdf_osm ) 
    13971397 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/ZDF/zdfphy.F90

    r10955 r11822  
    9595      REWIND( numnam_ref )              ! Namelist namzdf in reference namelist : Vertical mixing parameters 
    9696      READ  ( numnam_ref, namzdf, IOSTAT = ios, ERR = 901) 
    97 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namzdf in reference namelist', lwp ) 
     97901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namzdf in reference namelist' ) 
    9898      ! 
    9999      REWIND( numnam_cfg )              ! Namelist namzdf in reference namelist : Vertical mixing parameters 
    100100      READ  ( numnam_cfg, namzdf, IOSTAT = ios, ERR = 902 ) 
    101 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namzdf in configuration namelist', lwp ) 
     101902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namzdf in configuration namelist' ) 
    102102      IF(lwm)   WRITE ( numond, namzdf ) 
    103103      ! 
    … …  
    134134      IF( ln_zad_Aimp ) THEN 
    135135         IF( zdf_phy_alloc() /= 0 )   & 
    136         &       CALL ctl_stop( 'STOP', 'zdf_phy_init : unable to allocate adaptive-implicit z-advection arrays' ) 
    137          wi(:,:,:) = 0._wp 
     136            &       CALL ctl_stop( 'STOP', 'zdf_phy_init : unable to allocate adaptive-implicit z-advection arrays' ) 
     137         Cu_adv(:,:,:) = 0._wp 
     138         wi    (:,:,:) = 0._wp 
    138139      ENDIF 
    139140      !                          !==  Background eddy viscosity and diffusivity  ==! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/ZDF/zdfric.F90

    r10883 r11822  
    8080      REWIND( numnam_ref )              ! Namelist namzdf_ric in reference namelist : Vertical diffusion Kz depends on Richardson number 
    8181      READ  ( numnam_ref, namzdf_ric, IOSTAT = ios, ERR = 901) 
    82 901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_ric in reference namelist', lwp ) 
     82901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_ric in reference namelist' ) 
    8383 
    8484      REWIND( numnam_cfg )              ! Namelist namzdf_ric in configuration namelist : Vertical diffusion Kz depends on Richardson number 
    8585      READ  ( numnam_cfg, namzdf_ric, IOSTAT = ios, ERR = 902 ) 
    86 902   IF( ios >  0 ) CALL ctl_nam ( ios , 'namzdf_ric in configuration namelist', lwp ) 
     86902   IF( ios >  0 ) CALL ctl_nam ( ios , 'namzdf_ric in configuration namelist' ) 
    8787      IF(lwm) WRITE ( numond, namzdf_ric ) 
    8888      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/ZDF/zdftke.F90

    r10955 r11822  
    658658      REWIND( numnam_ref )              ! Namelist namzdf_tke in reference namelist : Turbulent Kinetic Energy 
    659659      READ  ( numnam_ref, namzdf_tke, IOSTAT = ios, ERR = 901) 
    660 901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tke in reference namelist', lwp ) 
     660901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tke in reference namelist' ) 
    661661 
    662662      REWIND( numnam_cfg )              ! Namelist namzdf_tke in configuration namelist : Turbulent Kinetic Energy 
    663663      READ  ( numnam_cfg, namzdf_tke, IOSTAT = ios, ERR = 902 ) 
    664 902   IF( ios >  0 ) CALL ctl_nam ( ios , 'namzdf_tke in configuration namelist', lwp ) 
     664902   IF( ios >  0 ) CALL ctl_nam ( ios , 'namzdf_tke in configuration namelist' ) 
    665665      IF(lwm) WRITE ( numond, namzdf_tke ) 
    666666      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/module_example

    r10425 r11822  
    152152      REWIND( numnam_ref )              ! Namelist namexa in reference namelist : Example 
    153153      READ  ( numnam_ref, namexa, IOSTAT = ios, ERR = 901) 
    154 901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namexa in reference namelist', lwp ) 
     154901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namexa in reference namelist' ) 
    155155      ! 
    156156      REWIND( numnam_cfg )              ! Namelist namexa in configuration namelist : Example 
    157157      READ  ( numnam_cfg, namexa, IOSTAT = ios, ERR = 902 ) 
    158 902   IF( ios >  0 ) CALL ctl_nam ( ios , 'namexa in configuration namelist', lwp ) 
     158902   IF( ios >  0 ) CALL ctl_nam ( ios , 'namexa in configuration namelist' ) 
    159159   ! Output namelist for control 
    160160      WRITE ( numond, namexa ) 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/nemogcm.F90

    r11758 r11822  
    5959   USE diaobs         ! Observation diagnostics       (dia_obs_init routine) 
    6060   USE diacfl         ! CFL diagnostics               (dia_cfl_init routine) 
     61   USE diaharm        ! tidal harmonics diagnostics  (dia_harm_init routine) 
    6162   USE step           ! NEMO time-stepping                 (stp     routine) 
    6263   USE icbini         ! handle bergs, initialisation 
    … …  
    103104 
    104105#if defined key_mpp_mpi 
     106   ! need MPI_Wtime 
    105107   INCLUDE 'mpif.h' 
    106108#endif 
    … …  
    128130      !!---------------------------------------------------------------------- 
    129131      INTEGER ::   istp   ! time step index 
     132      REAL(wp)::   zstptiming   ! elapsed time for 1 time step 
    130133      !!---------------------------------------------------------------------- 
    131134      ! 
    … …  
    190193         ! 
    191194         DO WHILE( istp <= nitend .AND. nstop == 0 ) 
    192 #if defined key_mpp_mpi 
     195 
    193196            ncom_stp = istp 
    194             IF ( istp == ( nit000 + 1 ) ) elapsed_time = MPI_Wtime() 
    195             IF ( istp ==         nitend ) elapsed_time = MPI_Wtime() - elapsed_time 
    196 #endif 
     197            IF( ln_timing ) THEN 
     198               zstptiming = MPI_Wtime() 
     199               IF ( istp == ( nit000 + 1 ) ) elapsed_time = zstptiming 
     200               IF ( istp ==         nitend ) elapsed_time = zstptiming - elapsed_time 
     201            ENDIF 
     202             
    197203            CALL stp        ( istp )  
    198204            istp = istp + 1 
     205 
     206            IF( lwp .AND. ln_timing )   WRITE(numtime,*) 'timing step ', istp-1, ' : ', MPI_Wtime() - zstptiming 
     207 
    199208         END DO 
    200209         ! 
    … …  
    222231      ! 
    223232      IF( nstop /= 0 .AND. lwp ) THEN        ! error print 
    224          WRITE(numout,cform_err) 
    225          WRITE(numout,*) '   ==>>>   nemo_gcm: a total of ', nstop, ' errors have been found' 
    226          WRITE(numout,*) 
     233         WRITE(ctmp1,*) '   ==>>>   nemo_gcm: a total of ', nstop, ' errors have been found' 
     234         CALL ctl_stop( ctmp1 ) 
    227235      ENDIF 
    228236      ! 
    … …  
    236244#else 
    237245      IF    ( lk_oasis ) THEN   ;   CALL cpl_finalize   ! end coupling and mpp communications with OASIS 
    238       ELSEIF( lk_mpp   ) THEN   ;   CALL mppstop( ldfinal = .TRUE. )   ! end mpp communications 
     246      ELSEIF( lk_mpp   ) THEN   ;   CALL mppstop      ! end mpp communications 
    239247      ENDIF 
    240248#endif 
    … …  
    242250      IF(lwm) THEN 
    243251         IF( nstop == 0 ) THEN   ;   STOP 0 
    244          ELSE                    ;   STOP 999 
     252         ELSE                    ;   STOP 123 
    245253         ENDIF 
    246254      ENDIF 
    … …  
    255263      !! ** Purpose :   initialization of the NEMO GCM 
    256264      !!---------------------------------------------------------------------- 
    257       INTEGER  ::   ji                 ! dummy loop indices 
    258       INTEGER  ::   ios, ilocal_comm   ! local integers 
    259       CHARACTER(len=120), DIMENSION(60) ::   cltxt, cltxt2, clnam 
     265      INTEGER ::   ios, ilocal_comm   ! local integers 
    260266      !! 
    261267      NAMELIST/namctl/ ln_ctl   , sn_cfctl, nn_print, nn_ictls, nn_ictle,   & 
    … …  
    265271      !!---------------------------------------------------------------------- 
    266272      ! 
    267       cltxt  = '' 
    268       cltxt2 = '' 
    269       clnam  = ''   
    270273      cxios_context = 'nemo' 
    271274      ! 
    272       !                             ! Open reference namelist and configuration namelist files 
    273       CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 
    274       CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 
    275       ! 
    276       REWIND( numnam_ref )              ! Namelist namctl in reference namelist 
    277       READ  ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 ) 
    278 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namctl in reference namelist', .TRUE. ) 
    279       REWIND( numnam_cfg )              ! Namelist namctl in confguration namelist 
    280       READ  ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 ) 
    281 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namctl in configuration namelist', .TRUE. ) 
    282       ! 
    283       REWIND( numnam_ref )              ! Namelist namcfg in reference namelist 
    284       READ  ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 ) 
    285 903   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namcfg in reference namelist', .TRUE. ) 
    286       REWIND( numnam_cfg )              ! Namelist namcfg in confguration namelist 
    287       READ  ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 ) 
    288 904   IF( ios >  0 )   CALL ctl_nam ( ios , 'namcfg in configuration namelist', .TRUE. )    
    289  
    290       !                             !--------------------------! 
    291       !                             !  Set global domain size  !   (control print return in cltxt2) 
    292       !                             !--------------------------! 
    293       IF( ln_read_cfg ) THEN              ! Read sizes in domain configuration file 
    294          CALL domain_cfg ( cltxt2,        cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio ) 
    295          ! 
    296       ELSE                                ! user-defined namelist 
    297          CALL usr_def_nam( cltxt2, clnam, cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio ) 
    298       ENDIF 
    299       ! 
    300       ! 
    301       !                             !--------------------------------------------! 
    302       !                             !  set communicator & select the local node  ! 
    303       !                             !  NB: mynode also opens output.namelist.dyn ! 
    304       !                             !      on unit number numond on first proc   ! 
    305       !                             !--------------------------------------------! 
     275      !                             !-------------------------------------------------! 
     276      !                             !     set communicator & select the local rank    ! 
     277      !                             !  must be done as soon as possible to get narea  ! 
     278      !                             !-------------------------------------------------! 
     279      ! 
    306280#if defined key_iomput 
    307281      IF( Agrif_Root() ) THEN 
    308282         IF( lk_oasis ) THEN 
    309283            CALL cpl_init( "oceanx", ilocal_comm )                               ! nemo local communicator given by oasis 
    310             CALL xios_initialize( "not used"       ,local_comm= ilocal_comm )    ! send nemo communicator to xios 
     284            CALL xios_initialize( "not used"       , local_comm =ilocal_comm )   ! send nemo communicator to xios 
    311285         ELSE 
    312             CALL xios_initialize( "for_xios_mpi_id",return_comm=ilocal_comm )    ! nemo local communicator given by xios 
     286            CALL xios_initialize( "for_xios_mpi_id", return_comm=ilocal_comm )   ! nemo local communicator given by xios 
    313287         ENDIF 
    314288      ENDIF 
    315       ! Nodes selection (control print return in cltxt) 
    316       narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) 
     289      CALL mpp_start( ilocal_comm ) 
    317290#else 
    318291      IF( lk_oasis ) THEN 
    … …  
    320293            CALL cpl_init( "oceanx", ilocal_comm )          ! nemo local communicator given by oasis 
    321294         ENDIF 
    322          ! Nodes selection (control print return in cltxt) 
    323          narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) 
     295         CALL mpp_start( ilocal_comm ) 
    324296      ELSE 
    325          ilocal_comm = 0                                    ! Nodes selection (control print return in cltxt) 
    326          narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop ) 
    327       ENDIF 
    328 #endif 
    329  
    330       narea = narea + 1                                     ! mynode return the rank of proc (0 --> jpnij -1 ) 
    331  
    332       IF( sn_cfctl%l_config ) THEN 
    333          ! Activate finer control of report outputs 
    334          ! optionally switch off output from selected areas (note this only 
    335          ! applies to output which does not involve global communications) 
    336          IF( ( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax  ) .OR. & 
    337            & ( MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) )    & 
    338            &   CALL nemo_set_cfctl( sn_cfctl, .FALSE., .FALSE. ) 
    339       ELSE 
    340          ! Use ln_ctl to turn on or off all options. 
    341          CALL nemo_set_cfctl( sn_cfctl, ln_ctl, .TRUE. ) 
    342       ENDIF 
    343  
    344       lwm = (narea == 1)                                    ! control of output namelists 
    345       lwp = (narea == 1) .OR. ln_ctl                        ! control of all listing output print 
    346  
    347       IF(lwm) THEN               ! write merged namelists from earlier to output namelist  
    348          !                       ! now that the file has been opened in call to mynode.  
    349          !                       ! NB: nammpp has already been written in mynode (if lk_mpp_mpi) 
    350          WRITE( numond, namctl ) 
    351          WRITE( numond, namcfg ) 
    352          IF( .NOT.ln_read_cfg ) THEN 
    353             DO ji = 1, SIZE(clnam) 
    354                IF( TRIM(clnam(ji)) /= '' )   WRITE(numond, * ) clnam(ji)     ! namusr_def print 
    355             END DO 
    356          ENDIF 
    357       ENDIF 
    358  
    359       IF(lwp) THEN                            ! open listing units 
    360          ! 
    361          CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea ) 
     297         CALL mpp_start( ) 
     298      ENDIF 
     299#endif 
     300      ! 
     301      narea = mpprank + 1               ! mpprank: the rank of proc (0 --> mppsize -1 ) 
     302      lwm = (narea == 1)                ! control of output namelists 
     303      ! 
     304      !                             !---------------------------------------------------------------! 
     305      !                             ! Open output files, reference and configuration namelist files ! 
     306      !                             !---------------------------------------------------------------! 
     307      ! 
     308      ! open ocean.output as soon as possible to get all output prints (including errors messages) 
     309      IF( lwm )   CALL ctl_opn(     numout,        'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 
     310      ! open reference and configuration namelist files 
     311                  CALL ctl_opn( numnam_ref,        'namelist_ref',     'OLD', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 
     312                  CALL ctl_opn( numnam_cfg,        'namelist_cfg',     'OLD', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 
     313      IF( lwm )   CALL ctl_opn(     numond, 'output.namelist.dyn', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 
     314      ! open /dev/null file to be able to supress output write easily 
     315                  CALL ctl_opn(     numnul,           '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 
     316      ! 
     317      !                             !--------------------! 
     318      !                             ! Open listing units !  -> need ln_ctl from namctl to define lwp 
     319      !                             !--------------------! 
     320      ! 
     321      REWIND( numnam_ref )              ! Namelist namctl in reference namelist 
     322      READ  ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 ) 
     323901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namctl in reference namelist' ) 
     324      REWIND( numnam_cfg )              ! Namelist namctl in confguration namelist 
     325      READ  ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 ) 
     326902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namctl in configuration namelist' ) 
     327      ! 
     328      lwp = (narea == 1) .OR. ln_ctl    ! control of all listing output print 
     329      ! 
     330      IF(lwp) THEN                      ! open listing units 
     331         ! 
     332         IF( .NOT. lwm )   &            ! alreay opened for narea == 1 
     333            &            CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE., narea ) 
    362334         ! 
    363335         WRITE(numout,*) 
    364          WRITE(numout,*) '   CNRS - NERC - Met OFFICE - MERCATOR-ocean - INGV - CMCC' 
     336         WRITE(numout,*) '   CNRS - NERC - Met OFFICE - MERCATOR-ocean - CMCC' 
    365337         WRITE(numout,*) '                       NEMO team' 
    366338         WRITE(numout,*) '            Ocean General Circulation Model' 
    … …  
    381353         WRITE(numout,*) "     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ " 
    382354         WRITE(numout,*) 
    383           
    384          DO ji = 1, SIZE(cltxt) 
    385             IF( TRIM(cltxt (ji)) /= '' )   WRITE(numout,*) TRIM(cltxt(ji))    ! control print of mynode 
    386          END DO 
    387          WRITE(numout,*) 
    388          WRITE(numout,*) 
    389          DO ji = 1, SIZE(cltxt2) 
    390             IF( TRIM(cltxt2(ji)) /= '' )   WRITE(numout,*) TRIM(cltxt2(ji))   ! control print of domain size 
    391          END DO 
    392355         ! 
    393356         WRITE(numout,cform_aaa)                                        ! Flag AAAAAAA 
    394357         ! 
    395358      ENDIF 
    396       ! open /dev/null file to be able to supress output write easily 
    397       CALL ctl_opn( numnul, '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 
    398       ! 
    399       !                                      ! Domain decomposition 
    400       CALL mpp_init                          ! MPP 
     359      ! 
     360      ! finalize the definition of namctl variables 
     361      IF( sn_cfctl%l_config ) THEN 
     362         ! Activate finer control of report outputs 
     363         ! optionally switch off output from selected areas (note this only 
     364         ! applies to output which does not involve global communications) 
     365         IF( ( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax  ) .OR. & 
     366           & ( MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) )    & 
     367           &   CALL nemo_set_cfctl( sn_cfctl, .FALSE., .FALSE. ) 
     368      ELSE 
     369         ! Use ln_ctl to turn on or off all options. 
     370         CALL nemo_set_cfctl( sn_cfctl, ln_ctl, .TRUE. ) 
     371      ENDIF 
     372      ! 
     373      IF(lwm) WRITE( numond, namctl ) 
     374      ! 
     375      !                             !------------------------------------! 
     376      !                             !  Set global domain size parameters ! 
     377      !                             !------------------------------------! 
     378      ! 
     379      REWIND( numnam_ref )              ! Namelist namcfg in reference namelist 
     380      READ  ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 ) 
     381903   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namcfg in reference namelist' ) 
     382      REWIND( numnam_cfg )              ! Namelist namcfg in confguration namelist 
     383      READ  ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 ) 
     384904   IF( ios >  0 )   CALL ctl_nam ( ios , 'namcfg in configuration namelist' )    
     385      ! 
     386      IF( ln_read_cfg ) THEN            ! Read sizes in domain configuration file 
     387         CALL domain_cfg ( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio ) 
     388      ELSE                              ! user-defined namelist 
     389         CALL usr_def_nam( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio ) 
     390      ENDIF 
     391      ! 
     392      IF(lwm)   WRITE( numond, namcfg ) 
     393      ! 
     394      !                             !-----------------------------------------! 
     395      !                             ! mpp parameters and domain decomposition ! 
     396      !                             !-----------------------------------------! 
     397      CALL mpp_init 
    401398 
    402399      ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays 
    … …  
    485482      
    486483      !                                      ! Diagnostics 
    487       IF( lk_floats    )   CALL     flo_init( Nnn )    ! drifting Floats 
     484                           CALL     flo_init( Nnn )    ! drifting Floats 
    488485      IF( ln_diacfl    )   CALL dia_cfl_init    ! Initialise CFL diagnostics 
    489486                           CALL dia_ptr_init    ! Poleward TRansports initialization 
    490       IF( lk_diadct    )   CALL dia_dct_init    ! Sections tranports 
     487                           CALL dia_dct_init    ! Sections tranports 
    491488                           CALL dia_hsb_init( Nnn )    ! heat content, salt content and volume budgets 
    492489                           CALL     trd_init( Nnn )    ! Mixed-layer/Vorticity/Integral constraints trends 
    … …  
    494491                           CALL dia_tmb_init    ! TMB outputs 
    495492                           CALL dia_25h_init( Nbb )    ! 25h mean  outputs 
     493                           CALL dia_harm_init   ! tidal harmonics outputs 
    496494      IF( ln_diaobs    )   CALL dia_obs( nit000-1, Nnn )   ! Observation operator for restart 
    497495 
    … …  
    512510      !! ** Purpose :   control print setting 
    513511      !! 
    514       !! ** Method  : - print namctl information and check some consistencies 
     512      !! ** Method  : - print namctl and namcfg information and check some consistencies 
    515513      !!---------------------------------------------------------------------- 
    516514      ! 
    … …  
    655653      USE trc_oce   , ONLY : trc_oce_alloc 
    656654      USE bdy_oce   , ONLY : bdy_oce_alloc 
    657 #if defined key_diadct  
    658       USE diadct    , ONLY : diadct_alloc  
    659 #endif  
    660655      ! 
    661656      INTEGER :: ierr 
    … …  
    669664      ierr = ierr + bdy_oce_alloc()    ! bdy masks (incl. initialization) 
    670665      ! 
    671 #if defined key_diadct  
    672       ierr = ierr + diadct_alloc ()    !  
    673 #endif  
    674       ! 
    675666      CALL mpp_sum( 'nemogcm', ierr ) 
    676667      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'nemo_alloc: unable to allocate standard ocean arrays' ) 
    … …  
    678669   END SUBROUTINE nemo_alloc 
    679670 
     671    
    680672   SUBROUTINE nemo_set_cfctl(sn_cfctl, setto, for_all ) 
    681673      !!---------------------------------------------------------------------- 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/step.F90

    r11480 r11822  
    117117      ! Update external forcing (tides, open boundaries, and surface boundary condition (including sea-ice) 
    118118      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    119       IF( ln_tide    )   CALL sbc_tide( kstp )                   ! update tide potential 
    120       IF( ln_apr_dyn )   CALL sbc_apr ( kstp )                   ! atmospheric pressure (NB: call before bdy_dta which needs ssh_ib)  
    121       IF( ln_bdy     )   CALL bdy_dta ( kstp,      Nnn, time_offset=+1 )  ! update dynamic & tracer data at open boundaries 
    122                          CALL sbc     ( kstp, Nbb, Nnn )         ! Sea Boundary Condition (including sea-ice) 
     119      IF( ln_tide    )   CALL sbc_tide( kstp )                        ! update tide potential 
     120      IF( ln_apr_dyn )   CALL sbc_apr ( kstp )                        ! atmospheric pressure (NB: call before bdy_dta which needs ssh_ib)  
     121      IF( ln_bdy     )   CALL bdy_dta ( kstp, Nnn, kt_offset = +1 )   ! update dynamic & tracer data at open boundaries 
     122                         CALL sbc     ( kstp, Nbb, Nnn )              ! Sea Boundary Condition (including sea-ice) 
    123123 
    124124      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    … …  
    172172                            CALL eos    ( ts(:,:,:,:,Nnn), rhd, rhop, gdept(:,:,:,Nnn) )  ! now in situ density for hpg computation 
    173173                             
    174 !!jc: fs simplification 
    175 !!jc: lines below are useless if ln_linssh=F. Keep them here (which maintains a bug if ln_linssh=T and ln_zps=T, cf ticket #1636)  
    176 !!                                         but ensures reproductible results 
    177 !!                                         with previous versions using split-explicit free surface           
    178             IF( ln_zps .AND. .NOT. ln_isfcav )                                    & 
    179                &            CALL zps_hde    ( kstp, Nnn, jpts, ts(:,:,:,:,Nnn), gtsu, gtsv,   &  ! Partial steps: before horizontal gradient 
    180                &                                          rhd, gru , grv     )       ! of t, s, rd at the last ocean level 
    181             IF( ln_zps .AND.       ln_isfcav )                                               & 
    182                &            CALL zps_hde_isf( kstp, Nnn, jpts, ts(:,:,:,:,Nnn), gtsu, gtsv, gtui, gtvi,  &  ! Partial steps for top cell (ISF) 
    183                &                                          rhd, gru , grv , grui, grvi   )       ! of t, s, rd at the first ocean level 
    184 !!jc: fs simplification 
    185174                             
    186175                         uu(:,:,:,Nrhs) = 0._wp            ! set dynamics trends to zero 
    … …  
    203192                                                      ! With split-explicit free surface, since now transports have been updated and ssh(:,:,Nrhs) as well 
    204193      IF( ln_dynspg_ts ) THEN                         ! vertical scale factors and vertical velocity need to be updated 
    205                             CALL div_hor       ( kstp, Nbb, Nnn )    ! Horizontal divergence  (2nd call in time-split case) 
     194                            CALL div_hor       ( kstp, Nbb, Nnn )                ! Horizontal divergence  (2nd call in time-split case) 
    206195         IF(.NOT.ln_linssh) CALL dom_vvl_sf_nxt( kstp, Nbb, Nnn, Naa, kcall=2 )  ! after vertical scale factors (update depth average component) 
    207                             CALL wzv        ( kstp, Nbb, Nnn, ww, Naa )  ! now cross-level velocity  
    208          IF( ln_zad_Aimp )  CALL wAimp      ( kstp,      Nnn )           ! Adaptive-implicit vertical advection partitioning 
     196      ENDIF 
     197                         CALL dyn_zdf( kstp, Nbb, Nnn, Nrhs, uu, vv, Naa  )      ! vertical diffusion    ==> after 
     198 
     199      IF( ln_dynspg_ts ) THEN                          
     200                            CALL wzv        ( kstp, Nbb, Nnn, ww, Naa )          ! now cross-level velocity  
     201         IF( ln_zad_Aimp )  CALL wAimp      ( kstp,      Nnn )                   ! Adaptive-implicit vertical advection partitioning 
    209202      ENDIF 
    210203       
    211                          CALL dyn_zdf( kstp, Nbb, Nnn, Nrhs, uu, vv, Naa  )  ! vertical diffusion     ==> after 
    212204 
    213205      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    … …  
    219211      ! diagnostics and outputs 
    220212      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    221       IF( lk_floats  )   CALL flo_stp ( kstp, Nbb, Nnn )   ! drifting Floats 
     213      IF( ln_floats  )   CALL flo_stp ( kstp, Nbb, Nnn )   ! drifting Floats 
    222214      IF( ln_diacfl  )   CALL dia_cfl ( kstp,      Nnn )   ! Courant number diagnostics 
    223215      IF( lk_diahth  )   CALL dia_hth ( kstp,      Nnn )   ! Thermocline depth (20 degres isotherm depth) 
    224       IF( lk_diadct  )   CALL dia_dct ( kstp,      Nnn )   ! Transports 
     216      IF( ln_diadct  )   CALL dia_dct ( kstp,      Nnn )   ! Transports 
    225217                         CALL dia_ar5 ( kstp,      Nnn )   ! ar5 diag 
    226       IF( lk_diaharm )   CALL dia_harm( kstp,      Nnn )   ! Tidal harmonic analysis 
     218      IF( ln_diaharm )   CALL dia_harm( kstp,      Nnn )   ! Tidal harmonic analysis 
    227219                         CALL dia_wri ( kstp,      Nnn )   ! ocean model: outputs 
    228220      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/stpctl.F90

    r11480 r11822  
    9797            IF( ln_zad_Aimp ) THEN 
    9898               istatus = NF90_DEF_VAR( idrun,   'abs_wi_max', NF90_DOUBLE, (/ idtime /), idw1  ) 
    99                istatus = NF90_DEF_VAR( idrun,       'Cu_max', NF90_DOUBLE, (/ idtime /), idc1  ) 
     99               istatus = NF90_DEF_VAR( idrun,       'Cf_max', NF90_DOUBLE, (/ idtime /), idc1  ) 
    100100            ENDIF 
    101101            istatus = NF90_ENDDEF(idrun) 
    … …  
    124124      IF( ln_zad_Aimp ) THEN 
    125125         zmax(8) = MAXVAL(  ABS( wi(:,:,:) ) , mask = wmask(:,:,:) == 1._wp ) ! implicit vertical vel. max 
    126          zmax(9) = MAXVAL(   Cu_adv(:,:,:)   , mask = tmask(:,:,:) == 1._wp ) !       cell Courant no. max 
     126         zmax(9) = MAXVAL(   Cu_adv(:,:,:)   , mask = tmask(:,:,:) == 1._wp ) ! partitioning coeff. max 
    127127      ENDIF 
    128128      ! 

  • NEMO/branches/2019/dev_r10721_KERNEL-02_Storkey_Coward_IMMERSE_first_steps/src/OCE/timing.F90

    r10510 r11822  
    347347 
    348348      ! write output file 
     349      IF( lwriter ) WRITE(numtime,*)  
     350      IF( lwriter ) WRITE(numtime,*)  
    349351      IF( lwriter ) WRITE(numtime,*) 'Total timing (sum) :' 
    350352      IF( lwriter ) WRITE(numtime,*) '--------------------' 
    … …  
    657659         ! Compute cpu/elapsed ratio 
    658660         zall_ratio(:) = all_ctime(:) / all_etime(:) 
    659          ztot_ratio    = SUM(zall_ratio(:)) 
    660          zavg_ratio    = ztot_ratio/REAL(jpnij,wp) 
     661         ztot_ratio    = SUM(all_ctime(:))/SUM(all_etime(:)) 
     662         zavg_ratio    = SUM(zall_ratio(:))/REAL(jpnij,wp) 
    661663         zmax_ratio    = MAXVAL(zall_ratio(:)) 
    662664         zmin_ratio    = MINVAL(zall_ratio(:))    
    … …  
    667669         cllignes(2)='1x,"--------------------",//,' 
    668670         cllignes(3)='1x,"Process Rank |"," Elapsed Time (s) |"," CPU Time (s) |"," Ratio CPU/Elapsed",/,' 
    669          cllignes(4)='    (1x,i4,9x,"|",f12.3,6x,"|",f12.3,2x,"|",4x,f7.3,/),' 
    670          WRITE(cllignes(4)(1:4),'(I4)') jpnij 
     671         cllignes(4)='      (4x,i6,4x,"|",f12.3,6x,"|",f12.3,2x,"|",4x,f7.3,/),' 
     672         WRITE(cllignes(4)(1:6),'(I6)') jpnij 
    671673         cllignes(5)='1x,"Total        |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3,/,' 
    672674         cllignes(6)='1x,"Minimum      |",f12.3,6x,"|",F12.3,2x,"|",4x,f7.3,/,' 
Note: See TracChangeset for help on using the changeset viewer.