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.

prtctl.F90 in NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/IOM – NEMO

Context Navigation

source: NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/IOM/prtctl.F90 @ 12807

Last change on this file since 12807 was 12807, checked in by smasson, 5 years ago
Extra_Halo: input file only over inner domain + new variables names, see #2366
Property svn:keywords set to `Id`
File size: 24.7 KB

Line
1	MODULE prtctl
2	!!======================================================================
3	!! * MODULE prtctl *
4	!! Ocean system : print all SUM trends for each processor domain
5	!!======================================================================
6	!! History : 9.0 ! 05-07 (C. Talandier) original code
7	!! 3.4 ! 11-11 (C. Harris) decomposition changes for running with CICE
8	!!----------------------------------------------------------------------
9	USE dom_oce ! ocean space and time domain variables
10	#if defined key_nemocice_decomp
11	USE ice_domain_size, only: nx_global, ny_global
12	#endif
13	USE in_out_manager ! I/O manager
14	USE lib_mpp ! distributed memory computing
15
16	IMPLICIT NONE
17	PRIVATE
18
19	INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: numid
20	INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nis0allp, njs0allp ! first, last indoor index for each i-domain
21	INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nie0allp, nje0allp ! first, last indoor index for each j-domain
22	INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nimpptl, njmpptl ! i-, j-indexes for each processor
23	INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: jpiallp, jpjallp ! dimensions of every subdomain
24	INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: ibonitl, ibonjtl !
25
26	REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: t_ctll , s_ctll ! previous tracer trend values
27	REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: u_ctll , v_ctll ! previous velocity trend values
28
29	INTEGER :: ktime ! time step
30
31	PUBLIC prt_ctl ! called by all subroutines
32	PUBLIC prt_ctl_info ! called by all subroutines
33	PUBLIC prt_ctl_init ! called by opa.F90
34	PUBLIC sub_dom ! called by opa.F90
35
36	!!----------------------------------------------------------------------
37	!! NEMO/OCE 4.0 , NEMO Consortium (2018)
38	!! $Id$
39	!! Software governed by the CeCILL license (see ./LICENSE)
40	!!----------------------------------------------------------------------
41	CONTAINS
42
43	SUBROUTINE prt_ctl (tab2d_1, tab3d_1, mask1, clinfo1, tab2d_2, tab3d_2, &
44	& mask2, clinfo2, kdim, clinfo3 )
45	!!----------------------------------------------------------------------
46	!! * ROUTINE prt_ctl *
47	!!
48	!! ** Purpose : - print sum control of 2D or 3D arrays over the same area
49	!! in mono and mpp case. This way can be usefull when
50	!! debugging a new parametrization in mono or mpp.
51	!!
52	!! ** Method : 2 possibilities exist when setting the sn_cfctl%prtctl parameter to
53	!! .true. in the ocean namelist:
54	!! - to debug a MPI run .vs. a mono-processor one;
55	!! the control print will be done over each sub-domain.
56	!! The nictl[se] and njctl[se] parameters in the namelist must
57	!! be set to zero and [ij]splt to the corresponding splitted
58	!! domain in MPI along respectively i-, j- directions.
59	!! - to debug a mono-processor run over the whole domain/a specific area;
60	!! in the first case the nictl[se] and njctl[se] parameters must be set
61	!! to zero else to the indices of the area to be controled. In both cases
62	!! isplt and jsplt must be set to 1.
63	!! - All arguments of the above calling sequence are optional so their
64	!! name must be explicitly typed if used. For instance if the 3D
65	!! array tn(:,:,:) must be passed through the prt_ctl subroutine,
66	!! it must look like: CALL prt_ctl(tab3d_1=tn).
67	!!
68	!! tab2d_1 : first 2D array
69	!! tab3d_1 : first 3D array
70	!! mask1 : mask (3D) to apply to the tab[23]d_1 array
71	!! clinfo1 : information about the tab[23]d_1 array
72	!! tab2d_2 : second 2D array
73	!! tab3d_2 : second 3D array
74	!! mask2 : mask (3D) to apply to the tab[23]d_2 array
75	!! clinfo2 : information about the tab[23]d_2 array
76	!! kdim : k- direction for 3D arrays
77	!! clinfo3 : additional information
78	!!----------------------------------------------------------------------
79	REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_1
80	REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: tab3d_1
81	REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask1
82	CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo1
83	REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_2
84	REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: tab3d_2
85	REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask2
86	CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo2
87	INTEGER , INTENT(in), OPTIONAL :: kdim
88	CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo3
89	!
90	CHARACTER (len=15) :: cl2
91	INTEGER :: jn, sind, eind, kdir,j_id
92	REAL(wp) :: zsum1, zsum2, zvctl1, zvctl2
93	REAL(wp), DIMENSION(jpi,jpj) :: ztab2d_1, ztab2d_2
94	REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask1, zmask2, ztab3d_1, ztab3d_2
95	!!----------------------------------------------------------------------
96
97	! Arrays, scalars initialization
98	kdir = jpkm1
99	cl2 = ''
100	zsum1 = 0.e0
101	zsum2 = 0.e0
102	zvctl1 = 0.e0
103	zvctl2 = 0.e0
104	ztab2d_1(:,:) = 0.e0
105	ztab2d_2(:,:) = 0.e0
106	ztab3d_1(:,:,:) = 0.e0
107	ztab3d_2(:,:,:) = 0.e0
108	zmask1 (:,:,:) = 1.e0
109	zmask2 (:,:,:) = 1.e0
110
111	! Control of optional arguments
112	IF( PRESENT(clinfo2) ) cl2 = clinfo2
113	IF( PRESENT(kdim) ) kdir = kdim
114	IF( PRESENT(tab2d_1) ) ztab2d_1(:,:) = tab2d_1(:,:)
115	IF( PRESENT(tab2d_2) ) ztab2d_2(:,:) = tab2d_2(:,:)
116	IF( PRESENT(tab3d_1) ) ztab3d_1(:,:,1:kdir) = tab3d_1(:,:,1:kdir)
117	IF( PRESENT(tab3d_2) ) ztab3d_2(:,:,1:kdir) = tab3d_2(:,:,1:kdir)
118	IF( PRESENT(mask1) ) zmask1 (:,:,:) = mask1 (:,:,:)
119	IF( PRESENT(mask2) ) zmask2 (:,:,:) = mask2 (:,:,:)
120
121	IF( lk_mpp .AND. jpnij > 1 ) THEN ! processor number
122	sind = narea
123	eind = narea
124	ELSE ! processors total number
125	sind = 1
126	eind = ijsplt
127	ENDIF
128
129	! Loop over each sub-domain, i.e. the total number of processors ijsplt
130	DO jn = sind, eind
131	! Set logical unit
132	j_id = numid(jn - narea + 1)
133	! Set indices for the SUM control
134	IF( .NOT. lsp_area ) THEN
135	IF (lk_mpp .AND. jpnij > 1) THEN
136	nictls = MAX( 1, nis0allp(jn) )
137	nictle = MIN(jpi, nie0allp(jn) )
138	njctls = MAX( 1, njs0allp(jn) )
139	njctle = MIN(jpj, nje0allp(jn) )
140	! Do not take into account the bound of the domain
141	IF( ibonitl(jn) == -1 .OR. ibonitl(jn) == 2 ) nictls = MAX(2, nictls)
142	IF( ibonjtl(jn) == -1 .OR. ibonjtl(jn) == 2 ) njctls = MAX(2, njctls)
143	IF( ibonitl(jn) == 1 .OR. ibonitl(jn) == 2 ) nictle = MIN(nictle, nie0allp(jn) - 1)
144	IF( ibonjtl(jn) == 1 .OR. ibonjtl(jn) == 2 ) njctle = MIN(njctle, nje0allp(jn) - 1)
145	ELSE
146	nictls = MAX( 1, nimpptl(jn) - 1 + nis0allp(jn) )
147	nictle = MIN(jpi, nimpptl(jn) - 1 + nie0allp(jn) )
148	njctls = MAX( 1, njmpptl(jn) - 1 + njs0allp(jn) )
149	njctle = MIN(jpj, njmpptl(jn) - 1 + nje0allp(jn) )
150	! Do not take into account the bound of the domain
151	IF( ibonitl(jn) == -1 .OR. ibonitl(jn) == 2 ) nictls = MAX(2, nictls)
152	IF( ibonjtl(jn) == -1 .OR. ibonjtl(jn) == 2 ) njctls = MAX(2, njctls)
153	IF( ibonitl(jn) == 1 .OR. ibonitl(jn) == 2 ) nictle = MIN(nictle, nimpptl(jn) + nie0allp(jn) - 2)
154	IF( ibonjtl(jn) == 1 .OR. ibonjtl(jn) == 2 ) njctle = MIN(njctle, njmpptl(jn) + nje0allp(jn) - 2)
155	ENDIF
156	ENDIF
157
158	IF( PRESENT(clinfo3)) THEN
159	IF ( clinfo3 == 'tra' ) THEN
160	zvctl1 = t_ctll(jn)
161	zvctl2 = s_ctll(jn)
162	ELSEIF ( clinfo3 == 'dyn' ) THEN
163	zvctl1 = u_ctll(jn)
164	zvctl2 = v_ctll(jn)
165	ENDIF
166	ENDIF
167
168	! Compute the sum control
169	! 2D arrays
170	IF( PRESENT(tab2d_1) ) THEN
171	zsum1 = SUM( ztab2d_1(nictls:nictle,njctls:njctle)*zmask1(nictls:nictle,njctls:njctle,1) )
172	zsum2 = SUM( ztab2d_2(nictls:nictle,njctls:njctle)*zmask2(nictls:nictle,njctls:njctle,1) )
173	ENDIF
174
175	! 3D arrays
176	IF( PRESENT(tab3d_1) ) THEN
177	zsum1 = SUM( ztab3d_1(nictls:nictle,njctls:njctle,1:kdir)*zmask1(nictls:nictle,njctls:njctle,1:kdir) )
178	zsum2 = SUM( ztab3d_2(nictls:nictle,njctls:njctle,1:kdir)*zmask2(nictls:nictle,njctls:njctle,1:kdir) )
179	ENDIF
180
181	! Print the result
182	IF( PRESENT(clinfo3) ) THEN
183	WRITE(j_id,FMT='(a,D23.16,3x,a,D23.16)')clinfo1, zsum1-zvctl1, cl2, zsum2-zvctl2
184	SELECT CASE( clinfo3 )
185	CASE ( 'tra-ta' )
186	t_ctll(jn) = zsum1
187	CASE ( 'tra' )
188	t_ctll(jn) = zsum1
189	s_ctll(jn) = zsum2
190	CASE ( 'dyn' )
191	u_ctll(jn) = zsum1
192	v_ctll(jn) = zsum2
193	END SELECT
194	ELSEIF ( PRESENT(clinfo2) .OR. PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN
195	WRITE(j_id,FMT='(a,D23.16,3x,a,D23.16)')clinfo1, zsum1, cl2, zsum2
196	ELSE
197	WRITE(j_id,FMT='(a,D23.16)')clinfo1, zsum1
198	ENDIF
199
200	ENDDO
201	!
202	END SUBROUTINE prt_ctl
203
204
205	SUBROUTINE prt_ctl_info (clinfo1, ivar1, clinfo2, ivar2, itime)
206	!!----------------------------------------------------------------------
207	!! * ROUTINE prt_ctl_info *
208	!!
209	!! ** Purpose : - print information without any computation
210	!!
211	!! ** Action : - input arguments
212	!! clinfo1 : information about the ivar1
213	!! ivar1 : value to print
214	!! clinfo2 : information about the ivar2
215	!! ivar2 : value to print
216	!!----------------------------------------------------------------------
217	CHARACTER (len=*), INTENT(in) :: clinfo1
218	INTEGER , INTENT(in), OPTIONAL :: ivar1
219	CHARACTER (len=*), INTENT(in), OPTIONAL :: clinfo2
220	INTEGER , INTENT(in), OPTIONAL :: ivar2
221	INTEGER , INTENT(in), OPTIONAL :: itime
222	!
223	INTEGER :: jn, sind, eind, iltime, j_id
224	!!----------------------------------------------------------------------
225
226	IF( lk_mpp .AND. jpnij > 1 ) THEN ! processor number
227	sind = narea
228	eind = narea
229	ELSE ! total number of processors
230	sind = 1
231	eind = ijsplt
232	ENDIF
233
234	! Set to zero arrays at each new time step
235	IF( PRESENT(itime) ) THEN
236	iltime = itime
237	IF( iltime > ktime ) THEN
238	t_ctll(:) = 0.e0 ; s_ctll(:) = 0.e0
239	u_ctll(:) = 0.e0 ; v_ctll(:) = 0.e0
240	ktime = iltime
241	ENDIF
242	ENDIF
243
244	! Loop over each sub-domain, i.e. number of processors ijsplt
245	DO jn = sind, eind
246	!
247	j_id = numid(jn - narea + 1) ! Set logical unit
248	!
249	IF( PRESENT(ivar1) .AND. PRESENT(clinfo2) .AND. PRESENT(ivar2) ) THEN
250	WRITE(j_id,*)clinfo1, ivar1, clinfo2, ivar2
251	ELSEIF ( PRESENT(ivar1) .AND. PRESENT(clinfo2) .AND. .NOT. PRESENT(ivar2) ) THEN
252	WRITE(j_id,*)clinfo1, ivar1, clinfo2
253	ELSEIF ( PRESENT(ivar1) .AND. .NOT. PRESENT(clinfo2) .AND. PRESENT(ivar2) ) THEN
254	WRITE(j_id,*)clinfo1, ivar1, ivar2
255	ELSEIF ( PRESENT(ivar1) .AND. .NOT. PRESENT(clinfo2) .AND. .NOT. PRESENT(ivar2) ) THEN
256	WRITE(j_id,*)clinfo1, ivar1
257	ELSE
258	WRITE(j_id,*)clinfo1
259	ENDIF
260	!
261	END DO
262	!
263	END SUBROUTINE prt_ctl_info
264
265
266	SUBROUTINE prt_ctl_init
267	!!----------------------------------------------------------------------
268	!! * ROUTINE prt_ctl_init *
269	!!
270	!! ** Purpose : open ASCII files & compute indices
271	!!----------------------------------------------------------------------
272	INTEGER :: jn, sind, eind, j_id
273	CHARACTER (len=28) :: clfile_out
274	CHARACTER (len=23) :: clb_name
275	CHARACTER (len=19) :: cl_run
276	!!----------------------------------------------------------------------
277
278	! Allocate arrays
279	ALLOCATE( nis0allp(ijsplt) , nie0allp(ijsplt) , nimpptl(ijsplt) , ibonitl(ijsplt) , &
280	& njs0allp(ijsplt) , nje0allp(ijsplt) , njmpptl(ijsplt) , ibonjtl(ijsplt) , &
281	& jpiallp(ijsplt) , t_ctll(ijsplt) , u_ctll(ijsplt) , &
282	& jpjallp(ijsplt) , s_ctll(ijsplt) , v_ctll(ijsplt) )
283
284	! Initialization
285	t_ctll(:) = 0.e0
286	s_ctll(:) = 0.e0
287	u_ctll(:) = 0.e0
288	v_ctll(:) = 0.e0
289	ktime = 1
290
291	IF( lk_mpp .AND. jpnij > 1 ) THEN
292	sind = narea
293	eind = narea
294	clb_name = "('mpp.output_',I4.4)"
295	cl_run = 'MULTI processor run'
296	! use indices for each area computed by mpp_init subroutine
297	nis0allp(1:jpnij) = nis0all(:)
298	nie0allp(1:jpnij) = nie0all(:)
299	njs0allp(1:jpnij) = njs0all(:)
300	nje0allp(1:jpnij) = nje0all(:)
301	!
302	nimpptl(1:jpnij) = nimppt(:)
303	njmpptl(1:jpnij) = njmppt(:)
304	!
305	jpiallp(1:jpnij) = jpiall(:)
306	jpjallp(1:jpnij) = jpjall(:)
307	!
308	ibonitl(1:jpnij) = ibonit(:)
309	ibonjtl(1:jpnij) = ibonjt(:)
310	ELSE
311	sind = 1
312	eind = ijsplt
313	clb_name = "('mono.output_',I4.4)"
314	cl_run = 'MONO processor run '
315	! compute indices for each area as done in mpp_init subroutine
316	CALL sub_dom
317	ENDIF
318
319	ALLOCATE( numid(eind-sind+1) )
320
321	DO jn = sind, eind
322	WRITE(clfile_out,FMT=clb_name) jn-1
323	CALL ctl_opn( numid(jn -narea + 1), clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', 1, numout, .FALSE. )
324	j_id = numid(jn -narea + 1)
325	WRITE(j_id,*)
326	WRITE(j_id,*) ' L O D Y C - I P S L'
327	WRITE(j_id,*) ' O P A model'
328	WRITE(j_id,*) ' Ocean General Circulation Model'
329	WRITE(j_id,*) ' version OPA 9.0 (2005) '
330	WRITE(j_id,*)
331	WRITE(j_id,*) ' PROC number: ', jn
332	WRITE(j_id,*)
333	WRITE(j_id,FMT="(19x,a20)")cl_run
334
335	! Print the SUM control indices
336	IF( .NOT. lsp_area ) THEN
337	nictls = nimpptl(jn) + nis0allp(jn) - 1
338	nictle = nimpptl(jn) + nie0allp(jn) - 1
339	njctls = njmpptl(jn) + njs0allp(jn) - 1
340	njctle = njmpptl(jn) + nje0allp(jn) - 1
341	ENDIF
342	WRITE(j_id,*)
343	WRITE(j_id,*) 'prt_ctl : Sum control indices'
344	WRITE(j_id,*) '~~~~~~~'
345	WRITE(j_id,*)
346	WRITE(j_id,9000)' Nje0 = ', nje0allp(jn), ' '
347	WRITE(j_id,9000)' ------------- njctle = ', njctle, ' -------------'
348	WRITE(j_id,9001)' \| \|'
349	WRITE(j_id,9001)' \| \|'
350	WRITE(j_id,9001)' \| \|'
351	WRITE(j_id,9002)' nictls = ', nictls, ' nictle = ', nictle
352	WRITE(j_id,9002)' Nis0 = ', nis0allp(jn), ' Nie0 = ', nie0allp(jn)
353	WRITE(j_id,9001)' \| \|'
354	WRITE(j_id,9001)' \| \|'
355	WRITE(j_id,9001)' \| \|'
356	WRITE(j_id,9004)' njmpp = ',njmpptl(jn),' ------------- njctls = ', njctls, ' -------------'
357	WRITE(j_id,9003)' nimpp = ', nimpptl(jn), ' Njs0 = ', njs0allp(jn), ' '
358	WRITE(j_id,*)
359	WRITE(j_id,*)
360
361	9000 FORMAT(a41,i4.4,a14)
362	9001 FORMAT(a59)
363	9002 FORMAT(a20,i4.4,a36,i3.3)
364	9003 FORMAT(a20,i4.4,a17,i4.4)
365	9004 FORMAT(a11,i4.4,a26,i4.4,a14)
366	END DO
367	!
368	END SUBROUTINE prt_ctl_init
369
370
371	SUBROUTINE sub_dom
372	!!----------------------------------------------------------------------
373	!! * ROUTINE sub_dom *
374	!!
375	!! ** Purpose : Lay out the global domain over processors.
376	!! CAUTION:
377	!! This part has been extracted from the mpp_init
378	!! subroutine and names of variables/arrays have been
379	!! slightly changed to avoid confusion but the computation
380	!! is exactly the same. Any modification about indices of
381	!! each sub-domain in the mppini.F90 module should be reported
382	!! here.
383	!!
384	!! ** Method : Global domain is distributed in smaller local domains.
385	!! Periodic condition is a function of the local domain position
386	!! (global boundary or neighbouring domain) and of the global
387	!! periodic
388	!! Type : jperio global periodic condition
389	!!
390	!! ** Action : - set domain parameters
391	!! nimpp : longitudinal index
392	!! njmpp : latitudinal index
393	!! narea : number for local area
394	!! ipil : first dimension
395	!! ipjl : second dimension
396	!! nbondil : mark for "east-west local boundary"
397	!! nbondjl : mark for "north-south local boundary"
398	!!
399	!! History :
400	!! ! 94-11 (M. Guyon) Original code
401	!! ! 95-04 (J. Escobar, M. Imbard)
402	!! ! 98-02 (M. Guyon) FETI method
403	!! ! 98-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI versions
404	!! 8.5 ! 02-08 (G. Madec) F90 : free form
405	!!----------------------------------------------------------------------
406	INTEGER :: ji, jj, jn ! dummy loop indices
407	INTEGER :: &
408	ii, ij, & ! temporary integers
409	irestil, irestjl, & ! " "
410	ijpi , ijpj, ipil, & ! temporary logical unit
411	ipjl , nbondil, nbondjl, &
412	nrecil, nrecjl, Nis0l, Nie0l, Njs0l, Nje0l
413
414	INTEGER, DIMENSION(jpi,jpj) :: iimpptl, ijmpptl, ijpitl, ijpjtl ! workspace
415	REAL(wp) :: zidom, zjdom ! temporary scalars
416	INTEGER :: inum ! local logical unit
417	!!----------------------------------------------------------------------
418
419	!
420	!
421	! 1. Dimension arrays for subdomains
422	! -----------------------------------
423	! Computation of local domain sizes ijpitl() ijpjtl()
424	! These dimensions depend on global sizes isplt,jsplt and jpiglo,jpjglo
425	! The subdomains are squares leeser than or equal to the global
426	! dimensions divided by the number of processors minus the overlap
427	! array (cf. par_oce.F90).
428
429	#if defined key_nemocice_decomp
430	ijpi = ( nx_global+2-2nn_hls + (isplt-1) ) / isplt + 2nn_hls
431	ijpj = ( ny_global+2-2nn_hls + (jsplt-1) ) / jsplt + 2nn_hls
432	#else
433	ijpi = ( jpiglo-2nn_hls + (isplt-1) ) / isplt + 2nn_hls
434	ijpj = ( jpjglo-2nn_hls + (jsplt-1) ) / jsplt + 2nn_hls
435	#endif
436
437
438	nrecil = 2 * nn_hls
439	nrecjl = 2 * nn_hls
440	irestil = MOD( jpiglo - nrecil , isplt )
441	irestjl = MOD( jpjglo - nrecjl , jsplt )
442
443	IF( irestil == 0 ) irestil = isplt
444	#if defined key_nemocice_decomp
445
446	! In order to match CICE the size of domains in NEMO has to be changed
447	! The last line of blocks (west) will have fewer points
448	DO jj = 1, jsplt
449	DO ji=1, isplt-1
450	ijpitl(ji,jj) = ijpi
451	END DO
452	ijpitl(isplt,jj) = jpiglo - (isplt - 1) * (ijpi - nrecil)
453	END DO
454
455	#else
456
457	DO jj = 1, jsplt
458	DO ji = 1, irestil
459	ijpitl(ji,jj) = ijpi
460	END DO
461	DO ji = irestil+1, isplt
462	ijpitl(ji,jj) = ijpi -1
463	END DO
464	END DO
465
466	#endif
467
468	IF( irestjl == 0 ) irestjl = jsplt
469	#if defined key_nemocice_decomp
470
471	! Same change to domains in North-South direction as in East-West.
472	DO ji = 1, isplt
473	DO jj=1, jsplt-1
474	ijpjtl(ji,jj) = ijpj
475	END DO
476	ijpjtl(ji,jsplt) = jpjglo - (jsplt - 1) * (ijpj - nrecjl)
477	END DO
478
479	#else
480
481	DO ji = 1, isplt
482	DO jj = 1, irestjl
483	ijpjtl(ji,jj) = ijpj
484	END DO
485	DO jj = irestjl+1, jsplt
486	ijpjtl(ji,jj) = ijpj -1
487	END DO
488	END DO
489
490	#endif
491	zidom = nrecil
492	DO ji = 1, isplt
493	zidom = zidom + ijpitl(ji,1) - nrecil
494	END DO
495	IF(lwp) WRITE(numout,*)
496	IF(lwp) WRITE(numout,*)' sum ijpitl(i,1) = ', zidom, ' jpiglo = ', jpiglo
497
498	zjdom = nrecjl
499	DO jj = 1, jsplt
500	zjdom = zjdom + ijpjtl(1,jj) - nrecjl
501	END DO
502	IF(lwp) WRITE(numout,*)' sum ijpitl(1,j) = ', zjdom, ' jpjglo = ', jpjglo
503	IF(lwp) WRITE(numout,*)
504
505
506	! 2. Index arrays for subdomains
507	! -------------------------------
508
509	iimpptl(:,:) = 1
510	ijmpptl(:,:) = 1
511
512	IF( isplt > 1 ) THEN
513	DO jj = 1, jsplt
514	DO ji = 2, isplt
515	iimpptl(ji,jj) = iimpptl(ji-1,jj) + ijpitl(ji-1,jj) - nrecil
516	END DO
517	END DO
518	ENDIF
519
520	IF( jsplt > 1 ) THEN
521	DO jj = 2, jsplt
522	DO ji = 1, isplt
523	ijmpptl(ji,jj) = ijmpptl(ji,jj-1)+ijpjtl(ji,jj-1)-nrecjl
524	END DO
525	END DO
526	ENDIF
527
528	! 3. Subdomain description
529	! ------------------------
530
531	DO jn = 1, ijsplt
532	ii = 1 + MOD( jn-1, isplt )
533	ij = 1 + (jn-1) / isplt
534	nimpptl(jn) = iimpptl(ii,ij)
535	njmpptl(jn) = ijmpptl(ii,ij)
536	jpiallp(jn) = ijpitl (ii,ij)
537	ipil = jpiallp(jn)
538	jpjallp(jn) = ijpjtl (ii,ij)
539	ipjl = jpjallp(jn)
540	nbondjl = -1 ! general case
541	IF( jn > isplt ) nbondjl = 0 ! first row of processor
542	IF( jn > (jsplt-1)*isplt ) nbondjl = 1 ! last row of processor
543	IF( jsplt == 1 ) nbondjl = 2 ! one processor only in j-direction
544	ibonjtl(jn) = nbondjl
545
546	nbondil = 0 !
547	IF( MOD( jn, isplt ) == 1 ) nbondil = -1 !
548	IF( MOD( jn, isplt ) == 0 ) nbondil = 1 !
549	IF( isplt == 1 ) nbondil = 2 ! one processor only in i-direction
550	ibonitl(jn) = nbondil
551
552	Nis0l = 1 + nn_hls
553	Nie0l = ipil - nn_hls
554	IF( nbondil == -1 .OR. nbondil == 2 ) Nis0l = 1
555	IF( nbondil == 1 .OR. nbondil == 2 ) Nie0l = ipil
556	Njs0l = 1 + nn_hls
557	Nje0l = ipjl - nn_hls
558	IF( nbondjl == -1 .OR. nbondjl == 2 ) Njs0l = 1
559	IF( nbondjl == 1 .OR. nbondjl == 2 ) Nje0l = ipjl
560	nis0allp(jn) = Nis0l
561	nie0allp(jn) = Nie0l
562	njs0allp(jn) = Njs0l
563	nje0allp(jn) = Nje0l
564	END DO
565	!
566	! Save processor layout in layout_prtctl.dat file
567	IF(lwp) THEN
568	CALL ctl_opn( inum, 'layout_prtctl.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea )
569	WRITE(inum,'(a)') 'nproc ipil ipjl Nis0l Njs0l Nie0l Nje0l nimpptl njmpptl ibonitl ibonjtl'
570	!
571	DO jn = 1, ijsplt
572	WRITE(inum,'(i5,6i6,4i8)') jn-1, jpiallp(jn), jpjallp(jn), &
573	& nis0allp(jn), njs0allp(jn), &
574	& nie0allp(jn), nje0allp(jn), &
575	& nimpptl(jn), njmpptl(jn), &
576	& ibonitl(jn), ibonjtl(jn)
577	END DO
578	CLOSE(inum)
579	END IF
580	!
581	!
582	END SUBROUTINE sub_dom
583
584	!!======================================================================
585	END MODULE prtctl

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

Download in other formats: