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 utils/tools/DOMAINcfg/src – NEMO

Context Navigation

source: utils/tools/DOMAINcfg/src/mppini.F90 @ 14623

Last change on this file since 14623 was 14623, checked in by ldebreu, 3 years ago
AGFdomcfg: 1) Update DOMAINcfg to be compliant with the removal of halo cells 2) Update most of the LBC ... subroutines to a recent NEMO 4 version #2638
File size: 67.2 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: