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.
lib_mpp.F90 in trunk/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

source: trunk/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 7753

Last change on this file since 7753 was 7753, checked in by mocavero, 7 years ago

Reverting trunk to remove OpenMP

  • Property svn:keywords set to Id
File size: 189.3 KB
RevLine 
[3]1MODULE lib_mpp
[13]2   !!======================================================================
3   !!                       ***  MODULE  lib_mpp  ***
[1344]4   !! Ocean numerics:  massively parallel processing library
[13]5   !!=====================================================================
[1344]6   !! History :  OPA  !  1994  (M. Guyon, J. Escobar, M. Imbard)  Original code
7   !!            7.0  !  1997  (A.M. Treguier)  SHMEM additions
8   !!            8.0  !  1998  (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
9   !!                 !  1998  (J.M. Molines) Open boundary conditions
10   !!   NEMO     1.0  !  2003  (J.-M. Molines, G. Madec)  F90, free form
11   !!                 !  2003  (J.M. Molines) add mpp_ini_north(_3d,_2d)
12   !!             -   !  2004  (R. Bourdalle Badie)  isend option in mpi
13   !!                 !  2004  (J.M. Molines) minloc, maxloc
14   !!             -   !  2005  (G. Madec, S. Masson)  npolj=5,6 F-point & ice cases
15   !!             -   !  2005  (R. Redler) Replacement of MPI_COMM_WORLD except for MPI_Abort
16   !!             -   !  2005  (R. Benshila, G. Madec)  add extra halo case
17   !!             -   !  2008  (R. Benshila) add mpp_ini_ice
18   !!            3.2  !  2009  (R. Benshila) SHMEM suppression, north fold in lbc_nfd
[3764]19   !!            3.2  !  2009  (O. Marti)    add mpp_ini_znl
[2715]20   !!            4.0  !  2011  (G. Madec)  move ctl_ routines from in_out_manager
[3680]21   !!            3.5  !  2012  (S.Mocavero, I. Epicoco) Add 'mpp_lnk_bdy_3d', 'mpp_lnk_obc_3d',
22   !!                          'mpp_lnk_bdy_2d' and 'mpp_lnk_obc_2d' routines and update
23   !!                          the mppobc routine to optimize the BDY and OBC communications
[4230]24   !!            3.5  !  2013  ( C. Ethe, G. Madec ) message passing arrays as local variables
[6140]25   !!            3.5  !  2013  (S.Mocavero, I.Epicoco - CMCC) north fold optimizations
[6490]26   !!            3.6  !  2015 (O. Tintó and M. Castrillo - BSC) Added 'mpp_lnk_2d_multiple', 'mpp_lbc_north_2d_multiple', 'mpp_max_multiple'
[13]27   !!----------------------------------------------------------------------
[2715]28
29   !!----------------------------------------------------------------------
[6140]30   !!   ctl_stop      : update momentum and tracer Kz from a tke scheme
31   !!   ctl_warn      : initialization, namelist read, and parameters control
32   !!   ctl_opn       : Open file and check if required file is available.
33   !!   ctl_nam       : Prints informations when an error occurs while reading a namelist
34   !!   get_unit      : give the index of an unused logical unit
[2715]35   !!----------------------------------------------------------------------
[3764]36#if   defined key_mpp_mpi
[13]37   !!----------------------------------------------------------------------
[1344]38   !!   'key_mpp_mpi'             MPI massively parallel processing library
39   !!----------------------------------------------------------------------
[2715]40   !!   lib_mpp_alloc : allocate mpp arrays
41   !!   mynode        : indentify the processor unit
42   !!   mpp_lnk       : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d)
[473]43   !!   mpp_lnk_3d_gather :  Message passing manadgement for two 3D arrays
[2715]44   !!   mpp_lnk_e     : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e)
[4990]45   !!   mpp_lnk_icb   : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb)
[6140]46   !!   mpprecv       :
[2715]47   !!   mppsend       :   SUBROUTINE mpp_ini_znl
48   !!   mppscatter    :
49   !!   mppgather     :
50   !!   mpp_min       : generic interface for mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
51   !!   mpp_max       : generic interface for mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real
52   !!   mpp_sum       : generic interface for mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
53   !!   mpp_minloc    :
54   !!   mpp_maxloc    :
55   !!   mppsync       :
56   !!   mppstop       :
[1344]57   !!   mpp_ini_north : initialisation of north fold
58   !!   mpp_lbc_north : north fold processors gathering
59   !!   mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo
[4990]60   !!   mpp_lbc_north_icb : variant of mpp_lbc_north for extra outer halo with icebergs
[13]61   !!----------------------------------------------------------------------
[3764]62   USE dom_oce        ! ocean space and time domain
[2715]63   USE lbcnfd         ! north fold treatment
64   USE in_out_manager ! I/O manager
[6490]65   USE wrk_nemo       ! work arrays
[3]66
[13]67   IMPLICIT NONE
[415]68   PRIVATE
[4147]69   
70   PUBLIC   ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam
[1344]71   PUBLIC   mynode, mppstop, mppsync, mpp_comm_free
72   PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e
73   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc
[6490]74   PUBLIC   mpp_max_multiple
[1344]75   PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e
[6490]76   PUBLIC   mpp_lnk_2d_9 , mpp_lnk_2d_multiple 
[6140]77   PUBLIC   mpp_lnk_sum_3d, mpp_lnk_sum_2d
[3294]78   PUBLIC   mppscatter, mppgather
[4328]79   PUBLIC   mpp_ini_ice, mpp_ini_znl
[2715]80   PUBLIC   mppsize
[3764]81   PUBLIC   mppsend, mpprecv                          ! needed by TAM and ICB routines
[3680]82   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d
[4990]83   PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb
[6490]84   PUBLIC   mpprank
[415]85
[5429]86   TYPE arrayptr
87      REAL , DIMENSION (:,:),  POINTER :: pt2d
88   END TYPE arrayptr
[6490]89   PUBLIC   arrayptr
[5429]90   
[13]91   !! * Interfaces
92   !! define generic interface for these routine as they are called sometimes
[1344]93   !! with scalar arguments instead of array arguments, which causes problems
94   !! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
[13]95   INTERFACE mpp_min
96      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
97   END INTERFACE
98   INTERFACE mpp_max
[681]99      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
[13]100   END INTERFACE
101   INTERFACE mpp_sum
[6140]102      MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real,   &
[1976]103                       mppsum_realdd, mppsum_a_realdd
[13]104   END INTERFACE
105   INTERFACE mpp_lbc_north
[3764]106      MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d
[13]107   END INTERFACE
[1344]108   INTERFACE mpp_minloc
109      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
110   END INTERFACE
111   INTERFACE mpp_maxloc
112      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
113   END INTERFACE
[3764]114
[6490]115   INTERFACE mpp_max_multiple
116      MODULE PROCEDURE mppmax_real_multiple
117   END INTERFACE
118
[51]119   !! ========================= !!
120   !!  MPI  variable definition !!
121   !! ========================= !!
[1629]122!$AGRIF_DO_NOT_TREAT
[2004]123   INCLUDE 'mpif.h'
[1629]124!$AGRIF_END_DO_NOT_TREAT
[3764]125
[1344]126   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .TRUE.    !: mpp flag
[3]127
[1344]128   INTEGER, PARAMETER         ::   nprocmax = 2**10   ! maximun dimension (required to be a power of 2)
[3764]129
[1344]130   INTEGER ::   mppsize        ! number of process
131   INTEGER ::   mpprank        ! process number  [ 0 - size-1 ]
[2363]132!$AGRIF_DO_NOT_TREAT
[2249]133   INTEGER, PUBLIC ::   mpi_comm_opa   ! opa local communicator
[2363]134!$AGRIF_END_DO_NOT_TREAT
[3]135
[2480]136   INTEGER :: MPI_SUMDD
[1976]137
[869]138   ! variables used in case of sea-ice
[3625]139   INTEGER, PUBLIC ::   ncomm_ice       !: communicator made by the processors with sea-ice (public so that it can be freed in limthd)
140   INTEGER ::   ngrp_iworld     !  group ID for the world processors (for rheology)
[1345]141   INTEGER ::   ngrp_ice        !  group ID for the ice processors (for rheology)
142   INTEGER ::   ndim_rank_ice   !  number of 'ice' processors
143   INTEGER ::   n_ice_root      !  number (in the comm_ice) of proc 0 in the ice comm
[2715]144   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_ice     ! dimension ndim_rank_ice
[1345]145
146   ! variables used for zonal integration
147   INTEGER, PUBLIC ::   ncomm_znl       !: communicator made by the processors on the same zonal average
148   LOGICAL, PUBLIC ::   l_znl_root      ! True on the 'left'most processor on the same row
149   INTEGER ::   ngrp_znl        ! group ID for the znl processors
150   INTEGER ::   ndim_rank_znl   ! number of processors on the same zonal average
[2715]151   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_znl  ! dimension ndim_rank_znl, number of the procs into the same znl domain
[3]152
[3764]153   ! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM)
154   INTEGER, PUBLIC ::   ngrp_world        ! group ID for the world processors
155   INTEGER, PUBLIC ::   ngrp_opa          ! group ID for the opa processors
156   INTEGER, PUBLIC ::   ngrp_north        ! group ID for the northern processors (to be fold)
157   INTEGER, PUBLIC ::   ncomm_north       ! communicator made by the processors belonging to ngrp_north
158   INTEGER, PUBLIC ::   ndim_rank_north   ! number of 'sea' processor in the northern line (can be /= jpni !)
159   INTEGER, PUBLIC ::   njmppmax          ! value of njmpp for the processors of the northern line
160   INTEGER, PUBLIC ::   north_root        ! number (in the comm_opa) of proc 0 in the northern comm
161   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE, PUBLIC ::   nrank_north   ! dimension ndim_rank_north
162
[1344]163   ! Type of send : standard, buffered, immediate
[4147]164   CHARACTER(len=1), PUBLIC ::   cn_mpi_send   ! type od mpi send/recieve (S=standard, B=bsend, I=isend)
[3764]165   LOGICAL, PUBLIC          ::   l_isend = .FALSE.   ! isend use indicator (T if cn_mpi_send='I')
[4147]166   INTEGER, PUBLIC          ::   nn_buffer     ! size of the buffer in case of mpi_bsend
[3764]167
[2715]168   REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon  ! buffer in case of bsend
[3]169
[4230]170   LOGICAL, PUBLIC                                  ::   ln_nnogather       ! namelist control of northfold comms
[3294]171   LOGICAL, PUBLIC                                  ::   l_north_nogather = .FALSE.  ! internal control of northfold comms
172   INTEGER, PUBLIC                                  ::   ityp
[51]173   !!----------------------------------------------------------------------
[2287]174   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
[888]175   !! $Id$
[2715]176   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
[1344]177   !!----------------------------------------------------------------------
[3]178CONTAINS
179
[2715]180
[5407]181   FUNCTION mynode( ldtxt, ldname, kumnam_ref , kumnam_cfg , kumond , kstop, localComm )
[2715]182      !!----------------------------------------------------------------------
[51]183      !!                  ***  routine mynode  ***
[3764]184      !!
[51]185      !! ** Purpose :   Find processor unit
186      !!----------------------------------------------------------------------
[6140]187      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt        !
188      CHARACTER(len=*)             , INTENT(in   ) ::   ldname       !
189      INTEGER                      , INTENT(in   ) ::   kumnam_ref   ! logical unit for reference namelist
190      INTEGER                      , INTENT(in   ) ::   kumnam_cfg   ! logical unit for configuration namelist
191      INTEGER                      , INTENT(inout) ::   kumond       ! logical unit for namelist output
192      INTEGER                      , INTENT(inout) ::   kstop        ! stop indicator
193      INTEGER         , OPTIONAL   , INTENT(in   ) ::   localComm    !
[2715]194      !
[4147]195      INTEGER ::   mynode, ierr, code, ji, ii, ios
[532]196      LOGICAL ::   mpi_was_called
[2715]197      !
[3294]198      NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, jpnij, ln_nnogather
[51]199      !!----------------------------------------------------------------------
[1344]200      !
[2481]201      ii = 1
[6140]202      WRITE(ldtxt(ii),*)                                                                  ;   ii = ii + 1
203      WRITE(ldtxt(ii),*) 'mynode : mpi initialisation'                                    ;   ii = ii + 1
204      WRITE(ldtxt(ii),*) '~~~~~~ '                                                        ;   ii = ii + 1
[1344]205      !
[4147]206
207      REWIND( kumnam_ref )              ! Namelist nammpp in reference namelist: mpi variables
208      READ  ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901)
209901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp )
210
211      REWIND( kumnam_cfg )              ! Namelist nammpp in configuration namelist: mpi variables
212      READ  ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 )
213902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp )
214
[1344]215      !                              ! control print
[6140]216      WRITE(ldtxt(ii),*) '   Namelist nammpp'                                             ;   ii = ii + 1
217      WRITE(ldtxt(ii),*) '      mpi send type          cn_mpi_send = ', cn_mpi_send       ;   ii = ii + 1
218      WRITE(ldtxt(ii),*) '      size exported buffer   nn_buffer   = ', nn_buffer,' bytes';   ii = ii + 1
[300]219
[2731]220#if defined key_agrif
221      IF( .NOT. Agrif_Root() ) THEN
[3764]222         jpni  = Agrif_Parent(jpni )
[2731]223         jpnj  = Agrif_Parent(jpnj )
224         jpnij = Agrif_Parent(jpnij)
225      ENDIF
226#endif
227
[2715]228      IF(jpnij < 1)THEN
229         ! If jpnij is not specified in namelist then we calculate it - this
230         ! means there will be no land cutting out.
231         jpnij = jpni * jpnj
232      END IF
233
234      IF( (jpni < 1) .OR. (jpnj < 1) )THEN
[6140]235         WRITE(ldtxt(ii),*) '      jpni, jpnj and jpnij will be calculated automatically' ;   ii = ii + 1
[2715]236      ELSE
[6140]237         WRITE(ldtxt(ii),*) '      processor grid extent in i         jpni = ',jpni       ;   ii = ii + 1
238         WRITE(ldtxt(ii),*) '      processor grid extent in j         jpnj = ',jpnj       ;   ii = ii + 1
239         WRITE(ldtxt(ii),*) '      number of local domains           jpnij = ',jpnij      ;   ii = ii + 1
[2715]240      END IF
241
[3294]242      WRITE(ldtxt(ii),*) '      avoid use of mpi_allgather at the north fold  ln_nnogather = ', ln_nnogather  ; ii = ii + 1
243
[2480]244      CALL mpi_initialized ( mpi_was_called, code )
245      IF( code /= MPI_SUCCESS ) THEN
[3764]246         DO ji = 1, SIZE(ldtxt)
[2481]247            IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
[3764]248         END DO
[2480]249         WRITE(*, cform_err)
250         WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized'
251         CALL mpi_abort( mpi_comm_world, code, ierr )
252      ENDIF
[415]253
[2480]254      IF( mpi_was_called ) THEN
255         !
256         SELECT CASE ( cn_mpi_send )
257         CASE ( 'S' )                ! Standard mpi send (blocking)
[6140]258            WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'             ;   ii = ii + 1
[2480]259         CASE ( 'B' )                ! Buffer mpi send (blocking)
[6140]260            WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'              ;   ii = ii + 1
[3764]261            IF( Agrif_Root() )   CALL mpi_init_opa( ldtxt, ii, ierr )
[2480]262         CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
[6140]263            WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'           ;   ii = ii + 1
[2480]264            l_isend = .TRUE.
265         CASE DEFAULT
[6140]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
[2715]268            kstop = kstop + 1
[2480]269         END SELECT
270      ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN
[6140]271         WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator '          ;   ii = ii + 1
272         WRITE(ldtxt(ii),*) '          without calling MPI_Init before ! '                ;   ii = ii + 1
[2715]273         kstop = kstop + 1
[532]274      ELSE
[1601]275         SELECT CASE ( cn_mpi_send )
[524]276         CASE ( 'S' )                ! Standard mpi send (blocking)
[6140]277            WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'             ;   ii = ii + 1
[2480]278            CALL mpi_init( ierr )
[524]279         CASE ( 'B' )                ! Buffer mpi send (blocking)
[6140]280            WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'              ;   ii = ii + 1
[2481]281            IF( Agrif_Root() )   CALL mpi_init_opa( ldtxt, ii, ierr )
[524]282         CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
[6140]283            WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'           ;   ii = ii + 1
[524]284            l_isend = .TRUE.
[2480]285            CALL mpi_init( ierr )
[524]286         CASE DEFAULT
[6140]287            WRITE(ldtxt(ii),cform_err)                                                    ;   ii = ii + 1
288            WRITE(ldtxt(ii),*) '           bad value for cn_mpi_send = ', cn_mpi_send     ;   ii = ii + 1
[2715]289            kstop = kstop + 1
[524]290         END SELECT
[2480]291         !
[415]292      ENDIF
[570]293
[3764]294      IF( PRESENT(localComm) ) THEN
[2480]295         IF( Agrif_Root() ) THEN
296            mpi_comm_opa = localComm
297         ENDIF
298      ELSE
299         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code)
300         IF( code /= MPI_SUCCESS ) THEN
[3764]301            DO ji = 1, SIZE(ldtxt)
[2481]302               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
303            END DO
[2480]304            WRITE(*, cform_err)
305            WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'
306            CALL mpi_abort( mpi_comm_world, code, ierr )
307         ENDIF
[3764]308      ENDIF
[2480]309
[5656]310#if defined key_agrif
311      IF (Agrif_Root()) THEN
312         CALL Agrif_MPI_Init(mpi_comm_opa)
313      ELSE
314         CALL Agrif_MPI_set_grid_comm(mpi_comm_opa)
315      ENDIF
316#endif
317
[1344]318      CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr )
319      CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr )
[629]320      mynode = mpprank
[4624]321
322      IF( mynode == 0 ) THEN
[5407]323         CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )
324         WRITE(kumond, nammpp)     
[4624]325      ENDIF
[3764]326      !
[1976]327      CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr)
328      !
[51]329   END FUNCTION mynode
[3]330
[6140]331
[888]332   SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval )
[51]333      !!----------------------------------------------------------------------
334      !!                  ***  routine mpp_lnk_3d  ***
335      !!
336      !! ** Purpose :   Message passing manadgement
337      !!
[3764]338      !! ** Method  :   Use mppsend and mpprecv function for passing mask
[51]339      !!      between processors following neighboring subdomains.
340      !!            domain parameters
341      !!                    nlci   : first dimension of the local subdomain
342      !!                    nlcj   : second dimension of the local subdomain
343      !!                    nbondi : mark for "east-west local boundary"
344      !!                    nbondj : mark for "north-south local boundary"
[3764]345      !!                    noea   : number for local neighboring processors
[51]346      !!                    nowe   : number for local neighboring processors
347      !!                    noso   : number for local neighboring processors
348      !!                    nono   : number for local neighboring processors
349      !!
350      !! ** Action  :   ptab with update value at its periphery
351      !!
352      !!----------------------------------------------------------------------
[1344]353      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied
354      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
355      !                                                             ! = T , U , V , F , W points
356      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
357      !                                                             ! =  1. , the sign is kept
[3764]358      CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only
[1344]359      REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries)
[6140]360      !
[1718]361      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices
[1344]362      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
363      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
[888]364      REAL(wp) ::   zland
[6140]365      INTEGER , DIMENSION(MPI_STATUS_SIZE)      ::   ml_stat        ! for key_mpi_isend
[4152]366      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north
367      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east
[51]368      !!----------------------------------------------------------------------
[4152]369     
370      ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2),   &
371         &      zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2)  )
[3]372
[4152]373      !
[1344]374      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
[6140]375      ELSE                         ;   zland = 0._wp     ! zero by default
[1344]376      ENDIF
377
[51]378      ! 1. standard boundary treatment
379      ! ------------------------------
[1718]380      IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values
[1344]381         !
[1718]382         ! WARNING ptab is defined only between nld and nle
383         DO jk = 1, jpk
384            DO jj = nlcj+1, jpj                 ! added line(s)   (inner only)
[3764]385               ptab(nldi  :nlei  , jj          ,jk) = ptab(nldi:nlei,     nlej,jk)
[1718]386               ptab(1     :nldi-1, jj          ,jk) = ptab(nldi     ,     nlej,jk)
387               ptab(nlei+1:nlci  , jj          ,jk) = ptab(     nlei,     nlej,jk)
388            END DO
389            DO ji = nlci+1, jpi                 ! added column(s) (full)
390               ptab(ji           ,nldj  :nlej  ,jk) = ptab(     nlei,nldj:nlej,jk)
391               ptab(ji           ,1     :nldj-1,jk) = ptab(     nlei,nldj     ,jk)
392               ptab(ji           ,nlej+1:jpj   ,jk) = ptab(     nlei,     nlej,jk)
393            END DO
[610]394         END DO
[1344]395         !
[3764]396      ELSE                              ! standard close or cyclic treatment
[1344]397         !
398         !                                   ! East-West boundaries
399         !                                        !* Cyclic east-west
400         IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
[7753]401            ptab( 1 ,:,:) = ptab(jpim1,:,:)
402            ptab(jpi,:,:) = ptab(  2  ,:,:)
[1344]403         ELSE                                     !* closed
[7753]404            IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point
405                                         ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north
[473]406         ENDIF
[7646]407                                          ! North-south cyclic
408         IF ( nbondj == 2 .AND. jperio == 7 )    THEN !* cyclic north south only with no mpp split in latitude
[7753]409            ptab(:,1 , :) = ptab(:, jpjm1,:)
410            ptab(:,jpj,:) = ptab(:,     2,:)
[7646]411         ELSE   !                                   ! North-South boundaries (closed)
[7753]412            IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point
413                                         ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north
[7646]414         ENDIF
[1344]415         !
[51]416      ENDIF
[3]417
[51]418      ! 2. East and west directions exchange
419      ! ------------------------------------
[3764]420      ! we play with the neigbours AND the row number because of the periodicity
[1344]421      !
422      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
423      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
[51]424         iihom = nlci-nreci
[7753]425         DO jl = 1, jpreci
426            zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
427            zt3we(:,jl,:,1) = ptab(iihom +jl,:,:)
[51]428         END DO
[3764]429      END SELECT
[1344]430      !
431      !                           ! Migrations
[51]432      imigr = jpreci * jpj * jpk
[1344]433      !
[3764]434      SELECT CASE ( nbondi )
[51]435      CASE ( -1 )
[4152]436         CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 )
437         CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
[300]438         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
[51]439      CASE ( 0 )
[4152]440         CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
441         CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 )
442         CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
443         CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
[300]444         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
445         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
[51]446      CASE ( 1 )
[4152]447         CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
448         CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
[300]449         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
[51]450      END SELECT
[1344]451      !
452      !                           ! Write Dirichlet lateral conditions
[51]453      iihom = nlci-jpreci
[1344]454      !
[51]455      SELECT CASE ( nbondi )
456      CASE ( -1 )
[7753]457         DO jl = 1, jpreci
458            ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)
[51]459         END DO
[3764]460      CASE ( 0 )
[7753]461         DO jl = 1, jpreci
462            ptab(jl      ,:,:) = zt3we(:,jl,:,2)
463            ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)
[51]464         END DO
465      CASE ( 1 )
[7753]466         DO jl = 1, jpreci
467            ptab(jl      ,:,:) = zt3we(:,jl,:,2)
[51]468         END DO
469      END SELECT
[3]470
[51]471      ! 3. North and south directions
472      ! -----------------------------
[1344]473      ! always closed : we play only with the neigbours
474      !
475      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
[51]476         ijhom = nlcj-nrecj
[7753]477         DO jl = 1, jprecj
478            zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
479            zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
[51]480         END DO
481      ENDIF
[1344]482      !
483      !                           ! Migrations
[51]484      imigr = jprecj * jpi * jpk
[1344]485      !
[3764]486      SELECT CASE ( nbondj )
[51]487      CASE ( -1 )
[4152]488         CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 )
489         CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
[300]490         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
[51]491      CASE ( 0 )
[4152]492         CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
493         CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 )
494         CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
495         CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
[300]496         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
497         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
[3764]498      CASE ( 1 )
[4152]499         CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
500         CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
[300]501         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
[51]502      END SELECT
[1344]503      !
504      !                           ! Write Dirichlet lateral conditions
[51]505      ijhom = nlcj-jprecj
[1344]506      !
[51]507      SELECT CASE ( nbondj )
508      CASE ( -1 )
[7753]509         DO jl = 1, jprecj
510            ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)
[51]511         END DO
[3764]512      CASE ( 0 )
[7753]513         DO jl = 1, jprecj
514            ptab(:,jl      ,:) = zt3sn(:,jl,:,2)
515            ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)
[51]516         END DO
517      CASE ( 1 )
[7753]518         DO jl = 1, jprecj
519            ptab(:,jl,:) = zt3sn(:,jl,:,2)
[51]520         END DO
521      END SELECT
[3]522
[51]523      ! 4. north fold treatment
524      ! -----------------------
[1344]525      !
526      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
527         !
528         SELECT CASE ( jpni )
529         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp
530         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs.
531         END SELECT
532         !
[473]533      ENDIF
[1344]534      !
[4152]535      DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we )
536      !
[51]537   END SUBROUTINE mpp_lnk_3d
[3]538
[6140]539
[5429]540   SUBROUTINE mpp_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields , cd_mpp, pval )
541      !!----------------------------------------------------------------------
542      !!                  ***  routine mpp_lnk_2d_multiple  ***
543      !!
544      !! ** Purpose :   Message passing management for multiple 2d arrays
545      !!
546      !! ** Method  :   Use mppsend and mpprecv function for passing mask
547      !!      between processors following neighboring subdomains.
548      !!            domain parameters
549      !!                    nlci   : first dimension of the local subdomain
550      !!                    nlcj   : second dimension of the local subdomain
551      !!                    nbondi : mark for "east-west local boundary"
552      !!                    nbondj : mark for "north-south local boundary"
553      !!                    noea   : number for local neighboring processors
554      !!                    nowe   : number for local neighboring processors
555      !!                    noso   : number for local neighboring processors
556      !!                    nono   : number for local neighboring processors
557      !!----------------------------------------------------------------------
558      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points
559      !                                                               ! = T , U , V , F , W and I points
560      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary
561      !                                                               ! =  1. , the sign is kept
562      CHARACTER(len=3), OPTIONAL    , INTENT(in   ) ::   cd_mpp       ! fill the overlap area only
563      REAL(wp)        , OPTIONAL    , INTENT(in   ) ::   pval         ! background value (used at closed boundaries)
564      !!
565      INTEGER  ::   ji, jj, jl   ! dummy loop indices
566      INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES
567      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
568      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
[6140]569      INTEGER :: num_fields
570      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array
[5429]571      REAL(wp) ::   zland
[6140]572      INTEGER , DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat       ! for key_mpi_isend
[5429]573      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north
574      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east
575
576      !!----------------------------------------------------------------------
[6140]577      !
[5429]578      ALLOCATE( zt2ns(jpi,jprecj,2*num_fields), zt2sn(jpi,jprecj,2*num_fields),  &
579         &      zt2ew(jpj,jpreci,2*num_fields), zt2we(jpj,jpreci,2*num_fields)   )
580      !
581      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
[6140]582      ELSE                         ;   zland = 0._wp     ! zero by default
[5429]583      ENDIF
584
585      ! 1. standard boundary treatment
586      ! ------------------------------
587      !
588      !First Array
589      DO ii = 1 , num_fields
590         IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values
591            !
592            ! WARNING pt2d is defined only between nld and nle
593            DO jj = nlcj+1, jpj                 ! added line(s)   (inner only)
594               pt2d_array(ii)%pt2d(nldi  :nlei  , jj) = pt2d_array(ii)%pt2d(nldi:nlei, nlej)
595               pt2d_array(ii)%pt2d(1     :nldi-1, jj) = pt2d_array(ii)%pt2d(nldi     , nlej)
596               pt2d_array(ii)%pt2d(nlei+1:nlci  , jj) = pt2d_array(ii)%pt2d(     nlei, nlej) 
597            END DO
598            DO ji = nlci+1, jpi                 ! added column(s) (full)
599               pt2d_array(ii)%pt2d(ji, nldj  :nlej  ) = pt2d_array(ii)%pt2d(nlei, nldj:nlej)
600               pt2d_array(ii)%pt2d(ji, 1     :nldj-1) = pt2d_array(ii)%pt2d(nlei, nldj     )
601               pt2d_array(ii)%pt2d(ji, nlej+1:jpj   ) = pt2d_array(ii)%pt2d(nlei,      nlej)
602            END DO
603            !
604         ELSE                              ! standard close or cyclic treatment
605            !
606            !                                   ! East-West boundaries
607            IF( nbondi == 2 .AND.   &                ! Cyclic east-west
608               &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
609               pt2d_array(ii)%pt2d(  1  , : ) = pt2d_array(ii)%pt2d( jpim1, : )                                    ! west
610               pt2d_array(ii)%pt2d( jpi , : ) = pt2d_array(ii)%pt2d(   2  , : )                                    ! east
611            ELSE                                     ! closed
612               IF( .NOT. type_array(ii) == 'F' )   pt2d_array(ii)%pt2d(            1 : jpreci,:) = zland    ! south except F-point
613                                                   pt2d_array(ii)%pt2d(nlci-jpreci+1 : jpi   ,:) = zland    ! north
614            ENDIF
[7646]615                                                ! Noth-South boundaries
616            IF ( nbondj == 2 .AND. jperio == 7 )    THEN !* cyclic north south
617               pt2d_array(ii)%pt2d(:, 1   ) =   pt2d_array(ii)%pt2d(:, jpjm1 )
618               pt2d_array(ii)%pt2d(:, jpj ) =   pt2d_array(ii)%pt2d(:, 2 )         
619            ELSE   !             
620               !                                   ! North-South boundaries (closed)
[5429]621               IF( .NOT. type_array(ii) == 'F' )   pt2d_array(ii)%pt2d(:,             1:jprecj ) = zland    ! south except F-point
622                                                   pt2d_array(ii)%pt2d(:, nlcj-jprecj+1:jpj    ) = zland    ! north
623            !
[7646]624            ENDIF
625          ENDIF
[5429]626      END DO
627
628      ! 2. East and west directions exchange
629      ! ------------------------------------
630      ! we play with the neigbours AND the row number because of the periodicity
631      !
632      DO ii = 1 , num_fields
633         SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
634         CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
635            iihom = nlci-nreci
636            DO jl = 1, jpreci
637               zt2ew( : , jl , ii ) = pt2d_array(ii)%pt2d( jpreci+jl , : )
638               zt2we( : , jl , ii ) = pt2d_array(ii)%pt2d( iihom +jl , : )
639            END DO
640         END SELECT
641      END DO
642      !
643      !                           ! Migrations
644      imigr = jpreci * jpj
645      !
646      SELECT CASE ( nbondi )
647      CASE ( -1 )
648         CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req1 )
649         CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea )
650         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
651      CASE ( 0 )
652         CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 )
653         CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req2 )
654         CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea )
655         CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe )
656         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
657         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
658      CASE ( 1 )
659         CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 )
660         CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe )
661         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
662      END SELECT
663      !
664      !                           ! Write Dirichlet lateral conditions
665      iihom = nlci - jpreci
666      !
667
668      DO ii = 1 , num_fields
669         SELECT CASE ( nbondi )
670         CASE ( -1 )
671            DO jl = 1, jpreci
672               pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii)
673            END DO
674         CASE ( 0 )
675            DO jl = 1, jpreci
676               pt2d_array(ii)%pt2d( jl , : ) = zt2we(:,jl,num_fields+ii)
677               pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii)
678            END DO
679         CASE ( 1 )
680            DO jl = 1, jpreci
681               pt2d_array(ii)%pt2d( jl , : )= zt2we(:,jl,num_fields+ii)
682            END DO
683         END SELECT
684      END DO
685     
686      ! 3. North and south directions
687      ! -----------------------------
688      ! always closed : we play only with the neigbours
689      !
690      !First Array
691      DO ii = 1 , num_fields
692         IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
693            ijhom = nlcj-nrecj
694            DO jl = 1, jprecj
695               zt2sn(:,jl , ii) = pt2d_array(ii)%pt2d( : , ijhom +jl )
696               zt2ns(:,jl , ii) = pt2d_array(ii)%pt2d( : , jprecj+jl )
697            END DO
698         ENDIF
699      END DO
700      !
701      !                           ! Migrations
702      imigr = jprecj * jpi
703      !
704      SELECT CASE ( nbondj )
705      CASE ( -1 )
706         CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req1 )
707         CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono )
708         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
709      CASE ( 0 )
710         CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 )
711         CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req2 )
712         CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono )
713         CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso )
714         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
715         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
716      CASE ( 1 )
717         CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 )
718         CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso )
719         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
720      END SELECT
721      !
722      !                           ! Write Dirichlet lateral conditions
723      ijhom = nlcj - jprecj
724      !
725
726      DO ii = 1 , num_fields
727         !First Array
728         SELECT CASE ( nbondj )
729         CASE ( -1 )
730            DO jl = 1, jprecj
731               pt2d_array(ii)%pt2d( : , ijhom+jl ) = zt2ns( : , jl , num_fields+ii )
732            END DO
733         CASE ( 0 )
734            DO jl = 1, jprecj
735               pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii)
736               pt2d_array(ii)%pt2d( : , ijhom + jl ) = zt2ns( : , jl , num_fields + ii )
737            END DO
738         CASE ( 1 )
739            DO jl = 1, jprecj
740               pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii )
741            END DO
742         END SELECT
743      END DO
744     
745      ! 4. north fold treatment
746      ! -----------------------
747      !
748         !First Array
[6490]749      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
[5429]750         !
[6490]751         SELECT CASE ( jpni )
752         CASE ( 1 )     ;   
753             DO ii = 1 , num_fields 
754                       CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp
755             END DO
756         CASE DEFAULT   ;   CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields )   ! for all northern procs.
757         END SELECT
758         !
759      ENDIF
760        !
[6140]761      !
[5429]762      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we )
763      !
764   END SUBROUTINE mpp_lnk_2d_multiple
765
766   
[6140]767   SUBROUTINE load_array( pt2d, cd_type, psgn, pt2d_array, type_array, psgn_array, num_fields )
[5429]768      !!---------------------------------------------------------------------
[6140]769      REAL(wp), DIMENSION(jpi,jpj), TARGET, INTENT(inout) ::   pt2d    ! Second 2D array on which the boundary condition is applied
770      CHARACTER(len=1)                    , INTENT(in   ) ::   cd_type ! define the nature of ptab array grid-points
771      REAL(wp)                            , INTENT(in   ) ::   psgn    ! =-1 the sign change across the north fold boundary
[5429]772      TYPE(arrayptr)   , DIMENSION(9) ::   pt2d_array
773      CHARACTER(len=1) , DIMENSION(9) ::   type_array    ! define the nature of ptab array grid-points
774      REAL(wp)         , DIMENSION(9) ::   psgn_array    ! =-1 the sign change across the north fold boundary
[6140]775      INTEGER                            , INTENT (inout) :: num_fields 
[5429]776      !!---------------------------------------------------------------------
[6140]777      num_fields = num_fields + 1
778      pt2d_array(num_fields)%pt2d => pt2d
779      type_array(num_fields)      =  cd_type
780      psgn_array(num_fields)      =  psgn
[5429]781   END SUBROUTINE load_array
782   
783   
784   SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   &
785      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   &
786      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval)
787      !!---------------------------------------------------------------------
788      ! Second 2D array on which the boundary condition is applied
789      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA   
790      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE
791      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI 
792      ! define the nature of ptab array grid-points
793      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA
794      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE
795      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI
796      ! =-1 the sign change across the north fold boundary
797      REAL(wp)                                      , INTENT(in   ) ::   psgnA   
798      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE
799      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI   
800      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only
801      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries)
802      !!
803      TYPE(arrayptr)   , DIMENSION(9) ::   pt2d_array 
804      CHARACTER(len=1) , DIMENSION(9) ::   type_array    ! define the nature of ptab array grid-points
805      !                                                         ! = T , U , V , F , W and I points
806      REAL(wp)         , DIMENSION(9) ::   psgn_array    ! =-1 the sign change across the north fold boundary
807      INTEGER :: num_fields
808      !!---------------------------------------------------------------------
[6140]809      !
[5429]810      num_fields = 0
[6140]811      !
812      ! Load the first array
813      CALL load_array( pt2dA, cd_typeA, psgnA, pt2d_array, type_array, psgn_array, num_fields )
814      !
815      ! Look if more arrays are added
816      IF( PRESENT(psgnB) )   CALL load_array(pt2dB,cd_typeB,psgnB,pt2d_array, type_array, psgn_array,num_fields)
817      IF( PRESENT(psgnC) )   CALL load_array(pt2dC,cd_typeC,psgnC,pt2d_array, type_array, psgn_array,num_fields)
818      IF( PRESENT(psgnD) )   CALL load_array(pt2dD,cd_typeD,psgnD,pt2d_array, type_array, psgn_array,num_fields)
819      IF( PRESENT(psgnE) )   CALL load_array(pt2dE,cd_typeE,psgnE,pt2d_array, type_array, psgn_array,num_fields)
820      IF( PRESENT(psgnF) )   CALL load_array(pt2dF,cd_typeF,psgnF,pt2d_array, type_array, psgn_array,num_fields)
821      IF( PRESENT(psgnG) )   CALL load_array(pt2dG,cd_typeG,psgnG,pt2d_array, type_array, psgn_array,num_fields)
822      IF( PRESENT(psgnH) )   CALL load_array(pt2dH,cd_typeH,psgnH,pt2d_array, type_array, psgn_array,num_fields)
823      IF( PRESENT(psgnI) )   CALL load_array(pt2dI,cd_typeI,psgnI,pt2d_array, type_array, psgn_array,num_fields)
824      !
825      CALL mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, num_fields, cd_mpp,pval )
826      !
[5429]827   END SUBROUTINE mpp_lnk_2d_9
828
829
[888]830   SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
[51]831      !!----------------------------------------------------------------------
832      !!                  ***  routine mpp_lnk_2d  ***
[3764]833      !!
[51]834      !! ** Purpose :   Message passing manadgement for 2d array
835      !!
[3764]836      !! ** Method  :   Use mppsend and mpprecv function for passing mask
[51]837      !!      between processors following neighboring subdomains.
838      !!            domain parameters
839      !!                    nlci   : first dimension of the local subdomain
840      !!                    nlcj   : second dimension of the local subdomain
841      !!                    nbondi : mark for "east-west local boundary"
842      !!                    nbondj : mark for "north-south local boundary"
[3764]843      !!                    noea   : number for local neighboring processors
[51]844      !!                    nowe   : number for local neighboring processors
845      !!                    noso   : number for local neighboring processors
846      !!                    nono   : number for local neighboring processors
847      !!
848      !!----------------------------------------------------------------------
[1344]849      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied
850      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
851      !                                                         ! = T , U , V , F , W and I points
852      REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
853      !                                                         ! =  1. , the sign is kept
[3764]854      CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only
[1344]855      REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries)
856      !!
857      INTEGER  ::   ji, jj, jl   ! dummy loop indices
858      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
859      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
[888]860      REAL(wp) ::   zland
[6140]861      INTEGER, DIMENSION(MPI_STATUS_SIZE)     ::   ml_stat       ! for key_mpi_isend
[4152]862      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north
863      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east
[51]864      !!----------------------------------------------------------------------
[6140]865      !
[4152]866      ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  &
867         &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   )
868      !
[1344]869      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
[6140]870      ELSE                         ;   zland = 0._wp     ! zero by default
[888]871      ENDIF
872
[51]873      ! 1. standard boundary treatment
874      ! ------------------------------
[1344]875      !
[1718]876      IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values
[1344]877         !
[1718]878         ! WARNING pt2d is defined only between nld and nle
879         DO jj = nlcj+1, jpj                 ! added line(s)   (inner only)
[3764]880            pt2d(nldi  :nlei  , jj          ) = pt2d(nldi:nlei,     nlej)
[1718]881            pt2d(1     :nldi-1, jj          ) = pt2d(nldi     ,     nlej)
882            pt2d(nlei+1:nlci  , jj          ) = pt2d(     nlei,     nlej)
[610]883         END DO
[1718]884         DO ji = nlci+1, jpi                 ! added column(s) (full)
885            pt2d(ji           ,nldj  :nlej  ) = pt2d(     nlei,nldj:nlej)
886            pt2d(ji           ,1     :nldj-1) = pt2d(     nlei,nldj     )
887            pt2d(ji           ,nlej+1:jpj   ) = pt2d(     nlei,     nlej)
[1344]888         END DO
889         !
[3764]890      ELSE                              ! standard close or cyclic treatment
[1344]891         !
892         !                                   ! East-West boundaries
893         IF( nbondi == 2 .AND.   &                ! Cyclic east-west
[473]894            &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
[1344]895            pt2d( 1 ,:) = pt2d(jpim1,:)                                    ! west
896            pt2d(jpi,:) = pt2d(  2  ,:)                                    ! east
897         ELSE                                     ! closed
898            IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point
899                                         pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north
[473]900         ENDIF
[7646]901                                            ! North-South boudaries
902         IF ( nbondj == 2 .AND. jperio == 7 )    THEN !* cyclic north south
903            pt2d(:,  1 ) = pt2d(:,jpjm1)
904            pt2d(:, jpj) = pt2d(:,    2)
905         ELSE   
906         !                                   ! North-South boundaries (closed)
[1344]907            IF( .NOT. cd_type == 'F' )   pt2d(:,     1       :jprecj) = zland    !south except F-point
908                                         pt2d(:,nlcj-jprecj+1:jpj   ) = zland    ! north
[7646]909         ENDIF     
[51]910      ENDIF
[3]911
[1344]912      ! 2. East and west directions exchange
913      ! ------------------------------------
[3764]914      ! we play with the neigbours AND the row number because of the periodicity
[1344]915      !
916      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
917      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
[51]918         iihom = nlci-nreci
[7753]919         DO jl = 1, jpreci
920            zt2ew(:,jl,1) = pt2d(jpreci+jl,:)
921            zt2we(:,jl,1) = pt2d(iihom +jl,:)
[51]922         END DO
923      END SELECT
[1344]924      !
925      !                           ! Migrations
[51]926      imigr = jpreci * jpj
[1344]927      !
[51]928      SELECT CASE ( nbondi )
929      CASE ( -1 )
[4152]930         CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 )
931         CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
[300]932         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
[51]933      CASE ( 0 )
[4152]934         CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
935         CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 )
936         CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
937         CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
[300]938         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
939         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
[51]940      CASE ( 1 )
[4152]941         CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
942         CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
[300]943         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
[51]944      END SELECT
[1344]945      !
946      !                           ! Write Dirichlet lateral conditions
[51]947      iihom = nlci - jpreci
[1344]948      !
[51]949      SELECT CASE ( nbondi )
950      CASE ( -1 )
951         DO jl = 1, jpreci
[7753]952            pt2d(iihom+jl,:) = zt2ew(:,jl,2)
[51]953         END DO
954      CASE ( 0 )
955         DO jl = 1, jpreci
[7753]956            pt2d(jl      ,:) = zt2we(:,jl,2)
957            pt2d(iihom+jl,:) = zt2ew(:,jl,2)
[51]958         END DO
959      CASE ( 1 )
960         DO jl = 1, jpreci
[7753]961            pt2d(jl      ,:) = zt2we(:,jl,2)
[51]962         END DO
963      END SELECT
[3]964
965
[51]966      ! 3. North and south directions
967      ! -----------------------------
[1344]968      ! always closed : we play only with the neigbours
969      !
970      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
[51]971         ijhom = nlcj-nrecj
972         DO jl = 1, jprecj
[7753]973            zt2sn(:,jl,1) = pt2d(:,ijhom +jl)
974            zt2ns(:,jl,1) = pt2d(:,jprecj+jl)
[51]975         END DO
976      ENDIF
[1344]977      !
978      !                           ! Migrations
[51]979      imigr = jprecj * jpi
[1344]980      !
[51]981      SELECT CASE ( nbondj )
982      CASE ( -1 )
[4152]983         CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 )
984         CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
[300]985         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
[51]986      CASE ( 0 )
[4152]987         CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
988         CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 )
989         CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
990         CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
[300]991         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
992         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
[51]993      CASE ( 1 )
[4152]994         CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
995         CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
[300]996         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
[51]997      END SELECT
[1344]998      !
999      !                           ! Write Dirichlet lateral conditions
[51]1000      ijhom = nlcj - jprecj
[1344]1001      !
[51]1002      SELECT CASE ( nbondj )
1003      CASE ( -1 )
1004         DO jl = 1, jprecj
[7753]1005            pt2d(:,ijhom+jl) = zt2ns(:,jl,2)
[51]1006         END DO
1007      CASE ( 0 )
1008         DO jl = 1, jprecj
[7753]1009            pt2d(:,jl      ) = zt2sn(:,jl,2)
1010            pt2d(:,ijhom+jl) = zt2ns(:,jl,2)
[51]1011         END DO
[3764]1012      CASE ( 1 )
[51]1013         DO jl = 1, jprecj
[7753]1014            pt2d(:,jl      ) = zt2sn(:,jl,2)
[51]1015         END DO
[1344]1016      END SELECT
[3]1017
[1344]1018
[51]1019      ! 4. north fold treatment
1020      ! -----------------------
[1344]1021      !
1022      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
1023         !
1024         SELECT CASE ( jpni )
1025         CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d, cd_type, psgn )   ! only 1 northern proc, no mpp
1026         CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! for all northern procs.
1027         END SELECT
1028         !
[473]1029      ENDIF
[1344]1030      !
[4152]1031      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we )
1032      !
[51]1033   END SUBROUTINE mpp_lnk_2d
[3]1034
1035
[473]1036   SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn )
1037      !!----------------------------------------------------------------------
1038      !!                  ***  routine mpp_lnk_3d_gather  ***
1039      !!
1040      !! ** Purpose :   Message passing manadgement for two 3D arrays
1041      !!
[3764]1042      !! ** Method  :   Use mppsend and mpprecv function for passing mask
[473]1043      !!      between processors following neighboring subdomains.
1044      !!            domain parameters
1045      !!                    nlci   : first dimension of the local subdomain
1046      !!                    nlcj   : second dimension of the local subdomain
1047      !!                    nbondi : mark for "east-west local boundary"
1048      !!                    nbondj : mark for "north-south local boundary"
[3764]1049      !!                    noea   : number for local neighboring processors
[473]1050      !!                    nowe   : number for local neighboring processors
1051      !!                    noso   : number for local neighboring processors
1052      !!                    nono   : number for local neighboring processors
1053      !!
1054      !! ** Action  :   ptab1 and ptab2  with update value at its periphery
1055      !!
1056      !!----------------------------------------------------------------------
[3764]1057      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab1     ! first and second 3D array on which
[1344]1058      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab2     ! the boundary condition is applied
[3764]1059      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type1  ! nature of ptab1 and ptab2 arrays
[1344]1060      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type2  ! i.e. grid-points = T , U , V , F or W points
1061      REAL(wp)                        , INTENT(in   ) ::   psgn      ! =-1 the sign change across the north fold boundary
1062      !!                                                             ! =  1. , the sign is kept
1063      INTEGER  ::   jl   ! dummy loop indices
1064      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
1065      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
[6140]1066      INTEGER , DIMENSION(MPI_STATUS_SIZE)        ::   ml_stat   ! for key_mpi_isend
[4152]1067      REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zt4ns, zt4sn   ! 2 x 3d for north-south & south-north
1068      REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE ::   zt4ew, zt4we   ! 2 x 3d for east-west & west-east
[473]1069      !!----------------------------------------------------------------------
[6140]1070      !
[4152]1071      ALLOCATE( zt4ns(jpi,jprecj,jpk,2,2), zt4sn(jpi,jprecj,jpk,2,2) ,    &
1072         &      zt4ew(jpj,jpreci,jpk,2,2), zt4we(jpj,jpreci,jpk,2,2) )
[6140]1073      !
[473]1074      ! 1. standard boundary treatment
1075      ! ------------------------------
[1344]1076      !                                      ! East-West boundaries
1077      !                                           !* Cyclic east-west
1078      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
[473]1079         ptab1( 1 ,:,:) = ptab1(jpim1,:,:)
1080         ptab1(jpi,:,:) = ptab1(  2  ,:,:)
1081         ptab2( 1 ,:,:) = ptab2(jpim1,:,:)
1082         ptab2(jpi,:,:) = ptab2(  2  ,:,:)
[1344]1083      ELSE                                        !* closed
1084         IF( .NOT. cd_type1 == 'F' )   ptab1(     1       :jpreci,:,:) = 0.e0    ! south except at F-point
1085         IF( .NOT. cd_type2 == 'F' )   ptab2(     1       :jpreci,:,:) = 0.e0
1086                                       ptab1(nlci-jpreci+1:jpi   ,:,:) = 0.e0    ! north
1087                                       ptab2(nlci-jpreci+1:jpi   ,:,:) = 0.e0
[473]1088      ENDIF
[7646]1089                                            ! North-South boundaries
1090      IF ( nbondj == 2 .AND. jperio == 7 )    THEN !* cyclic north south
1091         ptab1(:,     1       ,:) = ptab1(: ,  jpjm1 , :)
1092         ptab1(:,   jpj       ,:) = ptab1(: ,      2 , :)
1093         ptab2(:,     1       ,:) = ptab2(: ,  jpjm1 , :)
1094         ptab2(:,   jpj       ,:) = ptab2(: ,      2 , :)
1095      ELSE     
1096      !                                      ! North-South boundaries closed
[1344]1097      IF( .NOT. cd_type1 == 'F' )   ptab1(:,     1       :jprecj,:) = 0.e0    ! south except at F-point
1098      IF( .NOT. cd_type2 == 'F' )   ptab2(:,     1       :jprecj,:) = 0.e0
1099                                    ptab1(:,nlcj-jprecj+1:jpj   ,:) = 0.e0    ! north
1100                                    ptab2(:,nlcj-jprecj+1:jpj   ,:) = 0.e0
[7646]1101      ENDIF     
[473]1102
1103      ! 2. East and west directions exchange
1104      ! ------------------------------------
[3764]1105      ! we play with the neigbours AND the row number because of the periodicity
[1344]1106      !
1107      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
1108      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
[473]1109         iihom = nlci-nreci
1110         DO jl = 1, jpreci
[4152]1111            zt4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:)
1112            zt4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:)
1113            zt4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:)
1114            zt4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:)
[473]1115         END DO
1116      END SELECT
[1344]1117      !
1118      !                           ! Migrations
[473]1119      imigr = jpreci * jpj * jpk *2
[1344]1120      !
[3764]1121      SELECT CASE ( nbondi )
[473]1122      CASE ( -1 )
[4152]1123         CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req1 )
1124         CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea )
[473]1125         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1126      CASE ( 0 )
[4152]1127         CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
1128         CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req2 )
1129         CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea )
1130         CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe )
[473]1131         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1132         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
1133      CASE ( 1 )
[4152]1134         CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
1135         CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe )
[473]1136         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1137      END SELECT
[1344]1138      !
1139      !                           ! Write Dirichlet lateral conditions
1140      iihom = nlci - jpreci
1141      !
[473]1142      SELECT CASE ( nbondi )
1143      CASE ( -1 )
1144         DO jl = 1, jpreci
[4152]1145            ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2)
1146            ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2)
[473]1147         END DO
[3764]1148      CASE ( 0 )
[473]1149         DO jl = 1, jpreci
[4152]1150            ptab1(jl      ,:,:) = zt4we(:,jl,:,1,2)
1151            ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2)
1152            ptab2(jl      ,:,:) = zt4we(:,jl,:,2,2)
1153            ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2)
[473]1154         END DO
1155      CASE ( 1 )
1156         DO jl = 1, jpreci
[4152]1157            ptab1(jl      ,:,:) = zt4we(:,jl,:,1,2)
1158            ptab2(jl      ,:,:) = zt4we(:,jl,:,2,2)
[473]1159         END DO
1160      END SELECT
1161
1162
1163      ! 3. North and south directions
1164      ! -----------------------------
[1344]1165      ! always closed : we play only with the neigbours
1166      !
1167      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
1168         ijhom = nlcj - nrecj
[473]1169         DO jl = 1, jprecj
[4152]1170            zt4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:)
1171            zt4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:)
1172            zt4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:)
1173            zt4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:)
[473]1174         END DO
1175      ENDIF
[1344]1176      !
1177      !                           ! Migrations
[473]1178      imigr = jprecj * jpi * jpk * 2
[1344]1179      !
[3764]1180      SELECT CASE ( nbondj )
[473]1181      CASE ( -1 )
[4152]1182         CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req1 )
1183         CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono )
[473]1184         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1185      CASE ( 0 )
[4152]1186         CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 )
1187         CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req2 )
1188         CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono )
1189         CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso )
[473]1190         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1191         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
[3764]1192      CASE ( 1 )
[4152]1193         CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 )
1194         CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso )
[473]1195         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1196      END SELECT
[1344]1197      !
1198      !                           ! Write Dirichlet lateral conditions
1199      ijhom = nlcj - jprecj
1200      !
[473]1201      SELECT CASE ( nbondj )
1202      CASE ( -1 )
1203         DO jl = 1, jprecj
[4152]1204            ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2)
1205            ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2)
[473]1206         END DO
[3764]1207      CASE ( 0 )
[473]1208         DO jl = 1, jprecj
[4152]1209            ptab1(:,jl      ,:) = zt4sn(:,jl,:,1,2)
1210            ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2)
1211            ptab2(:,jl      ,:) = zt4sn(:,jl,:,2,2)
1212            ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2)
[473]1213         END DO
1214      CASE ( 1 )
1215         DO jl = 1, jprecj
[4152]1216            ptab1(:,jl,:) = zt4sn(:,jl,:,1,2)
1217            ptab2(:,jl,:) = zt4sn(:,jl,:,2,2)
[473]1218         END DO
1219      END SELECT
1220
1221
1222      ! 4. north fold treatment
1223      ! -----------------------
[1344]1224      IF( npolj /= 0 ) THEN
1225         !
1226         SELECT CASE ( jpni )
[3764]1227         CASE ( 1 )
[1344]1228            CALL lbc_nfd      ( ptab1, cd_type1, psgn )   ! only for northern procs.
1229            CALL lbc_nfd      ( ptab2, cd_type2, psgn )
1230         CASE DEFAULT
1231            CALL mpp_lbc_north( ptab1, cd_type1, psgn )   ! for all northern procs.
1232            CALL mpp_lbc_north (ptab2, cd_type2, psgn)
[3764]1233         END SELECT
[1344]1234         !
1235      ENDIF
1236      !
[4152]1237      DEALLOCATE( zt4ns, zt4sn, zt4ew, zt4we )
1238      !
[473]1239   END SUBROUTINE mpp_lnk_3d_gather
1240
1241
[3609]1242   SUBROUTINE mpp_lnk_2d_e( pt2d, cd_type, psgn, jpri, jprj )
[311]1243      !!----------------------------------------------------------------------
1244      !!                  ***  routine mpp_lnk_2d_e  ***
[3764]1245      !!
[311]1246      !! ** Purpose :   Message passing manadgement for 2d array (with halo)
1247      !!
[3764]1248      !! ** Method  :   Use mppsend and mpprecv function for passing mask
[311]1249      !!      between processors following neighboring subdomains.
1250      !!            domain parameters
1251      !!                    nlci   : first dimension of the local subdomain
1252      !!                    nlcj   : second dimension of the local subdomain
[3609]1253      !!                    jpri   : number of rows for extra outer halo
1254      !!                    jprj   : number of columns for extra outer halo
[311]1255      !!                    nbondi : mark for "east-west local boundary"
1256      !!                    nbondj : mark for "north-south local boundary"
[3764]1257      !!                    noea   : number for local neighboring processors
[311]1258      !!                    nowe   : number for local neighboring processors
1259      !!                    noso   : number for local neighboring processors
1260      !!                    nono   : number for local neighboring processors
1261      !!
1262      !!----------------------------------------------------------------------
[3609]1263      INTEGER                                             , INTENT(in   ) ::   jpri
1264      INTEGER                                             , INTENT(in   ) ::   jprj
1265      REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
1266      CHARACTER(len=1)                                    , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points
1267      !                                                                                 ! = T , U , V , F , W and I points
1268      REAL(wp)                                            , INTENT(in   ) ::   psgn     ! =-1 the sign change across the
1269      !!                                                                                ! north boundary, =  1. otherwise
[1344]1270      INTEGER  ::   jl   ! dummy loop indices
1271      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
1272      INTEGER  ::   ipreci, iprecj             ! temporary integers
1273      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
1274      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
[3609]1275      !!
1276      REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns
1277      REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn
1278      REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe
1279      REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew
[1344]1280      !!----------------------------------------------------------------------
[311]1281
[3609]1282      ipreci = jpreci + jpri      ! take into account outer extra 2D overlap area
1283      iprecj = jprecj + jprj
[311]1284
1285
1286      ! 1. standard boundary treatment
1287      ! ------------------------------
[1344]1288      ! Order matters Here !!!!
1289      !
[7646]1290                                           ! North-South cyclic
1291      IF ( nbondj == 2 .AND. jperio == 7 )    THEN !* cyclic north south
1292         pt2d(:, 1-jprj:  1     ) = pt2d ( :, jpjm1-jprj:jpjm1)
1293         pt2d(:, jpj   :jpj+jprj) = pt2d ( :, 2         :2+jprj)
1294      ELSE
1295       
1296      !                                      !* North-South boundaries (closed)
[3609]1297      IF( .NOT. cd_type == 'F' )   pt2d(:,  1-jprj   :  jprecj  ) = 0.e0    ! south except at F-point
1298                                   pt2d(:,nlcj-jprecj+1:jpj+jprj) = 0.e0    ! north
[7646]1299      ENDIF
1300                               
[1344]1301      !                                      ! East-West boundaries
1302      !                                           !* Cyclic east-west
1303      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
[3609]1304         pt2d(1-jpri:     1    ,:) = pt2d(jpim1-jpri:  jpim1 ,:)       ! east
1305         pt2d(   jpi  :jpi+jpri,:) = pt2d(     2      :2+jpri,:)       ! west
[1344]1306         !
1307      ELSE                                        !* closed
[3609]1308         IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :jpreci    ,:) = 0.e0    ! south except at F-point
1309                                      pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0    ! north
[1344]1310      ENDIF
1311      !
[311]1312
[1344]1313      ! north fold treatment
1314      ! -----------------------
1315      IF( npolj /= 0 ) THEN
1316         !
1317         SELECT CASE ( jpni )
[3609]1318         CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj )
[1344]1319         CASE DEFAULT   ;   CALL mpp_lbc_north_e( pt2d                    , cd_type, psgn               )
[3764]1320         END SELECT
[1344]1321         !
[311]1322      ENDIF
1323
[1344]1324      ! 2. East and west directions exchange
1325      ! ------------------------------------
[3764]1326      ! we play with the neigbours AND the row number because of the periodicity
[1344]1327      !
1328      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
1329      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
[3609]1330         iihom = nlci-nreci-jpri
[311]1331         DO jl = 1, ipreci
[3609]1332            r2dew(:,jl,1) = pt2d(jpreci+jl,:)
1333            r2dwe(:,jl,1) = pt2d(iihom +jl,:)
[311]1334         END DO
1335      END SELECT
[1344]1336      !
1337      !                           ! Migrations
[3609]1338      imigr = ipreci * ( jpj + 2*jprj)
[1344]1339      !
[311]1340      SELECT CASE ( nbondi )
1341      CASE ( -1 )
[3609]1342         CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 )
1343         CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
[311]1344         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1345      CASE ( 0 )
[3609]1346         CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
1347         CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 )
1348         CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
1349         CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
[311]1350         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1351         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1352      CASE ( 1 )
[3609]1353         CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
1354         CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
[311]1355         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1356      END SELECT
[1344]1357      !
1358      !                           ! Write Dirichlet lateral conditions
[311]1359      iihom = nlci - jpreci
[1344]1360      !
[311]1361      SELECT CASE ( nbondi )
1362      CASE ( -1 )
1363         DO jl = 1, ipreci
[3609]1364            pt2d(iihom+jl,:) = r2dew(:,jl,2)
[311]1365         END DO
1366      CASE ( 0 )
1367         DO jl = 1, ipreci
[3609]1368            pt2d(jl-jpri,:) = r2dwe(:,jl,2)
1369            pt2d( iihom+jl,:) = r2dew(:,jl,2)
[311]1370         END DO
1371      CASE ( 1 )
1372         DO jl = 1, ipreci
[3609]1373            pt2d(jl-jpri,:) = r2dwe(:,jl,2)
[311]1374         END DO
1375      END SELECT
1376
1377
1378      ! 3. North and south directions
1379      ! -----------------------------
[1344]1380      ! always closed : we play only with the neigbours
1381      !
1382      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
[3609]1383         ijhom = nlcj-nrecj-jprj
[311]1384         DO jl = 1, iprecj
[3609]1385            r2dsn(:,jl,1) = pt2d(:,ijhom +jl)
1386            r2dns(:,jl,1) = pt2d(:,jprecj+jl)
[311]1387         END DO
1388      ENDIF
[1344]1389      !
1390      !                           ! Migrations
[3609]1391      imigr = iprecj * ( jpi + 2*jpri )
[1344]1392      !
[311]1393      SELECT CASE ( nbondj )
1394      CASE ( -1 )
[3609]1395         CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 )
1396         CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
[311]1397         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1398      CASE ( 0 )
[3609]1399         CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
1400         CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 )
1401         CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
1402         CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
[311]1403         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1404         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1405      CASE ( 1 )
[3609]1406         CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
1407         CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
[311]1408         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1409      END SELECT
[1344]1410      !
1411      !                           ! Write Dirichlet lateral conditions
[3764]1412      ijhom = nlcj - jprecj
[1344]1413      !
[311]1414      SELECT CASE ( nbondj )
1415      CASE ( -1 )
1416         DO jl = 1, iprecj
[3609]1417            pt2d(:,ijhom+jl) = r2dns(:,jl,2)
[311]1418         END DO
1419      CASE ( 0 )
1420         DO jl = 1, iprecj
[3609]1421            pt2d(:,jl-jprj) = r2dsn(:,jl,2)
1422            pt2d(:,ijhom+jl ) = r2dns(:,jl,2)
[311]1423         END DO
[3764]1424      CASE ( 1 )
[311]1425         DO jl = 1, iprecj
[3609]1426            pt2d(:,jl-jprj) = r2dsn(:,jl,2)
[311]1427         END DO
[1344]1428      END SELECT
[6140]1429      !
[311]1430   END SUBROUTINE mpp_lnk_2d_e
1431
[6140]1432   SUBROUTINE mpp_lnk_sum_3d( ptab, cd_type, psgn, cd_mpp, pval )
1433      !!----------------------------------------------------------------------
1434      !!                  ***  routine mpp_lnk_sum_3d  ***
1435      !!
1436      !! ** Purpose :   Message passing manadgement (sum the overlap region)
1437      !!
1438      !! ** Method  :   Use mppsend and mpprecv function for passing mask
1439      !!      between processors following neighboring subdomains.
1440      !!            domain parameters
1441      !!                    nlci   : first dimension of the local subdomain
1442      !!                    nlcj   : second dimension of the local subdomain
1443      !!                    nbondi : mark for "east-west local boundary"
1444      !!                    nbondj : mark for "north-south local boundary"
1445      !!                    noea   : number for local neighboring processors
1446      !!                    nowe   : number for local neighboring processors
1447      !!                    noso   : number for local neighboring processors
1448      !!                    nono   : number for local neighboring processors
1449      !!
1450      !! ** Action  :   ptab with update value at its periphery
1451      !!
1452      !!----------------------------------------------------------------------
1453      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied
1454      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
1455      !                                                             ! = T , U , V , F , W points
1456      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
1457      !                                                             ! =  1. , the sign is kept
1458      CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only
1459      REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries)
1460      !!
1461      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices
1462      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
1463      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
1464      REAL(wp) ::   zland
1465      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
1466      !
1467      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north
1468      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east
[311]1469
[6140]1470      !!----------------------------------------------------------------------
1471     
1472      ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2),   &
1473         &      zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2)  )
1474
1475      !
1476      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
1477      ELSE                         ;   zland = 0.e0      ! zero by default
1478      ENDIF
1479
1480      ! 1. standard boundary treatment
1481      ! ------------------------------
1482      ! 2. East and west directions exchange
1483      ! ------------------------------------
1484      ! we play with the neigbours AND the row number because of the periodicity
1485      !
1486      SELECT CASE ( nbondi )      ! Read lateral conditions
1487      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
1488      iihom = nlci-jpreci
1489         DO jl = 1, jpreci
1490            zt3ew(:,jl,:,1) = ptab(jl      ,:,:) ; ptab(jl      ,:,:) = 0.0_wp
1491            zt3we(:,jl,:,1) = ptab(iihom+jl,:,:) ; ptab(iihom+jl,:,:) = 0.0_wp 
1492         END DO
1493      END SELECT
1494      !
1495      !                           ! Migrations
1496      imigr = jpreci * jpj * jpk
1497      !
1498      SELECT CASE ( nbondi )
1499      CASE ( -1 )
1500         CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 )
1501         CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
1502         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1503      CASE ( 0 )
1504         CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
1505         CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 )
1506         CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
1507         CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
1508         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1509         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
1510      CASE ( 1 )
1511         CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
1512         CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
1513         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1514      END SELECT
1515      !
1516      !                           ! Write lateral conditions
1517      iihom = nlci-nreci
1518      !
1519      SELECT CASE ( nbondi )
1520      CASE ( -1 )
1521         DO jl = 1, jpreci
1522            ptab(iihom+jl,:,:) = ptab(iihom+jl,:,:) + zt3ew(:,jl,:,2)
1523         END DO
1524      CASE ( 0 )
1525         DO jl = 1, jpreci
1526            ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2)
1527            ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2)
1528         END DO
1529      CASE ( 1 )
1530         DO jl = 1, jpreci
1531            ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2)
1532         END DO
1533      END SELECT
1534
1535
1536      ! 3. North and south directions
1537      ! -----------------------------
1538      ! always closed : we play only with the neigbours
1539      !
1540      IF( nbondj /= 2 ) THEN      ! Read lateral conditions
1541         ijhom = nlcj-jprecj
1542         DO jl = 1, jprecj
1543            zt3sn(:,jl,:,1) = ptab(:,ijhom+jl,:) ; ptab(:,ijhom+jl,:) = 0.0_wp
1544            zt3ns(:,jl,:,1) = ptab(:,jl      ,:) ; ptab(:,jl      ,:) = 0.0_wp
1545         END DO
1546      ENDIF
1547      !
1548      !                           ! Migrations
1549      imigr = jprecj * jpi * jpk
1550      !
1551      SELECT CASE ( nbondj )
1552      CASE ( -1 )
1553         CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 )
1554         CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
1555         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1556      CASE ( 0 )
1557         CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
1558         CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 )
1559         CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
1560         CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
1561         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1562         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
1563      CASE ( 1 )
1564         CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
1565         CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
1566         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1567      END SELECT
1568      !
1569      !                           ! Write lateral conditions
1570      ijhom = nlcj-nrecj
1571      !
1572      SELECT CASE ( nbondj )
1573      CASE ( -1 )
1574         DO jl = 1, jprecj
1575            ptab(:,ijhom+jl,:) = ptab(:,ijhom+jl,:) + zt3ns(:,jl,:,2)
1576         END DO
1577      CASE ( 0 )
1578         DO jl = 1, jprecj
1579            ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl,:,2)
1580            ptab(:,ijhom +jl,:) = ptab(:,ijhom +jl,:) + zt3ns(:,jl,:,2)
1581         END DO
1582      CASE ( 1 )
1583         DO jl = 1, jprecj
1584            ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl   ,:,2)
1585         END DO
1586      END SELECT
1587
1588
1589      ! 4. north fold treatment
1590      ! -----------------------
1591      !
1592      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
1593         !
1594         SELECT CASE ( jpni )
1595         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp
1596         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs.
1597         END SELECT
1598         !
1599      ENDIF
1600      !
1601      DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we )
1602      !
1603   END SUBROUTINE mpp_lnk_sum_3d
1604
1605   SUBROUTINE mpp_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval )
1606      !!----------------------------------------------------------------------
1607      !!                  ***  routine mpp_lnk_sum_2d  ***
1608      !!
1609      !! ** Purpose :   Message passing manadgement for 2d array (sum the overlap region)
1610      !!
1611      !! ** Method  :   Use mppsend and mpprecv function for passing mask
1612      !!      between processors following neighboring subdomains.
1613      !!            domain parameters
1614      !!                    nlci   : first dimension of the local subdomain
1615      !!                    nlcj   : second dimension of the local subdomain
1616      !!                    nbondi : mark for "east-west local boundary"
1617      !!                    nbondj : mark for "north-south local boundary"
1618      !!                    noea   : number for local neighboring processors
1619      !!                    nowe   : number for local neighboring processors
1620      !!                    noso   : number for local neighboring processors
1621      !!                    nono   : number for local neighboring processors
1622      !!
1623      !!----------------------------------------------------------------------
1624      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied
1625      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
1626      !                                                         ! = T , U , V , F , W and I points
1627      REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
1628      !                                                         ! =  1. , the sign is kept
1629      CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only
1630      REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries)
1631      !!
1632      INTEGER  ::   ji, jj, jl   ! dummy loop indices
1633      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
1634      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
1635      REAL(wp) ::   zland
1636      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
1637      !
1638      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north
1639      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east
1640
1641      !!----------------------------------------------------------------------
1642
1643      ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  &
1644         &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   )
1645
1646      !
1647      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
1648      ELSE                         ;   zland = 0.e0      ! zero by default
1649      ENDIF
1650
1651      ! 1. standard boundary treatment
1652      ! ------------------------------
1653      ! 2. East and west directions exchange
1654      ! ------------------------------------
1655      ! we play with the neigbours AND the row number because of the periodicity
1656      !
1657      SELECT CASE ( nbondi )      ! Read lateral conditions
1658      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
1659         iihom = nlci - jpreci
1660         DO jl = 1, jpreci
1661            zt2ew(:,jl,1) = pt2d(jl       ,:) ; pt2d(jl       ,:) = 0.0_wp
1662            zt2we(:,jl,1) = pt2d(iihom +jl,:) ; pt2d(iihom +jl,:) = 0.0_wp
1663         END DO
1664      END SELECT
1665      !
1666      !                           ! Migrations
1667      imigr = jpreci * jpj
1668      !
1669      SELECT CASE ( nbondi )
1670      CASE ( -1 )
1671         CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 )
1672         CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
1673         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1674      CASE ( 0 )
1675         CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
1676         CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 )
1677         CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
1678         CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
1679         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1680         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1681      CASE ( 1 )
1682         CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
1683         CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
1684         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1685      END SELECT
1686      !
1687      !                           ! Write lateral conditions
1688      iihom = nlci-nreci
1689      !
1690      SELECT CASE ( nbondi )
1691      CASE ( -1 )
1692         DO jl = 1, jpreci
1693            pt2d(iihom+jl,:) = pt2d(iihom+jl,:) + zt2ew(:,jl,2)
1694         END DO
1695      CASE ( 0 )
1696         DO jl = 1, jpreci
1697            pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2)
1698            pt2d(iihom +jl,:) = pt2d(iihom +jl,:) + zt2ew(:,jl,2)
1699         END DO
1700      CASE ( 1 )
1701         DO jl = 1, jpreci
1702            pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2)
1703         END DO
1704      END SELECT
1705
1706
1707      ! 3. North and south directions
1708      ! -----------------------------
1709      ! always closed : we play only with the neigbours
1710      !
1711      IF( nbondj /= 2 ) THEN      ! Read lateral conditions
1712         ijhom = nlcj - jprecj
1713         DO jl = 1, jprecj
1714            zt2sn(:,jl,1) = pt2d(:,ijhom +jl) ; pt2d(:,ijhom +jl) = 0.0_wp
1715            zt2ns(:,jl,1) = pt2d(:,jl       ) ; pt2d(:,jl       ) = 0.0_wp
1716         END DO
1717      ENDIF
1718      !
1719      !                           ! Migrations
1720      imigr = jprecj * jpi
1721      !
1722      SELECT CASE ( nbondj )
1723      CASE ( -1 )
1724         CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 )
1725         CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
1726         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1727      CASE ( 0 )
1728         CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
1729         CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 )
1730         CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
1731         CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
1732         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1733         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1734      CASE ( 1 )
1735         CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
1736         CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
1737         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1738      END SELECT
1739      !
1740      !                           ! Write lateral conditions
1741      ijhom = nlcj-nrecj
1742      !
1743      SELECT CASE ( nbondj )
1744      CASE ( -1 )
1745         DO jl = 1, jprecj
1746            pt2d(:,ijhom+jl) = pt2d(:,ijhom+jl) + zt2ns(:,jl,2)
1747         END DO
1748      CASE ( 0 )
1749         DO jl = 1, jprecj
1750            pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2)
1751            pt2d(:,ijhom +jl) = pt2d(:,ijhom +jl) + zt2ns(:,jl,2)
1752         END DO
1753      CASE ( 1 )
1754         DO jl = 1, jprecj
1755            pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2)
1756         END DO
1757      END SELECT
1758
1759
1760      ! 4. north fold treatment
1761      ! -----------------------
1762      !
1763      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
1764         !
1765         SELECT CASE ( jpni )
1766         CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d, cd_type, psgn )   ! only 1 northern proc, no mpp
1767         CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! for all northern procs.
1768         END SELECT
1769         !
1770      ENDIF
1771      !
1772      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we )
1773      !
1774   END SUBROUTINE mpp_lnk_sum_2d
1775
[1344]1776   SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req )
[51]1777      !!----------------------------------------------------------------------
1778      !!                  ***  routine mppsend  ***
[3764]1779      !!
[51]1780      !! ** Purpose :   Send messag passing array
1781      !!
1782      !!----------------------------------------------------------------------
[1344]1783      REAL(wp), INTENT(inout) ::   pmess(*)   ! array of real
1784      INTEGER , INTENT(in   ) ::   kbytes     ! size of the array pmess
1785      INTEGER , INTENT(in   ) ::   kdest      ! receive process number
1786      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message
1787      INTEGER , INTENT(in   ) ::   md_req     ! argument for isend
1788      !!
1789      INTEGER ::   iflag
[51]1790      !!----------------------------------------------------------------------
[1344]1791      !
[1601]1792      SELECT CASE ( cn_mpi_send )
[300]1793      CASE ( 'S' )                ! Standard mpi send (blocking)
[1344]1794         CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa        , iflag )
[300]1795      CASE ( 'B' )                ! Buffer mpi send (blocking)
[1344]1796         CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa        , iflag )
[300]1797      CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
[1344]1798         ! be carefull, one more argument here : the mpi request identifier..
1799         CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa, md_req, iflag )
[300]1800      END SELECT
[1344]1801      !
[51]1802   END SUBROUTINE mppsend
[3]1803
1804
[3294]1805   SUBROUTINE mpprecv( ktyp, pmess, kbytes, ksource )
[51]1806      !!----------------------------------------------------------------------
1807      !!                  ***  routine mpprecv  ***
1808      !!
1809      !! ** Purpose :   Receive messag passing array
1810      !!
1811      !!----------------------------------------------------------------------
[1344]1812      REAL(wp), INTENT(inout) ::   pmess(*)   ! array of real
1813      INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess
1814      INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message
[3764]1815      INTEGER, OPTIONAL, INTENT(in) :: ksource    ! source process number
[1344]1816      !!
[51]1817      INTEGER :: istatus(mpi_status_size)
1818      INTEGER :: iflag
[3294]1819      INTEGER :: use_source
[1344]1820      !!----------------------------------------------------------------------
1821      !
[3764]1822      ! If a specific process number has been passed to the receive call,
[3294]1823      ! use that one. Default is to use mpi_any_source
[6140]1824      use_source = mpi_any_source
1825      IF( PRESENT(ksource) )   use_source = ksource
1826      !
[3294]1827      CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_opa, istatus, iflag )
[1344]1828      !
[51]1829   END SUBROUTINE mpprecv
[3]1830
1831
[51]1832   SUBROUTINE mppgather( ptab, kp, pio )
1833      !!----------------------------------------------------------------------
1834      !!                   ***  routine mppgather  ***
[3764]1835      !!
1836      !! ** Purpose :   Transfert between a local subdomain array and a work
[51]1837      !!     array which is distributed following the vertical level.
1838      !!
[1344]1839      !!----------------------------------------------------------------------
[6140]1840      REAL(wp), DIMENSION(jpi,jpj)      , INTENT(in   ) ::   ptab   ! subdomain input array
1841      INTEGER                           , INTENT(in   ) ::   kp     ! record length
[1344]1842      REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT(  out) ::   pio    ! subdomain input array
[51]1843      !!
[1344]1844      INTEGER :: itaille, ierror   ! temporary integer
[51]1845      !!---------------------------------------------------------------------
[1344]1846      !
1847      itaille = jpi * jpj
1848      CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille     ,   &
[3764]1849         &                            mpi_double_precision, kp , mpi_comm_opa, ierror )
[1344]1850      !
[51]1851   END SUBROUTINE mppgather
[3]1852
1853
[51]1854   SUBROUTINE mppscatter( pio, kp, ptab )
1855      !!----------------------------------------------------------------------
1856      !!                  ***  routine mppscatter  ***
1857      !!
[3764]1858      !! ** Purpose :   Transfert between awork array which is distributed
[51]1859      !!      following the vertical level and the local subdomain array.
1860      !!
1861      !!----------------------------------------------------------------------
[6140]1862      REAL(wp), DIMENSION(jpi,jpj,jpnij)  ::   pio    ! output array
1863      INTEGER                             ::   kp     ! Tag (not used with MPI
1864      REAL(wp), DIMENSION(jpi,jpj)        ::   ptab   ! subdomain array input
[1344]1865      !!
1866      INTEGER :: itaille, ierror   ! temporary integer
[51]1867      !!---------------------------------------------------------------------
[1344]1868      !
[6140]1869      itaille = jpi * jpj
[1344]1870      !
1871      CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille     ,   &
1872         &                            mpi_double_precision, kp  , mpi_comm_opa, ierror )
1873      !
[51]1874   END SUBROUTINE mppscatter
[3]1875
1876
[869]1877   SUBROUTINE mppmax_a_int( ktab, kdim, kcom )
[681]1878      !!----------------------------------------------------------------------
1879      !!                  ***  routine mppmax_a_int  ***
[3764]1880      !!
[681]1881      !! ** Purpose :   Find maximum value in an integer layout array
1882      !!
1883      !!----------------------------------------------------------------------
[1344]1884      INTEGER , INTENT(in   )                  ::   kdim   ! size of array
1885      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab   ! input array
[3764]1886      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom   !
[6140]1887      !
[1344]1888      INTEGER :: ierror, localcomm   ! temporary integer
[681]1889      INTEGER, DIMENSION(kdim) ::   iwork
[1344]1890      !!----------------------------------------------------------------------
1891      !
[869]1892      localcomm = mpi_comm_opa
[1344]1893      IF( PRESENT(kcom) )   localcomm = kcom
1894      !
1895      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, localcomm, ierror )
1896      !
[681]1897      ktab(:) = iwork(:)
[1344]1898      !
[681]1899   END SUBROUTINE mppmax_a_int
1900
1901
[869]1902   SUBROUTINE mppmax_int( ktab, kcom )
[681]1903      !!----------------------------------------------------------------------
1904      !!                  ***  routine mppmax_int  ***
1905      !!
[1344]1906      !! ** Purpose :   Find maximum value in an integer layout array
[681]1907      !!
1908      !!----------------------------------------------------------------------
[6140]1909      INTEGER, INTENT(inout)           ::   ktab   ! ???
1910      INTEGER, INTENT(in   ), OPTIONAL ::   kcom   ! ???
1911      !
[1344]1912      INTEGER ::   ierror, iwork, localcomm   ! temporary integer
1913      !!----------------------------------------------------------------------
1914      !
[3764]1915      localcomm = mpi_comm_opa
[1344]1916      IF( PRESENT(kcom) )   localcomm = kcom
1917      !
[6140]1918      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror )
[1344]1919      !
[681]1920      ktab = iwork
[1344]1921      !
[681]1922   END SUBROUTINE mppmax_int
1923
1924
[869]1925   SUBROUTINE mppmin_a_int( ktab, kdim, kcom )
[51]1926      !!----------------------------------------------------------------------
1927      !!                  ***  routine mppmin_a_int  ***
[3764]1928      !!
[51]1929      !! ** Purpose :   Find minimum value in an integer layout array
1930      !!
1931      !!----------------------------------------------------------------------
[6140]1932      INTEGER , INTENT( in  )                  ::   kdim   ! size of array
1933      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab   ! input array
1934      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom   ! input array
[1344]1935      !!
1936      INTEGER ::   ierror, localcomm   ! temporary integer
[51]1937      INTEGER, DIMENSION(kdim) ::   iwork
[1344]1938      !!----------------------------------------------------------------------
1939      !
[869]1940      localcomm = mpi_comm_opa
[1344]1941      IF( PRESENT(kcom) )   localcomm = kcom
1942      !
1943      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, localcomm, ierror )
1944      !
[51]1945      ktab(:) = iwork(:)
[1344]1946      !
[51]1947   END SUBROUTINE mppmin_a_int
[3]1948
[13]1949
[1345]1950   SUBROUTINE mppmin_int( ktab, kcom )
[51]1951      !!----------------------------------------------------------------------
1952      !!                  ***  routine mppmin_int  ***
1953      !!
[1344]1954      !! ** Purpose :   Find minimum value in an integer layout array
[51]1955      !!
1956      !!----------------------------------------------------------------------
1957      INTEGER, INTENT(inout) ::   ktab      ! ???
[1345]1958      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom        ! input array
[1344]1959      !!
[1345]1960      INTEGER ::  ierror, iwork, localcomm
[1344]1961      !!----------------------------------------------------------------------
1962      !
[1345]1963      localcomm = mpi_comm_opa
1964      IF( PRESENT(kcom) )   localcomm = kcom
[1344]1965      !
[6140]1966      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror )
[1345]1967      !
[51]1968      ktab = iwork
[1344]1969      !
[51]1970   END SUBROUTINE mppmin_int
[3]1971
[13]1972
[51]1973   SUBROUTINE mppsum_a_int( ktab, kdim )
1974      !!----------------------------------------------------------------------
1975      !!                  ***  routine mppsum_a_int  ***
[3764]1976      !!
[1344]1977      !! ** Purpose :   Global integer sum, 1D array case
[51]1978      !!
1979      !!----------------------------------------------------------------------
[6140]1980      INTEGER, INTENT(in   )                   ::   kdim   ! ???
1981      INTEGER, INTENT(inout), DIMENSION (kdim) ::   ktab   ! ???
1982      !
[51]1983      INTEGER :: ierror
1984      INTEGER, DIMENSION (kdim) ::  iwork
[1344]1985      !!----------------------------------------------------------------------
1986      !
1987      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
1988      !
[51]1989      ktab(:) = iwork(:)
[1344]1990      !
[51]1991   END SUBROUTINE mppsum_a_int
[3]1992
[13]1993
[1344]1994   SUBROUTINE mppsum_int( ktab )
1995      !!----------------------------------------------------------------------
1996      !!                 ***  routine mppsum_int  ***
[3764]1997      !!
[1344]1998      !! ** Purpose :   Global integer sum
1999      !!
2000      !!----------------------------------------------------------------------
2001      INTEGER, INTENT(inout) ::   ktab
[3764]2002      !!
[1344]2003      INTEGER :: ierror, iwork
2004      !!----------------------------------------------------------------------
2005      !
2006      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
2007      !
2008      ktab = iwork
2009      !
2010   END SUBROUTINE mppsum_int
[3]2011
[13]2012
[1344]2013   SUBROUTINE mppmax_a_real( ptab, kdim, kcom )
2014      !!----------------------------------------------------------------------
2015      !!                 ***  routine mppmax_a_real  ***
[3764]2016      !!
[1344]2017      !! ** Purpose :   Maximum
2018      !!
2019      !!----------------------------------------------------------------------
2020      INTEGER , INTENT(in   )                  ::   kdim
2021      REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab
2022      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom
[6140]2023      !
[1344]2024      INTEGER :: ierror, localcomm
2025      REAL(wp), DIMENSION(kdim) ::  zwork
2026      !!----------------------------------------------------------------------
2027      !
2028      localcomm = mpi_comm_opa
2029      IF( PRESENT(kcom) ) localcomm = kcom
2030      !
2031      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror )
2032      ptab(:) = zwork(:)
2033      !
2034   END SUBROUTINE mppmax_a_real
[3]2035
2036
[1344]2037   SUBROUTINE mppmax_real( ptab, kcom )
2038      !!----------------------------------------------------------------------
2039      !!                  ***  routine mppmax_real  ***
[3764]2040      !!
[1344]2041      !! ** Purpose :   Maximum
2042      !!
2043      !!----------------------------------------------------------------------
2044      REAL(wp), INTENT(inout)           ::   ptab   ! ???
2045      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ???
2046      !!
2047      INTEGER  ::   ierror, localcomm
2048      REAL(wp) ::   zwork
2049      !!----------------------------------------------------------------------
2050      !
[3764]2051      localcomm = mpi_comm_opa
[1344]2052      IF( PRESENT(kcom) )   localcomm = kcom
2053      !
2054      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, localcomm, ierror )
2055      ptab = zwork
2056      !
2057   END SUBROUTINE mppmax_real
[13]2058
[6490]2059   SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom  )
2060      !!----------------------------------------------------------------------
2061      !!                  ***  routine mppmax_real  ***
2062      !!
2063      !! ** Purpose :   Maximum
2064      !!
2065      !!----------------------------------------------------------------------
2066      REAL(wp), DIMENSION(:) ,  INTENT(inout)           ::   ptab   ! ???
2067      INTEGER , INTENT(in   )           ::   NUM
2068      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ???
2069      !!
2070      INTEGER  ::   ierror, localcomm
2071      REAL(wp) , POINTER , DIMENSION(:) ::   zwork
2072      !!----------------------------------------------------------------------
2073      !
2074      CALL wrk_alloc(NUM , zwork)
2075      localcomm = mpi_comm_opa
2076      IF( PRESENT(kcom) )   localcomm = kcom
2077      !
2078      CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror )
2079      ptab = zwork
2080      CALL wrk_dealloc(NUM , zwork)
2081      !
2082   END SUBROUTINE mppmax_real_multiple
[3]2083
[6490]2084
[1344]2085   SUBROUTINE mppmin_a_real( ptab, kdim, kcom )
2086      !!----------------------------------------------------------------------
2087      !!                 ***  routine mppmin_a_real  ***
[3764]2088      !!
[1344]2089      !! ** Purpose :   Minimum of REAL, array case
2090      !!
2091      !!-----------------------------------------------------------------------
2092      INTEGER , INTENT(in   )                  ::   kdim
2093      REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab
2094      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom
2095      !!
2096      INTEGER :: ierror, localcomm
2097      REAL(wp), DIMENSION(kdim) ::   zwork
2098      !!-----------------------------------------------------------------------
2099      !
[3764]2100      localcomm = mpi_comm_opa
[1344]2101      IF( PRESENT(kcom) ) localcomm = kcom
2102      !
2103      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, localcomm, ierror )
2104      ptab(:) = zwork(:)
2105      !
2106   END SUBROUTINE mppmin_a_real
[3]2107
2108
[1344]2109   SUBROUTINE mppmin_real( ptab, kcom )
2110      !!----------------------------------------------------------------------
2111      !!                  ***  routine mppmin_real  ***
[3764]2112      !!
[1344]2113      !! ** Purpose :   minimum of REAL, scalar case
2114      !!
2115      !!-----------------------------------------------------------------------
[3764]2116      REAL(wp), INTENT(inout)           ::   ptab        !
[1344]2117      INTEGER , INTENT(in   ), OPTIONAL :: kcom
2118      !!
2119      INTEGER  ::   ierror
2120      REAL(wp) ::   zwork
2121      INTEGER :: localcomm
2122      !!-----------------------------------------------------------------------
2123      !
[3764]2124      localcomm = mpi_comm_opa
[1344]2125      IF( PRESENT(kcom) )   localcomm = kcom
2126      !
2127      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, localcomm, ierror )
2128      ptab = zwork
2129      !
2130   END SUBROUTINE mppmin_real
[13]2131
[3]2132
[1344]2133   SUBROUTINE mppsum_a_real( ptab, kdim, kcom )
2134      !!----------------------------------------------------------------------
2135      !!                  ***  routine mppsum_a_real  ***
[3764]2136      !!
[1344]2137      !! ** Purpose :   global sum, REAL ARRAY argument case
2138      !!
2139      !!-----------------------------------------------------------------------
2140      INTEGER , INTENT( in )                     ::   kdim      ! size of ptab
2141      REAL(wp), DIMENSION(kdim), INTENT( inout ) ::   ptab      ! input array
2142      INTEGER , INTENT( in ), OPTIONAL           :: kcom
2143      !!
2144      INTEGER                   ::   ierror    ! temporary integer
[3764]2145      INTEGER                   ::   localcomm
2146      REAL(wp), DIMENSION(kdim) ::   zwork     ! temporary workspace
[1344]2147      !!-----------------------------------------------------------------------
2148      !
[3764]2149      localcomm = mpi_comm_opa
[1344]2150      IF( PRESENT(kcom) )   localcomm = kcom
2151      !
2152      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, localcomm, ierror )
2153      ptab(:) = zwork(:)
2154      !
2155   END SUBROUTINE mppsum_a_real
[869]2156
[3]2157
[1344]2158   SUBROUTINE mppsum_real( ptab, kcom )
2159      !!----------------------------------------------------------------------
2160      !!                  ***  routine mppsum_real  ***
[3764]2161      !!
[1344]2162      !! ** Purpose :   global sum, SCALAR argument case
2163      !!
2164      !!-----------------------------------------------------------------------
2165      REAL(wp), INTENT(inout)           ::   ptab   ! input scalar
2166      INTEGER , INTENT(in   ), OPTIONAL ::   kcom
2167      !!
[3764]2168      INTEGER  ::   ierror, localcomm
[1344]2169      REAL(wp) ::   zwork
2170      !!-----------------------------------------------------------------------
2171      !
[3764]2172      localcomm = mpi_comm_opa
[1344]2173      IF( PRESENT(kcom) ) localcomm = kcom
2174      !
2175      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, localcomm, ierror )
2176      ptab = zwork
2177      !
2178   END SUBROUTINE mppsum_real
[3]2179
[6140]2180
[1976]2181   SUBROUTINE mppsum_realdd( ytab, kcom )
2182      !!----------------------------------------------------------------------
2183      !!                  ***  routine mppsum_realdd ***
2184      !!
2185      !! ** Purpose :   global sum in Massively Parallel Processing
2186      !!                SCALAR argument case for double-double precision
2187      !!
2188      !!-----------------------------------------------------------------------
[6140]2189      COMPLEX(wp), INTENT(inout)           ::   ytab    ! input scalar
2190      INTEGER    , INTENT(in   ), OPTIONAL ::   kcom
2191      !
2192      INTEGER     ::   ierror
2193      INTEGER     ::   localcomm
2194      COMPLEX(wp) ::   zwork
2195      !!-----------------------------------------------------------------------
2196      !
[1976]2197      localcomm = mpi_comm_opa
[6140]2198      IF( PRESENT(kcom) )   localcomm = kcom
2199      !
[1976]2200      ! reduce local sums into global sum
[6140]2201      CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror )
[1976]2202      ytab = zwork
[6140]2203      !
[1976]2204   END SUBROUTINE mppsum_realdd
[3764]2205
2206
[1976]2207   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
2208      !!----------------------------------------------------------------------
2209      !!                  ***  routine mppsum_a_realdd  ***
2210      !!
2211      !! ** Purpose :   global sum in Massively Parallel Processing
2212      !!                COMPLEX ARRAY case for double-double precision
2213      !!
2214      !!-----------------------------------------------------------------------
[6140]2215      INTEGER                     , INTENT(in   ) ::   kdim   ! size of ytab
2216      COMPLEX(wp), DIMENSION(kdim), INTENT(inout) ::   ytab   ! input array
2217      INTEGER    , OPTIONAL       , INTENT(in   ) ::   kcom
2218      !
2219      INTEGER:: ierror, localcomm    ! local integer
[1976]2220      COMPLEX(wp), DIMENSION(kdim) :: zwork     ! temporary workspace
[6140]2221      !!-----------------------------------------------------------------------
2222      !
[1976]2223      localcomm = mpi_comm_opa
[6140]2224      IF( PRESENT(kcom) )   localcomm = kcom
2225      !
2226      CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror )
[1976]2227      ytab(:) = zwork(:)
[6140]2228      !
[1976]2229   END SUBROUTINE mppsum_a_realdd
[3764]2230
[6140]2231
[1344]2232   SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj )
2233      !!------------------------------------------------------------------------
2234      !!             ***  routine mpp_minloc  ***
2235      !!
2236      !! ** Purpose :   Compute the global minimum of an array ptab
2237      !!              and also give its global position
2238      !!
2239      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
2240      !!
2241      !!--------------------------------------------------------------------------
2242      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   ptab    ! Local 2D array
2243      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask   ! Local mask
2244      REAL(wp)                     , INTENT(  out) ::   pmin    ! Global minimum of ptab
2245      INTEGER                      , INTENT(  out) ::   ki, kj   ! index of minimum in global frame
[6140]2246      !
2247      INTEGER :: ierror
[1344]2248      INTEGER , DIMENSION(2)   ::   ilocs
2249      REAL(wp) ::   zmin   ! local minimum
2250      REAL(wp), DIMENSION(2,1) ::   zain, zaout
2251      !!-----------------------------------------------------------------------
2252      !
2253      zmin  = MINVAL( ptab(:,:) , mask= pmask == 1.e0 )
2254      ilocs = MINLOC( ptab(:,:) , mask= pmask == 1.e0 )
2255      !
2256      ki = ilocs(1) + nimpp - 1
2257      kj = ilocs(2) + njmpp - 1
2258      !
2259      zain(1,:)=zmin
2260      zain(2,:)=ki+10000.*kj
2261      !
2262      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
2263      !
2264      pmin = zaout(1,1)
2265      kj = INT(zaout(2,1)/10000.)
2266      ki = INT(zaout(2,1) - 10000.*kj )
2267      !
2268   END SUBROUTINE mpp_minloc2d
[13]2269
[3]2270
[1344]2271   SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj ,kk)
2272      !!------------------------------------------------------------------------
2273      !!             ***  routine mpp_minloc  ***
2274      !!
2275      !! ** Purpose :   Compute the global minimum of an array ptab
2276      !!              and also give its global position
2277      !!
2278      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
2279      !!
2280      !!--------------------------------------------------------------------------
2281      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   ptab         ! Local 2D array
2282      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pmask        ! Local mask
2283      REAL(wp)                         , INTENT(  out) ::   pmin         ! Global minimum of ptab
2284      INTEGER                          , INTENT(  out) ::   ki, kj, kk   ! index of minimum in global frame
2285      !!
2286      INTEGER  ::   ierror
2287      REAL(wp) ::   zmin     ! local minimum
2288      INTEGER , DIMENSION(3)   ::   ilocs
2289      REAL(wp), DIMENSION(2,1) ::   zain, zaout
2290      !!-----------------------------------------------------------------------
2291      !
2292      zmin  = MINVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
2293      ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
2294      !
2295      ki = ilocs(1) + nimpp - 1
2296      kj = ilocs(2) + njmpp - 1
2297      kk = ilocs(3)
2298      !
2299      zain(1,:)=zmin
2300      zain(2,:)=ki+10000.*kj+100000000.*kk
2301      !
2302      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
2303      !
2304      pmin = zaout(1,1)
2305      kk   = INT( zaout(2,1) / 100000000. )
2306      kj   = INT( zaout(2,1) - kk * 100000000. ) / 10000
2307      ki   = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
2308      !
2309   END SUBROUTINE mpp_minloc3d
[13]2310
[3]2311
[1344]2312   SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
2313      !!------------------------------------------------------------------------
2314      !!             ***  routine mpp_maxloc  ***
2315      !!
2316      !! ** Purpose :   Compute the global maximum of an array ptab
2317      !!              and also give its global position
2318      !!
2319      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
2320      !!
2321      !!--------------------------------------------------------------------------
2322      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   ptab     ! Local 2D array
2323      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask    ! Local mask
2324      REAL(wp)                     , INTENT(  out) ::   pmax     ! Global maximum of ptab
2325      INTEGER                      , INTENT(  out) ::   ki, kj   ! index of maximum in global frame
[3764]2326      !!
[1344]2327      INTEGER  :: ierror
2328      INTEGER, DIMENSION (2)   ::   ilocs
2329      REAL(wp) :: zmax   ! local maximum
2330      REAL(wp), DIMENSION(2,1) ::   zain, zaout
2331      !!-----------------------------------------------------------------------
2332      !
2333      zmax  = MAXVAL( ptab(:,:) , mask= pmask == 1.e0 )
2334      ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1.e0 )
2335      !
2336      ki = ilocs(1) + nimpp - 1
2337      kj = ilocs(2) + njmpp - 1
2338      !
2339      zain(1,:) = zmax
2340      zain(2,:) = ki + 10000. * kj
2341      !
2342      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
2343      !
2344      pmax = zaout(1,1)
2345      kj   = INT( zaout(2,1) / 10000.     )
2346      ki   = INT( zaout(2,1) - 10000.* kj )
2347      !
2348   END SUBROUTINE mpp_maxloc2d
[3]2349
[13]2350
[1344]2351   SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
2352      !!------------------------------------------------------------------------
2353      !!             ***  routine mpp_maxloc  ***
2354      !!
2355      !! ** Purpose :  Compute the global maximum of an array ptab
2356      !!              and also give its global position
2357      !!
2358      !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
2359      !!
2360      !!--------------------------------------------------------------------------
2361      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   ptab         ! Local 2D array
2362      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pmask        ! Local mask
2363      REAL(wp)                         , INTENT(  out) ::   pmax         ! Global maximum of ptab
2364      INTEGER                          , INTENT(  out) ::   ki, kj, kk   ! index of maximum in global frame
[3764]2365      !!
[1344]2366      REAL(wp) :: zmax   ! local maximum
2367      REAL(wp), DIMENSION(2,1) ::   zain, zaout
2368      INTEGER , DIMENSION(3)   ::   ilocs
2369      INTEGER :: ierror
2370      !!-----------------------------------------------------------------------
2371      !
2372      zmax  = MAXVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
2373      ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
2374      !
2375      ki = ilocs(1) + nimpp - 1
2376      kj = ilocs(2) + njmpp - 1
2377      kk = ilocs(3)
2378      !
2379      zain(1,:)=zmax
2380      zain(2,:)=ki+10000.*kj+100000000.*kk
2381      !
2382      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
2383      !
2384      pmax = zaout(1,1)
2385      kk   = INT( zaout(2,1) / 100000000. )
2386      kj   = INT( zaout(2,1) - kk * 100000000. ) / 10000
2387      ki   = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
2388      !
2389   END SUBROUTINE mpp_maxloc3d
[3]2390
[869]2391
[1344]2392   SUBROUTINE mppsync()
2393      !!----------------------------------------------------------------------
2394      !!                  ***  routine mppsync  ***
[3764]2395      !!
[1344]2396      !! ** Purpose :   Massively parallel processors, synchroneous
2397      !!
2398      !!-----------------------------------------------------------------------
2399      INTEGER :: ierror
2400      !!-----------------------------------------------------------------------
2401      !
2402      CALL mpi_barrier( mpi_comm_opa, ierror )
2403      !
2404   END SUBROUTINE mppsync
[3]2405
2406
[1344]2407   SUBROUTINE mppstop
2408      !!----------------------------------------------------------------------
2409      !!                  ***  routine mppstop  ***
[3764]2410      !!
[3294]2411      !! ** purpose :   Stop massively parallel processors method
[1344]2412      !!
2413      !!----------------------------------------------------------------------
2414      INTEGER ::   info
2415      !!----------------------------------------------------------------------
2416      !
2417      CALL mppsync
2418      CALL mpi_finalize( info )
2419      !
2420   END SUBROUTINE mppstop
[3]2421
2422
[1344]2423   SUBROUTINE mpp_comm_free( kcom )
2424      !!----------------------------------------------------------------------
2425      !!----------------------------------------------------------------------
2426      INTEGER, INTENT(in) ::   kcom
2427      !!
2428      INTEGER :: ierr
2429      !!----------------------------------------------------------------------
2430      !
2431      CALL MPI_COMM_FREE(kcom, ierr)
2432      !
2433   END SUBROUTINE mpp_comm_free
[3]2434
[869]2435
[2715]2436   SUBROUTINE mpp_ini_ice( pindic, kumout )
[1344]2437      !!----------------------------------------------------------------------
2438      !!               ***  routine mpp_ini_ice  ***
2439      !!
2440      !! ** Purpose :   Initialize special communicator for ice areas
2441      !!      condition together with global variables needed in the ddmpp folding
2442      !!
2443      !! ** Method  : - Look for ice processors in ice routines
2444      !!              - Put their number in nrank_ice
2445      !!              - Create groups for the world processors and the ice processors
2446      !!              - Create a communicator for ice processors
2447      !!
2448      !! ** output
2449      !!      njmppmax = njmpp for northern procs
2450      !!      ndim_rank_ice = number of processors with ice
2451      !!      nrank_ice (ndim_rank_ice) = ice processors
[3625]2452      !!      ngrp_iworld = group ID for the world processors
[1344]2453      !!      ngrp_ice = group ID for the ice processors
2454      !!      ncomm_ice = communicator for the ice procs.
2455      !!      n_ice_root = number (in the world) of proc 0 in the ice comm.
2456      !!
2457      !!----------------------------------------------------------------------
[2715]2458      INTEGER, INTENT(in) ::   pindic
2459      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical unit
[1344]2460      !!
2461      INTEGER :: jjproc
[2715]2462      INTEGER :: ii, ierr
2463      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kice
2464      INTEGER, ALLOCATABLE, DIMENSION(:) ::   zwork
[1344]2465      !!----------------------------------------------------------------------
2466      !
[2715]2467      ! Since this is just an init routine and these arrays are of length jpnij
2468      ! then don't use wrk_nemo module - just allocate and deallocate.
2469      ALLOCATE( kice(jpnij), zwork(jpnij), STAT=ierr )
2470      IF( ierr /= 0 ) THEN
2471         WRITE(kumout, cform_err)
2472         WRITE(kumout,*) 'mpp_ini_ice : failed to allocate 2, 1D arrays (jpnij in length)'
2473         CALL mppstop
2474      ENDIF
2475
[1344]2476      ! Look for how many procs with sea-ice
2477      !
2478      kice = 0
2479      DO jjproc = 1, jpnij
[3764]2480         IF( jjproc == narea .AND. pindic .GT. 0 )   kice(jjproc) = 1
[1344]2481      END DO
2482      !
2483      zwork = 0
2484      CALL MPI_ALLREDUCE( kice, zwork, jpnij, mpi_integer, mpi_sum, mpi_comm_opa, ierr )
[3764]2485      ndim_rank_ice = SUM( zwork )
[3]2486
[1344]2487      ! Allocate the right size to nrank_north
[1441]2488      IF( ALLOCATED ( nrank_ice ) )   DEALLOCATE( nrank_ice )
[1344]2489      ALLOCATE( nrank_ice(ndim_rank_ice) )
2490      !
[3764]2491      ii = 0
[1344]2492      nrank_ice = 0
2493      DO jjproc = 1, jpnij
2494         IF( zwork(jjproc) == 1) THEN
2495            ii = ii + 1
[3764]2496            nrank_ice(ii) = jjproc -1
[1344]2497         ENDIF
2498      END DO
[1208]2499
[1344]2500      ! Create the world group
[3625]2501      CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_iworld, ierr )
[869]2502
[1344]2503      ! Create the ice group from the world group
[3625]2504      CALL MPI_GROUP_INCL( ngrp_iworld, ndim_rank_ice, nrank_ice, ngrp_ice, ierr )
[869]2505
[1344]2506      ! Create the ice communicator , ie the pool of procs with sea-ice
2507      CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_ice, ncomm_ice, ierr )
[869]2508
[1344]2509      ! Find proc number in the world of proc 0 in the north
2510      ! The following line seems to be useless, we just comment & keep it as reminder
[3625]2511      ! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_iworld,n_ice_root,ierr)
[1344]2512      !
[3625]2513      CALL MPI_GROUP_FREE(ngrp_ice, ierr)
2514      CALL MPI_GROUP_FREE(ngrp_iworld, ierr)
2515
[2715]2516      DEALLOCATE(kice, zwork)
2517      !
[1344]2518   END SUBROUTINE mpp_ini_ice
[869]2519
2520
[2715]2521   SUBROUTINE mpp_ini_znl( kumout )
[1345]2522      !!----------------------------------------------------------------------
2523      !!               ***  routine mpp_ini_znl  ***
2524      !!
2525      !! ** Purpose :   Initialize special communicator for computing zonal sum
2526      !!
2527      !! ** Method  : - Look for processors in the same row
2528      !!              - Put their number in nrank_znl
2529      !!              - Create group for the znl processors
2530      !!              - Create a communicator for znl processors
2531      !!              - Determine if processor should write znl files
2532      !!
2533      !! ** output
2534      !!      ndim_rank_znl = number of processors on the same row
2535      !!      ngrp_znl = group ID for the znl processors
2536      !!      ncomm_znl = communicator for the ice procs.
2537      !!      n_znl_root = number (in the world) of proc 0 in the ice comm.
2538      !!
2539      !!----------------------------------------------------------------------
[2715]2540      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical units
[1345]2541      !
[2715]2542      INTEGER :: jproc      ! dummy loop integer
2543      INTEGER :: ierr, ii   ! local integer
2544      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kwork
2545      !!----------------------------------------------------------------------
[1345]2546      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world     : ', ngrp_world
2547      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
2548      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_opa   : ', mpi_comm_opa
2549      !
[2715]2550      ALLOCATE( kwork(jpnij), STAT=ierr )
2551      IF( ierr /= 0 ) THEN
2552         WRITE(kumout, cform_err)
2553         WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij'
2554         CALL mppstop
2555      ENDIF
2556
2557      IF( jpnj == 1 ) THEN
[1345]2558         ngrp_znl  = ngrp_world
2559         ncomm_znl = mpi_comm_opa
2560      ELSE
2561         !
2562         CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_opa, ierr )
2563         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
2564         !-$$        CALL flush(numout)
2565         !
2566         ! Count number of processors on the same row
2567         ndim_rank_znl = 0
2568         DO jproc=1,jpnij
2569            IF ( kwork(jproc) == njmpp ) THEN
2570               ndim_rank_znl = ndim_rank_znl + 1
2571            ENDIF
2572         END DO
2573         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
2574         !-$$        CALL flush(numout)
2575         ! Allocate the right size to nrank_znl
[1441]2576         IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
[1345]2577         ALLOCATE(nrank_znl(ndim_rank_znl))
[3764]2578         ii = 0
[1345]2579         nrank_znl (:) = 0
2580         DO jproc=1,jpnij
2581            IF ( kwork(jproc) == njmpp) THEN
2582               ii = ii + 1
[3764]2583               nrank_znl(ii) = jproc -1
[1345]2584            ENDIF
2585         END DO
2586         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
2587         !-$$        CALL flush(numout)
2588
2589         ! Create the opa group
2590         CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_opa,ierr)
2591         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
2592         !-$$        CALL flush(numout)
2593
2594         ! Create the znl group from the opa group
2595         CALL MPI_GROUP_INCL  ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
2596         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
2597         !-$$        CALL flush(numout)
2598
2599         ! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
2600         CALL MPI_COMM_CREATE ( mpi_comm_opa, ngrp_znl, ncomm_znl, ierr )
2601         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
2602         !-$$        CALL flush(numout)
2603         !
2604      END IF
2605
2606      ! Determines if processor if the first (starting from i=1) on the row
[3764]2607      IF ( jpni == 1 ) THEN
[1345]2608         l_znl_root = .TRUE.
2609      ELSE
2610         l_znl_root = .FALSE.
2611         kwork (1) = nimpp
2612         CALL mpp_min ( kwork(1), kcom = ncomm_znl)
2613         IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
2614      END IF
2615
[2715]2616      DEALLOCATE(kwork)
2617
[1345]2618   END SUBROUTINE mpp_ini_znl
2619
2620
[1344]2621   SUBROUTINE mpp_ini_north
2622      !!----------------------------------------------------------------------
2623      !!               ***  routine mpp_ini_north  ***
2624      !!
[3764]2625      !! ** Purpose :   Initialize special communicator for north folding
[1344]2626      !!      condition together with global variables needed in the mpp folding
2627      !!
2628      !! ** Method  : - Look for northern processors
2629      !!              - Put their number in nrank_north
2630      !!              - Create groups for the world processors and the north processors
2631      !!              - Create a communicator for northern processors
2632      !!
2633      !! ** output
2634      !!      njmppmax = njmpp for northern procs
2635      !!      ndim_rank_north = number of processors in the northern line
2636      !!      nrank_north (ndim_rank_north) = number  of the northern procs.
2637      !!      ngrp_world = group ID for the world processors
2638      !!      ngrp_north = group ID for the northern processors
2639      !!      ncomm_north = communicator for the northern procs.
2640      !!      north_root = number (in the world) of proc 0 in the northern comm.
2641      !!
2642      !!----------------------------------------------------------------------
2643      INTEGER ::   ierr
2644      INTEGER ::   jjproc
2645      INTEGER ::   ii, ji
2646      !!----------------------------------------------------------------------
2647      !
2648      njmppmax = MAXVAL( njmppt )
2649      !
2650      ! Look for how many procs on the northern boundary
2651      ndim_rank_north = 0
2652      DO jjproc = 1, jpnij
2653         IF( njmppt(jjproc) == njmppmax )   ndim_rank_north = ndim_rank_north + 1
2654      END DO
2655      !
2656      ! Allocate the right size to nrank_north
[1441]2657      IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
[1344]2658      ALLOCATE( nrank_north(ndim_rank_north) )
[869]2659
[1344]2660      ! Fill the nrank_north array with proc. number of northern procs.
2661      ! Note : the rank start at 0 in MPI
2662      ii = 0
2663      DO ji = 1, jpnij
2664         IF ( njmppt(ji) == njmppmax   ) THEN
2665            ii=ii+1
2666            nrank_north(ii)=ji-1
2667         END IF
2668      END DO
2669      !
2670      ! create the world group
2671      CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
2672      !
2673      ! Create the North group from the world group
2674      CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
2675      !
2676      ! Create the North communicator , ie the pool of procs in the north group
2677      CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_north, ncomm_north, ierr )
2678      !
2679   END SUBROUTINE mpp_ini_north
[869]2680
2681
[1344]2682   SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn )
[51]2683      !!---------------------------------------------------------------------
2684      !!                   ***  routine mpp_lbc_north_3d  ***
2685      !!
[3764]2686      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
[1344]2687      !!              in mpp configuration in case of jpn1 > 1
[51]2688      !!
[1344]2689      !! ** Method  :   North fold condition and mpp with more than one proc
[3764]2690      !!              in i-direction require a specific treatment. We gather
[1344]2691      !!              the 4 northern lines of the global domain on 1 processor
2692      !!              and apply lbc north-fold on this sub array. Then we
2693      !!              scatter the north fold array back to the processors.
[51]2694      !!
2695      !!----------------------------------------------------------------------
[1344]2696      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d      ! 3D array on which the b.c. is applied
2697      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
2698      !                                                              !   = T ,  U , V , F or W  gridpoints
[4230]2699      REAL(wp)                        , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold
[1344]2700      !!                                                             ! =  1. , the sign is kept
[4230]2701      INTEGER ::   ji, jj, jr, jk
[1344]2702      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2703      INTEGER ::   ijpj, ijpjm1, ij, iproc
[4230]2704      INTEGER, DIMENSION (jpmaxngh)          ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather
[3294]2705      INTEGER                                ::   ml_err             ! for mpi_isend when avoiding mpi_allgather
2706      INTEGER, DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat            ! for mpi_isend when avoiding mpi_allgather
[4152]2707      !                                                              ! Workspace for message transfers avoiding mpi_allgather
2708      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab
2709      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk     
2710      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio
[4230]2711      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr
[4152]2712
[4230]2713      INTEGER :: istatus(mpi_status_size)
2714      INTEGER :: iflag
[51]2715      !!----------------------------------------------------------------------
[3764]2716      !
[4230]2717      ALLOCATE( ztab(jpiglo,4,jpk) , znorthloc(jpi,4,jpk), zfoldwk(jpi,4,jpk), znorthgloio(jpi,4,jpk,jpni) )
2718      ALLOCATE( ztabl(jpi,4,jpk), ztabr(jpi*jpmaxngh, 4, jpk) ) 
[4152]2719
[1344]2720      ijpj   = 4
2721      ijpjm1 = 3
2722      !
[4671]2723      znorthloc(:,:,:) = 0
[4230]2724      DO jk = 1, jpk
2725         DO jj = nlcj - ijpj +1, nlcj          ! put in xnorthloc the last 4 jlines of pt3d
2726            ij = jj - nlcj + ijpj
2727            znorthloc(:,ij,jk) = pt3d(:,jj,jk)
2728         END DO
[1344]2729      END DO
2730      !
[4152]2731      !                                     ! Build in procs of ncomm_north the znorthgloio
[1344]2732      itaille = jpi * jpk * ijpj
[4230]2733
[3294]2734      IF ( l_north_nogather ) THEN
2735         !
[4230]2736        ztabr(:,:,:) = 0
[4671]2737        ztabl(:,:,:) = 0
2738
[4230]2739        DO jk = 1, jpk
2740           DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array
2741              ij = jj - nlcj + ijpj
[4671]2742              DO ji = nfsloop, nfeloop
[4230]2743                 ztabl(ji,ij,jk) = pt3d(ji,jj,jk)
2744              END DO
2745           END DO
2746        END DO
2747
2748         DO jr = 1,nsndto
[4671]2749            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2750              CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )
2751            ENDIF
[4230]2752         END DO
2753         DO jr = 1,nsndto
[4671]2754            iproc = nfipproc(isendto(jr),jpnj)
2755            IF(iproc .ne. -1) THEN
2756               ilei = nleit (iproc+1)
2757               ildi = nldit (iproc+1)
2758               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
2759            ENDIF
2760            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN
2761              CALL mpprecv(5, zfoldwk, itaille, iproc)
[4230]2762              DO jk = 1, jpk
2763                 DO jj = 1, ijpj
[4671]2764                    DO ji = ildi, ilei
[4230]2765                       ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)
2766                    END DO
2767                 END DO
2768              END DO
[4671]2769           ELSE IF (iproc .eq. (narea-1)) THEN
[4230]2770              DO jk = 1, jpk
2771                 DO jj = 1, ijpj
[4671]2772                    DO ji = ildi, ilei
[4230]2773                       ztabr(iilb+ji,jj,jk) = pt3d(ji,nlcj-ijpj+jj,jk)
2774                    END DO
2775                 END DO
2776              END DO
2777           ENDIF
2778         END DO
2779         IF (l_isend) THEN
2780            DO jr = 1,nsndto
[4765]2781               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2782                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
2783               ENDIF   
[4230]2784            END DO
2785         ENDIF
[4232]2786         CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn )   ! North fold boundary condition
[4230]2787         DO jk = 1, jpk
2788            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d
2789               ij = jj - nlcj + ijpj
2790               DO ji= 1, nlci
2791                  pt3d(ji,jj,jk) = ztabl(ji,ij,jk)
2792               END DO
[1344]2793            END DO
2794         END DO
[3294]2795         !
2796
[4230]2797      ELSE
[4152]2798         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                &
2799            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
[3294]2800         !
[4230]2801         ztab(:,:,:) = 0.e0
[3294]2802         DO jr = 1, ndim_rank_north         ! recover the global north array
2803            iproc = nrank_north(jr) + 1
2804            ildi  = nldit (iproc)
2805            ilei  = nleit (iproc)
2806            iilb  = nimppt(iproc)
[4230]2807            DO jk = 1, jpk
2808               DO jj = 1, ijpj
2809                  DO ji = ildi, ilei
2810                    ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr)
2811                  END DO
[3294]2812               END DO
2813            END DO
2814         END DO
[4230]2815         CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition
2816         !
2817         DO jk = 1, jpk
2818            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d
2819               ij = jj - nlcj + ijpj
2820               DO ji= 1, nlci
2821                  pt3d(ji,jj,jk) = ztab(ji+nimpp-1,ij,jk)
2822               END DO
2823            END DO
2824         END DO
2825         !
[3294]2826      ENDIF
[1344]2827      !
[4152]2828      ! The ztab array has been either:
[3294]2829      !  a. Fully populated by the mpi_allgather operation or
[3764]2830      !  b. Had the active points for this domain and northern neighbours populated
[3294]2831      !     by peer to peer exchanges
[3764]2832      ! Either way the array may be folded by lbc_nfd and the result for the span of
[3294]2833      ! this domain will be identical.
2834      !
[4152]2835      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )
[4230]2836      DEALLOCATE( ztabl, ztabr ) 
[4152]2837      !
[1344]2838   END SUBROUTINE mpp_lbc_north_3d
[3]2839
2840
[1344]2841   SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn)
2842      !!---------------------------------------------------------------------
2843      !!                   ***  routine mpp_lbc_north_2d  ***
2844      !!
[3764]2845      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
[1344]2846      !!              in mpp configuration in case of jpn1 > 1 (for 2d array )
2847      !!
2848      !! ** Method  :   North fold condition and mpp with more than one proc
[3764]2849      !!              in i-direction require a specific treatment. We gather
[1344]2850      !!              the 4 northern lines of the global domain on 1 processor
2851      !!              and apply lbc north-fold on this sub array. Then we
2852      !!              scatter the north fold array back to the processors.
2853      !!
2854      !!----------------------------------------------------------------------
[4230]2855      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 2D array on which the b.c. is applied
2856      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points
[1344]2857      !                                                          !   = T ,  U , V , F or W  gridpoints
[4230]2858      REAL(wp)                    , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold
[1344]2859      !!                                                             ! =  1. , the sign is kept
2860      INTEGER ::   ji, jj, jr
2861      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2862      INTEGER ::   ijpj, ijpjm1, ij, iproc
[4230]2863      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather
[3294]2864      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather
2865      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather
[4152]2866      !                                                              ! Workspace for message transfers avoiding mpi_allgather
2867      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: ztab
2868      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk     
2869      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE   :: znorthgloio
[4230]2870      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: ztabl, ztabr
2871      INTEGER :: istatus(mpi_status_size)
2872      INTEGER :: iflag
[1344]2873      !!----------------------------------------------------------------------
2874      !
[4152]2875      ALLOCATE( ztab(jpiglo,4), znorthloc(jpi,4), zfoldwk(jpi,4), znorthgloio(jpi,4,jpni) )
[4230]2876      ALLOCATE( ztabl(jpi,4), ztabr(jpi*jpmaxngh, 4) ) 
[4152]2877      !
[1344]2878      ijpj   = 4
2879      ijpjm1 = 3
2880      !
[4152]2881      DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d
[1344]2882         ij = jj - nlcj + ijpj
[4152]2883         znorthloc(:,ij) = pt2d(:,jj)
[1344]2884      END DO
[3]2885
[4152]2886      !                                     ! Build in procs of ncomm_north the znorthgloio
[1344]2887      itaille = jpi * ijpj
[3294]2888      IF ( l_north_nogather ) THEN
2889         !
[4230]2890         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified
[3294]2891         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange
2892         !
[4230]2893         ztabr(:,:) = 0
[4671]2894         ztabl(:,:) = 0
2895
[3294]2896         DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array
2897            ij = jj - nlcj + ijpj
[4671]2898              DO ji = nfsloop, nfeloop
[4230]2899               ztabl(ji,ij) = pt2d(ji,jj)
[13]2900            END DO
2901         END DO
[3294]2902
[4230]2903         DO jr = 1,nsndto
[4671]2904            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2905               CALL mppsend(5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr))
2906            ENDIF
[4230]2907         END DO
2908         DO jr = 1,nsndto
[4671]2909            iproc = nfipproc(isendto(jr),jpnj)
2910            IF(iproc .ne. -1) THEN
2911               ilei = nleit (iproc+1)
2912               ildi = nldit (iproc+1)
2913               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
2914            ENDIF
2915            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN
2916              CALL mpprecv(5, zfoldwk, itaille, iproc)
[4230]2917              DO jj = 1, ijpj
[4671]2918                 DO ji = ildi, ilei
[4230]2919                    ztabr(iilb+ji,jj) = zfoldwk(ji,jj)
2920                 END DO
2921              END DO
[4671]2922            ELSE IF (iproc .eq. (narea-1)) THEN
[4230]2923              DO jj = 1, ijpj
[4671]2924                 DO ji = ildi, ilei
[4230]2925                    ztabr(iilb+ji,jj) = pt2d(ji,nlcj-ijpj+jj)
2926                 END DO
2927              END DO
2928            ENDIF
2929         END DO
2930         IF (l_isend) THEN
2931            DO jr = 1,nsndto
[4671]2932               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2933                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
2934               ENDIF
[4230]2935            END DO
2936         ENDIF
2937         CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn )   ! North fold boundary condition
[3294]2938         !
[4230]2939         DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
2940            ij = jj - nlcj + ijpj
2941            DO ji = 1, nlci
2942               pt2d(ji,jj) = ztabl(ji,ij)
2943            END DO
2944         END DO
[3294]2945         !
[4230]2946      ELSE
[4152]2947         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,        &
2948            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
[3294]2949         !
[4230]2950         ztab(:,:) = 0.e0
[3294]2951         DO jr = 1, ndim_rank_north            ! recover the global north array
2952            iproc = nrank_north(jr) + 1
2953            ildi = nldit (iproc)
2954            ilei = nleit (iproc)
2955            iilb = nimppt(iproc)
2956            DO jj = 1, ijpj
2957               DO ji = ildi, ilei
[4152]2958                  ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr)
[3294]2959               END DO
2960            END DO
2961         END DO
[4230]2962         CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition
2963         !
2964         DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
2965            ij = jj - nlcj + ijpj
2966            DO ji = 1, nlci
2967               pt2d(ji,jj) = ztab(ji+nimpp-1,ij)
2968            END DO
2969         END DO
2970         !
[3294]2971      ENDIF
[4152]2972      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )
[4230]2973      DEALLOCATE( ztabl, ztabr ) 
[4152]2974      !
[13]2975   END SUBROUTINE mpp_lbc_north_2d
[3]2976
[6490]2977   SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields)
2978      !!---------------------------------------------------------------------
2979      !!                   ***  routine mpp_lbc_north_2d  ***
2980      !!
2981      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2982      !!              in mpp configuration in case of jpn1 > 1
2983      !!              (for multiple 2d arrays )
2984      !!
2985      !! ** Method  :   North fold condition and mpp with more than one proc
2986      !!              in i-direction require a specific treatment. We gather
2987      !!              the 4 northern lines of the global domain on 1 processor
2988      !!              and apply lbc north-fold on this sub array. Then we
2989      !!              scatter the north fold array back to the processors.
2990      !!
2991      !!----------------------------------------------------------------------
2992      INTEGER ,  INTENT (in   ) ::   num_fields  ! number of variables contained in pt2d
2993      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array
2994      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points
2995      !                                                          !   = T ,  U , V , F or W  gridpoints
2996      REAL(wp), DIMENSION(:), INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold
2997      !!                                                             ! =  1. , the sign is kept
2998      INTEGER ::   ji, jj, jr, jk
2999      INTEGER ::   ierr, itaille, ildi, ilei, iilb
3000      INTEGER ::   ijpj, ijpjm1, ij, iproc
3001      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather
3002      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather
3003      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather
3004      !                                                              ! Workspace for message transfers avoiding mpi_allgather
3005      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab
3006      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk
3007      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio
3008      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr
3009      INTEGER :: istatus(mpi_status_size)
3010      INTEGER :: iflag
3011      !!----------------------------------------------------------------------
3012      !
[6918]3013      ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields),   &
3014            &   znorthgloio(jpi,4,num_fields,jpni) )   ! expanded to 3 dimensions
[6490]3015      ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) )
3016      !
3017      ijpj   = 4
3018      ijpjm1 = 3
3019      !
3020     
3021      DO jk = 1, num_fields
3022         DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d (for every variable)
3023            ij = jj - nlcj + ijpj
3024            znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj)
3025         END DO
3026      END DO
3027      !                                     ! Build in procs of ncomm_north the znorthgloio
3028      itaille = jpi * ijpj
3029                                                                 
3030      IF ( l_north_nogather ) THEN
3031         !
3032         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified
3033         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange
3034         !
3035         ztabr(:,:,:) = 0
3036         ztabl(:,:,:) = 0
[3]3037
[6490]3038         DO jk = 1, num_fields
3039            DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array
3040               ij = jj - nlcj + ijpj
3041               DO ji = nfsloop, nfeloop
3042                  ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj)
3043               END DO
3044            END DO
3045         END DO
3046
3047         DO jr = 1,nsndto
3048            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
3049               CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times
3050            ENDIF
3051         END DO
3052         DO jr = 1,nsndto
3053            iproc = nfipproc(isendto(jr),jpnj)
3054            IF(iproc .ne. -1) THEN
3055               ilei = nleit (iproc+1)
3056               ildi = nldit (iproc+1)
3057               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
3058            ENDIF
3059            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN
3060              CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times
3061              DO jk = 1 , num_fields
3062                 DO jj = 1, ijpj
3063                    DO ji = ildi, ilei
3064                       ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)       ! Modified to 3D
3065                    END DO
3066                 END DO
3067              END DO
3068            ELSE IF (iproc .eq. (narea-1)) THEN
3069              DO jk = 1, num_fields
3070                 DO jj = 1, ijpj
3071                    DO ji = ildi, ilei
3072                          ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj)       ! Modified to 3D
3073                    END DO
3074                 END DO
3075              END DO
3076            ENDIF
3077         END DO
3078         IF (l_isend) THEN
3079            DO jr = 1,nsndto
3080               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
3081                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
3082               ENDIF
3083            END DO
3084         ENDIF
3085         !
3086         DO ji = 1, num_fields     ! Loop to manage 3D variables
3087            CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) )  ! North fold boundary condition
3088         END DO
3089         !
3090         DO jk = 1, num_fields
3091            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
3092               ij = jj - nlcj + ijpj
3093               DO ji = 1, nlci
3094                  pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk)       ! Modified to 3D
3095               END DO
3096            END DO
3097         END DO
3098         
3099         !
3100      ELSE
3101         !
3102         CALL MPI_ALLGATHER( znorthloc  , itaille*num_fields, MPI_DOUBLE_PRECISION,        &
3103            &                znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
3104         !
3105         ztab(:,:,:) = 0.e0
3106         DO jk = 1, num_fields
3107            DO jr = 1, ndim_rank_north            ! recover the global north array
3108               iproc = nrank_north(jr) + 1
3109               ildi = nldit (iproc)
3110               ilei = nleit (iproc)
3111               iilb = nimppt(iproc)
3112               DO jj = 1, ijpj
3113                  DO ji = ildi, ilei
3114                     ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr)
3115                  END DO
3116               END DO
3117            END DO
3118         END DO
3119         
3120         DO ji = 1, num_fields
3121            CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) )   ! North fold boundary condition
3122         END DO
3123         !
3124         DO jk = 1, num_fields
3125            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
3126               ij = jj - nlcj + ijpj
3127               DO ji = 1, nlci
3128                  pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk)
3129               END DO
3130            END DO
3131         END DO
3132         !
3133         !
3134      ENDIF
3135      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )
3136      DEALLOCATE( ztabl, ztabr )
3137      !
3138   END SUBROUTINE mpp_lbc_north_2d_multiple
3139
[1344]3140   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn)
3141      !!---------------------------------------------------------------------
3142      !!                   ***  routine mpp_lbc_north_2d  ***
3143      !!
[3764]3144      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
3145      !!              in mpp configuration in case of jpn1 > 1 and for 2d
[1344]3146      !!              array with outer extra halo
3147      !!
3148      !! ** Method  :   North fold condition and mpp with more than one proc
[3764]3149      !!              in i-direction require a specific treatment. We gather
3150      !!              the 4+2*jpr2dj northern lines of the global domain on 1
3151      !!              processor and apply lbc north-fold on this sub array.
[1344]3152      !!              Then we scatter the north fold array back to the processors.
3153      !!
3154      !!----------------------------------------------------------------------
3155      REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
3156      CHARACTER(len=1)                                            , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points
3157      !                                                                                         !   = T ,  U , V , F or W -points
[3764]3158      REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! = -1. the sign change across the
[1344]3159      !!                                                                                        ! north fold, =  1. otherwise
3160      INTEGER ::   ji, jj, jr
3161      INTEGER ::   ierr, itaille, ildi, ilei, iilb
3162      INTEGER ::   ijpj, ij, iproc
[4152]3163      !
3164      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e
3165      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e
3166
[1344]3167      !!----------------------------------------------------------------------
3168      !
[4152]3169      ALLOCATE( ztab_e(jpiglo,4+2*jpr2dj), znorthloc_e(jpi,4+2*jpr2dj), znorthgloio_e(jpi,4+2*jpr2dj,jpni) )
3170
3171      !
[1344]3172      ijpj=4
[4152]3173      ztab_e(:,:) = 0.e0
[311]3174
[1344]3175      ij=0
[4152]3176      ! put in znorthloc_e the last 4 jlines of pt2d
[1344]3177      DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj
3178         ij = ij + 1
3179         DO ji = 1, jpi
[4152]3180            znorthloc_e(ji,ij)=pt2d(ji,jj)
[1344]3181         END DO
3182      END DO
3183      !
3184      itaille = jpi * ( ijpj + 2 * jpr2dj )
[4152]3185      CALL MPI_ALLGATHER( znorthloc_e(1,1)  , itaille, MPI_DOUBLE_PRECISION,    &
3186         &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
[1344]3187      !
3188      DO jr = 1, ndim_rank_north            ! recover the global north array
3189         iproc = nrank_north(jr) + 1
3190         ildi = nldit (iproc)
3191         ilei = nleit (iproc)
3192         iilb = nimppt(iproc)
3193         DO jj = 1, ijpj+2*jpr2dj
3194            DO ji = ildi, ilei
[4152]3195               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
[311]3196            END DO
[1344]3197         END DO
3198      END DO
[311]3199
3200
[1344]3201      ! 2. North-Fold boundary conditions
3202      ! ----------------------------------
[4152]3203      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj )
[311]3204
[1344]3205      ij = jpr2dj
3206      !! Scatter back to pt2d
3207      DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj
[3764]3208      ij  = ij +1
[1344]3209         DO ji= 1, nlci
[4152]3210            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
[311]3211         END DO
3212      END DO
[1344]3213      !
[4152]3214      DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
3215      !
[311]3216   END SUBROUTINE mpp_lbc_north_e
3217
[6140]3218
3219   SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy )
[3680]3220      !!----------------------------------------------------------------------
3221      !!                  ***  routine mpp_lnk_bdy_3d  ***
3222      !!
3223      !! ** Purpose :   Message passing management
3224      !!
3225      !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries
3226      !!      between processors following neighboring subdomains.
3227      !!            domain parameters
3228      !!                    nlci   : first dimension of the local subdomain
3229      !!                    nlcj   : second dimension of the local subdomain
3230      !!                    nbondi_bdy : mark for "east-west local boundary"
3231      !!                    nbondj_bdy : mark for "north-south local boundary"
3232      !!                    noea   : number for local neighboring processors
3233      !!                    nowe   : number for local neighboring processors
3234      !!                    noso   : number for local neighboring processors
3235      !!                    nono   : number for local neighboring processors
3236      !!
3237      !! ** Action  :   ptab with update value at its periphery
3238      !!
3239      !!----------------------------------------------------------------------
3240      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied
3241      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
3242      !                                                             ! = T , U , V , F , W points
3243      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
3244      !                                                             ! =  1. , the sign is kept
3245      INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set
[6140]3246      !
[3680]3247      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices
[6140]3248      INTEGER  ::   imigr, iihom, ijhom        ! local integers
[3680]3249      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
[6140]3250      REAL(wp) ::   zland                      ! local scalar
[3680]3251      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
[4152]3252      !
3253      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north
3254      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east
[3680]3255      !!----------------------------------------------------------------------
[6140]3256      !
[4152]3257      ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2),   &
3258         &      zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2)  )
[3680]3259
[6140]3260      zland = 0._wp
[3680]3261
3262      ! 1. standard boundary treatment
3263      ! ------------------------------
3264      !                                   ! East-West boundaries
3265      !                                        !* Cyclic east-west
3266      IF( nbondi == 2) THEN
[6140]3267         IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN
3268            ptab( 1 ,:,:) = ptab(jpim1,:,:)
3269            ptab(jpi,:,:) = ptab(  2  ,:,:)
3270         ELSE
3271            IF( .NOT. cd_type == 'F' )   ptab(1:jpreci,:,:) = zland    ! south except F-point
3272            ptab(nlci-jpreci+1:jpi,:,:) = zland    ! north
3273         ENDIF
[3680]3274      ELSEIF(nbondi == -1) THEN
[6140]3275         IF( .NOT. cd_type == 'F' )   ptab(1:jpreci,:,:) = zland    ! south except F-point
[3680]3276      ELSEIF(nbondi == 1) THEN
[6140]3277         ptab(nlci-jpreci+1:jpi,:,:) = zland    ! north
[3680]3278      ENDIF                                     !* closed
3279
3280      IF (nbondj == 2 .OR. nbondj == -1) THEN
[6140]3281        IF( .NOT. cd_type == 'F' )   ptab(:,1:jprecj,:) = zland       ! south except F-point
[3680]3282      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
[6140]3283        ptab(:,nlcj-jprecj+1:jpj,:) = zland       ! north
[3680]3284      ENDIF
3285      !
3286      ! 2. East and west directions exchange
3287      ! ------------------------------------
3288      ! we play with the neigbours AND the row number because of the periodicity
3289      !
3290      SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions
3291      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
3292         iihom = nlci-nreci
3293         DO jl = 1, jpreci
[4152]3294            zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
3295            zt3we(:,jl,:,1) = ptab(iihom +jl,:,:)
[3680]3296         END DO
3297      END SELECT
3298      !
3299      !                           ! Migrations
3300      imigr = jpreci * jpj * jpk
3301      !
3302      SELECT CASE ( nbondi_bdy(ib_bdy) )
3303      CASE ( -1 )
[4152]3304         CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 )
[3680]3305      CASE ( 0 )
[4152]3306         CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
3307         CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 )
[3680]3308      CASE ( 1 )
[4152]3309         CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
[3680]3310      END SELECT
3311      !
3312      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
3313      CASE ( -1 )
[4152]3314         CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
[3680]3315      CASE ( 0 )
[4152]3316         CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
3317         CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
[3680]3318      CASE ( 1 )
[4152]3319         CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
[3680]3320      END SELECT
3321      !
3322      SELECT CASE ( nbondi_bdy(ib_bdy) )
3323      CASE ( -1 )
3324         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3325      CASE ( 0 )
3326         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3327         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
3328      CASE ( 1 )
3329         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3330      END SELECT
3331      !
3332      !                           ! Write Dirichlet lateral conditions
3333      iihom = nlci-jpreci
3334      !
3335      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
3336      CASE ( -1 )
3337         DO jl = 1, jpreci
[4152]3338            ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)
[3680]3339         END DO
3340      CASE ( 0 )
3341         DO jl = 1, jpreci
[6140]3342            ptab(      jl,:,:) = zt3we(:,jl,:,2)
[4152]3343            ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)
[3680]3344         END DO
3345      CASE ( 1 )
3346         DO jl = 1, jpreci
[6140]3347            ptab(      jl,:,:) = zt3we(:,jl,:,2)
[3680]3348         END DO
3349      END SELECT
3350
3351
3352      ! 3. North and south directions
3353      ! -----------------------------
3354      ! always closed : we play only with the neigbours
3355      !
3356      IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions
3357         ijhom = nlcj-nrecj
3358         DO jl = 1, jprecj
[4152]3359            zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
3360            zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
[3680]3361         END DO
3362      ENDIF
3363      !
3364      !                           ! Migrations
3365      imigr = jprecj * jpi * jpk
3366      !
3367      SELECT CASE ( nbondj_bdy(ib_bdy) )
3368      CASE ( -1 )
[4152]3369         CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 )
[3680]3370      CASE ( 0 )
[4152]3371         CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
3372         CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 )
[3680]3373      CASE ( 1 )
[4152]3374         CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
[3680]3375      END SELECT
3376      !
3377      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3378      CASE ( -1 )
[4152]3379         CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
[3680]3380      CASE ( 0 )
[4152]3381         CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
3382         CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
[3680]3383      CASE ( 1 )
[4152]3384         CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
[3680]3385      END SELECT
3386      !
3387      SELECT CASE ( nbondj_bdy(ib_bdy) )
3388      CASE ( -1 )
3389         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3390      CASE ( 0 )
3391         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3392         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
3393      CASE ( 1 )
3394         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3395      END SELECT
3396      !
3397      !                           ! Write Dirichlet lateral conditions
3398      ijhom = nlcj-jprecj
3399      !
3400      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3401      CASE ( -1 )
3402         DO jl = 1, jprecj
[4152]3403            ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)
[3680]3404         END DO
3405      CASE ( 0 )
3406         DO jl = 1, jprecj
[4152]3407            ptab(:,jl      ,:) = zt3sn(:,jl,:,2)
3408            ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)
[3680]3409         END DO
3410      CASE ( 1 )
3411         DO jl = 1, jprecj
[4152]3412            ptab(:,jl,:) = zt3sn(:,jl,:,2)
[3680]3413         END DO
3414      END SELECT
3415
3416
3417      ! 4. north fold treatment
3418      ! -----------------------
3419      !
3420      IF( npolj /= 0) THEN
3421         !
3422         SELECT CASE ( jpni )
3423         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp
3424         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs.
3425         END SELECT
3426         !
3427      ENDIF
3428      !
[4152]3429      DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we  )
3430      !
[3680]3431   END SUBROUTINE mpp_lnk_bdy_3d
3432
[6140]3433
3434   SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy )
[3680]3435      !!----------------------------------------------------------------------
3436      !!                  ***  routine mpp_lnk_bdy_2d  ***
3437      !!
3438      !! ** Purpose :   Message passing management
3439      !!
3440      !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries
3441      !!      between processors following neighboring subdomains.
3442      !!            domain parameters
3443      !!                    nlci   : first dimension of the local subdomain
3444      !!                    nlcj   : second dimension of the local subdomain
3445      !!                    nbondi_bdy : mark for "east-west local boundary"
3446      !!                    nbondj_bdy : mark for "north-south local boundary"
3447      !!                    noea   : number for local neighboring processors
3448      !!                    nowe   : number for local neighboring processors
3449      !!                    noso   : number for local neighboring processors
3450      !!                    nono   : number for local neighboring processors
3451      !!
3452      !! ** Action  :   ptab with update value at its periphery
3453      !!
3454      !!----------------------------------------------------------------------
[6140]3455      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied
3456      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
3457      !                                                         ! = T , U , V , F , W points
3458      REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
3459      !                                                         ! =  1. , the sign is kept
3460      INTEGER                     , INTENT(in   ) ::   ib_bdy   ! BDY boundary set
3461      !
[3680]3462      INTEGER  ::   ji, jj, jl             ! dummy loop indices
[6140]3463      INTEGER  ::   imigr, iihom, ijhom        ! local integers
[3680]3464      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
3465      REAL(wp) ::   zland
3466      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
[4152]3467      !
3468      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north
3469      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east
[3680]3470      !!----------------------------------------------------------------------
3471
[4152]3472      ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  &
3473         &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   )
3474
[6140]3475      zland = 0._wp
[3680]3476
3477      ! 1. standard boundary treatment
3478      ! ------------------------------
3479      !                                   ! East-West boundaries
[6140]3480      !                                      !* Cyclic east-west
3481      IF( nbondi == 2 ) THEN
3482         IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN
3483            ptab( 1 ,:) = ptab(jpim1,:)
3484            ptab(jpi,:) = ptab(  2  ,:)
3485         ELSE
3486            IF(.NOT.cd_type == 'F' )  ptab(     1       :jpreci,:) = zland    ! south except F-point
3487                                      ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north
3488         ENDIF
[3680]3489      ELSEIF(nbondi == -1) THEN
[6140]3490         IF( .NOT.cd_type == 'F' )    ptab(     1       :jpreci,:) = zland    ! south except F-point
[3680]3491      ELSEIF(nbondi == 1) THEN
[6140]3492                                      ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north
3493      ENDIF
3494      !                                      !* closed
3495      IF( nbondj == 2 .OR. nbondj == -1 ) THEN
3496         IF( .NOT.cd_type == 'F' )    ptab(:,     1       :jprecj) = zland    ! south except F-point
[3680]3497      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
[6140]3498                                      ptab(:,nlcj-jprecj+1:jpj   ) = zland    ! north
[3680]3499      ENDIF
3500      !
3501      ! 2. East and west directions exchange
3502      ! ------------------------------------
3503      ! we play with the neigbours AND the row number because of the periodicity
3504      !
3505      SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions
3506      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
3507         iihom = nlci-nreci
3508         DO jl = 1, jpreci
[4152]3509            zt2ew(:,jl,1) = ptab(jpreci+jl,:)
3510            zt2we(:,jl,1) = ptab(iihom +jl,:)
[3680]3511         END DO
3512      END SELECT
3513      !
3514      !                           ! Migrations
3515      imigr = jpreci * jpj
3516      !
3517      SELECT CASE ( nbondi_bdy(ib_bdy) )
3518      CASE ( -1 )
[4152]3519         CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 )
[3680]3520      CASE ( 0 )
[4152]3521         CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
3522         CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 )
[3680]3523      CASE ( 1 )
[4152]3524         CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
[3680]3525      END SELECT
3526      !
3527      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
3528      CASE ( -1 )
[4152]3529         CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
[3680]3530      CASE ( 0 )
[4152]3531         CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
3532         CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
[3680]3533      CASE ( 1 )
[4152]3534         CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
[3680]3535      END SELECT
3536      !
3537      SELECT CASE ( nbondi_bdy(ib_bdy) )
3538      CASE ( -1 )
3539         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3540      CASE ( 0 )
3541         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3542         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
3543      CASE ( 1 )
3544         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3545      END SELECT
3546      !
3547      !                           ! Write Dirichlet lateral conditions
3548      iihom = nlci-jpreci
3549      !
3550      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
3551      CASE ( -1 )
3552         DO jl = 1, jpreci
[4152]3553            ptab(iihom+jl,:) = zt2ew(:,jl,2)
[3680]3554         END DO
3555      CASE ( 0 )
3556         DO jl = 1, jpreci
[4152]3557            ptab(jl      ,:) = zt2we(:,jl,2)
3558            ptab(iihom+jl,:) = zt2ew(:,jl,2)
[3680]3559         END DO
3560      CASE ( 1 )
3561         DO jl = 1, jpreci
[4152]3562            ptab(jl      ,:) = zt2we(:,jl,2)
[3680]3563         END DO
3564      END SELECT
3565
3566
3567      ! 3. North and south directions
3568      ! -----------------------------
3569      ! always closed : we play only with the neigbours
3570      !
3571      IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions
3572         ijhom = nlcj-nrecj
3573         DO jl = 1, jprecj
[4152]3574            zt2sn(:,jl,1) = ptab(:,ijhom +jl)
3575            zt2ns(:,jl,1) = ptab(:,jprecj+jl)
[3680]3576         END DO
3577      ENDIF
3578      !
3579      !                           ! Migrations
3580      imigr = jprecj * jpi
3581      !
3582      SELECT CASE ( nbondj_bdy(ib_bdy) )
3583      CASE ( -1 )
[4152]3584         CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 )
[3680]3585      CASE ( 0 )
[4152]3586         CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
3587         CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 )
[3680]3588      CASE ( 1 )
[4152]3589         CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
[3680]3590      END SELECT
3591      !
3592      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3593      CASE ( -1 )
[4152]3594         CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
[3680]3595      CASE ( 0 )
[4152]3596         CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
3597         CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
[3680]3598      CASE ( 1 )
[4152]3599         CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
[3680]3600      END SELECT
3601      !
3602      SELECT CASE ( nbondj_bdy(ib_bdy) )
3603      CASE ( -1 )
3604         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3605      CASE ( 0 )
3606         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3607         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
3608      CASE ( 1 )
3609         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3610      END SELECT
3611      !
3612      !                           ! Write Dirichlet lateral conditions
3613      ijhom = nlcj-jprecj
3614      !
3615      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3616      CASE ( -1 )
3617         DO jl = 1, jprecj
[4152]3618            ptab(:,ijhom+jl) = zt2ns(:,jl,2)
[3680]3619         END DO
3620      CASE ( 0 )
3621         DO jl = 1, jprecj
[4152]3622            ptab(:,jl      ) = zt2sn(:,jl,2)
3623            ptab(:,ijhom+jl) = zt2ns(:,jl,2)
[3680]3624         END DO
3625      CASE ( 1 )
3626         DO jl = 1, jprecj
[4152]3627            ptab(:,jl) = zt2sn(:,jl,2)
[3680]3628         END DO
3629      END SELECT
3630
3631
3632      ! 4. north fold treatment
3633      ! -----------------------
3634      !
3635      IF( npolj /= 0) THEN
3636         !
3637         SELECT CASE ( jpni )
3638         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp
3639         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs.
3640         END SELECT
3641         !
3642      ENDIF
3643      !
[4152]3644      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we  )
3645      !
[3680]3646   END SUBROUTINE mpp_lnk_bdy_2d
3647
[6140]3648
[2481]3649   SUBROUTINE mpi_init_opa( ldtxt, ksft, code )
[1344]3650      !!---------------------------------------------------------------------
3651      !!                   ***  routine mpp_init.opa  ***
3652      !!
3653      !! ** Purpose :: export and attach a MPI buffer for bsend
3654      !!
3655      !! ** Method  :: define buffer size in namelist, if 0 no buffer attachment
3656      !!            but classical mpi_init
[3764]3657      !!
3658      !! History :: 01/11 :: IDRIS initial version for IBM only
[1344]3659      !!            08/04 :: R. Benshila, generalisation
3660      !!---------------------------------------------------------------------
[3764]3661      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt
[2481]3662      INTEGER                      , INTENT(inout) ::   ksft
3663      INTEGER                      , INTENT(  out) ::   code
3664      INTEGER                                      ::   ierr, ji
3665      LOGICAL                                      ::   mpi_was_called
[1344]3666      !!---------------------------------------------------------------------
3667      !
3668      CALL mpi_initialized( mpi_was_called, code )      ! MPI initialization
[532]3669      IF ( code /= MPI_SUCCESS ) THEN
[3764]3670         DO ji = 1, SIZE(ldtxt)
[2481]3671            IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
[3764]3672         END DO
[2481]3673         WRITE(*, cform_err)
3674         WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized'
[1344]3675         CALL mpi_abort( mpi_comm_world, code, ierr )
[532]3676      ENDIF
[1344]3677      !
3678      IF( .NOT. mpi_was_called ) THEN
3679         CALL mpi_init( code )
3680         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code )
[532]3681         IF ( code /= MPI_SUCCESS ) THEN
[3764]3682            DO ji = 1, SIZE(ldtxt)
[2481]3683               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
3684            END DO
3685            WRITE(*, cform_err)
3686            WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'
[532]3687            CALL mpi_abort( mpi_comm_world, code, ierr )
3688         ENDIF
3689      ENDIF
[1344]3690      !
[897]3691      IF( nn_buffer > 0 ) THEN
[2481]3692         WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of  : ', nn_buffer   ;   ksft = ksft + 1
[897]3693         ! Buffer allocation and attachment
[2481]3694         ALLOCATE( tampon(nn_buffer), stat = ierr )
[3764]3695         IF( ierr /= 0 ) THEN
3696            DO ji = 1, SIZE(ldtxt)
[2481]3697               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
3698            END DO
3699            WRITE(*, cform_err)
3700            WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr
3701            CALL mpi_abort( mpi_comm_world, code, ierr )
3702         END IF
3703         CALL mpi_buffer_attach( tampon, nn_buffer, code )
[897]3704      ENDIF
[1344]3705      !
[13]3706   END SUBROUTINE mpi_init_opa
[3]3707
[1976]3708   SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype)
3709      !!---------------------------------------------------------------------
3710      !!   Routine DDPDD_MPI: used by reduction operator MPI_SUMDD
3711      !!
3712      !!   Modification of original codes written by David H. Bailey
3713      !!   This subroutine computes yddb(i) = ydda(i)+yddb(i)
3714      !!---------------------------------------------------------------------
3715      INTEGER, INTENT(in)                         :: ilen, itype
3716      COMPLEX(wp), DIMENSION(ilen), INTENT(in)     :: ydda
3717      COMPLEX(wp), DIMENSION(ilen), INTENT(inout)  :: yddb
3718      !
3719      REAL(wp) :: zerr, zt1, zt2    ! local work variables
3720      INTEGER :: ji, ztmp           ! local scalar
3721
3722      ztmp = itype   ! avoid compilation warning
3723
3724      DO ji=1,ilen
3725      ! Compute ydda + yddb using Knuth's trick.
3726         zt1  = real(ydda(ji)) + real(yddb(ji))
3727         zerr = zt1 - real(ydda(ji))
3728         zt2  = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) &
3729                + aimag(ydda(ji)) + aimag(yddb(ji))
3730
3731         ! The result is zt1 + zt2, after normalization.
3732         yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
3733      END DO
3734
3735   END SUBROUTINE DDPDD_MPI
3736
[6140]3737
[4990]3738   SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, pr2dj)
3739      !!---------------------------------------------------------------------
3740      !!                   ***  routine mpp_lbc_north_icb  ***
3741      !!
3742      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
3743      !!              in mpp configuration in case of jpn1 > 1 and for 2d
3744      !!              array with outer extra halo
3745      !!
3746      !! ** Method  :   North fold condition and mpp with more than one proc
3747      !!              in i-direction require a specific treatment. We gather
3748      !!              the 4+2*jpr2dj northern lines of the global domain on 1
3749      !!              processor and apply lbc north-fold on this sub array.
3750      !!              Then we scatter the north fold array back to the processors.
3751      !!              This version accounts for an extra halo with icebergs.
3752      !!
3753      !!----------------------------------------------------------------------
3754      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d     ! 2D array with extra halo
3755      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points
3756      !                                                     !   = T ,  U , V , F or W -points
3757      REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the
3758      !!                                                    ! north fold, =  1. otherwise
3759      INTEGER, OPTIONAL       , INTENT(in   ) ::   pr2dj
[6140]3760      !
[4990]3761      INTEGER ::   ji, jj, jr
3762      INTEGER ::   ierr, itaille, ildi, ilei, iilb
3763      INTEGER ::   ijpj, ij, iproc, ipr2dj
3764      !
3765      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e
3766      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e
3767      !!----------------------------------------------------------------------
3768      !
3769      ijpj=4
3770      IF( PRESENT(pr2dj) ) THEN           ! use of additional halos
3771         ipr2dj = pr2dj
3772      ELSE
3773         ipr2dj = 0
3774      ENDIF
3775      ALLOCATE( ztab_e(jpiglo,4+2*ipr2dj), znorthloc_e(jpi,4+2*ipr2dj), znorthgloio_e(jpi,4+2*ipr2dj,jpni) )
3776      !
[6140]3777      ztab_e(:,:) = 0._wp
3778      !
3779      ij = 0
[4990]3780      ! put in znorthloc_e the last 4 jlines of pt2d
3781      DO jj = nlcj - ijpj + 1 - ipr2dj, nlcj +ipr2dj
3782         ij = ij + 1
3783         DO ji = 1, jpi
3784            znorthloc_e(ji,ij)=pt2d(ji,jj)
3785         END DO
3786      END DO
3787      !
3788      itaille = jpi * ( ijpj + 2 * ipr2dj )
3789      CALL MPI_ALLGATHER( znorthloc_e(1,1)  , itaille, MPI_DOUBLE_PRECISION,    &
3790         &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
3791      !
3792      DO jr = 1, ndim_rank_north            ! recover the global north array
3793         iproc = nrank_north(jr) + 1
3794         ildi = nldit (iproc)
3795         ilei = nleit (iproc)
3796         iilb = nimppt(iproc)
3797         DO jj = 1, ijpj+2*ipr2dj
3798            DO ji = ildi, ilei
3799               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
3800            END DO
3801         END DO
3802      END DO
3803
3804
3805      ! 2. North-Fold boundary conditions
3806      ! ----------------------------------
3807      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj )
3808
3809      ij = ipr2dj
3810      !! Scatter back to pt2d
3811      DO jj = nlcj - ijpj + 1 , nlcj +ipr2dj
3812      ij  = ij +1
3813         DO ji= 1, nlci
3814            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
3815         END DO
3816      END DO
3817      !
3818      DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
3819      !
3820   END SUBROUTINE mpp_lbc_north_icb
3821
[6140]3822
[4990]3823   SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, jpri, jprj )
3824      !!----------------------------------------------------------------------
3825      !!                  ***  routine mpp_lnk_2d_icb  ***
3826      !!
3827      !! ** Purpose :   Message passing manadgement for 2d array (with extra halo and icebergs)
3828      !!
3829      !! ** Method  :   Use mppsend and mpprecv function for passing mask
3830      !!      between processors following neighboring subdomains.
3831      !!            domain parameters
3832      !!                    nlci   : first dimension of the local subdomain
3833      !!                    nlcj   : second dimension of the local subdomain
3834      !!                    jpri   : number of rows for extra outer halo
3835      !!                    jprj   : number of columns for extra outer halo
3836      !!                    nbondi : mark for "east-west local boundary"
3837      !!                    nbondj : mark for "north-south local boundary"
3838      !!                    noea   : number for local neighboring processors
3839      !!                    nowe   : number for local neighboring processors
3840      !!                    noso   : number for local neighboring processors
3841      !!                    nono   : number for local neighboring processors
3842      !!----------------------------------------------------------------------
3843      INTEGER                                             , INTENT(in   ) ::   jpri
3844      INTEGER                                             , INTENT(in   ) ::   jprj
3845      REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
3846      CHARACTER(len=1)                                    , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points
3847      !                                                                                 ! = T , U , V , F , W and I points
3848      REAL(wp)                                            , INTENT(in   ) ::   psgn     ! =-1 the sign change across the
3849      !!                                                                                ! north boundary, =  1. otherwise
3850      INTEGER  ::   jl   ! dummy loop indices
3851      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
3852      INTEGER  ::   ipreci, iprecj             ! temporary integers
3853      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
3854      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
3855      !!
3856      REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns
3857      REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn
3858      REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe
3859      REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew
3860      !!----------------------------------------------------------------------
3861
3862      ipreci = jpreci + jpri      ! take into account outer extra 2D overlap area
3863      iprecj = jprecj + jprj
3864
3865
3866      ! 1. standard boundary treatment
3867      ! ------------------------------
3868      ! Order matters Here !!!!
3869      !
3870      !                                      ! East-West boundaries
3871      !                                           !* Cyclic east-west
3872      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
3873         pt2d(1-jpri:     1    ,:) = pt2d(jpim1-jpri:  jpim1 ,:)       ! east
3874         pt2d(   jpi  :jpi+jpri,:) = pt2d(     2      :2+jpri,:)       ! west
3875         !
3876      ELSE                                        !* closed
3877         IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :jpreci    ,:) = 0.e0    ! south except at F-point
3878                                      pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0    ! north
3879      ENDIF
3880      !
3881
3882      ! north fold treatment
3883      ! -----------------------
3884      IF( npolj /= 0 ) THEN
3885         !
3886         SELECT CASE ( jpni )
3887         CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj )
3888         CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj)  , cd_type, psgn , pr2dj=jprj  )
3889         END SELECT
3890         !
3891      ENDIF
3892
3893      ! 2. East and west directions exchange
3894      ! ------------------------------------
3895      ! we play with the neigbours AND the row number because of the periodicity
3896      !
3897      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
3898      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
3899         iihom = nlci-nreci-jpri
3900         DO jl = 1, ipreci
3901            r2dew(:,jl,1) = pt2d(jpreci+jl,:)
3902            r2dwe(:,jl,1) = pt2d(iihom +jl,:)
3903         END DO
3904      END SELECT
3905      !
3906      !                           ! Migrations
3907      imigr = ipreci * ( jpj + 2*jprj)
3908      !
3909      SELECT CASE ( nbondi )
3910      CASE ( -1 )
3911         CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 )
3912         CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
3913         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3914      CASE ( 0 )
3915         CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
3916         CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 )
3917         CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
3918         CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
3919         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3920         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
3921      CASE ( 1 )
3922         CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
3923         CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
3924         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3925      END SELECT
3926      !
3927      !                           ! Write Dirichlet lateral conditions
3928      iihom = nlci - jpreci
3929      !
3930      SELECT CASE ( nbondi )
3931      CASE ( -1 )
3932         DO jl = 1, ipreci
3933            pt2d(iihom+jl,:) = r2dew(:,jl,2)
3934         END DO
3935      CASE ( 0 )
3936         DO jl = 1, ipreci
3937            pt2d(jl-jpri,:) = r2dwe(:,jl,2)
3938            pt2d( iihom+jl,:) = r2dew(:,jl,2)
3939         END DO
3940      CASE ( 1 )
3941         DO jl = 1, ipreci
3942            pt2d(jl-jpri,:) = r2dwe(:,jl,2)
3943         END DO
3944      END SELECT
3945
3946
3947      ! 3. North and south directions
3948      ! -----------------------------
3949      ! always closed : we play only with the neigbours
3950      !
3951      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
3952         ijhom = nlcj-nrecj-jprj
3953         DO jl = 1, iprecj
3954            r2dsn(:,jl,1) = pt2d(:,ijhom +jl)
3955            r2dns(:,jl,1) = pt2d(:,jprecj+jl)
3956         END DO
3957      ENDIF
3958      !
3959      !                           ! Migrations
3960      imigr = iprecj * ( jpi + 2*jpri )
3961      !
3962      SELECT CASE ( nbondj )
3963      CASE ( -1 )
3964         CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 )
3965         CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
3966         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3967      CASE ( 0 )
3968         CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
3969         CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 )
3970         CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
3971         CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
3972         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3973         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
3974      CASE ( 1 )
3975         CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
3976         CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
3977         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3978      END SELECT
3979      !
3980      !                           ! Write Dirichlet lateral conditions
3981      ijhom = nlcj - jprecj
3982      !
3983      SELECT CASE ( nbondj )
3984      CASE ( -1 )
3985         DO jl = 1, iprecj
3986            pt2d(:,ijhom+jl) = r2dns(:,jl,2)
3987         END DO
3988      CASE ( 0 )
3989         DO jl = 1, iprecj
3990            pt2d(:,jl-jprj) = r2dsn(:,jl,2)
3991            pt2d(:,ijhom+jl ) = r2dns(:,jl,2)
3992         END DO
3993      CASE ( 1 )
3994         DO jl = 1, iprecj
3995            pt2d(:,jl-jprj) = r2dsn(:,jl,2)
3996         END DO
3997      END SELECT
3998
3999   END SUBROUTINE mpp_lnk_2d_icb
[6140]4000   
[13]4001#else
4002   !!----------------------------------------------------------------------
4003   !!   Default case:            Dummy module        share memory computing
4004   !!----------------------------------------------------------------------
[2715]4005   USE in_out_manager
[1976]4006
[13]4007   INTERFACE mpp_sum
[3294]4008      MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i, mppsum_realdd, mppsum_a_realdd
[13]4009   END INTERFACE
4010   INTERFACE mpp_max
[681]4011      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
[13]4012   END INTERFACE
4013   INTERFACE mpp_min
4014      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
4015   END INTERFACE
[1344]4016   INTERFACE mpp_minloc
4017      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
4018   END INTERFACE
4019   INTERFACE mpp_maxloc
4020      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
4021   END INTERFACE
[3]4022
[13]4023   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag
[4147]4024   LOGICAL, PUBLIC            ::   ln_nnogather          !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used)
[869]4025   INTEGER :: ncomm_ice
[5412]4026   INTEGER, PUBLIC            ::   mpi_comm_opa          ! opa local communicator
[2715]4027   !!----------------------------------------------------------------------
[13]4028CONTAINS
[3]4029
[2715]4030   INTEGER FUNCTION lib_mpp_alloc(kumout)          ! Dummy function
4031      INTEGER, INTENT(in) ::   kumout
4032      lib_mpp_alloc = 0
4033   END FUNCTION lib_mpp_alloc
4034
[5407]4035   FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg,  kumond , kstop, localComm ) RESULT (function_value)
[1579]4036      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm
[3764]4037      CHARACTER(len=*),DIMENSION(:) ::   ldtxt
[5407]4038      CHARACTER(len=*) ::   ldname
[4314]4039      INTEGER ::   kumnam_ref, knumnam_cfg , kumond , kstop
[5412]4040      IF( PRESENT( localComm ) ) mpi_comm_opa = localComm
4041      function_value = 0
[1579]4042      IF( .FALSE. )   ldtxt(:) = 'never done'
[5407]4043      CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )
[13]4044   END FUNCTION mynode
[3]4045
[13]4046   SUBROUTINE mppsync                       ! Dummy routine
4047   END SUBROUTINE mppsync
[3]4048
[869]4049   SUBROUTINE mpp_sum_as( parr, kdim, kcom )      ! Dummy routine
[13]4050      REAL   , DIMENSION(:) :: parr
4051      INTEGER               :: kdim
[3764]4052      INTEGER, OPTIONAL     :: kcom
[869]4053      WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom
[13]4054   END SUBROUTINE mpp_sum_as
[3]4055
[869]4056   SUBROUTINE mpp_sum_a2s( parr, kdim, kcom )      ! Dummy routine
[13]4057      REAL   , DIMENSION(:,:) :: parr
4058      INTEGER               :: kdim
[3764]4059      INTEGER, OPTIONAL     :: kcom
[869]4060      WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom
[13]4061   END SUBROUTINE mpp_sum_a2s
[3]4062
[869]4063   SUBROUTINE mpp_sum_ai( karr, kdim, kcom )      ! Dummy routine
[13]4064      INTEGER, DIMENSION(:) :: karr
4065      INTEGER               :: kdim
[3764]4066      INTEGER, OPTIONAL     :: kcom
[869]4067      WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom
[13]4068   END SUBROUTINE mpp_sum_ai
[3]4069
[869]4070   SUBROUTINE mpp_sum_s( psca, kcom )            ! Dummy routine
[13]4071      REAL                  :: psca
[3764]4072      INTEGER, OPTIONAL     :: kcom
[869]4073      WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom
[13]4074   END SUBROUTINE mpp_sum_s
[2480]4075
[869]4076   SUBROUTINE mpp_sum_i( kint, kcom )            ! Dummy routine
[13]4077      integer               :: kint
[3764]4078      INTEGER, OPTIONAL     :: kcom
[869]4079      WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom
[13]4080   END SUBROUTINE mpp_sum_i
4081
[3294]4082   SUBROUTINE mppsum_realdd( ytab, kcom )
4083      COMPLEX(wp), INTENT(inout)         :: ytab    ! input scalar
4084      INTEGER , INTENT( in  ), OPTIONAL :: kcom
4085      WRITE(*,*) 'mppsum_realdd: You should not have seen this print! error?', ytab
4086   END SUBROUTINE mppsum_realdd
[3764]4087
[3294]4088   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
4089      INTEGER , INTENT( in )                        ::   kdim      ! size of ytab
4090      COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) ::   ytab      ! input array
4091      INTEGER , INTENT( in  ), OPTIONAL :: kcom
4092      WRITE(*,*) 'mppsum_a_realdd: You should not have seen this print! error?', kdim, ytab(1), kcom
4093   END SUBROUTINE mppsum_a_realdd
4094
[869]4095   SUBROUTINE mppmax_a_real( parr, kdim, kcom )
[13]4096      REAL   , DIMENSION(:) :: parr
4097      INTEGER               :: kdim
[3764]4098      INTEGER, OPTIONAL     :: kcom
[869]4099      WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
[13]4100   END SUBROUTINE mppmax_a_real
4101
[869]4102   SUBROUTINE mppmax_real( psca, kcom )
[13]4103      REAL                  :: psca
[3764]4104      INTEGER, OPTIONAL     :: kcom
[869]4105      WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca, kcom
[13]4106   END SUBROUTINE mppmax_real
4107
[869]4108   SUBROUTINE mppmin_a_real( parr, kdim, kcom )
[13]4109      REAL   , DIMENSION(:) :: parr
4110      INTEGER               :: kdim
[3764]4111      INTEGER, OPTIONAL     :: kcom
[869]4112      WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
[13]4113   END SUBROUTINE mppmin_a_real
4114
[869]4115   SUBROUTINE mppmin_real( psca, kcom )
[13]4116      REAL                  :: psca
[3764]4117      INTEGER, OPTIONAL     :: kcom
[869]4118      WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca, kcom
[13]4119   END SUBROUTINE mppmin_real
4120
[869]4121   SUBROUTINE mppmax_a_int( karr, kdim ,kcom)
[681]4122      INTEGER, DIMENSION(:) :: karr
4123      INTEGER               :: kdim
[3764]4124      INTEGER, OPTIONAL     :: kcom
[888]4125      WRITE(*,*) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
[681]4126   END SUBROUTINE mppmax_a_int
4127
[869]4128   SUBROUTINE mppmax_int( kint, kcom)
[681]4129      INTEGER               :: kint
[3764]4130      INTEGER, OPTIONAL     :: kcom
[869]4131      WRITE(*,*) 'mppmax_int: You should not have seen this print! error?', kint, kcom
[681]4132   END SUBROUTINE mppmax_int
4133
[869]4134   SUBROUTINE mppmin_a_int( karr, kdim, kcom )
[13]4135      INTEGER, DIMENSION(:) :: karr
4136      INTEGER               :: kdim
[3764]4137      INTEGER, OPTIONAL     :: kcom
[869]4138      WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
[13]4139   END SUBROUTINE mppmin_a_int
4140
[869]4141   SUBROUTINE mppmin_int( kint, kcom )
[13]4142      INTEGER               :: kint
[3764]4143      INTEGER, OPTIONAL     :: kcom
[869]4144      WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint, kcom
[13]4145   END SUBROUTINE mppmin_int
4146
[1344]4147   SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki, kj )
[181]4148      REAL                   :: pmin
4149      REAL , DIMENSION (:,:) :: ptab, pmask
4150      INTEGER :: ki, kj
[1528]4151      WRITE(*,*) 'mpp_minloc2d: You should not have seen this print! error?', pmin, ki, kj, ptab(1,1), pmask(1,1)
[181]4152   END SUBROUTINE mpp_minloc2d
4153
[1344]4154   SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj, kk )
[181]4155      REAL                     :: pmin
4156      REAL , DIMENSION (:,:,:) :: ptab, pmask
4157      INTEGER :: ki, kj, kk
[1528]4158      WRITE(*,*) 'mpp_minloc3d: You should not have seen this print! error?', pmin, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
[181]4159   END SUBROUTINE mpp_minloc3d
4160
[1344]4161   SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
[181]4162      REAL                   :: pmax
4163      REAL , DIMENSION (:,:) :: ptab, pmask
4164      INTEGER :: ki, kj
[1528]4165      WRITE(*,*) 'mpp_maxloc2d: You should not have seen this print! error?', pmax, ki, kj, ptab(1,1), pmask(1,1)
[181]4166   END SUBROUTINE mpp_maxloc2d
4167
[1344]4168   SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
[181]4169      REAL                     :: pmax
4170      REAL , DIMENSION (:,:,:) :: ptab, pmask
4171      INTEGER :: ki, kj, kk
[1528]4172      WRITE(*,*) 'mpp_maxloc3d: You should not have seen this print! error?', pmax, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
[181]4173   END SUBROUTINE mpp_maxloc3d
4174
[51]4175   SUBROUTINE mppstop
[3799]4176      STOP      ! non MPP case, just stop the run
[51]4177   END SUBROUTINE mppstop
4178
[2715]4179   SUBROUTINE mpp_ini_ice( kcom, knum )
4180      INTEGER :: kcom, knum
4181      WRITE(*,*) 'mpp_ini_ice: You should not have seen this print! error?', kcom, knum
[888]4182   END SUBROUTINE mpp_ini_ice
[869]4183
[2715]4184   SUBROUTINE mpp_ini_znl( knum )
4185      INTEGER :: knum
4186      WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?', knum
[1345]4187   END SUBROUTINE mpp_ini_znl
4188
[1344]4189   SUBROUTINE mpp_comm_free( kcom )
[869]4190      INTEGER :: kcom
[1344]4191      WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom
[869]4192   END SUBROUTINE mpp_comm_free
[3]4193#endif
[2715]4194
[13]4195   !!----------------------------------------------------------------------
[4147]4196   !!   All cases:         ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam   routines
[2715]4197   !!----------------------------------------------------------------------
4198
4199   SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 ,   &
4200      &                 cd6, cd7, cd8, cd9, cd10 )
4201      !!----------------------------------------------------------------------
4202      !!                  ***  ROUTINE  stop_opa  ***
4203      !!
[3764]4204      !! ** Purpose :   print in ocean.outpput file a error message and
[2715]4205      !!                increment the error number (nstop) by one.
4206      !!----------------------------------------------------------------------
4207      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5
4208      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10
4209      !!----------------------------------------------------------------------
4210      !
[3764]4211      nstop = nstop + 1
[2715]4212      IF(lwp) THEN
4213         WRITE(numout,cform_err)
4214         IF( PRESENT(cd1 ) )   WRITE(numout,*) cd1
4215         IF( PRESENT(cd2 ) )   WRITE(numout,*) cd2
4216         IF( PRESENT(cd3 ) )   WRITE(numout,*) cd3
4217         IF( PRESENT(cd4 ) )   WRITE(numout,*) cd4
4218         IF( PRESENT(cd5 ) )   WRITE(numout,*) cd5
4219         IF( PRESENT(cd6 ) )   WRITE(numout,*) cd6
4220         IF( PRESENT(cd7 ) )   WRITE(numout,*) cd7
4221         IF( PRESENT(cd8 ) )   WRITE(numout,*) cd8
4222         IF( PRESENT(cd9 ) )   WRITE(numout,*) cd9
4223         IF( PRESENT(cd10) )   WRITE(numout,*) cd10
4224      ENDIF
4225                               CALL FLUSH(numout    )
4226      IF( numstp     /= -1 )   CALL FLUSH(numstp    )
4227      IF( numsol     /= -1 )   CALL FLUSH(numsol    )
4228      IF( numevo_ice /= -1 )   CALL FLUSH(numevo_ice)
4229      !
4230      IF( cd1 == 'STOP' ) THEN
4231         IF(lwp) WRITE(numout,*)  'huge E-R-R-O-R : immediate stop'
4232         CALL mppstop()
4233      ENDIF
4234      !
4235   END SUBROUTINE ctl_stop
4236
4237
4238   SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5,   &
4239      &                 cd6, cd7, cd8, cd9, cd10 )
4240      !!----------------------------------------------------------------------
4241      !!                  ***  ROUTINE  stop_warn  ***
4242      !!
[3764]4243      !! ** Purpose :   print in ocean.outpput file a error message and
[2715]4244      !!                increment the warning number (nwarn) by one.
4245      !!----------------------------------------------------------------------
4246      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5
4247      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10
4248      !!----------------------------------------------------------------------
[3764]4249      !
4250      nwarn = nwarn + 1
[2715]4251      IF(lwp) THEN
4252         WRITE(numout,cform_war)
4253         IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1
4254         IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2
4255         IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3
4256         IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4
4257         IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5
4258         IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6
4259         IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7
4260         IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8
4261         IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9
4262         IF( PRESENT(cd10) ) WRITE(numout,*) cd10
4263      ENDIF
4264      CALL FLUSH(numout)
4265      !
4266   END SUBROUTINE ctl_warn
4267
4268
4269   SUBROUTINE ctl_opn( knum, cdfile, cdstat, cdform, cdacce, klengh, kout, ldwp, karea )
4270      !!----------------------------------------------------------------------
4271      !!                  ***  ROUTINE ctl_opn  ***
4272      !!
4273      !! ** Purpose :   Open file and check if required file is available.
4274      !!
4275      !! ** Method  :   Fortan open
4276      !!----------------------------------------------------------------------
4277      INTEGER          , INTENT(  out) ::   knum      ! logical unit to open
4278      CHARACTER(len=*) , INTENT(in   ) ::   cdfile    ! file name to open
4279      CHARACTER(len=*) , INTENT(in   ) ::   cdstat    ! disposition specifier
4280      CHARACTER(len=*) , INTENT(in   ) ::   cdform    ! formatting specifier
4281      CHARACTER(len=*) , INTENT(in   ) ::   cdacce    ! access specifier
4282      INTEGER          , INTENT(in   ) ::   klengh    ! record length
4283      INTEGER          , INTENT(in   ) ::   kout      ! number of logical units for write
4284      LOGICAL          , INTENT(in   ) ::   ldwp      ! boolean term for print
4285      INTEGER, OPTIONAL, INTENT(in   ) ::   karea     ! proc number
[5836]4286      !
[2715]4287      CHARACTER(len=80) ::   clfile
4288      INTEGER           ::   iost
4289      !!----------------------------------------------------------------------
[5836]4290      !
[2715]4291      ! adapt filename
4292      ! ----------------
4293      clfile = TRIM(cdfile)
4294      IF( PRESENT( karea ) ) THEN
4295         IF( karea > 1 )   WRITE(clfile, "(a,'_',i4.4)") TRIM(clfile), karea-1
4296      ENDIF
4297#if defined key_agrif
4298      IF( .NOT. Agrif_Root() )   clfile = TRIM(Agrif_CFixed())//'_'//TRIM(clfile)
4299      knum=Agrif_Get_Unit()
4300#else
4301      knum=get_unit()
4302#endif
[5836]4303      !
[2715]4304      iost=0
4305      IF( cdacce(1:6) == 'DIRECT' )  THEN
4306         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh, ERR=100, IOSTAT=iost )
4307      ELSE
4308         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat             , ERR=100, IOSTAT=iost )
4309      ENDIF
4310      IF( iost == 0 ) THEN
4311         IF(ldwp) THEN
4312            WRITE(kout,*) '     file   : ', clfile,' open ok'
4313            WRITE(kout,*) '     unit   = ', knum
4314            WRITE(kout,*) '     status = ', cdstat
4315            WRITE(kout,*) '     form   = ', cdform
4316            WRITE(kout,*) '     access = ', cdacce
4317            WRITE(kout,*)
4318         ENDIF
4319      ENDIF
4320100   CONTINUE
4321      IF( iost /= 0 ) THEN
4322         IF(ldwp) THEN
4323            WRITE(kout,*)
4324            WRITE(kout,*) ' ===>>>> : bad opening file: ', clfile
4325            WRITE(kout,*) ' =======   ===  '
4326            WRITE(kout,*) '           unit   = ', knum
4327            WRITE(kout,*) '           status = ', cdstat
4328            WRITE(kout,*) '           form   = ', cdform
4329            WRITE(kout,*) '           access = ', cdacce
4330            WRITE(kout,*) '           iostat = ', iost
4331            WRITE(kout,*) '           we stop. verify the file '
4332            WRITE(kout,*)
4333         ENDIF
[7646]4334         CALL FLUSH(kout) 
[2715]4335         STOP 'ctl_opn bad opening'
4336      ENDIF
[5836]4337      !
[2715]4338   END SUBROUTINE ctl_opn
4339
[5836]4340
[4147]4341   SUBROUTINE ctl_nam ( kios, cdnam, ldwp )
4342      !!----------------------------------------------------------------------
4343      !!                  ***  ROUTINE ctl_nam  ***
4344      !!
4345      !! ** Purpose :   Informations when error while reading a namelist
4346      !!
4347      !! ** Method  :   Fortan open
4348      !!----------------------------------------------------------------------
[5836]4349      INTEGER         , INTENT(inout) ::   kios    ! IO status after reading the namelist
4350      CHARACTER(len=*), INTENT(in   ) ::   cdnam   ! group name of namelist for which error occurs
[7646]4351      CHARACTER(len=5)                ::   clios   ! string to convert iostat in character for print
[5836]4352      LOGICAL         , INTENT(in   ) ::   ldwp    ! boolean term for print
[4147]4353      !!----------------------------------------------------------------------
[5836]4354      !
[7646]4355      WRITE (clios, '(I5.0)')   kios
[4147]4356      IF( kios < 0 ) THEN         
[5836]4357         CALL ctl_warn( 'end of record or file while reading namelist '   &
4358            &           // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
[4147]4359      ENDIF
[5836]4360      !
[4147]4361      IF( kios > 0 ) THEN
[5836]4362         CALL ctl_stop( 'misspelled variable in namelist '   &
4363            &           // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
[4147]4364      ENDIF
4365      kios = 0
4366      RETURN
[5836]4367      !
[4147]4368   END SUBROUTINE ctl_nam
4369
[5836]4370
[2715]4371   INTEGER FUNCTION get_unit()
4372      !!----------------------------------------------------------------------
4373      !!                  ***  FUNCTION  get_unit  ***
4374      !!
4375      !! ** Purpose :   return the index of an unused logical unit
4376      !!----------------------------------------------------------------------
[3764]4377      LOGICAL :: llopn
[2715]4378      !!----------------------------------------------------------------------
4379      !
4380      get_unit = 15   ! choose a unit that is big enough then it is not already used in NEMO
4381      llopn = .TRUE.
4382      DO WHILE( (get_unit < 998) .AND. llopn )
4383         get_unit = get_unit + 1
4384         INQUIRE( unit = get_unit, opened = llopn )
4385      END DO
4386      IF( (get_unit == 999) .AND. llopn ) THEN
4387         CALL ctl_stop( 'get_unit: All logical units until 999 are used...' )
4388         get_unit = -1
4389      ENDIF
4390      !
4391   END FUNCTION get_unit
4392
4393   !!----------------------------------------------------------------------
[3]4394END MODULE lib_mpp
Note: See TracBrowser for help on using the repository browser.