Context Navigation

mppini.F90 @ 9500

Last change on this file since 9500 was 9500, checked in by davestorkey, 6 years ago
branches/UKMO/dev_merge_2017_CICE_interface : recommit science changes.
File size: 37.8 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 mpp_init_nfdcom
11	!! 3. ! 2013-06 (I. Epicoco, S. Mocavero, CMCC) mpp_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	!! mpp_init_mask : Read global bathymetric information to facilitate land suppression
19	!! mpp_init_ioipsl : IOIPSL initialization in mpp
20	!! mpp_init_partition: Calculate MPP domain decomposition
21	!! factorise : Calculate the factors of the no. of MPI processes
22	!! mpp_init_nfdcom : Setup for north fold exchanges with explicit point-to-point messaging
23	!!----------------------------------------------------------------------
24	USE dom_oce ! ocean space and time domain
25	USE bdy_oce ! open BounDarY
26	!
27	USE lbcnfd , ONLY : isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges
28	USE lib_mpp ! distribued memory computing library
29	USE iom ! nemo I/O library
30	USE ioipsl ! I/O IPSL library
31	USE in_out_manager ! I/O Manager
32	#if defined key_nemocice_decomp
33	USE ice_domain_size, only: nx_global, ny_global
34	#endif
35
36	IMPLICIT NONE
37	PRIVATE
38
39	PUBLIC mpp_init ! called by opa.F90
40
41	!!----------------------------------------------------------------------
42	!! NEMO/OPA 4.0 , NEMO Consortium (2017)
43	!! $Id$
44	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
45	!!----------------------------------------------------------------------
46	CONTAINS
47
48	#if ! defined key_mpp_mpi
49	!!----------------------------------------------------------------------
50	!! Default option : shared memory computing
51	!!----------------------------------------------------------------------
52
53	SUBROUTINE mpp_init
54	!!----------------------------------------------------------------------
55	!! * ROUTINE mpp_init *
56	!!
57	!! ** Purpose : Lay out the global domain over processors.
58	!!
59	!! ** Method : Shared memory computing, set the local processor
60	!! variables to the value of the global domain
61	!!----------------------------------------------------------------------
62	!
63	jpimax = jpiglo
64	jpjmax = jpjglo
65	jpi = jpiglo
66	jpj = jpjglo
67	jpk = jpjglo
68	jpim1 = jpi-1 ! inner domain indices
69	jpjm1 = jpj-1 ! " "
70	jpkm1 = MAX( 1, jpk-1 ) ! " "
71	jpij = jpi*jpj
72	jpni = 1
73	jpnj = 1
74	jpnij = jpni*jpnj
75	nimpp = 1 !
76	njmpp = 1
77	nlci = jpi
78	nlcj = jpj
79	nldi = 1
80	nldj = 1
81	nlei = jpi
82	nlej = jpj
83	nperio = jperio
84	nbondi = 2
85	nbondj = 2
86	nidom = FLIO_DOM_NONE
87	npolj = jperio
88	!
89	IF(lwp) THEN
90	WRITE(numout,*)
91	WRITE(numout,*) 'mpp_init : NO massively parallel processing'
92	WRITE(numout,*) '~~~~~~~~ '
93	WRITE(numout,*) ' nperio = ', nperio, ' nimpp = ', nimpp
94	WRITE(numout,*) ' npolj = ', npolj , ' njmpp = ', njmpp
95	ENDIF
96	!
97	IF( jpni /= 1 .OR. jpnj /= 1 .OR. jpnij /= 1 ) &
98	CALL ctl_stop( 'mpp_init: equality jpni = jpnj = jpnij = 1 is not satisfied', &
99	& 'the domain is lay out for distributed memory computing!' )
100	!
101	IF( jperio == 7 ) CALL ctl_stop( 'mpp_init: jperio = 7 needs distributed memory computing ', &
102	& 'with 1 process. Add key_mpp_mpi in the list of active cpp keys ' )
103	!
104	END SUBROUTINE mpp_init
105
106	#else
107	!!----------------------------------------------------------------------
108	!! 'key_mpp_mpi' MPI massively parallel processing
109	!!----------------------------------------------------------------------
110
111
112	SUBROUTINE mpp_init
113	!!----------------------------------------------------------------------
114	!! * ROUTINE mpp_init *
115	!!
116	!! ** Purpose : Lay out the global domain over processors.
117	!! If land processors are to be eliminated, this program requires the
118	!! presence of the domain configuration file. Land processors elimination
119	!! is performed if jpni x jpnj /= jpnij. In this case, using the MPP_PREP
120	!! preprocessing tool, help for defining the best cutting out.
121	!!
122	!! ** Method : Global domain is distributed in smaller local domains.
123	!! Periodic condition is a function of the local domain position
124	!! (global boundary or neighbouring domain) and of the global
125	!! periodic
126	!! Type : jperio global periodic condition
127	!! nperio local periodic condition
128	!!
129	!! ** Action : - set domain parameters
130	!! nimpp : longitudinal index
131	!! njmpp : latitudinal index
132	!! nperio : lateral condition type
133	!! narea : number for local area
134	!! nlci : first dimension
135	!! nlcj : second dimension
136	!! nbondi : mark for "east-west local boundary"
137	!! nbondj : mark for "north-south local boundary"
138	!! nproc : number for local processor
139	!! noea : number for local neighboring processor
140	!! nowe : number for local neighboring processor
141	!! noso : number for local neighboring processor
142	!! nono : number for local neighboring processor
143	!!----------------------------------------------------------------------
144	INTEGER :: ji, jj, jn, jproc, jarea ! dummy loop indices
145	INTEGER :: inum ! local logical unit
146	INTEGER :: idir, ifreq, icont, isurf ! local integers
147	INTEGER :: ii, il1, ili, imil ! - -
148	INTEGER :: ij, il2, ilj, ijm1 ! - -
149	INTEGER :: iino, ijno, iiso, ijso ! - -
150	INTEGER :: iiea, ijea, iiwe, ijwe ! - -
151	INTEGER :: iresti, irestj, iproc ! - -
152	INTEGER :: ierr ! local logical unit
153	REAL(wp):: zidom, zjdom ! local scalars
154	INTEGER, ALLOCATABLE, DIMENSION(:) :: iin, ii_nono, ii_noea ! 1D workspace
155	INTEGER, ALLOCATABLE, DIMENSION(:) :: ijn, ii_noso, ii_nowe ! - -
156	INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ilci, ibondi, ipproc ! 2D workspace
157	INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ilcj, ibondj, ipolj ! - -
158	INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ilei, ildi, iono, ioea ! - -
159	INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ilej, ildj, ioso, iowe ! - -
160	INTEGER, DIMENSION(jpiglo,jpjglo) :: imask ! 2D global domain workspace
161	!!----------------------------------------------------------------------
162
163	! If dimensions of processor grid weren't specified in the namelist file
164	! then we calculate them here now that we have our communicator size
165	IF( jpni < 1 .OR. jpnj < 1 ) CALL mpp_init_partition( mppsize )
166	!
167	#if defined key_agrif
168	IF( jpnij /= jpni*jpnj ) CALL ctl_stop( 'STOP', 'Cannot remove land proc with AGRIF' )
169	#endif
170	!
171	ALLOCATE( nfiimpp(jpni,jpnj), nfipproc(jpni,jpnj), nfilcit(jpni,jpnj) , &
172	& nimppt(jpnij) , ibonit(jpnij) , nlcit(jpnij) , nlcjt(jpnij) , &
173	& njmppt(jpnij) , ibonjt(jpnij) , nldit(jpnij) , nldjt(jpnij) , &
174	& nleit(jpnij) , nlejt(jpnij) , &
175	& iin(jpnij), ii_nono(jpnij), ii_noea(jpnij), &
176	& ijn(jpnij), ii_noso(jpnij), ii_nowe(jpnij), &
177	& iimppt(jpni,jpnj), ilci(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj), &
178	& ijmppt(jpni,jpnj), ilcj(jpni,jpnj), ibondj(jpni,jpnj), ipolj(jpni,jpnj), &
179	& ilei(jpni,jpnj), ildi(jpni,jpnj), iono(jpni,jpnj), ioea(jpni,jpnj), &
180	& ilej(jpni,jpnj), ildj(jpni,jpnj), ioso(jpni,jpnj), iowe(jpni,jpnj), &
181	& STAT=ierr )
182	CALL mpp_sum( ierr )
183	IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_init: unable to allocate standard ocean arrays' )
184
185	!
186	IF( .NOT. Agrif_Root() ) THEN ! AGRIF children: specific setting (cf. agrif_user.F90)
187	IF( jpiglo /= nbcellsx + 2 + 2*nbghostcells ) &
188	CALL ctl_stop( 'STOP', 'mpp_init: Agrif children requires jpiglo == nbcellsx + 2 + 2*nbghostcells' )
189	IF( jpjglo /= nbcellsy + 2 + 2*nbghostcells ) &
190	CALL ctl_stop( 'STOP', 'mpp_init: Agrif children requires jpjglo == nbcellsy + 2 + 2*nbghostcells' )
191	IF( ln_use_jattr ) CALL ctl_stop( 'STOP', 'mpp_init:Agrif children requires ln_use_jattr = .false. ' )
192	ENDIF
193
194	#if defined key_nemocice_decomp
195	jpimax = ( nx_global+2-2nn_hls + (jpni-1) ) / jpni + 2nn_hls ! first dim.
196	jpjmax = ( ny_global+2-2nn_hls + (jpnj-1) ) / jpnj + 2nn_hls ! second dim.
197	#else
198	jpimax = ( jpiglo - 2nn_hls + (jpni-1) ) / jpni + 2nn_hls ! first dim.
199	jpjmax = ( jpjglo - 2nn_hls + (jpnj-1) ) / jpnj + 2nn_hls ! second dim.
200	#endif
201
202	!
203	IF ( jpni * jpnj == jpnij ) THEN ! regular domain lay out over processors
204	imask(:,:) = 1
205	ELSEIF ( jpni*jpnj > jpnij ) THEN ! remove land-only processor (i.e. where imask(:,:)=0)
206	CALL mpp_init_mask( imask )
207	ELSE ! error
208	CALL ctl_stop( 'mpp_init: jpnij > jpni x jpnj. Check namelist setting!' )
209	ENDIF
210	!
211	! 1. Dimension arrays for subdomains
212	! -----------------------------------
213	! Computation of local domain sizes ilci() ilcj()
214	! These dimensions depend on global sizes jpni,jpnj and jpiglo,jpjglo
215	! The subdomains are squares lesser than or equal to the global
216	! dimensions divided by the number of processors minus the overlap array.
217	!
218	nreci = 2 * nn_hls
219	nrecj = 2 * nn_hls
220	iresti = 1 + MOD( jpiglo - nreci -1 , jpni )
221	irestj = 1 + MOD( jpjglo - nrecj -1 , jpnj )
222	!
223	! Need to use jpimax and jpjmax here since jpi and jpj not yet defined
224	#if defined key_nemocice_decomp
225	! Change padding to be consistent with CICE
226	ilci(1:jpni-1 ,:) = jpimax
227	ilci(jpni ,:) = jpiglo - (jpni - 1) * (jpimax - nreci)
228	!
229	ilcj(:, 1:jpnj-1) = jpjmax
230	ilcj(:, jpnj) = jpjglo - (jpnj - 1) * (jpjmax - nrecj)
231	#else
232	ilci(1:iresti ,:) = jpimax
233	ilci(iresti+1:jpni ,:) = jpimax-1
234
235	ilcj(:, 1:irestj) = jpjmax
236	ilcj(:, irestj+1:jpnj) = jpjmax-1
237	#endif
238	!
239	zidom = nreci + sum(ilci(:,1) - nreci )
240	zjdom = nrecj + sum(ilcj(1,:) - nrecj )
241	!
242	IF(lwp) THEN
243	WRITE(numout,*)
244	WRITE(numout,*) 'mpp_init : MPI Message Passing MPI - domain lay out over processors'
245	WRITE(numout,*) '~~~~~~~~ '
246	WRITE(numout,*) ' defines mpp subdomains'
247	WRITE(numout,*) ' iresti = ', iresti, ' jpni = ', jpni
248	WRITE(numout,*) ' irestj = ', irestj, ' jpnj = ', jpnj
249	WRITE(numout,*)
250	WRITE(numout,*) ' sum ilci(i,1) = ', zidom, ' jpiglo = ', jpiglo
251	WRITE(numout,*) ' sum ilcj(1,j) = ', zjdom, ' jpjglo = ', jpjglo
252	ENDIF
253
254	! 2. Index arrays for subdomains
255	! -------------------------------
256	iimppt(:,:) = 1
257	ijmppt(:,:) = 1
258	ipproc(:,:) = -1
259	!
260	IF( jpni > 1 ) THEN
261	DO jj = 1, jpnj
262	DO ji = 2, jpni
263	iimppt(ji,jj) = iimppt(ji-1,jj) + ilci(ji-1,jj) - nreci
264	END DO
265	END DO
266	ENDIF
267	nfiimpp(:,:) = iimppt(:,:)
268	!
269	IF( jpnj > 1 )THEN
270	DO jj = 2, jpnj
271	DO ji = 1, jpni
272	ijmppt(ji,jj) = ijmppt(ji,jj-1) + ilcj(ji,jj-1) - nrecj
273	END DO
274	END DO
275	ENDIF
276
277	! 3. Subdomain description in the Regular Case
278	! --------------------------------------------
279	nperio = 0
280	icont = -1
281	DO jarea = 1, jpni*jpnj
282	ii = 1 + MOD(jarea-1,jpni)
283	ij = 1 + (jarea-1)/jpni
284	ili = ilci(ii,ij)
285	ilj = ilcj(ii,ij)
286	ibondj(ii,ij) = -1
287	IF( jarea > jpni ) ibondj(ii,ij) = 0
288	IF( jarea > (jpnj-1)*jpni ) ibondj(ii,ij) = 1
289	IF( jpnj == 1 ) ibondj(ii,ij) = 2
290	ibondi(ii,ij) = 0
291	IF( MOD(jarea,jpni) == 1 ) ibondi(ii,ij) = -1
292	IF( MOD(jarea,jpni) == 0 ) ibondi(ii,ij) = 1
293	IF( jpni == 1 ) ibondi(ii,ij) = 2
294
295	! Subdomain neighbors (get their zone number): default definition
296	iproc = jarea - 1
297	ioso(ii,ij) = iproc - jpni
298	iowe(ii,ij) = iproc - 1
299	ioea(ii,ij) = iproc + 1
300	iono(ii,ij) = iproc + jpni
301	ildi(ii,ij) = 1 + nn_hls
302	ilei(ii,ij) = ili - nn_hls
303	ildj(ii,ij) = 1 + nn_hls
304	ilej(ii,ij) = ilj - nn_hls
305
306	! East-West periodicity: change ibondi, ioea, iowe
307	IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 ) THEN
308	IF( jpni == 1 )THEN
309	ibondi(ii,ij) = 2
310	nperio = 1
311	ELSE
312	ibondi(ii,ij) = 0
313	ENDIF
314	IF( MOD(jarea,jpni) == 0 ) THEN
315	ioea(ii,ij) = iproc - (jpni-1)
316	ENDIF
317	IF( MOD(jarea,jpni) == 1 ) THEN
318	iowe(ii,ij) = iproc + jpni - 1
319	ENDIF
320	ENDIF
321
322	! North fold: define ipolj, change iono. Warning: we do not change ibondj...
323	ipolj(ii,ij) = 0
324	IF( jperio == 3 .OR. jperio == 4 ) THEN
325	ijm1 = jpni*(jpnj-1)
326	imil = ijm1+(jpni+1)/2
327	IF( jarea > ijm1 ) ipolj(ii,ij) = 3
328	IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 4
329	IF( ipolj(ii,ij) == 3 ) iono(ii,ij) = jpni*jpnj-jarea+ijm1 ! MPI rank of northern neighbour
330	ENDIF
331	IF( jperio == 5 .OR. jperio == 6 ) THEN
332	ijm1 = jpni*(jpnj-1)
333	imil = ijm1+(jpni+1)/2
334	IF( jarea > ijm1) ipolj(ii,ij) = 5
335	IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 6
336	IF( ipolj(ii,ij) == 5) iono(ii,ij) = jpni*jpnj-jarea+ijm1 ! MPI rank of northern neighbour
337	ENDIF
338	!
339	! Check wet points over the entire domain to preserve the MPI communication stencil
340	isurf = 0
341	DO jj = 1, ilj
342	DO ji = 1, ili
343	IF( imask(ji+iimppt(ii,ij)-1, jj+ijmppt(ii,ij)-1) == 1) isurf = isurf+1
344	END DO
345	END DO
346	!
347	IF( isurf /= 0 ) THEN
348	icont = icont + 1
349	ipproc(ii,ij) = icont
350	iin(icont+1) = ii
351	ijn(icont+1) = ij
352	ENDIF
353	END DO
354	!
355	nfipproc(:,:) = ipproc(:,:)
356
357	! Check potential error
358	IF( icont+1 /= jpnij ) THEN
359	WRITE(ctmp1,*) ' jpni =',jpni,' jpnj =',jpnj
360	WRITE(ctmp2,*) ' jpnij =',jpnij, '< jpni x jpnj'
361	WRITE(ctmp3,) ' **********, mpp_init2 finds jpnij=',icont+1
362	CALL ctl_stop( 'STOP', 'mpp_init: Eliminate land processors algorithm', '', ctmp1, ctmp2, '', ctmp3 )
363	ENDIF
364
365	! 4. Subdomain print
366	! ------------------
367	IF(lwp) THEN
368	ifreq = 4
369	il1 = 1
370	DO jn = 1, (jpni-1)/ifreq+1
371	il2 = MIN(jpni,il1+ifreq-1)
372	WRITE(numout,*)
373	WRITE(numout,9400) ('***',ji=il1,il2-1)
374	DO jj = jpnj, 1, -1
375	WRITE(numout,9403) (' ',ji=il1,il2-1)
376	WRITE(numout,9402) jj, (ilci(ji,jj),ilcj(ji,jj),ji=il1,il2)
377	WRITE(numout,9404) (ipproc(ji,jj),ji=il1,il2)
378	WRITE(numout,9403) (' ',ji=il1,il2-1)
379	WRITE(numout,9400) ('***',ji=il1,il2-1)
380	END DO
381	WRITE(numout,9401) (ji,ji=il1,il2)
382	il1 = il1+ifreq
383	END DO
384	9400 FORMAT(' *' ,20('***********',a3) )
385	9403 FORMAT(' * ',20(' * ',a3) )
386	9401 FORMAT(' ' ,20(' ',i3,' ') )
387	9402 FORMAT(' ',i3,' * ',20(i3,' x',i3,' * ') )
388	9404 FORMAT(' * ' ,20(' ',i3,' * ') )
389	ENDIF
390
391	! 5. neighbour treatment: change ibondi, ibondj if next to a land zone
392	! ----------------------
393	DO jarea = 1, jpni*jpnj
394	iproc = jarea-1
395	ii = 1 + MOD( jarea-1 , jpni )
396	ij = 1 + (jarea-1) / jpni
397	IF ( ipproc(ii,ij) == -1 .AND. 0 <= iono(ii,ij) .AND. iono(ii,ij) <= jpni*jpnj-1 ) THEN
398	iino = 1 + MOD( iono(ii,ij) , jpni )
399	ijno = 1 + iono(ii,ij) / jpni
400	! Need to reverse the logical direction of communication
401	! for northern neighbours of northern row processors (north-fold)
402	! i.e. need to check that the northern neighbour only communicates
403	! to the SOUTH (or not at all) if this area is land-only (#1057)
404	idir = 1
405	IF( ij == jpnj .AND. ijno == jpnj ) idir = -1
406	IF( ibondj(iino,ijno) == idir ) ibondj(iino,ijno) = 2
407	IF( ibondj(iino,ijno) == 0 ) ibondj(iino,ijno) = -idir
408	ENDIF
409	IF( ipproc(ii,ij) == -1 .AND. 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= jpni*jpnj-1 ) THEN
410	iiso = 1 + MOD( ioso(ii,ij) , jpni )
411	ijso = 1 + ioso(ii,ij) / jpni
412	IF( ibondj(iiso,ijso) == -1 ) ibondj(iiso,ijso) = 2
413	IF( ibondj(iiso,ijso) == 0 ) ibondj(iiso,ijso) = 1
414	ENDIF
415	IF( ipproc(ii,ij) == -1 .AND. 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= jpni*jpnj-1 ) THEN
416	iiea = 1 + MOD( ioea(ii,ij) , jpni )
417	ijea = 1 + ioea(ii,ij) / jpni
418	IF( ibondi(iiea,ijea) == 1 ) ibondi(iiea,ijea) = 2
419	IF( ibondi(iiea,ijea) == 0 ) ibondi(iiea,ijea) = -1
420	ENDIF
421	IF( ipproc(ii,ij) == -1 .AND. 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= jpni*jpnj-1) THEN
422	iiwe = 1 + MOD( iowe(ii,ij) , jpni )
423	ijwe = 1 + iowe(ii,ij) / jpni
424	IF( ibondi(iiwe,ijwe) == -1 ) ibondi(iiwe,ijwe) = 2
425	IF( ibondi(iiwe,ijwe) == 0 ) ibondi(iiwe,ijwe) = 1
426	ENDIF
427	END DO
428
429	! Update il[de][ij] according to modified ibond[ij]
430	! ----------------------
431	DO jarea = 1, jpni*jpnj
432	ii = iin(jarea)
433	ij = ijn(jarea)
434	IF( ibondi(ii,ij) == -1 .OR. ibondi(ii,ij) == 2 ) ildi(ii,ij) = 1
435	IF( ibondi(ii,ij) == 1 .OR. ibondi(ii,ij) == 2 ) ilei(ii,ij) = ilci(ii,ij)
436	IF( ibondj(ii,ij) == -1 .OR. ibondj(ii,ij) == 2 ) ildj(ii,ij) = 1
437	IF( ibondj(ii,ij) == 1 .OR. ibondj(ii,ij) == 2 ) ilej(ii,ij) = ilcj(ii,ij)
438	END DO
439
440	! just to save nono etc for all proc
441	! warning ii*ij (zone) /= nproc (processors)!
442	! ioso = zone number, ii_noso = proc number
443	ii_noso(:) = -1
444	ii_nono(:) = -1
445	ii_noea(:) = -1
446	ii_nowe(:) = -1
447	DO jproc = 1, jpnij
448	ii = iin(jproc)
449	ij = ijn(jproc)
450	IF( 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN
451	iiso = 1 + MOD( ioso(ii,ij) , jpni )
452	ijso = 1 + ioso(ii,ij) / jpni
453	ii_noso(jproc) = ipproc(iiso,ijso)
454	ENDIF
455	IF( 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= (jpni*jpnj-1) ) THEN
456	iiwe = 1 + MOD( iowe(ii,ij) , jpni )
457	ijwe = 1 + iowe(ii,ij) / jpni
458	ii_nowe(jproc) = ipproc(iiwe,ijwe)
459	ENDIF
460	IF( 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= (jpni*jpnj-1) ) THEN
461	iiea = 1 + MOD( ioea(ii,ij) , jpni )
462	ijea = 1 + ioea(ii,ij) / jpni
463	ii_noea(jproc)= ipproc(iiea,ijea)
464	ENDIF
465	IF( 0 <= iono(ii,ij) .AND. iono(ii,ij) <= (jpni*jpnj-1) ) THEN
466	iino = 1 + MOD( iono(ii,ij) , jpni )
467	ijno = 1 + iono(ii,ij) / jpni
468	ii_nono(jproc)= ipproc(iino,ijno)
469	ENDIF
470	END DO
471
472	! 6. Change processor name
473	! ------------------------
474	ii = iin(narea)
475	ij = ijn(narea)
476	!
477	! set default neighbours
478	noso = ii_noso(narea)
479	nowe = ii_nowe(narea)
480	noea = ii_noea(narea)
481	nono = ii_nono(narea)
482	nlci = ilci(ii,ij)
483	nldi = ildi(ii,ij)
484	nlei = ilei(ii,ij)
485	nlcj = ilcj(ii,ij)
486	nldj = ildj(ii,ij)
487	nlej = ilej(ii,ij)
488	nbondi = ibondi(ii,ij)
489	nbondj = ibondj(ii,ij)
490	nimpp = iimppt(ii,ij)
491	njmpp = ijmppt(ii,ij)
492	jpi = nlci
493	jpj = nlcj
494	jpk = jpkglo ! third dim
495	#if defined key_agrif
496	! simple trick to use same vertical grid as parent but different number of levels:
497	! Save maximum number of levels in jpkglo, then define all vertical grids with this number.
498	! Suppress once vertical online interpolation is ok
499	!!$ IF(.NOT.Agrif_Root()) jpkglo = Agrif_Parent( jpkglo )
500	#endif
501	jpim1 = jpi-1 ! inner domain indices
502	jpjm1 = jpj-1 ! " "
503	jpkm1 = MAX( 1, jpk-1 ) ! " "
504	jpij = jpi*jpj ! jpi x j
505	DO jproc = 1, jpnij
506	ii = iin(jproc)
507	ij = ijn(jproc)
508	nlcit(jproc) = ilci(ii,ij)
509	nldit(jproc) = ildi(ii,ij)
510	nleit(jproc) = ilei(ii,ij)
511	nlcjt(jproc) = ilcj(ii,ij)
512	nldjt(jproc) = ildj(ii,ij)
513	nlejt(jproc) = ilej(ii,ij)
514	ibonit(jproc) = ibondi(ii,ij)
515	ibonjt(jproc) = ibondj(ii,ij)
516	nimppt(jproc) = iimppt(ii,ij)
517	njmppt(jproc) = ijmppt(ii,ij)
518	nfilcit(ii,ij) = ilci(ii,ij)
519	END DO
520
521	! Save processor layout in ascii file
522	IF (lwp) THEN
523	CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea )
524	WRITE(inum,'(a)') ' jpnij jpimax jpjmax jpk jpiglo jpjglo'//&
525	& ' ( local: narea jpi jpj )'
526	WRITE(inum,'(6i8,a,3i8,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,&
527	& ' ( local: ',narea,jpi,jpj,' )'
528	WRITE(inum,'(a)') 'nproc nlci nlcj nldi nldj nlei nlej nimp njmp nono noso nowe noea nbondi nbondj '
529
530	DO jproc = 1, jpnij
531	WRITE(inum,'(13i5,2i7)') jproc-1, nlcit (jproc), nlcjt (jproc), &
532	& nldit (jproc), nldjt (jproc), &
533	& nleit (jproc), nlejt (jproc), &
534	& nimppt (jproc), njmppt (jproc), &
535	& ii_nono(jproc), ii_noso(jproc), &
536	& ii_nowe(jproc), ii_noea(jproc), &
537	& ibonit (jproc), ibonjt (jproc)
538	END DO
539	CLOSE(inum)
540	END IF
541
542	! ! north fold parameter
543	! Defined npolj, either 0, 3 , 4 , 5 , 6
544	! In this case the important thing is that npolj /= 0
545	! Because if we go through these line it is because jpni >1 and thus
546	! we must use lbcnorthmpp, which tests only npolj =0 or npolj /= 0
547	npolj = 0
548	ij = ijn(narea)
549	IF( jperio == 3 .OR. jperio == 4 ) THEN
550	IF( ij == jpnj ) npolj = 3
551	ENDIF
552	IF( jperio == 5 .OR. jperio == 6 ) THEN
553	IF( ij == jpnj ) npolj = 5
554	ENDIF
555	!
556	nproc = narea-1
557	IF(lwp) THEN
558	WRITE(numout,*)
559	WRITE(numout,*) ' resulting internal parameters : '
560	WRITE(numout,*) ' nproc = ', nproc
561	WRITE(numout,*) ' nowe = ', nowe , ' noea = ', noea
562	WRITE(numout,*) ' nono = ', nono , ' noso = ', noso
563	WRITE(numout,*) ' nbondi = ', nbondi
564	WRITE(numout,*) ' nbondj = ', nbondj
565	WRITE(numout,*) ' npolj = ', npolj
566	WRITE(numout,*) ' nperio = ', nperio
567	WRITE(numout,*) ' nlci = ', nlci
568	WRITE(numout,*) ' nlcj = ', nlcj
569	WRITE(numout,*) ' nimpp = ', nimpp
570	WRITE(numout,*) ' njmpp = ', njmpp
571	WRITE(numout,*) ' nreci = ', nreci
572	WRITE(numout,*) ' nrecj = ', nrecj
573	WRITE(numout,*) ' nn_hls = ', nn_hls
574	ENDIF
575
576	IF( nperio == 1 .AND. jpni /= 1 ) CALL ctl_stop( 'mpp_init: error on cyclicity' )
577
578	IF( jperio == 7 .AND. ( jpni /= 1 .OR. jpnj /= 1 ) ) &
579	& CALL ctl_stop( ' mpp_init: error jperio = 7 works only with jpni = jpnj = 1' )
580
581	! ! Prepare mpp north fold
582	IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN
583	CALL mpp_ini_north
584	IF(lwp) WRITE(numout,*)
585	IF(lwp) WRITE(numout,*) ' ==>>> North fold boundary prepared for jpni >1'
586	ENDIF
587	!
588	CALL mpp_init_ioipsl ! Prepare NetCDF output file (if necessary)
589	!
590	IF( ln_nnogather ) CALL mpp_init_nfdcom ! northfold neighbour lists
591	!
592	DEALLOCATE(iin, ijn, ii_nono, ii_noea, ii_noso, ii_nowe, &
593	& iimppt, ijmppt, ibondi, ibondj, ipproc, ipolj, &
594	& ilci, ilcj, ilei, ilej, ildi, ildj, &
595	& iono, ioea, ioso, iowe)
596	!
597	END SUBROUTINE mpp_init
598
599
600	SUBROUTINE mpp_init_mask( kmask )
601	!!----------------------------------------------------------------------
602	!! * ROUTINE mpp_init_mask *
603	!!
604	!! ** Purpose : Read relevant bathymetric information in a global array
605	!! in order to provide a land/sea mask used for the elimination
606	!! of land domains, in an mpp computation.
607	!!
608	!! ** Method : Read the namelist ln_zco and ln_isfcav in namelist namzgr
609	!! in order to choose the correct bathymetric information
610	!! (file and variables)
611	!!----------------------------------------------------------------------
612	INTEGER, DIMENSION(jpiglo,jpjglo), INTENT(out) :: kmask ! global domain
613
614	INTEGER :: inum !: logical unit for configuration file
615	INTEGER :: ios !: iostat error flag
616	INTEGER :: ijstartrow ! temporary integers
617	REAL(wp), DIMENSION(jpiglo,jpjglo) :: zbot, zbdy ! global workspace
618	REAL(wp) :: zidom , zjdom ! local scalars
619	NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file, &
620	& ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta, &
621	& cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta, &
622	& ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, &
623	& cn_ice_lim, nn_ice_lim_dta, &
624	& rn_ice_tem, rn_ice_sal, rn_ice_age, &
625	& ln_vol, nn_volctl, nn_rimwidth, nb_jpk_bdy
626	!!----------------------------------------------------------------------
627	! 0. initialisation
628	! -----------------
629	CALL iom_open( cn_domcfg, inum )
630	!
631	! ocean bottom level
632	CALL iom_get( inum, jpdom_unknown, 'bottom_level' , zbot , lrowattr=ln_use_jattr ) ! nb of ocean T-points
633	!
634	CALL iom_close( inum )
635	!
636	! 2D ocean mask (=1 if at least one level of the water column is ocean, =0 otherwise)
637	WHERE( zbot(:,:) > 0 ) ; kmask(:,:) = 1
638	ELSEWHERE ; kmask(:,:) = 0
639	END WHERE
640
641	! Adjust kmask with bdy_msk if it exists
642
643	REWIND( numnam_ref ) ! Namelist nambdy in reference namelist : BDY
644	READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903)
645	903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist (mppini)', lwp )
646	!
647	REWIND( numnam_cfg ) ! Namelist nambdy in configuration namelist : BDY
648	READ ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 )
649	904 IF( ios > 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist (mppini)', lwp )
650
651	IF( ln_bdy .AND. ln_mask_file ) THEN
652	CALL iom_open( cn_mask_file, inum )
653	CALL iom_get ( inum, jpdom_unknown, 'bdy_msk', zbdy )
654	CALL iom_close( inum )
655	WHERE ( zbdy(:,:) <= 0. ) kmask = 0
656	ENDIF
657	!
658	END SUBROUTINE mpp_init_mask
659
660
661	SUBROUTINE mpp_init_ioipsl
662	!!----------------------------------------------------------------------
663	!! * ROUTINE mpp_init_ioipsl *
664	!!
665	!! ** Purpose :
666	!!
667	!! ** Method :
668	!!
669	!! History :
670	!! 9.0 ! 04-03 (G. Madec ) MPP-IOIPSL
671	!! " " ! 08-12 (A. Coward) addition in case of jpni*jpnj < jpnij
672	!!----------------------------------------------------------------------
673	INTEGER, DIMENSION(2) :: iglo, iloc, iabsf, iabsl, ihals, ihale, idid
674	!!----------------------------------------------------------------------
675
676	! The domain is split only horizontally along i- or/and j- direction
677	! So we need at the most only 1D arrays with 2 elements.
678	! Set idompar values equivalent to the jpdom_local_noextra definition
679	! used in IOM. This works even if jpnij .ne. jpni*jpnj.
680	iglo(1) = jpiglo
681	iglo(2) = jpjglo
682	iloc(1) = nlci
683	iloc(2) = nlcj
684	iabsf(1) = nimppt(narea)
685	iabsf(2) = njmppt(narea)
686	iabsl(:) = iabsf(:) + iloc(:) - 1
687	ihals(1) = nldi - 1
688	ihals(2) = nldj - 1
689	ihale(1) = nlci - nlei
690	ihale(2) = nlcj - nlej
691	idid(1) = 1
692	idid(2) = 2
693
694	IF(lwp) THEN
695	WRITE(numout,*)
696	WRITE(numout,*) 'mpp_init_ioipsl : iloc = ', iloc (1), iloc (2)
697	WRITE(numout,*) '~~~~~~~~~~~~~~~ iabsf = ', iabsf(1), iabsf(2)
698	WRITE(numout,*) ' ihals = ', ihals(1), ihals(2)
699	WRITE(numout,*) ' ihale = ', ihale(1), ihale(2)
700	ENDIF
701	!
702	CALL flio_dom_set ( jpnij, nproc, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom)
703	!
704	END SUBROUTINE mpp_init_ioipsl
705
706
707	SUBROUTINE mpp_init_partition( num_pes )
708	!!----------------------------------------------------------------------
709	!! * ROUTINE mpp_init_partition *
710	!!
711	!! ** Purpose :
712	!!
713	!! ** Method :
714	!!----------------------------------------------------------------------
715	INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have
716	!
717	INTEGER, PARAMETER :: nfactmax = 20
718	INTEGER :: nfact ! The no. of factors returned
719	INTEGER :: ierr ! Error flag
720	INTEGER :: ji
721	INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value
722	INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors
723	!!----------------------------------------------------------------------
724	!
725	ierr = 0
726	!
727	CALL factorise( ifact, nfactmax, nfact, num_pes, ierr )
728	!
729	IF( nfact <= 1 ) THEN
730	WRITE (numout, *) 'WARNING: factorisation of number of PEs failed'
731	WRITE (numout, *) ' : using grid of ',num_pes,' x 1'
732	jpnj = 1
733	jpni = num_pes
734	ELSE
735	! Search through factors for the pair that are closest in value
736	mindiff = 1000000
737	imin = 1
738	DO ji = 1, nfact-1, 2
739	idiff = ABS( ifact(ji) - ifact(ji+1) )
740	IF( idiff < mindiff ) THEN
741	mindiff = idiff
742	imin = ji
743	ENDIF
744	END DO
745	jpnj = ifact(imin)
746	jpni = ifact(imin + 1)
747	ENDIF
748	!
749	jpnij = jpni*jpnj
750	!
751	END SUBROUTINE mpp_init_partition
752
753
754	SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr )
755	!!----------------------------------------------------------------------
756	!! * ROUTINE factorise *
757	!!
758	!! ** Purpose : return the prime factors of n.
759	!! knfax factors are returned in array kfax which is of
760	!! maximum dimension kmaxfax.
761	!! ** Method :
762	!!----------------------------------------------------------------------
763	INTEGER , INTENT(in ) :: kn, kmaxfax
764	INTEGER , INTENT( out) :: kerr, knfax
765	INTEGER, DIMENSION(kmaxfax), INTENT( out) :: kfax
766	!
767	INTEGER :: ifac, jl, inu
768	INTEGER, PARAMETER :: ntest = 14
769	INTEGER, DIMENSION(ntest) :: ilfax
770	!!----------------------------------------------------------------------
771	!
772	! lfax contains the set of allowed factors.
773	ilfax(:) = (/(2**jl,jl=ntest,1,-1)/)
774	!
775	! Clear the error flag and initialise output vars
776	kerr = 0
777	kfax = 1
778	knfax = 0
779	!
780	IF( kn /= 1 ) THEN ! Find the factors of n
781	!
782	! nu holds the unfactorised part of the number.
783	! knfax holds the number of factors found.
784	! l points to the allowed factor list.
785	! ifac holds the current factor.
786	!
787	inu = kn
788	knfax = 0
789	!
790	DO jl = ntest, 1, -1
791	!
792	ifac = ilfax(jl)
793	IF( ifac > inu ) CYCLE
794	!
795	! Test whether the factor will divide.
796	!
797	IF( MOD(inu,ifac) == 0 ) THEN
798	!
799	knfax = knfax + 1 ! Add the factor to the list
800	IF( knfax > kmaxfax ) THEN
801	kerr = 6
802	write (,) 'FACTOR: insufficient space in factor array ', knfax
803	return
804	ENDIF
805	kfax(knfax) = ifac
806	! Store the other factor that goes with this one
807	knfax = knfax + 1
808	kfax(knfax) = inu / ifac
809	!WRITE (,) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax)
810	ENDIF
811	!
812	END DO
813	!
814	ENDIF
815	!
816	END SUBROUTINE factorise
817
818
819	SUBROUTINE mpp_init_nfdcom
820	!!----------------------------------------------------------------------
821	!! * ROUTINE mpp_init_nfdcom *
822	!! ** Purpose : Setup for north fold exchanges with explicit
823	!! point-to-point messaging
824	!!
825	!! ** Method : Initialization of the northern neighbours lists.
826	!!----------------------------------------------------------------------
827	!! 1.0 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE)
828	!! 2.0 ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S. Mocavero, CMCC)
829	!!----------------------------------------------------------------------
830	INTEGER :: sxM, dxM, sxT, dxT, jn
831	INTEGER :: njmppmax
832	!!----------------------------------------------------------------------
833	!
834	njmppmax = MAXVAL( njmppt )
835	!
836	!initializes the north-fold communication variables
837	isendto(:) = 0
838	nsndto = 0
839	!
840	IF ( njmpp == njmppmax ) THEN ! if I am a process in the north
841	!
842	!sxM is the first point (in the global domain) needed to compute the north-fold for the current process
843	sxM = jpiglo - nimppt(narea) - nlcit(narea) + 1
844	!dxM is the last point (in the global domain) needed to compute the north-fold for the current process
845	dxM = jpiglo - nimppt(narea) + 2
846	!
847	! loop over the other north-fold processes to find the processes
848	! managing the points belonging to the sxT-dxT range
849	!
850	DO jn = 1, jpni
851	!
852	sxT = nfiimpp(jn, jpnj) ! sxT = 1st point (in the global domain) of the jn process
853	dxT = nfiimpp(jn, jpnj) + nfilcit(jn, jpnj) - 1 ! dxT = last point (in the global domain) of the jn process
854	!
855	IF ( sxT < sxM .AND. sxM < dxT ) THEN
856	nsndto = nsndto + 1
857	isendto(nsndto) = jn
858	ELSEIF( sxM <= sxT .AND. dxM >= dxT ) THEN
859	nsndto = nsndto + 1
860	isendto(nsndto) = jn
861	ELSEIF( dxM < dxT .AND. sxT < dxM ) THEN
862	nsndto = nsndto + 1
863	isendto(nsndto) = jn
864	ENDIF
865	!
866	END DO
867	nfsloop = 1
868	nfeloop = nlci
869	DO jn = 2,jpni-1
870	IF( nfipproc(jn,jpnj) == (narea - 1) ) THEN
871	IF( nfipproc(jn-1,jpnj) == -1 ) nfsloop = nldi
872	IF( nfipproc(jn+1,jpnj) == -1 ) nfeloop = nlei
873	ENDIF
874	END DO
875	!
876	ENDIF
877	l_north_nogather = .TRUE.
878	!
879	END SUBROUTINE mpp_init_nfdcom
880
881
882	#endif
883
884	!!======================================================================
885	END MODULE mppini

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

New URL for NEMO forge! http://forge.nemo-ocean.eu

Context Navigation

source: branches/UKMO/dev_merge_2017_CICE_interface/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90 @ 9500

Download in other formats: