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.
mppini.F90 in NEMO/trunk/src/OCE/LBC – NEMO

source: NEMO/trunk/src/OCE/LBC/mppini.F90 @ 14325

Last change on this file since 14325 was 14275, checked in by smasson, 3 years ago

trunk: suppress nproc ( = mpprank = narea-1)

  • Property svn:keywords set to Id
File size: 68.0 KB
Line 
1MODULE mppini
2   !!======================================================================
3   !!                       ***  MODULE mppini   ***
4   !! Ocean initialization : distributed memory computing initialization
5   !!======================================================================
6   !! History :  6.0  !  1994-11  (M. Guyon)  Original code
7   !!  OPA       7.0  !  1995-04  (J. Escobar, M. Imbard)
8   !!            8.0  !  1998-05  (M. Imbard, J. Escobar, L. Colombet )  SHMEM and MPI versions
9   !!  NEMO      1.0  !  2004-01  (G. Madec, J.M Molines)  F90 : free form , north fold jpni > 1
10   !!            3.4  !  2011-10  (A. C. Coward, NOCS & J. Donners, PRACE)  add init_nfdcom
11   !!            3.   !  2013-06  (I. Epicoco, S. Mocavero, CMCC)  init_nfdcom: setup avoiding MPI communication
12   !!            4.0  !  2016-06  (G. Madec)  use domain configuration file instead of bathymetry file
13   !!            4.0  !  2017-06  (J.M. Molines, T. Lovato) merge of mppini and mppini_2
14   !!----------------------------------------------------------------------
15
16   !!----------------------------------------------------------------------
17   !!  mpp_init       : Lay out the global domain over processors with/without land processor elimination
18   !!      init_ioipsl: IOIPSL initialization in mpp
19   !!      init_nfdcom: Setup for north fold exchanges with explicit point-to-point messaging
20   !!      init_doloop: set the starting/ending indices of DO-loop used in do_loop_substitute
21   !!----------------------------------------------------------------------
22   USE dom_oce        ! ocean space and time domain
23   USE bdy_oce        ! open BounDarY
24   !
25   USE lbcnfd  , ONLY : isendto, nsndto ! Setup of north fold exchanges
26   USE lib_mpp        ! distribued memory computing library
27   USE iom            ! nemo I/O library
28   USE ioipsl         ! I/O IPSL library
29   USE in_out_manager ! I/O Manager
30
31   IMPLICIT NONE
32   PRIVATE
33
34   PUBLIC   mpp_init       ! called by nemogcm.F90
35   PUBLIC   mpp_getnum     ! called by prtctl
36   PUBLIC   mpp_basesplit  ! called by prtctl
37   PUBLIC   mpp_is_ocean   ! called by prtctl
38
39   INTEGER ::   numbot = -1   ! 'bottom_level' local logical unit
40   INTEGER ::   numbdy = -1   ! 'bdy_msk'      local logical unit
41
42   !!----------------------------------------------------------------------
43   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
44   !! $Id$
45   !! Software governed by the CeCILL license (see ./LICENSE)
46   !!----------------------------------------------------------------------
47CONTAINS
48
49#if defined key_mpi_off
50   !!----------------------------------------------------------------------
51   !!   Default option :                            shared memory computing
52   !!----------------------------------------------------------------------
53
54   SUBROUTINE mpp_init
55      !!----------------------------------------------------------------------
56      !!                  ***  ROUTINE mpp_init  ***
57      !!
58      !! ** Purpose :   Lay out the global domain over processors.
59      !!
60      !! ** Method  :   Shared memory computing, set the local processor
61      !!              variables to the value of the global domain
62      !!----------------------------------------------------------------------
63      !
64      nn_hls = 1
65      jpiglo = Ni0glo + 2 * nn_hls
66      jpjglo = Nj0glo + 2 * nn_hls
67      jpimax = jpiglo
68      jpjmax = jpjglo
69      jpi    = jpiglo
70      jpj    = jpjglo
71      jpk    = jpkglo
72      jpim1  = jpi-1                         ! inner domain indices
73      jpjm1  = jpj-1                         !   "           "
74      jpkm1  = MAX( 1, jpk-1 )               !   "           "
75      jpij   = jpi*jpj
76      jpni   = 1
77      jpnj   = 1
78      jpnij  = jpni*jpnj
79      nimpp  = 1
80      njmpp  = 1
81      nbondi = 2
82      nbondj = 2
83      nidom  = FLIO_DOM_NONE
84      npolj = 0
85      IF( jperio == 3 .OR. jperio == 4 )   npolj = 3
86      IF( jperio == 5 .OR. jperio == 6 )   npolj = 5
87      l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7)
88      l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7)
89      !
90      CALL init_doloop                       ! set start/end indices or do-loop depending on the halo width value (nn_hls)
91      !
92      IF(lwp) THEN
93         WRITE(numout,*)
94         WRITE(numout,*) 'mpp_init : NO massively parallel processing'
95         WRITE(numout,*) '~~~~~~~~ '
96         WRITE(numout,*) '   l_Iperio = ', l_Iperio, '    l_Jperio = ', l_Jperio
97         WRITE(numout,*) '     npolj  = ',   npolj , '      njmpp  = ', njmpp
98      ENDIF
99      !
100#if defined key_agrif
101    IF (.NOT.agrif_root()) THEN
102      call agrif_nemo_init()
103    ENDIF
104#endif
105   END SUBROUTINE mpp_init
106
107#else
108   !!----------------------------------------------------------------------
109   !!                   MPI massively parallel processing
110   !!----------------------------------------------------------------------
111
112
113   SUBROUTINE mpp_init
114      !!----------------------------------------------------------------------
115      !!                  ***  ROUTINE mpp_init  ***
116      !!
117      !! ** Purpose :   Lay out the global domain over processors.
118      !!      If land processors are to be eliminated, this program requires the
119      !!      presence of the domain configuration file. Land processors elimination
120      !!      is performed if jpni x jpnj /= jpnij. In this case, using the MPP_PREP
121      !!      preprocessing tool, help for defining the best cutting out.
122      !!
123      !! ** Method  :   Global domain is distributed in smaller local domains.
124      !!      Periodic condition is a function of the local domain position
125      !!      (global boundary or neighbouring domain) and of the global
126      !!      periodic
127      !!      Type :         jperio global periodic condition
128      !!
129      !! ** Action : - set domain parameters
130      !!                    nimpp     : longitudinal index
131      !!                    njmpp     : latitudinal  index
132      !!                    narea     : number for local area
133      !!                    nbondi    : mark for "east-west local boundary"
134      !!                    nbondj    : mark for "north-south local boundary"
135      !!                    noea      : number for local neighboring processor
136      !!                    nowe      : number for local neighboring processor
137      !!                    noso      : number for local neighboring processor
138      !!                    nono      : number for local neighboring processor
139      !!----------------------------------------------------------------------
140      INTEGER ::   ji, jj, jn, jproc, jarea   ! dummy loop indices
141      INTEGER ::   inijmin
142      INTEGER ::   inum                       ! local logical unit
143      INTEGER ::   idir, ifreq                ! local integers
144      INTEGER ::   ii, il1, ili, imil         !   -       -
145      INTEGER ::   ij, il2, ilj, ijm1         !   -       -
146      INTEGER ::   iino, ijno, iiso, ijso     !   -       -
147      INTEGER ::   iiea, ijea, iiwe, ijwe     !   -       -
148      INTEGER ::   iarea0                     !   -       -
149      INTEGER ::   ierr, ios                  !
150      INTEGER ::   inbi, inbj, iimax,  ijmax, icnt1, icnt2
151      LOGICAL ::   llbest, llauto
152      LOGICAL ::   llwrtlay
153      LOGICAL ::   ln_listonly
154      INTEGER, ALLOCATABLE, DIMENSION(:)     ::   iin, ii_nono, ii_noea          ! 1D workspace
155      INTEGER, ALLOCATABLE, DIMENSION(:)     ::   ijn, ii_noso, ii_nowe          !  -     -
156      INTEGER, ALLOCATABLE, DIMENSION(:,:) ::   iimppt, ijpi, ibondi, ipproc   ! 2D workspace
157      INTEGER, ALLOCATABLE, DIMENSION(:,:) ::   ijmppt, ijpj, ibondj, ipolj    !  -     -
158      INTEGER, ALLOCATABLE, DIMENSION(:,:) ::   iie0, iis0, iono, ioea         !  -     -
159      INTEGER, ALLOCATABLE, DIMENSION(:,:) ::   ije0, ijs0, ioso, iowe         !  -     -
160      LOGICAL, ALLOCATABLE, DIMENSION(:,:) ::   llisoce                        !  -     -
161      NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file,           &
162           &             ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta,     &
163           &             cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta,             &
164           &             ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, &
165           &             cn_ice, nn_ice_dta,                                     &
166           &             ln_vol, nn_volctl, nn_rimwidth
167      NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly
168      !!----------------------------------------------------------------------
169      !
170      llwrtlay = lwm .OR. sn_cfctl%l_layout
171      !
172      !  0. read namelists parameters
173      ! -----------------------------------
174      !
175      READ  ( numnam_ref, nammpp, IOSTAT = ios, ERR = 901 )
176901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nammpp in reference namelist' )
177      READ  ( numnam_cfg, nammpp, IOSTAT = ios, ERR = 902 )
178902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nammpp in configuration namelist' )
179      !
180      nn_hls = MAX(1, nn_hls)   ! nn_hls must be > 0
181      IF(lwp) THEN
182            WRITE(numout,*) '   Namelist nammpp'
183         IF( jpni < 1 .OR. jpnj < 1  ) THEN
184            WRITE(numout,*) '      jpni and jpnj will be calculated automatically'
185         ELSE
186            WRITE(numout,*) '      processor grid extent in i                            jpni = ', jpni
187            WRITE(numout,*) '      processor grid extent in j                            jpnj = ', jpnj
188         ENDIF
189            WRITE(numout,*) '      avoid use of mpi_allgather at the north fold  ln_nnogather = ', ln_nnogather
190            WRITE(numout,*) '      halo width (applies to both rows and columns)       nn_hls = ', nn_hls
191      ENDIF
192      !
193      IF(lwm)   WRITE( numond, nammpp )
194      !
195!!!------------------------------------
196!!!  nn_hls shloud be read in nammpp
197!!!------------------------------------
198      jpiglo = Ni0glo + 2 * nn_hls
199      jpjglo = Nj0glo + 2 * nn_hls
200      !
201      ! do we need to take into account bdy_msk?
202      READ  ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903)
203903   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambdy in reference namelist (mppini)' )
204      READ  ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 )
205904   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambdy in configuration namelist (mppini)' )
206      !
207      IF(               ln_read_cfg ) CALL iom_open( cn_domcfg,    numbot )
208      IF( ln_bdy .AND. ln_mask_file ) CALL iom_open( cn_mask_file, numbdy )
209      !
210      IF( ln_listonly )   CALL bestpartition( MAX(mppsize,jpni*jpnj), ldlist = .TRUE. )   ! must be done by all core
211      !
212      !  1. Dimension arrays for subdomains
213      ! -----------------------------------
214      !
215      ! If dimensions of processors grid weren't specified in the namelist file
216      ! then we calculate them here now that we have our communicator size
217      IF(lwp) THEN
218         WRITE(numout,*)
219         WRITE(numout,*) 'mpp_init:'
220         WRITE(numout,*) '~~~~~~~~ '
221      ENDIF
222      IF( jpni < 1 .OR. jpnj < 1 ) THEN
223         CALL bestpartition( mppsize, jpni, jpnj )           ! best mpi decomposition for mppsize mpi processes
224         llauto = .TRUE.
225         llbest = .TRUE.
226      ELSE
227         llauto = .FALSE.
228         CALL bestpartition( mppsize, inbi, inbj, icnt2 )    ! best mpi decomposition for mppsize mpi processes
229         ! largest subdomain size for mpi decoposition jpni*jpnj given in the namelist
230         CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax )
231         ! largest subdomain size for mpi decoposition inbi*inbj given by bestpartition
232         CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, inbi, inbj,  iimax,  ijmax )
233         icnt1 = jpni*jpnj - mppsize   ! number of land subdomains that should be removed to use mppsize mpi processes
234         IF(lwp) THEN
235            WRITE(numout,9000) '   The chosen domain decomposition ', jpni, ' x ', jpnj, ' with ', icnt1, ' land subdomains'
236            WRITE(numout,9002) '      - uses a total of ',  mppsize,' mpi process'
237            WRITE(numout,9000) '      - has mpi subdomains with a maximum size of (jpi = ', jpimax, ', jpj = ', jpjmax,   &
238               &                                                                ', jpi*jpj = ', jpimax*jpjmax, ')'
239            WRITE(numout,9000) '   The best domain decompostion ', inbi, ' x ', inbj, ' with ', icnt2, ' land subdomains'
240            WRITE(numout,9002) '      - uses a total of ',  inbi*inbj-icnt2,' mpi process'
241            WRITE(numout,9000) '      - has mpi subdomains with a maximum size of (jpi = ',  iimax, ', jpj = ',  ijmax,   &
242               &                                                             ', jpi*jpj = ',  iimax* ijmax, ')'
243         ENDIF
244         IF( iimax*ijmax < jpimax*jpjmax ) THEN   ! chosen subdomain size is larger that the best subdomain size
245            llbest = .FALSE.
246            IF ( inbi*inbj-icnt2 < mppsize ) THEN
247               WRITE(ctmp1,*) '   ==> You could therefore have smaller mpi subdomains with less mpi processes'
248            ELSE
249               WRITE(ctmp1,*) '   ==> You could therefore have smaller mpi subdomains with the same number of mpi processes'
250            ENDIF
251            CALL ctl_warn( ' ', ctmp1, ' ', '    ---   YOU ARE WASTING CPU...   ---', ' ' )
252         ELSE IF ( iimax*ijmax == jpimax*jpjmax .AND. (inbi*inbj-icnt2) <  mppsize) THEN
253            llbest = .FALSE.
254            WRITE(ctmp1,*) '   ==> You could therefore have the same mpi subdomains size with less mpi processes'
255            CALL ctl_warn( ' ', ctmp1, ' ', '    ---   YOU ARE WASTING CPU...   ---', ' ' )
256         ELSE
257            llbest = .TRUE.
258         ENDIF
259      ENDIF
260
261      ! look for land mpi subdomains...
262      ALLOCATE( llisoce(jpni,jpnj) )
263      CALL mpp_is_ocean( llisoce )
264      inijmin = COUNT( llisoce )   ! number of oce subdomains
265
266      IF( mppsize < inijmin ) THEN   ! too many oce subdomains: can happen only if jpni and jpnj are prescribed...
267         WRITE(ctmp1,9001) '   With this specified domain decomposition: jpni = ', jpni, ' jpnj = ', jpnj
268         WRITE(ctmp2,9002) '   we can eliminate only ', jpni*jpnj - inijmin, ' land mpi subdomains therefore '
269         WRITE(ctmp3,9001) '   the number of ocean mpi subdomains (', inijmin,') exceed the number of MPI processes:', mppsize
270         WRITE(ctmp4,*) '   ==>>> There is the list of best domain decompositions you should use: '
271         CALL ctl_stop( ctmp1, ctmp2, ctmp3, ' ', ctmp4, ' ' )
272         CALL bestpartition( mppsize, ldlist = .TRUE. )   ! must be done by all core
273      ENDIF
274
275      IF( mppsize > jpni*jpnj ) THEN   ! not enough mpi subdomains for the total number of mpi processes
276         IF(lwp) THEN
277            WRITE(numout,9003) '   The number of mpi processes: ', mppsize
278            WRITE(numout,9003) '   exceeds the maximum number of subdomains (ocean+land) = ', jpni*jpnj
279            WRITE(numout,9001) '   defined by the following domain decomposition: jpni = ', jpni, ' jpnj = ', jpnj
280            WRITE(numout,   *) '   You should: '
281           IF( llauto ) THEN
282               WRITE(numout,*) '     - either prescribe your domain decomposition with the namelist variables'
283               WRITE(numout,*) '       jpni and jpnj to match the number of mpi process you want to use, '
284               WRITE(numout,*) '       even IF it not the best choice...'
285               WRITE(numout,*) '     - or keep the automatic and optimal domain decomposition by picking up one'
286               WRITE(numout,*) '       of the number of mpi process proposed in the list bellow'
287            ELSE
288               WRITE(numout,*) '     - either properly prescribe your domain decomposition with jpni and jpnj'
289               WRITE(numout,*) '       in order to be consistent with the number of mpi process you want to use'
290               WRITE(numout,*) '       even IF it not the best choice...'
291               WRITE(numout,*) '     - or use the automatic and optimal domain decomposition and pick up one of'
292               WRITE(numout,*) '       the domain decomposition proposed in the list bellow'
293            ENDIF
294            WRITE(numout,*)
295         ENDIF
296         CALL bestpartition( mppsize, ldlist = .TRUE. )   ! must be done by all core
297      ENDIF
298
299      jpnij = mppsize   ! force jpnij definition <-- remove as much land subdomains as needed to reach this condition
300      IF( mppsize > inijmin ) THEN
301         WRITE(ctmp1,9003) '   The number of mpi processes: ', mppsize
302         WRITE(ctmp2,9003) '   exceeds the maximum number of ocean subdomains = ', inijmin
303         WRITE(ctmp3,9002) '   we suppressed ', jpni*jpnj - mppsize, ' land subdomains '
304         WRITE(ctmp4,9002) '   BUT we had to keep ', mppsize - inijmin, ' land subdomains that are useless...'
305         CALL ctl_warn( ctmp1, ctmp2, ctmp3, ctmp4, ' ', '    --- YOU ARE WASTING CPU... ---', ' ' )
306      ELSE   ! mppsize = inijmin
307         IF(lwp) THEN
308            IF(llbest) WRITE(numout,*) '   ==> you use the best mpi decomposition'
309            WRITE(numout,*)
310            WRITE(numout,9003) '   Number of mpi processes: ', mppsize
311            WRITE(numout,9003) '   Number of ocean subdomains = ', inijmin
312            WRITE(numout,9003) '   Number of suppressed land subdomains = ', jpni*jpnj - inijmin
313            WRITE(numout,*)
314         ENDIF
315      ENDIF
3169000  FORMAT (a, i4, a, i4, a, i7, a)
3179001  FORMAT (a, i4, a, i4)
3189002  FORMAT (a, i4, a)
3199003  FORMAT (a, i5)
320
321      ALLOCATE(  nfimpp(jpni ) , nfproc(jpni ) ,   nfjpi(jpni ) ,                     &
322         &       nimppt(jpnij) , ibonit(jpnij) ,  jpiall(jpnij) ,  jpjall(jpnij) ,    &
323         &       njmppt(jpnij) , ibonjt(jpnij) , nis0all(jpnij) , njs0all(jpnij) ,    &
324         &                                       nie0all(jpnij) , nje0all(jpnij) ,    &
325         &       iin(jpnij), ii_nono(jpnij), ii_noea(jpnij),   &
326         &       ijn(jpnij), ii_noso(jpnij), ii_nowe(jpnij),   &
327         &       iimppt(jpni,jpnj), ijpi(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj),   &
328         &       ijmppt(jpni,jpnj), ijpj(jpni,jpnj), ibondj(jpni,jpnj),  ipolj(jpni,jpnj),   &
329         &         iie0(jpni,jpnj), iis0(jpni,jpnj),   iono(jpni,jpnj),   ioea(jpni,jpnj),   &
330         &         ije0(jpni,jpnj), ijs0(jpni,jpnj),   ioso(jpni,jpnj),   iowe(jpni,jpnj),   &
331         &       STAT=ierr )
332      CALL mpp_sum( 'mppini', ierr )
333      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'mpp_init: unable to allocate standard ocean arrays' )
334
335#if defined key_agrif
336      IF( .NOT. Agrif_Root() ) THEN       ! AGRIF children: specific setting (cf. agrif_user.F90)
337         CALL agrif_nemo_init()
338      ENDIF
339#endif
340      !
341      !  2. Index arrays for subdomains
342      ! -----------------------------------
343      !
344      CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ijpi, ijpj )
345      CALL mpp_getnum( llisoce, ipproc, iin, ijn )
346      !
347      !DO jn = 1, jpni
348      !   jproc = ipproc(jn,jpnj)
349      !   ii = iin(jproc+1)
350      !   ij = ijn(jproc+1)
351      !   nfproc(jn) = jproc
352      !   nfimpp(jn) = iimppt(ii,ij)
353      !   nfjpi (jn) =   ijpi(ii,ij)
354      !END DO
355      nfproc(:) = ipproc(:,jpnj)
356      nfimpp(:) = iimppt(:,jpnj)
357      nfjpi (:) =   ijpi(:,jpnj)
358      !
359      IF(lwp) THEN
360         WRITE(numout,*)
361         WRITE(numout,*) 'MPI Message Passing MPI - domain lay out over processors'
362         WRITE(numout,*)
363         WRITE(numout,*) '   defines mpp subdomains'
364         WRITE(numout,*) '      jpni = ', jpni
365         WRITE(numout,*) '      jpnj = ', jpnj
366         WRITE(numout,*) '     jpnij = ', jpnij
367         WRITE(numout,*)
368         WRITE(numout,*) '      sum ijpi(i,1) = ', sum(ijpi(:,1)), ' jpiglo = ', jpiglo
369         WRITE(numout,*) '      sum ijpj(1,j) = ', sum(ijpj(1,:)), ' jpjglo = ', jpjglo
370      ENDIF
371
372      ! 3. Subdomain description in the Regular Case
373      ! --------------------------------------------
374      ! specific cases where there is no communication -> must do the periodicity by itself
375      ! Warning: because of potential land-area suppression, do not use nbond[ij] == 2
376      l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7)
377      l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7)
378
379      DO jarea = 1, jpni*jpnj
380         !
381         iarea0 = jarea - 1
382         ii = 1 + MOD(iarea0,jpni)
383         ij = 1 +     iarea0/jpni
384         ili = ijpi(ii,ij)
385         ilj = ijpj(ii,ij)
386         ibondi(ii,ij) = 0                         ! default: has e-w neighbours
387         IF( ii   ==    1 )   ibondi(ii,ij) = -1   ! first column, has only e neighbour
388         IF( ii   == jpni )   ibondi(ii,ij) =  1   ! last column,  has only w neighbour
389         IF( jpni ==    1 )   ibondi(ii,ij) =  2   ! has no e-w neighbour
390         ibondj(ii,ij) = 0                         ! default: has n-s neighbours
391         IF( ij   ==    1 )   ibondj(ii,ij) = -1   ! first row, has only n neighbour
392         IF( ij   == jpnj )   ibondj(ii,ij) =  1   ! last row,  has only s neighbour
393         IF( jpnj ==    1 )   ibondj(ii,ij) =  2   ! has no n-s neighbour
394
395         ! Subdomain neighbors (get their zone number): default definition
396         ioso(ii,ij) = iarea0 - jpni
397         iowe(ii,ij) = iarea0 - 1
398         ioea(ii,ij) = iarea0 + 1
399         iono(ii,ij) = iarea0 + jpni
400         iis0(ii,ij) =  1  + nn_hls
401         iie0(ii,ij) = ili - nn_hls
402         ijs0(ii,ij) =  1  + nn_hls
403         ije0(ii,ij) = ilj - nn_hls
404
405         ! East-West periodicity: change ibondi, ioea, iowe
406         IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 ) THEN
407            IF( jpni  /= 1 )   ibondi(ii,ij) = 0                        ! redefine: all have e-w neighbours
408            IF( ii ==    1 )   iowe(ii,ij) = iarea0 +        (jpni-1)   ! redefine: first column, address of w neighbour
409            IF( ii == jpni )   ioea(ii,ij) = iarea0 -        (jpni-1)   ! redefine: last column,  address of e neighbour
410         ENDIF
411
412         ! Simple North-South periodicity: change ibondj, ioso, iono
413         IF( jperio == 2 .OR. jperio == 7 ) THEN
414            IF( jpnj  /= 1 )   ibondj(ii,ij) = 0                        ! redefine: all have n-s neighbours
415            IF( ij ==    1 )   ioso(ii,ij) = iarea0 + jpni * (jpnj-1)   ! redefine: first row, address of s neighbour
416            IF( ij == jpnj )   iono(ii,ij) = iarea0 - jpni * (jpnj-1)   ! redefine: last row,  address of n neighbour
417         ENDIF
418
419         ! North fold: define ipolj, change iono. Warning: we do not change ibondj...
420         ipolj(ii,ij) = 0
421         IF( jperio == 3 .OR. jperio == 4 ) THEN
422            ijm1 = jpni*(jpnj-1)
423            imil = ijm1+(jpni+1)/2
424            IF( jarea > ijm1 ) ipolj(ii,ij) = 3
425            IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 4
426            IF( ipolj(ii,ij) == 3 ) iono(ii,ij) = jpni*jpnj-jarea+ijm1   ! MPI rank of northern neighbour
427         ENDIF
428         IF( jperio == 5 .OR. jperio == 6 ) THEN
429            ijm1 = jpni*(jpnj-1)
430            imil = ijm1+(jpni+1)/2
431            IF( jarea > ijm1) ipolj(ii,ij) = 5
432            IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 6
433            IF( ipolj(ii,ij) == 5) iono(ii,ij) = jpni*jpnj-jarea+ijm1    ! MPI rank of northern neighbour
434         ENDIF
435         !
436      END DO
437
438      ! 4. deal with land subdomains
439      ! ----------------------------
440      !
441      ! neighbour treatment: change ibondi, ibondj if next to a land zone
442      DO jarea = 1, jpni*jpnj
443         ii = 1 + MOD( jarea-1  , jpni )
444         ij = 1 +     (jarea-1) / jpni
445         ! land-only area with an active n neigbour
446         IF ( ipproc(ii,ij) == -1 .AND. 0 <= iono(ii,ij) .AND. iono(ii,ij) <= jpni*jpnj-1 ) THEN
447            iino = 1 + MOD( iono(ii,ij) , jpni )                    ! ii index of this n neigbour
448            ijno = 1 +      iono(ii,ij) / jpni                      ! ij index of this n neigbour
449            ! In case of north fold exchange: I am the n neigbour of my n neigbour!! (#1057)
450            ! --> for northern neighbours of northern row processors (in case of north-fold)
451            !     need to reverse the LOGICAL direction of communication
452            idir = 1                                           ! we are indeed the s neigbour of this n neigbour
453            IF( ij == jpnj .AND. ijno == jpnj )   idir = -1    ! both are on the last row, we are in fact the n neigbour
454            IF( ibondj(iino,ijno) == idir     )   ibondj(iino,ijno) =   2     ! this n neigbour had only a s/n neigbour -> no more
455            IF( ibondj(iino,ijno) == 0        )   ibondj(iino,ijno) = -idir   ! this n neigbour had both, n-s neighbours -> keep 1
456         ENDIF
457         ! land-only area with an active s neigbour
458         IF( ipproc(ii,ij) == -1 .AND. 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= jpni*jpnj-1 ) THEN
459            iiso = 1 + MOD( ioso(ii,ij) , jpni )                    ! ii index of this s neigbour
460            ijso = 1 +      ioso(ii,ij) / jpni                      ! ij index of this s neigbour
461            IF( ibondj(iiso,ijso) == -1 )   ibondj(iiso,ijso) = 2   ! this s neigbour had only a n neigbour    -> no more neigbour
462            IF( ibondj(iiso,ijso) ==  0 )   ibondj(iiso,ijso) = 1   ! this s neigbour had both, n-s neighbours -> keep s neigbour
463         ENDIF
464         ! land-only area with an active e neigbour
465         IF( ipproc(ii,ij) == -1 .AND. 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= jpni*jpnj-1 ) THEN
466            iiea = 1 + MOD( ioea(ii,ij) , jpni )                    ! ii index of this e neigbour
467            ijea = 1 +      ioea(ii,ij) / jpni                      ! ij index of this e neigbour
468            IF( ibondi(iiea,ijea) == 1 )   ibondi(iiea,ijea) =  2   ! this e neigbour had only a w neigbour    -> no more neigbour
469            IF( ibondi(iiea,ijea) == 0 )   ibondi(iiea,ijea) = -1   ! this e neigbour had both, e-w neighbours -> keep e neigbour
470         ENDIF
471         ! land-only area with an active w neigbour
472         IF( ipproc(ii,ij) == -1 .AND. 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= jpni*jpnj-1) THEN
473            iiwe = 1 + MOD( iowe(ii,ij) , jpni )                    ! ii index of this w neigbour
474            ijwe = 1 +      iowe(ii,ij) / jpni                      ! ij index of this w neigbour
475            IF( ibondi(iiwe,ijwe) == -1 )   ibondi(iiwe,ijwe) = 2   ! this w neigbour had only a e neigbour    -> no more neigbour
476            IF( ibondi(iiwe,ijwe) ==  0 )   ibondi(iiwe,ijwe) = 1   ! this w neigbour had both, e-w neighbours -> keep w neigbour
477         ENDIF
478      END DO
479
480      ! 5. Subdomain print
481      ! ------------------
482      IF(lwp) THEN
483         ifreq = 4
484         il1 = 1
485         DO jn = 1, (jpni-1)/ifreq+1
486            il2 = MIN(jpni,il1+ifreq-1)
487            WRITE(numout,*)
488            WRITE(numout,9400) ('***',ji=il1,il2-1)
489            DO jj = jpnj, 1, -1
490               WRITE(numout,9403) ('   ',ji=il1,il2-1)
491               WRITE(numout,9402) jj, (ijpi(ji,jj),ijpj(ji,jj),ji=il1,il2)
492               WRITE(numout,9404) (ipproc(ji,jj),ji=il1,il2)
493               WRITE(numout,9403) ('   ',ji=il1,il2-1)
494               WRITE(numout,9400) ('***',ji=il1,il2-1)
495            END DO
496            WRITE(numout,9401) (ji,ji=il1,il2)
497            il1 = il1+ifreq
498         END DO
499 9400    FORMAT('           ***'   ,20('*************',a3)    )
500 9403    FORMAT('           *     ',20('         *   ',a3)    )
501 9401    FORMAT('              '   ,20('   ',i3,'          ') )
502 9402    FORMAT('       ',i3,' *  ',20(i3,'  x',i3,'   *   ') )
503 9404    FORMAT('           *  '   ,20('     ' ,i4,'   *   ') )
504      ENDIF
505
506      ! just to save nono etc for all proc
507      ! warning ii*ij (zone) /= mpprank (processors)!
508      ! ioso = zone number, ii_noso = proc number
509      ii_noso(:) = -1
510      ii_nono(:) = -1
511      ii_noea(:) = -1
512      ii_nowe(:) = -1
513      DO jproc = 1, jpnij
514         ii = iin(jproc)
515         ij = ijn(jproc)
516         IF( 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN
517            iiso = 1 + MOD( ioso(ii,ij) , jpni )
518            ijso = 1 +      ioso(ii,ij) / jpni
519            ii_noso(jproc) = ipproc(iiso,ijso)
520         ENDIF
521         IF( 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= (jpni*jpnj-1) ) THEN
522          iiwe = 1 + MOD( iowe(ii,ij) , jpni )
523          ijwe = 1 +      iowe(ii,ij) / jpni
524          ii_nowe(jproc) = ipproc(iiwe,ijwe)
525         ENDIF
526         IF( 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= (jpni*jpnj-1) ) THEN
527            iiea = 1 + MOD( ioea(ii,ij) , jpni )
528            ijea = 1 +      ioea(ii,ij) / jpni
529            ii_noea(jproc)= ipproc(iiea,ijea)
530         ENDIF
531         IF( 0 <= iono(ii,ij) .AND. iono(ii,ij) <= (jpni*jpnj-1) ) THEN
532            iino = 1 + MOD( iono(ii,ij) , jpni )
533            ijno = 1 +      iono(ii,ij) / jpni
534            ii_nono(jproc)= ipproc(iino,ijno)
535         ENDIF
536      END DO
537
538      ! 6. Change processor name
539      ! ------------------------
540      ii = iin(narea)
541      ij = ijn(narea)
542      !
543      jpi    = ijpi(ii,ij)
544!!$      Nis0  = iis0(ii,ij)
545!!$      Nie0  = iie0(ii,ij)
546      jpj    = ijpj(ii,ij)
547!!$      Njs0  = ijs0(ii,ij)
548!!$      Nje0  = ije0(ii,ij)
549      nbondi = ibondi(ii,ij)
550      nbondj = ibondj(ii,ij)
551      nimpp = iimppt(ii,ij)
552      njmpp = ijmppt(ii,ij)
553      jpk = jpkglo                              ! third dim
554
555      ! set default neighbours
556      noso = ii_noso(narea)
557      nowe = ii_nowe(narea)
558      noea = ii_noea(narea)
559      nono = ii_nono(narea)
560
561      nones = -1
562      nonws = -1
563      noses = -1
564      nosws = -1
565
566      noner = -1
567      nonwr = -1
568      noser = -1
569      noswr = -1
570
571      IF((nbondi .eq. -1) .or. (nbondi .eq. 0)) THEN ! east neighbour exists
572         IF(ibondj(iin(noea+1),ijn(noea+1)) .eq. 0) THEN
573            nones = ii_nono(noea+1)                  ! east neighbour has north and south neighbours
574            noses = ii_noso(noea+1)
575         ELSEIF(ibondj(iin(noea+1),ijn(noea+1)) .eq. -1) THEN
576            nones = ii_nono(noea+1)                  ! east neighbour has north neighbour
577         ELSEIF(ibondj(iin(noea+1),ijn(noea+1)) .eq. 1) THEN
578            noses = ii_noso(noea+1)                  ! east neighbour has south neighbour
579         END IF
580      END IF
581      IF((nbondi .eq. 1) .or. (nbondi .eq. 0)) THEN  ! west neighbour exists
582         IF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. 0) THEN
583            nonws = ii_nono(nowe+1)                  ! west neighbour has north and south neighbours
584            nosws = ii_noso(nowe+1)
585         ELSEIF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. -1) THEN
586            nonws = ii_nono(nowe+1)                  ! west neighbour has north neighbour
587         ELSEIF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. 1)  THEN
588            nosws = ii_noso(nowe+1)                  ! west neighbour has north neighbour
589         END IF
590      END IF
591
592      IF((nbondj .eq. -1) .or. (nbondj .eq. 0)) THEN ! north neighbour exists
593         IF(ibondi(iin(nono+1),ijn(nono+1)) .eq. 0) THEN
594            noner = ii_noea(nono+1)                  ! north neighbour has east and west neighbours
595            nonwr = ii_nowe(nono+1)
596         ELSEIF(ibondi(iin(nono+1),ijn(nono+1)) .eq. -1) THEN
597            noner = ii_noea(nono+1)                  ! north neighbour has east neighbour
598         ELSEIF(ibondi(iin(nono+1),ijn(nono+1)) .eq. 1) THEN
599            nonwr = ii_nowe(nono+1)                  ! north neighbour has west neighbour
600         END IF
601      END IF
602      IF((nbondj .eq. 1) .or. (nbondj .eq. 0)) THEN  ! south neighbour exists
603         IF(ibondi(iin(noso+1),ijn(noso+1)) .eq. 0) THEN
604            noser = ii_noea(noso+1)                  ! south neighbour has east and west neighbours
605            noswr = ii_nowe(noso+1)
606         ELSEIF(ibondi(iin(noso+1),ijn(noso+1)) .eq. -1) THEN
607            noser = ii_noea(noso+1)                  ! south neighbour has east neighbour
608         ELSEIF(ibondi(iin(noso+1),ijn(noso+1)) .eq. 1) THEN
609            noswr = ii_nowe(noso+1)                  ! south neighbour has west neighbour
610         END IF
611      END IF
612
613      !
614      CALL init_doloop                          ! set start/end indices of do-loop, depending on the halo width value (nn_hls)
615      !
616      jpim1 = jpi-1                             ! inner domain indices
617      jpjm1 = jpj-1                             !   "           "
618      jpkm1 = MAX( 1, jpk-1 )                   !   "           "
619      jpij  = jpi*jpj                           !  jpi x j
620      DO jproc = 1, jpnij
621         ii = iin(jproc)
622         ij = ijn(jproc)
623         jpiall (jproc) = ijpi(ii,ij)
624         nis0all(jproc) = iis0(ii,ij)
625         nie0all(jproc) = iie0(ii,ij)
626         jpjall (jproc) = ijpj(ii,ij)
627         njs0all(jproc) = ijs0(ii,ij)
628         nje0all(jproc) = ije0(ii,ij)
629         ibonit(jproc) = ibondi(ii,ij)
630         ibonjt(jproc) = ibondj(ii,ij)
631         nimppt(jproc) = iimppt(ii,ij)
632         njmppt(jproc) = ijmppt(ii,ij)
633      END DO
634
635      ! Save processor layout in ascii file
636      IF (llwrtlay) THEN
637         CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea )
638         WRITE(inum,'(a)') '   jpnij   jpimax  jpjmax    jpk  jpiglo  jpjglo'//&
639   &           ' ( local:    narea     jpi     jpj )'
640         WRITE(inum,'(6i8,a,3i8,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,&
641   &           ' ( local: ',narea,jpi,jpj,' )'
642         WRITE(inum,'(a)') 'narea   jpi  jpj Nis0 Njs0 Nie0 Nje0 nimp njmp nono noso nowe noea nbondi nbondj '
643
644         DO jproc = 1, jpnij
645            WRITE(inum,'(13i5,2i7)')     jproc,  jpiall(jproc),  jpjall(jproc),   &
646               &                                nis0all(jproc), njs0all(jproc),   &
647               &                                nie0all(jproc), nje0all(jproc),   &
648               &                                nimppt (jproc), njmppt (jproc),   &
649               &                                ii_nono(jproc), ii_noso(jproc),   &
650               &                                ii_nowe(jproc), ii_noea(jproc),   &
651               &                                ibonit (jproc), ibonjt (jproc)
652         END DO
653      END IF
654
655      !                          ! north fold parameter
656      ! Defined npolj, either 0, 3 , 4 , 5 , 6
657      ! In this case the important thing is that npolj /= 0
658      ! Because if we go through these line it is because jpni >1 and thus
659      ! we must use lbcnorthmpp, which tests only npolj =0 or npolj /= 0
660      npolj = 0
661      ij = ijn(narea)
662      IF( jperio == 3 .OR. jperio == 4 ) THEN
663         IF( ij == jpnj )   npolj = 3
664      ENDIF
665      IF( jperio == 5 .OR. jperio == 6 ) THEN
666         IF( ij == jpnj )   npolj = 5
667      ENDIF
668      !
669      IF(lwp) THEN
670         WRITE(numout,*)
671         WRITE(numout,*) '   resulting internal parameters : '
672         WRITE(numout,*) '      narea  = ', narea
673         WRITE(numout,*) '      nowe   = ', nowe  , '   noea  =  ', noea
674         WRITE(numout,*) '      nono   = ', nono  , '   noso  =  ', noso
675         WRITE(numout,*) '      nbondi = ', nbondi
676         WRITE(numout,*) '      nbondj = ', nbondj
677         WRITE(numout,*) '      npolj  = ', npolj
678         WRITE(numout,*) '    l_Iperio = ', l_Iperio
679         WRITE(numout,*) '    l_Jperio = ', l_Jperio
680         WRITE(numout,*) '      nimpp  = ', nimpp
681         WRITE(numout,*) '      njmpp  = ', njmpp
682      ENDIF
683
684      !                          ! Prepare mpp north fold
685      IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN
686         CALL mpp_ini_north
687         IF (lwp) THEN
688            WRITE(numout,*)
689            WRITE(numout,*) '   ==>>>   North fold boundary prepared for jpni >1'
690            ! additional prints in layout.dat
691         ENDIF
692         IF (llwrtlay) THEN
693            WRITE(inum,*)
694            WRITE(inum,*)
695            WRITE(inum,*) 'number of subdomains located along the north fold : ', ndim_rank_north
696            WRITE(inum,*) 'Rank of the subdomains located along the north fold : ', ndim_rank_north
697            DO jproc = 1, ndim_rank_north, 5
698               WRITE(inum,*) nrank_north( jproc:MINVAL( (/jproc+4,ndim_rank_north/) ) )
699            END DO
700         ENDIF
701      ENDIF
702
703      !
704      CALL mpp_ini_nc        ! Initialize communicator for neighbourhood collective communications
705      !
706      CALL init_ioipsl       ! Prepare NetCDF output file (if necessary)
707      !
708      IF (( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ).AND.( ln_nnogather )) THEN
709         CALL init_nfdcom     ! northfold neighbour lists
710         IF (llwrtlay) THEN
711            WRITE(inum,*)
712            WRITE(inum,*)
713            WRITE(inum,*) 'north fold exchanges with explicit point-to-point messaging :'
714            WRITE(inum,*) 'nsndto : ', nsndto
715            WRITE(inum,*) 'isendto : ', isendto
716         ENDIF
717      ENDIF
718      !
719      IF (llwrtlay) CLOSE(inum)
720      !
721      DEALLOCATE(iin, ijn, ii_nono, ii_noea, ii_noso, ii_nowe,    &
722         &       iimppt, ijmppt, ibondi, ibondj, ipproc, ipolj,   &
723         &       ijpi, ijpj, iie0, ije0, iis0, ijs0,              &
724         &       iono, ioea, ioso, iowe, llisoce)
725      !
726    END SUBROUTINE mpp_init
727
728#endif
729
730    SUBROUTINE mpp_basesplit( kiglo, kjglo, khls, knbi, knbj, kimax, kjmax, kimppt, kjmppt, klci, klcj)
731      !!----------------------------------------------------------------------
732      !!                  ***  ROUTINE mpp_basesplit  ***
733      !!
734      !! ** Purpose :   Lay out the global domain over processors.
735      !!
736      !! ** Method  :   Global domain is distributed in smaller local domains.
737      !!
738      !! ** Action : - set for all knbi*knbj domains:
739      !!                    kimppt     : longitudinal index
740      !!                    kjmppt     : latitudinal  index
741      !!                    klci       : first dimension
742      !!                    klcj       : second dimension
743      !!----------------------------------------------------------------------
744      INTEGER,                                 INTENT(in   ) ::   kiglo, kjglo
745      INTEGER,                                 INTENT(in   ) ::   khls
746      INTEGER,                                 INTENT(in   ) ::   knbi, knbj
747      INTEGER,                                 INTENT(  out) ::   kimax, kjmax
748      INTEGER, DIMENSION(knbi,knbj), OPTIONAL, INTENT(  out) ::   kimppt, kjmppt
749      INTEGER, DIMENSION(knbi,knbj), OPTIONAL, INTENT(  out) ::   klci, klcj
750      !
751      INTEGER ::   ji, jj
752      INTEGER ::   i2hls
753      INTEGER ::   iresti, irestj, irm, ijpjmin
754      !!----------------------------------------------------------------------
755      i2hls = 2*khls
756      !
757#if defined key_nemocice_decomp
758      kimax = ( nx_global+2-i2hls + (knbi-1) ) / knbi + i2hls    ! first  dim.
759      kjmax = ( ny_global+2-i2hls + (knbj-1) ) / knbj + i2hls    ! second dim.
760#else
761      kimax = ( kiglo - i2hls + (knbi-1) ) / knbi + i2hls    ! first  dim.
762      kjmax = ( kjglo - i2hls + (knbj-1) ) / knbj + i2hls    ! second dim.
763#endif
764      IF( .NOT. PRESENT(kimppt) ) RETURN
765      !
766      !  1. Dimension arrays for subdomains
767      ! -----------------------------------
768      !  Computation of local domain sizes klci() klcj()
769      !  These dimensions depend on global sizes knbi,knbj and kiglo,kjglo
770      !  The subdomains are squares lesser than or equal to the global
771      !  dimensions divided by the number of processors minus the overlap array.
772      !
773      iresti = 1 + MOD( kiglo - i2hls - 1 , knbi )
774      irestj = 1 + MOD( kjglo - i2hls - 1 , knbj )
775      !
776      !  Need to use kimax and kjmax here since jpi and jpj not yet defined
777#if defined key_nemocice_decomp
778      ! Change padding to be consistent with CICE
779      klci(1:knbi-1,:       ) = kimax
780      klci(  knbi  ,:       ) = kiglo - (knbi - 1) * (kimax - i2hls)
781      klcj(:       ,1:knbj-1) = kjmax
782      klcj(:       ,  knbj  ) = kjglo - (knbj - 1) * (kjmax - i2hls)
783#else
784      klci(1:iresti      ,:) = kimax
785      klci(iresti+1:knbi ,:) = kimax-1
786      IF( MINVAL(klci) < 2*i2hls ) THEN
787         WRITE(ctmp1,*) '   mpp_basesplit: minimum value of jpi must be >= ', 2*i2hls
788         WRITE(ctmp2,*) '   We have ', MINVAL(klci)
789        CALL ctl_stop( 'STOP', ctmp1, ctmp2 )
790      ENDIF
791      IF( jperio == 3 .OR. jperio == 4 .OR. jperio == 5 .OR. jperio == 6 ) THEN
792         ! minimize the size of the last row to compensate for the north pole folding coast
793         IF( jperio == 3 .OR. jperio == 4 )   ijpjmin = 2+3*khls   ! V and F folding must be outside of southern halos
794         IF( jperio == 5 .OR. jperio == 6 )   ijpjmin = 1+3*khls   ! V and F folding must be outside of southern halos
795         irm = knbj - irestj                                       ! total number of lines to be removed
796         klcj(:,knbj) = MAX( ijpjmin, kjmax-irm )                  ! we must have jpj >= ijpjmin in the last row
797         irm = irm - ( kjmax - klcj(1,knbj) )                      ! remaining number of lines to remove
798         irestj = knbj - 1 - irm
799         klcj(:, irestj+1:knbj-1) = kjmax-1
800      ELSE
801         klcj(:, irestj+1:knbj  ) = kjmax-1
802      ENDIF
803      klcj(:,1:irestj) = kjmax
804      IF( MINVAL(klcj) < 2*i2hls ) THEN
805         WRITE(ctmp1,*) '   mpp_basesplit: minimum value of jpj must be >= ', 2*i2hls
806         WRITE(ctmp2,*) '   We have ', MINVAL(klcj)
807         CALL ctl_stop( 'STOP', ctmp1, ctmp2 )
808      ENDIF
809#endif
810
811      !  2. Index arrays for subdomains
812      ! -------------------------------
813      kimppt(:,:) = 1
814      kjmppt(:,:) = 1
815      !
816      IF( knbi > 1 ) THEN
817         DO jj = 1, knbj
818            DO ji = 2, knbi
819               kimppt(ji,jj) = kimppt(ji-1,jj) + klci(ji-1,jj) - i2hls
820            END DO
821         END DO
822      ENDIF
823      !
824      IF( knbj > 1 )THEN
825         DO jj = 2, knbj
826            DO ji = 1, knbi
827               kjmppt(ji,jj) = kjmppt(ji,jj-1) + klcj(ji,jj-1) - i2hls
828            END DO
829         END DO
830      ENDIF
831
832   END SUBROUTINE mpp_basesplit
833
834
835   SUBROUTINE bestpartition( knbij, knbi, knbj, knbcnt, ldlist )
836      !!----------------------------------------------------------------------
837      !!                 ***  ROUTINE bestpartition  ***
838      !!
839      !! ** Purpose :
840      !!
841      !! ** Method  :
842      !!----------------------------------------------------------------------
843      INTEGER,           INTENT(in   ) ::   knbij         ! total number of subdomains (knbi*knbj)
844      INTEGER, OPTIONAL, INTENT(  out) ::   knbi, knbj    ! number if subdomains along i and j (knbi and knbj)
845      INTEGER, OPTIONAL, INTENT(  out) ::   knbcnt        ! number of land subdomains
846      LOGICAL, OPTIONAL, INTENT(in   ) ::   ldlist        ! .true.: print the list the best domain decompositions (with land)
847      !
848      INTEGER :: ji, jj, ii, iitarget
849      INTEGER :: iszitst, iszjtst
850      INTEGER :: isziref, iszjref
851      INTEGER :: iszimin, iszjmin
852      INTEGER :: inbij, iszij
853      INTEGER :: inbimax, inbjmax, inbijmax, inbijold
854      INTEGER :: isz0, isz1
855      INTEGER, DIMENSION(  :), ALLOCATABLE :: indexok
856      INTEGER, DIMENSION(  :), ALLOCATABLE :: inbi0, inbj0, inbij0   ! number of subdomains along i,j
857      INTEGER, DIMENSION(  :), ALLOCATABLE :: iszi0, iszj0, iszij0   ! max size of the subdomains along i,j
858      INTEGER, DIMENSION(  :), ALLOCATABLE :: inbi1, inbj1, inbij1   ! number of subdomains along i,j
859      INTEGER, DIMENSION(  :), ALLOCATABLE :: iszi1, iszj1, iszij1   ! max size of the subdomains along i,j
860      LOGICAL :: llist
861      LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llmsk2d                 ! max size of the subdomains along i,j
862      LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llisoce              !  -     -
863      REAL(wp)::   zpropland
864      !!----------------------------------------------------------------------
865      !
866      llist = .FALSE.
867      IF( PRESENT(ldlist) ) llist = ldlist
868
869      CALL mpp_init_landprop( zpropland )                      ! get the proportion of land point over the gloal domain
870      inbij = NINT( REAL(knbij, wp) / ( 1.0 - zpropland ) )    ! define the largest possible value for jpni*jpnj
871      !
872      IF( llist ) THEN   ;   inbijmax = inbij*2
873      ELSE               ;   inbijmax = inbij
874      ENDIF
875      !
876      ALLOCATE(inbi0(inbijmax),inbj0(inbijmax),iszi0(inbijmax),iszj0(inbijmax))
877      !
878      inbimax = 0
879      inbjmax = 0
880      isziref = jpiglo*jpjglo+1   ! define a value that is larger than the largest possible
881      iszjref = jpiglo*jpjglo+1
882      !
883      iszimin = 4*nn_hls          ! minimum size of the MPI subdomain so halos are always adressing neighbor inner domain
884      iszjmin = 4*nn_hls
885      IF( jperio == 3 .OR. jperio == 4 )   iszjmin = MAX(iszjmin, 2+3*nn_hls)   ! V and F folding must be outside of southern halos
886      IF( jperio == 5 .OR. jperio == 6 )   iszjmin = MAX(iszjmin, 1+3*nn_hls)   ! V and F folding must be outside of southern halos
887      !
888      ! get the list of knbi that gives a smaller jpimax than knbi-1
889      ! get the list of knbj that gives a smaller jpjmax than knbj-1
890      DO ji = 1, inbijmax
891#if defined key_nemocice_decomp
892         iszitst = ( nx_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls    ! first  dim.
893#else
894         iszitst = ( Ni0glo + (ji-1) ) / ji + 2*nn_hls   ! max subdomain i-size
895#endif
896         IF( iszitst < isziref .AND. iszitst >= iszimin ) THEN
897            isziref = iszitst
898            inbimax = inbimax + 1
899            inbi0(inbimax) = ji
900            iszi0(inbimax) = isziref
901         ENDIF
902#if defined key_nemocice_decomp
903         iszjtst = ( ny_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls    ! first  dim.
904#else
905         iszjtst = ( Nj0glo + (ji-1) ) / ji + 2*nn_hls   ! max subdomain j-size
906#endif
907         IF( iszjtst < iszjref .AND. iszjtst >= iszjmin ) THEN
908            iszjref = iszjtst
909            inbjmax = inbjmax + 1
910            inbj0(inbjmax) = ji
911            iszj0(inbjmax) = iszjref
912         ENDIF
913      END DO
914
915      ! combine these 2 lists to get all possible knbi*knbj <  inbijmax
916      ALLOCATE( llmsk2d(inbimax,inbjmax) )
917      DO jj = 1, inbjmax
918         DO ji = 1, inbimax
919            IF ( inbi0(ji) * inbj0(jj) <= inbijmax ) THEN   ;   llmsk2d(ji,jj) = .TRUE.
920            ELSE                                            ;   llmsk2d(ji,jj) = .FALSE.
921            ENDIF
922         END DO
923      END DO
924      isz1 = COUNT(llmsk2d)
925      ALLOCATE( inbi1(isz1), inbj1(isz1), iszi1(isz1), iszj1(isz1) )
926      ii = 0
927      DO jj = 1, inbjmax
928         DO ji = 1, inbimax
929            IF( llmsk2d(ji,jj) .EQV. .TRUE. ) THEN
930               ii = ii + 1
931               inbi1(ii) = inbi0(ji)
932               inbj1(ii) = inbj0(jj)
933               iszi1(ii) = iszi0(ji)
934               iszj1(ii) = iszj0(jj)
935            END IF
936         END DO
937      END DO
938      DEALLOCATE( inbi0, inbj0, iszi0, iszj0 )
939      DEALLOCATE( llmsk2d )
940
941      ALLOCATE( inbij1(isz1), iszij1(isz1) )
942      inbij1(:) = inbi1(:) * inbj1(:)
943      iszij1(:) = iszi1(:) * iszj1(:)
944
945      ! if there is no land and no print
946      IF( .NOT. llist .AND. numbot == -1 .AND. numbdy == -1 ) THEN
947         ! get the smaller partition which gives the smallest subdomain size
948         ii = MINLOC(inbij1, mask = iszij1 == MINVAL(iszij1), dim = 1)
949         knbi = inbi1(ii)
950         knbj = inbj1(ii)
951         IF(PRESENT(knbcnt))   knbcnt = 0
952         DEALLOCATE( inbi1, inbj1, inbij1, iszi1, iszj1, iszij1 )
953         RETURN
954      ENDIF
955
956      ! extract only the partitions which reduce the subdomain size in comparison with smaller partitions
957      ALLOCATE( indexok(isz1) )                                 ! to store indices of the best partitions
958      isz0 = 0                                                  ! number of best partitions
959      inbij = 1                                                 ! start with the min value of inbij1 => 1
960      iszij = jpiglo*jpjglo+1                                   ! default: larger than global domain
961      DO WHILE( inbij <= inbijmax )                             ! if we did not reach the max of inbij1
962         ii = MINLOC(iszij1, mask = inbij1 == inbij, dim = 1)   ! warning: send back the first occurence if multiple results
963         IF ( iszij1(ii) < iszij ) THEN
964            ii = MINLOC( iszi1+iszj1, mask = iszij1 == iszij1(ii) .AND. inbij1 == inbij, dim = 1)  ! select the smaller perimeter if multiple min
965            isz0 = isz0 + 1
966            indexok(isz0) = ii
967            iszij = iszij1(ii)
968         ENDIF
969         inbij = MINVAL(inbij1, mask = inbij1 > inbij)   ! warning: return largest integer value if mask = .false. everywhere
970      END DO
971      DEALLOCATE( inbij1, iszij1 )
972
973      ! keep only the best partitions (sorted by increasing order of subdomains number and decreassing subdomain size)
974      ALLOCATE( inbi0(isz0), inbj0(isz0), iszi0(isz0), iszj0(isz0) )
975      DO ji = 1, isz0
976         ii = indexok(ji)
977         inbi0(ji) = inbi1(ii)
978         inbj0(ji) = inbj1(ii)
979         iszi0(ji) = iszi1(ii)
980         iszj0(ji) = iszj1(ii)
981      END DO
982      DEALLOCATE( indexok, inbi1, inbj1, iszi1, iszj1 )
983
984      IF( llist ) THEN
985         IF(lwp) THEN
986            WRITE(numout,*)
987            WRITE(numout,*) '                  For your information:'
988            WRITE(numout,*) '  list of the best partitions including land supression'
989            WRITE(numout,*) '  -----------------------------------------------------'
990            WRITE(numout,*)
991         END IF
992         ji = isz0   ! initialization with the largest value
993         ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) )
994         CALL mpp_is_ocean( llisoce )   ! Warning: must be call by all cores (call mpp_sum)
995         inbijold = COUNT(llisoce)
996         DEALLOCATE( llisoce )
997         DO ji =isz0-1,1,-1
998            ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) )
999            CALL mpp_is_ocean( llisoce )   ! Warning: must be call by all cores (call mpp_sum)
1000            inbij = COUNT(llisoce)
1001            DEALLOCATE( llisoce )
1002            IF(lwp .AND. inbij < inbijold) THEN
1003               WRITE(numout,'(a, i6, a, i6, a, f4.1, a, i9, a, i6, a, i6, a)')                                 &
1004                  &   'nb_cores oce: ', inbij, ', land domains excluded: ', inbi0(ji)*inbj0(ji) - inbij,       &
1005                  &   ' (', REAL(inbi0(ji)*inbj0(ji) - inbij,wp) / REAL(inbi0(ji)*inbj0(ji),wp) *100.,         &
1006                  &   '%), largest oce domain: ', iszi0(ji)*iszj0(ji), ' ( ', iszi0(ji),' x ', iszj0(ji), ' )'
1007               inbijold = inbij
1008            END IF
1009         END DO
1010         DEALLOCATE( inbi0, inbj0, iszi0, iszj0 )
1011         IF(lwp) THEN
1012            WRITE(numout,*)
1013            WRITE(numout,*)  '  -----------------------------------------------------------'
1014         ENDIF
1015         CALL mppsync
1016         CALL mppstop( ld_abort = .TRUE. )
1017      ENDIF
1018
1019      DEALLOCATE( iszi0, iszj0 )
1020      inbij = inbijmax + 1        ! default: larger than possible
1021      ii = isz0+1                 ! start from the end of the list (smaller subdomains)
1022      DO WHILE( inbij > knbij )   ! while the number of ocean subdomains exceed the number of procs
1023         ii = ii -1
1024         ALLOCATE( llisoce(inbi0(ii), inbj0(ii)) )
1025         CALL mpp_is_ocean( llisoce )            ! must be done by all core
1026         inbij = COUNT(llisoce)
1027         DEALLOCATE( llisoce )
1028      END DO
1029      knbi = inbi0(ii)
1030      knbj = inbj0(ii)
1031      IF(PRESENT(knbcnt))   knbcnt = knbi * knbj - inbij
1032      DEALLOCATE( inbi0, inbj0 )
1033      !
1034   END SUBROUTINE bestpartition
1035
1036
1037   SUBROUTINE mpp_init_landprop( propland )
1038      !!----------------------------------------------------------------------
1039      !!                  ***  ROUTINE mpp_init_landprop  ***
1040      !!
1041      !! ** Purpose : the the proportion of land points in the surface land-sea mask
1042      !!
1043      !! ** Method  : read iproc strips (of length Ni0glo) of the land-sea mask
1044      !!----------------------------------------------------------------------
1045      REAL(wp), INTENT(  out) :: propland    ! proportion of land points in the global domain (between 0 and 1)
1046      !
1047      INTEGER, DIMENSION(jpni*jpnj) ::   kusedom_1d
1048      INTEGER :: inboce, iarea
1049      INTEGER :: iproc, idiv, ijsz
1050      INTEGER :: ijstr
1051      LOGICAL, ALLOCATABLE, DIMENSION(:,:) ::   lloce
1052      !!----------------------------------------------------------------------
1053      ! do nothing if there is no land-sea mask
1054      IF( numbot == -1 .and. numbdy == -1 ) THEN
1055         propland = 0.
1056         RETURN
1057      ENDIF
1058
1059      ! number of processes reading the bathymetry file
1060      iproc = MINVAL( (/mppsize, Nj0glo/2, 100/) )  ! read a least 2 lines, no more that 100 processes reading at the same time
1061
1062      ! we want to read iproc strips of the land-sea mask. -> pick up iproc processes every idiv processes starting at 1
1063      IF( iproc == 1 ) THEN   ;   idiv = mppsize
1064      ELSE                    ;   idiv = ( mppsize - 1 ) / ( iproc - 1 )
1065      ENDIF
1066
1067      iarea = (narea-1)/idiv   ! involed process number (starting counting at 0)
1068      IF( MOD( narea-1, idiv ) == 0 .AND. iarea < iproc ) THEN   ! beware idiv can be = to 1
1069         !
1070         ijsz = Nj0glo / iproc                                               ! width of the stripe to read
1071         IF( iarea < MOD(Nj0glo,iproc) ) ijsz = ijsz + 1
1072         ijstr = iarea*(Nj0glo/iproc) + MIN(iarea, MOD(Nj0glo,iproc)) + 1    ! starting j position of the reading
1073         !
1074         ALLOCATE( lloce(Ni0glo, ijsz) )                                     ! allocate the strip
1075         CALL readbot_strip( ijstr, ijsz, lloce )
1076         inboce = COUNT(lloce)                                               ! number of ocean point in the stripe
1077         DEALLOCATE(lloce)
1078         !
1079      ELSE
1080         inboce = 0
1081      ENDIF
1082      CALL mpp_sum( 'mppini', inboce )   ! total number of ocean points over the global domain
1083      !
1084      propland = REAL( Ni0glo*Nj0glo - inboce, wp ) / REAL( Ni0glo*Nj0glo, wp )
1085      !
1086   END SUBROUTINE mpp_init_landprop
1087
1088
1089   SUBROUTINE mpp_is_ocean( ldisoce )
1090      !!----------------------------------------------------------------------
1091      !!                  ***  ROUTINE mpp_is_ocean  ***
1092      !!
1093      !! ** Purpose : Check for a mpi domain decomposition inbi x inbj which
1094      !!              subdomains, including 1 halo (even if nn_hls>1), contain
1095      !!              at least 1 ocean point.
1096      !!              We must indeed ensure that each subdomain that is a neighbour
1097      !!              of a land subdomain as only land points on its boundary
1098      !!              (inside the inner subdomain) with the land subdomain.
1099      !!              This is needed to get the proper bondary conditions on
1100      !!              a subdomain with a closed boundary.
1101      !!
1102      !! ** Method  : read inbj strips (of length Ni0glo) of the land-sea mask
1103      !!----------------------------------------------------------------------
1104      LOGICAL, DIMENSION(:,:), INTENT(  out) ::   ldisoce        ! .true. if a sub domain constains 1 ocean point
1105      !
1106      INTEGER :: idiv, iimax, ijmax, iarea
1107      INTEGER :: inbi, inbj, inx, iny, inry, isty
1108      INTEGER :: ji, jn
1109      INTEGER, ALLOCATABLE, DIMENSION(:,:) ::   inboce           ! number oce oce pint in each mpi subdomain
1110      INTEGER, ALLOCATABLE, DIMENSION(:  ) ::   inboce_1d
1111      INTEGER, ALLOCATABLE, DIMENSION(:,:) ::   iimppt, ijpi
1112      INTEGER, ALLOCATABLE, DIMENSION(:,:) ::   ijmppt, ijpj
1113      LOGICAL, ALLOCATABLE, DIMENSION(:,:) ::   lloce            ! lloce(i,j) = .true. if the point (i,j) is ocean
1114      !!----------------------------------------------------------------------
1115      ! do nothing if there is no land-sea mask
1116      IF( numbot == -1 .AND. numbdy == -1 ) THEN
1117         ldisoce(:,:) = .TRUE.
1118         RETURN
1119      ENDIF
1120      !
1121      inbi = SIZE( ldisoce, dim = 1 )
1122      inbj = SIZE( ldisoce, dim = 2 )
1123      !
1124      ! we want to read inbj strips of the land-sea mask. -> pick up inbj processes every idiv processes starting at 1
1125      IF           ( inbj == 1 ) THEN   ;   idiv = mppsize
1126      ELSE IF ( mppsize < inbj ) THEN   ;   idiv = 1
1127      ELSE                              ;   idiv = ( mppsize - 1 ) / ( inbj - 1 )
1128      ENDIF
1129      !
1130      ALLOCATE( inboce(inbi,inbj), inboce_1d(inbi*inbj) )
1131      inboce(:,:) = 0          ! default no ocean point found
1132      !
1133      DO jn = 0, (inbj-1)/mppsize   ! if mppsize < inbj : more strips than mpi processes (because of potential land domains)
1134         !
1135         iarea = (narea-1)/idiv + jn * mppsize + 1                     ! involed process number (starting counting at 1)
1136         IF( MOD( narea-1, idiv ) == 0 .AND. iarea <= inbj ) THEN      ! beware idiv can be = to 1
1137            !
1138            ALLOCATE( iimppt(inbi,inbj), ijmppt(inbi,inbj), ijpi(inbi,inbj), ijpj(inbi,inbj) )
1139            CALL mpp_basesplit( Ni0glo, Nj0glo, 0, inbi, inbj, iimax, ijmax, iimppt, ijmppt, ijpi, ijpj )
1140            !
1141            inx = Ni0glo + 2   ;   iny = ijpj(1,iarea) + 2             ! strip size + 1 halo on each direction (even if nn_hls>1)
1142            ALLOCATE( lloce(inx, iny) )                                ! allocate the strip
1143            inry = iny - COUNT( (/ iarea == 1, iarea == inbj /) )      ! number of point to read in y-direction
1144            isty = 1 + COUNT( (/ iarea == 1 /) )                       ! read from the first or the second line?
1145            CALL readbot_strip( ijmppt(1,iarea) - 2 + isty, inry, lloce(2:inx-1, isty:inry+isty-1) )   ! read the strip
1146            !
1147            IF( iarea == 1    ) THEN                                   ! the first line was not read
1148               IF( jperio == 2 .OR. jperio == 7 ) THEN                 !   north-south periodocity
1149                  CALL readbot_strip( Nj0glo, 1, lloce(2:inx-1, 1) )   !   read the last line -> first line of lloce
1150               ELSE
1151                  lloce(2:inx-1,  1) = .FALSE.                         !   closed boundary
1152               ENDIF
1153            ENDIF
1154            IF( iarea == inbj ) THEN                                   ! the last line was not read
1155               IF( jperio == 2 .OR. jperio == 7 ) THEN                 !   north-south periodocity
1156                  CALL readbot_strip( 1, 1, lloce(2:inx-1,iny) )       !      read the first line -> last line of lloce
1157               ELSEIF( jperio == 3 .OR. jperio == 4 ) THEN             !   north-pole folding T-pivot, T-point
1158                  lloce(2,iny) = lloce(2,iny-2)                        !      here we have 1 halo (even if nn_hls>1)
1159                  DO ji = 3,inx-1
1160                     lloce(ji,iny  ) = lloce(inx-ji+2,iny-2)           !      ok, we have at least 3 lines
1161                  END DO
1162                  DO ji = inx/2+2,inx-1
1163                     lloce(ji,iny-1) = lloce(inx-ji+2,iny-1)
1164                  END DO
1165               ELSEIF( jperio == 5 .OR. jperio == 6 ) THEN             !   north-pole folding F-pivot, T-point, 1 halo
1166                  lloce(inx/2+1,iny-1) = lloce(inx/2,iny-1)            !      here we have 1 halo (even if nn_hls>1)
1167                  lloce(inx  -1,iny-1) = lloce(2    ,iny-1)
1168                  DO ji = 2,inx-1
1169                     lloce(ji,iny) = lloce(inx-ji+1,iny-1)
1170                  END DO
1171               ELSE                                                    !   closed boundary
1172                  lloce(2:inx-1,iny) = .FALSE.
1173               ENDIF
1174            ENDIF
1175            !                                                          ! first and last column were not read
1176            IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 ) THEN
1177               lloce(1,:) = lloce(inx-1,:)   ;   lloce(inx,:) = lloce(2,:)   ! east-west periodocity
1178            ELSE
1179               lloce(1,:) = .FALSE.          ;   lloce(inx,:) = .FALSE.      ! closed boundary
1180            ENDIF
1181            !
1182            DO  ji = 1, inbi
1183               inboce(ji,iarea) = COUNT( lloce(iimppt(ji,1):iimppt(ji,1)+ijpi(ji,1)+1,:) )   ! lloce as 2 points more than Ni0glo
1184            END DO
1185            !
1186            DEALLOCATE(lloce)
1187            DEALLOCATE(iimppt, ijmppt, ijpi, ijpj)
1188            !
1189         ENDIF
1190      END DO
1191
1192      inboce_1d = RESHAPE(inboce, (/ inbi*inbj /))
1193      CALL mpp_sum( 'mppini', inboce_1d )
1194      inboce = RESHAPE(inboce_1d, (/inbi, inbj/))
1195      ldisoce(:,:) = inboce(:,:) /= 0
1196      DEALLOCATE(inboce, inboce_1d)
1197      !
1198   END SUBROUTINE mpp_is_ocean
1199
1200
1201   SUBROUTINE readbot_strip( kjstr, kjcnt, ldoce )
1202      !!----------------------------------------------------------------------
1203      !!                  ***  ROUTINE readbot_strip  ***
1204      !!
1205      !! ** Purpose : Read relevant bathymetric information in order to
1206      !!              provide a land/sea mask used for the elimination
1207      !!              of land domains, in an mpp computation.
1208      !!
1209      !! ** Method  : read stipe of size (Ni0glo,...)
1210      !!----------------------------------------------------------------------
1211      INTEGER                         , INTENT(in   ) ::   kjstr       ! starting j position of the reading
1212      INTEGER                         , INTENT(in   ) ::   kjcnt       ! number of lines to read
1213      LOGICAL, DIMENSION(Ni0glo,kjcnt), INTENT(  out) ::   ldoce       ! ldoce(i,j) = .true. if the point (i,j) is ocean
1214      !
1215      INTEGER                           ::   inumsave                ! local logical unit
1216      REAL(wp), DIMENSION(Ni0glo,kjcnt) ::   zbot, zbdy
1217      !!----------------------------------------------------------------------
1218      !
1219      inumsave = numout   ;   numout = numnul   !   redirect all print to /dev/null
1220      !
1221      IF( numbot /= -1 ) THEN
1222         CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/1,kjstr/), kcount = (/Ni0glo, kjcnt/) )
1223      ELSE
1224         zbot(:,:) = 1._wp                      ! put a non-null value
1225      ENDIF
1226      !
1227      IF( numbdy /= -1 ) THEN                   ! Adjust with bdy_msk if it exists
1228         CALL iom_get ( numbdy, jpdom_unknown,     'bdy_msk', zbdy, kstart = (/1,kjstr/), kcount = (/Ni0glo, kjcnt/) )
1229         zbot(:,:) = zbot(:,:) * zbdy(:,:)
1230      ENDIF
1231      !
1232      ldoce(:,:) = zbot(:,:) > 0._wp
1233      numout = inumsave
1234      !
1235   END SUBROUTINE readbot_strip
1236
1237
1238   SUBROUTINE mpp_getnum( ldisoce, kproc, kipos, kjpos )
1239      !!----------------------------------------------------------------------
1240      !!                  ***  ROUTINE mpp_getnum  ***
1241      !!
1242      !! ** Purpose : give a number to each MPI subdomains (starting at 0)
1243      !!
1244      !! ** Method  : start from bottom left. First skip land subdomain, and finally use them if needed
1245      !!----------------------------------------------------------------------
1246      LOGICAL, DIMENSION(:,:), INTENT(in   ) ::   ldisoce     ! F if land process
1247      INTEGER, DIMENSION(:,:), INTENT(  out) ::   kproc       ! subdomain number (-1 if supressed, starting at 0)
1248      INTEGER, DIMENSION(  :), INTENT(  out) ::   kipos       ! i-position of the subdomain (from 1 to jpni)
1249      INTEGER, DIMENSION(  :), INTENT(  out) ::   kjpos       ! j-position of the subdomain (from 1 to jpnj)
1250      !
1251      INTEGER :: ii, ij, jarea, iarea0
1252      INTEGER :: icont, i2add , ini, inj, inij
1253      !!----------------------------------------------------------------------
1254      !
1255      ini = SIZE(ldisoce, dim = 1)
1256      inj = SIZE(ldisoce, dim = 2)
1257      inij = SIZE(kipos)
1258      !
1259      ! specify which subdomains are oce subdomains; other are land subdomains
1260      kproc(:,:) = -1
1261      icont = -1
1262      DO jarea = 1, ini*inj
1263         iarea0 = jarea - 1
1264         ii = 1 + MOD(iarea0,ini)
1265         ij = 1 +     iarea0/ini
1266         IF( ldisoce(ii,ij) ) THEN
1267            icont = icont + 1
1268            kproc(ii,ij) = icont
1269            kipos(icont+1) = ii
1270            kjpos(icont+1) = ij
1271         ENDIF
1272      END DO
1273      ! if needed add some land subdomains to reach inij active subdomains
1274      i2add = inij - COUNT( ldisoce )
1275      DO jarea = 1, ini*inj
1276         iarea0 = jarea - 1
1277         ii = 1 + MOD(iarea0,ini)
1278         ij = 1 +     iarea0/ini
1279         IF( .NOT. ldisoce(ii,ij) .AND. i2add > 0 ) THEN
1280            icont = icont + 1
1281            kproc(ii,ij) = icont
1282            kipos(icont+1) = ii
1283            kjpos(icont+1) = ij
1284            i2add = i2add - 1
1285         ENDIF
1286      END DO
1287      !
1288   END SUBROUTINE mpp_getnum
1289
1290
1291   SUBROUTINE init_ioipsl
1292      !!----------------------------------------------------------------------
1293      !!                  ***  ROUTINE init_ioipsl  ***
1294      !!
1295      !! ** Purpose :
1296      !!
1297      !! ** Method  :
1298      !!
1299      !! History :
1300      !!   9.0  !  04-03  (G. Madec )  MPP-IOIPSL
1301      !!   " "  !  08-12  (A. Coward)  addition in case of jpni*jpnj < jpnij
1302      !!----------------------------------------------------------------------
1303      INTEGER, DIMENSION(2) ::   iglo, iloc, iabsf, iabsl, ihals, ihale, idid
1304      !!----------------------------------------------------------------------
1305
1306      ! The domain is split only horizontally along i- or/and j- direction
1307      ! So we need at the most only 1D arrays with 2 elements.
1308      ! Set idompar values equivalent to the jpdom_local_noextra definition
1309      ! used in IOM. This works even if jpnij .ne. jpni*jpnj.
1310      iglo( :) = (/ Ni0glo, Nj0glo /)
1311      iloc( :) = (/ Ni_0  , Nj_0   /)
1312      iabsf(:) = (/ Nis0  , Njs0   /) + (/ nimpp, njmpp /) - 1 - nn_hls   ! corresponds to mig0(Nis0) but mig0 is not yet defined!
1313      iabsl(:) = iabsf(:) + iloc(:) - 1
1314      ihals(:) = (/ 0     , 0      /)
1315      ihale(:) = (/ 0     , 0      /)
1316      idid( :) = (/ 1     , 2      /)
1317
1318      IF(lwp) THEN
1319          WRITE(numout,*)
1320          WRITE(numout,*) 'mpp init_ioipsl :   iloc  = ', iloc
1321          WRITE(numout,*) '~~~~~~~~~~~~~~~     iabsf = ', iabsf
1322          WRITE(numout,*) '                    ihals = ', ihals
1323          WRITE(numout,*) '                    ihale = ', ihale
1324      ENDIF
1325      !
1326      CALL flio_dom_set ( jpnij, narea-1, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom)
1327      !
1328   END SUBROUTINE init_ioipsl
1329
1330
1331   SUBROUTINE init_nfdcom
1332      !!----------------------------------------------------------------------
1333      !!                     ***  ROUTINE  init_nfdcom  ***
1334      !! ** Purpose :   Setup for north fold exchanges with explicit
1335      !!                point-to-point messaging
1336      !!
1337      !! ** Method :   Initialization of the northern neighbours lists.
1338      !!----------------------------------------------------------------------
1339      !!    1.0  ! 2011-10  (A. C. Coward, NOCS & J. Donners, PRACE)
1340      !!    2.0  ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S. Mocavero, CMCC)
1341      !!----------------------------------------------------------------------
1342      INTEGER  ::   sxM, dxM, sxT, dxT, jn
1343      !!----------------------------------------------------------------------
1344      !
1345      !initializes the north-fold communication variables
1346      isendto(:) = 0
1347      nsndto     = 0
1348      !
1349      IF ( njmpp == MAXVAL( njmppt ) ) THEN      ! if I am a process in the north
1350         !
1351         !sxM is the first point (in the global domain) needed to compute the north-fold for the current process
1352         sxM = jpiglo - nimppt(narea) - jpiall(narea) + 1
1353         !dxM is the last point (in the global domain) needed to compute the north-fold for the current process
1354         dxM = jpiglo - nimppt(narea) + 2
1355         !
1356         ! loop over the other north-fold processes to find the processes
1357         ! managing the points belonging to the sxT-dxT range
1358         !
1359         DO jn = 1, jpni
1360            !
1361            sxT = nfimpp(jn)                    ! sxT = 1st  point (in the global domain) of the jn process
1362            dxT = nfimpp(jn) + nfjpi(jn) - 1    ! dxT = last point (in the global domain) of the jn process
1363            !
1364            IF    ( sxT < sxM  .AND.  sxM < dxT ) THEN
1365               nsndto          = nsndto + 1
1366               isendto(nsndto) = jn
1367            ELSEIF( sxM <= sxT  .AND.  dxM >= dxT ) THEN
1368               nsndto          = nsndto + 1
1369               isendto(nsndto) = jn
1370            ELSEIF( dxM <  dxT  .AND.  sxT <  dxM ) THEN
1371               nsndto          = nsndto + 1
1372               isendto(nsndto) = jn
1373            ENDIF
1374            !
1375         END DO
1376         !
1377      ENDIF
1378      l_north_nogather = .TRUE.
1379      !
1380   END SUBROUTINE init_nfdcom
1381
1382
1383   SUBROUTINE init_doloop
1384      !!----------------------------------------------------------------------
1385      !!                  ***  ROUTINE init_doloop  ***
1386      !!
1387      !! ** Purpose :   set the starting/ending indices of DO-loop
1388      !!              These indices are used in do_loop_substitute.h90
1389      !!----------------------------------------------------------------------
1390      !
1391      Nis0 =   1+nn_hls   ;   Nis1 = Nis0-1   ;   Nis2 = MAX(  1, Nis0-2)
1392      Njs0 =   1+nn_hls   ;   Njs1 = Njs0-1   ;   Njs2 = MAX(  1, Njs0-2)
1393      !
1394      Nie0 = jpi-nn_hls   ;   Nie1 = Nie0+1   ;   Nie2 = MIN(jpi, Nie0+2)
1395      Nje0 = jpj-nn_hls   ;   Nje1 = Nje0+1   ;   Nje2 = MIN(jpj, Nje0+2)
1396      !
1397      IF( nn_hls == 1 ) THEN          !* halo size of 1
1398         !
1399         Nis1nxt2 = Nis0   ;   Njs1nxt2 = Njs0
1400         Nie1nxt2 = Nie0   ;   Nje1nxt2 = Nje0
1401         !
1402      ELSE                            !* larger halo size...
1403         !
1404         Nis1nxt2 = Nis1   ;   Njs1nxt2 = Njs1
1405         Nie1nxt2 = Nie1   ;   Nje1nxt2 = Nje1
1406         !
1407      ENDIF
1408      !
1409      Ni_0 = Nie0 - Nis0 + 1
1410      Nj_0 = Nje0 - Njs0 + 1
1411      Ni_1 = Nie1 - Nis1 + 1
1412      Nj_1 = Nje1 - Njs1 + 1
1413      Ni_2 = Nie2 - Nis2 + 1
1414      Nj_2 = Nje2 - Njs2 + 1
1415      !
1416   END SUBROUTINE init_doloop
1417
1418   !!======================================================================
1419END MODULE mppini
Note: See TracBrowser for help on using the repository browser.