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 11536 for NEMO/trunk/src/OCE – NEMO

Changeset 11536 for NEMO/trunk/src/OCE


Ignore:
Timestamp:
2019-09-11T15:54:18+02:00 (5 years ago)
Author:
smasson
Message:

trunk: merge dev_r10984_HPC-13 into the trunk

Location:
NEMO/trunk/src/OCE
Files:
2 deleted
103 edited

Legend:

Unmodified
Added
Removed

  • NEMO/trunk/src/OCE/ASM/asminc.F90

    r10425 r11536  
    147147      REWIND( numnam_ref )              ! Namelist nam_asminc in reference namelist : Assimilation increment 
    148148      READ  ( numnam_ref, nam_asminc, IOSTAT = ios, ERR = 901) 
    149 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nam_asminc in reference namelist', lwp ) 
     149901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nam_asminc in reference namelist' ) 
    150150      REWIND( numnam_cfg )              ! Namelist nam_asminc in configuration namelist : Assimilation increment 
    151151      READ  ( numnam_cfg, nam_asminc, IOSTAT = ios, ERR = 902 ) 
    152 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nam_asminc in configuration namelist', lwp ) 
     152902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nam_asminc in configuration namelist' ) 
    153153      IF(lwm) WRITE ( numond, nam_asminc ) 
    154154 

  • NEMO/trunk/src/OCE/BDY/bdy_oce.F90

    r10934 r11536  
    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, DIMENSION(jp_bdy) ::   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/trunk/src/OCE/BDY/bdydta.F90

    r11229 r11536  
    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, jit, time_offset ) 
     77   SUBROUTINE bdy_dta( kt, kit, kt_offset ) 
    6878      !!---------------------------------------------------------------------- 
    6979      !!                   ***  SUBROUTINE bdy_dta  *** 
    … …  
    7585      !!---------------------------------------------------------------------- 
    7686      INTEGER, INTENT(in)           ::   kt           ! ocean time-step index  
    77       INTEGER, INTENT(in), OPTIONAL ::   jit          ! subcycle time-step index (for timesplitting option) 
    78       INTEGER, INTENT(in), OPTIONAL ::   time_offset  ! time offset in units of timesteps. NB. if jit 
     87      INTEGER, INTENT(in), OPTIONAL ::   kit          ! subcycle time-step index (for timesplitting option) 
     88      INTEGER, INTENT(in), OPTIONAL ::   kt_offset    ! time offset in units of timesteps. NB. if kit 
    7989      !                                               ! 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 
     90      !                                               ! kt_offset = 0 => get data at "now" time level 
     91      !                                               ! kt_offset = -1 => get data at "before" time level 
     92      !                                               ! kt_offset = +1 => get data at "after" time level 
    8393      !                                               ! etc. 
    8494      ! 
    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 
     95      INTEGER ::  jbdy, jfld, jstart, jend, ib, jl    ! dummy loop indices 
     96      INTEGER ::  ii, ij, ik, igrd, ipl               ! local integers 
     97      INTEGER,   DIMENSION(jpbgrd)     ::   ilen1  
     98      INTEGER,   DIMENSION(:), POINTER ::   nblen, nblenrim  ! short cuts 
     99      TYPE(OBC_DATA)         , POINTER ::   dta_alias        ! short cut 
     100      TYPE(FLD), DIMENSION(:), POINTER ::   bf_alias 
    90101      !!--------------------------------------------------------------------------- 
    91102      ! 
    … …  
    94105      ! Initialise data arrays once for all from initial conditions where required 
    95106      !--------------------------------------------------------------------------- 
    96       IF( kt == nit000 .AND. .NOT.PRESENT(jit) ) THEN 
     107      IF( kt == nit000 .AND. .NOT.PRESENT(kit) ) THEN 
    97108 
    98109         ! Calculate depth-mean currents 
    99110         !----------------------------- 
    100           
     111 
    101112         DO jbdy = 1, nb_bdy 
    102113            ! 
    103114            nblen    => idx_bdy(jbdy)%nblen 
    104115            nblenrim => idx_bdy(jbdy)%nblenrim 
    105             dta      => dta_bdy(jbdy) 
    106116            ! 
    107117            IF( nn_dyn2d_dta(jbdy) == 0 ) THEN  
    108118               ilen1(:) = nblen(:) 
    109                IF( dta%ll_ssh ) THEN  
     119               IF( dta_bdy(jbdy)%lneed_ssh ) THEN  
    110120                  igrd = 1 
    111121                  DO ib = 1, ilen1(igrd) 
    … …  
    113123                     ij = idx_bdy(jbdy)%nbj(ib,igrd) 
    114124                     dta_bdy(jbdy)%ssh(ib) = sshn(ii,ij) * tmask(ii,ij,1)          
    115                   END DO  
    116                ENDIF 
    117                IF( dta%ll_u2d ) THEN  
     125                  END DO 
     126               ENDIF 
     127               IF( dta_bdy(jbdy)%lneed_dyn2d) THEN  
    118128                  igrd = 2 
    119129                  DO ib = 1, ilen1(igrd) 
    … …  
    121131                     ij = idx_bdy(jbdy)%nbj(ib,igrd) 
    122132                     dta_bdy(jbdy)%u2d(ib) = un_b(ii,ij) * umask(ii,ij,1)          
    123                   END DO  
    124                ENDIF 
    125                IF( dta%ll_v2d ) THEN  
     133                  END DO 
    126134                  igrd = 3 
    127135                  DO ib = 1, ilen1(igrd) 
    … …  
    129137                     ij = idx_bdy(jbdy)%nbj(ib,igrd) 
    130138                     dta_bdy(jbdy)%v2d(ib) = vn_b(ii,ij) * vmask(ii,ij,1)          
    131                   END DO  
     139                  END DO 
    132140               ENDIF 
    133141            ENDIF 
    … …  
    135143            IF( nn_dyn3d_dta(jbdy) == 0 ) THEN  
    136144               ilen1(:) = nblen(:) 
    137                IF( dta%ll_u3d ) THEN  
     145               IF( dta_bdy(jbdy)%lneed_dyn3d ) THEN  
    138146                  igrd = 2  
    139147                  DO ib = 1, ilen1(igrd) 
    … …  
    143151                        dta_bdy(jbdy)%u3d(ib,ik) =  ( un(ii,ij,ik) - un_b(ii,ij) ) * umask(ii,ij,ik)          
    144152                     END DO 
    145                   END DO  
    146                ENDIF 
    147                IF( dta%ll_v3d ) THEN  
     153                  END DO 
    148154                  igrd = 3  
    149155                  DO ib = 1, ilen1(igrd) 
    … …  
    152158                        ij = idx_bdy(jbdy)%nbj(ib,igrd) 
    153159                        dta_bdy(jbdy)%v3d(ib,ik) =  ( vn(ii,ij,ik) - vn_b(ii,ij) ) * vmask(ii,ij,ik)          
    154                         END DO 
    155                   END DO  
     160                     END DO 
     161                  END DO 
    156162               ENDIF 
    157163            ENDIF 
    … …  
    159165            IF( nn_tra_dta(jbdy) == 0 ) THEN  
    160166               ilen1(:) = nblen(:) 
    161                IF( dta%ll_tem ) THEN 
     167               IF( dta_bdy(jbdy)%lneed_tra ) THEN 
    162168                  igrd = 1  
    163169                  DO ib = 1, ilen1(igrd) 
    … …  
    165171                        ii = idx_bdy(jbdy)%nbi(ib,igrd) 
    166172                        ij = idx_bdy(jbdy)%nbj(ib,igrd) 
    167                         dta_bdy(jbdy)%tem(ib,ik) = tsn(ii,ij,ik,jp_tem) * tmask(ii,ij,ik)          
     173                        dta_bdy(jbdy)%tem(ib,ik) = tsn(ii,ij,ik,jp_bdytem) * tmask(ii,ij,ik)          
     174                        dta_bdy(jbdy)%sal(ib,ik) = tsn(ii,ij,ik,jp_bdysal) * tmask(ii,ij,ik)          
    168175                     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) = tsn(ii,ij,ik,jp_sal) * tmask(ii,ij,ik)          
    178                      END DO 
    179                   END DO  
     176                  END DO 
    180177               ENDIF 
    181178            ENDIF 
    … …  
    184181            IF( nn_ice_dta(jbdy) == 0 ) THEN    ! set ice to initial values 
    185182               ilen1(:) = nblen(:) 
    186                IF( dta%ll_a_i ) THEN 
     183               IF( dta_bdy(jbdy)%lneed_ice ) THEN 
    187184                  igrd = 1    
    188185                  DO jl = 1, jpl 
    … …  
    190187                        ii = idx_bdy(jbdy)%nbi(ib,igrd) 
    191188                        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)  
     189                        dta_bdy(jbdy)%a_i(ib,jl) =  a_i (ii,ij,jl) * tmask(ii,ij,1)  
     190                        dta_bdy(jbdy)%h_i(ib,jl) =  h_i (ii,ij,jl) * tmask(ii,ij,1)  
     191                        dta_bdy(jbdy)%h_s(ib,jl) =  h_s (ii,ij,jl) * tmask(ii,ij,1)  
     192                        dta_bdy(jbdy)%t_i(ib,jl) =  SUM(t_i (ii,ij,:,jl)) * r1_nlay_i * tmask(ii,ij,1)  
     193                        dta_bdy(jbdy)%t_s(ib,jl) =  SUM(t_s (ii,ij,:,jl)) * r1_nlay_s * tmask(ii,ij,1) 
     194                        dta_bdy(jbdy)%tsu(ib,jl) =  t_su(ii,ij,jl) * tmask(ii,ij,1)  
     195                        dta_bdy(jbdy)%s_i(ib,jl) =  s_i (ii,ij,jl) * tmask(ii,ij,1) 
     196                        ! melt ponds 
     197                        dta_bdy(jbdy)%aip(ib,jl) =  a_ip(ii,ij,jl) * tmask(ii,ij,1)  
     198                        dta_bdy(jbdy)%hip(ib,jl) =  h_ip(ii,ij,jl) * tmask(ii,ij,1)  
    213199                     END DO 
    214200                  END DO 
    … …  
    222208      ! update external data from files 
    223209      !-------------------------------- 
    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        
    230             IF( PRESENT(jit) ) THEN 
    231                ! Update barotropic boundary conditions only 
    232                ! jit is optional argument for fld_read and bdytide_update 
    233                IF( cn_dyn2d(jbdy) /= 'none' ) THEN 
    234                   IF( nn_dyn2d_dta(jbdy) == 2 ) THEN ! tidal harmonic forcing ONLY: initialise arrays 
    235                      IF( dta%ll_ssh ) dta%ssh(:) = 0._wp 
    236                      IF( dta%ll_u2d ) dta%u2d(:) = 0._wp 
    237                      IF( dta%ll_u3d ) dta%v2d(:) = 0._wp 
    238                   ENDIF 
    239                   IF (cn_tra(jbdy) /= 'runoff') THEN 
    240                      IF( nn_dyn2d_dta(jbdy) == 1 .OR. nn_dyn2d_dta(jbdy) == 3 ) THEN 
    241  
    242                         jend = jstart + dta%nread(2) - 1 
    243                         IF( ln_full_vel_array(jbdy) ) THEN 
    244                            CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), map=nbmap_ptr(jstart:jend),  & 
    245                                      & kit=jit, kt_offset=time_offset , jpk_bdy=nb_jpk_bdy(jbdy),   & 
    246                                      & fvl=ln_full_vel_array(jbdy)  ) 
    247                         ELSE 
    248                            CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), map=nbmap_ptr(jstart:jend),  & 
    249                                      & kit=jit, kt_offset=time_offset  ) 
    250                         ENDIF 
    251  
    252                         ! If full velocities in boundary data then extract barotropic velocities from 3D fields 
    253                         IF( ln_full_vel_array(jbdy) .AND.                                             & 
    254                           &    ( nn_dyn2d_dta(jbdy) == 1 .OR. nn_dyn2d_dta(jbdy) == 3 .OR.  & 
    255                           &      nn_dyn3d_dta(jbdy) == 1 ) )THEN 
    256  
    257                            igrd = 2                      ! zonal velocity 
    258                            dta%u2d(:) = 0._wp 
    259                            DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 
    260                               ii   = idx_bdy(jbdy)%nbi(ib,igrd) 
    261                               ij   = idx_bdy(jbdy)%nbj(ib,igrd) 
    262                               DO ik = 1, jpkm1 
    263                                  dta%u2d(ib) = dta%u2d(ib) & 
    264                        &                          + e3u_n(ii,ij,ik) * umask(ii,ij,ik) * dta%u3d(ib,ik) 
    265                               END DO 
    266                               dta%u2d(ib) =  dta%u2d(ib) * r1_hu_n(ii,ij) 
    267                            END DO 
    268                            igrd = 3                      ! meridional velocity 
    269                            dta%v2d(:) = 0._wp 
    270                            DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 
    271                               ii   = idx_bdy(jbdy)%nbi(ib,igrd) 
    272                               ij   = idx_bdy(jbdy)%nbj(ib,igrd) 
    273                               DO ik = 1, jpkm1 
    274                                  dta%v2d(ib) = dta%v2d(ib) & 
    275                        &                       + e3v_n(ii,ij,ik) * vmask(ii,ij,ik) * dta%v3d(ib,ik) 
    276                               END DO 
    277                               dta%v2d(ib) =  dta%v2d(ib) * r1_hv_n(ii,ij) 
    278                            END DO 
    279                         ENDIF                     
    280                      ENDIF 
    281                      IF( nn_dyn2d_dta(jbdy) .ge. 2 ) THEN ! update tidal harmonic forcing 
    282                         CALL bdytide_update( kt=kt, idx=idx_bdy(jbdy), dta=dta, td=tides(jbdy),   &  
    283                           &                 jit=jit, time_offset=time_offset ) 
    284                      ENDIF 
    285                   ENDIF 
    286                ENDIF 
    287             ELSE 
    288                IF (cn_tra(jbdy) == 'runoff') then      ! runoff condition 
    289                   jend = nb_bdy_fld(jbdy) 
    290                   CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend),  & 
    291                                & map=nbmap_ptr(jstart:jend), kt_offset=time_offset ) 
    292                   ! 
    293                   igrd = 2                      ! zonal velocity 
    294                   DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 
    295                      ii   = idx_bdy(jbdy)%nbi(ib,igrd) 
    296                      ij   = idx_bdy(jbdy)%nbj(ib,igrd) 
    297                      dta%u2d(ib) = dta%u2d(ib) / ( e2u(ii,ij) * hu_0(ii,ij) ) 
    298                   END DO 
    299                   ! 
    300                   igrd = 3                      ! meridional velocity 
    301                   DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 
    302                      ii   = idx_bdy(jbdy)%nbi(ib,igrd) 
    303                      ij   = idx_bdy(jbdy)%nbj(ib,igrd) 
    304                      dta%v2d(ib) = dta%v2d(ib) / ( e1v(ii,ij) * hv_0(ii,ij) ) 
    305                   END DO 
    306                ELSE 
    307                   IF( nn_dyn2d_dta(jbdy) == 2 ) THEN ! tidal harmonic forcing ONLY: initialise arrays 
    308                      IF( dta%ll_ssh ) dta%ssh(:) = 0._wp 
    309                      IF( dta%ll_u2d ) dta%u2d(:) = 0._wp 
    310                      IF( dta%ll_v2d ) dta%v2d(:) = 0._wp 
    311                   ENDIF 
    312                   IF( dta%nread(1) .gt. 0 ) THEN ! update external data 
    313                      jend = jstart + dta%nread(1) - 1 
    314                      CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), & 
    315                                   & map=nbmap_ptr(jstart:jend), kt_offset=time_offset, jpk_bdy=nb_jpk_bdy(jbdy),   & 
    316                                   & fvl=ln_full_vel_array(jbdy) ) 
    317                   ENDIF 
    318                   ! If full velocities in boundary data then split into barotropic and baroclinic data 
    319                   IF( ln_full_vel_array(jbdy) .and.                                             & 
    320                     & ( nn_dyn2d_dta(jbdy) == 1 .OR. nn_dyn2d_dta(jbdy) == 3 .OR. & 
    321                     &   nn_dyn3d_dta(jbdy) == 1 ) ) THEN 
    322                      igrd = 2                      ! zonal velocity 
    323                      dta%u2d(:) = 0._wp 
    324                      DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 
    325                         ii   = idx_bdy(jbdy)%nbi(ib,igrd) 
    326                         ij   = idx_bdy(jbdy)%nbj(ib,igrd) 
    327                         DO ik = 1, jpkm1 
    328                            dta%u2d(ib) = dta%u2d(ib) & 
    329                  &                       + e3u_n(ii,ij,ik) * umask(ii,ij,ik) * dta%u3d(ib,ik) 
    330                         END DO 
    331                         dta%u2d(ib) =  dta%u2d(ib) * r1_hu_n(ii,ij) 
    332                         DO ik = 1, jpkm1 
    333                            dta%u3d(ib,ik) = dta%u3d(ib,ik) - dta%u2d(ib) 
    334                         END DO 
    335                      END DO 
    336                      igrd = 3                      ! meridional velocity 
    337                      dta%v2d(:) = 0._wp 
    338                      DO ib = 1, idx_bdy(jbdy)%nblen(igrd) 
    339                         ii   = idx_bdy(jbdy)%nbi(ib,igrd) 
    340                         ij   = idx_bdy(jbdy)%nbj(ib,igrd) 
    341                         DO ik = 1, jpkm1 
    342                            dta%v2d(ib) = dta%v2d(ib) & 
    343                  &                       + e3v_n(ii,ij,ik) * vmask(ii,ij,ik) * dta%v3d(ib,ik) 
    344                         END DO 
    345                         dta%v2d(ib) =  dta%v2d(ib) * r1_hv_n(ii,ij) 
    346                         DO ik = 1, jpkm1 
    347                            dta%v3d(ib,ik) = dta%v3d(ib,ik) - dta%v2d(ib) 
    348                         END DO 
    349                      END DO 
    350                   ENDIF 
    351  
    352                ENDIF 
     210 
     211      DO jbdy = 1, nb_bdy 
     212 
     213         dta_alias => dta_bdy(jbdy) 
     214         bf_alias  => bf(:,jbdy) 
     215 
     216         ! read/update all bdy data 
     217         ! ------------------------ 
     218         CALL fld_read( kt, 1, bf_alias, kit = kit, kt_offset = kt_offset ) 
     219 
     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_n(ii,ij,ik) * umask(ii,ij,ik) * dta_alias%u3d(ib,ik) 
     257               END DO 
     258               dta_alias%u2d(ib) =  dta_alias%u2d(ib) * r1_hu_n(ii,ij) 
     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) 
     261               END DO 
     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_n(ii,ij,ik) * vmask(ii,ij,ik) * dta_alias%v3d(ib,ik) 
     270               END DO 
     271               dta_alias%v2d(ib) =  dta_alias%v2d(ib) * r1_hv_n(ii,ij) 
     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 
    353294#if defined key_si3 
    354                ! convert N-cat fields (input) into jpl-cat (output) 
    355                IF( cn_ice(jbdy) /= 'none' .AND. nn_ice_dta(jbdy) == 1 ) THEN 
    356                   jfld_hti = jfld_htit(jbdy) 
    357                   jfld_hts = jfld_htst(jbdy) 
    358                   jfld_ai  = jfld_ait(jbdy) 
    359                   CALL ice_var_itd( bf(jfld_hti)%fnow(:,1,:), bf(jfld_hts)%fnow(:,1,:), bf(jfld_ai)%fnow(:,1,:), & 
    360                      &              dta_bdy(jbdy)%h_i       , dta_bdy(jbdy)%h_s       , dta_bdy(jbdy)%a_i      ) 
    361                ENDIF 
     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             
     323            ! convert N-cat fields (input) into jpl-cat (output) 
     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 
    362336#endif 
    363             ENDIF 
    364             jstart = jstart + dta%nread(1) 
    365          ENDIF    ! nn_dta(jbdy) = 1 
    366337      END DO  ! jbdy 
    367  
    368       IF ( ln_apr_obc ) THEN 
    369          DO jbdy = 1, nb_bdy 
    370             IF (cn_tra(jbdy) /= 'runoff')THEN 
    371                igrd = 1                      ! meridional velocity 
    372                DO ib = 1, idx_bdy(jbdy)%nblenrim(igrd) 
    373                   ii   = idx_bdy(jbdy)%nbi(ib,igrd) 
    374                   ij   = idx_bdy(jbdy)%nbj(ib,igrd) 
    375                   dta_bdy(jbdy)%ssh(ib) = dta_bdy(jbdy)%ssh(ib) + ssh_ib(ii,ij) 
    376                END DO 
    377             ENDIF 
    378          END DO 
    379       ENDIF 
    380338 
    381339      IF ( ln_tide ) THEN 
    382340         IF (ln_dynspg_ts) THEN      ! Fill temporary arrays with slow-varying bdy data                            
    383             DO jbdy = 1, nb_bdy    ! Tidal component added in ts loop 
    384                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 
    385343                  nblen => idx_bdy(jbdy)%nblen 
    386344                  nblenrim => idx_bdy(jbdy)%nblenrim 
    387                   IF( cn_dyn2d(jbdy) == 'frs' ) THEN; ilen1(:)=nblen(:) ; ELSE ; ilen1(:)=nblenrim(:) ; ENDIF  
    388                   IF ( dta_bdy(jbdy)%ll_ssh ) dta_bdy_s(jbdy)%ssh(1:ilen1(1)) = dta_bdy(jbdy)%ssh(1:ilen1(1)) 
    389                   IF ( dta_bdy(jbdy)%ll_u2d ) dta_bdy_s(jbdy)%u2d(1:ilen1(2)) = dta_bdy(jbdy)%u2d(1:ilen1(2)) 
    390                   IF ( dta_bdy(jbdy)%ll_v2d ) dta_bdy_s(jbdy)%v2d(1:ilen1(3)) = dta_bdy(jbdy)%v2d(1:ilen1(3)) 
    391                ENDIF 
    392             END DO 
    393          ELSE ! Add tides if not split-explicit free surface else this is done in ts loop 
    394             ! 
    395             CALL bdy_dta_tides( kt=kt, time_offset=time_offset ) 
    396          ENDIF 
    397       ENDIF 
    398  
    399       ! 
    400       IF( ln_timing )   CALL timing_stop('bdy_dta') 
    401       ! 
    402    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 
    403360 
    404361 
    … …  
    413370      !!                 
    414371      !!---------------------------------------------------------------------- 
    415       INTEGER ::   jbdy, jfld, jstart, jend, ierror, ios     ! Local integers 
     372      INTEGER ::   jbdy, jfld    ! Local integers 
     373      INTEGER ::   ierror, ios     !  
    416374      ! 
     375      CHARACTER(len=3)                       ::   cl3           !  
    417376      CHARACTER(len=100)                     ::   cn_dir        ! Root directory for location of data files 
    418       CHARACTER(len=100), DIMENSION(nb_bdy)  ::   cn_dir_array  ! Root directory for location of data files 
    419       CHARACTER(len = 256)::   clname                           ! temporary file name 
    420377      LOGICAL                                ::   ln_full_vel   ! =T => full velocities in 3D boundary data 
    421378      !                                                         ! =F => baroclinic velocities in 3D boundary data 
    422       INTEGER                                ::   ilen_global   ! Max length required for global bdy dta arrays 
    423       INTEGER, ALLOCATABLE, DIMENSION(:)     ::   ilen1, ilen3  ! size of 1st and 3rd dimensions of local arrays 
    424       INTEGER, ALLOCATABLE, DIMENSION(:)     ::   ibdy           ! bdy set for a particular jfld 
    425       INTEGER, ALLOCATABLE, DIMENSION(:)     ::   igrid         ! index for grid type (1,2,3 = T,U,V) 
    426       INTEGER, POINTER, DIMENSION(:)         ::   nblen, nblenrim  ! short cuts 
    427       TYPE(OBC_DATA), POINTER                ::   dta           ! short cut 
    428 #if defined key_si3 
    429       INTEGER               ::   kndims   ! number of dimensions in an array (i.e. 3 = wo ice cat; 4 = w ice cat) 
    430       INTEGER, DIMENSION(4) ::   kdimsz   ! size   of dimensions 
    431       INTEGER               ::   inum,id1 ! local integer 
    432 #endif 
    433       TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) ::   blf_i         !  array of namelist information structures 
    434       TYPE(FLD_N) ::   bn_tem, bn_sal, bn_u3d, bn_v3d   !  
    435       TYPE(FLD_N) ::   bn_ssh, bn_u2d, bn_v2d           ! informations about the fields to be read 
    436 #if defined key_si3 
    437       TYPE(FLD_N) ::   bn_a_i, bn_h_i, bn_h_s       
    438 #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      ! 
    439396      NAMELIST/nambdy_dta/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d  
    440 #if defined key_si3 
    441       NAMELIST/nambdy_dta/ bn_a_i, bn_h_i, bn_h_s 
    442 #endif 
    443       NAMELIST/nambdy_dta/ ln_full_vel 
     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 
    444400      !!--------------------------------------------------------------------------- 
    445401      ! 
    … …  
    449405      IF(lwp) WRITE(numout,*) '' 
    450406 
    451       ! Set nn_dta 
    452       DO jbdy = 1, nb_bdy 
    453          nn_dta(jbdy) = MAX(   nn_dyn2d_dta  (jbdy)    & 
    454             &                , nn_dyn3d_dta  (jbdy)    & 
    455             &                , nn_tra_dta    (jbdy)    & 
    456 #if defined key_si3 
    457             &                , nn_ice_dta    (jbdy)    & 
    458 #endif 
    459                               ) 
    460          IF(nn_dta(jbdy) > 1)   nn_dta(jbdy) = 1 
    461       END DO 
    462  
    463       ! Work out upper bound of how many fields there are to read in and allocate arrays 
    464       ! --------------------------------------------------------------------------- 
    465       ALLOCATE( nb_bdy_fld(nb_bdy) ) 
    466       nb_bdy_fld(:) = 0 
    467       DO jbdy = 1, nb_bdy          
    468          IF( cn_dyn2d(jbdy) /= 'none' .AND. ( nn_dyn2d_dta(jbdy) == 1 .or. nn_dyn2d_dta(jbdy) == 3 ) ) THEN 
    469             nb_bdy_fld(jbdy) = nb_bdy_fld(jbdy) + 3 
    470          ENDIF 
    471          IF( cn_dyn3d(jbdy) /= 'none' .AND. nn_dyn3d_dta(jbdy) == 1 ) THEN 
    472             nb_bdy_fld(jbdy) = nb_bdy_fld(jbdy) + 2 
    473          ENDIF 
    474          IF( cn_tra(jbdy) /= 'none' .AND. nn_tra_dta(jbdy) == 1  ) THEN 
    475             nb_bdy_fld(jbdy) = nb_bdy_fld(jbdy) + 2 
    476          ENDIF 
    477 #if defined key_si3 
    478          IF( cn_ice(jbdy) /= 'none' .AND. nn_ice_dta(jbdy) == 1  ) THEN 
    479             nb_bdy_fld(jbdy) = nb_bdy_fld(jbdy) + 3 
    480          ENDIF 
    481 #endif                
    482          IF(lwp) WRITE(numout,*) 'Maximum number of files to open =', nb_bdy_fld(jbdy) 
    483       END DO             
    484  
    485       nb_bdy_fld_sum = SUM( nb_bdy_fld ) 
    486  
    487       ALLOCATE( bf(nb_bdy_fld_sum), STAT=ierror ) 
     407      ALLOCATE( bf(jpbdyfld,nb_bdy), STAT=ierror ) 
    488408      IF( ierror > 0 ) THEN    
    489409         CALL ctl_stop( 'bdy_dta: unable to allocate bf structure' )   ;   RETURN   
    490410      ENDIF 
    491       ALLOCATE( blf_i(nb_bdy_fld_sum), STAT=ierror ) 
    492       IF( ierror > 0 ) THEN    
    493          CALL ctl_stop( 'bdy_dta: unable to allocate blf_i structure' )   ;   RETURN   
    494       ENDIF 
    495       ALLOCATE( nbmap_ptr(nb_bdy_fld_sum), STAT=ierror ) 
    496       IF( ierror > 0 ) THEN    
    497          CALL ctl_stop( 'bdy_dta: unable to allocate nbmap_ptr structure' )   ;   RETURN   
    498       ENDIF 
    499       ALLOCATE( ilen1(nb_bdy_fld_sum), ilen3(nb_bdy_fld_sum) )  
    500       ALLOCATE( ibdy(nb_bdy_fld_sum) )  
    501       ALLOCATE( igrid(nb_bdy_fld_sum) )  
    502  
     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  
    503415      ! Read namelists 
    504416      ! -------------- 
    505417      REWIND(numnam_cfg) 
    506       jfld = 0  
    507       DO jbdy = 1, nb_bdy          
    508          IF( nn_dta(jbdy) == 1 ) THEN 
    509             REWIND(numnam_ref) 
    510             READ  ( numnam_ref, nambdy_dta, IOSTAT = ios, ERR = 901) 
    511 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 
    512434            READ  ( numnam_cfg, nambdy_dta, IOSTAT = ios, ERR = 902 ) 
    513 902         IF( ios >  0 )   CALL ctl_nam ( ios , 'nambdy_dta in configuration namelist', lwp ) 
    514             IF(lwm) WRITE( numond, nambdy_dta ) 
    515  
    516             cn_dir_array(jbdy) = cn_dir 
    517             ln_full_vel_array(jbdy) = ln_full_vel 
    518  
    519             nblen => idx_bdy(jbdy)%nblen 
    520             nblenrim => idx_bdy(jbdy)%nblenrim 
    521             dta => dta_bdy(jbdy) 
    522             dta%nread(2) = 0 
    523  
    524             ! Only read in necessary fields for this set. 
    525             ! Important that barotropic variables come first. 
    526             IF( nn_dyn2d_dta(jbdy) == 1 .or. nn_dyn2d_dta(jbdy) == 3 ) THEN  
    527  
    528                IF( dta%ll_ssh ) THEN  
    529                   if(lwp) write(numout,*) '++++++ reading in ssh field' 
    530                   jfld = jfld + 1 
    531                   blf_i(jfld) = bn_ssh 
    532                   ibdy(jfld) = jbdy 
    533                   igrid(jfld) = 1 
    534                   ilen1(jfld) = nblen(igrid(jfld)) 
    535                   ilen3(jfld) = 1 
    536                   dta%nread(2) = dta%nread(2) + 1 
    537                ENDIF 
    538  
    539                IF( dta%ll_u2d .and. .not. ln_full_vel_array(jbdy) ) THEN 
    540                   if(lwp) write(numout,*) '++++++ reading in u2d field' 
    541                   jfld = jfld + 1 
    542                   blf_i(jfld) = bn_u2d 
    543                   ibdy(jfld) = jbdy 
    544                   igrid(jfld) = 2 
    545                   ilen1(jfld) = nblen(igrid(jfld)) 
    546                   ilen3(jfld) = 1 
    547                   dta%nread(2) = dta%nread(2) + 1 
    548                ENDIF 
    549  
    550                IF( dta%ll_v2d .and. .not. ln_full_vel_array(jbdy) ) THEN 
    551                   if(lwp) write(numout,*) '++++++ reading in v2d field' 
    552                   jfld = jfld + 1 
    553                   blf_i(jfld) = bn_v2d 
    554                   ibdy(jfld) = jbdy 
    555                   igrid(jfld) = 3 
    556                   ilen1(jfld) = nblen(igrid(jfld)) 
    557                   ilen3(jfld) = 1 
    558                   dta%nread(2) = dta%nread(2) + 1 
    559                ENDIF 
    560  
    561             ENDIF 
    562  
    563             ! read 3D velocities if baroclinic velocities require OR if 
    564             ! barotropic velocities required and ln_full_vel set to .true. 
    565             IF( nn_dyn3d_dta(jbdy) == 1 .OR. & 
    566            &  ( ln_full_vel_array(jbdy) .AND. ( nn_dyn2d_dta(jbdy) == 1 .OR. nn_dyn2d_dta(jbdy) == 3 ) ) ) THEN 
    567  
    568                IF( dta%ll_u3d .OR. ( ln_full_vel_array(jbdy) .and. dta%ll_u2d ) ) THEN 
    569                   if(lwp) write(numout,*) '++++++ reading in u3d field' 
    570                   jfld = jfld + 1 
    571                   blf_i(jfld) = bn_u3d 
    572                   ibdy(jfld) = jbdy 
    573                   igrid(jfld) = 2 
    574                   ilen1(jfld) = nblen(igrid(jfld)) 
    575                   ilen3(jfld) = jpk 
    576                   IF( ln_full_vel_array(jbdy) .and. dta%ll_u2d ) dta%nread(2) = dta%nread(2) + 1 
    577                ENDIF 
    578  
    579                IF( dta%ll_v3d .OR. ( ln_full_vel_array(jbdy) .and. dta%ll_v2d ) ) THEN 
    580                   if(lwp) write(numout,*) '++++++ reading in v3d field' 
    581                   jfld = jfld + 1 
    582                   blf_i(jfld) = bn_v3d 
    583                   ibdy(jfld) = jbdy 
    584                   igrid(jfld) = 3 
    585                   ilen1(jfld) = nblen(igrid(jfld)) 
    586                   ilen3(jfld) = jpk 
    587                   IF( ln_full_vel_array(jbdy) .and. dta%ll_v2d ) dta%nread(2) = dta%nread(2) + 1 
    588                ENDIF 
    589  
    590             ENDIF 
    591  
    592             ! temperature and salinity 
    593             IF( nn_tra_dta(jbdy) == 1 ) THEN 
    594  
    595                IF( dta%ll_tem ) THEN 
    596                   if(lwp) write(numout,*) '++++++ reading in tem field' 
    597                   jfld = jfld + 1 
    598                   blf_i(jfld) = bn_tem 
    599                   ibdy(jfld) = jbdy 
    600                   igrid(jfld) = 1 
    601                   ilen1(jfld) = nblen(igrid(jfld)) 
    602                   ilen3(jfld) = jpk 
    603                ENDIF 
    604  
    605                IF( dta%ll_sal ) THEN 
    606                   if(lwp) write(numout,*) '++++++ reading in sal field' 
    607                   jfld = jfld + 1 
    608                   blf_i(jfld) = bn_sal 
    609                   ibdy(jfld) = jbdy 
    610                   igrid(jfld) = 1 
    611                   ilen1(jfld) = nblen(igrid(jfld)) 
    612                   ilen3(jfld) = jpk 
    613                ENDIF 
    614  
    615             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 
    616451 
    617452#if defined key_si3 
    618             ! sea ice 
    619             IF( nn_ice_dta(jbdy) == 1 ) THEN 
    620                ! Test for types of ice input (1cat or Xcat)  
    621                ! Build file name to find dimensions  
    622                clname=TRIM( cn_dir )//TRIM(bn_a_i%clname) 
    623                IF( .NOT. bn_a_i%ln_clim ) THEN    
    624                                                   WRITE(clname, '(a,"_y",i4.4)' ) TRIM( clname ), nyear    ! add year 
    625                   IF( bn_a_i%cltype /= 'yearly' ) WRITE(clname, '(a,"m" ,i2.2)' ) TRIM( clname ), nmonth   ! add month 
    626                ELSE 
    627                   IF( bn_a_i%cltype /= 'yearly' ) WRITE(clname, '(a,"_m",i2.2)' ) TRIM( clname ), nmonth   ! add month 
    628                ENDIF 
    629                IF( bn_a_i%cltype == 'daily' .OR. bn_a_i%cltype(1:4) == 'week' ) & 
    630                &                                  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 
    631620               ! 
    632                CALL iom_open  ( clname, inum ) 
    633                id1 = iom_varid( inum, bn_a_i%clvar, kdimsz=kdimsz, kndims=kndims, ldstop = .FALSE. ) 
    634                CALL iom_close ( inum ) 
    635  
    636                 IF ( kndims == 4 ) THEN 
    637                  nice_cat = kdimsz(4)   ! Xcat input 
    638                ELSE 
    639                  nice_cat = 1           ! 1cat input       
    640                ENDIF 
    641                ! End test 
    642  
    643                IF( dta%ll_a_i ) THEN 
    644                   jfld = jfld + 1 
    645                   blf_i(jfld) = bn_a_i 
    646                   ibdy(jfld)  = jbdy 
    647                   igrid(jfld) = 1 
    648                   ilen1(jfld) = nblen(igrid(jfld)) 
    649                   ilen3(jfld) = nice_cat 
    650                ENDIF 
    651  
    652                IF( dta%ll_h_i ) THEN 
    653                   jfld = jfld + 1 
    654                   blf_i(jfld) = bn_h_i 
    655                   ibdy(jfld)  = jbdy 
    656                   igrid(jfld) = 1 
    657                   ilen1(jfld) = nblen(igrid(jfld)) 
    658                   ilen3(jfld) = nice_cat 
    659                ENDIF 
    660  
    661                IF( dta%ll_h_s ) THEN 
    662                   jfld = jfld + 1 
    663                   blf_i(jfld) = bn_h_s 
    664                   ibdy(jfld)  = jbdy 
    665                   igrid(jfld) = 1 
    666                   ilen1(jfld) = nblen(igrid(jfld)) 
    667                   ilen3(jfld) = nice_cat 
    668                ENDIF 
    669  
    670             ENDIF 
    671 #endif 
    672             ! Recalculate field counts 
    673             !------------------------- 
    674             IF( jbdy == 1 ) THEN  
    675                nb_bdy_fld_sum = 0 
    676                nb_bdy_fld(jbdy) = jfld 
    677                nb_bdy_fld_sum     = jfld               
    678             ELSE 
    679                nb_bdy_fld(jbdy) = jfld - nb_bdy_fld_sum 
    680                nb_bdy_fld_sum = nb_bdy_fld_sum + nb_bdy_fld(jbdy) 
    681             ENDIF 
    682  
    683             dta%nread(1) = nb_bdy_fld(jbdy) 
    684  
    685          ENDIF ! nn_dta == 1 
    686       ENDDO ! jbdy 
    687  
    688       DO jfld = 1, nb_bdy_fld_sum 
    689          ALLOCATE( bf(jfld)%fnow(ilen1(jfld),1,ilen3(jfld)) ) 
    690          IF( blf_i(jfld)%ln_tint ) ALLOCATE( bf(jfld)%fdta(ilen1(jfld),1,ilen3(jfld),2) ) 
    691          nbmap_ptr(jfld)%ptr => idx_bdy(ibdy(jfld))%nbmap(:,igrid(jfld)) 
    692          nbmap_ptr(jfld)%ll_unstruc = ln_coords_file(ibdy(jfld)) 
    693       ENDDO 
    694  
    695       ! fill bf with blf_i and control print 
    696       !------------------------------------- 
    697       jstart = 1 
    698       DO jbdy = 1, nb_bdy 
    699          jend = jstart - 1 + nb_bdy_fld(jbdy)  
    700          CALL fld_fill( bf(jstart:jend), blf_i(jstart:jend), cn_dir_array(jbdy), 'bdy_dta',   & 
    701          &              'open boundary conditions', 'nambdy_dta' ) 
    702          jstart = jend + 1 
    703       ENDDO 
    704  
    705       DO jfld = 1, nb_bdy_fld_sum 
    706          bf(jfld)%igrd = igrid(jfld) 
    707          bf(jfld)%ibdy = ibdy(jfld) 
    708       ENDDO 
    709  
    710       ! Initialise local boundary data arrays 
    711       ! nn_xxx_dta=0 : allocate space - will be filled from initial conditions later 
    712       ! nn_xxx_dta=1 : point to "fnow" arrays 
    713       !------------------------------------- 
    714  
    715       jfld = 0 
    716       DO jbdy=1, nb_bdy 
    717  
    718          nblen => idx_bdy(jbdy)%nblen 
    719          dta => dta_bdy(jbdy) 
    720  
    721          if(lwp) then 
    722             write(numout,*) '++++++ dta%ll_ssh = ',dta%ll_ssh 
    723             write(numout,*) '++++++ dta%ll_u2d = ',dta%ll_u2d 
    724             write(numout,*) '++++++ dta%ll_v2d = ',dta%ll_v2d 
    725             write(numout,*) '++++++ dta%ll_u3d = ',dta%ll_u3d 
    726             write(numout,*) '++++++ dta%ll_v3d = ',dta%ll_v3d 
    727             write(numout,*) '++++++ dta%ll_tem = ',dta%ll_tem 
    728             write(numout,*) '++++++ dta%ll_sal = ',dta%ll_sal 
    729          endif 
    730  
    731          IF ( nn_dyn2d_dta(jbdy) == 0 .or. nn_dyn2d_dta(jbdy) == 2 ) THEN 
    732             if(lwp) write(numout,*) '++++++ dta%ssh/u2d/u3d allocated space' 
    733             IF( dta%ll_ssh ) ALLOCATE( dta%ssh(nblen(1)) ) 
    734             IF( dta%ll_u2d ) ALLOCATE( dta%u2d(nblen(2)) ) 
    735             IF( dta%ll_v2d ) ALLOCATE( dta%v2d(nblen(3)) ) 
    736          ENDIF 
    737          IF ( nn_dyn2d_dta(jbdy) == 1 .or. nn_dyn2d_dta(jbdy) == 3 ) THEN 
    738             IF( dta%ll_ssh ) THEN 
    739                if(lwp) write(numout,*) '++++++ dta%ssh pointing to fnow' 
    740                jfld = jfld + 1 
    741                dta%ssh => bf(jfld)%fnow(:,1,1) 
    742             ENDIF 
    743             IF ( dta%ll_u2d ) THEN 
    744                IF ( ln_full_vel_array(jbdy) ) THEN 
    745                   if(lwp) write(numout,*) '++++++ dta%u2d allocated space' 
    746                   ALLOCATE( dta%u2d(nblen(2)) ) 
    747                ELSE 
    748                   if(lwp) write(numout,*) '++++++ dta%u2d pointing to fnow' 
    749                   jfld = jfld + 1 
    750                   dta%u2d => bf(jfld)%fnow(:,1,1) 
    751                ENDIF 
    752             ENDIF 
    753             IF ( dta%ll_v2d ) THEN 
    754                IF ( ln_full_vel_array(jbdy) ) THEN 
    755                   if(lwp) write(numout,*) '++++++ dta%v2d allocated space' 
    756                   ALLOCATE( dta%v2d(nblen(3)) ) 
    757                ELSE 
    758                   if(lwp) write(numout,*) '++++++ dta%v2d pointing to fnow' 
    759                   jfld = jfld + 1 
    760                   dta%v2d => bf(jfld)%fnow(:,1,1) 
    761                ENDIF 
    762             ENDIF 
    763          ENDIF 
    764  
    765          IF ( nn_dyn3d_dta(jbdy) == 0 ) THEN 
    766             if(lwp) write(numout,*) '++++++ dta%u3d/v3d allocated space' 
    767             IF( dta%ll_u3d ) ALLOCATE( dta_bdy(jbdy)%u3d(nblen(2),jpk) ) 
    768             IF( dta%ll_v3d ) ALLOCATE( dta_bdy(jbdy)%v3d(nblen(3),jpk) ) 
    769          ENDIF 
    770          IF ( nn_dyn3d_dta(jbdy) == 1 .or. & 
    771            &  ( ln_full_vel_array(jbdy) .and. ( nn_dyn2d_dta(jbdy) == 1 .or. nn_dyn2d_dta(jbdy) == 3 ) ) ) THEN 
    772             IF ( dta%ll_u3d .or. ( ln_full_vel_array(jbdy) .and. dta%ll_u2d ) ) THEN 
    773                if(lwp) write(numout,*) '++++++ dta%u3d pointing to fnow' 
    774                jfld = jfld + 1 
    775                dta_bdy(jbdy)%u3d => bf(jfld)%fnow(:,1,:) 
    776             ENDIF 
    777             IF ( dta%ll_v3d .or. ( ln_full_vel_array(jbdy) .and. dta%ll_v2d ) ) THEN 
    778                if(lwp) write(numout,*) '++++++ dta%v3d pointing to fnow' 
    779                jfld = jfld + 1 
    780                dta_bdy(jbdy)%v3d => bf(jfld)%fnow(:,1,:) 
    781             ENDIF 
    782          ENDIF 
    783  
    784          IF( nn_tra_dta(jbdy) == 0 ) THEN 
    785             if(lwp) write(numout,*) '++++++ dta%tem/sal allocated space' 
    786             IF( dta%ll_tem ) ALLOCATE( dta_bdy(jbdy)%tem(nblen(1),jpk) ) 
    787             IF( dta%ll_sal ) ALLOCATE( dta_bdy(jbdy)%sal(nblen(1),jpk) ) 
    788          ELSE 
    789             IF( dta%ll_tem ) THEN 
    790                if(lwp) write(numout,*) '++++++ dta%tem pointing to fnow' 
    791                jfld = jfld + 1 
    792                dta_bdy(jbdy)%tem => bf(jfld)%fnow(:,1,:) 
    793             ENDIF 
    794             IF( dta%ll_sal ) THEN  
    795                if(lwp) write(numout,*) '++++++ dta%sal pointing to fnow' 
    796                jfld = jfld + 1 
    797                dta_bdy(jbdy)%sal => bf(jfld)%fnow(:,1,:) 
    798             ENDIF 
    799          ENDIF 
    800  
    801 #if defined key_si3 
    802          IF (cn_ice(jbdy) /= 'none') THEN 
    803             IF( nn_ice_dta(jbdy) == 0 ) THEN 
    804                ALLOCATE( dta_bdy(jbdy)%a_i(nblen(1),jpl) ) 
    805                ALLOCATE( dta_bdy(jbdy)%h_i(nblen(1),jpl) ) 
    806                ALLOCATE( dta_bdy(jbdy)%h_s(nblen(1),jpl) ) 
    807             ELSE 
    808                IF ( nice_cat == jpl ) THEN ! case input cat = jpl 
    809                   jfld = jfld + 1 
    810                   dta_bdy(jbdy)%a_i => bf(jfld)%fnow(:,1,:) 
    811                   jfld = jfld + 1 
    812                   dta_bdy(jbdy)%h_i => bf(jfld)%fnow(:,1,:) 
    813                   jfld = jfld + 1 
    814                   dta_bdy(jbdy)%h_s => bf(jfld)%fnow(:,1,:) 
    815                ELSE                        ! case input cat = 1 OR (/=1 and /=jpl) 
    816                   jfld_ait(jbdy)  = jfld + 1 
    817                   jfld_htit(jbdy) = jfld + 2 
    818                   jfld_htst(jbdy) = jfld + 3 
    819                   jfld     = jfld + 3 
    820                   ALLOCATE( dta_bdy(jbdy)%a_i(nblen(1),jpl) ) 
    821                   ALLOCATE( dta_bdy(jbdy)%h_i(nblen(1),jpl) ) 
    822                   ALLOCATE( dta_bdy(jbdy)%h_s(nblen(1),jpl) ) 
    823                   dta_bdy(jbdy)%a_i(:,:) = 0._wp 
    824                   dta_bdy(jbdy)%h_i(:,:) = 0._wp 
    825                   dta_bdy(jbdy)%h_s(:,:) = 0._wp 
    826                ENDIF 
    827  
    828             ENDIF 
    829          ENDIF 
    830 #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 
    831686         ! 
    832687      END DO ! jbdy  
    833688      ! 
    834689   END SUBROUTINE bdy_dta_init 
    835  
     690    
    836691   !!============================================================================== 
    837692END MODULE bdydta 

  • NEMO/trunk/src/OCE/BDY/bdydyn2d.F90

    r11072 r11536  
    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(ii+NINT(flagu),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,ij+NINT(flagv)) 
    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/trunk/src/OCE/BDY/bdydyn3d.F90

    r10529 r11536  
    4242      INTEGER, INTENT(in) ::   kt   ! Main time step counter 
    4343      ! 
    44       INTEGER ::   ib_bdy   ! loop index 
    45       !!---------------------------------------------------------------------- 
    46       ! 
    47       DO ib_bdy=1, nb_bdy 
     44      INTEGER  ::   ib_bdy, ir     ! BDY set index, rim index 
     45      LOGICAL  ::   llrim0         ! indicate if rim 0 is treated 
     46      LOGICAL, DIMENSION(4) :: llsend2, llrecv2, llsend3, llrecv3  ! indicate how communications are to be carried out 
     47 
     48      !!---------------------------------------------------------------------- 
     49      llsend2(:) = .false.   ;   llrecv2(:) = .false. 
     50      llsend3(:) = .false.   ;   llrecv3(:) = .false. 
     51      DO ir = 1, 0, -1   ! treat rim 1 before rim 0 
     52         IF( ir == 0 ) THEN   ;   llrim0 = .TRUE. 
     53         ELSE                 ;   llrim0 = .FALSE. 
     54         END IF 
     55         DO ib_bdy=1, nb_bdy 
     56            ! 
     57            SELECT CASE( cn_dyn3d(ib_bdy) ) 
     58            CASE('none')        ;   CYCLE 
     59            CASE('frs' )        ! treat the whole boundary at once 
     60               IF( ir == 0) CALL bdy_dyn3d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
     61            CASE('specified')   ! treat the whole rim      at once 
     62               IF( ir == 0) CALL bdy_dyn3d_spe( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
     63            CASE('zero')        ! treat the whole rim      at once 
     64               IF( ir == 0) CALL bdy_dyn3d_zro( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
     65            CASE('orlanski' )   ;   CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, llrim0, ll_npo=.false. ) 
     66            CASE('orlanski_npo');   CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, llrim0, ll_npo=.true.  ) 
     67            CASE('zerograd')    ;   CALL bdy_dyn3d_zgrad( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy, llrim0 ) 
     68            CASE('neumann')     ;   CALL bdy_dyn3d_nmn( idx_bdy(ib_bdy), ib_bdy, llrim0 ) 
     69            CASE DEFAULT        ;   CALL ctl_stop( 'bdy_dyn3d : unrecognised option for open boundaries for baroclinic velocities' ) 
     70            END SELECT 
     71         END DO 
    4872         ! 
    49          SELECT CASE( cn_dyn3d(ib_bdy) ) 
    50          CASE('none')        ;   CYCLE 
    51          CASE('frs' )        ;   CALL bdy_dyn3d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
    52          CASE('specified')   ;   CALL bdy_dyn3d_spe( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
    53          CASE('zero')        ;   CALL bdy_dyn3d_zro( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
    54          CASE('orlanski' )   ;   CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, ll_npo=.false. ) 
    55          CASE('orlanski_npo');   CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, ll_npo=.true. ) 
    56          CASE('zerograd')    ;   CALL bdy_dyn3d_zgrad( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 
    57          CASE('neumann')     ;   CALL bdy_dyn3d_nmn( idx_bdy(ib_bdy), ib_bdy ) 
    58          CASE DEFAULT        ;   CALL ctl_stop( 'bdy_dyn3d : unrecognised option for open boundaries for baroclinic velocities' ) 
    59          END SELECT 
    60       END DO 
     73         IF( nn_hls > 1 .AND. ir == 1 ) CYCLE   ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 
     74         IF( nn_hls == 1 ) THEN 
     75            llsend2(:) = .false.   ;   llrecv2(:) = .false. 
     76            llsend3(:) = .false.   ;   llrecv3(:) = .false. 
     77         END IF 
     78         DO ib_bdy=1, nb_bdy 
     79            SELECT CASE( cn_dyn3d(ib_bdy) ) 
     80            CASE('orlanski', 'orlanski_npo') 
     81               llsend2(:) = llsend2(:) .OR. lsend_bdy(ib_bdy,2,:,ir)   ! possibly every direction, U points 
     82               llrecv2(:) = llrecv2(:) .OR. lrecv_bdy(ib_bdy,2,:,ir)   ! possibly every direction, U points 
     83               llsend3(:) = llsend3(:) .OR. lsend_bdy(ib_bdy,3,:,ir)   ! possibly every direction, V points 
     84               llrecv3(:) = llrecv3(:) .OR. lrecv_bdy(ib_bdy,3,:,ir)   ! possibly every direction, V points 
     85            CASE('zerograd') 
     86               llsend2(3:4) = llsend2(3:4) .OR. lsend_bdyint(ib_bdy,2,3:4,ir)   ! north/south, U points 
     87               llrecv2(3:4) = llrecv2(3:4) .OR. lrecv_bdyint(ib_bdy,2,3:4,ir)   ! north/south, U points 
     88               llsend3(1:2) = llsend3(1:2) .OR. lsend_bdyint(ib_bdy,3,1:2,ir)   ! west/east, V points 
     89               llrecv3(1:2) = llrecv3(1:2) .OR. lrecv_bdyint(ib_bdy,3,1:2,ir)   ! west/east, V points 
     90            CASE('neumann') 
     91               llsend2(:) = llsend2(:) .OR. lsend_bdyint(ib_bdy,2,:,ir)   ! possibly every direction, U points 
     92               llrecv2(:) = llrecv2(:) .OR. lrecv_bdyint(ib_bdy,2,:,ir)   ! possibly every direction, U points 
     93               llsend3(:) = llsend3(:) .OR. lsend_bdyint(ib_bdy,3,:,ir)   ! possibly every direction, V points 
     94               llrecv3(:) = llrecv3(:) .OR. lrecv_bdyint(ib_bdy,3,:,ir)   ! possibly every direction, V points 
     95            END SELECT 
     96         END DO 
     97         ! 
     98         IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN   ! if need to send/recv in at least one direction 
     99            CALL lbc_lnk( 'bdydyn2d', ua, 'U', -1., kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) 
     100         END IF 
     101         IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN   ! if need to send/recv in at least one direction 
     102            CALL lbc_lnk( 'bdydyn2d', va, 'V', -1., kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) 
     103         END IF 
     104      END DO   ! ir 
    61105      ! 
    62106   END SUBROUTINE bdy_dyn3d 
    … …  
    78122      INTEGER  ::   jb, jk         ! dummy loop indices 
    79123      INTEGER  ::   ii, ij, igrd   ! local integers 
    80       REAL(wp) ::   zwgt           ! boundary weight 
    81124      !!---------------------------------------------------------------------- 
    82125      ! 
    … …  
    98141         END DO 
    99142      END DO 
    100       CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy )   ! Boundary points should be updated   
    101       CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy )    
    102       ! 
    103       IF( kt == nit000 )   CLOSE( unit = 102 ) 
    104143      ! 
    105144   END SUBROUTINE bdy_dyn3d_spe 
    106145 
    107146 
    108    SUBROUTINE bdy_dyn3d_zgrad( idx, dta, kt , ib_bdy ) 
     147   SUBROUTINE bdy_dyn3d_zgrad( idx, dta, kt, ib_bdy, llrim0 ) 
    109148      !!---------------------------------------------------------------------- 
    110149      !!                  ***  SUBROUTINE bdy_dyn3d_zgrad  *** 
    … …  
    114153      !!---------------------------------------------------------------------- 
    115154      INTEGER                     ::   kt 
    116       TYPE(OBC_INDEX), INTENT(in) ::   idx  ! OBC indices 
    117       TYPE(OBC_DATA),  INTENT(in) ::   dta  ! OBC external data 
    118       INTEGER,         INTENT(in) ::   ib_bdy  ! BDY set index 
     155      TYPE(OBC_INDEX), INTENT(in) ::   idx      ! OBC indices 
     156      TYPE(OBC_DATA),  INTENT(in) ::   dta      ! OBC external data 
     157      INTEGER,         INTENT(in) ::   ib_bdy   ! BDY set index 
     158      LOGICAL,         INTENT(in) ::   llrim0   ! indicate if rim 0 is treated 
    119159      !! 
    120160      INTEGER  ::   jb, jk         ! dummy loop indices 
    121161      INTEGER  ::   ii, ij, igrd   ! local integers 
    122       REAL(wp) ::   zwgt           ! boundary weight 
    123       INTEGER  ::   fu, fv 
     162      INTEGER  ::   flagu, flagv           ! short cuts 
     163      INTEGER  ::   ibeg, iend     ! length of rim to be treated (rim 0 or rim 1 or both) 
    124164      !!---------------------------------------------------------------------- 
    125165      ! 
    126166      igrd = 2                      ! Copying tangential velocity into bdy points 
    127       DO jb = 1, idx%nblenrim(igrd) 
    128          DO jk = 1, jpkm1 
    129             ii   = idx%nbi(jb,igrd) 
    130             ij   = idx%nbj(jb,igrd) 
    131             fu   = ABS( ABS (NINT( idx%flagu(jb,igrd) ) ) - 1 ) 
    132             ua(ii,ij,jk) = ua(ii,ij,jk) * REAL( 1 - fu) + ( ua(ii,ij+fu,jk) * umask(ii,ij+fu,jk) & 
    133                         &+ ua(ii,ij-fu,jk) * umask(ii,ij-fu,jk) ) * umask(ii,ij,jk) * REAL( fu ) 
    134          END DO 
     167      IF( llrim0 ) THEN   ;   ibeg = 1                       ;   iend = idx%nblenrim0(igrd) 
     168      ELSE                ;   ibeg = idx%nblenrim0(igrd)+1   ;   iend = idx%nblenrim(igrd) 
     169      ENDIF 
     170      DO jb = ibeg, iend 
     171         ii    = idx%nbi(jb,igrd) 
     172         ij    = idx%nbj(jb,igrd) 
     173         flagu = NINT(idx%flagu(jb,igrd)) 
     174         flagv = NINT(idx%flagv(jb,igrd)) 
     175         ! 
     176         IF( flagu == 0 )   THEN              ! north/south bdy 
     177            IF( ij+flagv > jpj .OR. ij+flagv < 1 )   CYCLE       
     178            ! 
     179            DO jk = 1, jpkm1 
     180               ua(ii,ij,jk) = ua(ii,ij+flagv,jk) * umask(ii,ij+flagv,jk) 
     181            END DO 
     182            ! 
     183         END IF 
    135184      END DO 
    136185      ! 
    137186      igrd = 3                      ! Copying tangential velocity into bdy points 
    138       DO jb = 1, idx%nblenrim(igrd) 
    139          DO jk = 1, jpkm1 
    140             ii   = idx%nbi(jb,igrd) 
    141             ij   = idx%nbj(jb,igrd) 
    142             fv   = ABS( ABS (NINT( idx%flagv(jb,igrd) ) ) - 1 ) 
    143             va(ii,ij,jk) = va(ii,ij,jk) * REAL( 1 - fv ) + ( va(ii+fv,ij,jk) * vmask(ii+fv,ij,jk) & 
    144                         &+ va(ii-fv,ij,jk) * vmask(ii-fv,ij,jk) ) * vmask(ii,ij,jk) * REAL( fv ) 
    145          END DO 
    146       END DO 
    147       CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy )   ! Boundary points should be updated   
    148       CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy )    
    149       ! 
    150       IF( kt == nit000 )   CLOSE( unit = 102 ) 
     187      IF( llrim0 ) THEN   ;   ibeg = 1                       ;   iend = idx%nblenrim0(igrd) 
     188      ELSE                ;   ibeg = idx%nblenrim0(igrd)+1   ;   iend = idx%nblenrim(igrd) 
     189      ENDIF 
     190      DO jb = ibeg, iend 
     191         ii    = idx%nbi(jb,igrd) 
     192         ij    = idx%nbj(jb,igrd) 
     193         flagu = NINT(idx%flagu(jb,igrd)) 
     194         flagv = NINT(idx%flagv(jb,igrd)) 
     195         ! 
     196         IF( flagv == 0 )   THEN              !  west/east  bdy 
     197            IF( ii+flagu > jpi .OR. ii+flagu < 1 )   CYCLE       
     198            ! 
     199            DO jk = 1, jpkm1 
     200               va(ii,ij,jk) = va(ii+flagu,ij,jk) * vmask(ii+flagu,ij,jk) 
     201            END DO 
     202            ! 
     203         END IF 
     204      END DO 
    151205      ! 
    152206   END SUBROUTINE bdy_dyn3d_zgrad 
    … …  
    167221      INTEGER  ::   ib, ik         ! dummy loop indices 
    168222      INTEGER  ::   ii, ij, igrd   ! local integers 
    169       REAL(wp) ::   zwgt           ! boundary weight 
    170223      !!---------------------------------------------------------------------- 
    171224      ! 
    … …  
    178231         END DO 
    179232      END DO 
    180  
     233      ! 
    181234      igrd = 3                       ! Everything is at T-points here 
    182235      DO ib = 1, idx%nblenrim(igrd) 
    … …  
    187240         END DO 
    188241      END DO 
    189       ! 
    190       CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy )   ;   CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1.,ib_bdy )   ! Boundary points should be updated 
    191       ! 
    192       IF( kt == nit000 )   CLOSE( unit = 102 ) 
    193242      ! 
    194243   END SUBROUTINE bdy_dyn3d_zro 
    … …  
    234283            va(ii,ij,jk) = ( va(ii,ij,jk) + zwgt * ( dta%v3d(jb,jk) - va(ii,ij,jk) ) ) * vmask(ii,ij,jk) 
    235284         END DO 
    236       END DO  
    237       CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy )    ! Boundary points should be updated 
    238       CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy )    
    239       ! 
    240       IF( kt == nit000 )   CLOSE( unit = 102 ) 
     285      END DO    
    241286      ! 
    242287   END SUBROUTINE bdy_dyn3d_frs 
    243288 
    244289 
    245    SUBROUTINE bdy_dyn3d_orlanski( idx, dta, ib_bdy, ll_npo ) 
     290   SUBROUTINE bdy_dyn3d_orlanski( idx, dta, ib_bdy, llrim0, ll_npo ) 
    246291      !!---------------------------------------------------------------------- 
    247292      !!                 ***  SUBROUTINE bdy_dyn3d_orlanski  *** 
    … …  
    255300      TYPE(OBC_INDEX),              INTENT(in) ::   idx  ! OBC indices 
    256301      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 
     302      INTEGER,                      INTENT(in) ::   ib_bdy   ! BDY set index 
     303      LOGICAL,                      INTENT(in) ::   llrim0   ! indicate if rim 0 is treated 
     304      LOGICAL,                      INTENT(in) ::   ll_npo   ! switch for NPO version 
    259305 
    260306      INTEGER  ::   jb, igrd                               ! dummy loop indices 
    … …  
    265311      igrd = 2      ! Orlanski bc on u-velocity;  
    266312      !             
    267       CALL bdy_orlanski_3d( idx, igrd, ub, ua, dta%u3d, ll_npo ) 
     313      CALL bdy_orlanski_3d( idx, igrd, ub, ua, dta%u3d, ll_npo, llrim0 ) 
    268314 
    269315      igrd = 3      ! Orlanski bc on v-velocity 
    270316      !   
    271       CALL bdy_orlanski_3d( idx, igrd, vb, va, dta%v3d, ll_npo ) 
    272       ! 
    273       CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy )    ! Boundary points should be updated 
    274       CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy )    
     317      CALL bdy_orlanski_3d( idx, igrd, vb, va, dta%v3d, ll_npo, llrim0 ) 
    275318      ! 
    276319   END SUBROUTINE bdy_dyn3d_orlanski 
    … …  
    320363      END DO 
    321364      ! 
    322       CALL lbc_lnk_multi( 'bdydyn3d', ua, 'U', -1.,  va, 'V', -1. )   ! Boundary points should be updated 
    323       ! 
    324365      IF( ln_timing )   CALL timing_stop('bdy_dyn3d_dmp') 
    325366      ! 
    … …  
    327368 
    328369 
    329    SUBROUTINE bdy_dyn3d_nmn( idx, ib_bdy ) 
     370   SUBROUTINE bdy_dyn3d_nmn( idx, ib_bdy, llrim0 ) 
    330371      !!---------------------------------------------------------------------- 
    331372      !!                 ***  SUBROUTINE bdy_dyn3d_nmn  *** 
    … …  
    336377      !! 
    337378      !!---------------------------------------------------------------------- 
    338       TYPE(OBC_INDEX),              INTENT(in) ::   idx  ! OBC indices 
    339       INTEGER,                      INTENT(in) ::   ib_bdy  ! BDY set index 
    340  
    341       INTEGER  ::   jb, igrd                               ! dummy loop indices 
     379      TYPE(OBC_INDEX), INTENT(in) ::   idx      ! OBC indices 
     380      INTEGER,         INTENT(in) ::   ib_bdy   ! BDY set index 
     381      LOGICAL,         INTENT(in) ::   llrim0   ! indicate if rim 0 is treated 
     382      INTEGER  ::   igrd                        ! dummy indice 
    342383      !!---------------------------------------------------------------------- 
    343384      ! 
    … …  
    346387      igrd = 2      ! Neumann bc on u-velocity;  
    347388      !             
    348       CALL bdy_nmn( idx, igrd, ua ) 
     389      CALL bdy_nmn( idx, igrd, ua, llrim0 )   ! ua is masked 
    349390 
    350391      igrd = 3      ! Neumann bc on v-velocity 
    351392      !   
    352       CALL bdy_nmn( idx, igrd, va ) 
    353       ! 
    354       CALL lbc_bdy_lnk( 'bdydyn3d', ua, 'U', -1., ib_bdy )    ! Boundary points should be updated 
    355       CALL lbc_bdy_lnk( 'bdydyn3d', va, 'V', -1., ib_bdy ) 
     393      CALL bdy_nmn( idx, igrd, va, llrim0 )   ! va is masked 
    356394      ! 
    357395   END SUBROUTINE bdy_dyn3d_nmn 

  • NEMO/trunk/src/OCE/BDY/bdyice.F90

    r11041 r11536  
    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      !!---------------------------------------------------------------------- 
    5962      ! controls 
    6063      IF( ln_timing    )   CALL timing_start('bdy_ice_thd')                                                            ! timing 
    6164      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 
    6266      ! 
    6367      CALL ice_var_glo2eqv 
    6468      ! 
    65       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 
    6684         ! 
    67          SELECT CASE( cn_ice(jbdy) ) 
    68          CASE('none')   ;   CYCLE 
    69          CASE('frs' )   ;   CALL bdy_ice_frs( idx_bdy(jbdy), dta_bdy(jbdy), kt, jbdy ) 
    70          CASE DEFAULT 
    71             CALL ctl_stop( 'bdy_ice : unrecognised option for open boundaries for ice fields' ) 
    72          END SELECT 
    73          ! 
    74       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 
    75105      ! 
    76106      CALL ice_cor( kt , 0 )      ! -- In case categories are out of bounds, do a remapping 
    … …  
    80110      ! 
    81111      ! controls 
     112      IF( ln_icectl    )   CALL ice_prt     ( kt, iiceprt, jiceprt, 1, ' - ice thermo bdy - ' )                        ! prints 
    82113      IF( ln_icediachk )   CALL ice_cons_hsm(1,'bdy_ice_thd', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation 
    83       IF( ln_icectl    )   CALL ice_prt     ( kt, iiceprt, jiceprt, 1, ' - ice thermo bdy - ' )                        ! prints 
     114      IF( ln_icediachk )   CALL ice_cons2D  (1,'bdy_ice_thd',  diag_v,  diag_s,  diag_t,  diag_fv,  diag_fs,  diag_ft) ! conservation 
    84115      IF( ln_timing    )   CALL timing_stop ('bdy_ice_thd')                                                            ! timing 
    85116      ! 
    … …  
    87118 
    88119 
    89    SUBROUTINE bdy_ice_frs( idx, dta, kt, jbdy ) 
     120   SUBROUTINE bdy_ice_frs( idx, dta, kt, jbdy, llrim0 ) 
    90121      !!------------------------------------------------------------------------------ 
    91122      !!                 ***  SUBROUTINE bdy_ice_frs  *** 
    … …  
    96127      !!             dimensional baroclinic ocean model with realistic topography. Tellus, 365-382. 
    97128      !!------------------------------------------------------------------------------ 
    98       TYPE(OBC_INDEX), INTENT(in) ::   idx     ! OBC indices 
    99       TYPE(OBC_DATA),  INTENT(in) ::   dta     ! OBC external data 
    100       INTEGER,         INTENT(in) ::   kt      ! main time-step counter 
    101       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 
    102134      ! 
    103135      INTEGER  ::   jpbound            ! 0 = incoming ice 
    104136      !                                ! 1 = outgoing ice 
     137      INTEGER  ::   ibeg, iend         ! length of rim to be treated (rim 0 or rim 1) 
    105138      INTEGER  ::   i_bdy, jgrd        ! dummy loop indices 
    106139      INTEGER  ::   ji, jj, jk, jl, ib, jb 
    107140      REAL(wp) ::   zwgt, zwgt1        ! local scalar 
    108141      REAL(wp) ::   ztmelts, zdh 
     142      REAL(wp), POINTER  :: flagu, flagv              ! short cuts 
    109143      !!------------------------------------------------------------------------------ 
    110144      ! 
    111145      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 
    112149      ! 
    113150      DO jl = 1, jpl 
    114          DO i_bdy = 1, idx%nblenrim(jgrd) 
     151         DO i_bdy = ibeg, iend 
    115152            ji    = idx%nbi(i_bdy,jgrd) 
    116153            jj    = idx%nbj(i_bdy,jgrd) 
    117154            zwgt  = idx%nbw(i_bdy,jgrd) 
    118155            zwgt1 = 1.e0 - idx%nbw(i_bdy,jgrd) 
    119             a_i(ji,jj,jl) = ( a_i(ji,jj,jl) * zwgt1 + dta%a_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1)  ! Leads fraction  
    120             h_i(ji,jj,jl) = ( h_i(ji,jj,jl) * zwgt1 + dta%h_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1)  ! Ice depth  
    121             h_s(ji,jj,jl) = ( h_s(ji,jj,jl) * zwgt1 + dta%h_s(i_bdy,jl) * zwgt ) * tmask(ji,jj,1)  ! Snow depth 
    122  
     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            ! 
    123174            ! ----------------- 
    124175            ! Pathological case 
    … …  
    135186            h_i(ji,jj,jl) = MIN( hi_max(jl), h_i(ji,jj,jl) + zdh ) 
    136187            h_s(ji,jj,jl) = MAX( 0._wp, h_s(ji,jj,jl) - zdh * rhoi / rhos )  
    137  
     188            ! 
    138189         ENDDO 
    139190      ENDDO 
    140       CALL lbc_bdy_lnk( 'bdyice', a_i(:,:,:), 'T', 1., jbdy ) 
    141       CALL lbc_bdy_lnk( 'bdyice', h_i(:,:,:), 'T', 1., jbdy ) 
    142       CALL lbc_bdy_lnk( 'bdyice', h_s(:,:,:), 'T', 1., jbdy ) 
    143191 
    144192      DO jl = 1, jpl 
    145          DO i_bdy = 1, idx%nblenrim(jgrd) 
     193         DO i_bdy = ibeg, iend 
    146194            ji = idx%nbi(i_bdy,jgrd) 
    147195            jj = idx%nbj(i_bdy,jgrd) 
    148  
     196            flagu => idx%flagu(i_bdy,jgrd) 
     197            flagv => idx%flagv(i_bdy,jgrd) 
    149198            ! condition on ice thickness depends on the ice velocity 
    150199            ! if velocity is outward (strictly), then ice thickness, volume... must be equal to adjacent values 
    151200            jpbound = 0   ;   ib = ji   ;   jb = jj 
    152201            ! 
    153             IF( u_ice(ji  ,jj  ) < 0. .AND. umask(ji-1,jj  ,1) == 0. )   jpbound = 1 ; ib = ji+1 
    154             IF( u_ice(ji-1,jj  ) > 0. .AND. umask(ji  ,jj  ,1) == 0. )   jpbound = 1 ; ib = ji-1 
    155             IF( v_ice(ji  ,jj  ) < 0. .AND. vmask(ji  ,jj-1,1) == 0. )   jpbound = 1 ; jb = jj+1 
    156             IF( v_ice(ji  ,jj-1) > 0. .AND. vmask(ji  ,jj  ,1) == 0. )   jpbound = 1 ; 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 
    157218            ! 
    158219            IF( nn_ice_dta(jbdy) == 0 )   jpbound = 0 ; ib = ji ; jb = jj   ! case ice boundaries = initial conditions 
    … …  
    161222            IF( a_i(ib,jb,jl) > 0._wp ) THEN   ! there is ice at the boundary 
    162223               ! 
    163                a_i(ji,jj,jl) = a_i(ib,jb,jl) ! concentration 
    164                h_i(ji,jj,jl) = h_i(ib,jb,jl) ! thickness ice 
    165                h_s(ji,jj,jl) = h_s(ib,jb,jl) ! thickness snw 
    166                ! 
    167                SELECT CASE( jpbound ) 
    168                   ! 
    169                CASE( 0 )   ! velocity is inward 
    170                   ! 
    171                   oa_i(ji,jj,  jl) = rn_ice_age(jbdy) * a_i(ji,jj,jl) ! age 
    172                   a_ip(ji,jj,  jl) = 0._wp                            ! pond concentration 
    173                   v_ip(ji,jj,  jl) = 0._wp                            ! pond volume 
    174                   t_su(ji,jj,  jl) = rn_ice_tem(jbdy)                 ! temperature surface 
    175                   t_s (ji,jj,:,jl) = rn_ice_tem(jbdy)                 ! temperature snw 
    176                   t_i (ji,jj,:,jl) = rn_ice_tem(jbdy)                 ! temperature ice 
    177                   s_i (ji,jj,  jl) = rn_ice_sal(jbdy)                 ! salinity 
    178                   sz_i(ji,jj,:,jl) = rn_ice_sal(jbdy)                 ! salinity profile 
    179                   ! 
    180                CASE( 1 )   ! velocity is outward 
    181                   ! 
    182                   oa_i(ji,jj,  jl) = oa_i(ib,jb,  jl) ! age 
    183                   a_ip(ji,jj,  jl) = a_ip(ib,jb,  jl) ! pond concentration 
    184                   v_ip(ji,jj,  jl) = v_ip(ib,jb,  jl) ! pond volume 
    185                   t_su(ji,jj,  jl) = t_su(ib,jb,  jl) ! temperature surface 
    186                   t_s (ji,jj,:,jl) = t_s (ib,jb,:,jl) ! temperature snw 
    187                   t_i (ji,jj,:,jl) = t_i (ib,jb,:,jl) ! temperature ice 
    188                   s_i (ji,jj,  jl) = s_i (ib,jb,  jl) ! salinity 
    189                   sz_i(ji,jj,:,jl) = sz_i(ib,jb,:,jl) ! salinity profile 
    190                   ! 
    191                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 
    192242               ! 
    193243               IF( nn_icesal == 1 ) THEN     ! if constant salinity 
    … …  
    214264               END DO 
    215265               ! 
     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               ! 
    216274            ELSE   ! no ice at the boundary 
    217275               ! 
    … …  
    225283               t_s (ji,jj,:,jl) = rt0 
    226284               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 
    227290                
    228291               IF( nn_icesal == 1 ) THEN     ! if constant salinity 
    … …  
    246309         ! 
    247310      END DO ! jl 
    248  
    249       CALL lbc_bdy_lnk( 'bdyice', a_i (:,:,:)  , 'T', 1., jbdy ) 
    250       CALL lbc_bdy_lnk( 'bdyice', h_i (:,:,:)  , 'T', 1., jbdy ) 
    251       CALL lbc_bdy_lnk( 'bdyice', h_s (:,:,:)  , 'T', 1., jbdy ) 
    252       CALL lbc_bdy_lnk( 'bdyice', oa_i(:,:,:)  , 'T', 1., jbdy ) 
    253       CALL lbc_bdy_lnk( 'bdyice', a_ip(:,:,:)  , 'T', 1., jbdy ) 
    254       CALL lbc_bdy_lnk( 'bdyice', v_ip(:,:,:)  , 'T', 1., jbdy ) 
    255       CALL lbc_bdy_lnk( 'bdyice', s_i (:,:,:)  , 'T', 1., jbdy ) 
    256       CALL lbc_bdy_lnk( 'bdyice', t_su(:,:,:)  , 'T', 1., jbdy ) 
    257       CALL lbc_bdy_lnk( 'bdyice', v_i (:,:,:)  , 'T', 1., jbdy ) 
    258       CALL lbc_bdy_lnk( 'bdyice', v_s (:,:,:)  , 'T', 1., jbdy ) 
    259       CALL lbc_bdy_lnk( 'bdyice', sv_i(:,:,:)  , 'T', 1., jbdy ) 
    260       CALL lbc_bdy_lnk( 'bdyice', t_s (:,:,:,:), 'T', 1., jbdy ) 
    261       CALL lbc_bdy_lnk( 'bdyice', e_s (:,:,:,:), 'T', 1., jbdy ) 
    262       CALL lbc_bdy_lnk( 'bdyice', t_i (:,:,:,:), 'T', 1., jbdy ) 
    263       CALL lbc_bdy_lnk( 'bdyice', e_i (:,:,:,:), 'T', 1., jbdy ) 
    264311      !       
    265312   END SUBROUTINE bdy_ice_frs 
    … …  
    279326      CHARACTER(len=1), INTENT(in)  ::   cd_type   ! nature of velocity grid-points 
    280327      ! 
    281       INTEGER  ::   i_bdy, jgrd      ! dummy loop indices 
    282       INTEGER  ::   ji, jj           ! local scalar 
    283       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) 
    284332      REAL(wp) ::   zmsk1, zmsk2, zflag 
     333      LOGICAL, DIMENSION(4) :: llsend2, llrecv2, llsend3, llrecv3  ! indicate how communications are to be carried out 
    285334      !!------------------------------------------------------------------------------ 
    286335      IF( ln_timing )   CALL timing_start('bdy_ice_dyn') 
    287336      ! 
    288       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 
    289424         ! 
    290          SELECT CASE( cn_ice(jbdy) ) 
    291          ! 
    292          CASE('none') 
    293             CYCLE 
    294             ! 
    295          CASE('frs') 
    296             ! 
    297             IF( nn_ice_dta(jbdy) == 0 ) CYCLE            ! case ice boundaries = initial conditions  
    298             !                                            !      do not change ice velocity (it is only computed by rheology) 
    299             SELECT CASE ( cd_type ) 
    300             !      
    301             CASE ( 'U' )   
    302                jgrd = 2      ! u velocity 
    303                DO i_bdy = 1, idx_bdy(jbdy)%nblenrim(jgrd) 
    304                   ji    = idx_bdy(jbdy)%nbi(i_bdy,jgrd) 
    305                   jj    = idx_bdy(jbdy)%nbj(i_bdy,jgrd) 
    306                   zflag = idx_bdy(jbdy)%flagu(i_bdy,jgrd) 
    307                   ! 
    308                   IF ( ABS( zflag ) == 1. ) THEN  ! eastern and western boundaries 
    309                      ! one of the two zmsk is always 0 (because of zflag) 
    310                      zmsk1 = 1._wp - MAX( 0.0_wp, SIGN ( 1.0_wp , - vt_i(ji+1,jj) ) ) ! 0 if no ice 
    311                      zmsk2 = 1._wp - MAX( 0.0_wp, SIGN ( 1.0_wp , - vt_i(ji,jj) ) )   ! 0 if no ice 
    312                      !   
    313                      ! u_ice = u_ice of the adjacent grid point except if this grid point is ice-free (then do not change u_ice) 
    314                      u_ice (ji,jj) = u_ice(ji+1,jj) * 0.5_wp * ABS( zflag + 1._wp ) * zmsk1 + & 
    315                         &            u_ice(ji-1,jj) * 0.5_wp * ABS( zflag - 1._wp ) * zmsk2 + & 
    316                         &            u_ice(ji  ,jj) * ( 1._wp - MIN( 1._wp, zmsk1 + zmsk2 ) ) 
    317                   ELSE                             ! everywhere else 
    318                      u_ice(ji,jj) = 0._wp 
    319                   ENDIF 
    320                   ! 
    321                END DO 
    322                CALL lbc_bdy_lnk( 'bdyice', u_ice(:,:), 'U', -1., jbdy ) 
    323                ! 
    324             CASE ( 'V' ) 
    325                jgrd = 3      ! v velocity 
    326                DO i_bdy = 1, idx_bdy(jbdy)%nblenrim(jgrd) 
    327                   ji    = idx_bdy(jbdy)%nbi(i_bdy,jgrd) 
    328                   jj    = idx_bdy(jbdy)%nbj(i_bdy,jgrd) 
    329                   zflag = idx_bdy(jbdy)%flagv(i_bdy,jgrd) 
    330                   ! 
    331                   IF ( ABS( zflag ) == 1. ) THEN  ! northern and southern boundaries 
    332                      ! one of the two zmsk is always 0 (because of zflag) 
    333                      zmsk1 = 1._wp - MAX( 0.0_wp, SIGN ( 1.0_wp , - vt_i(ji,jj+1) ) ) ! 0 if no ice 
    334                      zmsk2 = 1._wp - MAX( 0.0_wp, SIGN ( 1.0_wp , - vt_i(ji,jj) ) )   ! 0 if no ice 
    335                      !   
    336                      ! v_ice = v_ice of the adjacent grid point except if this grid point is ice-free (then do not change v_ice) 
    337                      v_ice (ji,jj) = v_ice(ji,jj+1) * 0.5_wp * ABS( zflag + 1._wp ) * zmsk1 + & 
    338                         &            v_ice(ji,jj-1) * 0.5_wp * ABS( zflag - 1._wp ) * zmsk2 + & 
    339                         &            v_ice(ji,jj  ) * ( 1._wp - MIN( 1._wp, zmsk1 + zmsk2 ) ) 
    340                   ELSE                             ! everywhere else 
    341                      v_ice(ji,jj) = 0._wp 
    342                   ENDIF 
    343                   ! 
    344                END DO 
    345                CALL lbc_bdy_lnk( 'bdyice', v_ice(:,:), 'V', -1., jbdy ) 
    346                ! 
    347             END SELECT 
    348             ! 
    349          CASE DEFAULT 
    350             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 
    351454         END SELECT 
    352          ! 
    353       END DO 
     455      END DO   ! ir 
    354456      ! 
    355457      IF( ln_timing )   CALL timing_stop('bdy_ice_dyn') 

  • NEMO/trunk/src/OCE/BDY/bdyini.F90

    r10983 r11536  
    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, jpk_max  ! 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(ib_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          jpk_max = MAXVAL(nb_jpk_bdy) 
    520          jpk_max = MAX(jpk_max, jpk) 
    521  
    522          ALLOCATE( dta_global(jpbdtau, 1, jpk_max) ) 
    523          ALLOCATE( dta_global_z(jpbdtau, 1, jpk_max) ) ! needed ?? TODO 
    524          ALLOCATE( dta_global_dz(jpbdtau, 1, jpk_max) )! needed ?? TODO 
    525  
    526          IF ( icount>0 ) THEN 
    527             ALLOCATE( dta_global2(jpbdtas, nrimmax, jpk_max) ) 
    528             ALLOCATE( dta_global2_z(jpbdtas, nrimmax, jpk_max) ) ! needed ?? TODO 
    529             ALLOCATE( dta_global2_dz(jpbdtas, nrimmax, jpk_max) )! needed ?? TODO   
    530          ENDIF 
    531          !  
    532       ENDIF 
    533  
    534393      ! Now look for crossings in user (namelist) defined open boundary segments: 
    535       !-------------------------------------------------------------------------- 
    536       IF( icount>0 )   CALL bdy_ctl_seg 
    537  
     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     
    538401      ! Calculate global boundary index arrays or read in from file 
    539402      !------------------------------------------------------------                
    … …  
    543406         IF( ln_coords_file(ib_bdy) ) THEN 
    544407            ! 
     408            ALLOCATE( zz_read( MAXVAL(nblendta), 1 ) )           
    545409            CALL iom_open( cn_coords_file(ib_bdy), inum ) 
     410            ! 
    546411            DO igrd = 1, jpbgrd 
    547                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),:) ) 
    548413               DO ii = 1,nblendta(igrd,ib_bdy) 
    549                   nbidta(ii,igrd,ib_bdy) = INT( dta_global(ii,1,1) ) 
     414                  nbidta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) 
    550415               END DO 
    551                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),:) ) 
    552417               DO ii = 1,nblendta(igrd,ib_bdy) 
    553                   nbjdta(ii,igrd,ib_bdy) = INT( dta_global(ii,1,1) ) 
     418                  nbjdta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) 
    554419               END DO 
    555                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),:) ) 
    556421               DO ii = 1,nblendta(igrd,ib_bdy) 
    557                   nbrdta(ii,igrd,ib_bdy) = INT( dta_global(ii,1,1) ) 
     422                  nbrdta(ii,igrd,ib_bdy) = NINT( zz_read(ii,1) ) 
    558423               END DO 
    559424               ! 
    … …  
    563428               IF(lwp) WRITE(numout,*) ' nn_rimwidth from namelist is ', nn_rimwidth(ib_bdy) 
    564429               IF (ibr_max < nn_rimwidth(ib_bdy))   & 
    565                      CALL ctl_stop( 'nn_rimwidth is larger than maximum rimwidth in file',cn_coords_file(ib_bdy) ) 
    566             END DO 
     430                  CALL ctl_stop( 'nn_rimwidth is larger than maximum rimwidth in file',cn_coords_file(ib_bdy) ) 
     431            END DO 
     432            ! 
    567433            CALL iom_close( inum ) 
     434            DEALLOCATE( zz_read ) 
    568435            ! 
    569          ENDIF  
    570          ! 
    571       END DO       
    572      
     436         ENDIF 
     437         ! 
     438      END DO 
     439 
    573440      ! 2. Now fill indices corresponding to straight open boundary arrays: 
    574       ! East 
    575       !----- 
    576       DO iseg = 1, nbdysege 
    577          ib_bdy = npckge(iseg) 
    578          ! 
    579          ! ------------ T points ------------- 
    580          igrd=1 
    581          icount=0 
    582          DO ir = 1, nn_rimwidth(ib_bdy) 
    583             DO ij = jpjedt(iseg), jpjeft(iseg) 
    584                icount = icount + 1 
    585                nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir 
    586                nbjdta(icount, igrd, ib_bdy) = ij 
    587                nbrdta(icount, igrd, ib_bdy) = ir 
    588             ENDDO 
    589          ENDDO 
    590          ! 
    591          ! ------------ U points ------------- 
    592          igrd=2 
    593          icount=0 
    594          DO ir = 1, nn_rimwidth(ib_bdy) 
    595             DO ij = jpjedt(iseg), jpjeft(iseg) 
    596                icount = icount + 1 
    597                nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 1 - ir 
    598                nbjdta(icount, igrd, ib_bdy) = ij 
    599                nbrdta(icount, igrd, ib_bdy) = ir 
    600             ENDDO 
    601          ENDDO 
    602          ! 
    603          ! ------------ V points ------------- 
    604          igrd=3 
    605          icount=0 
    606          DO ir = 1, nn_rimwidth(ib_bdy) 
    607 !            DO ij = jpjedt(iseg), jpjeft(iseg) - 1 
    608             DO ij = jpjedt(iseg), jpjeft(iseg) 
    609                icount = icount + 1 
    610                nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir 
    611                nbjdta(icount, igrd, ib_bdy) = ij 
    612                nbrdta(icount, igrd, ib_bdy) = ir 
    613             ENDDO 
    614             nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
    615             nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
    616          ENDDO 
    617       ENDDO 
    618       ! 
    619       ! West 
    620       !----- 
    621       DO iseg = 1, nbdysegw 
    622          ib_bdy = npckgw(iseg) 
    623          ! 
    624          ! ------------ T points ------------- 
    625          igrd=1 
    626          icount=0 
    627          DO ir = 1, nn_rimwidth(ib_bdy) 
    628             DO ij = jpjwdt(iseg), jpjwft(iseg) 
    629                icount = icount + 1 
    630                nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 
    631                nbjdta(icount, igrd, ib_bdy) = ij 
    632                nbrdta(icount, igrd, ib_bdy) = ir 
    633             ENDDO 
    634          ENDDO 
    635          ! 
    636          ! ------------ U points ------------- 
    637          igrd=2 
    638          icount=0 
    639          DO ir = 1, nn_rimwidth(ib_bdy) 
    640             DO ij = jpjwdt(iseg), jpjwft(iseg) 
    641                icount = icount + 1 
    642                nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 
    643                nbjdta(icount, igrd, ib_bdy) = ij 
    644                nbrdta(icount, igrd, ib_bdy) = ir 
    645             ENDDO 
    646          ENDDO 
    647          ! 
    648          ! ------------ V points ------------- 
    649          igrd=3 
    650          icount=0 
    651          DO ir = 1, nn_rimwidth(ib_bdy) 
    652 !            DO ij = jpjwdt(iseg), jpjwft(iseg) - 1 
    653             DO ij = jpjwdt(iseg), jpjwft(iseg) 
    654                icount = icount + 1 
    655                nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 
    656                nbjdta(icount, igrd, ib_bdy) = ij 
    657                nbrdta(icount, igrd, ib_bdy) = ir 
    658             ENDDO 
    659             nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
    660             nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
    661          ENDDO 
    662       ENDDO 
    663       ! 
    664       ! North 
    665       !----- 
    666       DO iseg = 1, nbdysegn 
    667          ib_bdy = npckgn(iseg) 
    668          ! 
    669          ! ------------ T points ------------- 
    670          igrd=1 
    671          icount=0 
    672          DO ir = 1, nn_rimwidth(ib_bdy) 
    673             DO ii = jpindt(iseg), jpinft(iseg) 
    674                icount = icount + 1 
    675                nbidta(icount, igrd, ib_bdy) = ii 
    676                nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir  
    677                nbrdta(icount, igrd, ib_bdy) = ir 
    678             ENDDO 
    679          ENDDO 
    680          ! 
    681          ! ------------ U points ------------- 
    682          igrd=2 
    683          icount=0 
    684          DO ir = 1, nn_rimwidth(ib_bdy) 
    685 !            DO ii = jpindt(iseg), jpinft(iseg) - 1 
    686             DO ii = jpindt(iseg), jpinft(iseg) 
    687                icount = icount + 1 
    688                nbidta(icount, igrd, ib_bdy) = ii 
    689                nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir 
    690                nbrdta(icount, igrd, ib_bdy) = ir 
    691             ENDDO 
    692             nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
    693             nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
    694          ENDDO 
    695          ! 
    696          ! ------------ V points ------------- 
    697          igrd=3 
    698          icount=0 
    699          DO ir = 1, nn_rimwidth(ib_bdy) 
    700             DO ii = jpindt(iseg), jpinft(iseg) 
    701                icount = icount + 1 
    702                nbidta(icount, igrd, ib_bdy) = ii 
    703                nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 1 - ir 
    704                nbrdta(icount, igrd, ib_bdy) = ir 
    705             ENDDO 
    706          ENDDO 
    707       ENDDO 
    708       ! 
    709       ! South 
    710       !----- 
    711       DO iseg = 1, nbdysegs 
    712          ib_bdy = npckgs(iseg) 
    713          ! 
    714          ! ------------ T points ------------- 
    715          igrd=1 
    716          icount=0 
    717          DO ir = 1, nn_rimwidth(ib_bdy) 
    718             DO ii = jpisdt(iseg), jpisft(iseg) 
    719                icount = icount + 1 
    720                nbidta(icount, igrd, ib_bdy) = ii 
    721                nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 
    722                nbrdta(icount, igrd, ib_bdy) = ir 
    723             ENDDO 
    724          ENDDO 
    725          ! 
    726          ! ------------ U points ------------- 
    727          igrd=2 
    728          icount=0 
    729          DO ir = 1, nn_rimwidth(ib_bdy) 
    730 !            DO ii = jpisdt(iseg), jpisft(iseg) - 1 
    731             DO ii = jpisdt(iseg), jpisft(iseg) 
    732                icount = icount + 1 
    733                nbidta(icount, igrd, ib_bdy) = ii 
    734                nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 
    735                nbrdta(icount, igrd, ib_bdy) = ir 
    736             ENDDO 
    737             nbidta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
    738             nbjdta(icount, igrd, ib_bdy) = -ib_bdy ! Discount this point 
    739          ENDDO 
    740          ! 
    741          ! ------------ V points ------------- 
    742          igrd=3 
    743          icount=0 
    744          DO ir = 1, nn_rimwidth(ib_bdy) 
    745             DO ii = jpisdt(iseg), jpisft(iseg) 
    746                icount = icount + 1 
    747                nbidta(icount, igrd, ib_bdy) = ii 
    748                nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 
    749                nbrdta(icount, igrd, ib_bdy) = ir 
    750             ENDDO 
    751          ENDDO 
    752       ENDDO 
     441      CALL bdy_coords_seg( nbidta, nbjdta, nbrdta ) 
    753442 
    754443      !  Deal with duplicated points 
    … …  
    764453                     DO ib2 = 1, nblendta(igrd,ib_bdy2) 
    765454                        IF ((nbidta(ib1, igrd, ib_bdy1)==nbidta(ib2, igrd, ib_bdy2)).AND. & 
    766                         &   (nbjdta(ib1, igrd, ib_bdy1)==nbjdta(ib2, igrd, ib_bdy2))) THEN 
    767 !                           IF ((lwp).AND.(igrd==1)) WRITE(numout,*) ' found coincident point ji, jj:', &  
    768 !                                                       &              nbidta(ib1, igrd, ib_bdy1),      &  
    769 !                                                       &              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) 
    770459                           ! keep only points with the lowest distance to boundary: 
    771460                           IF (nbrdta(ib1, igrd, ib_bdy1)<nbrdta(ib2, igrd, ib_bdy2)) THEN 
    772                              nbidta(ib2, igrd, ib_bdy2) =-ib_bdy2 
    773                              nbjdta(ib2, igrd, ib_bdy2) =-ib_bdy2 
     461                              nbidta(ib2, igrd, ib_bdy2) =-ib_bdy2 
     462                              nbjdta(ib2, igrd, ib_bdy2) =-ib_bdy2 
    774463                           ELSEIF (nbrdta(ib1, igrd, ib_bdy1)>nbrdta(ib2, igrd, ib_bdy2)) THEN 
    775                              nbidta(ib1, igrd, ib_bdy1) =-ib_bdy1 
    776                              nbjdta(ib1, igrd, ib_bdy1) =-ib_bdy1 
    777                            ! 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: 
    778467                           ELSE 
    779                              nbidta(ib1, igrd, ib_bdy1) =-ib_bdy1 
    780                              nbjdta(ib1, igrd, ib_bdy1) =-ib_bdy1 
     468                              nbidta(ib1, igrd, ib_bdy1) =-ib_bdy1 
     469                              nbjdta(ib1, igrd, ib_bdy1) =-ib_bdy1 
    781470                           ENDIF 
    782471                        END IF 
    … …  
    787476         END DO 
    788477      END DO 
    789  
    790       ! Work out dimensions of boundary data on each processor 
    791       ! ------------------------------------------------------ 
    792  
    793       ! Rather assume that boundary data indices are given on global domain 
    794       ! TO BE DISCUSSED ? 
    795 !      iw = mig(1) + 1            ! if monotasking and no zoom, iw=2 
    796 !      ie = mig(1) + nlci-1 - 1   ! if monotasking and no zoom, ie=jpim1 
    797 !      is = mjg(1) + 1            ! if monotasking and no zoom, is=2 
    798 !      in = mjg(1) + nlcj-1 - 1   ! if monotasking and no zoom, in=jpjm1       
    799       iwe = mig(1) - 1 + 2         ! if monotasking and no zoom, iw=2 
    800       ies = mig(1) + nlci-1 - 1  ! if monotasking and no zoom, ie=jpim1 
    801       iso = mjg(1) - 1 + 2         ! if monotasking and no zoom, is=2 
    802       ino = mjg(1) + nlcj-1 - 1  ! if monotasking and no zoom, in=jpjm1 
    803  
    804       ALLOCATE( nbondi_bdy(nb_bdy)) 
    805       ALLOCATE( nbondj_bdy(nb_bdy)) 
    806       nbondi_bdy(:)=2 
    807       nbondj_bdy(:)=2 
    808       ALLOCATE( nbondi_bdy_b(nb_bdy)) 
    809       ALLOCATE( nbondj_bdy_b(nb_bdy)) 
    810       nbondi_bdy_b(:)=2 
    811       nbondj_bdy_b(:)=2 
    812  
    813       ! Work out dimensions of boundary data on each neighbour process 
    814       IF(nbondi == 0) THEN 
    815          iw_b(1) = 1 + nimppt(nowe+1) 
    816          ie_b(1) = 1 + nimppt(nowe+1)+nlcit(nowe+1)-3 
    817          is_b(1) = 1 + njmppt(nowe+1) 
    818          in_b(1) = 1 + njmppt(nowe+1)+nlcjt(nowe+1)-3 
    819  
    820          iw_b(2) = 1 + nimppt(noea+1) 
    821          ie_b(2) = 1 + nimppt(noea+1)+nlcit(noea+1)-3 
    822          is_b(2) = 1 + njmppt(noea+1) 
    823          in_b(2) = 1 + njmppt(noea+1)+nlcjt(noea+1)-3 
    824       ELSEIF(nbondi == 1) THEN 
    825          iw_b(1) = 1 + nimppt(nowe+1) 
    826          ie_b(1) = 1 + nimppt(nowe+1)+nlcit(nowe+1)-3 
    827          is_b(1) = 1 + njmppt(nowe+1) 
    828          in_b(1) = 1 + njmppt(nowe+1)+nlcjt(nowe+1)-3 
    829       ELSEIF(nbondi == -1) THEN 
    830          iw_b(2) = 1 + nimppt(noea+1) 
    831          ie_b(2) = 1 + nimppt(noea+1)+nlcit(noea+1)-3 
    832          is_b(2) = 1 + njmppt(noea+1) 
    833          in_b(2) = 1 + njmppt(noea+1)+nlcjt(noea+1)-3 
    834       ENDIF 
    835  
    836       IF(nbondj == 0) THEN 
    837          iw_b(3) = 1 + nimppt(noso+1) 
    838          ie_b(3) = 1 + nimppt(noso+1)+nlcit(noso+1)-3 
    839          is_b(3) = 1 + njmppt(noso+1) 
    840          in_b(3) = 1 + njmppt(noso+1)+nlcjt(noso+1)-3 
    841  
    842          iw_b(4) = 1 + nimppt(nono+1) 
    843          ie_b(4) = 1 + nimppt(nono+1)+nlcit(nono+1)-3 
    844          is_b(4) = 1 + njmppt(nono+1) 
    845          in_b(4) = 1 + njmppt(nono+1)+nlcjt(nono+1)-3 
    846       ELSEIF(nbondj == 1) THEN 
    847          iw_b(3) = 1 + nimppt(noso+1) 
    848          ie_b(3) = 1 + nimppt(noso+1)+nlcit(noso+1)-3 
    849          is_b(3) = 1 + njmppt(noso+1) 
    850          in_b(3) = 1 + njmppt(noso+1)+nlcjt(noso+1)-3 
    851       ELSEIF(nbondj == -1) THEN 
    852          iw_b(4) = 1 + nimppt(nono+1) 
    853          ie_b(4) = 1 + nimppt(nono+1)+nlcit(nono+1)-3 
    854          is_b(4) = 1 + njmppt(nono+1) 
    855          in_b(4) = 1 + njmppt(nono+1)+nlcjt(nono+1)-3 
    856       ENDIF 
    857  
     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      ! 
    858487      DO ib_bdy = 1, nb_bdy 
    859488         DO igrd = 1, jpbgrd 
    860             icount  = 0 
    861             icountr = 0 
    862             idx_bdy(ib_bdy)%nblen(igrd)    = 0 
    863             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 
    864495            DO ib = 1, nblendta(igrd,ib_bdy) 
    865496               ! check that data is in correct order in file 
    866                ibm1 = MAX(1,ib-1) 
    867                IF(lwp) THEN         ! Since all procs read global data only need to do this check on one proc... 
    868                   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 
    869499                     CALL ctl_stop('bdy_segs : ERROR : boundary data in file must be defined ', & 
    870                           &        ' in order of distance from edge nbr A utility for re-ordering ', & 
    871                           &        ' boundary coordinates and data files exists in the TOOLS/OBC directory') 
    872                   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 
    873503               ENDIF 
    874504               ! check if point is in local domain 
    … …  
    876506                  & nbjdta(ib,igrd,ib_bdy) >= iso .AND. nbjdta(ib,igrd,ib_bdy) <= ino      ) THEN 
    877507                  ! 
    878                   icount = icount  + 1 
    879                   ! 
    880                   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 
    881511               ENDIF 
    882512            END DO 
    883             idx_bdy(ib_bdy)%nblenrim(igrd) = icountr !: length of rim boundary data on each proc 
    884             idx_bdy(ib_bdy)%nblen   (igrd) = icount  !: length of boundary data on each proc         
    885          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 
    886517 
    887518         ! Allocate index arrays for this boundary set 
    … …  
    893524            &      idx_bdy(ib_bdy)%nbd   (ilen1,jpbgrd) ,   & 
    894525            &      idx_bdy(ib_bdy)%nbdout(ilen1,jpbgrd) ,   & 
     526            &      idx_bdy(ib_bdy)%ntreat(ilen1,jpbgrd) ,   & 
    895527            &      idx_bdy(ib_bdy)%nbmap (ilen1,jpbgrd) ,   & 
    896528            &      idx_bdy(ib_bdy)%nbw   (ilen1,jpbgrd) ,   & 
    … …  
    900532         ! Dispatch mapping indices and discrete distances on each processor 
    901533         ! ----------------------------------------------------------------- 
    902  
    903          com_east  = 0 
    904          com_west  = 0 
    905          com_south = 0 
    906          com_north = 0 
    907  
    908          com_east_b  = 0 
    909          com_west_b  = 0 
    910          com_south_b = 0 
    911          com_north_b = 0 
    912  
    913534         DO igrd = 1, jpbgrd 
    914535            icount  = 0 
    915             ! Loop on rimwidth to ensure outermost points come first in the local arrays. 
    916             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) 
    917538               DO ib = 1, nblendta(igrd,ib_bdy) 
    918539                  ! check if point is in local domain and equals ir 
    … …  
    922543                     ! 
    923544                     icount = icount  + 1 
    924  
    925                      ! Rather assume that boundary data indices are given on global domain 
    926                      ! TO BE DISCUSSED ? 
    927 !                     idx_bdy(ib_bdy)%nbi(icount,igrd)   = nbidta(ib,igrd,ib_bdy)- mig(1)+1 
    928 !                     idx_bdy(ib_bdy)%nbj(icount,igrd)   = nbjdta(ib,igrd,ib_bdy)- mjg(1)+1 
    929                      idx_bdy(ib_bdy)%nbi(icount,igrd)   = nbidta(ib,igrd,ib_bdy)- mig(1)+1 
    930                      idx_bdy(ib_bdy)%nbj(icount,igrd)   = nbjdta(ib,igrd,ib_bdy)- mjg(1)+1 
    931                      ! check if point has to be sent 
    932                      ii = idx_bdy(ib_bdy)%nbi(icount,igrd) 
    933                      ij = idx_bdy(ib_bdy)%nbj(icount,igrd) 
    934                      if((com_east .ne. 1) .and. (ii == (nlci-1)) .and. (nbondi .le. 0)) then 
    935                         com_east = 1 
    936                      elseif((com_west .ne. 1) .and. (ii == 2) .and. (nbondi .ge. 0) .and. (nbondi .ne. 2)) then 
    937                         com_west = 1 
    938                      endif  
    939                      if((com_south .ne. 1) .and. (ij == 2) .and. (nbondj .ge. 0) .and. (nbondj .ne. 2)) then 
    940                         com_south = 1 
    941                      elseif((com_north .ne. 1) .and. (ij == (nlcj-1)) .and. (nbondj .le. 0)) then 
    942                         com_north = 1 
    943                      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 
    944547                     idx_bdy(ib_bdy)%nbr(icount,igrd)   = nbrdta(ib,igrd,ib_bdy) 
    945548                     idx_bdy(ib_bdy)%nbmap(icount,igrd) = ib 
    946549                  ENDIF 
    947                   ! check if point has to be received from a neighbour 
    948                   IF(nbondi == 0) THEN 
    949                      IF( nbidta(ib,igrd,ib_bdy) >= iw_b(1) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(1) .AND.   & 
    950                        & nbjdta(ib,igrd,ib_bdy) >= is_b(1) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(1) .AND.   & 
    951                        & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
    952                        ii = nbidta(ib,igrd,ib_bdy)- iw_b(1)+2 
    953                        if( ii == (nlcit(nowe+1)-1) ) then 
    954                           ij = nbjdta(ib,igrd,ib_bdy) - is_b(1)+2 
    955                           if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then 
    956                             com_south = 1 
    957                           elseif((ij == nlcjt(nowe+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then 
    958                             com_north = 1 
    959                           endif 
    960                           com_west_b = 1 
    961                        endif  
    962                      ENDIF 
    963                      IF( nbidta(ib,igrd,ib_bdy) >= iw_b(2) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(2) .AND.   & 
    964                        & nbjdta(ib,igrd,ib_bdy) >= is_b(2) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(2) .AND.   & 
    965                        & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
    966                        ii = nbidta(ib,igrd,ib_bdy)- iw_b(2)+2 
    967                        if( ii == 2 ) then 
    968                           ij = nbjdta(ib,igrd,ib_bdy) - is_b(2)+2 
    969                           if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then 
    970                             com_south = 1 
    971                           elseif((ij == nlcjt(noea+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then 
    972                             com_north = 1 
    973                           endif 
    974                           com_east_b = 1 
    975                        endif  
    976                      ENDIF 
    977                   ELSEIF(nbondi == 1) THEN 
    978                      IF( nbidta(ib,igrd,ib_bdy) >= iw_b(1) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(1) .AND.   & 
    979                        & nbjdta(ib,igrd,ib_bdy) >= is_b(1) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(1) .AND.   & 
    980                        & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
    981                        ii = nbidta(ib,igrd,ib_bdy)- iw_b(1)+2 
    982                        if( ii == (nlcit(nowe+1)-1) ) then 
    983                           ij = nbjdta(ib,igrd,ib_bdy) - is_b(1)+2 
    984                           if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then 
    985                             com_south = 1 
    986                           elseif((ij == nlcjt(nowe+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then 
    987                             com_north = 1 
    988                           endif 
    989                           com_west_b = 1 
    990                        endif  
    991                      ENDIF 
    992                   ELSEIF(nbondi == -1) THEN 
    993                      IF( nbidta(ib,igrd,ib_bdy) >= iw_b(2) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(2) .AND.   & 
    994                        & nbjdta(ib,igrd,ib_bdy) >= is_b(2) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(2) .AND.   & 
    995                        & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
    996                        ii = nbidta(ib,igrd,ib_bdy)- iw_b(2)+2 
    997                        if( ii == 2 ) then 
    998                           ij = nbjdta(ib,igrd,ib_bdy) - is_b(2)+2 
    999                           if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then 
    1000                             com_south = 1 
    1001                           elseif((ij == nlcjt(noea+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then 
    1002                             com_north = 1 
    1003                           endif 
    1004                           com_east_b = 1 
    1005                        endif  
    1006                      ENDIF 
    1007                   ENDIF 
    1008                   IF(nbondj == 0) THEN 
    1009                      IF(com_north_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(4)-1  & 
    1010                        & .OR. nbidta(ib,igrd,ib_bdy) == ie_b(4)+1) .AND. & 
    1011                        & nbjdta(ib,igrd,ib_bdy) == is_b(4) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 
    1012                        com_north_b = 1  
    1013                      ENDIF 
    1014                      IF(com_south_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(3)-1  & 
    1015                        &.OR. nbidta(ib,igrd,ib_bdy) == ie_b(3)+1) .AND. & 
    1016                        & nbjdta(ib,igrd,ib_bdy) == in_b(3) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 
    1017                        com_south_b = 1  
    1018                      ENDIF 
    1019                      IF( nbidta(ib,igrd,ib_bdy) >= iw_b(3) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(3) .AND.   & 
    1020                        & nbjdta(ib,igrd,ib_bdy) >= is_b(3) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(3) .AND.   & 
    1021                        & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
    1022                        ij = nbjdta(ib,igrd,ib_bdy)- is_b(3)+2 
    1023                        if((com_south_b .ne. 1) .and. (ij == (nlcjt(noso+1)-1))) then 
    1024                           com_south_b = 1 
    1025                        endif  
    1026                      ENDIF 
    1027                      IF( nbidta(ib,igrd,ib_bdy) >= iw_b(4) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(4) .AND.   & 
    1028                        & nbjdta(ib,igrd,ib_bdy) >= is_b(4) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(4) .AND.   & 
    1029                        & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
    1030                        ij = nbjdta(ib,igrd,ib_bdy)- is_b(4)+2 
    1031                        if((com_north_b .ne. 1) .and. (ij == 2)) then 
    1032                           com_north_b = 1 
    1033                        endif  
    1034                      ENDIF 
    1035                   ELSEIF(nbondj == 1) THEN 
    1036                      IF( com_south_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(3)-1 .OR. & 
    1037                        & nbidta(ib,igrd,ib_bdy) == ie_b(3)+1) .AND. & 
    1038                        & nbjdta(ib,igrd,ib_bdy) == in_b(3) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 
    1039                        com_south_b = 1  
    1040                      ENDIF 
    1041                      IF( nbidta(ib,igrd,ib_bdy) >= iw_b(3) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(3) .AND.   & 
    1042                        & nbjdta(ib,igrd,ib_bdy) >= is_b(3) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(3) .AND.   & 
    1043                        & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
    1044                        ij = nbjdta(ib,igrd,ib_bdy)- is_b(3)+2 
    1045                        if((com_south_b .ne. 1) .and. (ij == (nlcjt(noso+1)-1))) then 
    1046                           com_south_b = 1 
    1047                        endif  
    1048                      ENDIF 
    1049                   ELSEIF(nbondj == -1) THEN 
    1050                      IF(com_north_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(4)-1  & 
    1051                        & .OR. nbidta(ib,igrd,ib_bdy) == ie_b(4)+1) .AND. & 
    1052                        & nbjdta(ib,igrd,ib_bdy) == is_b(4) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN 
    1053                        com_north_b = 1  
    1054                      ENDIF 
    1055                      IF( nbidta(ib,igrd,ib_bdy) >= iw_b(4) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(4) .AND.   & 
    1056                        & nbjdta(ib,igrd,ib_bdy) >= is_b(4) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(4) .AND.   & 
    1057                        & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
    1058                        ij = nbjdta(ib,igrd,ib_bdy)- is_b(4)+2 
    1059                        if((com_north_b .ne. 1) .and. (ij == 2)) then 
    1060                           com_north_b = 1 
    1061                        endif  
    1062                      ENDIF 
    1063                   ENDIF 
    1064                ENDDO 
    1065             ENDDO 
    1066          ENDDO  
    1067  
    1068          ! definition of the i- and j- direction local boundaries arrays used for sending the boundaries 
    1069          IF(     (com_east  == 1) .and. (com_west  == 1) ) THEN   ;   nbondi_bdy(ib_bdy) =  0 
    1070          ELSEIF( (com_east  == 1) .and. (com_west  == 0) ) THEN   ;   nbondi_bdy(ib_bdy) = -1 
    1071          ELSEIF( (com_east  == 0) .and. (com_west  == 1) ) THEN   ;   nbondi_bdy(ib_bdy) =  1 
    1072          ENDIF 
    1073          IF(     (com_north == 1) .and. (com_south == 1) ) THEN   ;   nbondj_bdy(ib_bdy) =  0 
    1074          ELSEIF( (com_north == 1) .and. (com_south == 0) ) THEN   ;   nbondj_bdy(ib_bdy) = -1 
    1075          ELSEIF( (com_north == 0) .and. (com_south == 1) ) THEN   ;   nbondj_bdy(ib_bdy) =  1 
    1076          ENDIF 
    1077  
    1078          ! definition of the i- and j- direction local boundaries arrays used for receiving the boundaries 
    1079          IF(     (com_east_b  == 1) .and. (com_west_b  == 1) ) THEN   ;   nbondi_bdy_b(ib_bdy) =  0 
    1080          ELSEIF( (com_east_b  == 1) .and. (com_west_b  == 0) ) THEN   ;   nbondi_bdy_b(ib_bdy) = -1 
    1081          ELSEIF( (com_east_b  == 0) .and. (com_west_b  == 1) ) THEN   ;   nbondi_bdy_b(ib_bdy) =  1 
    1082          ENDIF 
    1083          IF(     (com_north_b == 1) .and. (com_south_b == 1) ) THEN   ;   nbondj_bdy_b(ib_bdy) =  0 
    1084          ELSEIF( (com_north_b == 1) .and. (com_south_b == 0) ) THEN   ;   nbondj_bdy_b(ib_bdy) = -1 
    1085          ELSEIF( (com_north_b == 0) .and. (com_south_b == 1) ) THEN   ;   nbondj_bdy_b(ib_bdy) =  1 
    1086          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 
    1087593 
    1088594         ! Compute rim weights for FRS scheme 
    … …  
    1090596         DO igrd = 1, jpbgrd 
    1091597            DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) 
    1092                nbr => idx_bdy(ib_bdy)%nbr(ib,igrd) 
    1093                idx_bdy(ib_bdy)%nbw(ib,igrd) = 1.- TANH( REAL( nbr - 1 ) *0.5 )      ! tanh formulation 
    1094 !               idx_bdy(ib_bdy)%nbw(ib,igrd) = (REAL(nn_rimwidth(ib_bdy)+1-nbr)/REAL(nn_rimwidth(ib_bdy)))**2.  ! quadratic 
    1095 !               idx_bdy(ib_bdy)%nbw(ib,igrd) =  REAL(nn_rimwidth(ib_bdy)+1-nbr)/REAL(nn_rimwidth(ib_bdy))       ! linear 
    1096             END DO 
    1097          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 
    1098604 
    1099605         ! Compute damping coefficients 
    … …  
    1101607         DO igrd = 1, jpbgrd 
    1102608            DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) 
    1103                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 
    1104610               idx_bdy(ib_bdy)%nbd(ib,igrd) = 1. / ( rn_time_dmp(ib_bdy) * rday ) &  
    1105                & *(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 
    1106612               idx_bdy(ib_bdy)%nbdout(ib,igrd) = 1. / ( rn_time_dmp_out(ib_bdy) * rday ) &  
    1107                & *(REAL(nn_rimwidth(ib_bdy)+1-nbr)/REAL(nn_rimwidth(ib_bdy)))**2.   ! quadratic 
    1108             END DO 
    1109          END DO  
    1110  
    1111       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 
    1112618 
    1113619      ! ------------------------------------------------------ 
    1114620      ! Initialise masks and find normal/tangential directions 
    1115621      ! ------------------------------------------------------ 
     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. ) 
    1116637 
    1117638      ! Read global 2D mask at T-points: bdytmask 
    … …  
    1119640      ! bdytmask = 1  on the computational domain AND on open boundaries 
    1120641      !          = 0  elsewhere    
    1121   
     642 
    1122643      bdytmask(:,:) = ssmask(:,:) 
    1123644 
    1124645      ! Derive mask on U and V grid from mask on T grid 
    1125  
    1126       bdyumask(:,:) = 0._wp 
    1127       bdyvmask(:,:) = 0._wp 
    1128646      DO ij = 1, jpjm1 
    1129647         DO ii = 1, jpim1 
    1130             bdyumask(ii,ij) = bdytmask(ii,ij) * bdytmask(ii+1, ij ) 
     648            bdyumask(ii,ij) = bdytmask(ii,ij) * bdytmask(ii+1,ij ) 
    1131649            bdyvmask(ii,ij) = bdytmask(ii,ij) * bdytmask(ii  ,ij+1)   
    1132650         END DO 
    1133651      END DO 
    1134       CALL lbc_lnk_multi( 'bdyini', bdyumask, 'U', 1. , bdyvmask, 'V', 1. )   ! Lateral boundary cond.  
    1135  
    1136       ! bdy masks are now set to zero on boundary points: 
    1137       ! 
    1138       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: 
    1139655      DO ib_bdy = 1, nb_bdy 
    1140         DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd)       
    1141           bdytmask(idx_bdy(ib_bdy)%nbi(ib,igrd), idx_bdy(ib_bdy)%nbj(ib,igrd)) = 0._wp 
    1142         END DO 
    1143       END DO 
    1144       ! 
    1145       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: 
    1146674      DO ib_bdy = 1, nb_bdy 
    1147         DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 
    1148           bdyumask(idx_bdy(ib_bdy)%nbi(ib,igrd), idx_bdy(ib_bdy)%nbj(ib,igrd)) = 0._wp 
    1149         END DO 
    1150       END DO 
    1151       ! 
    1152       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: 
    1153696      DO ib_bdy = 1, nb_bdy 
    1154         DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 
    1155           bdyvmask(idx_bdy(ib_bdy)%nbi(ib,igrd), idx_bdy(ib_bdy)%nbj(ib,igrd)) = 0._wp 
    1156         END DO 
    1157       END DO 
    1158  
    1159       ! For the flagu/flagv calculation below we require a version of fmask without 
    1160       ! the land boundary condition (shlat) included: 
    1161       zfmask(:,:) = 0 
    1162       DO ij = 2, jpjm1 
    1163          DO ii = 2, jpim1 
    1164             zfmask(ii,ij) = tmask(ii,ij  ,1) * tmask(ii+1,ij  ,1)   & 
    1165            &              * tmask(ii,ij+1,1) * tmask(ii+1,ij+1,1) 
    1166          END DO       
    1167       END DO 
    1168  
    1169       ! Lateral boundary conditions 
    1170       CALL lbc_lnk( 'bdyini', zfmask, 'F', 1. )  
    1171       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 
    1172830      DO ib_bdy = 1, nb_bdy       ! Indices and directions of rim velocity components 
    1173  
    1174          idx_bdy(ib_bdy)%flagu(:,:) = 0._wp 
    1175          idx_bdy(ib_bdy)%flagv(:,:) = 0._wp 
    1176          icount = 0  
    1177831 
    1178832         ! Calculate relationship of U direction to the local orientation of the boundary 
    … …  
    1180834         ! flagu =  0 : u is tangential 
    1181835         ! flagu =  1 : u is normal to the boundary and is direction is inward 
    1182    
    1183836         DO igrd = 1, jpbgrd  
    1184837            SELECT CASE( igrd ) 
    1185                CASE( 1 )   ;   pmask => umask   (:,:,1)   ;   i_offset = 0 
    1186                CASE( 2 )   ;   pmask => bdytmask(:,:)     ;   i_offset = 1 
    1187                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 
    1188841            END SELECT  
    1189842            icount = 0 
    1190             DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd)   
    1191                nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 
    1192                nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 
    1193                zefl = pmask(nbi+i_offset-1,nbj) 
    1194                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) 
    1195855               ! This error check only works if you are using the bdyXmask arrays 
    1196                IF( i_offset == 1 .and. zefl + zwfl == 2 ) THEN 
     856               IF( i_offset == 1 .and. zefl + zwfl == 2. ) THEN 
    1197857                  icount = icount + 1 
    1198                   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) 
    1199859               ELSE 
    1200                   idx_bdy(ib_bdy)%flagu(ib,igrd) = -zefl + zwfl 
     860                  ztmp(ii,ij) = -zwfl + zefl 
    1201861               ENDIF 
    1202862            END DO 
    1203863            IF( icount /= 0 ) THEN 
    1204                WRITE(ctmp1,*) ' E R R O R : Some ',cgrid(igrd),' grid points,',   & 
     864               WRITE(ctmp1,*) 'Some ',cgrid(igrd),' grid points,',   & 
    1205865                  ' are not boundary points (flagu calculation). Check nbi, nbj, indices for boundary set ',ib_bdy 
    1206                WRITE(ctmp2,*) ' ========== ' 
    1207                CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 
     866               CALL ctl_stop( ctmp1 ) 
    1208867            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 
    1209878         END DO 
    1210879 
    … …  
    1213882         ! flagv =  0 : v is tangential 
    1214883         ! flagv =  1 : v is normal to the boundary and is direction is inward 
    1215  
    1216884         DO igrd = 1, jpbgrd  
    1217885            SELECT CASE( igrd ) 
    1218                CASE( 1 )   ;   pmask => vmask (:,:,1)   ;   j_offset = 0 
    1219                CASE( 2 )   ;   pmask => zfmask(:,:)     ;   j_offset = 0 
    1220                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 
    1221889            END SELECT  
    1222890            icount = 0 
    1223             DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd)   
    1224                nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 
    1225                nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 
    1226                znfl = pmask(nbi,nbj+j_offset-1) 
    1227                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  ) 
    1228903               ! This error check only works if you are using the bdyXmask arrays 
    1229                IF( j_offset == 1 .and. znfl + zsfl == 2 ) THEN 
    1230                   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) 
    1231906                  icount = icount + 1 
    1232907               ELSE 
    1233                   idx_bdy(ib_bdy)%flagv(ib,igrd) = -znfl + zsfl 
     908                  ztmp(ii,ij) = -zsfl + znfl 
    1234909               END IF 
    1235910            END DO 
    1236911            IF( icount /= 0 ) THEN 
    1237                WRITE(ctmp1,*) ' E R R O R : Some ',cgrid(igrd),' grid points,',   & 
     912               WRITE(ctmp1,*) 'Some ',cgrid(igrd),' grid points,',   & 
    1238913                  ' are not boundary points (flagv calculation). Check nbi, nbj, indices for boundary set ',ib_bdy 
    1239                WRITE(ctmp2,*) ' ========== ' 
    1240                CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 
    1241             ENDIF  
    1242          END DO 
    1243          ! 
    1244       END DO 
    1245       ! 
    1246       ! Tidy up 
    1247       !-------- 
    1248       IF( nb_bdy>0 )   DEALLOCATE( nbidta, nbjdta, nbrdta ) 
    1249       ! 
    1250    END SUBROUTINE bdy_segs 
    1251  
     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    
    12521154   SUBROUTINE bdy_ctl_seg 
    12531155      !!---------------------------------------------------------------------- 
    … …  
    12791181            &(jpjnob(ib).le.1))        CALL ctl_stop( 'nbdyind out of domain' ) 
    12801182         IF (jpindt(ib).ge.jpinft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 
    1281          IF (jpindt(ib).le.1     )     CALL ctl_stop( 'Start index out of domain' ) 
    1282          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' ) 
    12831185      END DO 
    12841186      ! 
    … …  
    12881190            &(jpjsob(ib).le.1))        CALL ctl_stop( 'nbdyind out of domain' ) 
    12891191         IF (jpisdt(ib).ge.jpisft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 
    1290          IF (jpisdt(ib).le.1     )     CALL ctl_stop( 'Start index out of domain' ) 
    1291          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' ) 
    12921194      END DO 
    12931195      ! 
    … …  
    12971199            &(jpieob(ib).le.1))        CALL ctl_stop( 'nbdyind out of domain' ) 
    12981200         IF (jpjedt(ib).ge.jpjeft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 
    1299          IF (jpjedt(ib).le.1     )     CALL ctl_stop( 'Start index out of domain' ) 
    1300          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' ) 
    13011203      END DO 
    13021204      ! 
    … …  
    13061208            &(jpiwob(ib).le.1))        CALL ctl_stop( 'nbdyind out of domain' ) 
    13071209         IF (jpjwdt(ib).ge.jpjwft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 
    1308          IF (jpjwdt(ib).le.1     )     CALL ctl_stop( 'Start index out of domain' ) 
    1309          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' ) 
    13101212      ENDDO 
    13111213      ! 
    … …  
    13361238                     icorns(ib2,1) = npckgw(ib1) 
    13371239                  ELSEIF ((jpisft(ib2)==jpiwob(ib1)).AND.(jpjwft(ib1)==jpjsob(ib2))) THEN 
    1338                      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)= ', & 
    13391241                        &                                     jpisft(ib2), jpjwft(ib1) 
    1340                      WRITE(ctmp2,*) ' ==========  Not allowed yet' 
    1341                      WRITE(ctmp3,*) '             Crossing problem with West segment: ',npckgw(ib1), &  
    1342                         &                                        ' and South segment: ',npckgs(ib2) 
    1343                      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 ) 
    13441246                  ELSE 
    1345                      WRITE(ctmp1,*) ' E R R O R : Check South and West Open boundary indices' 
    1346                      WRITE(ctmp2,*) ' ==========  Crossing problem with West segment: ',npckgw(ib1) , & 
    1347                         &                                         ' and South segment: ',npckgs(ib2) 
    1348                      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 ) 
    13491251                  END IF 
    13501252               END IF 
    … …  
    13681270                     icorns(ib2,2) = npckge(ib1) 
    13691271                  ELSEIF ((jpjeft(ib1)==jpjsob(ib2)).AND.(jpisdt(ib2)==jpieob(ib1)+1)) THEN 
    1370                      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)= ', & 
    13711273                        &                                     jpisdt(ib2), jpjeft(ib1) 
    1372                      WRITE(ctmp2,*) ' ==========  Not allowed yet' 
    1373                      WRITE(ctmp3,*) '             Crossing problem with East segment: ',npckge(ib1), & 
    1374                         &                                        ' and South segment: ',npckgs(ib2) 
    1375                      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 ) 
    13761278                  ELSE 
    1377                      WRITE(ctmp1,*) ' E R R O R : Check South and East Open boundary indices' 
    1378                      WRITE(ctmp2,*) ' ==========  Crossing problem with East segment: ',npckge(ib1), & 
    1379                      &                                           ' and South segment: ',npckgs(ib2) 
    1380                      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 ) 
    13811283                  END IF 
    13821284               END IF 
    … …  
    14001302                     icornn(ib2,1) = npckgw(ib1) 
    14011303                  ELSEIF ((jpjwdt(ib1)==jpjnob(ib2)+1).AND.(jpinft(ib2)==jpiwob(ib1))) THEN 
    1402                      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)= ', & 
    14031305                     &                                     jpinft(ib2), jpjwdt(ib1) 
    1404                      WRITE(ctmp2,*) ' ==========  Not allowed yet' 
    1405                      WRITE(ctmp3,*) '             Crossing problem with West segment: ',npckgw(ib1), & 
    1406                      &                                                    ' and North segment: ',npckgn(ib2) 
    1407                      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 ) 
    14081310                  ELSE 
    1409                      WRITE(ctmp1,*) ' E R R O R : Check North and West Open boundary indices' 
    1410                      WRITE(ctmp2,*) ' ==========  Crossing problem with West segment: ',npckgw(ib1), & 
    1411                      &                                                    ' and North segment: ',npckgn(ib2) 
    1412                      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 ) 
    14131315                  END IF 
    14141316               END IF 
    … …  
    14321334                     icornn(ib2,2) = npckge(ib1) 
    14331335                  ELSEIF ((jpjedt(ib1)==jpjnob(ib2)+1).AND.(jpindt(ib2)==jpieob(ib1)+1)) THEN 
    1434                      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)= ', & 
    14351337                     &                                     jpindt(ib2), jpjedt(ib1) 
    1436                      WRITE(ctmp2,*) ' ==========  Not allowed yet' 
    1437                      WRITE(ctmp3,*) '             Crossing problem with East segment: ',npckge(ib1), & 
    1438                      &                                           ' and North segment: ',npckgn(ib2) 
    1439                      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 ) 
    14401342                  ELSE 
    1441                      WRITE(ctmp1,*) ' E R R O R : Check North and East Open boundary indices' 
    1442                      WRITE(ctmp2,*) ' ==========  Crossing problem with East segment: ',npckge(ib1), & 
    1443                      &                                           ' and North segment: ',npckgn(ib2) 
    1444                      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 ) 
    14451347                  END IF 
    14461348               END IF 
    … …  
    14681370         IF (ztestmask(1)==1) THEN  
    14691371            IF (icornw(ib,1)==0) THEN 
    1470                WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgw(ib) 
    1471                WRITE(ctmp2,*) ' ==========  does not start on land or on a corner'                                                   
    1472                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' ) 
    14731374            ELSE 
    14741375               ! This is a corner 
    … …  
    14801381         IF (ztestmask(2)==1) THEN 
    14811382            IF (icornw(ib,2)==0) THEN 
    1482                WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgw(ib) 
    1483                WRITE(ctmp2,*) ' ==========  does not end on land or on a corner'                                                   
    1484                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' ) 
    14851385            ELSE 
    14861386               ! This is a corner 
    … …  
    15081408         IF (ztestmask(1)==1) THEN 
    15091409            IF (icorne(ib,1)==0) THEN 
    1510                WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckge(ib) 
    1511                WRITE(ctmp2,*) ' ==========  does not start on land or on a corner'                                                   
    1512                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' ) 
    15131412            ELSE 
    15141413               ! This is a corner 
    … …  
    15201419         IF (ztestmask(2)==1) THEN 
    15211420            IF (icorne(ib,2)==0) THEN 
    1522                WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckge(ib) 
    1523                WRITE(ctmp2,*) ' ==========  does not end on land or on a corner'                                                   
    1524                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' ) 
    15251423            ELSE 
    15261424               ! This is a corner 
    … …  
    15471445 
    15481446         IF ((ztestmask(1)==1).AND.(icorns(ib,1)==0)) THEN 
    1549             WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgs(ib) 
    1550             WRITE(ctmp2,*) ' ==========  does not start on land or on a corner'                                                   
    1551             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' ) 
    15521449         ENDIF 
    15531450         IF ((ztestmask(2)==1).AND.(icorns(ib,2)==0)) THEN 
    1554             WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgs(ib) 
    1555             WRITE(ctmp2,*) ' ==========  does not end on land or on a corner'                                                   
    1556             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' ) 
    15571453         ENDIF 
    15581454      END DO 
    … …  
    15731469 
    15741470         IF ((ztestmask(1)==1).AND.(icornn(ib,1)==0)) THEN 
    1575             WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgn(ib) 
    1576             WRITE(ctmp2,*) ' ==========  does not start on land'                                                   
    1577             CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 
     1471            WRITE(ctmp1,*) ' Open boundary segment ', npckgn(ib) 
     1472            CALL ctl_stop( ctmp1, ' does not start on land' ) 
    15781473         ENDIF 
    15791474         IF ((ztestmask(2)==1).AND.(icornn(ib,2)==0)) THEN 
    1580             WRITE(ctmp1,*) ' E R R O R : Open boundary segment ', npckgn(ib) 
    1581             WRITE(ctmp2,*) ' ==========  does not end on land'                                                   
    1582             CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 
     1475            WRITE(ctmp1,*) ' Open boundary segment ', npckgn(ib) 
     1476            CALL ctl_stop( ctmp1, ' does not end on land' ) 
    15831477         ENDIF 
    15841478      END DO 
    … …  
    15931487   END SUBROUTINE bdy_ctl_seg 
    15941488 
    1595  
     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    
    15961691   SUBROUTINE bdy_ctl_corn( ib1, ib2 ) 
    15971692      !!---------------------------------------------------------------------- 
    … …  
    16191714      ! 
    16201715      IF( itest>0 ) THEN 
    1621          WRITE(ctmp1,*) ' E R R O R : Segments ', ib1, 'and ', ib2 
    1622          WRITE(ctmp2,*) ' ==========  have different open bdy schemes'                                                   
    1623          CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) 
     1716         WRITE(ctmp1,*) ' Segments ', ib1, 'and ', ib2 
     1717         CALL ctl_stop( ctmp1, ' have different open bdy schemes' ) 
    16241718      ENDIF 
    16251719      ! 
    16261720   END SUBROUTINE bdy_ctl_corn 
    16271721 
     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    
    16281791   !!================================================================================= 
    16291792END MODULE bdyini 

  • NEMO/trunk/src/OCE/BDY/bdylib.F90

    r10529 r11536  
    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) ::   pta  ! 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, ptb, pta, dta, ll_npo ) 
     94   SUBROUTINE bdy_orl( idx, ptb, pta, dta, lrim0, ll_npo ) 
    9595      !!---------------------------------------------------------------------- 
    9696      !!                 ***  SUBROUTINE bdy_orl  *** 
    … …  
    104104      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptb  ! before tracer field 
    105105      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pta  ! 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, ptb(:,:,:), pta(:,:,:), dta, ll_npo ) 
     114      CALL bdy_orlanski_3d( idx, igrd, ptb(:,:,:), pta(:,:,:), 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/trunk/src/OCE/BDY/bdytides.F90

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

    r10529 r11536  
    4949      INTEGER, INTENT(in) ::   kt   ! Main time step counter 
    5050      ! 
    51       INTEGER                        :: ib_bdy, jn, igrd   ! Loop indeces 
    52       TYPE(ztrabdy), DIMENSION(jpts) :: zdta               ! Temporary data structure 
     51      INTEGER                        :: ib_bdy, jn, igrd, ir   ! Loop indeces 
     52      TYPE(ztrabdy), DIMENSION(jpts) :: zdta                   ! Temporary data structure 
     53      LOGICAL                        :: llrim0                 ! indicate if rim 0 is treated 
     54      LOGICAL, DIMENSION(4)          :: llsend1, llrecv1       ! indicate how communications are to be carried out 
    5355      !!---------------------------------------------------------------------- 
    5456      igrd = 1  
    55  
    56       DO ib_bdy=1, nb_bdy 
     57      llsend1(:) = .false.  ;   llrecv1(:) = .false. 
     58      DO ir = 1, 0, -1   ! treat rim 1 before rim 0 
     59         IF( ir == 0 ) THEN   ;   llrim0 = .TRUE. 
     60         ELSE                 ;   llrim0 = .FALSE. 
     61         END IF 
     62         DO ib_bdy=1, nb_bdy 
     63            ! 
     64            zdta(1)%tra => dta_bdy(ib_bdy)%tem 
     65            zdta(2)%tra => dta_bdy(ib_bdy)%sal 
     66            ! 
     67            DO jn = 1, jpts 
     68               ! 
     69               SELECT CASE( TRIM(cn_tra(ib_bdy)) ) 
     70               CASE('none'        )   ;   CYCLE 
     71               CASE('frs'         )   ! treat the whole boundary at once 
     72                  IF( ir == 0 ) CALL bdy_frs ( idx_bdy(ib_bdy),                tsa(:,:,:,jn), zdta(jn)%tra ) 
     73               CASE('specified'   )   ! treat the whole rim      at once 
     74                  IF( ir == 0 ) CALL bdy_spe ( idx_bdy(ib_bdy),                tsa(:,:,:,jn), zdta(jn)%tra ) 
     75               CASE('neumann'     )   ;   CALL bdy_nmn ( idx_bdy(ib_bdy), igrd         , tsa(:,:,:,jn), llrim0 )   ! tsa masked 
     76               CASE('orlanski'    )   ;   CALL bdy_orl ( idx_bdy(ib_bdy), tsb(:,:,:,jn), tsa(:,:,:,jn), & 
     77                    & zdta(jn)%tra, llrim0, ll_npo=.false. ) 
     78               CASE('orlanski_npo')   ;   CALL bdy_orl ( idx_bdy(ib_bdy), tsb(:,:,:,jn), tsa(:,:,:,jn), & 
     79                    & zdta(jn)%tra, llrim0, ll_npo=.true.  ) 
     80               CASE('runoff'      )   ;   CALL bdy_rnf ( idx_bdy(ib_bdy),                tsa(:,:,:,jn), jn, llrim0 ) 
     81               CASE DEFAULT           ;   CALL ctl_stop( 'bdy_tra : unrecognised option for open boundaries for T and S' ) 
     82               END SELECT 
     83               !  
     84            END DO 
     85         END DO 
    5786         ! 
    58          zdta(1)%tra => dta_bdy(ib_bdy)%tem 
    59          zdta(2)%tra => dta_bdy(ib_bdy)%sal 
     87         IF( nn_hls > 1 .AND. ir == 1 ) CYCLE   ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 
     88         IF( nn_hls == 1 ) THEN   ;   llsend1(:) = .false.   ;   llrecv1(:) = .false.   ;   END IF 
     89         DO ib_bdy=1, nb_bdy 
     90            SELECT CASE( TRIM(cn_tra(ib_bdy)) ) 
     91            CASE('neumann','runoff') 
     92               llsend1(:) = llsend1(:) .OR. lsend_bdyint(ib_bdy,1,:,ir)   ! possibly every direction, T points 
     93               llrecv1(:) = llrecv1(:) .OR. lrecv_bdyint(ib_bdy,1,:,ir)   ! possibly every direction, T points 
     94            CASE('orlanski', 'orlanski_npo') 
     95               llsend1(:) = llsend1(:) .OR. lsend_bdy(ib_bdy,1,:,ir)   ! possibly every direction, T points 
     96               llrecv1(:) = llrecv1(:) .OR. lrecv_bdy(ib_bdy,1,:,ir)   ! possibly every direction, T points 
     97            END SELECT 
     98         END DO 
     99         IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN   ! if need to send/recv in at least one direction 
     100            CALL lbc_lnk( 'bdytra', tsa, 'T',  1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
     101         END IF 
    60102         ! 
    61          DO jn = 1, jpts 
    62             ! 
    63             SELECT CASE( TRIM(cn_tra(ib_bdy)) ) 
    64             CASE('none'        )   ;   CYCLE 
    65             CASE('frs'         )   ;   CALL bdy_frs ( idx_bdy(ib_bdy),                tsa(:,:,:,jn), zdta(jn)%tra ) 
    66             CASE('specified'   )   ;   CALL bdy_spe ( idx_bdy(ib_bdy),                tsa(:,:,:,jn), zdta(jn)%tra ) 
    67             CASE('neumann'     )   ;   CALL bdy_nmn ( idx_bdy(ib_bdy), igrd         , tsa(:,:,:,jn)               ) 
    68             CASE('orlanski'    )   ;   CALL bdy_orl ( idx_bdy(ib_bdy), tsb(:,:,:,jn), tsa(:,:,:,jn), zdta(jn)%tra, ll_npo=.false. ) 
    69             CASE('orlanski_npo')   ;   CALL bdy_orl ( idx_bdy(ib_bdy), tsb(:,:,:,jn), tsa(:,:,:,jn), zdta(jn)%tra, ll_npo=.true. ) 
    70             CASE('runoff'      )   ;   CALL bdy_rnf ( idx_bdy(ib_bdy),                tsa(:,:,:,jn),               jn ) 
    71             CASE DEFAULT           ;   CALL ctl_stop( 'bdy_tra : unrecognised option for open boundaries for T and S' ) 
    72             END SELECT 
    73             ! Boundary points should be updated 
    74             CALL lbc_bdy_lnk( 'bdytra', tsa(:,:,:,jn), 'T', 1., ib_bdy ) 
    75             !  
    76          END DO 
    77       END DO 
     103      END DO   ! ir 
    78104      ! 
    79105   END SUBROUTINE bdy_tra 
    80106 
    81107 
    82    SUBROUTINE bdy_rnf( idx, pta, jpa ) 
     108   SUBROUTINE bdy_rnf( idx, pta, jpa, llrim0 ) 
    83109      !!---------------------------------------------------------------------- 
    84110      !!                 ***  SUBROUTINE bdy_rnf  *** 
    … …  
    89115      !!  
    90116      !!---------------------------------------------------------------------- 
    91       TYPE(OBC_INDEX),                     INTENT(in) ::   idx  ! OBC indices 
    92       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pta  ! tracer trend 
    93       INTEGER,                             INTENT(in) ::   jpa  ! TRA index 
     117      TYPE(OBC_INDEX),                     INTENT(in) ::   idx      ! OBC indices 
     118      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pta      ! tracer trend 
     119      INTEGER,                             INTENT(in) ::   jpa      ! TRA index 
     120      LOGICAL,                             INTENT(in) ::   llrim0   ! indicate if rim 0 is treated 
    94121      ! 
    95       REAL(wp) ::   zwgt           ! boundary weight 
    96       INTEGER  ::   ib, ik, igrd   ! dummy loop indices 
    97       INTEGER  ::   ii, ij, ip, jp ! 2D addresses 
     122      INTEGER  ::   ib, ii, ij, igrd   ! dummy loop indices 
     123      INTEGER  ::   ik, ip, jp ! 2D addresses 
    98124      !!---------------------------------------------------------------------- 
    99125      ! 
    100126      igrd = 1                       ! Everything is at T-points here 
    101       DO ib = 1, idx%nblenrim(igrd) 
    102          ii = idx%nbi(ib,igrd) 
    103          ij = idx%nbj(ib,igrd) 
    104          DO ik = 1, jpkm1 
    105             ip = bdytmask(ii+1,ij  ) - bdytmask(ii-1,ij  ) 
    106             jp = bdytmask(ii  ,ij+1) - bdytmask(ii  ,ij-1) 
    107             if (jpa == jp_tem) pta(ii,ij,ik) = pta(ii+ip,ij+jp,ik) * tmask(ii,ij,ik) 
    108             if (jpa == jp_sal) pta(ii,ij,ik) =                 0.1 * tmask(ii,ij,ik) 
     127      IF(      jpa == jp_tem ) THEN 
     128         CALL bdy_nmn( idx, igrd, pta, llrim0 ) 
     129      ELSE IF( jpa == jp_sal ) THEN 
     130         IF( .NOT. llrim0 )   RETURN 
     131         DO ib = 1, idx%nblenrim(igrd)   ! if llrim0 then treat the whole rim 
     132            ii = idx%nbi(ib,igrd) 
     133            ij = idx%nbj(ib,igrd) 
     134            pta(ii,ij,1:jpkm1) = 0.1 * tmask(ii,ij,1:jpkm1) 
    109135         END DO 
    110       END DO 
     136      END IF 
    111137      ! 
    112138   END SUBROUTINE bdy_rnf 

  • NEMO/trunk/src/OCE/BDY/bdyvol.F90

    r10481 r11536  
    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/trunk/src/OCE/C1D/c1d.F90

    r10068 r11536  
    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/trunk/src/OCE/C1D/dtauvd.F90

    r10068 r11536  
    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/trunk/src/OCE/C1D/dyndmp.F90

    r10425 r11536  
    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/trunk/src/OCE/CRS/crsdom.F90

    r10068 r11536  
    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/trunk/src/OCE/CRS/crsini.F90

    r10068 r11536  
    8282      REWIND( numnam_ref )              ! Namelist namrun in reference namelist : Parameters of the run 
    8383      READ  ( numnam_ref, namcrs, IOSTAT = ios, ERR = 901) 
    84 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namcrs in reference namelist', lwp ) 
     84901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namcrs in reference namelist' ) 
    8585      REWIND( numnam_cfg )              ! Namelist namrun in configuration namelist : Parameters of the run 
    8686      READ  ( numnam_cfg, namcrs, IOSTAT = ios, ERR = 902 ) 
    87 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namcrs in configuration namelist', lwp ) 
     87902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namcrs in configuration namelist' ) 
    8888      IF(lwm) WRITE ( numond, namcrs ) 
    8989 

  • NEMO/trunk/src/OCE/CRS/crslbclnk.F90

    r10425 r11536  
    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/trunk/src/OCE/DIA/dia25h.F90

    r10641 r11536  
    5555      REWIND ( numnam_ref )              ! Read Namelist nam_dia25h in reference namelist : 25hour mean diagnostics 
    5656      READ   ( numnam_ref, nam_dia25h, IOSTAT=ios, ERR= 901 ) 
    57 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nam_dia25h in reference namelist', lwp ) 
     57901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nam_dia25h in reference namelist' ) 
    5858      REWIND( numnam_cfg )              ! Namelist nam_dia25h in configuration namelist  25hour diagnostics 
    5959      READ  ( numnam_cfg, nam_dia25h, IOSTAT = ios, ERR = 902 ) 
    60 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nam_dia25h in configuration namelist', lwp ) 
     60902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nam_dia25h in configuration namelist' ) 
    6161      IF(lwm) WRITE ( numond, nam_dia25h ) 
    6262 

  • NEMO/trunk/src/OCE/DIA/diadct.F90

    r10425 r11536  
    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 
    … …  
    12411238#else 
    12421239   !!---------------------------------------------------------------------- 
    1243    !!   Default option :                                       Dummy module 
     1240   !!   Dummy module                                              
    12441241   !!---------------------------------------------------------------------- 
    1245    LOGICAL, PUBLIC, PARAMETER ::   lk_diadct = .FALSE.    !: diamht flag 
    1246    PUBLIC  
    1247    !! $Id$ 
     1242   LOGICAL, PUBLIC ::   ln_diadct = .FALSE. 
    12481243CONTAINS 
    1249  
    1250    SUBROUTINE dia_dct_init          ! Dummy routine 
     1244   SUBROUTINE dia_dct_init 
    12511245      IMPLICIT NONE 
    1252       WRITE(*,*) 'dia_dct_init: You should not have seen this print! error?' 
    12531246   END SUBROUTINE dia_dct_init 
    1254  
    1255    SUBROUTINE dia_dct( kt )         ! Dummy routine 
     1247   SUBROUTINE dia_dct( kt ) 
    12561248      IMPLICIT NONE 
    1257       INTEGER, INTENT( in ) :: kt   ! ocean time-step index 
    1258       WRITE(*,*) 'dia_dct: You should not have seen this print! error?', kt 
     1249      INTEGER, INTENT(in) ::   kt 
    12591250   END SUBROUTINE dia_dct 
     1251   ! 
    12601252#endif 
    12611253 

  • NEMO/trunk/src/OCE/DIA/diaharm.F90

    r10835 r11536  
    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,*) ' nb_ana must be lower than jpmax_harmo' 
    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 
    … …  
    177178      !!-------------------------------------------------------------------- 
    178179      IF( ln_timing )   CALL timing_start('dia_harm') 
    179       ! 
    180       IF( kt == nit000 )   CALL dia_harm_init 
    181180      ! 
    182181      IF( kt >= nit000_han .AND. kt <= nitend_han .AND. MOD(kt,nstep_han) == 0 ) THEN 
    … …  
    422421      INTEGER, INTENT(in) ::   init  
    423422      ! 
    424       INTEGER                         :: ji_sd, jj_sd, ji1_sd, ji2_sd, jk1_sd, jk2_sd 
     423      INTEGER                         :: ji_sd, jj_sd, ji1_sd, ji2_sd, jh1_sd, jh2_sd 
    425424      REAL(wp)                        :: zval1, zval2, zx1 
    426425      REAL(wp), DIMENSION(jpincomax) :: ztmpx, zcol1, zcol2 
    … …  
    434433         ztmp3(:,:) = 0._wp 
    435434         ! 
    436          DO jk1_sd = 1, nsparse 
    437             DO jk2_sd = 1, nsparse 
    438                nisparse(jk2_sd) = nisparse(jk2_sd) 
    439                njsparse(jk2_sd) = njsparse(jk2_sd) 
    440                IF( nisparse(jk2_sd) == nisparse(jk1_sd) ) THEN 
    441                   ztmp3(njsparse(jk1_sd),njsparse(jk2_sd)) = ztmp3(njsparse(jk1_sd),njsparse(jk2_sd))  & 
    442                      &                                     + valuesparse(jk1_sd)*valuesparse(jk2_sd) 
     435         DO jh1_sd = 1, nsparse 
     436            DO jh2_sd = 1, nsparse 
     437               nisparse(jh2_sd) = nisparse(jh2_sd) 
     438               njsparse(jh2_sd) = njsparse(jh2_sd) 
     439               IF( nisparse(jh2_sd) == nisparse(jh1_sd) ) THEN 
     440                  ztmp3(njsparse(jh1_sd),njsparse(jh2_sd)) = ztmp3(njsparse(jh1_sd),njsparse(jh2_sd))  & 
     441                     &                                     + valuesparse(jh1_sd)*valuesparse(jh2_sd) 
    443442               ENDIF 
    444443            END DO 
    … …  
    515514   END SUBROUTINE SUR_DETERMINE 
    516515 
    517 #else 
    518    !!---------------------------------------------------------------------- 
    519    !!   Default case :   Empty module 
    520    !!---------------------------------------------------------------------- 
    521    LOGICAL, PUBLIC, PARAMETER ::   lk_diaharm = .FALSE. 
    522 CONTAINS 
    523    SUBROUTINE dia_harm ( kt )     ! Empty routine 
    524       INTEGER, INTENT( IN ) :: kt   
    525       WRITE(*,*) 'dia_harm: you should not have seen this print' 
    526    END SUBROUTINE dia_harm 
    527 #endif 
    528  
    529516   !!====================================================================== 
    530517END MODULE diaharm 

  • NEMO/trunk/src/OCE/DIA/diahsb.F90

    r10425 r11536  
    362362      REWIND( numnam_ref )              ! Namelist namhsb in reference namelist 
    363363      READ  ( numnam_ref, namhsb, IOSTAT = ios, ERR = 901) 
    364 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namhsb in reference namelist', lwp ) 
     364901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namhsb in reference namelist' ) 
    365365      REWIND( numnam_cfg )              ! Namelist namhsb in configuration namelist 
    366366      READ  ( numnam_cfg, namhsb, IOSTAT = ios, ERR = 902 ) 
    367 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namhsb in configuration namelist', lwp ) 
     367902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namhsb in configuration namelist' ) 
    368368      IF(lwm) WRITE( numond, namhsb ) 
    369369 

  • NEMO/trunk/src/OCE/DIA/diaptr.F90

    r10425 r11536  
    393393      REWIND( numnam_ref )              ! Namelist namptr in reference namelist : Poleward transport 
    394394      READ  ( numnam_ref, namptr, IOSTAT = ios, ERR = 901) 
    395 901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in reference namelist', lwp ) 
     395901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in reference namelist' ) 
    396396 
    397397      REWIND( numnam_cfg )              ! Namelist namptr in configuration namelist : Poleward transport 
    398398      READ  ( numnam_cfg, namptr, IOSTAT = ios, ERR = 902 ) 
    399 902   IF( ios >  0 ) CALL ctl_nam ( ios , 'namptr in configuration namelist', lwp ) 
     399902   IF( ios >  0 ) CALL ctl_nam ( ios , 'namptr in configuration namelist' ) 
    400400      IF(lwm) WRITE ( numond, namptr ) 
    401401 

  • NEMO/trunk/src/OCE/DIA/diatmb.F90

    r10499 r11536  
    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/trunk/src/OCE/DIA/diawri.F90

    r11418 r11536  
    430430      !!      define all the NETCDF files and fields 
    431431      !!      At each time step call histdef to compute the mean if ncessary 
    432       !!      Each nwrite time step, output the instantaneous or mean fields 
     432      !!      Each nn_write time step, output the instantaneous or mean fields 
    433433      !!---------------------------------------------------------------------- 
    434434      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
    … …  
    446446      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zw3d       ! 3D workspace 
    447447      !!---------------------------------------------------------------------- 
    448       !  
    449       IF( ln_timing )   CALL timing_start('dia_wri') 
    450448      ! 
    451449      IF( ninist == 1 ) THEN     !==  Output the initial state and forcings  ==! 
    … …  
    454452      ENDIF 
    455453      ! 
     454      IF( nn_write == -1 )   RETURN   ! we will never do any output 
     455      !  
     456      IF( ln_timing )   CALL timing_start('dia_wri') 
     457      ! 
    456458      ! 0. Initialisation 
    457459      ! ----------------- 
    … …  
    463465      clop = "x"         ! no use of the mask value (require less cpu time and otherwise the model crashes) 
    464466#if defined key_diainstant 
    465       zsto = nwrite * rdt 
     467      zsto = nn_write * rdt 
    466468      clop = "inst("//TRIM(clop)//")" 
    467469#else 
    … …  
    469471      clop = "ave("//TRIM(clop)//")" 
    470472#endif 
    471       zout = nwrite * rdt 
     473      zout = nn_write * rdt 
    472474      zmax = ( nitend - nit000 + 1 ) * rdt 
    473475 
    … …  
    500502         ! WRITE root name in date.file for use by postpro 
    501503         IF(lwp) THEN 
    502             CALL dia_nam( clhstnam, nwrite,' ' ) 
     504            CALL dia_nam( clhstnam, nn_write,' ' ) 
    503505            CALL ctl_opn( inum, 'date.file', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
    504506            WRITE(inum,*) clhstnam 
    … …  
    508510         ! Define the T grid FILE ( nid_T ) 
    509511 
    510          CALL dia_nam( clhstnam, nwrite, 'grid_T' ) 
     512         CALL dia_nam( clhstnam, nn_write, 'grid_T' ) 
    511513         IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam    ! filename 
    512514         CALL histbeg( clhstnam, jpi, glamt, jpj, gphit,           &  ! Horizontal grid: glamt and gphit 
    … …  
    544546         ! Define the U grid FILE ( nid_U ) 
    545547 
    546          CALL dia_nam( clhstnam, nwrite, 'grid_U' ) 
     548         CALL dia_nam( clhstnam, nn_write, 'grid_U' ) 
    547549         IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam    ! filename 
    548550         CALL histbeg( clhstnam, jpi, glamu, jpj, gphiu,           &  ! Horizontal grid: glamu and gphiu 
    … …  
    557559         ! Define the V grid FILE ( nid_V ) 
    558560 
    559          CALL dia_nam( clhstnam, nwrite, 'grid_V' )                   ! filename 
     561         CALL dia_nam( clhstnam, nn_write, 'grid_V' )                   ! filename 
    560562         IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam 
    561563         CALL histbeg( clhstnam, jpi, glamv, jpj, gphiv,           &  ! Horizontal grid: glamv and gphiv 
    … …  
    570572         ! Define the W grid FILE ( nid_W ) 
    571573 
    572          CALL dia_nam( clhstnam, nwrite, 'grid_W' )                   ! filename 
     574         CALL dia_nam( clhstnam, nn_write, 'grid_W' )                   ! filename 
    573575         IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam 
    574576         CALL histbeg( clhstnam, jpi, glamt, jpj, gphit,           &  ! Horizontal grid: glamt and gphit 
    … …  
    661663         ENDIF 
    662664 
    663          IF( .NOT. ln_cpl ) THEN 
     665         IF( ln_ssr ) THEN 
    664666            CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping"         , "W/m2"   ,   &  ! qrp 
    665667               &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
    … …  
    669671               &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
    670672         ENDIF 
    671  
    672          IF( ln_cpl .AND. nn_ice <= 1 ) THEN 
    673             CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping"         , "W/m2"   ,   &  ! qrp 
    674                &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
    675             CALL histdef( nid_T, "sowafldp", "Surface Water Flux: Damping"        , "Kg/m2/s",   &  ! erp 
    676                &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
    677             CALL histdef( nid_T, "sosafldp", "Surface salt flux: Damping"         , "Kg/m2/s",   &  ! erp * sn 
    678                &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
    679          ENDIF 
    680           
     673        
    681674         clmx ="l_max(only(x))"    ! max index on a period 
    682675!         CALL histdef( nid_T, "sobowlin", "Bowl Index"                         , "W-point",   &  ! bowl INDEX  
    … …  
    754747      ! donne le nombre d'elements, et ndex la liste des indices a sortir 
    755748 
    756       IF( lwp .AND. MOD( itmod, nwrite ) == 0 ) THEN  
     749      IF( lwp .AND. MOD( itmod, nn_write ) == 0 ) THEN  
    757750         WRITE(numout,*) 'dia_wri : write model outputs in NetCDF files at ', kt, 'time-step' 
    758751         WRITE(numout,*) '~~~~~~ ' 
    … …  
    818811      ENDIF 
    819812 
    820       IF( .NOT. ln_cpl ) THEN 
     813      IF( ln_ssr ) THEN 
    821814         CALL histwrite( nid_T, "sohefldp", it, qrp           , ndim_hT, ndex_hT )   ! heat flux damping 
    822815         CALL histwrite( nid_T, "sowafldp", it, erp           , ndim_hT, ndex_hT )   ! freshwater flux damping 
    823          IF( ln_ssr ) zw2d(:,:) = erp(:,:) * tsn(:,:,1,jp_sal) * tmask(:,:,1) 
    824          CALL histwrite( nid_T, "sosafldp", it, zw2d          , ndim_hT, ndex_hT )   ! salt flux damping 
    825       ENDIF 
    826       IF( ln_cpl .AND. nn_ice <= 1 ) THEN 
    827          CALL histwrite( nid_T, "sohefldp", it, qrp           , ndim_hT, ndex_hT )   ! heat flux damping 
    828          CALL histwrite( nid_T, "sowafldp", it, erp           , ndim_hT, ndex_hT )   ! freshwater flux damping 
    829          IF( ln_ssr ) zw2d(:,:) = erp(:,:) * tsn(:,:,1,jp_sal) * tmask(:,:,1) 
     816         zw2d(:,:) = erp(:,:) * tsn(:,:,1,jp_sal) * tmask(:,:,1) 
    830817         CALL histwrite( nid_T, "sosafldp", it, zw2d          , ndim_hT, ndex_hT )   ! salt flux damping 
    831818      ENDIF 

  • NEMO/trunk/src/OCE/DIU/diurnal_bulk.F90

    r10069 r11536  
    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/trunk/src/OCE/DOM/domain.F90

    r10425 r11536  
    101101         CASE( 0 )   ;   WRITE(numout,*) '         (i.e. closed)' 
    102102         CASE( 1 )   ;   WRITE(numout,*) '         (i.e. cyclic east-west)' 
    103          CASE( 2 )   ;   WRITE(numout,*) '         (i.e. equatorial symmetric)' 
     103         CASE( 2 )   ;   WRITE(numout,*) '         (i.e. cyclic north-south)' 
    104104         CASE( 3 )   ;   WRITE(numout,*) '         (i.e. north fold with T-point pivot)' 
    105105         CASE( 4 )   ;   WRITE(numout,*) '         (i.e. cyclic east-west and north fold with T-point pivot)' 
    … …  
    308308      REWIND( numnam_ref )              ! Namelist namrun in reference namelist : Parameters of the run 
    309309      READ  ( numnam_ref, namrun, IOSTAT = ios, ERR = 901) 
    310 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namrun in reference namelist', lwp ) 
     310901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namrun in reference namelist' ) 
    311311      REWIND( numnam_cfg )              ! Namelist namrun in configuration namelist : Parameters of the run 
    312312      READ  ( numnam_cfg, namrun, IOSTAT = ios, ERR = 902 ) 
    313 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namrun in configuration namelist', lwp ) 
     313902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namrun in configuration namelist' ) 
    314314      IF(lwm) WRITE ( numond, namrun ) 
    315315      ! 
    … …  
    336336            WRITE(numout,*) '      frequency of restart file       nn_stock        = ', nn_stock 
    337337         ENDIF 
     338#if ! defined key_iomput 
    338339         WRITE(numout,*) '      frequency of output file        nn_write        = ', nn_write 
     340#endif 
    339341         WRITE(numout,*) '      mask land points                ln_mskland      = ', ln_mskland 
    340342         WRITE(numout,*) '      additional CF standard metadata ln_cfmeta       = ', ln_cfmeta 
    … …  
    358360      nleapy = nn_leapy 
    359361      ninist = nn_istate 
    360       nstock = nn_stock 
    361       nstocklist = nn_stocklist 
    362       nwrite = nn_write 
    363362      neuler = nn_euler 
    364363      IF( neuler == 1 .AND. .NOT. ln_rstart ) THEN 
    … …  
    369368      ENDIF 
    370369      !                             ! control of output frequency 
    371       IF( nstock == 0 .OR. nstock > nitend ) THEN 
    372          WRITE(ctmp1,*) 'nstock = ', nstock, ' it is forced to ', nitend 
     370      IF( .NOT. ln_rst_list ) THEN     ! we use nn_stock 
     371         IF( nn_stock == -1 )   CALL ctl_warn( 'nn_stock = -1 --> no restart will be done' ) 
     372         IF( nn_stock == 0 .OR. nn_stock > nitend ) THEN 
     373            WRITE(ctmp1,*) 'nn_stock = ', nn_stock, ' it is forced to ', nitend 
     374            CALL ctl_warn( ctmp1 ) 
     375            nn_stock = nitend 
     376         ENDIF 
     377      ENDIF 
     378#if ! defined key_iomput 
     379      IF( nn_write == -1 )   CALL ctl_warn( 'nn_write = -1 --> no output files will be done' ) 
     380      IF ( nn_write == 0 ) THEN 
     381         WRITE(ctmp1,*) 'nn_write = ', nn_write, ' it is forced to ', nitend 
    373382         CALL ctl_warn( ctmp1 ) 
    374          nstock = nitend 
    375       ENDIF 
    376       IF ( nwrite == 0 ) THEN 
    377          WRITE(ctmp1,*) 'nwrite = ', nwrite, ' it is forced to ', nitend 
    378          CALL ctl_warn( ctmp1 ) 
    379          nwrite = nitend 
    380       ENDIF 
     383         nn_write = nitend 
     384      ENDIF 
     385#endif 
    381386 
    382387#if defined key_agrif 
    … …  
    401406      REWIND( numnam_ref )              ! Namelist namdom in reference namelist : space & time domain (bathymetry, mesh, timestep) 
    402407      READ  ( numnam_ref, namdom, IOSTAT = ios, ERR = 903) 
    403 903   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdom in reference namelist', lwp ) 
     408903   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdom in reference namelist' ) 
    404409      REWIND( numnam_cfg )              ! Namelist namdom in configuration namelist : space & time domain (bathymetry, mesh, timestep) 
    405410      READ  ( numnam_cfg, namdom, IOSTAT = ios, ERR = 904 ) 
    406 904   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdom in configuration namelist', lwp ) 
     411904   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdom in configuration namelist' ) 
    407412      IF(lwm) WRITE( numond, namdom ) 
    408413      ! 
    … …  
    433438      REWIND( numnam_ref )              ! Namelist namnc4 in reference namelist : NETCDF 
    434439      READ  ( numnam_ref, namnc4, IOSTAT = ios, ERR = 907) 
    435 907   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namnc4 in reference namelist', lwp ) 
     440907   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namnc4 in reference namelist' ) 
    436441      REWIND( numnam_cfg )              ! Namelist namnc4 in configuration namelist : NETCDF 
    437442      READ  ( numnam_cfg, namnc4, IOSTAT = ios, ERR = 908 ) 
    438 908   IF( ios >  0 )   CALL ctl_nam ( ios , 'namnc4 in configuration namelist', lwp ) 
     443908   IF( ios >  0 )   CALL ctl_nam ( ios , 'namnc4 in configuration namelist' ) 
    439444      IF(lwm) WRITE( numond, namnc4 ) 
    440445 
    … …  
    511516 
    512517 
    513    SUBROUTINE domain_cfg( ldtxt, cd_cfg, kk_cfg, kpi, kpj, kpk, kperio ) 
     518   SUBROUTINE domain_cfg( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio ) 
    514519      !!---------------------------------------------------------------------- 
    515520      !!                     ***  ROUTINE dom_nam  *** 
    … …  
    519524      !! ** Method  :   read the cn_domcfg NetCDF file 
    520525      !!---------------------------------------------------------------------- 
    521       CHARACTER(len=*), DIMENSION(:), INTENT(out) ::   ldtxt           ! stored print information 
    522526      CHARACTER(len=*)              , INTENT(out) ::   cd_cfg          ! configuration name 
    523527      INTEGER                       , INTENT(out) ::   kk_cfg          ! configuration resolution 
    … …  
    525529      INTEGER                       , INTENT(out) ::   kperio          ! lateral global domain b.c.  
    526530      ! 
    527       INTEGER ::   inum, ii   ! local integer 
     531      INTEGER ::   inum   ! local integer 
    528532      REAL(wp) ::   zorca_res                     ! local scalars 
    529       REAL(wp) ::   ziglo, zjglo, zkglo, zperio   !   -      - 
    530       !!---------------------------------------------------------------------- 
    531       ! 
    532       ii = 1 
    533       WRITE(ldtxt(ii),*) '           '                                                    ;   ii = ii+1 
    534       WRITE(ldtxt(ii),*) 'domain_cfg : domain size read in ', TRIM( cn_domcfg ), ' file'  ;   ii = ii+1 
    535       WRITE(ldtxt(ii),*) '~~~~~~~~~~ '                                                    ;   ii = ii+1 
     533      REAL(wp) ::   zperio                        !   -      - 
     534      INTEGER, DIMENSION(4) ::   idvar, idimsz    ! size   of dimensions 
     535      !!---------------------------------------------------------------------- 
     536      ! 
     537      IF(lwp) THEN 
     538         WRITE(numout,*) '           ' 
     539         WRITE(numout,*) 'domain_cfg : domain size read in ', TRIM( cn_domcfg ), ' file' 
     540         WRITE(numout,*) '~~~~~~~~~~ ' 
     541      ENDIF 
    536542      ! 
    537543      CALL iom_open( cn_domcfg, inum ) 
    … …  
    544550         CALL iom_get( inum, 'ORCA_index', zorca_res )   ;   kk_cfg = NINT( zorca_res ) 
    545551         ! 
    546          WRITE(ldtxt(ii),*) '   .'                                                     ;   ii = ii+1 
    547          WRITE(ldtxt(ii),*) '   ==>>>   ORCA configuration '                           ;   ii = ii+1 
    548          WRITE(ldtxt(ii),*) '   .'                                                     ;   ii = ii+1 
     552         IF(lwp) THEN 
     553            WRITE(numout,*) '   .' 
     554            WRITE(numout,*) '   ==>>>   ORCA configuration ' 
     555            WRITE(numout,*) '   .' 
     556         ENDIF 
    549557         ! 
    550558      ELSE                                !- cd_cfg & k_cfg are not used 
    … …  
    559567         ! 
    560568      ENDIF 
    561       ! 
    562       CALL iom_get( inum, 'jpiglo', ziglo  )   ;   kpi = NINT( ziglo ) 
    563       CALL iom_get( inum, 'jpjglo', zjglo  )   ;   kpj = NINT( zjglo ) 
    564       CALL iom_get( inum, 'jpkglo', zkglo  )   ;   kpk = NINT( zkglo ) 
     569       ! 
     570      idvar = iom_varid( inum, 'e3t_0', kdimsz = idimsz )   ! use e3t_0, that must exist, to get jp(ijk)glo 
     571      kpi = idimsz(1) 
     572      kpj = idimsz(2) 
     573      kpk = idimsz(3) 
    565574      CALL iom_get( inum, 'jperio', zperio )   ;   kperio = NINT( zperio ) 
    566575      CALL iom_close( inum ) 
    567576      ! 
    568       WRITE(ldtxt(ii),*) '      cn_cfg = ', TRIM(cd_cfg), '   nn_cfg = ', kk_cfg             ;   ii = ii+1 
    569       WRITE(ldtxt(ii),*) '      jpiglo = ', kpi                                              ;   ii = ii+1 
    570       WRITE(ldtxt(ii),*) '      jpjglo = ', kpj                                              ;   ii = ii+1 
    571       WRITE(ldtxt(ii),*) '      jpkglo = ', kpk                                              ;   ii = ii+1 
    572       WRITE(ldtxt(ii),*) '      type of global domain lateral boundary   jperio = ', kperio  ;   ii = ii+1 
     577      IF(lwp) THEN 
     578         WRITE(numout,*) '      cn_cfg = ', TRIM(cd_cfg), '   nn_cfg = ', kk_cfg 
     579         WRITE(numout,*) '      jpiglo = ', kpi 
     580         WRITE(numout,*) '      jpjglo = ', kpj 
     581         WRITE(numout,*) '      jpkglo = ', kpk 
     582         WRITE(numout,*) '      type of global domain lateral boundary   jperio = ', kperio 
     583      ENDIF 
    573584      !         
    574585   END SUBROUTINE domain_cfg 

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

    r11233 r11536  
    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       
    … …  
    151150      REWIND( numnam_ref )              ! Namelist nambdy in reference namelist :Unstructured open boundaries 
    152151      READ  ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) 
    153 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' ) 
    154153      REWIND( numnam_cfg )              ! Namelist nambdy in configuration namelist :Unstructured open boundaries 
    155154      READ  ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 ) 
    156 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' ) 
    157156      ! ------------------------ 
    158157      IF ( ln_bdy .AND. ln_mask_file ) THEN 

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

    r11415 r11536  
    993993      REWIND( numnam_ref )              ! Namelist nam_vvl in reference namelist :  
    994994      READ  ( numnam_ref, nam_vvl, IOSTAT = ios, ERR = 901) 
    995 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nam_vvl in reference namelist', lwp ) 
     995901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nam_vvl in reference namelist' ) 
    996996      REWIND( numnam_cfg )              ! Namelist nam_vvl in configuration namelist : Parameters of the run 
    997997      READ  ( numnam_cfg, nam_vvl, IOSTAT = ios, ERR = 902 ) 
    998 902   IF( ios >  0 ) CALL ctl_nam ( ios , 'nam_vvl in configuration namelist', lwp ) 
     998902   IF( ios >  0 ) CALL ctl_nam ( ios , 'nam_vvl in configuration namelist' ) 
    999999      IF(lwm) WRITE ( numond, nam_vvl ) 
    10001000      ! 

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

    r10213 r11536  
    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/trunk/src/OCE/DOM/iscplhsb.F90

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

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

    r10425 r11536  
    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/trunk/src/OCE/DYN/dynadv.F90

    r10068 r11536  
    106106      REWIND( numnam_ref )              ! Namelist namdyn_adv in reference namelist : Momentum advection scheme 
    107107      READ  ( numnam_ref, namdyn_adv, IOSTAT = ios, ERR = 901) 
    108 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_adv in reference namelist', lwp ) 
     108901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_adv in reference namelist' ) 
    109109      REWIND( numnam_cfg )              ! Namelist namdyn_adv in configuration namelist : Momentum advection scheme 
    110110      READ  ( numnam_cfg, namdyn_adv, IOSTAT = ios, ERR = 902 ) 
    111 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_adv in configuration namelist', lwp ) 
     111902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_adv in configuration namelist' ) 
    112112      IF(lwm) WRITE ( numond, namdyn_adv ) 
    113113 

  • NEMO/trunk/src/OCE/DYN/dynhpg.F90

    r11416 r11536  
    152152      REWIND( numnam_ref )              ! Namelist namdyn_hpg in reference namelist : Hydrostatic pressure gradient 
    153153      READ  ( numnam_ref, namdyn_hpg, IOSTAT = ios, ERR = 901) 
    154 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_hpg in reference namelist', lwp ) 
     154901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_hpg in reference namelist' ) 
    155155      ! 
    156156      REWIND( numnam_cfg )              ! Namelist namdyn_hpg in configuration namelist : Hydrostatic pressure gradient 
    157157      READ  ( numnam_cfg, namdyn_hpg, IOSTAT = ios, ERR = 902 ) 
    158 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_hpg in configuration namelist', lwp ) 
     158902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_hpg in configuration namelist' ) 
    159159      IF(lwm) WRITE ( numond, namdyn_hpg ) 
    160160      ! 

  • NEMO/trunk/src/OCE/DYN/dynkeg.F90

    r10996 r11536  
    7474      INTEGER, INTENT( in ) ::   kscheme   ! =0/1   type of KEG scheme  
    7575      ! 
    76       INTEGER  ::   ji, jj, jk, jb           ! dummy loop indices 
    77       INTEGER  ::   ifu, ifv, igrd, ib_bdy   ! local integers 
     76      INTEGER  ::   ji, jj, jk             ! dummy loop indices 
    7877      REAL(wp) ::   zu, zv                   ! local scalars 
    7978      REAL(wp), DIMENSION(jpi,jpj,jpk)        ::   zhke 
    8079      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdu, ztrdv  
    81       REAL(wp)  :: zweightu, zweightv 
    8280      !!---------------------------------------------------------------------- 
    8381      ! 
    … …  
    112110            END DO 
    113111         END DO 
    114          ! 
    115          IF (ln_bdy) THEN 
    116             ! Maria Luneva & Fred Wobus: July-2016 
    117             ! compensate for lack of turbulent kinetic energy on liquid bdy points 
    118             DO ib_bdy = 1, nb_bdy 
    119                IF( cn_dyn3d(ib_bdy) /= 'none' ) THEN 
    120                   igrd = 1           ! compensating null velocity on the bdy 
    121                   DO jb = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 
    122                      ji   = idx_bdy(ib_bdy)%nbi(jb,igrd)   ! maximum extent : from 2 to jpi-1 
    123                      jj   = idx_bdy(ib_bdy)%nbj(jb,igrd)   ! maximum extent : from 2 to jpj-1 
    124                      DO jk = 1, jpkm1 
    125                         zhke(ji,jj,jk) = 0._wp 
    126                         zweightu = umask(ji-1,jj  ,jk) + umask(ji,jj,jk) 
    127                         zweightv = vmask(ji  ,jj-1,jk) + vmask(ji,jj,jk) 
    128                         zu = un(ji-1,jj  ,jk) * un(ji-1,jj  ,jk)  +  un(ji  ,jj  ,jk) * un(ji  ,jj  ,jk) 
    129                         zv = vn(ji  ,jj-1,jk) * vn(ji  ,jj-1,jk)  +  vn(ji  ,jj  ,jk) * vn(ji  ,jj  ,jk) 
    130                         IF( zweightu > 0._wp )   zhke(ji,jj,jk) =  zhke(ji,jj,jk) + zu / (2._wp * zweightu)  
    131                         IF( zweightv > 0._wp )   zhke(ji,jj,jk) =  zhke(ji,jj,jk) + zv / (2._wp * zweightv)  
    132                      END DO 
    133                   END DO 
    134                END IF 
    135                CALL lbc_bdy_lnk( 'dynkeg', zhke, 'T', 1., ib_bdy )   ! send 2 and recv jpi, jpj used in the computation of the speed tendencies 
    136             END DO 
    137          END IF 
    138          ! 
    139112      CASE ( nkeg_HW )                          !--  Hollingsworth scheme  --! 
    140113         DO jk = 1, jpkm1 
    … …  
    154127            END DO 
    155128         END DO 
    156          IF (ln_bdy) THEN 
    157             ! Maria Luneva & Fred Wobus: July-2016 
    158             ! compensate for lack of turbulent kinetic energy on liquid bdy points 
    159             DO ib_bdy = 1, nb_bdy 
    160                IF( cn_dyn3d(ib_bdy) /= 'none' ) THEN 
    161                   igrd = 1           ! compensation null velocity on land at the bdy 
    162                   DO jb = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 
    163                      ji   = idx_bdy(ib_bdy)%nbi(jb,igrd)   ! maximum extent : from 2 to jpi-1 
    164                      jj   = idx_bdy(ib_bdy)%nbj(jb,igrd)   ! maximum extent : from 2 to jpj-1 
    165                      DO jk = 1, jpkm1 
    166                         zhke(ji,jj,jk) = 0._wp 
    167                         zweightu = 8._wp * ( umask(ji-1,jj  ,jk) + umask(ji  ,jj  ,jk) ) & 
    168                              &   + 2._wp * ( umask(ji-1,jj-1,jk) + umask(ji-1,jj+1,jk) + umask(ji  ,jj-1,jk) + umask(ji  ,jj+1,jk) )  
    169                         zweightv = 8._wp * ( vmask(ji  ,jj-1,jk) + vmask(ji  ,jj-1,jk) ) & 
    170                              &   + 2._wp * ( vmask(ji-1,jj-1,jk) + vmask(ji+1,jj-1,jk) + vmask(ji-1,jj  ,jk) + vmask(ji+1,jj  ,jk) ) 
    171                         zu = 8._wp * ( un(ji-1,jj  ,jk) * un(ji-1,jj  ,jk)    & 
    172                            &         + un(ji  ,jj  ,jk) * un(ji  ,jj  ,jk) )  & 
    173                            &   +     ( un(ji-1,jj-1,jk) + un(ji-1,jj+1,jk) ) * ( un(ji-1,jj-1,jk) + un(ji-1,jj+1,jk) )   & 
    174                            &   +     ( un(ji  ,jj-1,jk) + un(ji  ,jj+1,jk) ) * ( un(ji  ,jj-1,jk) + un(ji  ,jj+1,jk) ) 
    175                         zv = 8._wp * ( vn(ji  ,jj-1,jk) * vn(ji  ,jj-1,jk)    & 
    176                            &         + vn(ji  ,jj  ,jk) * vn(ji  ,jj  ,jk) )  & 
    177                            &  +      ( vn(ji-1,jj-1,jk) + vn(ji+1,jj-1,jk) ) * ( vn(ji-1,jj-1,jk) + vn(ji+1,jj-1,jk) )   & 
    178                            &  +      ( vn(ji-1,jj  ,jk) + vn(ji+1,jj  ,jk) ) * ( vn(ji-1,jj  ,jk) + vn(ji+1,jj  ,jk) ) 
    179                         IF( zweightu > 0._wp )   zhke(ji,jj,jk) =  zhke(ji,jj,jk) +  zu / ( 2._wp * zweightu ) 
    180                         IF( zweightv > 0._wp )   zhke(ji,jj,jk) =  zhke(ji,jj,jk) +  zv / ( 2._wp * zweightv ) 
    181                      END DO 
    182                   END DO 
    183                END IF 
    184             END DO 
    185          END IF 
    186129         CALL lbc_lnk( 'dynkeg', zhke, 'T', 1. ) 
    187130         ! 

  • NEMO/trunk/src/OCE/DYN/dynspg.F90

    r10068 r11536  
    202202      REWIND( numnam_ref )              ! Namelist namdyn_spg in reference namelist : Free surface 
    203203      READ  ( numnam_ref, namdyn_spg, IOSTAT = ios, ERR = 901) 
    204 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_spg in reference namelist', lwp ) 
     204901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_spg in reference namelist' ) 
    205205      ! 
    206206      REWIND( numnam_cfg )              ! Namelist namdyn_spg in configuration namelist : Free surface 
    207207      READ  ( numnam_cfg, namdyn_spg, IOSTAT = ios, ERR = 902 ) 
    208 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_spg in configuration namelist', lwp ) 
     208902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_spg in configuration namelist' ) 
    209209      IF(lwm) WRITE ( numond, namdyn_spg ) 
    210210      ! 

  • NEMO/trunk/src/OCE/DYN/dynspg_ts.F90

    r10742 r11536  
    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) ) 
    … …  
    149149      LOGICAL  ::   ll_fw_start           ! =T : forward integration  
    150150      LOGICAL  ::   ll_init               ! =T : special startup of 2d equations 
    151       LOGICAL  ::   ll_tmp1, ll_tmp2      ! local logical variables used in W/D 
    152       INTEGER  ::   ikbu, iktu, noffset   ! local integers 
    153       INTEGER  ::   ikbv, iktv            !   -      - 
    154       REAL(wp) ::   r1_2dt_b, z2dt_bf               ! local scalars 
    155       REAL(wp) ::   zx1, zx2, zu_spg, zhura, z1_hu  !   -      - 
    156       REAL(wp) ::   zy1, zy2, zv_spg, zhvra, z1_hv  !   -      - 
     151      INTEGER  ::   noffset               ! local integers  : time offset for bdy update 
     152      REAL(wp) ::   r1_2dt_b, z1_hu, z1_hv          ! local scalars 
    157153      REAL(wp) ::   za0, za1, za2, za3              !   -      - 
    158       REAL(wp) ::   zmdi, zztmp            , z1_ht  !   -      - 
    159       REAL(wp), DIMENSION(jpi,jpj) :: zsshp2_e, zhf 
    160       REAL(wp), DIMENSION(jpi,jpj) :: zwx, zu_trd, zu_frc, zssh_frc 
    161       REAL(wp), DIMENSION(jpi,jpj) :: zwy, zv_trd, zv_frc, zhdiv 
    162       REAL(wp), DIMENSION(jpi,jpj) :: zsshu_a, zhup2_e, zhust_e, zhtp2_e 
    163       REAL(wp), DIMENSION(jpi,jpj) :: zsshv_a, zhvp2_e, zhvst_e 
     154      REAL(wp) ::   zmdi, zztmp, zldg               !   -      - 
     155      REAL(wp) ::   zhu_bck, zhv_bck, zhdiv         !   -      - 
     156      REAL(wp) ::   zun_save, zvn_save              !   -      - 
     157      REAL(wp), DIMENSION(jpi,jpj) :: zu_trd, zu_frc, zu_spg, zssh_frc 
     158      REAL(wp), DIMENSION(jpi,jpj) :: zv_trd, zv_frc, zv_spg 
     159      REAL(wp), DIMENSION(jpi,jpj) :: zsshu_a, zhup2_e, zhtp2_e 
     160      REAL(wp), DIMENSION(jpi,jpj) :: zsshv_a, zhvp2_e, zsshp2_e 
    164161      REAL(wp), DIMENSION(jpi,jpj) :: zCdU_u, zCdU_v   ! top/bottom stress at u- & v-points 
     162      REAL(wp), DIMENSION(jpi,jpj) :: zhU, zhV         ! fluxes 
    165163      ! 
    166164      REAL(wp) ::   zwdramp                     ! local scalar - only used if ln_wd_dl = .True.  
    … …  
    182180      zwdramp = r_rn_wdmin1               ! simplest ramp  
    183181!     zwdramp = 1._wp / (rn_wdmin2 - rn_wdmin1) ! more general ramp 
    184       !                                         ! reciprocal of baroclinic time step  
    185       IF( kt == nit000 .AND. neuler == 0 ) THEN   ;   z2dt_bf =          rdt 
    186       ELSE                                        ;   z2dt_bf = 2.0_wp * rdt 
    187       ENDIF 
    188       r1_2dt_b = 1.0_wp / z2dt_bf  
     182      !                                         ! inverse of baroclinic time step  
     183      IF( kt == nit000 .AND. neuler == 0 ) THEN   ;   r1_2dt_b = 1._wp / (         rdt ) 
     184      ELSE                                        ;   r1_2dt_b = 1._wp / ( 2._wp * rdt ) 
     185      ENDIF 
    189186      ! 
    190187      ll_init     = ln_bt_av                    ! if no time averaging, then no specific restart  
    … …  
    210207            ll_fw_start =.FALSE. 
    211208         ENDIF 
    212          ! 
    213          ! Set averaging weights and cycle length: 
     209         !                    ! Set averaging weights and cycle length: 
    214210         CALL ts_wgt( ln_bt_av, ll_fw_start, icycle, wgtbtp1, wgtbtp2 ) 
    215211         ! 
    216       ENDIF 
    217       ! 
    218       IF( ln_isfcav ) THEN    ! top+bottom friction (ocean cavities) 
    219          DO jj = 2, jpjm1 
    220             DO ji = fs_2, fs_jpim1   ! vector opt. 
    221                zCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) + rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) 
    222                zCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) + rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) 
    223             END DO 
    224          END DO 
    225       ELSE                    ! bottom friction only 
    226          DO jj = 2, jpjm1 
    227             DO ji = fs_2, fs_jpim1   ! vector opt. 
    228                zCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) 
    229                zCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) 
    230             END DO 
    231          END DO 
    232       ENDIF 
    233       ! 
    234       ! Set arrays to remove/compute coriolis trend. 
    235       ! Do it once at kt=nit000 if volume is fixed, else at each long time step. 
    236       ! Note that these arrays are also used during barotropic loop. These are however frozen 
    237       ! although they should be updated in the variable volume case. Not a big approximation. 
    238       ! To remove this approximation, copy lines below inside barotropic loop 
    239       ! and update depths at T-F points (ht and zhf resp.) at each barotropic time step 
    240       ! 
    241       IF( kt == nit000 .OR. .NOT.ln_linssh ) THEN 
    242          ! 
    243          SELECT CASE( nvor_scheme ) 
    244          CASE( np_EEN )                != EEN scheme using e3f (energy & enstrophy scheme) 
    245             SELECT CASE( nn_een_e3f )              !* ff_f/e3 at F-point 
    246             CASE ( 0 )                                   ! original formulation  (masked averaging of e3t divided by 4) 
    247                DO jj = 1, jpjm1 
    248                   DO ji = 1, jpim1 
    249                      zwz(ji,jj) =   ( ht_n(ji  ,jj+1) + ht_n(ji+1,jj+1) +                    & 
    250                         &             ht_n(ji  ,jj  ) + ht_n(ji+1,jj  )   ) * 0.25_wp   
    251                      IF( zwz(ji,jj) /= 0._wp )   zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 
    252                   END DO 
    253                END DO 
    254             CASE ( 1 )                                   ! new formulation  (masked averaging of e3t divided by the sum of mask) 
    255                DO jj = 1, jpjm1 
    256                   DO ji = 1, jpim1 
    257                      zwz(ji,jj) =             (  ht_n  (ji  ,jj+1) + ht_n  (ji+1,jj+1)      & 
    258                         &                      + ht_n  (ji  ,jj  ) + ht_n  (ji+1,jj  )  )   & 
    259                         &       / ( MAX( 1._wp,  ssmask(ji  ,jj+1) + ssmask(ji+1,jj+1)      & 
    260                         &                      + ssmask(ji  ,jj  ) + ssmask(ji+1,jj  )  )   ) 
    261                      IF( zwz(ji,jj) /= 0._wp )   zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 
    262                   END DO 
    263                END DO 
    264             END SELECT 
    265             CALL lbc_lnk( 'dynspg_ts', zwz, 'F', 1._wp ) 
    266             ! 
    267             ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 
    268             DO jj = 2, jpj 
    269                DO ji = 2, jpi 
    270                   ftne(ji,jj) = zwz(ji-1,jj  ) + zwz(ji  ,jj  ) + zwz(ji  ,jj-1) 
    271                   ftnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj  ) + zwz(ji  ,jj  ) 
    272                   ftse(ji,jj) = zwz(ji  ,jj  ) + zwz(ji  ,jj-1) + zwz(ji-1,jj-1) 
    273                   ftsw(ji,jj) = zwz(ji  ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj  ) 
    274                END DO 
    275             END DO 
    276             ! 
    277          CASE( np_EET )                  != EEN scheme using e3t (energy conserving scheme) 
    278             ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 
    279             DO jj = 2, jpj 
    280                DO ji = 2, jpi 
    281                   z1_ht = ssmask(ji,jj) / ( ht_n(ji,jj) + 1._wp - ssmask(ji,jj) ) 
    282                   ftne(ji,jj) = ( ff_f(ji-1,jj  ) + ff_f(ji  ,jj  ) + ff_f(ji  ,jj-1) ) * z1_ht 
    283                   ftnw(ji,jj) = ( ff_f(ji-1,jj-1) + ff_f(ji-1,jj  ) + ff_f(ji  ,jj  ) ) * z1_ht 
    284                   ftse(ji,jj) = ( ff_f(ji  ,jj  ) + ff_f(ji  ,jj-1) + ff_f(ji-1,jj-1) ) * z1_ht 
    285                   ftsw(ji,jj) = ( ff_f(ji  ,jj-1) + ff_f(ji-1,jj-1) + ff_f(ji-1,jj  ) ) * z1_ht 
    286                END DO 
    287             END DO 
    288             ! 
    289          CASE( np_ENE, np_ENS , np_MIX )  != all other schemes (ENE, ENS, MIX) except ENT ! 
    290             ! 
    291             zwz(:,:) = 0._wp 
    292             zhf(:,:) = 0._wp 
    293              
    294 !!gm  assume 0 in both cases (which is almost surely WRONG ! ) as hvatf has been removed  
    295 !!gm    A priori a better value should be something like : 
    296 !!gm          zhf(i,j) = masked sum of  ht(i,j) , ht(i+1,j) , ht(i,j+1) , (i+1,j+1)  
    297 !!gm                     divided by the sum of the corresponding mask  
    298 !!gm  
    299 !!             
    300             IF( .NOT.ln_sco ) THEN 
    301    
    302    !!gm  agree the JC comment  : this should be done in a much clear way 
    303    
    304    ! JC: It not clear yet what should be the depth at f-points over land in z-coordinate case 
    305    !     Set it to zero for the time being  
    306    !              IF( rn_hmin < 0._wp ) THEN    ;   jk = - INT( rn_hmin )                                      ! from a nb of level 
    307    !              ELSE                          ;   jk = MINLOC( gdepw_0, mask = gdepw_0 > rn_hmin, dim = 1 )  ! from a depth 
    308    !              ENDIF 
    309    !              zhf(:,:) = gdepw_0(:,:,jk+1) 
    310                ! 
    311             ELSE 
    312                ! 
    313                !zhf(:,:) = hbatf(:,:) 
    314                DO jj = 1, jpjm1 
    315                   DO ji = 1, jpim1 
    316                      zhf(ji,jj) =    (   ht_0  (ji,jj  ) + ht_0  (ji+1,jj  )          & 
    317                         &              + ht_0  (ji,jj+1) + ht_0  (ji+1,jj+1)   )      & 
    318                         &       / MAX(   ssmask(ji,jj  ) + ssmask(ji+1,jj  )          & 
    319                         &              + ssmask(ji,jj+1) + ssmask(ji+1,jj+1) , 1._wp  ) 
    320                   END DO 
    321                END DO 
    322             ENDIF 
    323             ! 
    324             DO jj = 1, jpjm1 
    325                zhf(:,jj) = zhf(:,jj) * (1._wp- umask(:,jj,1) * umask(:,jj+1,1)) 
    326             END DO 
    327             ! 
    328             DO jk = 1, jpkm1 
    329                DO jj = 1, jpjm1 
    330                   zhf(:,jj) = zhf(:,jj) + e3f_n(:,jj,jk) * umask(:,jj,jk) * umask(:,jj+1,jk) 
    331                END DO 
    332             END DO 
    333             CALL lbc_lnk( 'dynspg_ts', zhf, 'F', 1._wp ) 
    334             ! JC: TBC. hf should be greater than 0  
    335             DO jj = 1, jpj 
    336                DO ji = 1, jpi 
    337                   IF( zhf(ji,jj) /= 0._wp )   zwz(ji,jj) = 1._wp / zhf(ji,jj) ! zhf is actually hf here but it saves an array 
    338                END DO 
    339             END DO 
    340             zwz(:,:) = ff_f(:,:) * zwz(:,:) 
    341          END SELECT 
    342212      ENDIF 
    343213      ! 
    … …  
    348218         CALL ts_wgt( ln_bt_av, ll_fw_start, icycle, wgtbtp1, wgtbtp2 ) 
    349219      ENDIF 
     220      ! 
    350221                           
    351222      ! ----------------------------------------------------------------------------- 
    … …  
    354225      !       
    355226      ! 
    356       !                                   !* e3*d/dt(Ua) (Vertically integrated) 
    357       !                                   ! -------------------------------------------------- 
    358       zu_frc(:,:) = 0._wp 
    359       zv_frc(:,:) = 0._wp 
    360       ! 
    361       DO jk = 1, jpkm1 
    362          zu_frc(:,:) = zu_frc(:,:) + e3u_n(:,:,jk) * ua(:,:,jk) * umask(:,:,jk) 
    363          zv_frc(:,:) = zv_frc(:,:) + e3v_n(:,:,jk) * va(:,:,jk) * vmask(:,:,jk)          
    364       END DO 
    365       ! 
    366       zu_frc(:,:) = zu_frc(:,:) * r1_hu_n(:,:) 
    367       zv_frc(:,:) = zv_frc(:,:) * r1_hv_n(:,:) 
    368       ! 
    369       ! 
    370       !                                   !* baroclinic momentum trend (remove the vertical mean trend) 
    371       DO jk = 1, jpkm1                    ! ----------------------------------------------------------- 
    372          DO jj = 2, jpjm1 
    373             DO ji = fs_2, fs_jpim1   ! vector opt. 
    374                ua(ji,jj,jk) = ua(ji,jj,jk) - zu_frc(ji,jj) * umask(ji,jj,jk) 
    375                va(ji,jj,jk) = va(ji,jj,jk) - zv_frc(ji,jj) * vmask(ji,jj,jk) 
    376             END DO 
    377          END DO 
     227      !                                   !=  zu_frc =  1/H e3*d/dt(Ua)  =!  (Vertical mean of Ua, the 3D trends) 
     228      !                                   !  ---------------------------  ! 
     229      zu_frc(:,:) = SUM( e3u_n(:,:,:) * ua(:,:,:) * umask(:,:,:) , DIM=3 ) * r1_hu_n(:,:) 
     230      zv_frc(:,:) = SUM( e3v_n(:,:,:) * va(:,:,:) * vmask(:,:,:) , DIM=3 ) * r1_hv_n(:,:) 
     231      ! 
     232      ! 
     233      !                                   !=  Ua => baroclinic trend  =!   (remove its vertical mean) 
     234      DO jk = 1, jpkm1                    !  ------------------------  ! 
     235         ua(:,:,jk) = ( ua(:,:,jk) - zu_frc(:,:) ) * umask(:,:,jk) 
     236         va(:,:,jk) = ( va(:,:,jk) - zv_frc(:,:) ) * vmask(:,:,jk) 
    378237      END DO 
    379238       
    … …  
    381240!!gm  Is it correct to do so ?   I think so... 
    382241       
    383        
    384       !                                   !* barotropic Coriolis trends (vorticity scheme dependent) 
    385       !                                   ! -------------------------------------------------------- 
    386       ! 
    387       zwx(:,:) = un_b(:,:) * hu_n(:,:) * e2u(:,:)        ! now fluxes  
    388       zwy(:,:) = vn_b(:,:) * hv_n(:,:) * e1v(:,:) 
    389       ! 
    390       SELECT CASE( nvor_scheme ) 
    391       CASE( np_ENT )                ! enstrophy conserving scheme (f-point) 
    392          DO jj = 2, jpjm1 
    393             DO ji = 2, jpim1   ! vector opt. 
    394                zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * r1_hu_n(ji,jj)                    & 
    395                   &               * (  e1e2t(ji+1,jj)*ht_n(ji+1,jj)*ff_t(ji+1,jj) * ( vn_b(ji+1,jj) + vn_b(ji+1,jj-1) )   & 
    396                   &                  + e1e2t(ji  ,jj)*ht_n(ji  ,jj)*ff_t(ji  ,jj) * ( vn_b(ji  ,jj) + vn_b(ji  ,jj-1) )   ) 
    397                   ! 
    398                zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * r1_hv_n(ji,jj)                    & 
    399                   &               * (  e1e2t(ji,jj+1)*ht_n(ji,jj+1)*ff_t(ji,jj+1) * ( un_b(ji,jj+1) + un_b(ji-1,jj+1) )   &  
    400                   &                  + e1e2t(ji,jj  )*ht_n(ji,jj  )*ff_t(ji,jj  ) * ( un_b(ji,jj  ) + un_b(ji-1,jj  ) )   )  
    401             END DO   
    402          END DO   
    403          !          
    404       CASE( np_ENE , np_MIX )        ! energy conserving scheme (t-point) ENE or MIX 
    405          DO jj = 2, jpjm1 
    406             DO ji = fs_2, fs_jpim1   ! vector opt. 
    407                zy1 = ( zwy(ji,jj-1) + zwy(ji+1,jj-1) ) * r1_e1u(ji,jj) 
    408                zy2 = ( zwy(ji,jj  ) + zwy(ji+1,jj  ) ) * r1_e1u(ji,jj) 
    409                zx1 = ( zwx(ji-1,jj) + zwx(ji-1,jj+1) ) * r1_e2v(ji,jj) 
    410                zx2 = ( zwx(ji  ,jj) + zwx(ji  ,jj+1) ) * r1_e2v(ji,jj) 
    411                ! energy conserving formulation for planetary vorticity term 
    412                zu_trd(ji,jj) =   r1_4 * ( zwz(ji  ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 
    413                zv_trd(ji,jj) = - r1_4 * ( zwz(ji-1,jj  ) * zx1 + zwz(ji,jj) * zx2 ) 
    414             END DO 
    415          END DO 
    416          ! 
    417       CASE( np_ENS )                ! enstrophy conserving scheme (f-point) 
    418          DO jj = 2, jpjm1 
    419             DO ji = fs_2, fs_jpim1   ! vector opt. 
    420                zy1 =   r1_8 * ( zwy(ji  ,jj-1) + zwy(ji+1,jj-1) & 
    421                  &            + zwy(ji  ,jj  ) + zwy(ji+1,jj  ) ) * r1_e1u(ji,jj) 
    422                zx1 = - r1_8 * ( zwx(ji-1,jj  ) + zwx(ji-1,jj+1) & 
    423                  &            + zwx(ji  ,jj  ) + zwx(ji  ,jj+1) ) * r1_e2v(ji,jj) 
    424                zu_trd(ji,jj)  = zy1 * ( zwz(ji  ,jj-1) + zwz(ji,jj) ) 
    425                zv_trd(ji,jj)  = zx1 * ( zwz(ji-1,jj  ) + zwz(ji,jj) ) 
    426             END DO 
    427          END DO 
    428          ! 
    429       CASE( np_EET , np_EEN )      ! energy & enstrophy scheme (using e3t or e3f)          
    430          DO jj = 2, jpjm1 
    431             DO ji = fs_2, fs_jpim1   ! vector opt. 
    432                zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * (  ftne(ji,jj  ) * zwy(ji  ,jj  ) & 
    433                 &                                         + ftnw(ji+1,jj) * zwy(ji+1,jj  ) & 
    434                 &                                         + ftse(ji,jj  ) * zwy(ji  ,jj-1) & 
    435                 &                                         + ftsw(ji+1,jj) * zwy(ji+1,jj-1) ) 
    436                zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * (  ftsw(ji,jj+1) * zwx(ji-1,jj+1) & 
    437                 &                                         + ftse(ji,jj+1) * zwx(ji  ,jj+1) & 
    438                 &                                         + ftnw(ji,jj  ) * zwx(ji-1,jj  ) & 
    439                 &                                         + ftne(ji,jj  ) * zwx(ji  ,jj  ) ) 
    440             END DO 
    441          END DO 
    442          ! 
    443       END SELECT 
    444       ! 
    445       !                                   !* Right-Hand-Side of the barotropic momentum equation 
    446       !                                   ! ---------------------------------------------------- 
    447       IF( .NOT.ln_linssh ) THEN                 ! Variable volume : remove surface pressure gradient 
    448          IF( ln_wd_il ) THEN                        ! Calculating and applying W/D gravity filters 
     242      !                                   !=  remove 2D Coriolis and pressure gradient trends  =! 
     243      !                                   !  -------------------------------------------------  ! 
     244      ! 
     245      IF( kt == nit000 .OR. .NOT. ln_linssh )   CALL dyn_cor_2D_init   ! Set zwz, the barotropic Coriolis force coefficient 
     246      !       ! recompute zwz = f/depth  at every time step for (.NOT.ln_linssh) as the water colomn height changes 
     247      ! 
     248      !                                         !* 2D Coriolis trends 
     249      zhU(:,:) = un_b(:,:) * hu_n(:,:) * e2u(:,:)        ! now fluxes  
     250      zhV(:,:) = vn_b(:,:) * hv_n(:,:) * e1v(:,:)        ! NB: FULL domain : put a value in last row and column 
     251      ! 
     252      CALL dyn_cor_2d( hu_n, hv_n, un_b, vn_b, zhU, zhV,  &   ! <<== in 
     253         &                               zu_trd, zv_trd   )   ! ==>> out 
     254      ! 
     255      IF( .NOT.ln_linssh ) THEN                 !* surface pressure gradient   (variable volume only) 
     256         ! 
     257         IF( ln_wd_il ) THEN                       ! W/D : limiter applied to spgspg 
     258            CALL wad_spg( sshn, zcpx, zcpy )          ! Calculating W/D gravity filters, zcpx and zcpy 
    449259            DO jj = 2, jpjm1 
    450                DO ji = 2, jpim1  
    451                   ll_tmp1 = MIN(  sshn(ji,jj)               ,  sshn(ji+1,jj) ) >                & 
    452                      &      MAX( -ht_0(ji,jj)               , -ht_0(ji+1,jj) ) .AND.            & 
    453                      &      MAX(  sshn(ji,jj) + ht_0(ji,jj) ,  sshn(ji+1,jj) + ht_0(ji+1,jj) )  & 
    454                      &                                                         > rn_wdmin1 + rn_wdmin2 
    455                   ll_tmp2 = ( ABS( sshn(ji+1,jj)            -  sshn(ji  ,jj))  > 1.E-12 ).AND.( & 
    456                      &      MAX(   sshn(ji,jj)              ,  sshn(ji+1,jj) ) >                & 
    457                      &      MAX(  -ht_0(ji,jj)              , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 
    458                   IF(ll_tmp1) THEN 
    459                      zcpx(ji,jj) = 1.0_wp 
    460                   ELSEIF(ll_tmp2) THEN 
    461                      ! no worries about  sshn(ji+1,jj) -  sshn(ji  ,jj) = 0, it won't happen ! here 
    462                      zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_0(ji+1,jj) - sshn(ji,jj) - ht_0(ji,jj)) & 
    463                                  &    / (sshn(ji+1,jj) - sshn(ji  ,jj)) ) 
    464                      zcpx(ji,jj) = max(min( zcpx(ji,jj) , 1.0_wp),0.0_wp) 
    465                   ELSE 
    466                      zcpx(ji,jj) = 0._wp 
    467                   ENDIF 
    468                   ! 
    469                   ll_tmp1 = MIN(  sshn(ji,jj)               ,  sshn(ji,jj+1) ) >                & 
    470                      &      MAX( -ht_0(ji,jj)               , -ht_0(ji,jj+1) ) .AND.            & 
    471                      &      MAX(  sshn(ji,jj) + ht_0(ji,jj) ,  sshn(ji,jj+1) + ht_0(ji,jj+1) )  & 
    472                      &                                                       > rn_wdmin1 + rn_wdmin2 
    473                   ll_tmp2 = ( ABS( sshn(ji,jj)              -  sshn(ji,jj+1))  > 1.E-12 ).AND.( & 
    474                      &      MAX(   sshn(ji,jj)              ,  sshn(ji,jj+1) ) >                & 
    475                      &      MAX(  -ht_0(ji,jj)              , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 
    476    
    477                   IF(ll_tmp1) THEN 
    478                      zcpy(ji,jj) = 1.0_wp 
    479                   ELSE IF(ll_tmp2) THEN 
    480                      ! no worries about  sshn(ji,jj+1) -  sshn(ji,jj  ) = 0, it won't happen ! here 
    481                      zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_0(ji,jj+1) - sshn(ji,jj) - ht_0(ji,jj)) & 
    482                         &             / (sshn(ji,jj+1) - sshn(ji,jj  )) ) 
    483                      zcpy(ji,jj) = MAX(  0._wp , MIN( zcpy(ji,jj) , 1.0_wp )  ) 
    484                   ELSE 
    485                      zcpy(ji,jj) = 0._wp 
    486                   ENDIF 
    487                END DO 
    488             END DO 
    489             ! 
    490             DO jj = 2, jpjm1 
    491                DO ji = 2, jpim1 
     260               DO ji = 2, jpim1                ! SPG with the application of W/D gravity filters 
    492261                  zu_trd(ji,jj) = zu_trd(ji,jj) - grav * ( sshn(ji+1,jj  ) - sshn(ji  ,jj ) )   & 
    493262                     &                          * r1_e1u(ji,jj) * zcpx(ji,jj)  * wdrampu(ji,jj)  !jth 
    … …  
    496265               END DO 
    497266            END DO 
    498             ! 
    499          ELSE 
    500             ! 
     267         ELSE                                      ! now suface pressure gradient 
    501268            DO jj = 2, jpjm1 
    502269               DO ji = fs_2, fs_jpim1   ! vector opt. 
    … …  
    516283      END DO  
    517284      ! 
    518       !                                         ! Add bottom stress contribution from baroclinic velocities:       
    519       IF (ln_bt_fw) THEN 
    520          DO jj = 2, jpjm1                           
    521             DO ji = fs_2, fs_jpim1   ! vector opt. 
    522                ikbu = mbku(ji,jj)        
    523                ikbv = mbkv(ji,jj)     
    524                zwx(ji,jj) = un(ji,jj,ikbu) - un_b(ji,jj) ! NOW bottom baroclinic velocities 
    525                zwy(ji,jj) = vn(ji,jj,ikbv) - vn_b(ji,jj) 
    526             END DO 
    527          END DO 
    528       ELSE 
    529          DO jj = 2, jpjm1 
    530             DO ji = fs_2, fs_jpim1   ! vector opt. 
    531                ikbu = mbku(ji,jj)        
    532                ikbv = mbkv(ji,jj)     
    533                zwx(ji,jj) = ub(ji,jj,ikbu) - ub_b(ji,jj) ! BEFORE bottom baroclinic velocities 
    534                zwy(ji,jj) = vb(ji,jj,ikbv) - vb_b(ji,jj) 
    535             END DO 
    536          END DO 
    537       ENDIF 
    538       ! 
    539       ! Note that the "unclipped" bottom friction parameter is used even with explicit drag 
    540       IF( ln_wd_il ) THEN 
    541          zztmp = -1._wp / rdtbt 
    542          DO jj = 2, jpjm1 
    543             DO ji = fs_2, fs_jpim1   ! vector opt. 
    544                zu_frc(ji,jj) = zu_frc(ji,jj) + &  
    545                & MAX(r1_hu_n(ji,jj) * r1_2 * ( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ), zztmp ) * zwx(ji,jj) *  wdrampu(ji,jj) 
    546                zv_frc(ji,jj) = zv_frc(ji,jj) + &  
    547                & MAX(r1_hv_n(ji,jj) * r1_2 * ( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ), zztmp ) * zwy(ji,jj) *  wdrampv(ji,jj) 
    548             END DO 
    549          END DO 
    550       ELSE 
    551          DO jj = 2, jpjm1 
    552             DO ji = fs_2, fs_jpim1   ! vector opt. 
    553                zu_frc(ji,jj) = zu_frc(ji,jj) + r1_hu_n(ji,jj) * r1_2 * ( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * zwx(ji,jj) 
    554                zv_frc(ji,jj) = zv_frc(ji,jj) + r1_hv_n(ji,jj) * r1_2 * ( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * zwy(ji,jj) 
    555             END DO 
    556          END DO 
    557       END IF 
    558       ! 
    559       IF( ln_isfcav ) THEN       ! Add TOP stress contribution from baroclinic velocities:       
    560          IF( ln_bt_fw ) THEN 
    561             DO jj = 2, jpjm1 
     285      !                                   !=  Add bottom stress contribution from baroclinic velocities  =! 
     286      !                                   !  -----------------------------------------------------------  ! 
     287      CALL dyn_drg_init( zu_frc, zv_frc,  zCdU_u, zCdU_v )      ! also provide the barotropic drag coefficients 
     288      ! 
     289      !                                   !=  Add atmospheric pressure forcing  =! 
     290      !                                   !  ----------------------------------  ! 
     291      IF( ln_apr_dyn ) THEN 
     292         IF( ln_bt_fw ) THEN                          ! FORWARD integration: use kt+1/2 pressure (NOW+1/2) 
     293            DO jj = 2, jpjm1               
    562294               DO ji = fs_2, fs_jpim1   ! vector opt. 
    563                   iktu = miku(ji,jj) 
    564                   iktv = mikv(ji,jj) 
    565                   zwx(ji,jj) = un(ji,jj,iktu) - un_b(ji,jj) ! NOW top baroclinic velocities 
    566                   zwy(ji,jj) = vn(ji,jj,iktv) - vn_b(ji,jj) 
    567                END DO 
    568             END DO 
    569          ELSE 
    570             DO jj = 2, jpjm1 
     295                  zu_frc(ji,jj) = zu_frc(ji,jj) + grav * (  ssh_ib (ji+1,jj  ) - ssh_ib (ji,jj) ) * r1_e1u(ji,jj) 
     296                  zv_frc(ji,jj) = zv_frc(ji,jj) + grav * (  ssh_ib (ji  ,jj+1) - ssh_ib (ji,jj) ) * r1_e2v(ji,jj) 
     297               END DO 
     298            END DO 
     299         ELSE                                         ! CENTRED integration: use kt-1/2 + kt+1/2 pressure (NOW) 
     300            zztmp = grav * r1_2 
     301            DO jj = 2, jpjm1               
    571302               DO ji = fs_2, fs_jpim1   ! vector opt. 
    572                   iktu = miku(ji,jj) 
    573                   iktv = mikv(ji,jj) 
    574                   zwx(ji,jj) = ub(ji,jj,iktu) - ub_b(ji,jj) ! BEFORE top baroclinic velocities 
    575                   zwy(ji,jj) = vb(ji,jj,iktv) - vb_b(ji,jj) 
    576                END DO 
    577             END DO 
    578          ENDIF 
    579          ! 
    580          ! Note that the "unclipped" top friction parameter is used even with explicit drag 
    581          DO jj = 2, jpjm1               
    582             DO ji = fs_2, fs_jpim1   ! vector opt. 
    583                zu_frc(ji,jj) = zu_frc(ji,jj) + r1_hu_n(ji,jj) * r1_2 * ( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * zwx(ji,jj) 
    584                zv_frc(ji,jj) = zv_frc(ji,jj) + r1_hv_n(ji,jj) * r1_2 * ( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * zwy(ji,jj) 
    585             END DO 
    586          END DO 
    587       ENDIF 
    588       !        
     303                  zu_frc(ji,jj) = zu_frc(ji,jj) + zztmp * (  ssh_ib (ji+1,jj  ) - ssh_ib (ji,jj)  & 
     304                       &                                   + ssh_ibb(ji+1,jj  ) - ssh_ibb(ji,jj)  ) * r1_e1u(ji,jj) 
     305                  zv_frc(ji,jj) = zv_frc(ji,jj) + zztmp * (  ssh_ib (ji  ,jj+1) - ssh_ib (ji,jj)  & 
     306                       &                                   + ssh_ibb(ji  ,jj+1) - ssh_ibb(ji,jj)  ) * r1_e2v(ji,jj) 
     307               END DO 
     308            END DO 
     309         ENDIF  
     310      ENDIF 
     311      ! 
     312      !                                   !=  Add atmospheric pressure forcing  =! 
     313      !                                   !  ----------------------------------  ! 
    589314      IF( ln_bt_fw ) THEN                        ! Add wind forcing 
    590315         DO jj = 2, jpjm1 
    … …  
    604329      ENDIF   
    605330      ! 
    606       IF( ln_apr_dyn ) THEN                     ! Add atm pressure forcing 
    607          IF( ln_bt_fw ) THEN 
    608             DO jj = 2, jpjm1               
    609                DO ji = fs_2, fs_jpim1   ! vector opt. 
    610                   zu_spg =  grav * (  ssh_ib (ji+1,jj  ) - ssh_ib (ji,jj) ) * r1_e1u(ji,jj) 
    611                   zv_spg =  grav * (  ssh_ib (ji  ,jj+1) - ssh_ib (ji,jj) ) * r1_e2v(ji,jj) 
    612                   zu_frc(ji,jj) = zu_frc(ji,jj) + zu_spg 
    613                   zv_frc(ji,jj) = zv_frc(ji,jj) + zv_spg 
    614                END DO 
    615             END DO 
    616          ELSE 
    617             zztmp = grav * r1_2 
    618             DO jj = 2, jpjm1               
    619                DO ji = fs_2, fs_jpim1   ! vector opt. 
    620                   zu_spg = zztmp * (  ssh_ib (ji+1,jj  ) - ssh_ib (ji,jj)    & 
    621                       &             + ssh_ibb(ji+1,jj  ) - ssh_ibb(ji,jj)  ) * r1_e1u(ji,jj) 
    622                   zv_spg = zztmp * (  ssh_ib (ji  ,jj+1) - ssh_ib (ji,jj)    & 
    623                       &             + ssh_ibb(ji  ,jj+1) - ssh_ibb(ji,jj)  ) * r1_e2v(ji,jj) 
    624                   zu_frc(ji,jj) = zu_frc(ji,jj) + zu_spg 
    625                   zv_frc(ji,jj) = zv_frc(ji,jj) + zv_spg 
    626                END DO 
    627             END DO 
    628          ENDIF  
    629       ENDIF 
    630       !                                   !* Right-Hand-Side of the barotropic ssh equation 
    631       !                                   ! ----------------------------------------------- 
    632       !                                         ! Surface net water flux and rivers 
    633       IF (ln_bt_fw) THEN 
    634          zssh_frc(:,:) = r1_rau0 * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) ) 
    635       ELSE 
     331      !              !----------------! 
     332      !              !==  sssh_frc  ==!   Right-Hand-Side of the barotropic ssh equation   (over the FULL domain) 
     333      !              !----------------! 
     334      !                                   !=  Net water flux forcing applied to a water column  =! 
     335      !                                   ! ---------------------------------------------------  ! 
     336      IF (ln_bt_fw) THEN                          ! FORWARD integration: use kt+1/2 fluxes (NOW+1/2) 
     337         zssh_frc(:,:) = r1_rau0 * ( emp(:,:)             - rnf(:,:)              + fwfisf(:,:)                  ) 
     338      ELSE                                        ! CENTRED integration: use kt-1/2 + kt+1/2 fluxes (NOW) 
    636339         zztmp = r1_rau0 * r1_2 
    637          zssh_frc(:,:) = zztmp * (  emp(:,:) + emp_b(:,:) - rnf(:,:) - rnf_b(:,:)   & 
    638                 &                 + fwfisf(:,:) + fwfisf_b(:,:)                     ) 
    639       ENDIF 
    640       ! 
    641       IF( ln_sdw ) THEN                         ! Stokes drift divergence added if necessary 
     340         zssh_frc(:,:) = zztmp * (  emp(:,:) + emp_b(:,:) - rnf(:,:) - rnf_b(:,:) + fwfisf(:,:) + fwfisf_b(:,:)  ) 
     341      ENDIF 
     342      !                                   !=  Add Stokes drift divergence  =!   (if exist) 
     343      IF( ln_sdw ) THEN                   !  -----------------------------  ! 
    642344         zssh_frc(:,:) = zssh_frc(:,:) + div_sd(:,:) 
    643345      ENDIF 
    644346      ! 
    645347#if defined key_asminc 
    646       !                                         ! Include the IAU weighted SSH increment 
     348      !                                   !=  Add the IAU weighted SSH increment  =! 
     349      !                                   !  ------------------------------------  ! 
    647350      IF( lk_asminc .AND. ln_sshinc .AND. ln_asmiau ) THEN 
    648351         zssh_frc(:,:) = zssh_frc(:,:) - ssh_iau(:,:) 
    649352      ENDIF 
    650353#endif 
    651       !                                   !* Fill boundary data arrays for AGRIF 
     354      !                                   != Fill boundary data arrays for AGRIF 
    652355      !                                   ! ------------------------------------ 
    653356#if defined key_agrif 
    … …  
    671374         vb_e   (:,:) = 0._wp 
    672375      ENDIF 
    673  
     376      ! 
     377      IF( ln_linssh ) THEN    ! mid-step ocean depth is fixed (hup2_e=hu_n=hu_0) 
     378         zhup2_e(:,:) = hu_n(:,:) 
     379         zhvp2_e(:,:) = hv_n(:,:) 
     380         zhtp2_e(:,:) = ht_n(:,:) 
     381      ENDIF 
    674382      ! 
    675383      IF (ln_bt_fw) THEN                  ! FORWARD integration: start from NOW fields                     
    … …  
    693401      ENDIF 
    694402      ! 
    695       ! 
    696       ! 
    697403      ! Initialize sums: 
    698404      ua_b  (:,:) = 0._wp       ! After barotropic velocities (or transport if flux form)           
    … …  
    714420         ! 
    715421         l_full_nf_update = jn == icycle   ! false: disable full North fold update (performances) for jn = 1 to icycle-1 
    716          !                                                !  ------------------ 
    717          !                                                !* Update the forcing (BDY and tides) 
    718          !                                                !  ------------------ 
    719          ! Update only tidal forcing at open boundaries 
    720          IF( ln_bdy      .AND. ln_tide )   CALL bdy_dta_tides( kt, kit=jn, time_offset= noffset+1 ) 
    721          IF( ln_tide_pot .AND. ln_tide )   CALL upd_tide     ( kt, kit=jn, time_offset= noffset   ) 
    722          ! 
    723          ! Set extrapolation coefficients for predictor step: 
     422         ! 
     423         !                    !==  Update the forcing ==! (BDY and tides) 
     424         ! 
     425         IF( ln_bdy      .AND. ln_tide )   CALL bdy_dta_tides( kt, kit=jn, kt_offset= noffset+1 ) 
     426         IF( ln_tide_pot .AND. ln_tide )   CALL upd_tide     ( kt, kit=jn, kt_offset= noffset   ) 
     427         ! 
     428         !                    !==  extrapolation at mid-step  ==!   (jn+1/2) 
     429         ! 
     430         !                       !* Set extrapolation coefficients for predictor step: 
    724431         IF ((jn<3).AND.ll_init) THEN      ! Forward            
    725432           za1 = 1._wp                                           
    … …  
    731438           za3 =  0.281105_wp              ! za3 = bet 
    732439         ENDIF 
    733  
    734          ! Extrapolate barotropic velocities at step jit+0.5: 
     440         ! 
     441         !                       !* Extrapolate barotropic velocities at mid-step (jn+1/2) 
     442         !--        m+1/2               m                m-1           m-2       --! 
     443         !--       u      = (3/2+beta) u   -(1/2+2beta) u      + beta u          --! 
     444         !-------------------------------------------------------------------------! 
    735445         ua_e(:,:) = za1 * un_e(:,:) + za2 * ub_e(:,:) + za3 * ubb_e(:,:) 
    736446         va_e(:,:) = za1 * vn_e(:,:) + za2 * vb_e(:,:) + za3 * vbb_e(:,:) 
    … …  
    739449            !                                             !  ------------------ 
    740450            ! Extrapolate Sea Level at step jit+0.5: 
     451            !--         m+1/2                 m                  m-1             m-2       --! 
     452            !--      ssh      = (3/2+beta) ssh   -(1/2+2beta) ssh      + beta ssh          --! 
     453            !--------------------------------------------------------------------------------! 
    741454            zsshp2_e(:,:) = za1 * sshn_e(:,:)  + za2 * sshb_e(:,:) + za3 * sshbb_e(:,:) 
    742455             
    743             ! set wetting & drying mask at tracer points for this barotropic sub-step  
    744             IF ( ln_wd_dl ) THEN  
    745                ! 
    746                IF ( ln_wd_dl_rmp ) THEN  
    747                   DO jj = 1, jpj                                  
    748                      DO ji = 1, jpi   ! vector opt.   
    749                         IF ( zsshp2_e(ji,jj) + ht_0(ji,jj) >  2._wp * rn_wdmin1 ) THEN  
    750 !                        IF ( zsshp2_e(ji,jj) + ht_0(ji,jj) >  rn_wdmin2 ) THEN  
    751                            ztwdmask(ji,jj) = 1._wp 
    752                         ELSE IF ( zsshp2_e(ji,jj) + ht_0(ji,jj) >  rn_wdmin1 ) THEN 
    753                            ztwdmask(ji,jj) = (tanh(50._wp*( ( zsshp2_e(ji,jj) + ht_0(ji,jj) -  rn_wdmin1 )*r_rn_wdmin1)) )  
    754                         ELSE  
    755                            ztwdmask(ji,jj) = 0._wp 
    756                         END IF 
    757                      END DO 
    758                   END DO 
    759                ELSE 
    760                   DO jj = 1, jpj                                  
    761                      DO ji = 1, jpi   ! vector opt.   
    762                         IF ( zsshp2_e(ji,jj) + ht_0(ji,jj) >  rn_wdmin1 ) THEN  
    763                            ztwdmask(ji,jj) = 1._wp 
    764                         ELSE  
    765                            ztwdmask(ji,jj) = 0._wp 
    766                         ENDIF 
    767                      END DO 
    768                   END DO 
    769                ENDIF  
    770                ! 
    771             ENDIF  
     456            ! set wetting & drying mask at tracer points for this barotropic mid-step 
     457            IF( ln_wd_dl )   CALL wad_tmsk( zsshp2_e, ztwdmask ) 
    772458            ! 
    773             DO jj = 2, jpjm1                                    ! Sea Surface Height at u- & v-points 
    774                DO ji = 2, fs_jpim1   ! Vector opt. 
    775                   zwx(ji,jj) = r1_2 * ssumask(ji,jj)  * r1_e1e2u(ji,jj)     & 
    776                      &              * ( e1e2t(ji  ,jj) * zsshp2_e(ji  ,jj)  & 
    777                      &              +   e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) 
    778                   zwy(ji,jj) = r1_2 * ssvmask(ji,jj)  * r1_e1e2v(ji,jj)     & 
    779                      &              * ( e1e2t(ji,jj  ) * zsshp2_e(ji,jj  )  & 
    780                      &              +   e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) 
    781                END DO 
    782             END DO 
    783             CALL lbc_lnk_multi( 'dynspg_ts', zwx, 'U', 1._wp, zwy, 'V', 1._wp ) 
     459            !                          ! ocean t-depth at mid-step 
     460            zhtp2_e(:,:) = ht_0(:,:) + zsshp2_e(:,:) 
    784461            ! 
    785             zhup2_e(:,:) = hu_0(:,:) + zwx(:,:)                ! Ocean depth at U- and V-points 
    786             zhvp2_e(:,:) = hv_0(:,:) + zwy(:,:) 
    787             zhtp2_e(:,:) = ht_0(:,:) + zsshp2_e(:,:) 
    788          ELSE 
    789             zhup2_e(:,:) = hu_n(:,:) 
    790             zhvp2_e(:,:) = hv_n(:,:) 
    791             zhtp2_e(:,:) = ht_n(:,:) 
    792          ENDIF 
    793          !                                                !* after ssh 
    794          !                                                !  ----------- 
    795          ! 
    796          ! Enforce volume conservation at open boundaries: 
     462            !                          ! ocean u- and v-depth at mid-step   (separate DO-loops remove the need of a lbc_lnk) 
     463            DO jj = 1, jpj 
     464               DO ji = 1, jpim1   ! not jpi-column 
     465                  zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * r1_e1e2u(ji,jj)                        & 
     466                       &                              * (  e1e2t(ji  ,jj) * zsshp2_e(ji  ,jj)  & 
     467                       &                                 + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj)  ) * ssumask(ji,jj) 
     468               END DO 
     469            END DO 
     470            DO jj = 1, jpjm1        ! not jpj-row 
     471               DO ji = 1, jpi 
     472                  zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * r1_e1e2v(ji,jj)                        & 
     473                       &                              * (  e1e2t(ji,jj  ) * zsshp2_e(ji,jj  )  & 
     474                       &                                 + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1)  ) * ssvmask(ji,jj) 
     475               END DO 
     476            END DO 
     477            ! 
     478         ENDIF 
     479         ! 
     480         !                    !==  after SSH  ==!   (jn+1) 
     481         ! 
     482         !                             ! update (ua_e,va_e) to enforce volume conservation at open boundaries 
     483         !                             ! values of zhup2_e and zhvp2_e on the halo are not needed in bdy_vol2d 
    797484         IF( ln_bdy .AND. ln_vol ) CALL bdy_vol2d( kt, jn, ua_e, va_e, zhup2_e, zhvp2_e ) 
    798485         ! 
    799          zwx(:,:) = e2u(:,:) * ua_e(:,:) * zhup2_e(:,:)         ! fluxes at jn+0.5 
    800          zwy(:,:) = e1v(:,:) * va_e(:,:) * zhvp2_e(:,:) 
     486         !                             ! resulting flux at mid-step (not over the full domain) 
     487         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 
     488         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 
    801489         ! 
    802490#if defined key_agrif 
    … …  
    805493            IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    806494               DO jj = 1, jpj 
    807                   zwx(2:nbghostcells+1,jj) = ubdy_w(1:nbghostcells,jj) * e2u(2:nbghostcells+1,jj) 
    808                   zwy(2:nbghostcells+1,jj) = vbdy_w(1:nbghostcells,jj) * e1v(2:nbghostcells+1,jj) 
     495                  zhU(2:nbghostcells+1,jj) = ubdy_w(1:nbghostcells,jj) * e2u(2:nbghostcells+1,jj) 
     496                  zhV(2:nbghostcells+1,jj) = vbdy_w(1:nbghostcells,jj) * e1v(2:nbghostcells+1,jj) 
    809497               END DO 
    810498            ENDIF 
    811499            IF((nbondi ==  1).OR.(nbondi == 2)) THEN 
    812500               DO jj=1,jpj 
    813                   zwx(nlci-nbghostcells-1:nlci-2,jj) = ubdy_e(1:nbghostcells,jj) * e2u(nlci-nbghostcells-1:nlci-2,jj) 
    814                   zwy(nlci-nbghostcells  :nlci-1,jj) = vbdy_e(1:nbghostcells,jj) * e1v(nlci-nbghostcells  :nlci-1,jj) 
     501                  zhU(nlci-nbghostcells-1:nlci-2,jj) = ubdy_e(1:nbghostcells,jj) * e2u(nlci-nbghostcells-1:nlci-2,jj) 
     502                  zhV(nlci-nbghostcells  :nlci-1,jj) = vbdy_e(1:nbghostcells,jj) * e1v(nlci-nbghostcells  :nlci-1,jj) 
    815503               END DO 
    816504            ENDIF 
    817505            IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    818506               DO ji=1,jpi 
    819                   zwy(ji,2:nbghostcells+1) = vbdy_s(ji,1:nbghostcells) * e1v(ji,2:nbghostcells+1) 
    820                   zwx(ji,2:nbghostcells+1) = ubdy_s(ji,1:nbghostcells) * e2u(ji,2:nbghostcells+1) 
     507                  zhV(ji,2:nbghostcells+1) = vbdy_s(ji,1:nbghostcells) * e1v(ji,2:nbghostcells+1) 
     508                  zhU(ji,2:nbghostcells+1) = ubdy_s(ji,1:nbghostcells) * e2u(ji,2:nbghostcells+1) 
    821509               END DO 
    822510            ENDIF 
    823511            IF((nbondj ==  1).OR.(nbondj == 2)) THEN 
    824512               DO ji=1,jpi 
    825                   zwy(ji,nlcj-nbghostcells-1:nlcj-2) = vbdy_n(ji,1:nbghostcells) * e1v(ji,nlcj-nbghostcells-1:nlcj-2) 
    826                   zwx(ji,nlcj-nbghostcells  :nlcj-1) = ubdy_n(ji,1:nbghostcells) * e2u(ji,nlcj-nbghostcells  :nlcj-1) 
     513                  zhV(ji,nlcj-nbghostcells-1:nlcj-2) = vbdy_n(ji,1:nbghostcells) * e1v(ji,nlcj-nbghostcells-1:nlcj-2) 
     514                  zhU(ji,nlcj-nbghostcells  :nlcj-1) = ubdy_n(ji,1:nbghostcells) * e2u(ji,nlcj-nbghostcells  :nlcj-1) 
    827515               END DO 
    828516            ENDIF 
    829517         ENDIF 
    830518#endif 
    831          IF( ln_wd_il )   CALL wad_lmt_bt(zwx, zwy, sshn_e, zssh_frc, rdtbt) 
    832  
    833          IF ( ln_wd_dl ) THEN  
    834             ! 
    835             ! un_e and vn_e are set to zero at faces where the direction of the flow is from dry cells  
    836             ! 
    837             DO jj = 1, jpjm1                                  
    838                DO ji = 1, jpim1    
    839                   IF ( zwx(ji,jj) > 0.0 ) THEN  
    840                      zuwdmask(ji, jj) = ztwdmask(ji  ,jj)  
    841                   ELSE  
    842                      zuwdmask(ji, jj) = ztwdmask(ji+1,jj)   
    843                   END IF  
    844                   zwx(ji, jj) = zuwdmask(ji,jj)*zwx(ji, jj) 
    845                   un_e(ji,jj) = zuwdmask(ji,jj)*un_e(ji,jj) 
    846  
    847                   IF ( zwy(ji,jj) > 0.0 ) THEN 
    848                      zvwdmask(ji, jj) = ztwdmask(ji, jj  ) 
    849                   ELSE  
    850                      zvwdmask(ji, jj) = ztwdmask(ji, jj+1)   
    851                   END IF  
    852                   zwy(ji, jj) = zvwdmask(ji,jj)*zwy(ji,jj)  
    853                   vn_e(ji,jj) = zvwdmask(ji,jj)*vn_e(ji,jj) 
    854                END DO 
    855             END DO 
     519         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 
     520 
     521         IF( ln_wd_dl ) THEN           ! un_e and vn_e are set to zero at faces where  
     522            !                          ! the direction of the flow is from dry cells 
     523            CALL wad_Umsk( ztwdmask, zhU, zhV, un_e, vn_e, zuwdmask, zvwdmask )   ! not jpi colomn for U, not jpj row for V 
    856524            ! 
    857525         ENDIF     
    858           
    859          ! Sum over sub-time-steps to compute advective velocities 
    860          za2 = wgtbtp2(jn) 
    861          un_adv(:,:) = un_adv(:,:) + za2 * zwx(:,:) * r1_e2u(:,:) 
    862          vn_adv(:,:) = vn_adv(:,:) + za2 * zwy(:,:) * r1_e1v(:,:) 
    863           
    864          ! sum over sub-time-steps to decide which baroclinic velocities to set to zero (zuwdav2 is only used when ln_wd_dl_bc = True)  
     526         ! 
     527         ! 
     528         !     Compute Sea Level at step jit+1 
     529         !--           m+1        m                               m+1/2          --! 
     530         !--        ssh    =  ssh   - delta_t' * [ frc + div( flux      ) ]      --! 
     531         !-------------------------------------------------------------------------! 
     532         DO jj = 2, jpjm1        ! INNER domain                              
     533            DO ji = 2, jpim1 
     534               zhdiv = (   zhU(ji,jj) - zhU(ji-1,jj) + zhV(ji,jj) - zhV(ji,jj-1)   ) * r1_e1e2t(ji,jj) 
     535               ssha_e(ji,jj) = (  sshn_e(ji,jj) - rdtbt * ( zssh_frc(ji,jj) + zhdiv )  ) * ssmask(ji,jj) 
     536            END DO 
     537         END DO 
     538         ! 
     539         CALL lbc_lnk_multi( 'dynspg_ts', ssha_e, 'T', 1._wp,  zhU, 'U', -1._wp,  zhV, 'V', -1._wp ) 
     540         ! 
     541         !                             ! Sum over sub-time-steps to compute advective velocities 
     542         za2 = wgtbtp2(jn)             ! zhU, zhV hold fluxes extrapolated at jn+0.5 
     543         un_adv(:,:) = un_adv(:,:) + za2 * zhU(:,:) * r1_e2u(:,:) 
     544         vn_adv(:,:) = vn_adv(:,:) + za2 * zhV(:,:) * r1_e1v(:,:) 
     545         ! sum over sub-time-steps to decide which baroclinic velocities to set to zero (zuwdav2 is only used when ln_wd_dl_bc=True)  
    865546         IF ( ln_wd_dl_bc ) THEN 
    866             zuwdav2(:,:) = zuwdav2(:,:) + za2 * zuwdmask(:,:) 
    867             zvwdav2(:,:) = zvwdav2(:,:) + za2 * zvwdmask(:,:) 
    868          END IF  
    869  
    870          ! Set next sea level: 
    871          DO jj = 2, jpjm1                                  
    872             DO ji = fs_2, fs_jpim1   ! vector opt. 
    873                zhdiv(ji,jj) = (   zwx(ji,jj) - zwx(ji-1,jj)   & 
    874                   &             + zwy(ji,jj) - zwy(ji,jj-1)   ) * r1_e1e2t(ji,jj) 
    875             END DO 
    876          END DO 
    877          ssha_e(:,:) = (  sshn_e(:,:) - rdtbt * ( zssh_frc(:,:) + zhdiv(:,:) )  ) * ssmask(:,:) 
    878           
    879          CALL lbc_lnk( 'dynspg_ts', ssha_e, 'T',  1._wp ) 
    880  
     547            zuwdav2(1:jpim1,1:jpj  ) = zuwdav2(1:jpim1,1:jpj  ) + za2 * zuwdmask(1:jpim1,1:jpj  )   ! not jpi-column 
     548            zvwdav2(1:jpi  ,1:jpjm1) = zvwdav2(1:jpi  ,1:jpjm1) + za2 * zvwdmask(1:jpi  ,1:jpjm1)   ! not jpj-row 
     549         END IF 
     550         ! 
    881551         ! Duplicate sea level across open boundaries (this is only cosmetic if linssh=T) 
    882552         IF( ln_bdy )   CALL bdy_ssh( ssha_e ) 
    … …  
    887557         ! Sea Surface Height at u-,v-points (vvl case only) 
    888558         IF( .NOT.ln_linssh ) THEN                                 
    889             DO jj = 2, jpjm1 
     559            DO jj = 2, jpjm1   ! INNER domain, will be extended to whole domain later 
    890560               DO ji = 2, jpim1      ! NO Vector Opt. 
    891561                  zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj)    & 
    … …  
    897567               END DO 
    898568            END DO 
    899             CALL lbc_lnk_multi( 'dynspg_ts', zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) 
    900569         ENDIF    
    901          !                                  
    902          ! Half-step back interpolation of SSH for surface pressure computation: 
    903          !---------------------------------------------------------------------- 
    904          IF ((jn==1).AND.ll_init) THEN 
    905            za0=1._wp                        ! Forward-backward 
    906            za1=0._wp                            
    907            za2=0._wp 
    908            za3=0._wp 
    909          ELSEIF ((jn==2).AND.ll_init) THEN  ! AB2-AM3 Coefficients; bet=0 ; gam=-1/6 ; eps=1/12 
    910            za0= 1.0833333333333_wp          ! za0 = 1-gam-eps 
    911            za1=-0.1666666666666_wp          ! za1 = gam 
    912            za2= 0.0833333333333_wp          ! za2 = eps 
    913            za3= 0._wp               
    914          ELSE                               ! AB3-AM4 Coefficients; bet=0.281105 ; eps=0.013 ; gam=0.0880  
    915             IF (rn_bt_alpha==0._wp) THEN 
    916                za0=0.614_wp                 ! za0 = 1/2 +   gam + 2*eps 
    917                za1=0.285_wp                 ! za1 = 1/2 - 2*gam - 3*eps 
    918                za2=0.088_wp                 ! za2 = gam 
    919                za3=0.013_wp                 ! za3 = eps 
    920             ELSE 
    921                zepsilon = 0.00976186_wp - 0.13451357_wp * rn_bt_alpha 
    922                zgamma = 0.08344500_wp - 0.51358400_wp * rn_bt_alpha 
    923                za0 = 0.5_wp + zgamma + 2._wp * rn_bt_alpha + 2._wp * zepsilon 
    924                za1 = 1._wp - za0 - zgamma - zepsilon 
    925                za2 = zgamma 
    926                za3 = zepsilon 
    927             ENDIF  
    928          ENDIF 
    929          ! 
     570         !          
     571         ! Half-step back interpolation of SSH for surface pressure computation at step jit+1/2 
     572         !--            m+1/2           m+1              m               m-1              m-2     --! 
     573         !--        ssh'    =  za0 * ssh     +  za1 * ssh   +  za2 * ssh      +  za3 * ssh        --! 
     574         !------------------------------------------------------------------------------------------! 
     575         CALL ts_bck_interp( jn, ll_init, za0, za1, za2, za3 )   ! coeficients of the interpolation 
    930576         zsshp2_e(:,:) = za0 *  ssha_e(:,:) + za1 *  sshn_e (:,:)   & 
    931577            &          + za2 *  sshb_e(:,:) + za3 *  sshbb_e(:,:) 
    932           
    933          IF( ln_wd_il ) THEN                   ! Calculating and applying W/D gravity filters 
    934            DO jj = 2, jpjm1 
    935               DO ji = 2, jpim1  
    936                 ll_tmp1 = MIN( zsshp2_e(ji,jj)               , zsshp2_e(ji+1,jj) ) >                & 
    937                      &    MAX(    -ht_0(ji,jj)               ,    -ht_0(ji+1,jj) ) .AND.            & 
    938                      &    MAX( zsshp2_e(ji,jj) + ht_0(ji,jj) , zsshp2_e(ji+1,jj) + ht_0(ji+1,jj) ) & 
    939                      &                                                             > rn_wdmin1 + rn_wdmin2 
    940                 ll_tmp2 = (ABS(zsshp2_e(ji,jj)               - zsshp2_e(ji+1,jj))  > 1.E-12 ).AND.( & 
    941                      &    MAX( zsshp2_e(ji,jj)               , zsshp2_e(ji+1,jj) ) >                & 
    942                      &    MAX(    -ht_0(ji,jj)               ,    -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 
    943     
    944                 IF(ll_tmp1) THEN 
    945                   zcpx(ji,jj) = 1.0_wp 
    946                 ELSE IF(ll_tmp2) THEN 
    947                   ! no worries about  zsshp2_e(ji+1,jj) - zsshp2_e(ji  ,jj) = 0, it won't happen ! here 
    948                   zcpx(ji,jj) = ABS( (zsshp2_e(ji+1,jj) +     ht_0(ji+1,jj) - zsshp2_e(ji,jj) - ht_0(ji,jj)) & 
    949                               &    / (zsshp2_e(ji+1,jj) - zsshp2_e(ji  ,jj)) ) 
    950                 ELSE 
    951                   zcpx(ji,jj) = 0._wp 
    952                 ENDIF 
    953                 ! 
    954                 ll_tmp1 = MIN( zsshp2_e(ji,jj)               , zsshp2_e(ji,jj+1) ) >                & 
    955                      &    MAX(    -ht_0(ji,jj)               ,    -ht_0(ji,jj+1) ) .AND.            & 
    956                      &    MAX( zsshp2_e(ji,jj) + ht_0(ji,jj) , zsshp2_e(ji,jj+1) + ht_0(ji,jj+1) ) & 
    957                      &                                                             > rn_wdmin1 + rn_wdmin2 
    958                 ll_tmp2 = (ABS(zsshp2_e(ji,jj)               - zsshp2_e(ji,jj+1))  > 1.E-12 ).AND.( & 
    959                      &    MAX( zsshp2_e(ji,jj)               , zsshp2_e(ji,jj+1) ) >                & 
    960                      &    MAX(    -ht_0(ji,jj)               ,    -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 
    961     
    962                 IF(ll_tmp1) THEN 
    963                   zcpy(ji,jj) = 1.0_wp 
    964                 ELSEIF(ll_tmp2) THEN 
    965                   ! no worries about  zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj  ) = 0, it won't happen ! here 
    966                   zcpy(ji,jj) = ABS( (zsshp2_e(ji,jj+1) +     ht_0(ji,jj+1) - zsshp2_e(ji,jj) - ht_0(ji,jj)) & 
    967                               &    / (zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj  )) ) 
    968                 ELSE 
    969                   zcpy(ji,jj) = 0._wp 
    970                 ENDIF 
    971               END DO 
    972            END DO 
    973          ENDIF 
    974          ! 
    975          ! Compute associated depths at U and V points: 
    976          IF( .NOT.ln_linssh  .AND. .NOT.ln_dynadv_vec ) THEN     !* Vector form 
    977             !                                         
    978             DO jj = 2, jpjm1                             
    979                DO ji = 2, jpim1 
    980                   zx1 = r1_2 * ssumask(ji  ,jj) *  r1_e1e2u(ji  ,jj)    & 
    981                      &      * ( e1e2t(ji  ,jj  ) * zsshp2_e(ji  ,jj)    & 
    982                      &      +   e1e2t(ji+1,jj  ) * zsshp2_e(ji+1,jj  ) ) 
    983                   zy1 = r1_2 * ssvmask(ji  ,jj) *  r1_e1e2v(ji  ,jj  )  & 
    984                      &       * ( e1e2t(ji ,jj  ) * zsshp2_e(ji  ,jj  )  & 
    985                      &       +   e1e2t(ji ,jj+1) * zsshp2_e(ji  ,jj+1) ) 
    986                   zhust_e(ji,jj) = hu_0(ji,jj) + zx1  
    987                   zhvst_e(ji,jj) = hv_0(ji,jj) + zy1 
    988                END DO 
    989             END DO 
    990             ! 
     578         ! 
     579         !                             ! Surface pressure gradient 
     580         zldg = ( 1._wp - rn_scal_load ) * grav    ! local factor 
     581         DO jj = 2, jpjm1                             
     582            DO ji = 2, jpim1 
     583               zu_spg(ji,jj) = - zldg * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj) 
     584               zv_spg(ji,jj) = - zldg * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj) 
     585            END DO 
     586         END DO 
     587         IF( ln_wd_il ) THEN        ! W/D : gravity filters applied on pressure gradient 
     588            CALL wad_spg( zsshp2_e, zcpx, zcpy )   ! Calculating W/D gravity filters 
     589            zu_spg(2:jpim1,2:jpjm1) = zu_spg(2:jpim1,2:jpjm1) * zcpx(2:jpim1,2:jpjm1) 
     590            zv_spg(2:jpim1,2:jpjm1) = zv_spg(2:jpim1,2:jpjm1) * zcpy(2:jpim1,2:jpjm1) 
    991591         ENDIF 
    992592         ! 
    … …  
    994594         ! zwz array below or triads normally depend on sea level with ln_linssh=F and should be updated 
    995595         ! at each time step. We however keep them constant here for optimization. 
    996          ! Recall that zwx and zwy arrays hold fluxes at this stage: 
    997          ! zwx(:,:) = e2u(:,:) * ua_e(:,:) * zhup2_e(:,:)   ! fluxes at jn+0.5 
    998          ! zwy(:,:) = e1v(:,:) * va_e(:,:) * zhvp2_e(:,:) 
    999          ! 
    1000          SELECT CASE( nvor_scheme ) 
    1001          CASE( np_ENT )             ! energy conserving scheme (t-point) 
    1002          DO jj = 2, jpjm1 
    1003             DO ji = 2, jpim1   ! vector opt. 
    1004  
    1005                z1_hu = ssumask(ji,jj) / ( zhup2_e(ji,jj) + 1._wp - ssumask(ji,jj) ) 
    1006                z1_hv = ssvmask(ji,jj) / ( zhvp2_e(ji,jj) + 1._wp - ssvmask(ji,jj) ) 
    1007              
    1008                zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * z1_hu                   & 
    1009                   &               * (  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) )   & 
    1010                   &                  + e1e2t(ji  ,jj)*zhtp2_e(ji  ,jj)*ff_t(ji  ,jj) * ( va_e(ji  ,jj) + va_e(ji  ,jj-1) )   ) 
    1011                   ! 
    1012                zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * z1_hv                    & 
    1013                   &               * (  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) )   &  
    1014                   &                  + e1e2t(ji,jj  )*zhtp2_e(ji,jj  )*ff_t(ji,jj  ) * ( ua_e(ji,jj  ) + ua_e(ji-1,jj  ) )   )  
    1015             END DO   
    1016          END DO   
    1017          !          
    1018          CASE( np_ENE, np_MIX )     ! energy conserving scheme (f-point) 
    1019             DO jj = 2, jpjm1 
    1020                DO ji = fs_2, fs_jpim1   ! vector opt. 
    1021                   zy1 = ( zwy(ji  ,jj-1) + zwy(ji+1,jj-1) ) * r1_e1u(ji,jj) 
    1022                   zy2 = ( zwy(ji  ,jj  ) + zwy(ji+1,jj  ) ) * r1_e1u(ji,jj) 
    1023                   zx1 = ( zwx(ji-1,jj  ) + zwx(ji-1,jj+1) ) * r1_e2v(ji,jj) 
    1024                   zx2 = ( zwx(ji  ,jj  ) + zwx(ji  ,jj+1) ) * r1_e2v(ji,jj) 
    1025                   zu_trd(ji,jj) = r1_4 * ( zwz(ji  ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 
    1026                   zv_trd(ji,jj) =-r1_4 * ( zwz(ji-1,jj  ) * zx1 + zwz(ji,jj) * zx2 ) 
    1027                END DO 
    1028             END DO 
    1029             ! 
    1030          CASE( np_ENS )             ! enstrophy conserving scheme (f-point) 
    1031             DO jj = 2, jpjm1 
    1032                DO ji = fs_2, fs_jpim1   ! vector opt. 
    1033                   zy1 =   r1_8 * ( zwy(ji  ,jj-1) + zwy(ji+1,jj-1) & 
    1034                    &             + zwy(ji  ,jj  ) + zwy(ji+1,jj  ) ) * r1_e1u(ji,jj) 
    1035                   zx1 = - r1_8 * ( zwx(ji-1,jj  ) + zwx(ji-1,jj+1) & 
    1036                    &             + zwx(ji  ,jj  ) + zwx(ji  ,jj+1) ) * r1_e2v(ji,jj) 
    1037                   zu_trd(ji,jj)  = zy1 * ( zwz(ji  ,jj-1) + zwz(ji,jj) ) 
    1038                   zv_trd(ji,jj)  = zx1 * ( zwz(ji-1,jj  ) + zwz(ji,jj) ) 
    1039                END DO 
    1040             END DO 
    1041             ! 
    1042          CASE( np_EET , np_EEN )   ! energy & enstrophy scheme (using e3t or e3f) 
    1043             DO jj = 2, jpjm1 
    1044                DO ji = fs_2, fs_jpim1   ! vector opt. 
    1045                   zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * (  ftne(ji,jj  ) * zwy(ji  ,jj  )  & 
    1046                      &                                       + ftnw(ji+1,jj) * zwy(ji+1,jj  )  & 
    1047                      &                                       + ftse(ji,jj  ) * zwy(ji  ,jj-1)  &  
    1048                      &                                       + ftsw(ji+1,jj) * zwy(ji+1,jj-1)  ) 
    1049                   zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * (  ftsw(ji,jj+1) * zwx(ji-1,jj+1)  &  
    1050                      &                                       + ftse(ji,jj+1) * zwx(ji  ,jj+1)  & 
    1051                      &                                       + ftnw(ji,jj  ) * zwx(ji-1,jj  )  &  
    1052                      &                                       + ftne(ji,jj  ) * zwx(ji  ,jj  )  ) 
    1053                END DO 
    1054             END DO 
    1055             !  
    1056          END SELECT 
     596         ! Recall that zhU and zhV hold fluxes at jn+0.5 (extrapolated not backward interpolated) 
     597         CALL dyn_cor_2d( zhup2_e, zhvp2_e, ua_e, va_e, zhU, zhV,    zu_trd, zv_trd   ) 
    1057598         ! 
    1058599         ! Add tidal astronomical forcing if defined 
    … …  
    1060601            DO jj = 2, jpjm1 
    1061602               DO ji = fs_2, fs_jpim1   ! vector opt. 
    1062                   zu_spg = grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) 
    1063                   zv_spg = grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj) 
    1064                   zu_trd(ji,jj) = zu_trd(ji,jj) + zu_spg 
    1065                   zv_trd(ji,jj) = zv_trd(ji,jj) + zv_spg 
     603                  zu_trd(ji,jj) = zu_trd(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) 
     604                  zv_trd(ji,jj) = zv_trd(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj) 
    1066605               END DO 
    1067606            END DO 
    … …  
    1077616               END DO 
    1078617            END DO 
    1079          ENDIF  
    1080          ! 
    1081          ! Surface pressure trend: 
    1082          IF( ln_wd_il ) THEN 
    1083            DO jj = 2, jpjm1 
    1084               DO ji = 2, jpim1  
    1085                  ! Add surface pressure gradient 
    1086                  zu_spg = - grav * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj) 
    1087                  zv_spg = - grav * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj) 
    1088                  zwx(ji,jj) = (1._wp - rn_scal_load) * zu_spg * zcpx(ji,jj)  
    1089                  zwy(ji,jj) = (1._wp - rn_scal_load) * zv_spg * zcpy(ji,jj) 
    1090               END DO 
    1091            END DO 
    1092          ELSE 
    1093            DO jj = 2, jpjm1 
    1094               DO ji = fs_2, fs_jpim1   ! vector opt. 
    1095                  ! Add surface pressure gradient 
    1096                  zu_spg = - grav * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj) 
    1097                  zv_spg = - grav * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj) 
    1098                  zwx(ji,jj) = (1._wp - rn_scal_load) * zu_spg 
    1099                  zwy(ji,jj) = (1._wp - rn_scal_load) * zv_spg 
    1100               END DO 
    1101            END DO 
    1102          END IF 
    1103  
     618         ENDIF 
    1104619         ! 
    1105620         ! Set next velocities: 
     621         !     Compute barotropic speeds at step jit+1    (h : total height of the water colomn) 
     622         !--                              VECTOR FORM 
     623         !--   m+1                 m               /                                                       m+1/2           \    --! 
     624         !--  u     =             u   + delta_t' * \         (1-r)*g * grad_x( ssh') -         f * k vect u      +     frc /    --! 
     625         !--                                                                                                                    --! 
     626         !--                             FLUX FORM                                                                              --! 
     627         !--  m+1   __1__  /  m    m               /  m+1/2                             m+1/2              m+1/2    n      \ \  --! 
     628         !-- u    =   m+1 |  h  * u   + delta_t' * \ h     * (1-r)*g * grad_x( ssh') - h     * f * k vect u      + h * frc /  | --! 
     629         !--         h     \                                                                                                 /  --! 
     630         !------------------------------------------------------------------------------------------------------------------------! 
    1106631         IF( ln_dynadv_vec .OR. ln_linssh ) THEN      !* Vector form 
    1107632            DO jj = 2, jpjm1 
    1108633               DO ji = fs_2, fs_jpim1   ! vector opt. 
    1109634                  ua_e(ji,jj) = (                                 un_e(ji,jj)   &  
    1110                             &     + rdtbt * (                      zwx(ji,jj)   & 
     635                            &     + rdtbt * (                   zu_spg(ji,jj)   & 
    1111636                            &                                 + zu_trd(ji,jj)   & 
    1112637                            &                                 + zu_frc(ji,jj) ) &  
    … …  
    1114639 
    1115640                  va_e(ji,jj) = (                                 vn_e(ji,jj)   & 
    1116                             &     + rdtbt * (                      zwy(ji,jj)   & 
     641                            &     + rdtbt * (                   zv_spg(ji,jj)   & 
    1117642                            &                                 + zv_trd(ji,jj)   & 
    1118643                            &                                 + zv_frc(ji,jj) ) & 
    1119644                            &   ) * ssvmask(ji,jj) 
    1120   
    1121645               END DO 
    1122646            END DO 
    … …  
    1124648         ELSE                           !* Flux form 
    1125649            DO jj = 2, jpjm1 
    1126                DO ji = fs_2, fs_jpim1   ! vector opt. 
    1127  
    1128                   zhura = hu_0(ji,jj) + zsshu_a(ji,jj) 
    1129                   zhvra = hv_0(ji,jj) + zsshv_a(ji,jj) 
    1130  
    1131                   zhura = ssumask(ji,jj)/(zhura + 1._wp - ssumask(ji,jj)) 
    1132                   zhvra = ssvmask(ji,jj)/(zhvra + 1._wp - ssvmask(ji,jj)) 
    1133  
    1134                   ua_e(ji,jj) = (                hu_e(ji,jj)  *   un_e(ji,jj)   &  
    1135                             &     + rdtbt * ( zhust_e(ji,jj)  *    zwx(ji,jj)   &  
    1136                             &               + zhup2_e(ji,jj)  * zu_trd(ji,jj)   & 
    1137                             &               +    hu_n(ji,jj)  * zu_frc(ji,jj) ) & 
    1138                             &   ) * zhura 
    1139  
    1140                   va_e(ji,jj) = (                hv_e(ji,jj)  *   vn_e(ji,jj)   & 
    1141                             &     + rdtbt * ( zhvst_e(ji,jj)  *    zwy(ji,jj)   & 
    1142                             &               + zhvp2_e(ji,jj)  * zv_trd(ji,jj)   & 
    1143                             &               +    hv_n(ji,jj)  * zv_frc(ji,jj) ) & 
    1144                             &   ) * zhvra 
     650               DO ji = 2, jpim1 
     651                  !                    ! hu_e, hv_e hold depth at jn,  zhup2_e, zhvp2_e hold extrapolated depth at jn+1/2 
     652                  !                    ! backward interpolated depth used in spg terms at jn+1/2 
     653                  zhu_bck = hu_0(ji,jj) + r1_2*r1_e1e2u(ji,jj) * (  e1e2t(ji  ,jj) * zsshp2_e(ji  ,jj)    & 
     654                       &                                          + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj)  ) * ssumask(ji,jj) 
     655                  zhv_bck = hv_0(ji,jj) + r1_2*r1_e1e2v(ji,jj) * (  e1e2t(ji,jj  ) * zsshp2_e(ji,jj  )    & 
     656                       &                                          + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1)  ) * ssvmask(ji,jj) 
     657                  !                    ! inverse depth at jn+1 
     658                  z1_hu = ssumask(ji,jj) / ( hu_0(ji,jj) + zsshu_a(ji,jj) + 1._wp - ssumask(ji,jj) ) 
     659                  z1_hv = ssvmask(ji,jj) / ( hv_0(ji,jj) + zsshv_a(ji,jj) + 1._wp - ssvmask(ji,jj) ) 
     660                  ! 
     661                  ua_e(ji,jj) = (               hu_e  (ji,jj) *   un_e (ji,jj)      &  
     662                       &            + rdtbt * (  zhu_bck        * zu_spg (ji,jj)  &   ! 
     663                       &                       + zhup2_e(ji,jj) * zu_trd (ji,jj)  &   ! 
     664                       &                       +  hu_n  (ji,jj) * zu_frc (ji,jj)  )   ) * z1_hu 
     665                  ! 
     666                  va_e(ji,jj) = (               hv_e  (ji,jj) *   vn_e (ji,jj)      & 
     667                       &            + rdtbt * (  zhv_bck        * zv_spg (ji,jj)  &   ! 
     668                       &                       + zhvp2_e(ji,jj) * zv_trd (ji,jj)  &   ! 
     669                       &                       +  hv_n  (ji,jj) * zv_frc (ji,jj)  )   ) * z1_hv 
    1145670               END DO 
    1146671            END DO 
    … …  
    1155680            END DO 
    1156681         ENDIF 
    1157  
    1158           
    1159          IF( .NOT.ln_linssh ) THEN                     !* Update ocean depth (variable volume case only) 
    1160             hu_e (:,:) = hu_0(:,:) + zsshu_a(:,:) 
    1161             hv_e (:,:) = hv_0(:,:) + zsshv_a(:,:) 
    1162             hur_e(:,:) = ssumask(:,:) / ( hu_e(:,:) + 1._wp - ssumask(:,:) ) 
    1163             hvr_e(:,:) = ssvmask(:,:) / ( hv_e(:,:) + 1._wp - ssvmask(:,:) ) 
    1164             ! 
    1165          ENDIF 
    1166          !                                             !* domain lateral boundary 
    1167          CALL lbc_lnk_multi( 'dynspg_ts', ua_e, 'U', -1._wp, va_e , 'V', -1._wp ) 
     682        
     683         IF( .NOT.ln_linssh ) THEN   !* Update ocean depth (variable volume case only) 
     684            hu_e (2:jpim1,2:jpjm1) = hu_0(2:jpim1,2:jpjm1) + zsshu_a(2:jpim1,2:jpjm1) 
     685            hur_e(2:jpim1,2:jpjm1) = ssumask(2:jpim1,2:jpjm1) / ( hu_e(2:jpim1,2:jpjm1) + 1._wp - ssumask(2:jpim1,2:jpjm1) ) 
     686            hv_e (2:jpim1,2:jpjm1) = hv_0(2:jpim1,2:jpjm1) + zsshv_a(2:jpim1,2:jpjm1) 
     687            hvr_e(2:jpim1,2:jpjm1) = ssvmask(2:jpim1,2:jpjm1) / ( hv_e(2:jpim1,2:jpjm1) + 1._wp - ssvmask(2:jpim1,2:jpjm1) ) 
     688            CALL lbc_lnk_multi( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp  & 
     689                 &                         , hu_e , 'U', -1._wp, hv_e , 'V', -1._wp  & 
     690                 &                         , hur_e, 'U', -1._wp, hvr_e, 'V', -1._wp  ) 
     691         ELSE 
     692            CALL lbc_lnk_multi( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp  ) 
     693         ENDIF 
     694         ! 
    1168695         ! 
    1169696         !                                                 ! open boundaries 
    … …  
    1213740      ! Set advection velocity correction: 
    1214741      IF (ln_bt_fw) THEN 
    1215          zwx(:,:) = un_adv(:,:) 
    1216          zwy(:,:) = vn_adv(:,:) 
    1217742         IF( .NOT.( kt == nit000 .AND. neuler==0 ) ) THEN 
    1218             un_adv(:,:) = r1_2 * ( ub2_b(:,:) + zwx(:,:) - atfp * un_bf(:,:) ) 
    1219             vn_adv(:,:) = r1_2 * ( vb2_b(:,:) + zwy(:,:) - atfp * vn_bf(:,:) ) 
    1220             ! 
    1221             ! Update corrective fluxes for next time step: 
    1222             un_bf(:,:)  = atfp * un_bf(:,:) + (zwx(:,:) - ub2_b(:,:)) 
    1223             vn_bf(:,:)  = atfp * vn_bf(:,:) + (zwy(:,:) - vb2_b(:,:)) 
     743            DO jj = 1, jpj 
     744               DO ji = 1, jpi 
     745                  zun_save = un_adv(ji,jj) 
     746                  zvn_save = vn_adv(ji,jj) 
     747                  !                          ! apply the previously computed correction  
     748                  un_adv(ji,jj) = r1_2 * ( ub2_b(ji,jj) + zun_save - atfp * un_bf(ji,jj) ) 
     749                  vn_adv(ji,jj) = r1_2 * ( vb2_b(ji,jj) + zvn_save - atfp * vn_bf(ji,jj) ) 
     750                  !                          ! Update corrective fluxes for next time step 
     751                  un_bf(ji,jj)  = atfp * un_bf(ji,jj) + ( zun_save - ub2_b(ji,jj) ) 
     752                  vn_bf(ji,jj)  = atfp * vn_bf(ji,jj) + ( zvn_save - vb2_b(ji,jj) ) 
     753                  !                          ! Save integrated transport for next computation 
     754                  ub2_b(ji,jj) = zun_save 
     755                  vb2_b(ji,jj) = zvn_save 
     756               END DO 
     757            END DO 
    1224758         ELSE 
    1225             un_bf(:,:) = 0._wp 
    1226             vn_bf(:,:) = 0._wp  
    1227          END IF          
    1228          ! Save integrated transport for next computation 
    1229          ub2_b(:,:) = zwx(:,:) 
    1230          vb2_b(:,:) = zwy(:,:) 
     759            un_bf(:,:) = 0._wp            ! corrective fluxes for next time step set to zero 
     760            vn_bf(:,:) = 0._wp 
     761            ub2_b(:,:) = un_adv(:,:)      ! Save integrated transport for next computation 
     762            vb2_b(:,:) = vn_adv(:,:) 
     763         END IF 
    1231764      ENDIF 
    1232765 
    … …  
    14731006      REAL(wp) ::   zxr2, zyr2, zcmax   ! local scalar 
    14741007      REAL(wp), DIMENSION(jpi,jpj) ::   zcu 
     1008      INTEGER  :: inum 
    14751009      !!---------------------------------------------------------------------- 
    14761010      ! 
    … …  
    15791113   END SUBROUTINE dyn_spg_ts_init 
    15801114 
     1115    
     1116   SUBROUTINE dyn_cor_2d_init 
     1117      !!--------------------------------------------------------------------- 
     1118      !!                   ***  ROUTINE dyn_cor_2d_init  *** 
     1119      !! 
     1120      !! ** Purpose : Set time splitting options 
     1121      !! Set arrays to remove/compute coriolis trend. 
     1122      !! Do it once during initialization if volume is fixed, else at each long time step. 
     1123      !! Note that these arrays are also used during barotropic loop. These are however frozen 
     1124      !! although they should be updated in the variable volume case. Not a big approximation. 
     1125      !! To remove this approximation, copy lines below inside barotropic loop 
     1126      !! and update depths at T-F points (ht and zhf resp.) at each barotropic time step 
     1127      !! 
     1128      !! Compute zwz = f / ( height of the water colomn ) 
     1129      !!---------------------------------------------------------------------- 
     1130      INTEGER  ::   ji ,jj, jk              ! dummy loop indices 
     1131      REAL(wp) ::   z1_ht 
     1132      REAL(wp), DIMENSION(jpi,jpj) :: zhf 
     1133      !!---------------------------------------------------------------------- 
     1134      ! 
     1135      SELECT CASE( nvor_scheme ) 
     1136      CASE( np_EEN )                != EEN scheme using e3f (energy & enstrophy scheme) 
     1137         SELECT CASE( nn_een_e3f )              !* ff_f/e3 at F-point 
     1138         CASE ( 0 )                                   ! original formulation  (masked averaging of e3t divided by 4) 
     1139            DO jj = 1, jpjm1 
     1140               DO ji = 1, jpim1 
     1141                  zwz(ji,jj) =   ( ht_n(ji  ,jj+1) + ht_n(ji+1,jj+1) +                    & 
     1142                       &             ht_n(ji  ,jj  ) + ht_n(ji+1,jj  )   ) * 0.25_wp   
     1143                  IF( zwz(ji,jj) /= 0._wp )   zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 
     1144               END DO 
     1145            END DO 
     1146         CASE ( 1 )                                   ! new formulation  (masked averaging of e3t divided by the sum of mask) 
     1147            DO jj = 1, jpjm1 
     1148               DO ji = 1, jpim1 
     1149                  zwz(ji,jj) =             (  ht_n  (ji  ,jj+1) + ht_n  (ji+1,jj+1)      & 
     1150                       &                      + ht_n  (ji  ,jj  ) + ht_n  (ji+1,jj  )  )   & 
     1151                       &       / ( MAX( 1._wp,  ssmask(ji  ,jj+1) + ssmask(ji+1,jj+1)      & 
     1152                       &                      + ssmask(ji  ,jj  ) + ssmask(ji+1,jj  )  )   ) 
     1153                  IF( zwz(ji,jj) /= 0._wp )   zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 
     1154               END DO 
     1155            END DO 
     1156         END SELECT 
     1157         CALL lbc_lnk( 'dynspg_ts', zwz, 'F', 1._wp ) 
     1158         ! 
     1159         ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 
     1160         DO jj = 2, jpj 
     1161            DO ji = 2, jpi 
     1162               ftne(ji,jj) = zwz(ji-1,jj  ) + zwz(ji  ,jj  ) + zwz(ji  ,jj-1) 
     1163               ftnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj  ) + zwz(ji  ,jj  ) 
     1164               ftse(ji,jj) = zwz(ji  ,jj  ) + zwz(ji  ,jj-1) + zwz(ji-1,jj-1) 
     1165               ftsw(ji,jj) = zwz(ji  ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj  ) 
     1166            END DO 
     1167         END DO 
     1168         ! 
     1169      CASE( np_EET )                  != EEN scheme using e3t (energy conserving scheme) 
     1170         ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 
     1171         DO jj = 2, jpj 
     1172            DO ji = 2, jpi 
     1173               z1_ht = ssmask(ji,jj) / ( ht_n(ji,jj) + 1._wp - ssmask(ji,jj) ) 
     1174               ftne(ji,jj) = ( ff_f(ji-1,jj  ) + ff_f(ji  ,jj  ) + ff_f(ji  ,jj-1) ) * z1_ht 
     1175               ftnw(ji,jj) = ( ff_f(ji-1,jj-1) + ff_f(ji-1,jj  ) + ff_f(ji  ,jj  ) ) * z1_ht 
     1176               ftse(ji,jj) = ( ff_f(ji  ,jj  ) + ff_f(ji  ,jj-1) + ff_f(ji-1,jj-1) ) * z1_ht 
     1177               ftsw(ji,jj) = ( ff_f(ji  ,jj-1) + ff_f(ji-1,jj-1) + ff_f(ji-1,jj  ) ) * z1_ht 
     1178            END DO 
     1179         END DO 
     1180         ! 
     1181      CASE( np_ENE, np_ENS , np_MIX )  != all other schemes (ENE, ENS, MIX) except ENT ! 
     1182         ! 
     1183         zwz(:,:) = 0._wp 
     1184         zhf(:,:) = 0._wp 
     1185          
     1186         !!gm  assume 0 in both cases (which is almost surely WRONG ! ) as hvatf has been removed  
     1187!!gm    A priori a better value should be something like : 
     1188!!gm          zhf(i,j) = masked sum of  ht(i,j) , ht(i+1,j) , ht(i,j+1) , (i+1,j+1)  
     1189!!gm                     divided by the sum of the corresponding mask  
     1190!!gm  
     1191!!             
     1192         IF( .NOT.ln_sco ) THEN 
     1193   
     1194   !!gm  agree the JC comment  : this should be done in a much clear way 
     1195   
     1196   ! JC: It not clear yet what should be the depth at f-points over land in z-coordinate case 
     1197   !     Set it to zero for the time being  
     1198   !              IF( rn_hmin < 0._wp ) THEN    ;   jk = - INT( rn_hmin )                                      ! from a nb of level 
     1199   !              ELSE                          ;   jk = MINLOC( gdepw_0, mask = gdepw_0 > rn_hmin, dim = 1 )  ! from a depth 
     1200   !              ENDIF 
     1201   !              zhf(:,:) = gdepw_0(:,:,jk+1) 
     1202            ! 
     1203         ELSE 
     1204            ! 
     1205            !zhf(:,:) = hbatf(:,:) 
     1206            DO jj = 1, jpjm1 
     1207               DO ji = 1, jpim1 
     1208                  zhf(ji,jj) =    (   ht_0  (ji,jj  ) + ht_0  (ji+1,jj  )          & 
     1209                       &            + ht_0  (ji,jj+1) + ht_0  (ji+1,jj+1)   )      & 
     1210                       &     / MAX(   ssmask(ji,jj  ) + ssmask(ji+1,jj  )          & 
     1211                       &            + ssmask(ji,jj+1) + ssmask(ji+1,jj+1) , 1._wp  ) 
     1212               END DO 
     1213            END DO 
     1214         ENDIF 
     1215         ! 
     1216         DO jj = 1, jpjm1 
     1217            zhf(:,jj) = zhf(:,jj) * (1._wp- umask(:,jj,1) * umask(:,jj+1,1)) 
     1218         END DO 
     1219         ! 
     1220         DO jk = 1, jpkm1 
     1221            DO jj = 1, jpjm1 
     1222               zhf(:,jj) = zhf(:,jj) + e3f_n(:,jj,jk) * umask(:,jj,jk) * umask(:,jj+1,jk) 
     1223            END DO 
     1224         END DO 
     1225         CALL lbc_lnk( 'dynspg_ts', zhf, 'F', 1._wp ) 
     1226         ! JC: TBC. hf should be greater than 0  
     1227         DO jj = 1, jpj 
     1228            DO ji = 1, jpi 
     1229               IF( zhf(ji,jj) /= 0._wp )   zwz(ji,jj) = 1._wp / zhf(ji,jj) 
     1230            END DO 
     1231         END DO 
     1232         zwz(:,:) = ff_f(:,:) * zwz(:,:) 
     1233      END SELECT 
     1234       
     1235   END SUBROUTINE dyn_cor_2d_init 
     1236 
     1237 
     1238 
     1239   SUBROUTINE dyn_cor_2d( hu_n, hv_n, un_b, vn_b, zhU, zhV,    zu_trd, zv_trd   ) 
     1240      !!--------------------------------------------------------------------- 
     1241      !!                   ***  ROUTINE dyn_cor_2d  *** 
     1242      !! 
     1243      !! ** Purpose : Compute u and v coriolis trends 
     1244      !!---------------------------------------------------------------------- 
     1245      INTEGER  ::   ji ,jj                             ! dummy loop indices 
     1246      REAL(wp) ::   zx1, zx2, zy1, zy2, z1_hu, z1_hv   !   -      - 
     1247      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: hu_n, hv_n, un_b, vn_b, zhU, zhV 
     1248      REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) :: zu_trd, zv_trd 
     1249      !!---------------------------------------------------------------------- 
     1250      SELECT CASE( nvor_scheme ) 
     1251      CASE( np_ENT )                ! enstrophy conserving scheme (f-point) 
     1252         DO jj = 2, jpjm1 
     1253            DO ji = 2, jpim1 
     1254               z1_hu = ssumask(ji,jj) / ( hu_n(ji,jj) + 1._wp - ssumask(ji,jj) ) 
     1255               z1_hv = ssvmask(ji,jj) / ( hv_n(ji,jj) + 1._wp - ssvmask(ji,jj) ) 
     1256               zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * z1_hu                    & 
     1257                  &               * (  e1e2t(ji+1,jj)*ht_n(ji+1,jj)*ff_t(ji+1,jj) * ( vn_b(ji+1,jj) + vn_b(ji+1,jj-1) )   & 
     1258                  &                  + e1e2t(ji  ,jj)*ht_n(ji  ,jj)*ff_t(ji  ,jj) * ( vn_b(ji  ,jj) + vn_b(ji  ,jj-1) )   ) 
     1259                  ! 
     1260               zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * z1_hv                    & 
     1261                  &               * (  e1e2t(ji,jj+1)*ht_n(ji,jj+1)*ff_t(ji,jj+1) * ( un_b(ji,jj+1) + un_b(ji-1,jj+1) )   &  
     1262                  &                  + e1e2t(ji,jj  )*ht_n(ji,jj  )*ff_t(ji,jj  ) * ( un_b(ji,jj  ) + un_b(ji-1,jj  ) )   )  
     1263            END DO   
     1264         END DO   
     1265         !          
     1266      CASE( np_ENE , np_MIX )        ! energy conserving scheme (t-point) ENE or MIX 
     1267         DO jj = 2, jpjm1 
     1268            DO ji = fs_2, fs_jpim1   ! vector opt. 
     1269               zy1 = ( zhV(ji,jj-1) + zhV(ji+1,jj-1) ) * r1_e1u(ji,jj) 
     1270               zy2 = ( zhV(ji,jj  ) + zhV(ji+1,jj  ) ) * r1_e1u(ji,jj) 
     1271               zx1 = ( zhU(ji-1,jj) + zhU(ji-1,jj+1) ) * r1_e2v(ji,jj) 
     1272               zx2 = ( zhU(ji  ,jj) + zhU(ji  ,jj+1) ) * r1_e2v(ji,jj) 
     1273               ! energy conserving formulation for planetary vorticity term 
     1274               zu_trd(ji,jj) =   r1_4 * ( zwz(ji  ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 
     1275               zv_trd(ji,jj) = - r1_4 * ( zwz(ji-1,jj  ) * zx1 + zwz(ji,jj) * zx2 ) 
     1276            END DO 
     1277         END DO 
     1278         ! 
     1279      CASE( np_ENS )                ! enstrophy conserving scheme (f-point) 
     1280         DO jj = 2, jpjm1 
     1281            DO ji = fs_2, fs_jpim1   ! vector opt. 
     1282               zy1 =   r1_8 * ( zhV(ji  ,jj-1) + zhV(ji+1,jj-1) & 
     1283                 &            + zhV(ji  ,jj  ) + zhV(ji+1,jj  ) ) * r1_e1u(ji,jj) 
     1284               zx1 = - r1_8 * ( zhU(ji-1,jj  ) + zhU(ji-1,jj+1) & 
     1285                 &            + zhU(ji  ,jj  ) + zhU(ji  ,jj+1) ) * r1_e2v(ji,jj) 
     1286               zu_trd(ji,jj)  = zy1 * ( zwz(ji  ,jj-1) + zwz(ji,jj) ) 
     1287               zv_trd(ji,jj)  = zx1 * ( zwz(ji-1,jj  ) + zwz(ji,jj) ) 
     1288            END DO 
     1289         END DO 
     1290         ! 
     1291      CASE( np_EET , np_EEN )      ! energy & enstrophy scheme (using e3t or e3f)          
     1292         DO jj = 2, jpjm1 
     1293            DO ji = fs_2, fs_jpim1   ! vector opt. 
     1294               zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * (  ftne(ji,jj  ) * zhV(ji  ,jj  ) & 
     1295                &                                         + ftnw(ji+1,jj) * zhV(ji+1,jj  ) & 
     1296                &                                         + ftse(ji,jj  ) * zhV(ji  ,jj-1) & 
     1297                &                                         + ftsw(ji+1,jj) * zhV(ji+1,jj-1) ) 
     1298               zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * (  ftsw(ji,jj+1) * zhU(ji-1,jj+1) & 
     1299                &                                         + ftse(ji,jj+1) * zhU(ji  ,jj+1) & 
     1300                &                                         + ftnw(ji,jj  ) * zhU(ji-1,jj  ) & 
     1301                &                                         + ftne(ji,jj  ) * zhU(ji  ,jj  ) ) 
     1302            END DO 
     1303         END DO 
     1304         ! 
     1305      END SELECT 
     1306      ! 
     1307   END SUBROUTINE dyn_cor_2D 
     1308 
     1309 
     1310   SUBROUTINE wad_tmsk( pssh, ptmsk ) 
     1311      !!---------------------------------------------------------------------- 
     1312      !!                  ***  ROUTINE wad_lmt  *** 
     1313      !!                     
     1314      !! ** Purpose :   set wetting & drying mask at tracer points  
     1315      !!              for the current barotropic sub-step  
     1316      !! 
     1317      !! ** Method  :   ???  
     1318      !! 
     1319      !! ** Action  :  ptmsk : wetting & drying t-mask 
     1320      !!---------------------------------------------------------------------- 
     1321      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   pssh    ! 
     1322      REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) ::   ptmsk   ! 
     1323      ! 
     1324      INTEGER  ::   ji, jj   ! dummy loop indices 
     1325      !!---------------------------------------------------------------------- 
     1326      ! 
     1327      IF( ln_wd_dl_rmp ) THEN      
     1328         DO jj = 1, jpj 
     1329            DO ji = 1, jpi                     
     1330               IF    ( pssh(ji,jj) + ht_0(ji,jj) >  2._wp * rn_wdmin1 ) THEN  
     1331                  !           IF    ( pssh(ji,jj) + ht_0(ji,jj) >          rn_wdmin2 ) THEN  
     1332                  ptmsk(ji,jj) = 1._wp 
     1333               ELSEIF( pssh(ji,jj) + ht_0(ji,jj) >          rn_wdmin1 ) THEN 
     1334                  ptmsk(ji,jj) = TANH( 50._wp*( ( pssh(ji,jj) + ht_0(ji,jj) -  rn_wdmin1 )*r_rn_wdmin1) ) 
     1335               ELSE  
     1336                  ptmsk(ji,jj) = 0._wp 
     1337               ENDIF 
     1338            END DO 
     1339         END DO 
     1340      ELSE   
     1341         DO jj = 1, jpj 
     1342            DO ji = 1, jpi                               
     1343               IF ( pssh(ji,jj) + ht_0(ji,jj) >  rn_wdmin1 ) THEN   ;   ptmsk(ji,jj) = 1._wp 
     1344               ELSE                                                 ;   ptmsk(ji,jj) = 0._wp 
     1345               ENDIF 
     1346            END DO 
     1347         END DO 
     1348      ENDIF 
     1349      ! 
     1350   END SUBROUTINE wad_tmsk 
     1351 
     1352 
     1353   SUBROUTINE wad_Umsk( pTmsk, phU, phV, pu, pv, pUmsk, pVmsk ) 
     1354      !!---------------------------------------------------------------------- 
     1355      !!                  ***  ROUTINE wad_lmt  *** 
     1356      !!                     
     1357      !! ** Purpose :   set wetting & drying mask at tracer points  
     1358      !!              for the current barotropic sub-step  
     1359      !! 
     1360      !! ** Method  :   ???  
     1361      !! 
     1362      !! ** Action  :  ptmsk : wetting & drying t-mask 
     1363      !!---------------------------------------------------------------------- 
     1364      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   pTmsk              ! W & D t-mask 
     1365      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   phU, phV, pu, pv   ! ocean velocities and transports 
     1366      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pUmsk, pVmsk       ! W & D u- and v-mask 
     1367      ! 
     1368      INTEGER  ::   ji, jj   ! dummy loop indices 
     1369      !!---------------------------------------------------------------------- 
     1370      ! 
     1371      DO jj = 1, jpj 
     1372         DO ji = 1, jpim1   ! not jpi-column 
     1373            IF ( phU(ji,jj) > 0._wp ) THEN   ;   pUmsk(ji,jj) = pTmsk(ji  ,jj)  
     1374            ELSE                             ;   pUmsk(ji,jj) = pTmsk(ji+1,jj)   
     1375            ENDIF 
     1376            phU(ji,jj) = pUmsk(ji,jj)*phU(ji,jj) 
     1377            pu (ji,jj) = pUmsk(ji,jj)*pu (ji,jj) 
     1378         END DO 
     1379      END DO 
     1380      ! 
     1381      DO jj = 1, jpjm1   ! not jpj-row 
     1382         DO ji = 1, jpi 
     1383            IF ( phV(ji,jj) > 0._wp ) THEN   ;   pVmsk(ji,jj) = pTmsk(ji,jj  ) 
     1384            ELSE                             ;   pVmsk(ji,jj) = pTmsk(ji,jj+1)   
     1385            ENDIF 
     1386            phV(ji,jj) = pVmsk(ji,jj)*phV(ji,jj)  
     1387            pv (ji,jj) = pVmsk(ji,jj)*pv (ji,jj) 
     1388         END DO 
     1389      END DO 
     1390      ! 
     1391   END SUBROUTINE wad_Umsk 
     1392 
     1393 
     1394   SUBROUTINE wad_spg( sshn, zcpx, zcpy ) 
     1395      !!--------------------------------------------------------------------- 
     1396      !!                   ***  ROUTINE  wad_sp  *** 
     1397      !! 
     1398      !! ** Purpose :  
     1399      !!---------------------------------------------------------------------- 
     1400      INTEGER  ::   ji ,jj               ! dummy loop indices 
     1401      LOGICAL  ::   ll_tmp1, ll_tmp2 
     1402      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: sshn 
     1403      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: zcpx, zcpy 
     1404      !!---------------------------------------------------------------------- 
     1405      DO jj = 2, jpjm1 
     1406         DO ji = 2, jpim1  
     1407            ll_tmp1 = MIN(  sshn(ji,jj)               ,  sshn(ji+1,jj) ) >                & 
     1408                 &      MAX( -ht_0(ji,jj)               , -ht_0(ji+1,jj) ) .AND.            & 
     1409                 &      MAX(  sshn(ji,jj) + ht_0(ji,jj) ,  sshn(ji+1,jj) + ht_0(ji+1,jj) )  & 
     1410                 &                                                         > rn_wdmin1 + rn_wdmin2 
     1411            ll_tmp2 = ( ABS( sshn(ji+1,jj)            -  sshn(ji  ,jj))  > 1.E-12 ).AND.( & 
     1412                 &      MAX(   sshn(ji,jj)              ,  sshn(ji+1,jj) ) >                & 
     1413                 &      MAX(  -ht_0(ji,jj)              , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 
     1414            IF(ll_tmp1) THEN 
     1415               zcpx(ji,jj) = 1.0_wp 
     1416            ELSEIF(ll_tmp2) THEN 
     1417               ! no worries about  sshn(ji+1,jj) -  sshn(ji  ,jj) = 0, it won't happen ! here 
     1418               zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_0(ji+1,jj) - sshn(ji,jj) - ht_0(ji,jj)) & 
     1419                    &    / (sshn(ji+1,jj) - sshn(ji  ,jj)) ) 
     1420               zcpx(ji,jj) = max(min( zcpx(ji,jj) , 1.0_wp),0.0_wp) 
     1421            ELSE 
     1422               zcpx(ji,jj) = 0._wp 
     1423            ENDIF 
     1424            ! 
     1425            ll_tmp1 = MIN(  sshn(ji,jj)               ,  sshn(ji,jj+1) ) >                & 
     1426                 &      MAX( -ht_0(ji,jj)               , -ht_0(ji,jj+1) ) .AND.            & 
     1427                 &      MAX(  sshn(ji,jj) + ht_0(ji,jj) ,  sshn(ji,jj+1) + ht_0(ji,jj+1) )  & 
     1428                 &                                                       > rn_wdmin1 + rn_wdmin2 
     1429            ll_tmp2 = ( ABS( sshn(ji,jj)              -  sshn(ji,jj+1))  > 1.E-12 ).AND.( & 
     1430                 &      MAX(   sshn(ji,jj)              ,  sshn(ji,jj+1) ) >                & 
     1431                 &      MAX(  -ht_0(ji,jj)              , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 
     1432             
     1433            IF(ll_tmp1) THEN 
     1434               zcpy(ji,jj) = 1.0_wp 
     1435            ELSE IF(ll_tmp2) THEN 
     1436               ! no worries about  sshn(ji,jj+1) -  sshn(ji,jj  ) = 0, it won't happen ! here 
     1437               zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_0(ji,jj+1) - sshn(ji,jj) - ht_0(ji,jj)) & 
     1438                    &             / (sshn(ji,jj+1) - sshn(ji,jj  )) ) 
     1439               zcpy(ji,jj) = MAX(  0._wp , MIN( zcpy(ji,jj) , 1.0_wp )  ) 
     1440            ELSE 
     1441               zcpy(ji,jj) = 0._wp 
     1442            ENDIF 
     1443         END DO 
     1444      END DO 
     1445             
     1446   END SUBROUTINE wad_spg 
     1447      
     1448 
     1449 
     1450   SUBROUTINE dyn_drg_init( pu_RHSi, pv_RHSi, pCdU_u, pCdU_v ) 
     1451      !!---------------------------------------------------------------------- 
     1452      !!                  ***  ROUTINE dyn_drg_init  *** 
     1453      !!                     
     1454      !! ** Purpose : - add the baroclinic top/bottom drag contribution to  
     1455      !!              the baroclinic part of the barotropic RHS 
     1456      !!              - compute the barotropic drag coefficients 
     1457      !! 
     1458      !! ** Method  :   computation done over the INNER domain only  
     1459      !!---------------------------------------------------------------------- 
     1460      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pu_RHSi, pv_RHSi   ! baroclinic part of the barotropic RHS 
     1461      REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) ::   pCdU_u , pCdU_v    ! barotropic drag coefficients 
     1462      ! 
     1463      INTEGER  ::   ji, jj   ! dummy loop indices 
     1464      INTEGER  ::   ikbu, ikbv, iktu, iktv 
     1465      REAL(wp) ::   zztmp 
     1466      REAL(wp), DIMENSION(jpi,jpj) ::   zu_i, zv_i 
     1467      !!---------------------------------------------------------------------- 
     1468      ! 
     1469      !                    !==  Set the barotropic drag coef.  ==! 
     1470      ! 
     1471      IF( ln_isfcav ) THEN          ! top+bottom friction (ocean cavities) 
     1472          
     1473         DO jj = 2, jpjm1 
     1474            DO ji = 2, jpim1     ! INNER domain 
     1475               pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) + rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) 
     1476               pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) + rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) 
     1477            END DO 
     1478         END DO 
     1479      ELSE                          ! bottom friction only 
     1480         DO jj = 2, jpjm1 
     1481            DO ji = 2, jpim1  ! INNER domain 
     1482               pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) 
     1483               pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) 
     1484            END DO 
     1485         END DO 
     1486      ENDIF 
     1487      ! 
     1488      !                    !==  BOTTOM stress contribution from baroclinic velocities  ==! 
     1489      ! 
     1490      IF( ln_bt_fw ) THEN                 ! FORWARD integration: use NOW bottom baroclinic velocities 
     1491          
     1492         DO jj = 2, jpjm1 
     1493            DO ji = 2, jpim1  ! INNER domain 
     1494               ikbu = mbku(ji,jj)        
     1495               ikbv = mbkv(ji,jj)     
     1496               zu_i(ji,jj) = un(ji,jj,ikbu) - un_b(ji,jj) 
     1497               zv_i(ji,jj) = vn(ji,jj,ikbv) - vn_b(ji,jj) 
     1498            END DO 
     1499         END DO 
     1500      ELSE                                ! CENTRED integration: use BEFORE bottom baroclinic velocities 
     1501          
     1502         DO jj = 2, jpjm1 
     1503            DO ji = 2, jpim1   ! INNER domain 
     1504               ikbu = mbku(ji,jj)        
     1505               ikbv = mbkv(ji,jj)     
     1506               zu_i(ji,jj) = ub(ji,jj,ikbu) - ub_b(ji,jj) 
     1507               zv_i(ji,jj) = vb(ji,jj,ikbv) - vb_b(ji,jj) 
     1508            END DO 
     1509         END DO 
     1510      ENDIF 
     1511      ! 
     1512      IF( ln_wd_il ) THEN      ! W/D : use the "clipped" bottom friction   !!gm   explain WHY, please ! 
     1513         zztmp = -1._wp / rdtbt 
     1514         DO jj = 2, jpjm1 
     1515            DO ji = 2, jpim1    ! INNER domain 
     1516               pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + zu_i(ji,jj) *  wdrampu(ji,jj) * MAX(                                 &  
     1517                    &                              r1_hu_n(ji,jj) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) , zztmp  ) 
     1518               pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + zv_i(ji,jj) *  wdrampv(ji,jj) * MAX(                                 &  
     1519                    &                              r1_hv_n(ji,jj) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) , zztmp  ) 
     1520            END DO 
     1521         END DO 
     1522      ELSE                    ! use "unclipped" drag (even if explicit friction is used in 3D calculation) 
     1523          
     1524         DO jj = 2, jpjm1 
     1525            DO ji = 2, jpim1    ! INNER domain 
     1526               pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu_n(ji,jj) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * zu_i(ji,jj) 
     1527               pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv_n(ji,jj) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * zv_i(ji,jj) 
     1528            END DO 
     1529         END DO 
     1530      END IF 
     1531      ! 
     1532      !                    !==  TOP stress contribution from baroclinic velocities  ==!   (no W/D case) 
     1533      ! 
     1534      IF( ln_isfcav ) THEN 
     1535         ! 
     1536         IF( ln_bt_fw ) THEN                ! FORWARD integration: use NOW top baroclinic velocity 
     1537             
     1538            DO jj = 2, jpjm1 
     1539               DO ji = 2, jpim1   ! INNER domain 
     1540                  iktu = miku(ji,jj) 
     1541                  iktv = mikv(ji,jj) 
     1542                  zu_i(ji,jj) = un(ji,jj,iktu) - un_b(ji,jj) 
     1543                  zv_i(ji,jj) = vn(ji,jj,iktv) - vn_b(ji,jj) 
     1544               END DO 
     1545            END DO 
     1546         ELSE                                ! CENTRED integration: use BEFORE top baroclinic velocity 
     1547             
     1548            DO jj = 2, jpjm1 
     1549               DO ji = 2, jpim1      ! INNER domain 
     1550                  iktu = miku(ji,jj) 
     1551                  iktv = mikv(ji,jj) 
     1552                  zu_i(ji,jj) = ub(ji,jj,iktu) - ub_b(ji,jj) 
     1553                  zv_i(ji,jj) = vb(ji,jj,iktv) - vb_b(ji,jj) 
     1554               END DO 
     1555            END DO 
     1556         ENDIF 
     1557         ! 
     1558         !                    ! use "unclipped" top drag (even if explicit friction is used in 3D calculation) 
     1559          
     1560         DO jj = 2, jpjm1 
     1561            DO ji = 2, jpim1    ! INNER domain 
     1562               pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu_n(ji,jj) * r1_2*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * zu_i(ji,jj) 
     1563               pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv_n(ji,jj) * r1_2*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * zv_i(ji,jj) 
     1564            END DO 
     1565         END DO 
     1566         ! 
     1567      ENDIF 
     1568      ! 
     1569   END SUBROUTINE dyn_drg_init 
     1570 
     1571   SUBROUTINE ts_bck_interp( jn, ll_init,       &   ! <== in 
     1572      &                      za0, za1, za2, za3 )   ! ==> out 
     1573      !!---------------------------------------------------------------------- 
     1574      INTEGER ,INTENT(in   ) ::   jn                   ! index of sub time step 
     1575      LOGICAL ,INTENT(in   ) ::   ll_init              ! 
     1576      REAL(wp),INTENT(  out) ::   za0, za1, za2, za3   ! Half-step back interpolation coefficient 
     1577      ! 
     1578      REAL(wp) ::   zepsilon, zgamma                   !   -      - 
     1579      !!---------------------------------------------------------------------- 
     1580      !                             ! set Half-step back interpolation coefficient 
     1581      IF    ( jn==1 .AND. ll_init ) THEN   !* Forward-backward 
     1582         za0 = 1._wp                         
     1583         za1 = 0._wp                            
     1584         za2 = 0._wp 
     1585         za3 = 0._wp 
     1586      ELSEIF( jn==2 .AND. ll_init ) THEN   !* AB2-AM3 Coefficients; bet=0 ; gam=-1/6 ; eps=1/12 
     1587         za0 = 1.0833333333333_wp                 ! za0 = 1-gam-eps 
     1588         za1 =-0.1666666666666_wp                 ! za1 = gam 
     1589         za2 = 0.0833333333333_wp                 ! za2 = eps 
     1590         za3 = 0._wp               
     1591      ELSE                                 !* AB3-AM4 Coefficients; bet=0.281105 ; eps=0.013 ; gam=0.0880  
     1592         IF( rn_bt_alpha == 0._wp ) THEN      ! Time diffusion   
     1593            za0 = 0.614_wp                        ! za0 = 1/2 +   gam + 2*eps 
     1594            za1 = 0.285_wp                        ! za1 = 1/2 - 2*gam - 3*eps 
     1595            za2 = 0.088_wp                        ! za2 = gam 
     1596            za3 = 0.013_wp                        ! za3 = eps 
     1597         ELSE                                 ! no time diffusion 
     1598            zepsilon = 0.00976186_wp - 0.13451357_wp * rn_bt_alpha 
     1599            zgamma   = 0.08344500_wp - 0.51358400_wp * rn_bt_alpha 
     1600            za0 = 0.5_wp + zgamma + 2._wp * rn_bt_alpha + 2._wp * zepsilon 
     1601            za1 = 1._wp - za0 - zgamma - zepsilon 
     1602            za2 = zgamma 
     1603            za3 = zepsilon 
     1604         ENDIF  
     1605      ENDIF 
     1606   END SUBROUTINE ts_bck_interp 
     1607 
     1608 
    15811609   !!====================================================================== 
    15821610END MODULE dynspg_ts 

  • NEMO/trunk/src/OCE/DYN/dynvor.F90

    r10425 r11536  
    851851      REWIND( numnam_ref )              ! Namelist namdyn_vor in reference namelist : Vorticity scheme options 
    852852      READ  ( numnam_ref, namdyn_vor, IOSTAT = ios, ERR = 901) 
    853 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_vor in reference namelist', lwp ) 
     853901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_vor in reference namelist' ) 
    854854      REWIND( numnam_cfg )              ! Namelist namdyn_vor in configuration namelist : Vorticity scheme options 
    855855      READ  ( numnam_cfg, namdyn_vor, IOSTAT = ios, ERR = 902 ) 
    856 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_vor in configuration namelist', lwp ) 
     856902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_vor in configuration namelist' ) 
    857857      IF(lwm) WRITE ( numond, namdyn_vor ) 
    858858      ! 

  • NEMO/trunk/src/OCE/DYN/wet_dry.F90

    r10499 r11536  
    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/trunk/src/OCE/FLO/flo4rk.F90

    r10068 r11536  
    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 
    … …  
    445443   END SUBROUTINE flo_interp 
    446444 
    447 #  else 
    448    !!---------------------------------------------------------------------- 
    449    !!   No floats                                              Dummy module 
    450    !!---------------------------------------------------------------------- 
    451 #endif 
    452     
    453445   !!====================================================================== 
    454446END MODULE flo4rk 

  • NEMO/trunk/src/OCE/FLO/flo_oce.F90

    r10425 r11536  
    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/trunk/src/OCE/FLO/floats.F90

    r10068 r11536  
    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   !!---------------------------------------------------------------------- 
    … …  
    8179      INTEGER ::   ios                 ! Local integer output status for namelist read 
    8280      ! 
    83       NAMELIST/namflo/ jpnfl, jpnnewflo, ln_rstflo, nn_writefl, nn_stockfl, ln_argo, ln_flork4, ln_ariane, ln_flo_ascii 
     81      NAMELIST/namflo/ ln_floats, jpnfl, jpnnewflo, ln_rstflo, nn_writefl, nn_stockfl, ln_argo, ln_flork4, ln_ariane, ln_flo_ascii 
    8482      !!--------------------------------------------------------------------- 
    8583      ! 
    … …  
    9088      REWIND( numnam_ref )              ! Namelist namflo in reference namelist : Floats 
    9189      READ  ( numnam_ref, namflo, IOSTAT = ios, ERR = 901) 
    92 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namflo in reference namelist', lwp ) 
     90901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namflo in reference namelist' ) 
    9391 
    9492      REWIND( numnam_cfg )              ! Namelist namflo in configuration namelist : Floats 
    9593      READ  ( numnam_cfg, namflo, IOSTAT = ios, ERR = 902 ) 
    96 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namflo in configuration namelist', lwp ) 
     94902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namflo in configuration namelist' ) 
    9795      IF(lwm) WRITE ( numond, namflo ) 
    9896      ! 
    … …  
    10098         WRITE(numout,*) 
    10199         WRITE(numout,*) '         Namelist floats :' 
    102          WRITE(numout,*) '            number of floats                      jpnfl        = ', jpnfl 
    103          WRITE(numout,*) '            number of new floats                  jpnflnewflo  = ', jpnnewflo 
    104          WRITE(numout,*) '            restart                               ln_rstflo    = ', ln_rstflo 
    105          WRITE(numout,*) '            frequency of float output file        nn_writefl   = ', nn_writefl 
    106          WRITE(numout,*) '            frequency of float restart file       nn_stockfl   = ', nn_stockfl 
    107          WRITE(numout,*) '            Argo type floats                      ln_argo      = ', ln_argo 
    108          WRITE(numout,*) '            Computation of T trajectories         ln_flork4    = ', ln_flork4 
    109          WRITE(numout,*) '            Use of ariane convention              ln_ariane    = ', ln_ariane 
    110          WRITE(numout,*) '            ascii output (T) or netcdf output (F) ln_flo_ascii = ', ln_flo_ascii 
     100         WRITE(numout,*) '            Activate floats or not                   ln_floats    = ', ln_floats 
     101         WRITE(numout,*) '               number of floats                      jpnfl        = ', jpnfl 
     102         WRITE(numout,*) '               number of new floats                  jpnflnewflo  = ', jpnnewflo 
     103         WRITE(numout,*) '               restart                               ln_rstflo    = ', ln_rstflo 
     104         WRITE(numout,*) '               frequency of float output file        nn_writefl   = ', nn_writefl 
     105         WRITE(numout,*) '               frequency of float restart file       nn_stockfl   = ', nn_stockfl 
     106         WRITE(numout,*) '               Argo type floats                      ln_argo      = ', ln_argo 
     107         WRITE(numout,*) '               Computation of T trajectories         ln_flork4    = ', ln_flork4 
     108         WRITE(numout,*) '               Use of ariane convention              ln_ariane    = ', ln_ariane 
     109         WRITE(numout,*) '               ascii output (T) or netcdf output (F) ln_flo_ascii = ', ln_flo_ascii 
    111110 
    112111      ENDIF 
    113112      ! 
    114       !                             ! allocate floats arrays 
    115       IF( flo_oce_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'flo_init : unable to allocate arrays' ) 
    116       ! 
    117       !                             ! allocate flodom arrays 
    118       IF( flo_dom_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'flo_dom : unable to allocate arrays' ) 
    119       ! 
    120       !                             ! allocate flowri arrays 
    121       IF( flo_wri_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'flo_wri : unable to allocate arrays' ) 
    122       ! 
    123       !                             ! allocate florst arrays 
    124       IF( flo_rst_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'flo_rst : unable to allocate arrays' ) 
    125       ! 
    126       jpnrstflo = jpnfl-jpnnewflo   ! memory allocation  
    127       ! 
    128       DO jfl = 1, jpnfl             ! vertical axe for netcdf IOM ouput 
    129          nfloat(jfl) = jfl  
    130       END DO 
    131       ! 
    132       CALL flo_dom                  ! compute/read initial position of floats 
    133       ! 
    134       wb(:,:,:) = wn(:,:,:)         ! set wb for computation of floats trajectories at the first time step 
     113      IF( ln_floats ) THEN 
     114         !                             ! allocate floats arrays 
     115         IF( flo_oce_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'flo_init : unable to allocate arrays' ) 
     116         ! 
     117         !                             ! allocate flodom arrays 
     118         IF( flo_dom_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'flo_dom : unable to allocate arrays' ) 
     119         ! 
     120         !                             ! allocate flowri arrays 
     121         IF( flo_wri_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'flo_wri : unable to allocate arrays' ) 
     122         ! 
     123         !                             ! allocate florst arrays 
     124         IF( flo_rst_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'flo_rst : unable to allocate arrays' ) 
     125         ! 
     126         jpnrstflo = jpnfl-jpnnewflo   ! memory allocation  
     127         ! 
     128         DO jfl = 1, jpnfl             ! vertical axe for netcdf IOM ouput 
     129            nfloat(jfl) = jfl  
     130         END DO 
     131         ! 
     132         CALL flo_dom                  ! compute/read initial position of floats 
     133         ! 
     134         wb(:,:,:) = wn(:,:,:)         ! set wb for computation of floats trajectories at the first time step 
     135         ! 
     136      ENDIF 
    135137      ! 
    136138   END SUBROUTINE flo_init 
    137139 
    138 #  else 
    139    !!---------------------------------------------------------------------- 
    140    !!   Default option :                                       Empty module 
    141    !!---------------------------------------------------------------------- 
    142 CONTAINS 
    143    SUBROUTINE flo_stp( kt )          ! Empty routine 
    144       IMPLICIT NONE 
    145       INTEGER, INTENT( in ) :: kt 
    146       WRITE(*,*) 'flo_stp: You should not have seen this print! error?', kt 
    147    END SUBROUTINE flo_stp 
    148    SUBROUTINE flo_init          ! Empty routine 
    149       IMPLICIT NONE 
    150    END SUBROUTINE flo_init 
    151 #endif 
    152  
    153140   !!====================================================================== 
    154141 END MODULE floats 

  • NEMO/trunk/src/OCE/FLO/floblk.F90

    r10425 r11536  
    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 
    … …  
    369367   END SUBROUTINE flo_blk 
    370368 
    371 #  else 
    372    !!---------------------------------------------------------------------- 
    373    !!   Default option                                         Empty module 
    374    !!---------------------------------------------------------------------- 
    375 CONTAINS 
    376    SUBROUTINE flo_blk                  ! Empty routine 
    377    END SUBROUTINE flo_blk  
    378 #endif 
    379     
    380369   !!====================================================================== 
    381370END MODULE floblk  

  • NEMO/trunk/src/OCE/FLO/flodom.F90

    r10425 r11536  
    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 
    … …  
    455451   END FUNCTION flo_dom_alloc 
    456452 
    457  
    458 #else 
    459    !!---------------------------------------------------------------------- 
    460    !!   Default option                                         Empty module 
    461    !!---------------------------------------------------------------------- 
    462 CONTAINS 
    463    SUBROUTINE flo_dom                 ! Empty routine 
    464          WRITE(*,*) 'flo_dom: : You should not have seen this print! error?' 
    465    END SUBROUTINE flo_dom 
    466 #endif 
    467  
    468453   !!====================================================================== 
    469454END MODULE flodom 

  • NEMO/trunk/src/OCE/FLO/florst.F90

    r10425 r11536  
    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/trunk/src/OCE/FLO/flowri.F90

    r10425 r11536  
    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 
    … …  
    179175               CALL ctl_opn( numflo, 'trajec_float', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) 
    180176               irecflo = NINT( (nitend-nn_it000) / FLOAT(nn_writefl) ) 
    181                WRITE(numflo,*)cexper,no,irecflo,jpnfl,nn_writefl 
     177               WRITE(numflo,*) cexper, irecflo, jpnfl, nn_writefl 
    182178            ENDIF 
    183179 
    … …  
    255251 
    256252               istart = (/jfl,irec/) 
    257                icfl   = INT( tpkfl(jfl) )            ! K-index of the nearest point before 
    258  
    259                CALL flioputv( numflo , 'traj_lon'    , zlon(jfl)        , start=istart ) 
    260                CALL flioputv( numflo , 'traj_lat'    , zlat(jfl)        , start=istart )   
    261                CALL flioputv( numflo , 'traj_depth'  , zdep(jfl)        , start=istart )   
    262                CALL flioputv( numflo , 'traj_temp'   , ztemp(icfl,jfl)  , start=istart )   
    263                CALL flioputv( numflo , 'traj_salt'   , zsal(icfl,jfl)   , start=istart )   
    264                CALL flioputv( numflo , 'traj_dens'   , zrho(icfl,jfl)   , start=istart )   
     253 
     254               CALL flioputv( numflo , 'traj_lon'    , zlon(jfl), start=istart ) 
     255               CALL flioputv( numflo , 'traj_lat'    , zlat(jfl), start=istart )   
     256               CALL flioputv( numflo , 'traj_depth'  , zdep(jfl), start=istart )   
     257               CALL flioputv( numflo , 'traj_temp'   , ztem(jfl), start=istart )   
     258               CALL flioputv( numflo , 'traj_salt'   , zsal(jfl), start=istart )   
     259               CALL flioputv( numflo , 'traj_dens'   , zrho(jfl), start=istart )   
    265260 
    266261            ENDDO 
    … …  
    277272   END SUBROUTINE flo_wri 
    278273 
    279  
    280 #  else 
    281    !!---------------------------------------------------------------------- 
    282    !!   Default option                                         Empty module 
    283    !!---------------------------------------------------------------------- 
    284 CONTAINS 
    285    SUBROUTINE flo_wri                 ! Empty routine 
    286    END SUBROUTINE flo_wri 
    287 #endif 
    288  
    289274   !!======================================================================= 
    290275END MODULE flowri 

  • NEMO/trunk/src/OCE/ICB/icbini.F90

    r10702 r11536  
    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/trunk/src/OCE/ICB/icblbc.F90

    r10570 r11536  
    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/trunk/src/OCE/ICB/icbrst.F90

    r10425 r11536  
    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/trunk/src/OCE/ICB/icbstp.F90

    r10570 r11536  
    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/trunk/src/OCE/IOM/in_out_manager.F90

    r10817 r11536  
    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   !!---------------------------------------------------------------------- 
    … …  
    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/trunk/src/OCE/IOM/iom.F90

    r10817 r11536  
    5858   PUBLIC iom_init, iom_swap, iom_open, iom_close, iom_setkt, iom_varid, iom_get 
    5959   PUBLIC iom_chkatt, iom_getatt, iom_putatt, iom_getszuld, iom_rstput, iom_delay_rst, iom_put 
    60    PUBLIC iom_use, iom_context_finalize 
     60   PUBLIC iom_use, iom_context_finalize, iom_miss_val 
    6161 
    6262   PRIVATE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d 
    … …  
    212212          CALL iom_set_axis_attr( "depthv", bounds=zw_bnds ) 
    213213          CALL iom_set_axis_attr( "depthw", bounds=zt_bnds ) 
    214           ! 
    215 # if defined key_floats 
    216214          CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) ) 
    217 # endif 
    218215# if defined key_si3 
    219216          CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) 
    … …  
    835832 
    836833 
    837    FUNCTION iom_varid ( kiomid, cdvar, kdimsz, kndims, ldstop )   
     834   FUNCTION iom_varid ( kiomid, cdvar, kdimsz, kndims, lduld, ldstop )   
    838835      !!----------------------------------------------------------------------- 
    839836      !!                  ***  FUNCTION  iom_varid  *** 
    … …  
    844841      CHARACTER(len=*)     , INTENT(in   )           ::   cdvar    ! name of the variable 
    845842      INTEGER, DIMENSION(:), INTENT(  out), OPTIONAL ::   kdimsz   ! size of each dimension 
    846       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) 
    847845      LOGICAL              , INTENT(in   ), OPTIONAL ::   ldstop   ! stop if looking for non-existing variable (default = .TRUE.) 
    848846      ! 
    … …  
    874872               iiv = iiv + 1 
    875873               IF( iiv <= jpmax_vars ) THEN 
    876                   iom_varid = iom_nf90_varid( kiomid, cdvar, iiv, kdimsz, kndims ) 
     874                  iom_varid = iom_nf90_varid( kiomid, cdvar, iiv, kdimsz, kndims, lduld ) 
    877875               ELSE 
    878876                  CALL ctl_stop( trim(clinfo), 'Too many variables in the file '//iom_file(kiomid)%name,   & 
    … …  
    892890               ENDIF 
    893891               IF( PRESENT(kndims) )  kndims = iom_file(kiomid)%ndims(iiv) 
     892               IF( PRESENT( lduld) )  lduld  = iom_file(kiomid)%luld( iiv) 
    894893            ENDIF 
    895894         ENDIF 
    … …  
    12701269               !--- overlap areas and extra hallows (mpp) 
    12711270               IF(     PRESENT(pv_r2d) .AND. idom /= jpdom_unknown ) THEN 
    1272                   CALL lbc_lnk( 'iom', pv_r2d,'Z',-999.,'no0' ) 
     1271                  CALL lbc_lnk( 'iom', pv_r2d,'Z', -999., kfillmode = jpfillnothing ) 
    12731272               ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown ) THEN 
    12741273                  ! this if could be simplified with the new lbc_lnk that works with any size of the 3rd dimension 
    12751274                  IF( icnt(3) == inlev ) THEN 
    1276                      CALL lbc_lnk( 'iom', pv_r3d,'Z',-999.,'no0' ) 
     1275                     CALL lbc_lnk( 'iom', pv_r3d,'Z', -999., kfillmode = jpfillnothing ) 
    12771276                  ELSE   ! put some arbitrary value (a call to lbc_lnk will be done later...) 
    12781277                     DO jj = nlcj+1, jpj   ;   pv_r3d(1:nlci, jj, :) = pv_r3d(1:nlci, nlej, :)   ;   END DO 
    … …  
    12991298            CALL xios_recv_field( trim(cdvar), pv_r3d) 
    13001299            IF(idom /= jpdom_unknown ) then 
    1301                 CALL lbc_lnk( 'iom', pv_r3d,'Z',-999.,'no0' ) 
     1300                CALL lbc_lnk( 'iom', pv_r3d,'Z', -999., kfillmode = jpfillnothing) 
    13021301            ENDIF 
    13031302         ELSEIF( PRESENT(pv_r2d) ) THEN 
    … …  
    13061305            CALL xios_recv_field( trim(cdvar), pv_r2d) 
    13071306            IF(idom /= jpdom_unknown ) THEN 
    1308                 CALL lbc_lnk('iom', pv_r2d,'Z',-999.,'no0') 
     1307                CALL lbc_lnk('iom', pv_r2d,'Z',-999., kfillmode = jpfillnothing) 
    13091308            ENDIF 
    13101309         ELSEIF( PRESENT(pv_r1d) ) THEN 
    … …  
    16691668      CHARACTER(LEN=*), INTENT(in) ::   cdname 
    16701669      REAL(wp)        , INTENT(in) ::   pfield0d 
    1671       REAL(wp)        , DIMENSION(jpi,jpj) ::   zz     ! masson 
     1670!!      REAL(wp)        , DIMENSION(jpi,jpj) ::   zz     ! masson 
    16721671#if defined key_iomput 
    1673       zz(:,:)=pfield0d 
    1674       CALL xios_send_field(cdname, zz) 
    1675       !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/))  
    16761675#else 
    16771676      IF( .FALSE. )   WRITE(numout,*) cdname, pfield0d   ! useless test to avoid compilation warnings 
    … …  
    19791978      ! Cell vertices on boundries 
    19801979      DO jn = 1, 4 
    1981          CALL lbc_lnk( 'iom', z_bnds(jn,:,:,1), cdgrd, 1., pval=999._wp ) 
    1982          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 ) 
    19831982      END DO 
    19841983      ! 
    … …  
    23892388   !!   NOT 'key_iomput'                               a few dummy routines 
    23902389   !!---------------------------------------------------------------------- 
    2391  
    23922390   SUBROUTINE iom_setkt( kt, cdname ) 
    23932391      INTEGER         , INTENT(in)::   kt  
    … …  
    24042402 
    24052403   LOGICAL FUNCTION iom_use( cdname ) 
    2406       !!---------------------------------------------------------------------- 
    2407       !!---------------------------------------------------------------------- 
    24082404      CHARACTER(LEN=*), INTENT(in) ::   cdname 
    2409       !!---------------------------------------------------------------------- 
    24102405#if defined key_iomput 
    24112406      iom_use = xios_field_is_active( cdname ) 
    … …  
    24142409#endif 
    24152410   END FUNCTION iom_use 
    2416     
     2411 
     2412   SUBROUTINE iom_miss_val( cdname, pmiss_val ) 
     2413      CHARACTER(LEN=*), INTENT(in ) ::   cdname 
     2414      REAL(wp)        , INTENT(out) ::   pmiss_val    
     2415#if defined key_iomput 
     2416      ! get missing value 
     2417      CALL xios_get_field_attr( cdname, default_value = pmiss_val ) 
     2418#else 
     2419      IF( .FALSE. )   WRITE(numout,*) cdname, pmiss_val   ! useless test to avoid compilation warnings 
     2420#endif 
     2421   END SUBROUTINE iom_miss_val 
     2422   
    24172423   !!====================================================================== 
    24182424END MODULE iom 

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

    r10522 r11536  
    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/trunk/src/OCE/IOM/restart.F90

    r10425 r11536  
    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...) 
    … …  
    184186         lrst_oce = .FALSE. 
    185187            IF( ln_rst_list ) THEN 
    186                nrst_lst = MIN(nrst_lst + 1, SIZE(nstocklist,1)) 
    187                nitrst = nstocklist( nrst_lst ) 
     188               nrst_lst = MIN(nrst_lst + 1, SIZE(nn_stocklist,1)) 
     189               nitrst = nn_stocklist( nrst_lst ) 
    188190            ENDIF 
    189191      ENDIF 

  • NEMO/trunk/src/OCE/LBC/lbc_lnk_multi_generic.h90

    r10425 r11536  
    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/trunk/src/OCE/LBC/lbc_nfd_nogather_generic.h90

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

    r10425 r11536  
    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/trunk/src/OCE/LBC/lbcnfd.F90

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

    r10982 r11536  
    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) 
    … …  
    145132   INTEGER, PUBLIC ::   north_root        !: number (in the comm_opa) of proc 0 in the northern comm 
    146133   INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_north   !: dimension ndim_rank_north 
    147  
    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 
    152134 
    153135   ! Communications summary report 
    … …  
    187169   LOGICAL, PUBLIC ::   ln_nnogather                !: namelist control of northfold comms 
    188170   LOGICAL, PUBLIC ::   l_north_nogather = .FALSE.  !: internal control of northfold comms 
    189  
     171    
    190172   !!---------------------------------------------------------------------- 
    191173   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    195177CONTAINS 
    196178 
    197    FUNCTION mynode( ldtxt, ldname, kumnam_ref, kumnam_cfg, kumond, kstop, localComm ) 
    198       !!---------------------------------------------------------------------- 
    199       !!                  ***  routine mynode  *** 
    200       !! 
    201       !! ** Purpose :   Find processor unit 
    202       !!---------------------------------------------------------------------- 
    203       CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt        ! 
    204       CHARACTER(len=*)             , INTENT(in   ) ::   ldname       ! 
    205       INTEGER                      , INTENT(in   ) ::   kumnam_ref   ! logical unit for reference namelist 
    206       INTEGER                      , INTENT(in   ) ::   kumnam_cfg   ! logical unit for configuration namelist 
    207       INTEGER                      , INTENT(inout) ::   kumond       ! logical unit for namelist output 
    208       INTEGER                      , INTENT(inout) ::   kstop        ! stop indicator 
     179   SUBROUTINE mpp_start( localComm ) 
     180      !!---------------------------------------------------------------------- 
     181      !!                  ***  routine mpp_start  *** 
     182      !! 
     183      !! ** Purpose :   get mpi_comm_oce, mpprank and mppsize 
     184      !!---------------------------------------------------------------------- 
    209185      INTEGER         , OPTIONAL   , INTENT(in   ) ::   localComm    ! 
    210186      ! 
    211       INTEGER ::   mynode, ierr, code, ji, ii, ios 
    212       LOGICAL ::   mpi_was_called 
    213       ! 
    214       NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, ln_nnogather 
    215       !!---------------------------------------------------------------------- 
    216       ! 
    217       ii = 1 
    218       WRITE(ldtxt(ii),*)                                                                  ;   ii = ii + 1 
    219       WRITE(ldtxt(ii),*) 'mynode : mpi initialisation'                                    ;   ii = ii + 1 
    220       WRITE(ldtxt(ii),*) '~~~~~~ '                                                        ;   ii = ii + 1 
    221       ! 
    222       REWIND( kumnam_ref )              ! Namelist nammpp in reference namelist: mpi variables 
    223       READ  ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901) 
    224 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp ) 
    225       ! 
    226       REWIND( kumnam_cfg )              ! Namelist nammpp in configuration namelist: mpi variables 
    227       READ  ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 
    228 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp ) 
    229       ! 
    230       !                              ! control print 
    231       WRITE(ldtxt(ii),*) '   Namelist nammpp'                                             ;   ii = ii + 1 
    232       WRITE(ldtxt(ii),*) '      mpi send type          cn_mpi_send = ', cn_mpi_send       ;   ii = ii + 1 
    233       WRITE(ldtxt(ii),*) '      size exported buffer   nn_buffer   = ', nn_buffer,' bytes';   ii = ii + 1 
    234       ! 
    235       IF( jpni < 1 .OR. jpnj < 1  ) THEN 
    236          WRITE(ldtxt(ii),*) '      jpni and jpnj will be calculated automatically' ;   ii = ii + 1 
    237       ELSE 
    238          WRITE(ldtxt(ii),*) '      processor grid extent in i         jpni = ',jpni       ;   ii = ii + 1 
    239          WRITE(ldtxt(ii),*) '      processor grid extent in j         jpnj = ',jpnj       ;   ii = ii + 1 
    240       ENDIF 
    241  
    242       WRITE(ldtxt(ii),*) '      avoid use of mpi_allgather at the north fold  ln_nnogather = ', ln_nnogather  ; ii = ii + 1 
    243  
    244       CALL mpi_initialized ( mpi_was_called, code ) 
    245       IF( code /= MPI_SUCCESS ) THEN 
    246          DO ji = 1, SIZE(ldtxt) 
    247             IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    248          END DO 
    249          WRITE(*, cform_err) 
    250          WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized' 
    251          CALL mpi_abort( mpi_comm_world, code, ierr ) 
    252       ENDIF 
    253  
    254       IF( mpi_was_called ) THEN 
    255          ! 
    256          SELECT CASE ( cn_mpi_send ) 
    257          CASE ( 'S' )                ! Standard mpi send (blocking) 
    258             WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'             ;   ii = ii + 1 
    259          CASE ( 'B' )                ! Buffer mpi send (blocking) 
    260             WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'              ;   ii = ii + 1 
    261             IF( Agrif_Root() )   CALL mpi_init_oce( ldtxt, ii, ierr ) 
    262          CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
    263             WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'           ;   ii = ii + 1 
    264             l_isend = .TRUE. 
    265          CASE DEFAULT 
    266             WRITE(ldtxt(ii),cform_err)                                                    ;   ii = ii + 1 
    267             WRITE(ldtxt(ii),*) '           bad value for cn_mpi_send = ', cn_mpi_send     ;   ii = ii + 1 
    268             kstop = kstop + 1 
    269          END SELECT 
    270          ! 
    271       ELSEIF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN 
    272          WRITE(ldtxt(ii),cform_err)                                                    ;   ii = ii + 1 
    273          WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator '          ;   ii = ii + 1 
    274          WRITE(ldtxt(ii),*) '          without calling MPI_Init before ! '                ;   ii = ii + 1 
    275          kstop = kstop + 1 
    276       ELSE 
    277          SELECT CASE ( cn_mpi_send ) 
    278          CASE ( 'S' )                ! Standard mpi send (blocking) 
    279             WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'             ;   ii = ii + 1 
    280             CALL mpi_init( ierr ) 
    281          CASE ( 'B' )                ! Buffer mpi send (blocking) 
    282             WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'              ;   ii = ii + 1 
    283             IF( Agrif_Root() )   CALL mpi_init_oce( ldtxt, ii, ierr ) 
    284          CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
    285             WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'           ;   ii = ii + 1 
    286             l_isend = .TRUE. 
    287             CALL mpi_init( ierr ) 
    288          CASE DEFAULT 
    289             WRITE(ldtxt(ii),cform_err)                                                    ;   ii = ii + 1 
    290             WRITE(ldtxt(ii),*) '           bad value for cn_mpi_send = ', cn_mpi_send     ;   ii = ii + 1 
    291             kstop = kstop + 1 
    292          END SELECT 
    293          ! 
    294       ENDIF 
    295  
     187      INTEGER ::   ierr 
     188      LOGICAL ::   llmpi_init 
     189      !!---------------------------------------------------------------------- 
     190#if defined key_mpp_mpi 
     191      ! 
     192      CALL mpi_initialized ( llmpi_init, ierr ) 
     193      IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_initialized' ) 
     194 
     195      IF( .NOT. llmpi_init ) THEN 
     196         IF( PRESENT(localComm) ) THEN 
     197            WRITE(ctmp1,*) ' lib_mpp: You cannot provide a local communicator ' 
     198            WRITE(ctmp2,*) '          without calling MPI_Init before ! ' 
     199            CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) 
     200         ENDIF 
     201         CALL mpi_init( ierr ) 
     202         IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_init' ) 
     203      ENDIF 
     204        
    296205      IF( PRESENT(localComm) ) THEN 
    297206         IF( Agrif_Root() ) THEN 
    … …  
    299208         ENDIF 
    300209      ELSE 
    301          CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code) 
    302          IF( code /= MPI_SUCCESS ) THEN 
    303             DO ji = 1, SIZE(ldtxt) 
    304                IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    305             END DO 
    306             WRITE(*, cform_err) 
    307             WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' 
    308             CALL mpi_abort( mpi_comm_world, code, ierr ) 
    309          ENDIF 
    310       ENDIF 
    311  
    312 #if defined key_agrif 
     210         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, ierr) 
     211         IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_comm_dup' ) 
     212      ENDIF 
     213 
     214# if defined key_agrif 
    313215      IF( Agrif_Root() ) THEN 
    314216         CALL Agrif_MPI_Init(mpi_comm_oce) 
    … …  
    316218         CALL Agrif_MPI_set_grid_comm(mpi_comm_oce) 
    317219      ENDIF 
    318 #endif 
     220# endif 
    319221 
    320222      CALL mpi_comm_rank( mpi_comm_oce, mpprank, ierr ) 
    321223      CALL mpi_comm_size( mpi_comm_oce, mppsize, ierr ) 
    322       mynode = mpprank 
    323  
    324       IF( mynode == 0 ) THEN 
    325          CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 
    326          WRITE(kumond, nammpp)       
    327       ENDIF 
    328224      ! 
    329225      CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr) 
    330226      ! 
    331    END FUNCTION mynode 
    332  
    333    !!---------------------------------------------------------------------- 
    334    !!                   ***  routine mpp_lnk_(2,3,4)d  *** 
    335    !! 
    336    !!   * Argument : dummy argument use in mpp_lnk_... routines 
    337    !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
    338    !!                cd_nat :   nature of array grid-points 
    339    !!                psgn   :   sign used across the north fold boundary 
    340    !!                kfld   :   optional, number of pt3d arrays 
    341    !!                cd_mpp :   optional, fill the overlap area only 
    342    !!                pval   :   optional, background value (used at closed boundaries) 
    343    !!---------------------------------------------------------------------- 
    344    ! 
    345    !                       !==  2D array and array of 2D pointer  ==! 
    346    ! 
    347 #  define DIM_2d 
    348 #     define ROUTINE_LNK           mpp_lnk_2d 
    349 #     include "mpp_lnk_generic.h90" 
    350 #     undef ROUTINE_LNK 
    351 #     define MULTI 
    352 #     define ROUTINE_LNK           mpp_lnk_2d_ptr 
    353 #     include "mpp_lnk_generic.h90" 
    354 #     undef ROUTINE_LNK 
    355 #     undef MULTI 
    356 #  undef DIM_2d 
    357    ! 
    358    !                       !==  3D array and array of 3D pointer  ==! 
    359    ! 
    360 #  define DIM_3d 
    361 #     define ROUTINE_LNK           mpp_lnk_3d 
    362 #     include "mpp_lnk_generic.h90" 
    363 #     undef ROUTINE_LNK 
    364 #     define MULTI 
    365 #     define ROUTINE_LNK           mpp_lnk_3d_ptr 
    366 #     include "mpp_lnk_generic.h90" 
    367 #     undef ROUTINE_LNK 
    368 #     undef MULTI 
    369 #  undef DIM_3d 
    370    ! 
    371    !                       !==  4D array and array of 4D pointer  ==! 
    372    ! 
    373 #  define DIM_4d 
    374 #     define ROUTINE_LNK           mpp_lnk_4d 
    375 #     include "mpp_lnk_generic.h90" 
    376 #     undef ROUTINE_LNK 
    377 #     define MULTI 
    378 #     define ROUTINE_LNK           mpp_lnk_4d_ptr 
    379 #     include "mpp_lnk_generic.h90" 
    380 #     undef ROUTINE_LNK 
    381 #     undef MULTI 
    382 #  undef DIM_4d 
    383  
    384    !!---------------------------------------------------------------------- 
    385    !!                   ***  routine mpp_nfd_(2,3,4)d  *** 
    386    !! 
    387    !!   * Argument : dummy argument use in mpp_nfd_... routines 
    388    !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
    389    !!                cd_nat :   nature of array grid-points 
    390    !!                psgn   :   sign used across the north fold boundary 
    391    !!                kfld   :   optional, number of pt3d arrays 
    392    !!                cd_mpp :   optional, fill the overlap area only 
    393    !!                pval   :   optional, background value (used at closed boundaries) 
    394    !!---------------------------------------------------------------------- 
    395    ! 
    396    !                       !==  2D array and array of 2D pointer  ==! 
    397    ! 
    398 #  define DIM_2d 
    399 #     define ROUTINE_NFD           mpp_nfd_2d 
    400 #     include "mpp_nfd_generic.h90" 
    401 #     undef ROUTINE_NFD 
    402 #     define MULTI 
    403 #     define ROUTINE_NFD           mpp_nfd_2d_ptr 
    404 #     include "mpp_nfd_generic.h90" 
    405 #     undef ROUTINE_NFD 
    406 #     undef MULTI 
    407 #  undef DIM_2d 
    408    ! 
    409    !                       !==  3D array and array of 3D pointer  ==! 
    410    ! 
    411 #  define DIM_3d 
    412 #     define ROUTINE_NFD           mpp_nfd_3d 
    413 #     include "mpp_nfd_generic.h90" 
    414 #     undef ROUTINE_NFD 
    415 #     define MULTI 
    416 #     define ROUTINE_NFD           mpp_nfd_3d_ptr 
    417 #     include "mpp_nfd_generic.h90" 
    418 #     undef ROUTINE_NFD 
    419 #     undef MULTI 
    420 #  undef DIM_3d 
    421    ! 
    422    !                       !==  4D array and array of 4D pointer  ==! 
    423    ! 
    424 #  define DIM_4d 
    425 #     define ROUTINE_NFD           mpp_nfd_4d 
    426 #     include "mpp_nfd_generic.h90" 
    427 #     undef ROUTINE_NFD 
    428 #     define MULTI 
    429 #     define ROUTINE_NFD           mpp_nfd_4d_ptr 
    430 #     include "mpp_nfd_generic.h90" 
    431 #     undef ROUTINE_NFD 
    432 #     undef MULTI 
    433 #  undef DIM_4d 
    434  
    435  
    436    !!---------------------------------------------------------------------- 
    437    !!                   ***  routine mpp_lnk_bdy_(2,3,4)d  *** 
    438    !! 
    439    !!   * Argument : dummy argument use in mpp_lnk_... routines 
    440    !!                ptab   :   array or pointer of arrays on which the boundary condition is applied 
    441    !!                cd_nat :   nature of array grid-points 
    442    !!                psgn   :   sign used across the north fold boundary 
    443    !!                kb_bdy :   BDY boundary set 
    444    !!                kfld   :   optional, number of pt3d arrays 
    445    !!---------------------------------------------------------------------- 
    446    ! 
    447    !                       !==  2D array and array of 2D pointer  ==! 
    448    ! 
    449 #  define DIM_2d 
    450 #     define ROUTINE_BDY           mpp_lnk_bdy_2d 
    451 #     include "mpp_bdy_generic.h90" 
    452 #     undef ROUTINE_BDY 
    453 #  undef DIM_2d 
    454    ! 
    455    !                       !==  3D array and array of 3D pointer  ==! 
    456    ! 
    457 #  define DIM_3d 
    458 #     define ROUTINE_BDY           mpp_lnk_bdy_3d 
    459 #     include "mpp_bdy_generic.h90" 
    460 #     undef ROUTINE_BDY 
    461 #  undef DIM_3d 
    462    ! 
    463    !                       !==  4D array and array of 4D pointer  ==! 
    464    ! 
    465 #  define DIM_4d 
    466 #     define ROUTINE_BDY           mpp_lnk_bdy_4d 
    467 #     include "mpp_bdy_generic.h90" 
    468 #     undef ROUTINE_BDY 
    469 #  undef DIM_4d 
    470  
    471    !!---------------------------------------------------------------------- 
    472    !! 
    473    !!   load_array  &   mpp_lnk_2d_9    à generaliser a 3D et 4D 
    474     
    475     
    476    !!    mpp_lnk_sum_2d et 3D   ====>>>>>>   à virer du code !!!! 
    477     
    478     
    479    !!---------------------------------------------------------------------- 
    480  
     227#else 
     228      IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 
     229      mppsize = 1 
     230      mpprank = 0 
     231#endif 
     232   END SUBROUTINE mpp_start 
    481233 
    482234 
    … …  
    497249      !!---------------------------------------------------------------------- 
    498250      ! 
    499       SELECT CASE ( cn_mpi_send ) 
    500       CASE ( 'S' )                ! Standard mpi send (blocking) 
    501          CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce        , iflag ) 
    502       CASE ( 'B' )                ! Buffer mpi send (blocking) 
    503          CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce        , iflag ) 
    504       CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
    505          ! be carefull, one more argument here : the mpi request identifier.. 
    506          CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 
    507       END SELECT 
     251#if defined key_mpp_mpi 
     252      CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 
     253#endif 
    508254      ! 
    509255   END SUBROUTINE mppsend 
    … …  
    527273      !!---------------------------------------------------------------------- 
    528274      ! 
     275#if defined key_mpp_mpi 
    529276      ! If a specific process number has been passed to the receive call, 
    530277      ! use that one. Default is to use mpi_any_source 
    … …  
    533280      ! 
    534281      CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag ) 
     282#endif 
    535283      ! 
    536284   END SUBROUTINE mpprecv 
    … …  
    553301      ! 
    554302      itaille = jpi * jpj 
     303#if defined key_mpp_mpi 
    555304      CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille     ,   & 
    556305         &                            mpi_double_precision, kp , mpi_comm_oce, ierror ) 
     306#else 
     307      pio(:,:,1) = ptab(:,:) 
     308#endif 
    557309      ! 
    558310   END SUBROUTINE mppgather 
    … …  
    576328      itaille = jpi * jpj 
    577329      ! 
     330#if defined key_mpp_mpi 
    578331      CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille     ,   & 
    579332         &                            mpi_double_precision, kp  , mpi_comm_oce, ierror ) 
     333#else 
     334      ptab(:,:) = pio(:,:,1) 
     335#endif 
    580336      ! 
    581337   END SUBROUTINE mppscatter 
    … …  
    601357      COMPLEX(wp), ALLOCATABLE, DIMENSION(:) ::   ytmp 
    602358      !!---------------------------------------------------------------------- 
     359#if defined key_mpp_mpi 
    603360      ilocalcomm = mpi_comm_oce 
    604361      IF( PRESENT(kcom) )   ilocalcomm = kcom 
    … …  
    639396 
    640397      ! send y_in into todelay(idvar)%y1d with a non-blocking communication 
    641 #if defined key_mpi2 
     398# if defined key_mpi2 
    642399      IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 
    643400      CALL  mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 
    644401      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 
     402# else 
     403      CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 
     404# endif 
    645405#else 
    646       CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) 
     406      pout(:) = REAL(y_in(:), wp) 
    647407#endif 
    648408 
    … …  
    668428      INTEGER ::   ierr, ilocalcomm 
    669429      !!---------------------------------------------------------------------- 
     430#if defined key_mpp_mpi 
    670431      ilocalcomm = mpi_comm_oce 
    671432      IF( PRESENT(kcom) )   ilocalcomm = kcom 
    … …  
    702463 
    703464      ! send p_in into todelay(idvar)%z1d with a non-blocking communication 
    704 #if defined key_mpi2 
     465# if defined key_mpi2 
    705466      IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 
    706467      CALL  mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
    707468      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 
     469# else 
     470      CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
     471# endif 
    708472#else 
    709       CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
     473      pout(:) = p_in(:) 
    710474#endif 
    711475 
    … …  
    723487      INTEGER ::   ierr 
    724488      !!---------------------------------------------------------------------- 
     489#if defined key_mpp_mpi 
    725490      IF( ndelayid(kid) /= -2 ) THEN   
    726491#if ! defined key_mpi2 
    … …  
    732497         ndelayid(kid) = -2   ! add flag to know that mpi_wait was already called on kid 
    733498      ENDIF 
     499#endif 
    734500   END SUBROUTINE mpp_delay_rcv 
    735501 
    … …  
    890656      !!----------------------------------------------------------------------- 
    891657      ! 
     658#if defined key_mpp_mpi 
    892659      CALL mpi_barrier( mpi_comm_oce, ierror ) 
     660#endif 
    893661      ! 
    894662   END SUBROUTINE mppsync 
    895663 
    896664 
    897    SUBROUTINE mppstop( ldfinal, ld_force_abort )  
     665   SUBROUTINE mppstop( ld_abort )  
    898666      !!---------------------------------------------------------------------- 
    899667      !!                  ***  routine mppstop  *** 
    … …  
    902670      !! 
    903671      !!---------------------------------------------------------------------- 
    904       LOGICAL, OPTIONAL, INTENT(in) :: ldfinal    ! source process number 
    905       LOGICAL, OPTIONAL, INTENT(in) :: ld_force_abort    ! source process number 
    906       LOGICAL ::   llfinal, ll_force_abort 
     672      LOGICAL, OPTIONAL, INTENT(in) :: ld_abort    ! source process number 
     673      LOGICAL ::   ll_abort 
    907674      INTEGER ::   info 
    908675      !!---------------------------------------------------------------------- 
    909       llfinal = .FALSE. 
    910       IF( PRESENT(ldfinal) ) llfinal = ldfinal 
    911       ll_force_abort = .FALSE. 
    912       IF( PRESENT(ld_force_abort) ) ll_force_abort = ld_force_abort 
    913       ! 
    914       IF(ll_force_abort) THEN 
     676      ll_abort = .FALSE. 
     677      IF( PRESENT(ld_abort) ) ll_abort = ld_abort 
     678      ! 
     679#if defined key_mpp_mpi 
     680      IF(ll_abort) THEN 
    915681         CALL mpi_abort( MPI_COMM_WORLD ) 
    916682      ELSE 
    … …  
    918684         CALL mpi_finalize( info ) 
    919685      ENDIF 
    920       IF( .NOT. llfinal ) STOP 123 
     686#endif 
     687      IF( ll_abort ) STOP 123 
    921688      ! 
    922689   END SUBROUTINE mppstop 
    … …  
    930697      !!---------------------------------------------------------------------- 
    931698      ! 
     699#if defined key_mpp_mpi 
    932700      CALL MPI_COMM_FREE(kcom, ierr) 
     701#endif 
    933702      ! 
    934703   END SUBROUTINE mpp_comm_free 
    … …  
    960729      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kwork 
    961730      !!---------------------------------------------------------------------- 
     731#if defined key_mpp_mpi 
    962732      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world     : ', ngrp_world 
    963733      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world 
    … …  
    965735      ! 
    966736      ALLOCATE( kwork(jpnij), STAT=ierr ) 
    967       IF( ierr /= 0 ) THEN 
    968          WRITE(kumout, cform_err) 
    969          WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij' 
    970          CALL mppstop 
    971       ENDIF 
     737      IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_ini_znl : failed to allocate 1D array of length jpnij') 
    972738 
    973739      IF( jpnj == 1 ) THEN 
    … …  
    1031797 
    1032798      DEALLOCATE(kwork) 
     799#endif 
    1033800 
    1034801   END SUBROUTINE mpp_ini_znl 
    … …  
    1062829      !!---------------------------------------------------------------------- 
    1063830      ! 
     831#if defined key_mpp_mpi 
    1064832      njmppmax = MAXVAL( njmppt ) 
    1065833      ! 
    … …  
    1093861      CALL MPI_COMM_CREATE( mpi_comm_oce, ngrp_north, ncomm_north, ierr ) 
    1094862      ! 
     863#endif 
    1095864   END SUBROUTINE mpp_ini_north 
    1096  
    1097  
    1098    SUBROUTINE mpi_init_oce( ldtxt, ksft, code ) 
    1099       !!--------------------------------------------------------------------- 
    1100       !!                   ***  routine mpp_init.opa  *** 
    1101       !! 
    1102       !! ** Purpose :: export and attach a MPI buffer for bsend 
    1103       !! 
    1104       !! ** Method  :: define buffer size in namelist, if 0 no buffer attachment 
    1105       !!            but classical mpi_init 
    1106       !! 
    1107       !! History :: 01/11 :: IDRIS initial version for IBM only 
    1108       !!            08/04 :: R. Benshila, generalisation 
    1109       !!--------------------------------------------------------------------- 
    1110       CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt 
    1111       INTEGER                      , INTENT(inout) ::   ksft 
    1112       INTEGER                      , INTENT(  out) ::   code 
    1113       INTEGER                                      ::   ierr, ji 
    1114       LOGICAL                                      ::   mpi_was_called 
    1115       !!--------------------------------------------------------------------- 
    1116       ! 
    1117       CALL mpi_initialized( mpi_was_called, code )      ! MPI initialization 
    1118       IF ( code /= MPI_SUCCESS ) THEN 
    1119          DO ji = 1, SIZE(ldtxt) 
    1120             IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    1121          END DO 
    1122          WRITE(*, cform_err) 
    1123          WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized' 
    1124          CALL mpi_abort( mpi_comm_world, code, ierr ) 
    1125       ENDIF 
    1126       ! 
    1127       IF( .NOT. mpi_was_called ) THEN 
    1128          CALL mpi_init( code ) 
    1129          CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code ) 
    1130          IF ( code /= MPI_SUCCESS ) THEN 
    1131             DO ji = 1, SIZE(ldtxt) 
    1132                IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    1133             END DO 
    1134             WRITE(*, cform_err) 
    1135             WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' 
    1136             CALL mpi_abort( mpi_comm_world, code, ierr ) 
    1137          ENDIF 
    1138       ENDIF 
    1139       ! 
    1140       IF( nn_buffer > 0 ) THEN 
    1141          WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of  : ', nn_buffer   ;   ksft = ksft + 1 
    1142          ! Buffer allocation and attachment 
    1143          ALLOCATE( tampon(nn_buffer), stat = ierr ) 
    1144          IF( ierr /= 0 ) THEN 
    1145             DO ji = 1, SIZE(ldtxt) 
    1146                IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    1147             END DO 
    1148             WRITE(*, cform_err) 
    1149             WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr 
    1150             CALL mpi_abort( mpi_comm_world, code, ierr ) 
    1151          END IF 
    1152          CALL mpi_buffer_attach( tampon, nn_buffer, code ) 
    1153       ENDIF 
    1154       ! 
    1155    END SUBROUTINE mpi_init_oce 
    1156865 
    1157866 
    … …  
    1187896 
    1188897 
    1189    SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj) 
    1190       !!--------------------------------------------------------------------- 
    1191       !!                   ***  routine mpp_lbc_north_icb  *** 
    1192       !! 
    1193       !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
    1194       !!              in mpp configuration in case of jpn1 > 1 and for 2d 
    1195       !!              array with outer extra halo 
    1196       !! 
    1197       !! ** Method  :   North fold condition and mpp with more than one proc 
    1198       !!              in i-direction require a specific treatment. We gather 
    1199       !!              the 4+kextj northern lines of the global domain on 1 
    1200       !!              processor and apply lbc north-fold on this sub array. 
    1201       !!              Then we scatter the north fold array back to the processors. 
    1202       !!              This routine accounts for an extra halo with icebergs 
    1203       !!              and assumes ghost rows and columns have been suppressed. 
    1204       !! 
    1205       !!---------------------------------------------------------------------- 
    1206       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    1207       CHARACTER(len=1)        , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points 
    1208       !                                                     !   = T ,  U , V , F or W -points 
    1209       REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the 
    1210       !!                                                    ! north fold, =  1. otherwise 
    1211       INTEGER                 , INTENT(in   ) ::   kextj    ! Extra halo width at north fold 
    1212       ! 
    1213       INTEGER ::   ji, jj, jr 
    1214       INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    1215       INTEGER ::   ipj, ij, iproc 
    1216       ! 
    1217       REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e 
    1218       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e 
    1219       !!---------------------------------------------------------------------- 
    1220       ! 
    1221       ipj=4 
    1222       ALLOCATE(        ztab_e(jpiglo, 1-kextj:ipj+kextj)       ,       & 
    1223      &            znorthloc_e(jpimax, 1-kextj:ipj+kextj)       ,       & 
    1224      &          znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni)    ) 
    1225       ! 
    1226       ztab_e(:,:)      = 0._wp 
    1227       znorthloc_e(:,:) = 0._wp 
    1228       ! 
    1229       ij = 1 - kextj 
    1230       ! put the last ipj+2*kextj lines of pt2d into znorthloc_e  
    1231       DO jj = jpj - ipj + 1 - kextj , jpj + kextj 
    1232          znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj) 
    1233          ij = ij + 1 
    1234       END DO 
    1235       ! 
    1236       itaille = jpimax * ( ipj + 2*kextj ) 
    1237       ! 
    1238       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    1239       CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj)    , itaille, MPI_DOUBLE_PRECISION,    & 
    1240          &                znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION,    & 
    1241          &                ncomm_north, ierr ) 
    1242       ! 
    1243       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    1244       ! 
    1245       DO jr = 1, ndim_rank_north            ! recover the global north array 
    1246          iproc = nrank_north(jr) + 1 
    1247          ildi = nldit (iproc) 
    1248          ilei = nleit (iproc) 
    1249          iilb = nimppt(iproc) 
    1250          DO jj = 1-kextj, ipj+kextj 
    1251             DO ji = ildi, ilei 
    1252                ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 
    1253             END DO 
    1254          END DO 
    1255       END DO 
    1256  
    1257       ! 2. North-Fold boundary conditions 
    1258       ! ---------------------------------- 
    1259       CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj ) 
    1260  
    1261       ij = 1 - kextj 
    1262       !! Scatter back to pt2d 
    1263       DO jj = jpj - ipj + 1 - kextj , jpj + kextj 
    1264          DO ji= 1, jpi 
    1265             pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 
    1266          END DO 
    1267          ij  = ij +1 
    1268       END DO 
    1269       ! 
    1270       DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 
    1271       ! 
    1272    END SUBROUTINE mpp_lbc_north_icb 
    1273  
    1274  
    1275    SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj ) 
    1276       !!---------------------------------------------------------------------- 
    1277       !!                  ***  routine mpp_lnk_2d_icb  *** 
    1278       !! 
    1279       !! ** Purpose :   Message passing management for 2d array (with extra halo for icebergs) 
    1280       !!                This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj) 
    1281       !!                array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls. 
    1282       !! 
    1283       !! ** Method  :   Use mppsend and mpprecv function for passing mask 
    1284       !!      between processors following neighboring subdomains. 
    1285       !!            domain parameters 
    1286       !!                    jpi    : first dimension of the local subdomain 
    1287       !!                    jpj    : second dimension of the local subdomain 
    1288       !!                    kexti  : number of columns for extra outer halo 
    1289       !!                    kextj  : number of rows for extra outer halo 
    1290       !!                    nbondi : mark for "east-west local boundary" 
    1291       !!                    nbondj : mark for "north-south local boundary" 
    1292       !!                    noea   : number for local neighboring processors 
    1293       !!                    nowe   : number for local neighboring processors 
    1294       !!                    noso   : number for local neighboring processors 
    1295       !!                    nono   : number for local neighboring processors 
    1296       !!---------------------------------------------------------------------- 
    1297       CHARACTER(len=*)                                        , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    1298       REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    1299       CHARACTER(len=1)                                        , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
    1300       REAL(wp)                                                , INTENT(in   ) ::   psgn     ! sign used across the north fold 
    1301       INTEGER                                                 , INTENT(in   ) ::   kexti    ! extra i-halo width 
    1302       INTEGER                                                 , INTENT(in   ) ::   kextj    ! extra j-halo width 
    1303       ! 
    1304       INTEGER  ::   jl   ! dummy loop indices 
    1305       INTEGER  ::   imigr, iihom, ijhom        ! local integers 
    1306       INTEGER  ::   ipreci, iprecj             !   -       - 
    1307       INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend 
    1308       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend 
    1309       !! 
    1310       REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) ::   r2dns, r2dsn 
    1311       REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) ::   r2dwe, r2dew 
    1312       !!---------------------------------------------------------------------- 
    1313  
    1314       ipreci = nn_hls + kexti      ! take into account outer extra 2D overlap area 
    1315       iprecj = nn_hls + kextj 
    1316  
    1317       IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. ) 
    1318  
    1319       ! 1. standard boundary treatment 
    1320       ! ------------------------------ 
    1321       ! Order matters Here !!!! 
    1322       ! 
    1323       !                                      ! East-West boundaries 
    1324       !                                           !* Cyclic east-west 
    1325       IF( l_Iperio ) THEN 
    1326          pt2d(1-kexti:     1   ,:) = pt2d(jpim1-kexti: jpim1 ,:)       ! east 
    1327          pt2d(  jpi  :jpi+kexti,:) = pt2d(     2     :2+kexti,:)       ! west 
    1328          ! 
    1329       ELSE                                        !* closed 
    1330          IF( .NOT. cd_type == 'F' )   pt2d(  1-kexti   :nn_hls   ,:) = 0._wp    ! east except at F-point 
    1331                                       pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp    ! west 
    1332       ENDIF 
    1333       !                                      ! North-South boundaries 
    1334       IF( l_Jperio ) THEN                         !* cyclic (only with no mpp j-split) 
    1335          pt2d(:,1-kextj:     1   ) = pt2d(:,jpjm1-kextj:  jpjm1)       ! north 
    1336          pt2d(:,  jpj  :jpj+kextj) = pt2d(:,     2     :2+kextj)       ! south 
    1337       ELSE                                        !* closed 
    1338          IF( .NOT. cd_type == 'F' )   pt2d(:,  1-kextj   :nn_hls   ) = 0._wp    ! north except at F-point 
    1339                                       pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp    ! south 
    1340       ENDIF 
    1341       ! 
    1342  
    1343       ! north fold treatment 
    1344       ! ----------------------- 
    1345       IF( npolj /= 0 ) THEN 
    1346          ! 
    1347          SELECT CASE ( jpni ) 
    1348                    CASE ( 1 )     ;   CALL lbc_nfd          ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
    1349                    CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj ) 
    1350          END SELECT 
    1351          ! 
    1352       ENDIF 
    1353  
    1354       ! 2. East and west directions exchange 
    1355       ! ------------------------------------ 
    1356       ! we play with the neigbours AND the row number because of the periodicity 
    1357       ! 
    1358       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    1359       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
    1360          iihom = jpi-nreci-kexti 
    1361          DO jl = 1, ipreci 
    1362             r2dew(:,jl,1) = pt2d(nn_hls+jl,:) 
    1363             r2dwe(:,jl,1) = pt2d(iihom +jl,:) 
    1364          END DO 
    1365       END SELECT 
    1366       ! 
    1367       !                           ! Migrations 
    1368       imigr = ipreci * ( jpj + 2*kextj ) 
    1369       ! 
    1370       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    1371       ! 
    1372       SELECT CASE ( nbondi ) 
    1373       CASE ( -1 ) 
    1374          CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 
    1375          CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
    1376          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1377       CASE ( 0 ) 
    1378          CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
    1379          CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 
    1380          CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) 
    1381          CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
    1382          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1383          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    1384       CASE ( 1 ) 
    1385          CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
    1386          CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
    1387          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1388       END SELECT 
    1389       ! 
    1390       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    1391       ! 
    1392       !                           ! Write Dirichlet lateral conditions 
    1393       iihom = jpi - nn_hls 
    1394       ! 
    1395       SELECT CASE ( nbondi ) 
    1396       CASE ( -1 ) 
    1397          DO jl = 1, ipreci 
    1398             pt2d(iihom+jl,:) = r2dew(:,jl,2) 
    1399          END DO 
    1400       CASE ( 0 ) 
    1401          DO jl = 1, ipreci 
    1402             pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
    1403             pt2d(iihom+jl,:) = r2dew(:,jl,2) 
    1404          END DO 
    1405       CASE ( 1 ) 
    1406          DO jl = 1, ipreci 
    1407             pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
    1408          END DO 
    1409       END SELECT 
    1410  
    1411  
    1412       ! 3. North and south directions 
    1413       ! ----------------------------- 
    1414       ! always closed : we play only with the neigbours 
    1415       ! 
    1416       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
    1417          ijhom = jpj-nrecj-kextj 
    1418          DO jl = 1, iprecj 
    1419             r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 
    1420             r2dns(:,jl,1) = pt2d(:,nn_hls+jl) 
    1421          END DO 
    1422       ENDIF 
    1423       ! 
    1424       !                           ! Migrations 
    1425       imigr = iprecj * ( jpi + 2*kexti ) 
    1426       ! 
    1427       IF( ln_timing ) CALL tic_tac(.TRUE.) 
    1428       ! 
    1429       SELECT CASE ( nbondj ) 
    1430       CASE ( -1 ) 
    1431          CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 
    1432          CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
    1433          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1434       CASE ( 0 ) 
    1435          CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
    1436          CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 
    1437          CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) 
    1438          CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
    1439          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1440          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    1441       CASE ( 1 ) 
    1442          CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
    1443          CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
    1444          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    1445       END SELECT 
    1446       ! 
    1447       IF( ln_timing ) CALL tic_tac(.FALSE.) 
    1448       ! 
    1449       !                           ! Write Dirichlet lateral conditions 
    1450       ijhom = jpj - nn_hls 
    1451       ! 
    1452       SELECT CASE ( nbondj ) 
    1453       CASE ( -1 ) 
    1454          DO jl = 1, iprecj 
    1455             pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
    1456          END DO 
    1457       CASE ( 0 ) 
    1458          DO jl = 1, iprecj 
    1459             pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
    1460             pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
    1461          END DO 
    1462       CASE ( 1 ) 
    1463          DO jl = 1, iprecj 
    1464             pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
    1465          END DO 
    1466       END SELECT 
    1467       ! 
    1468    END SUBROUTINE mpp_lnk_2d_icb 
    1469  
    1470  
    1471898   SUBROUTINE mpp_report( cdname, kpk, kpl, kpf, ld_lbc, ld_glb, ld_dlg ) 
    1472899      !!---------------------------------------------------------------------- 
    … …  
    1484911      INTEGER ::    ji,  jj,  jk,  jh, jf, jcount   ! dummy loop indices 
    1485912      !!---------------------------------------------------------------------- 
     913#if defined key_mpp_mpi 
    1486914      ! 
    1487915      ll_lbc = .FALSE. 
    … …  
    15941022         DEALLOCATE(crname_lbc) 
    15951023      ENDIF 
     1024#endif 
    15961025   END SUBROUTINE mpp_report 
    15971026 
    … …  
    16041033    REAL(wp),               SAVE :: tic_ct = 0._wp 
    16051034    INTEGER :: ii 
     1035#if defined key_mpp_mpi 
    16061036 
    16071037    IF( ncom_stp <= nit000 ) RETURN 
    … …  
    16191049       tic_ct = MPI_Wtime()                                                        ! start count tac->tic (waiting time) 
    16201050    ENDIF 
     1051#endif 
    16211052     
    16221053   END SUBROUTINE tic_tac 
    16231054 
     1055#if ! defined key_mpp_mpi 
     1056   SUBROUTINE mpi_wait(request, status, ierror) 
     1057      INTEGER                            , INTENT(in   ) ::   request 
     1058      INTEGER, DIMENSION(MPI_STATUS_SIZE), INTENT(  out) ::   status 
     1059      INTEGER                            , INTENT(  out) ::   ierror 
     1060   END SUBROUTINE mpi_wait 
     1061 
    16241062    
    1625 #else 
    1626    !!---------------------------------------------------------------------- 
    1627    !!   Default case:            Dummy module        share memory computing 
    1628    !!---------------------------------------------------------------------- 
    1629    USE in_out_manager 
    1630  
    1631    INTERFACE mpp_sum 
    1632       MODULE PROCEDURE mppsum_int, mppsum_a_int, mppsum_real, mppsum_a_real, mppsum_realdd, mppsum_a_realdd 
    1633    END INTERFACE 
    1634    INTERFACE mpp_max 
    1635       MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real 
    1636    END INTERFACE 
    1637    INTERFACE mpp_min 
    1638       MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real 
    1639    END INTERFACE 
    1640    INTERFACE mpp_minloc 
    1641       MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d 
    1642    END INTERFACE 
    1643    INTERFACE mpp_maxloc 
    1644       MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
    1645    END INTERFACE 
    1646  
    1647    LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag 
    1648    LOGICAL, PUBLIC            ::   ln_nnogather          !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used) 
    1649    INTEGER, PUBLIC            ::   mpi_comm_oce          ! opa local communicator 
    1650  
    1651    INTEGER, PARAMETER, PUBLIC               ::   nbdelay = 0   ! make sure we don't enter loops: DO ji = 1, nbdelay 
    1652    CHARACTER(len=32), DIMENSION(1), PUBLIC  ::   c_delaylist = 'empty' 
    1653    CHARACTER(len=32), DIMENSION(1), PUBLIC  ::   c_delaycpnt = 'empty' 
    1654    LOGICAL, PUBLIC                          ::   l_full_nf_update = .TRUE. 
    1655    TYPE ::   DELAYARR 
    1656       REAL(   wp), POINTER, DIMENSION(:) ::  z1d => NULL() 
    1657       COMPLEX(wp), POINTER, DIMENSION(:) ::  y1d => NULL() 
    1658    END TYPE DELAYARR 
    1659    TYPE( DELAYARR ), DIMENSION(1), PUBLIC  ::   todelay               
    1660    INTEGER,  PUBLIC, DIMENSION(1)           ::   ndelayid = -1 
    1661    !!---------------------------------------------------------------------- 
    1662 CONTAINS 
    1663  
    1664    INTEGER FUNCTION lib_mpp_alloc(kumout)          ! Dummy function 
    1665       INTEGER, INTENT(in) ::   kumout 
    1666       lib_mpp_alloc = 0 
    1667    END FUNCTION lib_mpp_alloc 
    1668  
    1669    FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg,  kumond , kstop, localComm ) RESULT (function_value) 
    1670       INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm 
    1671       CHARACTER(len=*),DIMENSION(:) ::   ldtxt 
    1672       CHARACTER(len=*) ::   ldname 
    1673       INTEGER ::   kumnam_ref, knumnam_cfg , kumond , kstop 
    1674       IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 
    1675       function_value = 0 
    1676       IF( .FALSE. )   ldtxt(:) = 'never done' 
    1677       CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 
    1678    END FUNCTION mynode 
    1679  
    1680    SUBROUTINE mppsync                       ! Dummy routine 
    1681    END SUBROUTINE mppsync 
    1682  
    1683    !!---------------------------------------------------------------------- 
    1684    !!    ***  mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real  *** 
    1685    !!    
    1686    !!---------------------------------------------------------------------- 
    1687    !! 
    1688 #  define OPERATION_MAX 
    1689 #  define INTEGER_TYPE 
    1690 #  define DIM_0d 
    1691 #     define ROUTINE_ALLREDUCE           mppmax_int 
    1692 #     include "mpp_allreduce_generic.h90" 
    1693 #     undef ROUTINE_ALLREDUCE 
    1694 #  undef DIM_0d 
    1695 #  define DIM_1d 
    1696 #     define ROUTINE_ALLREDUCE           mppmax_a_int 
    1697 #     include "mpp_allreduce_generic.h90" 
    1698 #     undef ROUTINE_ALLREDUCE 
    1699 #  undef DIM_1d 
    1700 #  undef INTEGER_TYPE 
    1701 ! 
    1702 #  define REAL_TYPE 
    1703 #  define DIM_0d 
    1704 #     define ROUTINE_ALLREDUCE           mppmax_real 
    1705 #     include "mpp_allreduce_generic.h90" 
    1706 #     undef ROUTINE_ALLREDUCE 
    1707 #  undef DIM_0d 
    1708 #  define DIM_1d 
    1709 #     define ROUTINE_ALLREDUCE           mppmax_a_real 
    1710 #     include "mpp_allreduce_generic.h90" 
    1711 #     undef ROUTINE_ALLREDUCE 
    1712 #  undef DIM_1d 
    1713 #  undef REAL_TYPE 
    1714 #  undef OPERATION_MAX 
    1715    !!---------------------------------------------------------------------- 
    1716    !!    ***  mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real  *** 
    1717    !!    
    1718    !!---------------------------------------------------------------------- 
    1719    !! 
    1720 #  define OPERATION_MIN 
    1721 #  define INTEGER_TYPE 
    1722 #  define DIM_0d 
    1723 #     define ROUTINE_ALLREDUCE           mppmin_int 
    1724 #     include "mpp_allreduce_generic.h90" 
    1725 #     undef ROUTINE_ALLREDUCE 
    1726 #  undef DIM_0d 
    1727 #  define DIM_1d 
    1728 #     define ROUTINE_ALLREDUCE           mppmin_a_int 
    1729 #     include "mpp_allreduce_generic.h90" 
    1730 #     undef ROUTINE_ALLREDUCE 
    1731 #  undef DIM_1d 
    1732 #  undef INTEGER_TYPE 
    1733 ! 
    1734 #  define REAL_TYPE 
    1735 #  define DIM_0d 
    1736 #     define ROUTINE_ALLREDUCE           mppmin_real 
    1737 #     include "mpp_allreduce_generic.h90" 
    1738 #     undef ROUTINE_ALLREDUCE 
    1739 #  undef DIM_0d 
    1740 #  define DIM_1d 
    1741 #     define ROUTINE_ALLREDUCE           mppmin_a_real 
    1742 #     include "mpp_allreduce_generic.h90" 
    1743 #     undef ROUTINE_ALLREDUCE 
    1744 #  undef DIM_1d 
    1745 #  undef REAL_TYPE 
    1746 #  undef OPERATION_MIN 
    1747  
    1748    !!---------------------------------------------------------------------- 
    1749    !!    ***  mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real  *** 
    1750    !!    
    1751    !!   Global sum of 1D array or a variable (integer, real or complex) 
    1752    !!---------------------------------------------------------------------- 
    1753    !! 
    1754 #  define OPERATION_SUM 
    1755 #  define INTEGER_TYPE 
    1756 #  define DIM_0d 
    1757 #     define ROUTINE_ALLREDUCE           mppsum_int 
    1758 #     include "mpp_allreduce_generic.h90" 
    1759 #     undef ROUTINE_ALLREDUCE 
    1760 #  undef DIM_0d 
    1761 #  define DIM_1d 
    1762 #     define ROUTINE_ALLREDUCE           mppsum_a_int 
    1763 #     include "mpp_allreduce_generic.h90" 
    1764 #     undef ROUTINE_ALLREDUCE 
    1765 #  undef DIM_1d 
    1766 #  undef INTEGER_TYPE 
    1767 ! 
    1768 #  define REAL_TYPE 
    1769 #  define DIM_0d 
    1770 #     define ROUTINE_ALLREDUCE           mppsum_real 
    1771 #     include "mpp_allreduce_generic.h90" 
    1772 #     undef ROUTINE_ALLREDUCE 
    1773 #  undef DIM_0d 
    1774 #  define DIM_1d 
    1775 #     define ROUTINE_ALLREDUCE           mppsum_a_real 
    1776 #     include "mpp_allreduce_generic.h90" 
    1777 #     undef ROUTINE_ALLREDUCE 
    1778 #  undef DIM_1d 
    1779 #  undef REAL_TYPE 
    1780 #  undef OPERATION_SUM 
    1781  
    1782 #  define OPERATION_SUM_DD 
    1783 #  define COMPLEX_TYPE 
    1784 #  define DIM_0d 
    1785 #     define ROUTINE_ALLREDUCE           mppsum_realdd 
    1786 #     include "mpp_allreduce_generic.h90" 
    1787 #     undef ROUTINE_ALLREDUCE 
    1788 #  undef DIM_0d 
    1789 #  define DIM_1d 
    1790 #     define ROUTINE_ALLREDUCE           mppsum_a_realdd 
    1791 #     include "mpp_allreduce_generic.h90" 
    1792 #     undef ROUTINE_ALLREDUCE 
    1793 #  undef DIM_1d 
    1794 #  undef COMPLEX_TYPE 
    1795 #  undef OPERATION_SUM_DD 
    1796  
    1797    !!---------------------------------------------------------------------- 
    1798    !!    ***  mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d 
    1799    !!    
    1800    !!---------------------------------------------------------------------- 
    1801    !! 
    1802 #  define OPERATION_MINLOC 
    1803 #  define DIM_2d 
    1804 #     define ROUTINE_LOC           mpp_minloc2d 
    1805 #     include "mpp_loc_generic.h90" 
    1806 #     undef ROUTINE_LOC 
    1807 #  undef DIM_2d 
    1808 #  define DIM_3d 
    1809 #     define ROUTINE_LOC           mpp_minloc3d 
    1810 #     include "mpp_loc_generic.h90" 
    1811 #     undef ROUTINE_LOC 
    1812 #  undef DIM_3d 
    1813 #  undef OPERATION_MINLOC 
    1814  
    1815 #  define OPERATION_MAXLOC 
    1816 #  define DIM_2d 
    1817 #     define ROUTINE_LOC           mpp_maxloc2d 
    1818 #     include "mpp_loc_generic.h90" 
    1819 #     undef ROUTINE_LOC 
    1820 #  undef DIM_2d 
    1821 #  define DIM_3d 
    1822 #     define ROUTINE_LOC           mpp_maxloc3d 
    1823 #     include "mpp_loc_generic.h90" 
    1824 #     undef ROUTINE_LOC 
    1825 #  undef DIM_3d 
    1826 #  undef OPERATION_MAXLOC 
    1827  
    1828    SUBROUTINE mpp_delay_sum( cdname, cdelay, y_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       COMPLEX(wp),      INTENT(in   ), DIMENSION(:) ::   y_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(:) = REAL(y_in(:), wp) 
    1837    END SUBROUTINE mpp_delay_sum 
    1838  
    1839    SUBROUTINE mpp_delay_max( cdname, cdelay, p_in, pout, ldlast, kcom ) 
    1840       CHARACTER(len=*), INTENT(in   )               ::   cdname  ! name of the calling subroutine 
    1841       CHARACTER(len=*), INTENT(in   )               ::   cdelay  ! name (used as id) of the delayed operation 
    1842       REAL(wp),         INTENT(in   ), DIMENSION(:) ::   p_in 
    1843       REAL(wp),         INTENT(  out), DIMENSION(:) ::   pout 
    1844       LOGICAL,          INTENT(in   )               ::   ldlast  ! true if this is the last time we call this routine 
    1845       INTEGER,          INTENT(in   ), OPTIONAL     ::   kcom 
    1846       ! 
    1847       pout(:) = p_in(:) 
    1848    END SUBROUTINE mpp_delay_max 
    1849  
    1850    SUBROUTINE mpp_delay_rcv( kid ) 
    1851       INTEGER,INTENT(in   )      ::  kid  
    1852       WRITE(*,*) 'mpp_delay_rcv: You should not have seen this print! error?', kid 
    1853    END SUBROUTINE mpp_delay_rcv 
    1854     
    1855    SUBROUTINE mppstop( ldfinal, ld_force_abort ) 
    1856       LOGICAL, OPTIONAL, INTENT(in) :: ldfinal    ! source process number 
    1857       LOGICAL, OPTIONAL, INTENT(in) :: ld_force_abort    ! source process number 
    1858       STOP      ! non MPP case, just stop the run 
    1859    END SUBROUTINE mppstop 
    1860  
    1861    SUBROUTINE mpp_ini_znl( knum ) 
    1862       INTEGER :: knum 
    1863       WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?', knum 
    1864    END SUBROUTINE mpp_ini_znl 
    1865  
    1866    SUBROUTINE mpp_comm_free( kcom ) 
    1867       INTEGER :: kcom 
    1868       WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom 
    1869    END SUBROUTINE mpp_comm_free 
    1870     
    1871 #endif 
    1872  
    1873    !!---------------------------------------------------------------------- 
    1874    !!   All cases:         ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam   routines 
     1063   FUNCTION MPI_Wtime() 
     1064      REAL(wp) ::  MPI_Wtime 
     1065      MPI_Wtime = -1. 
     1066   END FUNCTION MPI_Wtime 
     1067#endif 
     1068 
     1069   !!---------------------------------------------------------------------- 
     1070   !!   ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam   routines 
    18751071   !!---------------------------------------------------------------------- 
    18761072 
    … …  
    18831079      !!                increment the error number (nstop) by one. 
    18841080      !!---------------------------------------------------------------------- 
    1885       CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5 
    1886       CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10 
     1081      CHARACTER(len=*), INTENT(in   )           ::   cd1 
     1082      CHARACTER(len=*), INTENT(in   ), OPTIONAL ::        cd2, cd3, cd4, cd5 
     1083      CHARACTER(len=*), INTENT(in   ), OPTIONAL ::   cd6, cd7, cd8, cd9, cd10 
    18871084      !!---------------------------------------------------------------------- 
    18881085      ! 
    18891086      nstop = nstop + 1 
    1890  
    1891       ! force to open ocean.output file 
     1087      ! 
     1088      ! force to open ocean.output file if not already opened 
    18921089      IF( numout == 6 ) CALL ctl_opn( numout, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 
    1893         
    1894       WRITE(numout,cform_err) 
    1895       IF( PRESENT(cd1 ) )   WRITE(numout,*) TRIM(cd1) 
     1090      ! 
     1091                            WRITE(numout,*) 
     1092                            WRITE(numout,*) ' ===>>> : E R R O R' 
     1093                            WRITE(numout,*) 
     1094                            WRITE(numout,*) '         ===========' 
     1095                            WRITE(numout,*) 
     1096                            WRITE(numout,*) TRIM(cd1) 
    18961097      IF( PRESENT(cd2 ) )   WRITE(numout,*) TRIM(cd2) 
    18971098      IF( PRESENT(cd3 ) )   WRITE(numout,*) TRIM(cd3) 
    … …  
    19031104      IF( PRESENT(cd9 ) )   WRITE(numout,*) TRIM(cd9) 
    19041105      IF( PRESENT(cd10) )   WRITE(numout,*) TRIM(cd10) 
    1905  
     1106                            WRITE(numout,*) 
     1107      ! 
    19061108                               CALL FLUSH(numout    ) 
    19071109      IF( numstp     /= -1 )   CALL FLUSH(numstp    ) 
    … …  
    19101112      ! 
    19111113      IF( cd1 == 'STOP' ) THEN 
     1114         WRITE(numout,*)   
    19121115         WRITE(numout,*)  'huge E-R-R-O-R : immediate stop' 
    1913          CALL mppstop(ld_force_abort = .true.) 
     1116         WRITE(numout,*)   
     1117         CALL mppstop( ld_abort = .true. ) 
    19141118      ENDIF 
    19151119      ! 
    … …  
    19301134      ! 
    19311135      nwarn = nwarn + 1 
     1136      ! 
    19321137      IF(lwp) THEN 
    1933          WRITE(numout,cform_war) 
    1934          IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) 
    1935          IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 
    1936          IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) 
    1937          IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4) 
    1938          IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5) 
    1939          IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6) 
    1940          IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7) 
    1941          IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8) 
    1942          IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 
    1943          IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 
     1138                               WRITE(numout,*) 
     1139                               WRITE(numout,*) ' ===>>> : W A R N I N G' 
     1140                               WRITE(numout,*) 
     1141                               WRITE(numout,*) '         ===============' 
     1142                               WRITE(numout,*) 
     1143         IF( PRESENT(cd1 ) )   WRITE(numout,*) TRIM(cd1) 
     1144         IF( PRESENT(cd2 ) )   WRITE(numout,*) TRIM(cd2) 
     1145         IF( PRESENT(cd3 ) )   WRITE(numout,*) TRIM(cd3) 
     1146         IF( PRESENT(cd4 ) )   WRITE(numout,*) TRIM(cd4) 
     1147         IF( PRESENT(cd5 ) )   WRITE(numout,*) TRIM(cd5) 
     1148         IF( PRESENT(cd6 ) )   WRITE(numout,*) TRIM(cd6) 
     1149         IF( PRESENT(cd7 ) )   WRITE(numout,*) TRIM(cd7) 
     1150         IF( PRESENT(cd8 ) )   WRITE(numout,*) TRIM(cd8) 
     1151         IF( PRESENT(cd9 ) )   WRITE(numout,*) TRIM(cd9) 
     1152         IF( PRESENT(cd10) )   WRITE(numout,*) TRIM(cd10) 
     1153                               WRITE(numout,*) 
    19441154      ENDIF 
    19451155      CALL FLUSH(numout) 
    … …  
    19841194      IF( TRIM(cdfile) == '/dev/null' )   clfile = TRIM(cdfile)   ! force the use of /dev/null 
    19851195      ! 
    1986       iost=0 
    1987       IF( cdacce(1:6) == 'DIRECT' )  THEN         ! cdacce has always more than 6 characters 
     1196      IF(       cdacce(1:6) == 'DIRECT' )  THEN   ! cdacce has always more than 6 characters 
    19881197         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh         , ERR=100, IOSTAT=iost ) 
    19891198      ELSE IF( TRIM(cdstat) == 'APPEND' )  THEN   ! cdstat can have less than 6 characters 
    … …  
    20061215100   CONTINUE 
    20071216      IF( iost /= 0 ) THEN 
    2008          IF(ldwp) THEN 
    2009             WRITE(kout,*) 
    2010             WRITE(kout,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 
    2011             WRITE(kout,*) ' =======   ===  ' 
    2012             WRITE(kout,*) '           unit   = ', knum 
    2013             WRITE(kout,*) '           status = ', cdstat 
    2014             WRITE(kout,*) '           form   = ', cdform 
    2015             WRITE(kout,*) '           access = ', cdacce 
    2016             WRITE(kout,*) '           iostat = ', iost 
    2017             WRITE(kout,*) '           we stop. verify the file ' 
    2018             WRITE(kout,*) 
    2019          ELSE  !!! Force writing to make sure we get the information - at least once - in this violent STOP!! 
    2020             WRITE(*,*) 
    2021             WRITE(*,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 
    2022             WRITE(*,*) ' =======   ===  ' 
    2023             WRITE(*,*) '           unit   = ', knum 
    2024             WRITE(*,*) '           status = ', cdstat 
    2025             WRITE(*,*) '           form   = ', cdform 
    2026             WRITE(*,*) '           access = ', cdacce 
    2027             WRITE(*,*) '           iostat = ', iost 
    2028             WRITE(*,*) '           we stop. verify the file ' 
    2029             WRITE(*,*) 
    2030          ENDIF 
    2031          CALL FLUSH( kout )  
    2032          STOP 'ctl_opn bad opening' 
     1217         WRITE(ctmp1,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 
     1218         WRITE(ctmp2,*) ' =======   ===  ' 
     1219         WRITE(ctmp3,*) '           unit   = ', knum 
     1220         WRITE(ctmp4,*) '           status = ', cdstat 
     1221         WRITE(ctmp5,*) '           form   = ', cdform 
     1222         WRITE(ctmp6,*) '           access = ', cdacce 
     1223         WRITE(ctmp7,*) '           iostat = ', iost 
     1224         WRITE(ctmp8,*) '           we stop. verify the file ' 
     1225         CALL ctl_stop( 'STOP', ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 ) 
    20331226      ENDIF 
    20341227      ! 
    … …  
    20361229 
    20371230 
    2038    SUBROUTINE ctl_nam ( kios, cdnam, ldwp ) 
     1231   SUBROUTINE ctl_nam ( kios, cdnam ) 
    20391232      !!---------------------------------------------------------------------- 
    20401233      !!                  ***  ROUTINE ctl_nam  *** 
    … …  
    20441237      !! ** Method  :   Fortan open 
    20451238      !!---------------------------------------------------------------------- 
    2046       INTEGER         , INTENT(inout) ::   kios    ! IO status after reading the namelist 
    2047       CHARACTER(len=*), INTENT(in   ) ::   cdnam   ! group name of namelist for which error occurs 
    2048       CHARACTER(len=5)                ::   clios   ! string to convert iostat in character for print 
    2049       LOGICAL         , INTENT(in   ) ::   ldwp    ! boolean term for print 
     1239      INTEGER                                , INTENT(inout) ::   kios    ! IO status after reading the namelist 
     1240      CHARACTER(len=*)                       , INTENT(in   ) ::   cdnam   ! group name of namelist for which error occurs 
     1241      ! 
     1242      CHARACTER(len=5) ::   clios   ! string to convert iostat in character for print 
    20501243      !!---------------------------------------------------------------------- 
    20511244      ! 
    … …  
    20611254      ENDIF 
    20621255      kios = 0 
    2063       RETURN 
    20641256      ! 
    20651257   END SUBROUTINE ctl_nam 
    … …  
    20821274      END DO 
    20831275      IF( (get_unit == 999) .AND. llopn ) THEN 
    2084          CALL ctl_stop( 'get_unit: All logical units until 999 are used...' ) 
    2085          get_unit = -1 
     1276         CALL ctl_stop( 'STOP', 'get_unit: All logical units until 999 are used...' ) 
    20861277      ENDIF 
    20871278      ! 

  • NEMO/trunk/src/OCE/LBC/mpp_lnk_generic.h90

    r10542 r11536  
    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/trunk/src/OCE/LBC/mpp_nfd_generic.h90

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

    r11242 r11536  
    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 
    … …  
    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/trunk/src/OCE/LDF/ldfdyn.F90

    r10784 r11536  
    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 

  • NEMO/trunk/src/OCE/LDF/ldftra.F90

    r10425 r11536  
    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      ! 
    … …  
    512512      REWIND( numnam_ref )              ! Namelist namtra_eiv in reference namelist : eddy induced velocity param. 
    513513      READ  ( numnam_ref, namtra_eiv, IOSTAT = ios, ERR = 901) 
    514 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_eiv in reference namelist', lwp ) 
     514901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_eiv in reference namelist' ) 
    515515      ! 
    516516      REWIND( numnam_cfg )              ! Namelist namtra_eiv in configuration namelist : eddy induced velocity param. 
    517517      READ  ( numnam_cfg, namtra_eiv, IOSTAT = ios, ERR = 902 ) 
    518 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_eiv in configuration namelist', lwp ) 
     518902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_eiv in configuration namelist' ) 
    519519      IF(lwm)  WRITE ( numond, namtra_eiv ) 
    520520 

  • NEMO/trunk/src/OCE/OBS/diaobs.F90

    r10068 r11536  
    203203      REWIND( numnam_ref )   ! Namelist namobs in reference namelist 
    204204      READ  ( numnam_ref, namobs, IOSTAT = ios, ERR = 901) 
    205 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namobs in reference namelist', lwp ) 
     205901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namobs in reference namelist' ) 
    206206      REWIND( numnam_cfg )   ! Namelist namobs in configuration namelist 
    207207      READ  ( numnam_cfg, namobs, IOSTAT = ios, ERR = 902 ) 
    208 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namobs in configuration namelist', lwp ) 
     208902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namobs in configuration namelist' ) 
    209209      IF(lwm) WRITE ( numond, namobs ) 
    210210 

  • NEMO/trunk/src/OCE/SBC/fldread.F90

    r10425 r11536  
    4848   TYPE, PUBLIC ::   FLD_N      !: Namelist field informations 
    4949      CHARACTER(len = 256) ::   clname      ! generic name of the NetCDF flux file 
    50       REAL(wp)             ::   nfreqh      ! frequency of each flux file 
     50      REAL(wp)             ::   freqh       ! frequency of each flux file 
    5151      CHARACTER(len = 34)  ::   clvar       ! generic name of the variable in the NetCDF flux file 
    5252      LOGICAL              ::   ln_tint     ! time interpolation or not (T/F) 
    … …  
    6464      CHARACTER(len = 256)            ::   clrootname   ! generic name of the NetCDF file 
    6565      CHARACTER(len = 256)            ::   clname       ! current name of the NetCDF file 
    66       REAL(wp)                        ::   nfreqh       ! frequency of each flux file 
     66      REAL(wp)                        ::   freqh        ! frequency of each flux file 
    6767      CHARACTER(len = 34)             ::   clvar        ! generic name of the variable in the NetCDF flux file 
    6868      LOGICAL                         ::   ln_tint      ! time interpolation or not (T/F) 
    … …  
    8080      INTEGER                         ::   nreclast     ! last record to be read in the current file 
    8181      CHARACTER(len = 256)            ::   lsmname      ! current name of the NetCDF mask file acting as a key 
    82       INTEGER                         ::   igrd         ! grid type for bdy data 
    83       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 
    8489   END TYPE FLD 
    85  
    86    TYPE, PUBLIC ::   MAP_POINTER      !: Map from input data file to local domain 
    87       INTEGER, POINTER, DIMENSION(:)  ::  ptr           ! Array of integer pointers to 1D arrays 
    88       LOGICAL                         ::  ll_unstruc    ! Unstructured (T) or structured (F) boundary data file 
    89    END TYPE MAP_POINTER 
    9090 
    9191!$AGRIF_DO_NOT_TREAT 
    … …  
    129129CONTAINS 
    130130 
    131    SUBROUTINE fld_read( kt, kn_fsbc, sd, map, kit, kt_offset, jpk_bdy, fvl ) 
     131   SUBROUTINE fld_read( kt, kn_fsbc, sd, kit, kt_offset ) 
    132132      !!--------------------------------------------------------------------- 
    133133      !!                    ***  ROUTINE fld_read  *** 
    … …  
    144144      INTEGER  , INTENT(in   )               ::   kn_fsbc   ! sbc computation period (in time step)  
    145145      TYPE(FLD), INTENT(inout), DIMENSION(:) ::   sd        ! input field related variables 
    146       TYPE(MAP_POINTER),INTENT(in), OPTIONAL, DIMENSION(:) ::   map   ! global-to-local mapping indices 
    147146      INTEGER  , INTENT(in   ), OPTIONAL     ::   kit       ! subcycle timestep for timesplitting option 
    148147      INTEGER  , INTENT(in   ), OPTIONAL     ::   kt_offset ! provide fields at time other than "now" 
    … …  
    150149      !                                                     !   kt_offset = +1 => fields at "after"  time level 
    151150      !                                                     !   etc. 
    152       INTEGER  , INTENT(in   ), OPTIONAL     ::   jpk_bdy   ! number of vertical levels in the BDY data 
    153       LOGICAL  , INTENT(in   ), OPTIONAL     ::   fvl   ! number of vertical levels in the BDY data 
    154151      !! 
    155152      INTEGER  ::   itmp         ! local variable 
    … …  
    166163      REAL(wp) ::   ztintb       ! ratio applied to before records when doing time interpolation 
    167164      CHARACTER(LEN=1000) ::   clfmt  ! write format 
    168       TYPE(MAP_POINTER)   ::   imap   ! global-to-local mapping indices 
    169165      !!--------------------------------------------------------------------- 
    170166      ll_firstcall = kt == nit000 
    … …  
    175171      ENDIF 
    176172      IF( PRESENT(kt_offset) )   it_offset = kt_offset 
    177  
    178       imap%ptr => NULL() 
    179173 
    180174      ! Note that shifting time to be centrered in the middle of sbc time step impacts only nsec_* variables of the calendar  
    … …  
    188182      IF( ll_firstcall ) THEN                      ! initialization 
    189183         DO jf = 1, imf  
    190             IF( PRESENT(map) ) imap = map(jf) 
    191                IF( PRESENT(jpk_bdy) ) THEN 
    192                   CALL fld_init( kn_fsbc, sd(jf), imap, jpk_bdy, fvl )  ! read each before field (put them in after as they will be swapped) 
    193                ELSE 
    194                   CALL fld_init( kn_fsbc, sd(jf), imap )  ! read each before field (put them in after as they will be swapped) 
    195                ENDIF 
     184            IF( TRIM(sd(jf)%clrootname) == 'NOT USED' )   CYCLE 
     185            CALL fld_init( kn_fsbc, sd(jf) )       ! read each before field (put them in after as they will be swapped) 
    196186         END DO 
    197187         IF( lwp ) CALL wgt_print()                ! control print 
    … …  
    202192         ! 
    203193         DO jf = 1, imf                            ! ---   loop over field   --- ! 
    204              
     194 
     195            IF( TRIM(sd(jf)%clrootname) == 'NOT USED' )   CYCLE 
     196                       
    205197            IF( isecsbc > sd(jf)%nrec_a(2) .OR. ll_firstcall ) THEN    ! read/update the after data? 
    206  
    207                IF( PRESENT(map) )   imap = map(jf)   ! temporary definition of map 
    208198 
    209199               sd(jf)%nrec_b(:) = sd(jf)%nrec_a(:)                                  ! swap before record informations 
    … …  
    213203               CALL fld_rec( kn_fsbc, sd(jf), kt_offset = it_offset, kit = kit )    ! update after record informations 
    214204 
    215                ! if kn_fsbc*rdt is larger than nfreqh (which is kind of odd), 
     205               ! if kn_fsbc*rdt is larger than freqh (which is kind of odd), 
    216206               ! it is possible that the before value is no more the good one... we have to re-read it 
    217207               ! if before is not the last record of the file currently opened and after is the first record to be read 
    … …  
    222212                  itmp = sd(jf)%nrec_a(1)                       ! temporary storage 
    223213                  sd(jf)%nrec_a(1) = sd(jf)%nreclast            ! read the last record of the file currently opened 
    224                   CALL fld_get( sd(jf), imap )                  ! read after data 
     214                  CALL fld_get( sd(jf) )                        ! read after data 
    225215                  sd(jf)%fdta(:,:,:,1) = sd(jf)%fdta(:,:,:,2)   ! re-swap before record field 
    226216                  sd(jf)%nrec_b(1) = sd(jf)%nrec_a(1)           ! update before record informations 
    227                   sd(jf)%nrec_b(2) = sd(jf)%nrec_a(2) - NINT( sd(jf)%nfreqh * 3600 )  ! assume freq to be in hours in this case 
     217                  sd(jf)%nrec_b(2) = sd(jf)%nrec_a(2) - NINT( sd(jf)%freqh * 3600. )  ! assume freq to be in hours in this case 
    228218                  sd(jf)%rotn(1)   = sd(jf)%rotn(2)             ! update before rotate informations 
    229219                  sd(jf)%nrec_a(1) = itmp                       ! move back to after record  
    … …  
    234224               IF( sd(jf)%ln_tint ) THEN 
    235225                   
    236                   ! if kn_fsbc*rdt is larger than nfreqh (which is kind of odd), 
     226                  ! if kn_fsbc*rdt is larger than freqh (which is kind of odd), 
    237227                  ! it is possible that the before value is no more the good one... we have to re-read it 
    238228                  ! if before record is not just just before the after record... 
    … …  
    240230                     &                   .AND. sd(jf)%nrec_b(1) /= sd(jf)%nrec_a(1) - 1 ) THEN    
    241231                     sd(jf)%nrec_a(1) = sd(jf)%nrec_a(1) - 1       ! move back to before record 
    242                      CALL fld_get( sd(jf), imap )                  ! read after data 
     232                     CALL fld_get( sd(jf) )                        ! read after data 
    243233                     sd(jf)%fdta(:,:,:,1) = sd(jf)%fdta(:,:,:,2)   ! re-swap before record field 
    244234                     sd(jf)%nrec_b(1) = sd(jf)%nrec_a(1)           ! update before record informations 
    245                      sd(jf)%nrec_b(2) = sd(jf)%nrec_a(2) - NINT( sd(jf)%nfreqh * 3600 )  ! assume freq to be in hours in this case 
     235                     sd(jf)%nrec_b(2) = sd(jf)%nrec_a(2) - NINT( sd(jf)%freqh * 3600. )  ! assume freq to be in hours in this case 
    246236                     sd(jf)%rotn(1)   = sd(jf)%rotn(2)             ! update before rotate informations 
    247237                     sd(jf)%nrec_a(1) = sd(jf)%nrec_a(1) + 1       ! move back to after record 
    … …  
    268258                     ! year/month/week/day, next year/month/week/day file must exist 
    269259                     isecend = nsec_year + nsec1jan000 + (nitend - kt) * NINT(rdt)   ! second at the end of the run 
    270                      llstop = isecend > sd(jf)%nrec_a(2)                                   ! read more than 1 record of next year 
     260                     llstop = isecend > sd(jf)%nrec_a(2)                             ! read more than 1 record of next year 
    271261                     ! we suppose that the date of next file is next day (should be ok even for weekly files...) 
    272262                     CALL fld_clopn( sd(jf), nyear  + COUNT((/llnxtyr /))                                           ,         & 
    … …  
    277267                        CALL ctl_warn('next year/month/week/day file: '//TRIM(sd(jf)%clname)//     & 
    278268                           &     ' not present -> back to current year/month/day') 
    279                         CALL fld_clopn( sd(jf) )       ! back to the current year/month/day 
     269                        CALL fld_clopn( sd(jf) )               ! back to the current year/month/day 
    280270                        sd(jf)%nrec_a(1) = sd(jf)%nreclast     ! force to read the last record in the current year file 
    281271                     ENDIF 
    … …  
    285275                   
    286276               ! read after data 
    287                IF( PRESENT(jpk_bdy) ) THEN 
    288                   CALL fld_get( sd(jf), imap, jpk_bdy, fvl) 
    289                ELSE 
    290                   CALL fld_get( sd(jf), imap ) 
    291                ENDIF 
     277               CALL fld_get( sd(jf) ) 
     278                
    292279            ENDIF   ! read new data? 
    293280         END DO                                    ! --- end loop over field --- ! 
    … …  
    296283 
    297284         DO jf = 1, imf                            ! ---   loop over field   --- ! 
     285            ! 
     286            IF( TRIM(sd(jf)%clrootname) == 'NOT USED' )   CYCLE 
    298287            ! 
    299288            IF( sd(jf)%ln_tint ) THEN              ! temporal interpolation 
    … …  
    327316 
    328317 
    329    SUBROUTINE fld_init( kn_fsbc, sdjf, map , jpk_bdy, fvl) 
     318   SUBROUTINE fld_init( kn_fsbc, sdjf ) 
    330319      !!--------------------------------------------------------------------- 
    331320      !!                    ***  ROUTINE fld_init  *** 
    … …  
    336325      INTEGER  , INTENT(in   ) ::   kn_fsbc      ! sbc computation period (in time step)  
    337326      TYPE(FLD), INTENT(inout) ::   sdjf         ! input field related variables 
    338       TYPE(MAP_POINTER),INTENT(in) ::   map      ! global-to-local mapping indices 
    339       INTEGER  , INTENT(in), OPTIONAL :: jpk_bdy ! number of vertical levels in the BDY data 
    340       LOGICAL  , INTENT(in), OPTIONAL :: fvl     ! number of vertical levels in the BDY data 
    341327      !! 
    342328      LOGICAL :: llprevyr              ! are we reading previous year  file? 
    … …  
    351337      CHARACTER(LEN=1000) ::   clfmt   ! write format 
    352338      !!--------------------------------------------------------------------- 
     339      ! 
    353340      llprevyr   = .FALSE. 
    354341      llprevmth  = .FALSE. 
    … …  
    365352         ! 
    366353         IF( sdjf%nrec_a(1) == 0  ) THEN   ! we redefine record sdjf%nrec_a(1) with the last record of previous year file 
    367             IF    ( sdjf%nfreqh == -12 ) THEN   ! yearly mean 
     354            IF    ( NINT(sdjf%freqh) == -12 ) THEN   ! yearly mean 
    368355               IF( sdjf%cltype == 'yearly' ) THEN             ! yearly file 
    369356                  sdjf%nrec_a(1) = 1                                                       ! force to read the unique record 
    … …  
    372359                  CALL ctl_stop( "fld_init: yearly mean file must be in a yearly type of file: "//TRIM(sdjf%clrootname) ) 
    373360               ENDIF 
    374             ELSEIF( sdjf%nfreqh ==  -1 ) THEN   ! monthly mean 
     361            ELSEIF( NINT(sdjf%freqh) ==  -1 ) THEN   ! monthly mean 
    375362               IF( sdjf%cltype == 'monthly' ) THEN            ! monthly file 
    376363                  sdjf%nrec_a(1) = 1                                                       ! force to read the unique record 
    … …  
    381368                  llprevyr = .NOT. sdjf%ln_clim                                            ! use previous year  file? 
    382369               ENDIF 
    383             ELSE                                ! higher frequency mean (in hours)  
     370            ELSE                                     ! higher frequency mean (in hours)  
    384371               IF    ( sdjf%cltype      == 'monthly' ) THEN   ! monthly file 
    385                   sdjf%nrec_a(1) = NINT( 24 * nmonth_len(nmonth-1) / sdjf%nfreqh )         ! last record of previous month 
     372                  sdjf%nrec_a(1) = NINT( 24. * REAL(nmonth_len(nmonth-1),wp) / sdjf%freqh )! last record of previous month 
    386373                  llprevmth = .TRUE.                                                       ! use previous month file? 
    387374                  llprevyr  = llprevmth .AND. nmonth == 1                                  ! use previous year  file? 
    388375               ELSEIF( sdjf%cltype(1:4) == 'week'    ) THEN   ! weekly file 
    389376                  llprevweek = .TRUE.                                                      ! use previous week  file? 
    390                   sdjf%nrec_a(1) = NINT( 24 * 7 / sdjf%nfreqh )                            ! last record of previous week 
     377                  sdjf%nrec_a(1) = NINT( 24. * 7. / sdjf%freqh )                           ! last record of previous week 
    391378                  isec_week = NINT(rday) * 7                                               ! add a shift toward previous week 
    392379               ELSEIF( sdjf%cltype      == 'daily'   ) THEN   ! daily file 
    393                   sdjf%nrec_a(1) = NINT( 24 / sdjf%nfreqh )                                ! last record of previous day 
     380                  sdjf%nrec_a(1) = NINT( 24. / sdjf%freqh )                                ! last record of previous day 
    394381                  llprevday = .TRUE.                                                       ! use previous day   file? 
    395382                  llprevmth = llprevday .AND. nday   == 1                                  ! use previous month file? 
    396383                  llprevyr  = llprevmth .AND. nmonth == 1                                  ! use previous year  file? 
    397384               ELSE                                           ! yearly file 
    398                   sdjf%nrec_a(1) = NINT( 24 * nyear_len(0) / sdjf%nfreqh )                 ! last record of previous year  
     385                  sdjf%nrec_a(1) = NINT( 24. * REAL(nyear_len(0),wp) / sdjf%freqh )        ! last record of previous year  
    399386                  llprevyr = .NOT. sdjf%ln_clim                                            ! use previous year  file? 
    400387               ENDIF 
    … …  
    433420         ! 
    434421         ! read before data in after arrays(as we will swap it later) 
    435          IF( PRESENT(jpk_bdy) ) THEN 
    436             CALL fld_get( sdjf, map, jpk_bdy, fvl ) 
    437          ELSE 
    438             CALL fld_get( sdjf, map ) 
    439          ENDIF 
     422         CALL fld_get( sdjf ) 
    440423         ! 
    441424         clfmt = "('   fld_init : time-interpolation for ', a, ' read previous record = ', i6, ' at time = ', f7.2, ' days')" 
    … …  
    456439      !!              if sdjf%ln_tint = .FALSE. 
    457440      !!                  nrec_a(1): record number 
    458       !!                  nrec_b(2) and nrec_a(2): time of the beginning and end of the record (for print only) 
     441      !!                  nrec_b(2) and nrec_a(2): time of the beginning and end of the record 
    459442      !!---------------------------------------------------------------------- 
    460443      INTEGER  , INTENT(in   )           ::   kn_fsbc   ! sbc computation period (in time step)  
    … …  
    484467      ELSE                                      ;   it_offset = 0 
    485468      ENDIF 
    486       IF( PRESENT(kt_offset) )   it_offset = kt_offset 
     469      IF( PRESENT(kt_offset) )      it_offset = kt_offset 
    487470      IF( PRESENT(kit) ) THEN   ;   it_offset = ( kit + it_offset ) * NINT( rdt/REAL(nn_baro,wp) ) 
    488471      ELSE                      ;   it_offset =         it_offset   * NINT(       rdt            ) 
    489472      ENDIF 
    490473      ! 
    491       !                                      ! =========== ! 
    492       IF    ( sdjf%nfreqh == -12 ) THEN      ! yearly mean 
    493          !                                   ! =========== ! 
    494          ! 
    495          IF( sdjf%ln_tint ) THEN                 ! time interpolation, shift by 1/2 record 
     474      !                                           ! =========== ! 
     475      IF    ( NINT(sdjf%freqh) == -12 ) THEN      ! yearly mean 
     476         !                                        ! =========== ! 
     477         ! 
     478         IF( sdjf%ln_tint ) THEN                  ! time interpolation, shift by 1/2 record 
    496479            ! 
    497480            !                  INT( ztmp ) 
    … …  
    505488            !       forcing record :    1  
    506489            !                             
    507             ztmp = REAL( nsec_year, wp ) / ( REAL( nyear_len(1), wp ) * rday ) + 0.5 & 
    508            &       + REAL( it_offset, wp ) / ( REAL( nyear_len(1), wp ) * rday ) 
     490            ztmp =  REAL( nsec_year, wp ) / ( REAL( nyear_len(1), wp ) * rday ) + 0.5 & 
     491               &  + REAL( it_offset, wp ) / ( REAL( nyear_len(1), wp ) * rday ) 
    509492            sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/)) 
    510493            ! swap at the middle of the year 
    … …  
    514497                                    & INT(ztmp) * INT(rday) * nyear_len(1) + INT(ztmp) * NINT( 0.5 * rday) * nyear_len(2)  
    515498            ENDIF 
    516          ELSE                                    ! no time interpolation 
     499         ELSE                                     ! no time interpolation 
    517500            sdjf%nrec_a(1) = 1 
    518501            sdjf%nrec_a(2) = NINT(rday) * nyear_len(1) + nsec1jan000   ! swap at the end    of the year 
    … …  
    520503         ENDIF 
    521504         ! 
    522          !                                   ! ============ ! 
    523       ELSEIF( sdjf%nfreqh ==  -1 ) THEN      ! monthly mean ! 
    524          !                                   ! ============ ! 
    525          ! 
    526          IF( sdjf%ln_tint ) THEN                 ! time interpolation, shift by 1/2 record 
     505         !                                        ! ============ ! 
     506      ELSEIF( NINT(sdjf%freqh) ==  -1 ) THEN      ! monthly mean ! 
     507         !                                        ! ============ ! 
     508         ! 
     509         IF( sdjf%ln_tint ) THEN                  ! time interpolation, shift by 1/2 record 
    527510            ! 
    528511            !                  INT( ztmp ) 
    … …  
    536519            !       forcing record :  nmonth  
    537520            !                             
    538             ztmp = REAL( nsec_month, wp ) / ( REAL( nmonth_len(nmonth), wp ) * rday ) + 0.5 & 
    539            &       + REAL( it_offset, wp ) / ( REAL( nmonth_len(nmonth), wp ) * rday ) 
     521            ztmp =  REAL( nsec_month, wp ) / ( REAL( nmonth_len(nmonth), wp ) * rday ) + 0.5 & 
     522           &      + REAL( it_offset, wp ) / ( REAL( nmonth_len(nmonth), wp ) * rday ) 
    540523            imth = nmonth + INT( ztmp ) - COUNT((/llbefore/)) 
    541524            IF( sdjf%cltype == 'monthly' ) THEN   ;   sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/)) 
    … …  
    551534         ENDIF 
    552535         ! 
    553          !                                   ! ================================ ! 
    554       ELSE                                   ! higher frequency mean (in hours) 
    555          !                                   ! ================================ ! 
    556          ! 
    557          ifreq_sec = NINT( sdjf%nfreqh * 3600 )                                         ! frequency mean (in seconds) 
     536         !                                        ! ================================ ! 
     537      ELSE                                        ! higher frequency mean (in hours) 
     538         !                                        ! ================================ ! 
     539         ! 
     540         ifreq_sec = NINT( sdjf%freqh * 3600. )                                         ! frequency mean (in seconds) 
    558541         IF( sdjf%cltype(1:4) == 'week' )   isec_week = ksec_week( sdjf%cltype(6:8) )   ! since the first day of the current week 
    559542         ! number of second since the beginning of the file 
    … …  
    565548         ztmp = ztmp + 0.5 * REAL(kn_fsbc - 1, wp) * rdt + REAL( it_offset, wp )        ! centrered in the middle of sbc time step 
    566549         ztmp = ztmp + 0.01 * rdt                                                       ! avoid truncation error  
    567          IF( sdjf%ln_tint ) THEN                ! time interpolation, shift by 1/2 record 
     550         IF( sdjf%ln_tint ) THEN                 ! time interpolation, shift by 1/2 record 
    568551            ! 
    569552            !          INT( ztmp/ifreq_sec + 0.5 ) 
    … …  
    579562            !                    
    580563            ztmp= ztmp / REAL(ifreq_sec, wp) + 0.5 
    581          ELSE                                   ! no time interpolation 
     564         ELSE                                    ! no time interpolation 
    582565            ! 
    583566            !           INT( ztmp/ifreq_sec ) 
    … …  
    610593      ENDIF 
    611594      ! 
     595      IF( .NOT. sdjf%ln_tint ) sdjf%nrec_a(2) = sdjf%nrec_a(2) - 1   ! last second belongs to bext record : *----( 
     596      ! 
    612597   END SUBROUTINE fld_rec 
    613598 
    614599 
    615    SUBROUTINE fld_get( sdjf, map, jpk_bdy, fvl ) 
     600   SUBROUTINE fld_get( sdjf ) 
    616601      !!--------------------------------------------------------------------- 
    617602      !!                    ***  ROUTINE fld_get  *** 
    … …  
    620605      !!---------------------------------------------------------------------- 
    621606      TYPE(FLD)        , INTENT(inout) ::   sdjf   ! input field related variables 
    622       TYPE(MAP_POINTER), INTENT(in   ) ::   map    ! global-to-local mapping indices 
    623       INTEGER  , INTENT(in), OPTIONAL  ::   jpk_bdy ! number of vertical levels in the bdy data 
    624       LOGICAL  , INTENT(in), OPTIONAL  ::   fvl     ! number of vertical levels in the bdy data 
    625607      ! 
    626608      INTEGER ::   ipk      ! number of vertical levels of sdjf%fdta ( 2D: ipk=1 ; 3D: ipk=jpk ) 
    … …  
    634616      ipk = SIZE( sdjf%fnow, 3 ) 
    635617      ! 
    636       IF( ASSOCIATED(map%ptr) ) THEN 
    637          IF( PRESENT(jpk_bdy) ) THEN 
    638             IF( sdjf%ln_tint ) THEN   ;   CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2),                & 
    639                                                         sdjf%nrec_a(1), map, sdjf%igrd, sdjf%ibdy, jpk_bdy, fvl ) 
    640             ELSE                      ;   CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,:  ),                & 
    641                                                         sdjf%nrec_a(1), map, sdjf%igrd, sdjf%ibdy, jpk_bdy, fvl ) 
    642             ENDIF 
    643          ELSE 
    644             IF( sdjf%ln_tint ) THEN   ;   CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), map ) 
    645             ELSE                      ;   CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,:  ), sdjf%nrec_a(1), map ) 
    646             ENDIF 
    647          ENDIF         
     618      IF( ASSOCIATED(sdjf%imap) ) THEN 
     619         IF( sdjf%ln_tint ) THEN   ;   CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1),   & 
     620            &                                        sdjf%imap, sdjf%igrd, sdjf%ibdy, sdjf%ltotvel, sdjf%lzint ) 
     621         ELSE                      ;   CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,:  ), sdjf%nrec_a(1),   & 
     622            &                                        sdjf%imap, sdjf%igrd, sdjf%ibdy, sdjf%ltotvel, sdjf%lzint ) 
     623         ENDIF 
    648624      ELSE IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN 
    649625         CALL wgt_list( sdjf, iw ) 
    … …  
    700676   END SUBROUTINE fld_get 
    701677 
    702    SUBROUTINE fld_map( num, clvar, dta, nrec, map, igrd, ibdy, jpk_bdy, fvl ) 
     678    
     679   SUBROUTINE fld_map( knum, cdvar, pdta, krec, kmap, kgrd, kbdy, ldtotvel, ldzint ) 
    703680      !!--------------------------------------------------------------------- 
    704681      !!                    ***  ROUTINE fld_map  *** 
    … …  
    707684      !!                using a general mapping (for open boundaries) 
    708685      !!---------------------------------------------------------------------- 
    709  
    710       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 
    711  
    712       INTEGER                   , INTENT(in ) ::   num     ! stream number 
    713       CHARACTER(LEN=*)          , INTENT(in ) ::   clvar   ! variable name 
    714       REAL(wp), DIMENSION(:,:,:), INTENT(out) ::   dta     ! output field on model grid (2 dimensional) 
    715       INTEGER                   , INTENT(in ) ::   nrec    ! record number to read (ie time slice) 
    716       TYPE(MAP_POINTER)         , INTENT(in ) ::   map     ! global-to-local mapping indices 
    717       INTEGER  , INTENT(in), OPTIONAL         ::   igrd, ibdy, jpk_bdy  ! grid type, set number and number of vertical levels in the bdy data 
    718       LOGICAL  , INTENT(in), OPTIONAL         ::   fvl     ! grid type, set number and number of vertical levels in the bdy data 
    719       INTEGER                                 ::   jpkm1_bdy! number of vertical levels in the bdy data minus 1 
    720       !! 
    721       INTEGER                                 ::   ipi      ! length of boundary data on local process 
    722       INTEGER                                 ::   ipj      ! length of dummy dimension ( = 1 ) 
    723       INTEGER                                 ::   ipk      ! number of vertical levels of dta ( 2D: ipk=1 ; 3D: ipk=jpk ) 
    724       INTEGER                                 ::   ilendta  ! length of data in file 
    725       INTEGER                                 ::   idvar    ! variable ID 
    726       INTEGER                                 ::   ib, ik, ji, jj   ! loop counters 
    727       INTEGER                                 ::   ierr 
    728       REAL(wp)                                ::   fv          ! fillvalue  
    729       REAL(wp), POINTER, DIMENSION(:,:,:)     ::   dta_read    ! work space for global data 
    730       REAL(wp), POINTER, DIMENSION(:,:,:)     ::   dta_read_z  ! work space for global data 
    731       REAL(wp), POINTER, DIMENSION(:,:,:)     ::   dta_read_dz ! work space for global data 
    732       !!--------------------------------------------------------------------- 
    733       ! 
    734       ipi = SIZE( dta, 1 ) 
    735       ipj = 1 
    736       ipk = SIZE( dta, 3 ) 
    737       ! 
    738       idvar   = iom_varid( num, clvar ) 
    739       ilendta = iom_file(num)%dimsz(1,idvar) 
    740  
    741       IF ( ln_bdy ) THEN 
    742          ipj = iom_file(num)%dimsz(2,idvar) 
    743          IF( map%ll_unstruc) THEN   ! unstructured open boundary data file 
    744             dta_read => dta_global 
    745             IF( PRESENT(jpk_bdy) ) THEN 
    746                IF( jpk_bdy>0 ) THEN 
    747                   dta_read_z => dta_global_z 
    748                   dta_read_dz => dta_global_dz 
    749                   jpkm1_bdy = jpk_bdy-1 
    750                ENDIF 
    751             ENDIF 
    752          ELSE                       ! structured open boundary file 
    753             dta_read => dta_global2 
    754             IF( PRESENT(jpk_bdy) ) THEN 
    755                IF( jpk_bdy>0 ) THEN 
    756                   dta_read_z => dta_global2_z 
    757                   dta_read_dz => dta_global2_dz 
    758                   jpkm1_bdy = jpk_bdy-1 
    759                ENDIF 
    760             ENDIF 
    761          ENDIF 
    762       ENDIF 
    763  
    764       IF(lwp) WRITE(numout,*) 'Dim size for ',        TRIM(clvar),' is ', ilendta 
    765       IF(lwp) WRITE(numout,*) 'Number of levels for ',TRIM(clvar),' is ', ipk 
    766       ! 
    767       SELECT CASE( ipk ) 
    768       CASE(1)        ;    
    769       CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1    ), nrec ) 
    770          IF ( map%ll_unstruc) THEN ! unstructured open boundary data file 
    771             DO ib = 1, ipi 
    772               DO ik = 1, ipk 
    773                 dta(ib,1,ik) =  dta_read(map%ptr(ib),1,ik) 
    774               END DO 
    775             END DO 
    776          ELSE ! we assume that this is a structured open boundary file 
    777             DO ib = 1, ipi 
    778                jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 
    779                ji=map%ptr(ib)-(jj-1)*ilendta 
    780                DO ik = 1, ipk 
    781                   dta(ib,1,ik) =  dta_read(ji,jj,ik) 
    782                END DO 
    783             END DO 
    784          ENDIF 
     686      INTEGER                   , INTENT(in   ) ::   knum         ! stream number 
     687      CHARACTER(LEN=*)          , INTENT(in   ) ::   cdvar        ! variable name 
     688      REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   pdta         ! bdy output field on model grid 
     689      INTEGER                   , INTENT(in   ) ::   krec         ! record number to read (ie time slice) 
     690      INTEGER , DIMENSION(:)    , INTENT(in   ) ::   kmap         ! global-to-local bdy mapping indices 
     691      ! optional variables used for vertical interpolation: 
     692      INTEGER, OPTIONAL         , INTENT(in   ) ::   kgrd         ! grid type (t, u, v) 
     693      INTEGER, OPTIONAL         , INTENT(in   ) ::   kbdy         ! bdy number 
     694      LOGICAL, OPTIONAL         , INTENT(in   ) ::   ldtotvel     ! true if total ( = barotrop + barocline) velocity 
     695      LOGICAL, OPTIONAL         , INTENT(in   ) ::   ldzint       ! true if 3D variable requires a vertical interpolation 
     696      !! 
     697      INTEGER                                   ::   ipi          ! length of boundary data on local process 
     698      INTEGER                                   ::   ipj          ! length of dummy dimension ( = 1 ) 
     699      INTEGER                                   ::   ipk          ! number of vertical levels of pdta ( 2D: ipk=1 ; 3D: ipk=jpk ) 
     700      INTEGER                                   ::   ipkb         ! number of vertical levels in boundary data file 
     701      INTEGER                                   ::   idvar        ! variable ID 
     702      INTEGER                                   ::   indims       ! number of dimensions of the variable 
     703      INTEGER, DIMENSION(4)                     ::   idimsz       ! size of variable dimensions  
     704      REAL(wp)                                  ::   zfv          ! fillvalue  
     705      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   ::   zz_read      ! work space for global boundary data 
     706      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   ::   zdta_read    ! work space local data requiring vertical interpolation 
     707      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   ::   zdta_read_z  ! work space local data requiring vertical interpolation 
     708      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)   ::   zdta_read_dz ! work space local data requiring vertical interpolation 
     709      CHARACTER(LEN=1),DIMENSION(3)             ::   clgrid 
     710      LOGICAL                                   ::   lluld        ! is the variable using the unlimited dimension 
     711      LOGICAL                                   ::   llzint       ! local value of ldzint 
     712      !!--------------------------------------------------------------------- 
     713      ! 
     714      clgrid = (/'t','u','v'/) 
     715      ! 
     716      ipi = SIZE( pdta, 1 ) 
     717      ipj = SIZE( pdta, 2 )   ! must be equal to 1 
     718      ipk = SIZE( pdta, 3 ) 
     719      ! 
     720      llzint = .FALSE. 
     721      IF( PRESENT(ldzint) )   llzint = ldzint 
     722      ! 
     723      idvar = iom_varid( knum, cdvar, kndims = indims, kdimsz = idimsz, lduld = lluld  ) 
     724      IF( indims == 4 .OR. ( indims == 3 .AND. .NOT. lluld ) ) THEN   ;   ipkb = idimsz(3)   ! xy(zl)t or xy(zl) 
     725      ELSE                                                            ;   ipkb = 1           ! xy or xyt 
     726      ENDIF 
     727      ! 
     728      ALLOCATE( zz_read( idimsz(1), idimsz(2), ipkb ) )  ! ++++++++ !!! this can be very big...          
     729      ! 
     730      IF( ipk == 1 ) THEN 
     731 
     732         IF( ipkb /= 1 ) CALL ctl_stop( 'fld_map : we must have ipkb = 1 to read surface data' ) 
     733         CALL iom_get ( knum, jpdom_unknown, cdvar, zz_read(:,:,1), krec )   ! call iom_get with a 2D file 
     734         CALL fld_map_core( zz_read, kmap, pdta ) 
    785735 
    786736      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    787737      ! Do we include something here to adjust barotropic velocities ! 
    788738      ! in case of a depth difference between bdy files and          ! 
    789       ! bathymetry in the case ln_full_vel = .false. and jpk_bdy>0?  ! 
     739      ! bathymetry in the case ln_totvel = .false. and ipkb>0?       ! 
    790740      ! [as the enveloping and parital cells could change H]         ! 
    791741      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    792742 
    793       CASE DEFAULT   ; 
    794  
    795       IF( PRESENT(jpk_bdy) .AND. jpk_bdy>0 ) THEN       ! boundary data not on model grid: vertical interpolation 
    796          CALL iom_getatt(num, '_FillValue', fv, cdvar=clvar ) 
    797          dta_read(:,:,:) = -ABS(fv) 
    798          dta_read_z(:,:,:) = 0._wp 
    799          dta_read_dz(:,:,:) = 0._wp 
    800          CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1:jpk_bdy), nrec ) 
    801          SELECT CASE( igrd )                   
    802             CASE(1) 
    803                CALL iom_get ( num, jpdom_unknown, 'gdept', dta_read_z(1:ilendta,1:ipj,1:jpk_bdy) ) 
    804                CALL iom_get ( num, jpdom_unknown, 'e3t',  dta_read_dz(1:ilendta,1:ipj,1:jpk_bdy) ) 
    805             CASE(2)   
    806                CALL iom_get ( num, jpdom_unknown, 'gdepu', dta_read_z(1:ilendta,1:ipj,1:jpk_bdy) ) 
    807                CALL iom_get ( num, jpdom_unknown, 'e3u',  dta_read_dz(1:ilendta,1:ipj,1:jpk_bdy) ) 
    808             CASE(3) 
    809                CALL iom_get ( num, jpdom_unknown, 'gdepv', dta_read_z(1:ilendta,1:ipj,1:jpk_bdy) ) 
    810                CALL iom_get ( num, jpdom_unknown, 'e3v',  dta_read_dz(1:ilendta,1:ipj,1:jpk_bdy) ) 
    811          END SELECT 
    812  
    813       IF ( ln_bdy ) &  
    814          CALL fld_bdy_interp(dta_read, dta_read_z, dta_read_dz, map, jpk_bdy, igrd, ibdy, fv, dta, fvl, ilendta) 
    815  
    816       ELSE ! boundary data assumed to be on model grid 
    817           
    818          CALL iom_get ( num, jpdom_unknown, clvar, dta_read(1:ilendta,1:ipj,1:ipk), nrec )                     
    819          IF ( map%ll_unstruc) THEN ! unstructured open boundary data file 
    820             DO ib = 1, ipi 
    821               DO ik = 1, ipk 
    822                 dta(ib,1,ik) =  dta_read(map%ptr(ib),1,ik) 
    823               END DO 
     743      ELSE 
     744         ! 
     745         CALL iom_get ( knum, jpdom_unknown, cdvar, zz_read(:,:,:), krec )   ! call iom_get with a 3D file 
     746         ! 
     747         IF( ipkb /= ipk .OR. llzint ) THEN   ! boundary data not on model vertical grid : vertical interpolation 
     748            ! 
     749            IF( ipk == jpk .AND. iom_varid(knum,'gdep'//clgrid(kgrd)) /= -1 .AND. iom_varid(knum,'e3'//clgrid(kgrd)) /= -1 ) THEN 
     750                
     751               ALLOCATE( zdta_read(ipi,ipj,ipkb), zdta_read_z(ipi,ipj,ipkb), zdta_read_dz(ipi,ipj,ipkb) ) 
     752                 
     753               CALL fld_map_core( zz_read, kmap, zdta_read ) 
     754               CALL iom_get ( knum, jpdom_unknown, 'gdep'//clgrid(kgrd), zz_read )   ! read only once? Potential temporal evolution? 
     755               CALL fld_map_core( zz_read, kmap, zdta_read_z ) 
     756               CALL iom_get ( knum, jpdom_unknown,   'e3'//clgrid(kgrd), zz_read )   ! read only once? Potential temporal evolution? 
     757               CALL fld_map_core( zz_read, kmap, zdta_read_dz ) 
     758                
     759               CALL iom_getatt(knum, '_FillValue', zfv, cdvar=cdvar ) 
     760               CALL fld_bdy_interp(zdta_read, zdta_read_z, zdta_read_dz, pdta, kgrd, kbdy, zfv, ldtotvel) 
     761               DEALLOCATE( zdta_read, zdta_read_z, zdta_read_dz ) 
     762                
     763            ELSE 
     764               IF( ipk /= jpk ) CALL ctl_stop( 'fld_map : this should be an impossible case...' ) 
     765               WRITE(ctmp1,*) 'fld_map : vertical interpolation for bdy variable '//TRIM(cdvar)//' requires '  
     766               IF( iom_varid(knum, 'gdep'//clgrid(kgrd)) == -1 ) CALL ctl_stop( ctmp1//'gdep'//clgrid(kgrd)//' variable' ) 
     767               IF( iom_varid(knum,   'e3'//clgrid(kgrd)) == -1 ) CALL ctl_stop( ctmp1//  'e3'//clgrid(kgrd)//' variable' ) 
     768 
     769            ENDIF 
     770            ! 
     771         ELSE                            ! bdy data assumed to be the same levels as bdy variables 
     772            ! 
     773            CALL fld_map_core( zz_read, kmap, pdta ) 
     774            ! 
     775         ENDIF   ! ipkb /= ipk 
     776      ENDIF   ! ipk == 1 
     777       
     778      DEALLOCATE( zz_read ) 
     779 
     780   END SUBROUTINE fld_map 
     781 
     782      
     783   SUBROUTINE fld_map_core( pdta_read, kmap, pdta_bdy ) 
     784      !!--------------------------------------------------------------------- 
     785      !!                    ***  ROUTINE fld_map_core  *** 
     786      !! 
     787      !! ** Purpose :  inner core of fld_map 
     788      !!---------------------------------------------------------------------- 
     789      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pdta_read    ! global boundary data 
     790      INTEGER,  DIMENSION(:    ), INTENT(in   ) ::   kmap         ! global-to-local bdy mapping indices 
     791      REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   pdta_bdy     ! bdy output field on model grid 
     792      !! 
     793      INTEGER,  DIMENSION(3) ::   idim_read,  idim_bdy            ! arrays dimensions 
     794      INTEGER                ::   ji, jj, jk, jb                  ! loop counters 
     795      INTEGER                ::   im1 
     796      !!--------------------------------------------------------------------- 
     797      ! 
     798      idim_read = SHAPE( pdta_read ) 
     799      idim_bdy  = SHAPE( pdta_bdy  ) 
     800      ! 
     801      ! in all cases: idim_bdy(2) == 1 .AND. idim_read(1) * idim_read(2) == idim_bdy(1) 
     802      ! structured BDY with rimwidth > 1                     : idim_read(2) == rimwidth /= 1 
     803      ! structured BDY with rimwidth == 1 or unstructured BDY: idim_read(2) == 1 
     804      ! 
     805      IF( idim_read(2) > 1 ) THEN    ! structured BDY with rimwidth > 1   
     806         DO jk = 1, idim_bdy(3) 
     807            DO jb = 1, idim_bdy(1) 
     808               im1 = kmap(jb) - 1 
     809               jj = im1 / idim_read(1) + 1 
     810               ji = MOD( im1, idim_read(1) ) + 1 
     811               pdta_bdy(jb,1,jk) =  pdta_read(ji,jj,jk) 
    824812            END DO 
    825          ELSE ! we assume that this is a structured open boundary file 
    826             DO ib = 1, ipi 
    827                jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 
    828                ji=map%ptr(ib)-(jj-1)*ilendta 
    829                DO ik = 1, ipk 
    830                   dta(ib,1,ik) =  dta_read(ji,jj,ik) 
    831                END DO 
     813         END DO 
     814      ELSE 
     815         DO jk = 1, idim_bdy(3) 
     816            DO jb = 1, idim_bdy(1)   ! horizontal remap of bdy data on the local bdy  
     817               pdta_bdy(jb,1,jk) = pdta_read(kmap(jb),1,jk) 
    832818            END DO 
    833          ENDIF 
    834       ENDIF ! PRESENT(jpk_bdy) 
    835       END SELECT 
    836  
    837    END SUBROUTINE fld_map 
     819         END DO 
     820      ENDIF 
     821       
     822   END SUBROUTINE fld_map_core 
    838823    
    839    SUBROUTINE fld_bdy_interp(dta_read, dta_read_z, dta_read_dz, map, jpk_bdy, igrd, ibdy, fv, dta, fvl, ilendta) 
    840  
     824    
     825   SUBROUTINE fld_bdy_interp(pdta_read, pdta_read_z, pdta_read_dz, pdta, kgrd, kbdy, pfv, ldtotvel) 
    841826      !!--------------------------------------------------------------------- 
    842827      !!                    ***  ROUTINE fld_bdy_interp  *** 
    … …  
    847832      USE bdy_oce, ONLY:  idx_bdy         ! indexing for map <-> ij transformation 
    848833 
    849       REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(in )     ::   dta_read      ! work space for global data 
    850       REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(in )     ::   dta_read_z    ! work space for global data 
    851       REAL(wp), POINTER, DIMENSION(:,:,:), INTENT(in )     ::   dta_read_dz   ! work space for global data 
    852       REAL(wp) , INTENT(in)                                ::   fv            ! fillvalue and alternative -ABS(fv) 
    853       REAL(wp), DIMENSION(:,:,:), INTENT(out) ::   dta                        ! output field on model grid (2 dimensional) 
    854       TYPE(MAP_POINTER)         , INTENT(in ) ::   map                        ! global-to-local mapping indices 
    855       LOGICAL  , INTENT(in), OPTIONAL         ::   fvl                        ! grid type, set number and number of vertical levels in the bdy data 
    856       INTEGER  , INTENT(in)                   ::   igrd, ibdy, jpk_bdy        ! number of levels in bdy data 
    857       INTEGER  , INTENT(in)                   ::   ilendta                    ! length of data in file 
    858       !! 
    859       INTEGER                                 ::   ipi                        ! length of boundary data on local process 
    860       INTEGER                                 ::   ipj                        ! length of dummy dimension ( = 1 ) 
    861       INTEGER                                 ::   ipk                        ! number of vertical levels of dta ( 2D: ipk=1 ; 3D: ipk=jpk ) 
    862       INTEGER                                 ::   jpkm1_bdy                  ! number of levels in bdy data minus 1 
    863       INTEGER                                 ::   ib, ik, ikk                ! loop counters 
    864       INTEGER                                 ::   ji, jj, zij, zjj           ! temporary indices 
    865       REAL(wp)                                ::   zl, zi, zh                 ! tmp variable for current depth and interpolation factor 
    866       REAL(wp)                                ::   fv_alt, ztrans, ztrans_new ! fillvalue and alternative -ABS(fv) 
    867       CHARACTER (LEN=10)                      ::   ibstr 
     834      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pdta_read       ! data read in bdy file 
     835      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pdta_read_z     ! depth of the data read in bdy file 
     836      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pdta_read_dz    ! thickness of the levels in bdy file 
     837      REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   pdta            ! output field on model grid (2 dimensional) 
     838      REAL(wp)                  , INTENT(in   ) ::   pfv             ! fillvalue of the data read in bdy file 
     839      LOGICAL                   , INTENT(in   ) ::   ldtotvel        ! true if toal ( = barotrop + barocline) velocity 
     840      INTEGER                   , INTENT(in   ) ::   kgrd            ! grid type (t, u, v) 
     841      INTEGER                   , INTENT(in   ) ::   kbdy            ! bdy number 
     842      !! 
     843      INTEGER                                   ::   ipi             ! length of boundary data on local process 
     844      INTEGER                                   ::   ipkb            ! number of vertical levels in boundary data file 
     845      INTEGER                                   ::   jb, ji, jj, jk, jkb   ! loop counters 
     846      REAL(wp)                                  ::   zcoef 
     847      REAL(wp)                                  ::   zl, zi, zh      ! tmp variable for current depth and interpolation factor 
     848      REAL(wp)                                  ::   zfv_alt, ztrans, ztrans_new ! fillvalue and alternative -ABS(pfv) 
     849      REAL(wp), DIMENSION(jpk)                  ::   zdepth, zdhalf  ! level and half-level depth 
    868850      !!--------------------------------------------------------------------- 
    869851      
    870  
    871       ipi       = SIZE( dta, 1 ) 
    872       ipj       = SIZE( dta_read, 2 ) 
    873       ipk       = SIZE( dta, 3 ) 
    874       jpkm1_bdy = jpk_bdy-1 
     852      ipi  = SIZE( pdta, 1 ) 
     853      ipkb = SIZE( pdta_read, 3 ) 
    875854       
    876       fv_alt = -ABS(fv)  ! set _FillValue < 0 as we make use of MAXVAL and MAXLOC later 
    877       DO ib = 1, ipi 
    878             zij = idx_bdy(ibdy)%nbi(ib,igrd) 
    879             zjj = idx_bdy(ibdy)%nbj(ib,igrd) 
    880          IF(narea==2) WRITE(*,*) 'MAPI', ib, igrd, map%ptr(ib), narea-1, zij, zjj 
    881       ENDDO 
    882       ! 
    883       IF ( map%ll_unstruc ) THEN                            ! unstructured open boundary data file 
    884  
    885          DO ib = 1, ipi 
    886             DO ik = 1, jpk_bdy 
    887                IF( ( dta_read(map%ptr(ib),1,ik) == fv ) ) THEN 
    888                   dta_read_z(map%ptr(ib),1,ik)  = fv_alt ! safety: put fillvalue into external depth field so consistent with data 
    889                   dta_read_dz(map%ptr(ib),1,ik) = 0._wp  ! safety: put 0._wp into external thickness factors to ensure transport is correct 
     855      zfv_alt = -ABS(pfv)  ! set _FillValue < 0 as we make use of MAXVAL and MAXLOC later 
     856      ! 
     857      WHERE( pdta_read == pfv ) 
     858         pdta_read_z  = zfv_alt ! safety: put fillvalue into external depth field so consistent with data 
     859         pdta_read_dz = 0._wp   ! safety: put 0._wp into external thickness factors to ensure transport is correct 
     860      ENDWHERE 
     861       
     862      DO jb = 1, ipi 
     863         ji = idx_bdy(kbdy)%nbi(jb,kgrd) 
     864         jj = idx_bdy(kbdy)%nbj(jb,kgrd) 
     865         zh  = SUM(pdta_read_dz(jb,1,:) ) 
     866         ! 
     867         ! Warnings to flag differences in the input and model topgraphy - is this useful/necessary? 
     868         SELECT CASE( kgrd )                          
     869         CASE(1) 
     870            IF( ABS( (zh - ht_n(ji,jj)) / ht_n(ji,jj)) * tmask(ji,jj,1) > 0.01_wp ) THEN 
     871               WRITE(ctmp1,"(I10.10)") jb  
     872               CALL ctl_warn('fld_bdy_interp: T depths differ between grids at BDY point '//TRIM(ctmp1)//' by more than 1%') 
     873               !   IF(lwp) WRITE(numout,*) 'DEPTHT', zh, sum(e3t_n(ji,jj,:), mask=tmask(ji,jj,:)==1),  ht_n(ji,jj), jb, jb, ji, jj 
     874            ENDIF 
     875         CASE(2) 
     876            IF( ABS( (zh - hu_n(ji,jj)) * r1_hu_n(ji,jj)) * umask(ji,jj,1) > 0.01_wp ) THEN 
     877               WRITE(ctmp1,"(I10.10)") jb  
     878               CALL ctl_warn('fld_bdy_interp: U depths differ between grids at BDY point '//TRIM(ctmp1)//' by more than 1%') 
     879               !   IF(lwp) WRITE(numout,*) 'DEPTHU', zh, SUM(e3u_n(ji,jj,:), mask=umask(ji,jj,:)==1),  SUM(umask(ji,jj,:)), & 
     880               !      &                hu_n(ji,jj), jb, jb, ji, jj, narea-1, pdta_read(jb,1,:) 
     881            ENDIF 
     882         CASE(3) 
     883            IF( ABS( (zh - hv_n(ji,jj)) * r1_hv_n(ji,jj)) * vmask(ji,jj,1) > 0.01_wp ) THEN 
     884               WRITE(ctmp1,"(I10.10)") jb 
     885               CALL ctl_warn('fld_bdy_interp: V depths differ between grids at BDY point '//TRIM(ctmp1)//' by more than 1%') 
     886            ENDIF 
     887         END SELECT 
     888         ! 
     889         SELECT CASE( kgrd )                          
     890         CASE(1) 
     891            ! depth of T points: 
     892            zdepth(:) = gdept_n(ji,jj,:) 
     893         CASE(2) 
     894            ! depth of U points: we must not use gdept_n as we don't want to do a communication 
     895            !   --> copy what is done for gdept_n in domvvl... 
     896            zdhalf(1) = 0.0_wp 
     897            zdepth(1) = 0.5_wp * e3uw_n(ji,jj,1) 
     898            DO jk = 2, jpk                               ! vertical sum 
     899               !    zcoef = umask - wumask    ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 
     900               !                              ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) 
     901               !                              ! 0.5 where jk = mikt      
     902               !!gm ???????   BUG ?  gdept_n as well as gde3w_n  does not include the thickness of ISF ?? 
     903               zcoef = ( umask(ji,jj,jk) - wumask(ji,jj,jk) ) 
     904               zdhalf(jk) = zdhalf(jk-1) + e3u_n(ji,jj,jk-1) 
     905               zdepth(jk) =      zcoef  * ( zdhalf(jk  ) + 0.5 * e3uw_n(ji,jj,jk))  & 
     906                  &         + (1-zcoef) * ( zdepth(jk-1) +       e3uw_n(ji,jj,jk)) 
     907            END DO 
     908         CASE(3) 
     909            ! depth of V points: we must not use gdept_n as we don't want to do a communication 
     910            !   --> copy what is done for gdept_n in domvvl... 
     911            zdhalf(1) = 0.0_wp 
     912            zdepth(1) = 0.5_wp * e3vw_n(ji,jj,1) 
     913            DO jk = 2, jpk                               ! vertical sum 
     914               !    zcoef = vmask - wvmask    ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 
     915               !                              ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) 
     916               !                              ! 0.5 where jk = mikt      
     917               !!gm ???????   BUG ?  gdept_n as well as gde3w_n  does not include the thickness of ISF ?? 
     918               zcoef = ( vmask(ji,jj,jk) - wvmask(ji,jj,jk) ) 
     919               zdhalf(jk) = zdhalf(jk-1) + e3v_n(ji,jj,jk-1) 
     920               zdepth(jk) =      zcoef  * ( zdhalf(jk  ) + 0.5 * e3vw_n(ji,jj,jk))  & 
     921                  &         + (1-zcoef) * ( zdepth(jk-1) +       e3vw_n(ji,jj,jk)) 
     922            END DO 
     923         END SELECT 
     924         ! 
     925         DO jk = 1, jpk                       
     926            IF(     zdepth(jk) < pdta_read_z(jb,1,          1) ) THEN                ! above the first level of external data 
     927               pdta(jb,1,jk) =  pdta_read(jb,1,1) 
     928            ELSEIF( zdepth(jk) > pdta_read_z(jb,1,ipkb) ) THEN                       ! below the last level of external data  
     929               pdta(jb,1,jk) =  pdta_read(jb,1,MAXLOC(pdta_read_z(jb,1,:),1)) 
     930            ELSE                                                             ! inbetween: vertical interpolation between jkb & jkb+1 
     931               DO jkb = 1, ipkb-1                                            ! when  gdept_n(jkb) < zdepth(jk) < gdept_n(jkb+1) 
     932                  IF( ( ( zdepth(jk) - pdta_read_z(jb,1,jkb) ) * ( zdepth(jk) - pdta_read_z(jb,1,jkb+1) ) <= 0._wp ) & 
     933                     &    .AND. ( pdta_read_z(jb,1,jkb+1) /= zfv_alt) ) THEN   ! linear interpolation between 2 levels 
     934                     zi = ( zdepth(jk) - pdta_read_z(jb,1,jkb) ) / ( pdta_read_z(jb,1,jkb+1) - pdta_read_z(jb,1,jkb) ) 
     935                     pdta(jb,1,jk) = pdta_read(jb,1,jkb) + ( pdta_read  (jb,1,jkb+1) - pdta_read  (jb,1,jkb) ) * zi 
     936                  ENDIF 
     937               END DO 
     938            ENDIF 
     939         END DO   ! jpk 
     940         ! 
     941      END DO   ! ipi 
     942       
     943      IF(kgrd == 2) THEN                                  ! do we need to adjust the transport term? 
     944         DO jb = 1, ipi 
     945            ji = idx_bdy(kbdy)%nbi(jb,kgrd) 
     946            jj = idx_bdy(kbdy)%nbj(jb,kgrd) 
     947            zh  = SUM(pdta_read_dz(jb,1,:) ) 
     948            ztrans = 0._wp 
     949            ztrans_new = 0._wp 
     950            DO jkb = 1, ipkb                              ! calculate transport on input grid 
     951               ztrans     = ztrans     + pdta_read(jb,1,jkb) * pdta_read_dz(jb, 1,jkb) 
     952            ENDDO 
     953            DO jk = 1, jpk                                ! calculate transport on model grid 
     954               ztrans_new = ztrans_new +      pdta(jb,1,jk ) *        e3u_n(ji,jj,jk ) * umask(ji,jj,jk) 
     955            ENDDO 
     956            DO jk = 1, jpk                                ! make transport correction 
     957               IF(ldtotvel) THEN ! bdy data are total velocity so adjust bt transport term to match input data 
     958                  pdta(jb,1,jk) = ( pdta(jb,1,jk) + ( ztrans - ztrans_new ) * r1_hu_n(ji,jj) ) * umask(ji,jj,jk) 
     959               ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 
     960                  pdta(jb,1,jk) =   pdta(jb,1,jk) + (  0._wp - ztrans_new ) * r1_hu_n(ji,jj)   * umask(ji,jj,jk) 
    890961               ENDIF 
    891962            ENDDO 
    892          ENDDO  
    893  
    894          DO ib = 1, ipi 
    895             zij = idx_bdy(ibdy)%nbi(ib,igrd) 
    896             zjj = idx_bdy(ibdy)%nbj(ib,igrd) 
    897             zh  = SUM(dta_read_dz(map%ptr(ib),1,:) ) 
    898             ! Warnings to flag differences in the input and model topgraphy - is this useful/necessary? 
    899             SELECT CASE( igrd )                          
    900                CASE(1) 
    901                   IF( ABS( (zh - ht_n(zij,zjj)) / ht_n(zij,zjj)) * tmask(zij,zjj,1) > 0.01_wp ) THEN 
    902                      WRITE(ibstr,"(I10.10)") map%ptr(ib)  
    903                      CALL ctl_warn('fld_bdy_interp: T depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 
    904                  !   IF(lwp) WRITE(*,*) 'DEPTHT', zh, sum(e3t_n(zij,zjj,:), mask=tmask(zij,zjj,:)==1),  ht_n(zij,zjj), map%ptr(ib), ib, zij, zjj 
    905                   ENDIF 
    906                CASE(2) 
    907                   IF( ABS( (zh - hu_n(zij,zjj)) * r1_hu_n(zij,zjj)) * umask(zij,zjj,1) > 0.01_wp ) THEN 
    908                      WRITE(ibstr,"(I10.10)") map%ptr(ib)  
    909                      CALL ctl_warn('fld_bdy_interp: U depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 
    910                      IF(lwp) WRITE(*,*) 'DEPTHU', zh, sum(e3u_n(zij,zjj,:), mask=umask(zij,zjj,:)==1),  sum(umask(zij,zjj,:)), & 
    911                        &                hu_n(zij,zjj), map%ptr(ib), ib, zij, zjj, narea-1  , & 
    912                         &                dta_read(map%ptr(ib),1,:) 
    913                   ENDIF 
    914                CASE(3) 
    915                   IF( ABS( (zh - hv_n(zij,zjj)) * r1_hv_n(zij,zjj)) * vmask(zij,zjj,1) > 0.01_wp ) THEN 
    916                      WRITE(ibstr,"(I10.10)") map%ptr(ib)  
    917                      CALL ctl_warn('fld_bdy_interp: V depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 
    918                   ENDIF 
    919             END SELECT 
    920             DO ik = 1, ipk                       
    921                SELECT CASE( igrd )                        
    922                   CASE(1) 
    923                      zl =  gdept_n(zij,zjj,ik)                                          ! if using in step could use fsdept instead of gdept_n? 
    924                   CASE(2) 
    925                      IF(ln_sco) THEN 
    926                         zl =  ( gdept_n(zij,zjj,ik) + gdept_n(zij+1,zjj,ik) ) * 0.5_wp  ! if using in step could use fsdept instead of gdept_n? 
    927                      ELSE 
    928                         zl =  MIN( gdept_n(zij,zjj,ik), gdept_n(zij+1,zjj,ik) )  
    929                      ENDIF 
    930                   CASE(3) 
    931                      IF(ln_sco) THEN 
    932                         zl =  ( gdept_n(zij,zjj,ik) + gdept_n(zij,zjj+1,ik) ) * 0.5_wp  ! if using in step could use fsdept instead of gdept_n? 
    933                      ELSE 
    934                         zl =  MIN( gdept_n(zij,zjj,ik), gdept_n(zij,zjj+1,ik) ) 
    935                      ENDIF 
    936                END SELECT 
    937                IF( zl < dta_read_z(map%ptr(ib),1,1) ) THEN                                         ! above the first level of external data 
    938                   dta(ib,1,ik) =  dta_read(map%ptr(ib),1,1) 
    939                ELSEIF( zl > MAXVAL(dta_read_z(map%ptr(ib),1,:),1) ) THEN                           ! below the last level of external data  
    940                   dta(ib,1,ik) =  dta_read(map%ptr(ib),1,MAXLOC(dta_read_z(map%ptr(ib),1,:),1)) 
    941                ELSE                                                                                ! inbetween : vertical interpolation between ikk & ikk+1 
    942                   DO ikk = 1, jpkm1_bdy                                                            ! when  gdept_n(ikk) < zl < gdept_n(ikk+1) 
    943                      IF( ( (zl-dta_read_z(map%ptr(ib),1,ikk)) * (zl-dta_read_z(map%ptr(ib),1,ikk+1)) <= 0._wp) & 
    944                     &    .AND. (dta_read_z(map%ptr(ib),1,ikk+1) /= fv_alt)) THEN 
    945                         zi           = ( zl - dta_read_z(map%ptr(ib),1,ikk) ) / & 
    946                        &               ( dta_read_z(map%ptr(ib),1,ikk+1) - dta_read_z(map%ptr(ib),1,ikk) ) 
    947                         dta(ib,1,ik) = dta_read(map%ptr(ib),1,ikk) + & 
    948                        &               ( dta_read(map%ptr(ib),1,ikk+1) - dta_read(map%ptr(ib),1,ikk) ) * zi 
    949                      ENDIF 
    950                   END DO 
    951                ENDIF 
    952             END DO 
    953          END DO 
    954  
    955          IF(igrd == 2) THEN                                 ! do we need to adjust the transport term? 
    956             DO ib = 1, ipi 
    957               zij = idx_bdy(ibdy)%nbi(ib,igrd) 
    958               zjj = idx_bdy(ibdy)%nbj(ib,igrd) 
    959               zh  = SUM(dta_read_dz(map%ptr(ib),1,:) ) 
    960               ztrans = 0._wp 
    961               ztrans_new = 0._wp 
    962               DO ik = 1, jpk_bdy                            ! calculate transport on input grid 
    963                   ztrans     = ztrans     + dta_read(map%ptr(ib),1,ik) * dta_read_dz(map%ptr(ib),1,ik) 
    964               ENDDO 
    965               DO ik = 1, ipk                                ! calculate transport on model grid 
    966                   ztrans_new = ztrans_new + dta(ib,1,ik) * e3u_n(zij,zjj,ik) * umask(zij,zjj,ik) 
    967               ENDDO 
    968               DO ik = 1, ipk                                ! make transport correction 
    969                  IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data 
    970                     dta(ib,1,ik) = ( dta(ib,1,ik) + ( ztrans - ztrans_new ) * r1_hu_n(zij,zjj) ) * umask(zij,zjj,ik) 
    971                  ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 
    972                     IF( ABS(ztrans * r1_hu_n(zij,zjj)) > 0.01_wp ) & 
    973                    &   CALL ctl_warn('fld_bdy_interp: barotropic component of > 0.01 ms-1 found in baroclinic velocities at') 
    974                     dta(ib,1,ik) = dta(ib,1,ik) + ( 0._wp - ztrans_new ) * r1_hu_n(zij,zjj) * umask(zij,zjj,ik) 
    975                  ENDIF 
    976               ENDDO 
     963         ENDDO 
     964      ENDIF 
     965       
     966      IF(kgrd == 3) THEN                                  ! do we need to adjust the transport term? 
     967         DO jb = 1, ipi 
     968            ji = idx_bdy(kbdy)%nbi(jb,kgrd) 
     969            jj = idx_bdy(kbdy)%nbj(jb,kgrd) 
     970            zh  = SUM(pdta_read_dz(jb,1,:) ) 
     971            ztrans = 0._wp 
     972            ztrans_new = 0._wp 
     973            DO jkb = 1, ipkb                              ! calculate transport on input grid 
     974               ztrans     = ztrans     + pdta_read(jb,1,jkb) * pdta_read_dz(jb, 1,jkb) 
    977975            ENDDO 
    978          ENDIF 
    979  
    980          IF(igrd == 3) THEN                                 ! do we need to adjust the transport term? 
    981             DO ib = 1, ipi 
    982               zij = idx_bdy(ibdy)%nbi(ib,igrd) 
    983               zjj = idx_bdy(ibdy)%nbj(ib,igrd) 
    984               zh  = SUM(dta_read_dz(map%ptr(ib),1,:) ) 
    985               ztrans = 0._wp 
    986               ztrans_new = 0._wp 
    987               DO ik = 1, jpk_bdy                            ! calculate transport on input grid 
    988                   ztrans     = ztrans     + dta_read(map%ptr(ib),1,ik) * dta_read_dz(map%ptr(ib),1,ik) 
    989               ENDDO 
    990               DO ik = 1, ipk                                ! calculate transport on model grid 
    991                   ztrans_new = ztrans_new + dta(ib,1,ik) * e3v_n(zij,zjj,ik) * vmask(zij,zjj,ik) 
    992               ENDDO 
    993               DO ik = 1, ipk                                ! make transport correction 
    994                  IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data 
    995                     dta(ib,1,ik) = ( dta(ib,1,ik) + ( ztrans - ztrans_new ) * r1_hv_n(zij,zjj) ) * vmask(zij,zjj,ik) 
    996                  ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 
    997                     dta(ib,1,ik) = dta(ib,1,ik) + ( 0._wp - ztrans_new ) * r1_hv_n(zij,zjj) * vmask(zij,zjj,ik) 
    998                  ENDIF 
    999               ENDDO 
     976            DO jk = 1, jpk                                ! calculate transport on model grid 
     977               ztrans_new = ztrans_new +      pdta(jb,1,jk ) *        e3v_n(ji,jj,jk ) * vmask(ji,jj,jk) 
    1000978            ENDDO 
    1001          ENDIF 
    1002    
    1003       ELSE ! structured open boundary file 
    1004  
    1005          DO ib = 1, ipi 
    1006             jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 
    1007             ji=map%ptr(ib)-(jj-1)*ilendta 
    1008             DO ik = 1, jpk_bdy                       
    1009                IF( ( dta_read(ji,jj,ik) == fv ) ) THEN 
    1010                   dta_read_z(ji,jj,ik)  = fv_alt ! safety: put fillvalue into external depth field so consistent with data 
    1011                   dta_read_dz(ji,jj,ik) = 0._wp  ! safety: put 0._wp into external thickness factors to ensure transport is correct 
     979            DO jk = 1, jpk                                ! make transport correction 
     980               IF(ldtotvel) THEN ! bdy data are total velocity so adjust bt transport term to match input data 
     981                  pdta(jb,1,jk) = ( pdta(jb,1,jk) + ( ztrans - ztrans_new ) * r1_hv_n(ji,jj) ) * vmask(ji,jj,jk) 
     982               ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 
     983                  pdta(jb,1,jk) =   pdta(jb,1,jk) + (  0._wp - ztrans_new ) * r1_hv_n(ji,jj)   * vmask(ji,jj,jk) 
    1012984               ENDIF 
    1013985            ENDDO 
    1014          ENDDO  
    1015         
    1016  
    1017          DO ib = 1, ipi 
    1018             jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 
    1019             ji=map%ptr(ib)-(jj-1)*ilendta 
    1020             zij = idx_bdy(ibdy)%nbi(ib,igrd) 
    1021             zjj = idx_bdy(ibdy)%nbj(ib,igrd) 
    1022             zh  = SUM(dta_read_dz(ji,jj,:) ) 
    1023             ! Warnings to flag differences in the input and model topgraphy - is this useful/necessary? 
    1024             SELECT CASE( igrd )                          
    1025                CASE(1) 
    1026                   IF( ABS( (zh - ht_n(zij,zjj)) / ht_n(zij,zjj)) * tmask(zij,zjj,1) > 0.01_wp ) THEN 
    1027                      WRITE(ibstr,"(I10.10)") map%ptr(ib)  
    1028                      CALL ctl_warn('fld_bdy_interp: T depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 
    1029                  !   IF(lwp) WRITE(*,*) 'DEPTHT', zh, sum(e3t_n(zij,zjj,:), mask=tmask(zij,zjj,:)==1),  ht_n(zij,zjj), map%ptr(ib), ib, zij, zjj 
    1030                   ENDIF 
    1031                CASE(2) 
    1032                   IF( ABS( (zh - hu_n(zij,zjj)) * r1_hu_n(zij,zjj)) * umask(zij,zjj,1) > 0.01_wp ) THEN 
    1033                      WRITE(ibstr,"(I10.10)") map%ptr(ib)  
    1034                      CALL ctl_warn('fld_bdy_interp: U depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 
    1035                   ENDIF 
    1036                CASE(3) 
    1037                   IF( ABS( (zh - hv_n(zij,zjj)) * r1_hv_n(zij,zjj)) * vmask(zij,zjj,1) > 0.01_wp ) THEN 
    1038                      WRITE(ibstr,"(I10.10)") map%ptr(ib)  
    1039                      CALL ctl_warn('fld_bdy_interp: V depths differ between grids at BDY point '//TRIM(ibstr)//' by more than 1%') 
    1040                   ENDIF 
    1041             END SELECT 
    1042             DO ik = 1, ipk                       
    1043                SELECT CASE( igrd )                          ! coded for sco - need zco and zps option using min 
    1044                   CASE(1) 
    1045                      zl =  gdept_n(zij,zjj,ik)              ! if using in step could use fsdept instead of gdept_n? 
    1046                   CASE(2) 
    1047                      IF(ln_sco) THEN 
    1048                         zl =  ( gdept_n(zij,zjj,ik) + gdept_n(zij+1,zjj,ik) ) * 0.5_wp  ! if using in step could use fsdept instead of gdept_n? 
    1049                      ELSE 
    1050                         zl =  MIN( gdept_n(zij,zjj,ik), gdept_n(zij+1,zjj,ik) ) 
    1051                      ENDIF 
    1052                   CASE(3) 
    1053                      IF(ln_sco) THEN 
    1054                         zl =  ( gdept_n(zij,zjj,ik) + gdept_n(zij,zjj+1,ik) ) * 0.5_wp  ! if using in step could use fsdept instead of gdept_n? 
    1055                      ELSE 
    1056                         zl =  MIN( gdept_n(zij,zjj,ik), gdept_n(zij,zjj+1,ik) ) 
    1057                      ENDIF 
    1058                END SELECT 
    1059                IF( zl < dta_read_z(ji,jj,1) ) THEN                                      ! above the first level of external data 
    1060                   dta(ib,1,ik) =  dta_read(ji,jj,1) 
    1061                ELSEIF( zl > MAXVAL(dta_read_z(ji,jj,:),1) ) THEN                        ! below the last level of external data  
    1062                   dta(ib,1,ik) =  dta_read(ji,jj,MAXLOC(dta_read_z(ji,jj,:),1)) 
    1063                ELSE                                                                     ! inbetween : vertical interpolation between ikk & ikk+1 
    1064                   DO ikk = 1, jpkm1_bdy                                                 ! when  gdept_n(ikk) < zl < gdept_n(ikk+1) 
    1065                      IF( ( (zl-dta_read_z(ji,jj,ikk)) * (zl-dta_read_z(ji,jj,ikk+1)) <= 0._wp) & 
    1066                     &    .AND. (dta_read_z(ji,jj,ikk+1) /= fv_alt)) THEN 
    1067                         zi           = ( zl - dta_read_z(ji,jj,ikk) ) / & 
    1068                        &               ( dta_read_z(ji,jj,ikk+1) - dta_read_z(ji,jj,ikk) ) 
    1069                         dta(ib,1,ik) = dta_read(ji,jj,ikk) + & 
    1070                        &               ( dta_read(ji,jj,ikk+1) - dta_read(ji,jj,ikk) ) * zi 
    1071                      ENDIF 
    1072                   END DO 
    1073                ENDIF 
    1074             END DO 
    1075          END DO 
    1076  
    1077          IF(igrd == 2) THEN                                 ! do we need to adjust the transport term? 
    1078             DO ib = 1, ipi 
    1079                jj=1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 
    1080                ji=map%ptr(ib)-(jj-1)*ilendta 
    1081                zij = idx_bdy(ibdy)%nbi(ib,igrd) 
    1082                zjj = idx_bdy(ibdy)%nbj(ib,igrd) 
    1083                zh = SUM(dta_read_dz(ji,jj,:) ) 
    1084                ztrans = 0._wp 
    1085                ztrans_new = 0._wp 
    1086                DO ik = 1, jpk_bdy                            ! calculate transport on input grid 
    1087                   ztrans = ztrans + dta_read(ji,jj,ik) * dta_read_dz(ji,jj,ik) 
    1088                ENDDO 
    1089                DO ik = 1, ipk                                ! calculate transport on model grid 
    1090                   ztrans_new = ztrans_new + dta(ib,1,ik) * e3u_n(zij,zjj,ik) * umask(zij,zjj,ik) 
    1091                ENDDO 
    1092                DO ik = 1, ipk                                ! make transport correction 
    1093                   IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data 
    1094                      dta(ib,1,ik) = ( dta(ib,1,ik) + ( ztrans - ztrans_new ) * r1_hu_n(zij,zjj) ) * umask(zij,zjj,ik) 
    1095                   ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 
    1096                      dta(ib,1,ik) = ( dta(ib,1,ik) + ( 0._wp  - ztrans_new ) * r1_hu_n(zij,zjj) ) * umask(zij,zjj,ik) 
    1097                   ENDIF 
    1098                ENDDO 
    1099             ENDDO 
    1100          ENDIF 
    1101  
    1102          IF(igrd == 3) THEN                                 ! do we need to adjust the transport term? 
    1103             DO ib = 1, ipi 
    1104                jj  = 1+floor(REAL(map%ptr(ib)-1)/REAL(ilendta)) 
    1105                ji  = map%ptr(ib)-(jj-1)*ilendta 
    1106                zij = idx_bdy(ibdy)%nbi(ib,igrd) 
    1107                zjj = idx_bdy(ibdy)%nbj(ib,igrd) 
    1108                zh  = SUM(dta_read_dz(ji,jj,:) ) 
    1109                ztrans = 0._wp 
    1110                ztrans_new = 0._wp 
    1111                DO ik = 1, jpk_bdy                            ! calculate transport on input grid 
    1112                   ztrans     = ztrans     + dta_read(ji,jj,ik) * dta_read_dz(ji,jj,ik) 
    1113                ENDDO 
    1114                DO ik = 1, ipk                                ! calculate transport on model grid 
    1115                   ztrans_new = ztrans_new + dta(ib,1,ik) * e3v_n(zij,zjj,ik) * vmask(zij,zjj,ik) 
    1116                ENDDO 
    1117                DO ik = 1, ipk                                ! make transport correction 
    1118                   IF(fvl) THEN ! bdy data are total velocity so adjust bt transport term to match input data 
    1119                      dta(ib,1,ik) = ( dta(ib,1,ik) + ( ztrans - ztrans_new ) * r1_hv_n(zij,zjj) ) * vmask(zij,zjj,ik) 
    1120                   ELSE ! we're just dealing with bc velocity so bt transport term should sum to zero 
    1121                      dta(ib,1,ik) = ( dta(ib,1,ik) + ( 0._wp  - ztrans_new ) * r1_hv_n(zij,zjj) ) * vmask(zij,zjj,ik) 
    1122                   ENDIF 
    1123                ENDDO 
    1124             ENDDO 
    1125          ENDIF 
    1126  
    1127       ENDIF ! endif unstructured or structured 
    1128  
     986         ENDDO 
     987      ENDIF 
     988       
    1129989   END SUBROUTINE fld_bdy_interp 
    1130990 
    … …  
    11511011      imf = SIZE( sd ) 
    11521012      DO ju = 1, imf 
     1013         IF( TRIM(sd(ju)%clrootname) == 'NOT USED' )   CYCLE 
    11531014         ill = LEN_TRIM( sd(ju)%vcomp ) 
    11541015         DO jn = 2-COUNT((/sd(ju)%ln_tint/)), 2 
    … …  
    11591020                  iv = -1 
    11601021                  DO jv = 1, imf 
     1022                     IF( TRIM(sd(jv)%clrootname) == 'NOT USED' )   CYCLE 
    11611023                     IF( TRIM(sd(jv)%vcomp) == TRIM(clcomp) )   iv = jv 
    11621024                  END DO 
    … …  
    11971059      LOGICAL, OPTIONAL, INTENT(in   ) ::   ldstop   ! stop if open to read a non-existing file (default = .TRUE.) 
    11981060      ! 
    1199       LOGICAL :: llprevyr              ! are we reading previous year  file? 
    1200       LOGICAL :: llprevmth             ! are we reading previous month file? 
    1201       INTEGER :: iyear, imonth, iday   ! first day of the current file in yyyy mm dd 
    1202       INTEGER :: isec_week             ! number of seconds since start of the weekly file 
    1203       INTEGER :: indexyr               ! year undex (O/1/2: previous/current/next) 
    1204       INTEGER :: iyear_len, imonth_len ! length (days) of iyear and imonth             !  
    1205       CHARACTER(len = 256)::   clname  ! temporary file name 
     1061      LOGICAL  :: llprevyr              ! are we reading previous year  file? 
     1062      LOGICAL  :: llprevmth             ! are we reading previous month file? 
     1063      INTEGER  :: iyear, imonth, iday   ! first day of the current file in yyyy mm dd 
     1064      INTEGER  :: isec_week             ! number of seconds since start of the weekly file 
     1065      INTEGER  :: indexyr               ! year undex (O/1/2: previous/current/next) 
     1066      REAL(wp) :: zyear_len, zmonth_len ! length (days) of iyear and imonth             !  
     1067      CHARACTER(len = 256) ::   clname  ! temporary file name 
    12061068      !!---------------------------------------------------------------------- 
    12071069      IF( PRESENT(kyear) ) THEN                             ! use given values  
    … …  
    12541116         ! find the last record to be read -> update sdjf%nreclast 
    12551117         indexyr = iyear - nyear + 1 
    1256          iyear_len = nyear_len( indexyr ) 
     1118         zyear_len = REAL(nyear_len( indexyr ), wp) 
    12571119         SELECT CASE ( indexyr ) 
    1258          CASE ( 0 )   ;   imonth_len = 31   ! previous year -> imonth = 12 
    1259          CASE ( 1 )   ;   imonth_len = nmonth_len(imonth)  
    1260          CASE ( 2 )   ;   imonth_len = 31   ! next     year -> imonth = 1 
     1120         CASE ( 0 )   ;   zmonth_len = 31.   ! previous year -> imonth = 12 
     1121         CASE ( 1 )   ;   zmonth_len = REAL(nmonth_len(imonth), wp) 
     1122         CASE ( 2 )   ;   zmonth_len = 31.   ! next     year -> imonth = 1 
    12611123         END SELECT 
    12621124         ! 
    12631125         ! last record to be read in the current file 
    1264          IF    ( sdjf%nfreqh == -12 ) THEN                 ;   sdjf%nreclast = 1    !  yearly mean 
    1265          ELSEIF( sdjf%nfreqh ==  -1 ) THEN                                          ! monthly mean 
     1126         IF    ( sdjf%freqh == -12. ) THEN                 ;   sdjf%nreclast = 1    !  yearly mean 
     1127         ELSEIF( sdjf%freqh ==  -1. ) THEN                                          ! monthly mean 
    12661128            IF(     sdjf%cltype      == 'monthly' ) THEN   ;   sdjf%nreclast = 1 
    12671129            ELSE                                           ;   sdjf%nreclast = 12 
    12681130            ENDIF 
    12691131         ELSE                                                                       ! higher frequency mean (in hours) 
    1270             IF(     sdjf%cltype      == 'monthly' ) THEN   ;   sdjf%nreclast = NINT( 24 * imonth_len / sdjf%nfreqh ) 
    1271             ELSEIF( sdjf%cltype(1:4) == 'week'    ) THEN   ;   sdjf%nreclast = NINT( 24 * 7          / sdjf%nfreqh ) 
    1272             ELSEIF( sdjf%cltype      == 'daily'   ) THEN   ;   sdjf%nreclast = NINT( 24              / sdjf%nfreqh ) 
    1273             ELSE                                           ;   sdjf%nreclast = NINT( 24 * iyear_len  / sdjf%nfreqh ) 
     1132            IF(     sdjf%cltype      == 'monthly' ) THEN   ;   sdjf%nreclast = NINT( 24. * zmonth_len / sdjf%freqh ) 
     1133            ELSEIF( sdjf%cltype(1:4) == 'week'    ) THEN   ;   sdjf%nreclast = NINT( 24. * 7.         / sdjf%freqh ) 
     1134            ELSEIF( sdjf%cltype      == 'daily'   ) THEN   ;   sdjf%nreclast = NINT( 24.              / sdjf%freqh ) 
     1135            ELSE                                           ;   sdjf%nreclast = NINT( 24. * zyear_len  / sdjf%freqh ) 
    12741136            ENDIF 
    12751137         ENDIF 
    … …  
    12991161      ! 
    13001162      DO jf = 1, SIZE(sdf) 
    1301          sdf(jf)%clrootname = TRIM( cdir )//TRIM( sdf_n(jf)%clname ) 
     1163         sdf(jf)%clrootname = sdf_n(jf)%clname 
     1164         IF( TRIM(sdf_n(jf)%clname) /= 'NOT USED' )   sdf(jf)%clrootname = TRIM( cdir )//sdf(jf)%clrootname 
    13021165         sdf(jf)%clname     = "not yet defined" 
    1303          sdf(jf)%nfreqh     = sdf_n(jf)%nfreqh 
     1166         sdf(jf)%freqh      = sdf_n(jf)%freqh 
    13041167         sdf(jf)%clvar      = sdf_n(jf)%clvar 
    13051168         sdf(jf)%ln_tint    = sdf_n(jf)%ln_tint 
    … …  
    13081171         sdf(jf)%num        = -1 
    13091172         sdf(jf)%wgtname    = " " 
    1310          IF( LEN( TRIM(sdf_n(jf)%wname) ) > 0 )   sdf(jf)%wgtname = TRIM( cdir )//TRIM( sdf_n(jf)%wname ) 
     1173         IF( LEN( TRIM(sdf_n(jf)%wname) ) > 0 )   sdf(jf)%wgtname = TRIM( cdir )//sdf_n(jf)%wname 
    13111174         sdf(jf)%lsmname = " " 
    1312          IF( LEN( TRIM(sdf_n(jf)%lname) ) > 0 )   sdf(jf)%lsmname = TRIM( cdir )//TRIM( sdf_n(jf)%lname ) 
     1175         IF( LEN( TRIM(sdf_n(jf)%lname) ) > 0 )   sdf(jf)%lsmname = TRIM( cdir )//sdf_n(jf)%lname 
    13131176         sdf(jf)%vcomp      = sdf_n(jf)%vcomp 
    13141177         sdf(jf)%rotn(:)    = .TRUE.   ! pretend to be rotated -> won't try to rotate data before the first call to fld_get 
    … …  
    13171180         IF( sdf(jf)%cltype(1:4) == 'week' .AND. sdf(jf)%ln_clim )   & 
    13181181            &   CALL ctl_stop('fld_clopn: weekly file ('//TRIM(sdf(jf)%clrootname)//') needs ln_clim = .FALSE.') 
    1319          sdf(jf)%nreclast = -1 ! Set to non zero default value to avoid errors, is updated to meaningful value during fld_clopn 
     1182         sdf(jf)%nreclast   = -1 ! Set to non zero default value to avoid errors, is updated to meaningful value during fld_clopn 
     1183         sdf(jf)%igrd       = 0 
     1184         sdf(jf)%ibdy       = 0 
     1185         sdf(jf)%imap       => NULL() 
     1186         sdf(jf)%ltotvel    = .FALSE. 
     1187         sdf(jf)%lzint      = .FALSE. 
    13201188      END DO 
    13211189      ! 
    … …  
    13311199         DO jf = 1, SIZE(sdf) 
    13321200            WRITE(numout,*) '      root filename: '  , TRIM( sdf(jf)%clrootname ), '   variable name: ', TRIM( sdf(jf)%clvar ) 
    1333             WRITE(numout,*) '         frequency: '      ,       sdf(jf)%nfreqh      ,   & 
     1201            WRITE(numout,*) '         frequency: '      ,       sdf(jf)%freqh       ,   & 
    13341202               &                  '   time interp: '    ,       sdf(jf)%ln_tint     ,   & 
    13351203               &                  '   climatology: '    ,       sdf(jf)%ln_clim 

  • NEMO/trunk/src/OCE/SBC/sbcapr.F90

    r11204 r11536  
    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/trunk/src/OCE/SBC/sbcblk.F90

    r10535 r11536  
    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/trunk/src/OCE/SBC/sbccpl.F90

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

    r10425 r11536  
    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/trunk/src/OCE/SBC/sbcice_cice.F90

    r10425 r11536  
    764764         REWIND( numnam_ref )              ! Namelist namsbc_cice in reference namelist :  
    765765         READ  ( numnam_ref, namsbc_cice, IOSTAT = ios, ERR = 901) 
    766 901      IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_cice in reference namelist', lwp ) 
     766901      IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_cice in reference namelist' ) 
    767767 
    768768         REWIND( numnam_cfg )              ! Namelist namsbc_cice in configuration namelist : Parameters of the run 
    769769         READ  ( numnam_cfg, namsbc_cice, IOSTAT = ios, ERR = 902 ) 
    770 902      IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_cice in configuration namelist', lwp ) 
     770902      IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_cice in configuration namelist' ) 
    771771         IF(lwm) WRITE ( numond, namsbc_cice ) 
    772772 

  • NEMO/trunk/src/OCE/SBC/sbcice_if.F90

    r10068 r11536  
    7676         REWIND( numnam_ref )              ! Namelist namsbc_iif in reference namelist : Ice if file 
    7777         READ  ( numnam_ref, namsbc_iif, IOSTAT = ios, ERR = 901) 
    78 901      IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_iif in reference namelist', lwp ) 
     78901      IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_iif in reference namelist' ) 
    7979 
    8080         REWIND( numnam_cfg )              ! Namelist Namelist namsbc_iif in configuration namelist : Ice if file 
    8181         READ  ( numnam_cfg, namsbc_iif, IOSTAT = ios, ERR = 902 ) 
    82 902      IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_iif in configuration namelist', lwp ) 
     82902      IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_iif in configuration namelist' ) 
    8383         IF(lwm) WRITE ( numond, namsbc_iif ) 
    8484 

  • NEMO/trunk/src/OCE/SBC/sbcisf.F90

    r10536 r11536  
    278278      REWIND( numnam_ref )              ! Namelist namsbc_rnf in reference namelist : Runoffs  
    279279      READ  ( numnam_ref, namsbc_isf, IOSTAT = ios, ERR = 901) 
    280 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_isf in reference namelist', lwp ) 
     280901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_isf in reference namelist' ) 
    281281 
    282282      REWIND( numnam_cfg )              ! Namelist namsbc_rnf in configuration namelist : Runoffs 
    283283      READ  ( numnam_cfg, namsbc_isf, IOSTAT = ios, ERR = 902 ) 
    284 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_isf in configuration namelist', lwp ) 
     284902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_isf in configuration namelist' ) 
    285285      IF(lwm) WRITE ( numond, namsbc_isf ) 
    286286 

  • NEMO/trunk/src/OCE/SBC/sbcmod.F90

    r10499 r11536  
    110110      REWIND( numnam_ref )          !* Namelist namsbc in reference namelist : Surface boundary 
    111111      READ  ( numnam_ref, namsbc, IOSTAT = ios, ERR = 901) 
    112 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc in reference namelist', lwp ) 
     112901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc in reference namelist' ) 
    113113      REWIND( numnam_cfg )          !* Namelist namsbc in configuration namelist : Parameters of the run 
    114114      READ  ( numnam_cfg, namsbc, IOSTAT = ios, ERR = 902 ) 
    115 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc in configuration namelist', lwp ) 
     115902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc in configuration namelist' ) 
    116116      IF(lwm) WRITE( numond, namsbc ) 
    117117      ! 
    … …  
    307307      ! 
    308308      !                             !* check consistency between model timeline and nn_fsbc 
    309       IF( MOD( nitend - nit000 + 1, nn_fsbc) /= 0 .OR.   & 
    310           MOD( nstock             , nn_fsbc) /= 0 ) THEN 
    311          WRITE(ctmp1,*) 'sbc_init : experiment length (', nitend - nit000 + 1, ') or nstock (', nstock,   & 
    312             &           ' is NOT a multiple of nn_fsbc (', nn_fsbc, ')' 
    313          CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' ) 
     309      IF( ln_rst_list .OR. nn_stock /= -1 ) THEN   ! we will do restart files 
     310         IF( MOD( nitend - nit000 + 1, nn_fsbc) /= 0 ) THEN 
     311            WRITE(ctmp1,*) 'sbc_init : experiment length (', nitend - nit000 + 1, ') is NOT a multiple of nn_fsbc (', nn_fsbc, ')' 
     312            CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' ) 
     313         ENDIF 
     314         IF( .NOT. ln_rst_list .AND. MOD( nn_stock, nn_fsbc) /= 0 ) THEN   ! we don't use nn_stock if ln_rst_list 
     315            WRITE(ctmp1,*) 'sbc_init : nn_stock (', nn_stock, ') is NOT a multiple of nn_fsbc (', nn_fsbc, ')' 
     316            CALL ctl_stop( ctmp1, 'Impossible to properly do model restart' ) 
     317         ENDIF 
    314318      ENDIF 
    315319      ! 

  • NEMO/trunk/src/OCE/SBC/sbcrnf.F90

    r10523 r11536  
    267267      REWIND( numnam_ref )              ! Namelist namsbc_rnf in reference namelist : Runoffs  
    268268      READ  ( numnam_ref, namsbc_rnf, IOSTAT = ios, ERR = 901) 
    269 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_rnf in reference namelist', lwp ) 
     269901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_rnf in reference namelist' ) 
    270270 
    271271      REWIND( numnam_cfg )              ! Namelist namsbc_rnf in configuration namelist : Runoffs 
    272272      READ  ( numnam_cfg, namsbc_rnf, IOSTAT = ios, ERR = 902 ) 
    273 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_rnf in configuration namelist', lwp ) 
     273902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_rnf in configuration namelist' ) 
    274274      IF(lwm) WRITE ( numond, namsbc_rnf ) 
    275275      ! 

  • NEMO/trunk/src/OCE/SBC/sbcssr.F90

    r10068 r11536  
    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/trunk/src/OCE/SBC/sbcwave.F90

    r10425 r11536  
    397397      REWIND( numnam_ref )              ! Namelist namsbc_wave in reference namelist : File for drag coeff. from wave model 
    398398      READ  ( numnam_ref, namsbc_wave, IOSTAT = ios, ERR = 901) 
    399 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_wave in reference namelist', lwp ) 
     399901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc_wave in reference namelist' ) 
    400400          
    401401      REWIND( numnam_cfg )              ! Namelist namsbc_wave in configuration namelist : File for drag coeff. from wave model 
    402402      READ  ( numnam_cfg, namsbc_wave, IOSTAT = ios, ERR = 902 ) 
    403 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_wave in configuration namelist', lwp ) 
     403902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc_wave in configuration namelist' ) 
    404404      IF(lwm) WRITE ( numond, namsbc_wave ) 
    405405      ! 

  • NEMO/trunk/src/OCE/SBC/tideini.F90

    r10068 r11536  
    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/trunk/src/OCE/SBC/updtide.F90

    r10068 r11536  
    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/trunk/src/OCE/STO/stopar.F90

    r11341 r11536  
    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 
    … …  
    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/trunk/src/OCE/TRA/eosbn2.F90

    r10425 r11536  
    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 
    … …  
    12351237      REWIND( numnam_ref )              ! Namelist nameos in reference namelist : equation of state 
    12361238      READ  ( numnam_ref, nameos, IOSTAT = ios, ERR = 901 ) 
    1237 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nameos in reference namelist', lwp ) 
     1239901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nameos in reference namelist' ) 
    12381240      ! 
    12391241      REWIND( numnam_cfg )              ! Namelist nameos in configuration namelist : equation of state 
    12401242      READ  ( numnam_cfg, nameos, IOSTAT = ios, ERR = 902 ) 
    1241 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nameos in configuration namelist', lwp ) 
     1243902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nameos in configuration namelist' ) 
    12421244      IF(lwm) WRITE( numond, nameos ) 
    12431245      ! 
    … …  
    16471649         ! 
    16481650      CASE( np_seos )                        !==  Simplified EOS     ==! 
     1651 
     1652         r1_S0  = 0.875_wp/35.16504_wp   ! Used to convert CT in potential temperature when using bulk formulae (eos_pt_from_ct) 
     1653          
    16491654         IF(lwp) THEN 
    16501655            WRITE(numout,*) 

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

    r10068 r11536  
    196196      REWIND( numnam_ref )                   ! Namelist namtra_adv in reference namelist : Tracer advection scheme 
    197197      READ  ( numnam_ref, namtra_adv, IOSTAT = ios, ERR = 901) 
    198 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_adv in reference namelist', lwp ) 
     198901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_adv in reference namelist' ) 
    199199      ! 
    200200      REWIND( numnam_cfg )                   ! Namelist namtra_adv in configuration namelist : Tracer advection scheme 
    201201      READ  ( numnam_cfg, namtra_adv, IOSTAT = ios, ERR = 902 ) 
    202 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_adv in configuration namelist', lwp ) 
     202902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_adv in configuration namelist' ) 
    203203      IF(lwm) WRITE( numond, namtra_adv ) 
    204204      ! 

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

    r10425 r11536  
    135135      REWIND( numnam_ref )              ! Namelist nambbc in reference namelist : Bottom momentum boundary condition 
    136136      READ  ( numnam_ref, nambbc, IOSTAT = ios, ERR = 901) 
    137 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambbc in reference namelist', lwp ) 
     137901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambbc in reference namelist' ) 
    138138      ! 
    139139      REWIND( numnam_cfg )              ! Namelist nambbc in configuration namelist : Bottom momentum boundary condition 
    140140      READ  ( numnam_cfg, nambbc, IOSTAT = ios, ERR = 902 ) 
    141 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambbc in configuration namelist', lwp ) 
     141902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambbc in configuration namelist' ) 
    142142      IF(lwm) WRITE ( numond, nambbc ) 
    143143      ! 

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

    r10425 r11536  
    485485      REWIND( numnam_ref )              ! Namelist nambbl in reference namelist : Bottom boundary layer scheme 
    486486      READ  ( numnam_ref, nambbl, IOSTAT = ios, ERR = 901) 
    487 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambbl in reference namelist', lwp ) 
     487901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambbl in reference namelist' ) 
    488488      ! 
    489489      REWIND( numnam_cfg )              ! Namelist nambbl in configuration namelist : Bottom boundary layer scheme 
    490490      READ  ( numnam_cfg, nambbl, IOSTAT = ios, ERR = 902 ) 
    491 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambbl in configuration namelist', lwp ) 
     491902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambbl in configuration namelist' ) 
    492492      IF(lwm) WRITE ( numond, nambbl ) 
    493493      ! 

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

    r10425 r11536  
    179179      REWIND( numnam_ref )   ! Namelist namtra_dmp in reference namelist : T & S relaxation 
    180180      READ  ( numnam_ref, namtra_dmp, IOSTAT = ios, ERR = 901) 
    181 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_dmp in reference namelist', lwp ) 
     181901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_dmp in reference namelist' ) 
    182182      ! 
    183183      REWIND( numnam_cfg )   ! Namelist namtra_dmp in configuration namelist : T & S relaxation 
    184184      READ  ( numnam_cfg, namtra_dmp, IOSTAT = ios, ERR = 902 ) 
    185 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_dmp in configuration namelist', lwp ) 
     185902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_dmp in configuration namelist' ) 
    186186      IF(lwm) WRITE ( numond, namtra_dmp ) 
    187187      ! 

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

    r10068 r11536  
    289289         !!---------------------------------------------------------------------- 
    290290         ! 
    291          ztfw(1,:,:) = 0._wp     ;     ztfw(jpi,:,:) = 0._wp 
     291         ztfw(fs_2:1,:,:) = 0._wp     ;     ztfw(jpi:fs_jpim1,:,:) = 0._wp   ! avoid to potentially manipulate NaN values 
    292292         ! 
    293293         ! Vertical fluxes 
    … …  
    323323         IF( ln_traldf_lap ) THEN               ! laplacian case: eddy coef = ah_wslp2 - akz 
    324324            DO jk = 2, jpkm1        
    325                DO jj = 1, jpjm1 
     325               DO jj = 2, jpjm1 
    326326                  DO ji = fs_2, fs_jpim1 
    327327                     ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w_n(ji,jj,jk) * wmask(ji,jj,jk)   & 
    … …  
    336336            CASE(  1  )                            ! 1st pass : eddy coef = ah_wslp2 
    337337               DO jk = 2, jpkm1  
    338                   DO jj = 1, jpjm1 
     338                  DO jj = 2, jpjm1 
    339339                     DO ji = fs_2, fs_jpim1 
    340340                        ztfw(ji,jj,jk) = ztfw(ji,jj,jk)    & 
    … …  
    346346            CASE(  2  )                         ! 2nd pass : eddy flux = ah_wslp2 and akz applied on ptb  and ptbb gradients, resp. 
    347347               DO jk = 2, jpkm1  
    348                   DO jj = 1, jpjm1 
     348                  DO jj = 2, jpjm1 
    349349                     DO ji = fs_2, fs_jpim1 
    350350                        ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w_n(ji,jj,jk) * wmask(ji,jj,jk)                      & 

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

    r10425 r11536  
    268268      REWIND( numnam_ref )              ! Namelist namtra_mle in reference namelist : Tracer advection scheme 
    269269      READ  ( numnam_ref, namtra_mle, IOSTAT = ios, ERR = 901) 
    270 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_mle in reference namelist', lwp ) 
     270901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_mle in reference namelist' ) 
    271271 
    272272      REWIND( numnam_cfg )              ! Namelist namtra_mle in configuration namelist : Tracer advection scheme 
    273273      READ  ( numnam_cfg, namtra_mle, IOSTAT = ios, ERR = 902 ) 
    274 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_mle in configuration namelist', lwp ) 
     274902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_mle in configuration namelist' ) 
    275275      IF(lwm) WRITE ( numond, namtra_mle ) 
    276276 

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

    r11410 r11536  
    338338      REWIND( numnam_ref )              ! Namelist namtra_qsr in reference     namelist 
    339339      READ  ( numnam_ref, namtra_qsr, IOSTAT = ios, ERR = 901) 
    340 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_qsr in reference namelist', lwp ) 
     340901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_qsr in reference namelist' ) 
    341341      ! 
    342342      REWIND( numnam_cfg )              ! Namelist namtra_qsr in configuration namelist 
    343343      READ  ( numnam_cfg, namtra_qsr, IOSTAT = ios, ERR = 902 ) 
    344 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_qsr in configuration namelist', lwp ) 
     344902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_qsr in configuration namelist' ) 
    345345      IF(lwm) WRITE ( numond, namtra_qsr ) 
    346346      ! 

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

    r10068 r11536  
    4848      REWIND( numnam_ref )              ! Namelist namtrd in reference namelist : trends diagnostic 
    4949      READ  ( numnam_ref, namtrd, IOSTAT = ios, ERR = 901 ) 
    50 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtrd in reference namelist', lwp ) 
     50901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtrd in reference namelist' ) 
    5151      ! 
    5252      REWIND( numnam_cfg )              ! Namelist namtrd in configuration namelist : trends diagnostic 
    5353      READ  ( numnam_cfg, namtrd, IOSTAT = ios, ERR = 902 ) 
    54 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtrd in configuration namelist', lwp ) 
     54902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtrd in configuration namelist' ) 
    5555      IF(lwm) WRITE( numond, namtrd ) 
    5656      ! 

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

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

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

    r10425 r11536  
    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/trunk/src/OCE/TRD/trdvor.F90

    r10425 r11536  
    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   ! 
    … …  
    129129      !!              from ocean surface down to control surface (NetCDF output) 
    130130      !! 
    131       !! ** Method/usage :   integration done over nwrite-1 time steps 
     131      !! ** Method/usage :   integration done over nn_write-1 time steps 
    132132      !! 
    133133      !! ** Action :   trends : 
    … …  
    143143      !!                  vortrd (,,10) = forcing term 
    144144      !!                  vortrd (,,11) = bottom friction term 
    145       !!                  rotot(,) : total cumulative trends over nwrite-1 time steps 
     145      !!                  rotot(,) : total cumulative trends over nn_write-1 time steps 
    146146      !!                  vor_avrtot(,) : first membre of vrticity equation 
    147147      !!                  vor_avrres(,) : residual = dh/dt entrainment 
    … …  
    214214      !!              from ocean surface down to control surface (NetCDF output) 
    215215      !! 
    216       !! ** Method/usage :   integration done over nwrite-1 time steps 
     216      !! ** Method/usage :   integration done over nn_write-1 time steps 
    217217      !! 
    218218      !! ** Action :     trends : 
    … …  
    228228      !!                  vortrd (,,10) = forcing term 
    229229      !!      vortrd (,,11) = bottom friction term 
    230       !!                  rotot(,) : total cumulative trends over nwrite-1 time steps 
     230      !!                  rotot(,) : total cumulative trends over nn_write-1 time steps 
    231231      !!                  vor_avrtot(,) : first membre of vrticity equation 
    232232      !!                  vor_avrres(,) : residual = dh/dt entrainment 
    … …  
    360360      ENDIF 
    361361 
    362       ! II.2 cumulated trends over analysis period (kt=2 to nwrite) 
     362      ! II.2 cumulated trends over analysis period (kt=2 to nn_write) 
    363363      ! ---------------------- 
    364       ! trends cumulated over nwrite-2 time steps 
     364      ! trends cumulated over nn_write-2 time steps 
    365365 
    366366      IF( kt >= nit000+2 ) THEN 
    … …  
    376376      !   III. Output in netCDF + residual computation 
    377377      !  ============================================= 
    378  
     378       
    379379      ! define time axis 
    380380      it    = kt 
    … …  
    504504      ENDIF 
    505505#if defined key_diainstant 
    506       zsto = nwrite*rdt 
     506      zsto = nn_write*rdt 
    507507      clop = "inst("//TRIM(clop)//")" 
    508508#else 

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

    r10069 r11536  
    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/trunk/src/OCE/ZDF/zdfdrg.F90

    r10069 r11536  
    238238      REWIND( numnam_ref )                   ! Namelist namdrg in reference namelist 
    239239      READ  ( numnam_ref, namdrg, IOSTAT = ios, ERR = 901) 
    240 901   IF( ios /= 0 )   CALL ctl_nam( ios , 'namdrg in reference namelist', lwp ) 
     240901   IF( ios /= 0 )   CALL ctl_nam( ios , 'namdrg in reference namelist' ) 
    241241      REWIND( numnam_cfg )                   ! Namelist namdrg in configuration namelist 
    242242      READ  ( numnam_cfg, namdrg, IOSTAT = ios, ERR = 902 ) 
    243 902   IF( ios >  0 )   CALL ctl_nam( ios , 'namdrg in configuration namelist', lwp ) 
     243902   IF( ios >  0 )   CALL ctl_nam( ios , 'namdrg in configuration namelist' ) 
    244244      IF(lwm) WRITE ( numond, namdrg ) 
    245245      ! 
    … …  
    338338      IF(ll_top)   READ  ( numnam_ref, namdrg_top, IOSTAT = ios, ERR = 901) 
    339339      IF(ll_bot)   READ  ( numnam_ref, namdrg_bot, IOSTAT = ios, ERR = 901) 
    340 901   IF( ios /= 0 )   CALL ctl_nam( ios , TRIM(cl_namref), lwp ) 
     340901   IF( ios /= 0 )   CALL ctl_nam( ios , TRIM(cl_namref) ) 
    341341      REWIND( numnam_cfg )                   ! Namelist cd_namdrg in configuration namelist 
    342342      IF(ll_top)   READ  ( numnam_cfg, namdrg_top, IOSTAT = ios, ERR = 902 ) 
    343343      IF(ll_bot)   READ  ( numnam_cfg, namdrg_bot, IOSTAT = ios, ERR = 902 ) 
    344 902   IF( ios >  0 )   CALL ctl_nam( ios , TRIM(cl_namcfg), lwp ) 
     344902   IF( ios >  0 )   CALL ctl_nam( ios , TRIM(cl_namcfg) ) 
    345345      IF(lwm .AND. ll_top)   WRITE ( numond, namdrg_top ) 
    346346      IF(lwm .AND. ll_bot)   WRITE ( numond, namdrg_bot ) 

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

    r10425 r11536  
    859859      REWIND( numnam_ref )              ! Namelist namzdf_gls in reference namelist : Vertical eddy diffivity and viscosity using gls turbulent closure scheme 
    860860      READ  ( numnam_ref, namzdf_gls, IOSTAT = ios, ERR = 901) 
    861 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namzdf_gls in reference namelist', lwp ) 
     861901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namzdf_gls in reference namelist' ) 
    862862 
    863863      REWIND( numnam_cfg )              ! Namelist namzdf_gls in configuration namelist : Vertical eddy diffivity and viscosity using gls turbulent closure scheme 
    864864      READ  ( numnam_cfg, namzdf_gls, IOSTAT = ios, ERR = 902 ) 
    865 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namzdf_gls in configuration namelist', lwp ) 
     865902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namzdf_gls in configuration namelist' ) 
    866866      IF(lwm) WRITE ( numond, namzdf_gls ) 
    867867 

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

    r10425 r11536  
    424424      REWIND( numnam_ref )              ! Namelist namzdf_iwm in reference namelist : Wave-driven mixing 
    425425      READ  ( numnam_ref, namzdf_iwm, IOSTAT = ios, ERR = 901) 
    426 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namzdf_iwm in reference namelist', lwp ) 
     426901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namzdf_iwm in reference namelist' ) 
    427427      ! 
    428428      REWIND( numnam_cfg )              ! Namelist namzdf_iwm in configuration namelist : Wave-driven mixing 
    429429      READ  ( numnam_cfg, namzdf_iwm, IOSTAT = ios, ERR = 902 ) 
    430 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namzdf_iwm in configuration namelist', lwp ) 
     430902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namzdf_iwm in configuration namelist' ) 
    431431      IF(lwm) WRITE ( numond, namzdf_iwm ) 
    432432      ! 

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

    r10425 r11536  
    13861386     REWIND( numnam_ref )              ! Namelist namzdf_osm in reference namelist : Osmosis ML model 
    13871387     READ  ( numnam_ref, namzdf_osm, IOSTAT = ios, ERR = 901) 
    1388 901  IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_osm in reference namelist', lwp ) 
     1388901  IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_osm in reference namelist' ) 
    13891389 
    13901390     REWIND( numnam_cfg )              ! Namelist namzdf_tke in configuration namelist : Turbulent Kinetic Energy 
    13911391     READ  ( numnam_cfg, namzdf_osm, IOSTAT = ios, ERR = 902 ) 
    1392 902  IF( ios >  0 ) CALL ctl_nam ( ios , 'namzdf_osm in configuration namelist', lwp ) 
     1392902  IF( ios >  0 ) CALL ctl_nam ( ios , 'namzdf_osm in configuration namelist' ) 
    13931393     IF(lwm) WRITE ( numond, namzdf_osm ) 
    13941394 

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

    r10907 r11536  
    9393      REWIND( numnam_ref )              ! Namelist namzdf in reference namelist : Vertical mixing parameters 
    9494      READ  ( numnam_ref, namzdf, IOSTAT = ios, ERR = 901) 
    95 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namzdf in reference namelist', lwp ) 
     95901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namzdf in reference namelist' ) 
    9696      ! 
    9797      REWIND( numnam_cfg )              ! Namelist namzdf in reference namelist : Vertical mixing parameters 
    9898      READ  ( numnam_cfg, namzdf, IOSTAT = ios, ERR = 902 ) 
    99 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namzdf in configuration namelist', lwp ) 
     99902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namzdf in configuration namelist' ) 
    100100      IF(lwm)   WRITE ( numond, namzdf ) 
    101101      ! 

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

    r10068 r11536  
    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/trunk/src/OCE/ZDF/zdftke.F90

    r10425 r11536  
    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/trunk/src/OCE/module_example

    r10425 r11536  
    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/trunk/src/OCE/nemogcm.F90

    r10588 r11536  
    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      ! 
    … …  
    188191         ! 
    189192         DO WHILE( istp <= nitend .AND. nstop == 0 ) 
    190 #if defined key_mpp_mpi 
     193 
    191194            ncom_stp = istp 
    192             IF ( istp == ( nit000 + 1 ) ) elapsed_time = MPI_Wtime() 
    193             IF ( istp ==         nitend ) elapsed_time = MPI_Wtime() - elapsed_time 
    194 #endif 
     195            IF( ln_timing ) THEN 
     196               zstptiming = MPI_Wtime() 
     197               IF ( istp == ( nit000 + 1 ) ) elapsed_time = zstptiming 
     198               IF ( istp ==         nitend ) elapsed_time = zstptiming - elapsed_time 
     199            ENDIF 
     200             
    195201            CALL stp        ( istp )  
    196202            istp = istp + 1 
     203 
     204            IF( lwp .AND. ln_timing )   WRITE(numtime,*) 'timing step ', istp-1, ' : ', MPI_Wtime() - zstptiming 
     205 
    197206         END DO 
    198207         ! 
    … …  
    220229      ! 
    221230      IF( nstop /= 0 .AND. lwp ) THEN        ! error print 
    222          WRITE(numout,cform_err) 
    223          WRITE(numout,*) '   ==>>>   nemo_gcm: a total of ', nstop, ' errors have been found' 
    224          WRITE(numout,*) 
     231         WRITE(ctmp1,*) '   ==>>>   nemo_gcm: a total of ', nstop, ' errors have been found' 
     232         CALL ctl_stop( ctmp1 ) 
    225233      ENDIF 
    226234      ! 
    … …  
    234242#else 
    235243      IF    ( lk_oasis ) THEN   ;   CALL cpl_finalize   ! end coupling and mpp communications with OASIS 
    236       ELSEIF( lk_mpp   ) THEN   ;   CALL mppstop( ldfinal = .TRUE. )   ! end mpp communications 
     244      ELSEIF( lk_mpp   ) THEN   ;   CALL mppstop      ! end mpp communications 
    237245      ENDIF 
    238246#endif 
    … …  
    240248      IF(lwm) THEN 
    241249         IF( nstop == 0 ) THEN   ;   STOP 0 
    242          ELSE                    ;   STOP 999 
     250         ELSE                    ;   STOP 123 
    243251         ENDIF 
    244252      ENDIF 
    … …  
    253261      !! ** Purpose :   initialization of the NEMO GCM 
    254262      !!---------------------------------------------------------------------- 
    255       INTEGER  ::   ji                 ! dummy loop indices 
    256       INTEGER  ::   ios, ilocal_comm   ! local integers 
    257       CHARACTER(len=120), DIMENSION(60) ::   cltxt, cltxt2, clnam 
     263      INTEGER ::   ios, ilocal_comm   ! local integers 
    258264      !! 
    259265      NAMELIST/namctl/ ln_ctl   , sn_cfctl, nn_print, nn_ictls, nn_ictle,   & 
    … …  
    263269      !!---------------------------------------------------------------------- 
    264270      ! 
    265       cltxt  = '' 
    266       cltxt2 = '' 
    267       clnam  = ''   
    268271      cxios_context = 'nemo' 
    269272      ! 
    270       !                             ! Open reference namelist and configuration namelist files 
    271       CALL ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 
    272       CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 
    273       ! 
    274       REWIND( numnam_ref )              ! Namelist namctl in reference namelist 
    275       READ  ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 ) 
    276 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namctl in reference namelist', .TRUE. ) 
    277       REWIND( numnam_cfg )              ! Namelist namctl in confguration namelist 
    278       READ  ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 ) 
    279 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namctl in configuration namelist', .TRUE. ) 
    280       ! 
    281       REWIND( numnam_ref )              ! Namelist namcfg in reference namelist 
    282       READ  ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 ) 
    283 903   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namcfg in reference namelist', .TRUE. ) 
    284       REWIND( numnam_cfg )              ! Namelist namcfg in confguration namelist 
    285       READ  ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 ) 
    286 904   IF( ios >  0 )   CALL ctl_nam ( ios , 'namcfg in configuration namelist', .TRUE. )    
    287  
    288       !                             !--------------------------! 
    289       !                             !  Set global domain size  !   (control print return in cltxt2) 
    290       !                             !--------------------------! 
    291       IF( ln_read_cfg ) THEN              ! Read sizes in domain configuration file 
    292          CALL domain_cfg ( cltxt2,        cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio ) 
    293          ! 
    294       ELSE                                ! user-defined namelist 
    295          CALL usr_def_nam( cltxt2, clnam, cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio ) 
    296       ENDIF 
    297       ! 
    298       ! 
    299       !                             !--------------------------------------------! 
    300       !                             !  set communicator & select the local node  ! 
    301       !                             !  NB: mynode also opens output.namelist.dyn ! 
    302       !                             !      on unit number numond on first proc   ! 
    303       !                             !--------------------------------------------! 
     273      !                             !-------------------------------------------------! 
     274      !                             !     set communicator & select the local rank    ! 
     275      !                             !  must be done as soon as possible to get narea  ! 
     276      !                             !-------------------------------------------------! 
     277      ! 
    304278#if defined key_iomput 
    305279      IF( Agrif_Root() ) THEN 
    306280         IF( lk_oasis ) THEN 
    307281            CALL cpl_init( "oceanx", ilocal_comm )                               ! nemo local communicator given by oasis 
    308             CALL xios_initialize( "not used"       ,local_comm= ilocal_comm )    ! send nemo communicator to xios 
     282            CALL xios_initialize( "not used"       , local_comm =ilocal_comm )   ! send nemo communicator to xios 
    309283         ELSE 
    310             CALL xios_initialize( "for_xios_mpi_id",return_comm=ilocal_comm )    ! nemo local communicator given by xios 
     284            CALL xios_initialize( "for_xios_mpi_id", return_comm=ilocal_comm )   ! nemo local communicator given by xios 
    311285         ENDIF 
    312286      ENDIF 
    313       ! Nodes selection (control print return in cltxt) 
    314       narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) 
     287      CALL mpp_start( ilocal_comm ) 
    315288#else 
    316289      IF( lk_oasis ) THEN 
    … …  
    318291            CALL cpl_init( "oceanx", ilocal_comm )          ! nemo local communicator given by oasis 
    319292         ENDIF 
    320          ! Nodes selection (control print return in cltxt) 
    321          narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop, ilocal_comm ) 
     293         CALL mpp_start( ilocal_comm ) 
    322294      ELSE 
    323          ilocal_comm = 0                                    ! Nodes selection (control print return in cltxt) 
    324          narea = mynode( cltxt, 'output.namelist.dyn', numnam_ref, numnam_cfg, numond , nstop ) 
    325       ENDIF 
    326 #endif 
    327  
    328       narea = narea + 1                                     ! mynode return the rank of proc (0 --> jpnij -1 ) 
    329  
    330       IF( sn_cfctl%l_config ) THEN 
    331          ! Activate finer control of report outputs 
    332          ! optionally switch off output from selected areas (note this only 
    333          ! applies to output which does not involve global communications) 
    334          IF( ( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax  ) .OR. & 
    335            & ( MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) )    & 
    336            &   CALL nemo_set_cfctl( sn_cfctl, .FALSE., .FALSE. ) 
    337       ELSE 
    338          ! Use ln_ctl to turn on or off all options. 
    339          CALL nemo_set_cfctl( sn_cfctl, ln_ctl, .TRUE. ) 
    340       ENDIF 
    341  
    342       lwm = (narea == 1)                                    ! control of output namelists 
    343       lwp = (narea == 1) .OR. ln_ctl                        ! control of all listing output print 
    344  
    345       IF(lwm) THEN               ! write merged namelists from earlier to output namelist  
    346          !                       ! now that the file has been opened in call to mynode.  
    347          !                       ! NB: nammpp has already been written in mynode (if lk_mpp_mpi) 
    348          WRITE( numond, namctl ) 
    349          WRITE( numond, namcfg ) 
    350          IF( .NOT.ln_read_cfg ) THEN 
    351             DO ji = 1, SIZE(clnam) 
    352                IF( TRIM(clnam(ji)) /= '' )   WRITE(numond, * ) clnam(ji)     ! namusr_def print 
    353             END DO 
    354          ENDIF 
    355       ENDIF 
    356  
    357       IF(lwp) THEN                            ! open listing units 
    358          ! 
    359          CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE., narea ) 
     295         CALL mpp_start( ) 
     296      ENDIF 
     297#endif 
     298      ! 
     299      narea = mpprank + 1               ! mpprank: the rank of proc (0 --> mppsize -1 ) 
     300      lwm = (narea == 1)                ! control of output namelists 
     301      ! 
     302      !                             !---------------------------------------------------------------! 
     303      !                             ! Open output files, reference and configuration namelist files ! 
     304      !                             !---------------------------------------------------------------! 
     305      ! 
     306      ! open ocean.output as soon as possible to get all output prints (including errors messages) 
     307      IF( lwm )   CALL ctl_opn(     numout,        'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 
     308      ! open reference and configuration namelist files 
     309                  CALL ctl_opn( numnam_ref,        'namelist_ref',     'OLD', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 
     310                  CALL ctl_opn( numnam_cfg,        'namelist_cfg',     'OLD', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 
     311      IF( lwm )   CALL ctl_opn(     numond, 'output.namelist.dyn', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 
     312      ! open /dev/null file to be able to supress output write easily 
     313                  CALL ctl_opn(     numnul,           '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) 
     314      ! 
     315      !                             !--------------------! 
     316      !                             ! Open listing units !  -> need ln_ctl from namctl to define lwp 
     317      !                             !--------------------! 
     318      ! 
     319      REWIND( numnam_ref )              ! Namelist namctl in reference namelist 
     320      READ  ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 ) 
     321901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namctl in reference namelist' ) 
     322      REWIND( numnam_cfg )              ! Namelist namctl in confguration namelist 
     323      READ  ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 ) 
     324902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namctl in configuration namelist' ) 
     325      ! 
     326      lwp = (narea == 1) .OR. ln_ctl    ! control of all listing output print 
     327      ! 
     328      IF(lwp) THEN                      ! open listing units 
     329         ! 
     330         IF( .NOT. lwm )   &            ! alreay opened for narea == 1 
     331            &            CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE., narea ) 
    360332         ! 
    361333         WRITE(numout,*) 
    362          WRITE(numout,*) '   CNRS - NERC - Met OFFICE - MERCATOR-ocean - INGV - CMCC' 
     334         WRITE(numout,*) '   CNRS - NERC - Met OFFICE - MERCATOR-ocean - CMCC' 
    363335         WRITE(numout,*) '                       NEMO team' 
    364336         WRITE(numout,*) '            Ocean General Circulation Model' 
    … …  
    379351         WRITE(numout,*) "     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ " 
    380352         WRITE(numout,*) 
    381           
    382          DO ji = 1, SIZE(cltxt) 
    383             IF( TRIM(cltxt (ji)) /= '' )   WRITE(numout,*) TRIM(cltxt(ji))    ! control print of mynode 
    384          END DO 
    385          WRITE(numout,*) 
    386          WRITE(numout,*) 
    387          DO ji = 1, SIZE(cltxt2) 
    388             IF( TRIM(cltxt2(ji)) /= '' )   WRITE(numout,*) TRIM(cltxt2(ji))   ! control print of domain size 
    389          END DO 
    390353         ! 
    391354         WRITE(numout,cform_aaa)                                        ! Flag AAAAAAA 
    392355         ! 
    393356      ENDIF 
    394       ! open /dev/null file to be able to supress output write easily 
    395       CALL ctl_opn( numnul, '/dev/null', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 
    396       ! 
    397       !                                      ! Domain decomposition 
    398       CALL mpp_init                          ! MPP 
     357      ! 
     358      ! finalize the definition of namctl variables 
     359      IF( sn_cfctl%l_config ) THEN 
     360         ! Activate finer control of report outputs 
     361         ! optionally switch off output from selected areas (note this only 
     362         ! applies to output which does not involve global communications) 
     363         IF( ( narea < sn_cfctl%procmin .OR. narea > sn_cfctl%procmax  ) .OR. & 
     364           & ( MOD( narea - sn_cfctl%procmin, sn_cfctl%procincr ) /= 0 ) )    & 
     365           &   CALL nemo_set_cfctl( sn_cfctl, .FALSE., .FALSE. ) 
     366      ELSE 
     367         ! Use ln_ctl to turn on or off all options. 
     368         CALL nemo_set_cfctl( sn_cfctl, ln_ctl, .TRUE. ) 
     369      ENDIF 
     370      ! 
     371      IF(lwm) WRITE( numond, namctl ) 
     372      ! 
     373      !                             !------------------------------------! 
     374      !                             !  Set global domain size parameters ! 
     375      !                             !------------------------------------! 
     376      ! 
     377      REWIND( numnam_ref )              ! Namelist namcfg in reference namelist 
     378      READ  ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 ) 
     379903   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namcfg in reference namelist' ) 
     380      REWIND( numnam_cfg )              ! Namelist namcfg in confguration namelist 
     381      READ  ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 ) 
     382904   IF( ios >  0 )   CALL ctl_nam ( ios , 'namcfg in configuration namelist' )    
     383      ! 
     384      IF( ln_read_cfg ) THEN            ! Read sizes in domain configuration file 
     385         CALL domain_cfg ( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio ) 
     386      ELSE                              ! user-defined namelist 
     387         CALL usr_def_nam( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio ) 
     388      ENDIF 
     389      ! 
     390      IF(lwm)   WRITE( numond, namcfg ) 
     391      ! 
     392      !                             !-----------------------------------------! 
     393      !                             ! mpp parameters and domain decomposition ! 
     394      !                             !-----------------------------------------! 
     395      CALL mpp_init 
    399396 
    400397      ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays 
    … …  
    480477      
    481478      !                                      ! Diagnostics 
    482       IF( lk_floats    )   CALL     flo_init    ! drifting Floats 
     479                           CALL     flo_init    ! drifting Floats 
    483480      IF( ln_diacfl    )   CALL dia_cfl_init    ! Initialise CFL diagnostics 
    484481                           CALL dia_ptr_init    ! Poleward TRansports initialization 
    485       IF( lk_diadct    )   CALL dia_dct_init    ! Sections tranports 
     482                           CALL dia_dct_init    ! Sections tranports 
    486483                           CALL dia_hsb_init    ! heat content, salt content and volume budgets 
    487484                           CALL     trd_init    ! Mixed-layer/Vorticity/Integral constraints trends 
    … …  
    489486                           CALL dia_tmb_init    ! TMB outputs 
    490487                           CALL dia_25h_init    ! 25h mean  outputs 
    491       IF( ln_diaobs    )   CALL dia_obs( nit000-1 )   ! Observation operator for restart 
     488                           CALL dia_harm_init   ! tidal harmonics outputs 
     489     IF( ln_diaobs    )    CALL dia_obs( nit000-1 )   ! Observation operator for restart 
    492490 
    493491      !                                      ! Assimilation increments 
    … …  
    507505      !! ** Purpose :   control print setting 
    508506      !! 
    509       !! ** Method  : - print namctl information and check some consistencies 
     507      !! ** Method  : - print namctl and namcfg information and check some consistencies 
    510508      !!---------------------------------------------------------------------- 
    511509      ! 
    … …  
    650648      USE trc_oce   , ONLY : trc_oce_alloc 
    651649      USE bdy_oce   , ONLY : bdy_oce_alloc 
    652 #if defined key_diadct  
    653       USE diadct    , ONLY : diadct_alloc  
    654 #endif  
    655650      ! 
    656651      INTEGER :: ierr 
    … …  
    664659      ierr = ierr + bdy_oce_alloc()    ! bdy masks (incl. initialization) 
    665660      ! 
    666 #if defined key_diadct  
    667       ierr = ierr + diadct_alloc ()    !  
    668 #endif  
    669       ! 
    670661      CALL mpp_sum( 'nemogcm', ierr ) 
    671662      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'nemo_alloc: unable to allocate standard ocean arrays' ) 
    … …  
    673664   END SUBROUTINE nemo_alloc 
    674665 
     666    
    675667   SUBROUTINE nemo_set_cfctl(sn_cfctl, setto, for_all ) 
    676668      !!---------------------------------------------------------------------- 

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

    r11416 r11536  
    112112      IF( ln_tide    )   CALL sbc_tide( kstp )                   ! update tide potential 
    113113      IF( ln_apr_dyn )   CALL sbc_apr ( kstp )                   ! atmospheric pressure (NB: call before bdy_dta which needs ssh_ib)  
    114       IF( ln_bdy     )   CALL bdy_dta ( kstp, time_offset=+1 )   ! update dynamic & tracer data at open boundaries 
     114      IF( ln_bdy     )   CALL bdy_dta ( kstp, kt_offset = +1 )   ! update dynamic & tracer data at open boundaries 
    115115                         CALL sbc     ( kstp )                   ! Sea Boundary Condition (including sea-ice) 
    116116 
    … …  
    203203      ! diagnostics and outputs 
    204204      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    205       IF( lk_floats  )   CALL flo_stp ( kstp )        ! drifting Floats 
     205      IF( ln_floats  )   CALL flo_stp ( kstp )        ! drifting Floats 
    206206      IF( ln_diacfl  )   CALL dia_cfl ( kstp )        ! Courant number diagnostics 
    207207      IF( lk_diahth  )   CALL dia_hth ( kstp )        ! Thermocline depth (20 degres isotherm depth) 
    208       IF( lk_diadct  )   CALL dia_dct ( kstp )        ! Transports 
     208      IF( ln_diadct  )   CALL dia_dct ( kstp )        ! Transports 
    209209                         CALL dia_ar5 ( kstp )        ! ar5 diag 
    210       IF( lk_diaharm )   CALL dia_harm( kstp )        ! Tidal harmonic analysis 
     210      IF( ln_diaharm )   CALL dia_harm( kstp )        ! Tidal harmonic analysis 
    211211                         CALL dia_wri ( kstp )        ! ocean model: outputs 
    212212      ! 

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

    r10510 r11536  
    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.