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_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC – NEMO

source: NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/mppini.F90 @ 12760

Last change on this file since 12760 was 12760, checked in by smasson, 5 years ago

Extra_Halo: update do_loop_substitute for nn_hls=2, see #2366

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