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/branches/2020/dev_r13383_HPC-02_Daley_Tiling/src/OCE/LBC – NEMO

source: NEMO/branches/2020/dev_r13383_HPC-02_Daley_Tiling/src/OCE/LBC/mppini.F90 @ 13411

Last change on this file since 13411 was 13411, checked in by hadcv, 4 years ago

#2365: Fix some bugs with non-MPP and GYRE code

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