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/UKMO/dev_r12745_HPC-02_Daley_Tiling_trial_public/src/OCE/IOM – NEMO

Context Navigation

source: NEMO/branches/UKMO/dev_r12745_HPC-02_Daley_Tiling_trial_public/src/OCE/IOM/prtctl.F90 @ 12943

Last change on this file since 12943 was 12943, checked in by hadcv, 4 years ago
Merge changes from dev_r12866_HPC-02_Daley_Tiling_trial_extra_halo
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 :: nlditl , nldjtl ! first, last indoor index for each i-domain
21	INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nleitl , nlejtl ! 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 :: nlcitl , nlcjtl ! 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	! TODO: TO BE TILED
97	IF( ntile /= 0 .AND. ntile /= nijtile ) RETURN
98
99	! Arrays, scalars initialization
100	kdir = jpkm1
101	cl2 = ''
102	zsum1 = 0.e0
103	zsum2 = 0.e0
104	zvctl1 = 0.e0
105	zvctl2 = 0.e0
106	ztab2d_1(:,:) = 0.e0
107	ztab2d_2(:,:) = 0.e0
108	ztab3d_1(:,:,:) = 0.e0
109	ztab3d_2(:,:,:) = 0.e0
110	zmask1 (:,:,:) = 1.e0
111	zmask2 (:,:,:) = 1.e0
112
113	! Control of optional arguments
114	IF( PRESENT(clinfo2) ) cl2 = clinfo2
115	IF( PRESENT(kdim) ) kdir = kdim
116	IF( PRESENT(tab2d_1) ) ztab2d_1(:,:) = tab2d_1(:,:)
117	IF( PRESENT(tab2d_2) ) ztab2d_2(:,:) = tab2d_2(:,:)
118	IF( PRESENT(tab3d_1) ) ztab3d_1(:,:,1:kdir) = tab3d_1(:,:,1:kdir)
119	IF( PRESENT(tab3d_2) ) ztab3d_2(:,:,1:kdir) = tab3d_2(:,:,1:kdir)
120	IF( PRESENT(mask1) ) zmask1 (:,:,:) = mask1 (:,:,:)
121	IF( PRESENT(mask2) ) zmask2 (:,:,:) = mask2 (:,:,:)
122
123	IF( lk_mpp .AND. jpnij > 1 ) THEN ! processor number
124	sind = narea
125	eind = narea
126	ELSE ! processors total number
127	sind = 1
128	eind = ijsplt
129	ENDIF
130
131	! Loop over each sub-domain, i.e. the total number of processors ijsplt
132	DO jn = sind, eind
133	! Set logical unit
134	j_id = numid(jn - narea + 1)
135	! Set indices for the SUM control
136	IF( .NOT. lsp_area ) THEN
137	IF (lk_mpp .AND. jpnij > 1) THEN
138	nictls = MAX( 1, nlditl(jn) )
139	nictle = MIN(jpi, nleitl(jn) )
140	njctls = MAX( 1, nldjtl(jn) )
141	njctle = MIN(jpj, nlejtl(jn) )
142	! Do not take into account the bound of the domain
143	IF( ibonitl(jn) == -1 .OR. ibonitl(jn) == 2 ) nictls = MAX(2, nictls)
144	IF( ibonjtl(jn) == -1 .OR. ibonjtl(jn) == 2 ) njctls = MAX(2, njctls)
145	IF( ibonitl(jn) == 1 .OR. ibonitl(jn) == 2 ) nictle = MIN(nictle, nleitl(jn) - 1)
146	IF( ibonjtl(jn) == 1 .OR. ibonjtl(jn) == 2 ) njctle = MIN(njctle, nlejtl(jn) - 1)
147	ELSE
148	nictls = MAX( 1, nimpptl(jn) - 1 + nlditl(jn) )
149	nictle = MIN(jpi, nimpptl(jn) - 1 + nleitl(jn) )
150	njctls = MAX( 1, njmpptl(jn) - 1 + nldjtl(jn) )
151	njctle = MIN(jpj, njmpptl(jn) - 1 + nlejtl(jn) )
152	! Do not take into account the bound of the domain
153	IF( ibonitl(jn) == -1 .OR. ibonitl(jn) == 2 ) nictls = MAX(2, nictls)
154	IF( ibonjtl(jn) == -1 .OR. ibonjtl(jn) == 2 ) njctls = MAX(2, njctls)
155	IF( ibonitl(jn) == 1 .OR. ibonitl(jn) == 2 ) nictle = MIN(nictle, nimpptl(jn) + nleitl(jn) - 2)
156	IF( ibonjtl(jn) == 1 .OR. ibonjtl(jn) == 2 ) njctle = MIN(njctle, njmpptl(jn) + nlejtl(jn) - 2)
157	ENDIF
158	ENDIF
159
160	IF( PRESENT(clinfo3)) THEN
161	IF ( clinfo3 == 'tra' ) THEN
162	zvctl1 = t_ctll(jn)
163	zvctl2 = s_ctll(jn)
164	ELSEIF ( clinfo3 == 'dyn' ) THEN
165	zvctl1 = u_ctll(jn)
166	zvctl2 = v_ctll(jn)
167	ENDIF
168	ENDIF
169
170	! Compute the sum control
171	! 2D arrays
172	IF( PRESENT(tab2d_1) ) THEN
173	zsum1 = SUM( ztab2d_1(nictls:nictle,njctls:njctle)*zmask1(nictls:nictle,njctls:njctle,1) )
174	zsum2 = SUM( ztab2d_2(nictls:nictle,njctls:njctle)*zmask2(nictls:nictle,njctls:njctle,1) )
175	ENDIF
176
177	! 3D arrays
178	IF( PRESENT(tab3d_1) ) THEN
179	zsum1 = SUM( ztab3d_1(nictls:nictle,njctls:njctle,1:kdir)*zmask1(nictls:nictle,njctls:njctle,1:kdir) )
180	zsum2 = SUM( ztab3d_2(nictls:nictle,njctls:njctle,1:kdir)*zmask2(nictls:nictle,njctls:njctle,1:kdir) )
181	ENDIF
182
183	! Print the result
184	IF( PRESENT(clinfo3) ) THEN
185	WRITE(j_id,FMT='(a,D23.16,3x,a,D23.16)')clinfo1, zsum1-zvctl1, cl2, zsum2-zvctl2
186	SELECT CASE( clinfo3 )
187	CASE ( 'tra-ta' )
188	t_ctll(jn) = zsum1
189	CASE ( 'tra' )
190	t_ctll(jn) = zsum1
191	s_ctll(jn) = zsum2
192	CASE ( 'dyn' )
193	u_ctll(jn) = zsum1
194	v_ctll(jn) = zsum2
195	END SELECT
196	ELSEIF ( PRESENT(clinfo2) .OR. PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN
197	WRITE(j_id,FMT='(a,D23.16,3x,a,D23.16)')clinfo1, zsum1, cl2, zsum2
198	ELSE
199	WRITE(j_id,FMT='(a,D23.16)')clinfo1, zsum1
200	ENDIF
201
202	ENDDO
203	!
204	END SUBROUTINE prt_ctl
205
206
207	SUBROUTINE prt_ctl_info (clinfo1, ivar1, clinfo2, ivar2, itime)
208	!!----------------------------------------------------------------------
209	!! * ROUTINE prt_ctl_info *
210	!!
211	!! ** Purpose : - print information without any computation
212	!!
213	!! ** Action : - input arguments
214	!! clinfo1 : information about the ivar1
215	!! ivar1 : value to print
216	!! clinfo2 : information about the ivar2
217	!! ivar2 : value to print
218	!!----------------------------------------------------------------------
219	CHARACTER (len=*), INTENT(in) :: clinfo1
220	INTEGER , INTENT(in), OPTIONAL :: ivar1
221	CHARACTER (len=*), INTENT(in), OPTIONAL :: clinfo2
222	INTEGER , INTENT(in), OPTIONAL :: ivar2
223	INTEGER , INTENT(in), OPTIONAL :: itime
224	!
225	INTEGER :: jn, sind, eind, iltime, j_id
226	!!----------------------------------------------------------------------
227
228	IF( lk_mpp .AND. jpnij > 1 ) THEN ! processor number
229	sind = narea
230	eind = narea
231	ELSE ! total number of processors
232	sind = 1
233	eind = ijsplt
234	ENDIF
235
236	! Set to zero arrays at each new time step
237	IF( PRESENT(itime) ) THEN
238	iltime = itime
239	IF( iltime > ktime ) THEN
240	t_ctll(:) = 0.e0 ; s_ctll(:) = 0.e0
241	u_ctll(:) = 0.e0 ; v_ctll(:) = 0.e0
242	ktime = iltime
243	ENDIF
244	ENDIF
245
246	! Loop over each sub-domain, i.e. number of processors ijsplt
247	DO jn = sind, eind
248	!
249	j_id = numid(jn - narea + 1) ! Set logical unit
250	!
251	IF( PRESENT(ivar1) .AND. PRESENT(clinfo2) .AND. PRESENT(ivar2) ) THEN
252	WRITE(j_id,*)clinfo1, ivar1, clinfo2, ivar2
253	ELSEIF ( PRESENT(ivar1) .AND. PRESENT(clinfo2) .AND. .NOT. PRESENT(ivar2) ) THEN
254	WRITE(j_id,*)clinfo1, ivar1, clinfo2
255	ELSEIF ( PRESENT(ivar1) .AND. .NOT. PRESENT(clinfo2) .AND. PRESENT(ivar2) ) THEN
256	WRITE(j_id,*)clinfo1, ivar1, ivar2
257	ELSEIF ( PRESENT(ivar1) .AND. .NOT. PRESENT(clinfo2) .AND. .NOT. PRESENT(ivar2) ) THEN
258	WRITE(j_id,*)clinfo1, ivar1
259	ELSE
260	WRITE(j_id,*)clinfo1
261	ENDIF
262	!
263	END DO
264	!
265	END SUBROUTINE prt_ctl_info
266
267
268	SUBROUTINE prt_ctl_init
269	!!----------------------------------------------------------------------
270	!! * ROUTINE prt_ctl_init *
271	!!
272	!! ** Purpose : open ASCII files & compute indices
273	!!----------------------------------------------------------------------
274	INTEGER :: jn, sind, eind, j_id
275	CHARACTER (len=28) :: clfile_out
276	CHARACTER (len=23) :: clb_name
277	CHARACTER (len=19) :: cl_run
278	!!----------------------------------------------------------------------
279
280	! Allocate arrays
281	ALLOCATE( nlditl(ijsplt) , nleitl(ijsplt) , nimpptl(ijsplt) , ibonitl(ijsplt) , &
282	& nldjtl(ijsplt) , nlejtl(ijsplt) , njmpptl(ijsplt) , ibonjtl(ijsplt) , &
283	& nlcitl(ijsplt) , t_ctll(ijsplt) , u_ctll (ijsplt) , &
284	& nlcjtl(ijsplt) , s_ctll(ijsplt) , v_ctll (ijsplt) )
285
286	! Initialization
287	t_ctll(:) = 0.e0
288	s_ctll(:) = 0.e0
289	u_ctll(:) = 0.e0
290	v_ctll(:) = 0.e0
291	ktime = 1
292
293	IF( lk_mpp .AND. jpnij > 1 ) THEN
294	sind = narea
295	eind = narea
296	clb_name = "('mpp.output_',I4.4)"
297	cl_run = 'MULTI processor run'
298	! use indices for each area computed by mpp_init subroutine
299	nlditl(1:jpnij) = nldit(:)
300	nleitl(1:jpnij) = nleit(:)
301	nldjtl(1:jpnij) = nldjt(:)
302	nlejtl(1:jpnij) = nlejt(:)
303	!
304	nimpptl(1:jpnij) = nimppt(:)
305	njmpptl(1:jpnij) = njmppt(:)
306	!
307	nlcitl(1:jpnij) = nlcit(:)
308	nlcjtl(1:jpnij) = nlcjt(:)
309	!
310	ibonitl(1:jpnij) = ibonit(:)
311	ibonjtl(1:jpnij) = ibonjt(:)
312	ELSE
313	sind = 1
314	eind = ijsplt
315	clb_name = "('mono.output_',I4.4)"
316	cl_run = 'MONO processor run '
317	! compute indices for each area as done in mpp_init subroutine
318	CALL sub_dom
319	ENDIF
320
321	ALLOCATE( numid(eind-sind+1) )
322
323	DO jn = sind, eind
324	WRITE(clfile_out,FMT=clb_name) jn-1
325	CALL ctl_opn( numid(jn -narea + 1), clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', 1, numout, .FALSE. )
326	j_id = numid(jn -narea + 1)
327	WRITE(j_id,*)
328	WRITE(j_id,*) ' L O D Y C - I P S L'
329	WRITE(j_id,*) ' O P A model'
330	WRITE(j_id,*) ' Ocean General Circulation Model'
331	WRITE(j_id,*) ' version OPA 9.0 (2005) '
332	WRITE(j_id,*)
333	WRITE(j_id,*) ' PROC number: ', jn
334	WRITE(j_id,*)
335	WRITE(j_id,FMT="(19x,a20)")cl_run
336
337	! Print the SUM control indices
338	IF( .NOT. lsp_area ) THEN
339	nictls = nimpptl(jn) + nlditl(jn) - 1
340	nictle = nimpptl(jn) + nleitl(jn) - 1
341	njctls = njmpptl(jn) + nldjtl(jn) - 1
342	njctle = njmpptl(jn) + nlejtl(jn) - 1
343	ENDIF
344	WRITE(j_id,*)
345	WRITE(j_id,*) 'prt_ctl : Sum control indices'
346	WRITE(j_id,*) '~~~~~~~'
347	WRITE(j_id,*)
348	WRITE(j_id,9000)' nlej = ', nlejtl(jn), ' '
349	WRITE(j_id,9000)' ------------- njctle = ', njctle, ' -------------'
350	WRITE(j_id,9001)' \| \|'
351	WRITE(j_id,9001)' \| \|'
352	WRITE(j_id,9001)' \| \|'
353	WRITE(j_id,9002)' nictls = ', nictls, ' nictle = ', nictle
354	WRITE(j_id,9002)' nldi = ', nlditl(jn), ' nlei = ', nleitl(jn)
355	WRITE(j_id,9001)' \| \|'
356	WRITE(j_id,9001)' \| \|'
357	WRITE(j_id,9001)' \| \|'
358	WRITE(j_id,9004)' njmpp = ',njmpptl(jn),' ------------- njctls = ', njctls, ' -------------'
359	WRITE(j_id,9003)' nimpp = ', nimpptl(jn), ' nldj = ', nldjtl(jn), ' '
360	WRITE(j_id,*)
361	WRITE(j_id,*)
362
363	9000 FORMAT(a41,i4.4,a14)
364	9001 FORMAT(a59)
365	9002 FORMAT(a20,i4.4,a36,i3.3)
366	9003 FORMAT(a20,i4.4,a17,i4.4)
367	9004 FORMAT(a11,i4.4,a26,i4.4,a14)
368	END DO
369	!
370	END SUBROUTINE prt_ctl_init
371
372
373	SUBROUTINE sub_dom
374	!!----------------------------------------------------------------------
375	!! * ROUTINE sub_dom *
376	!!
377	!! ** Purpose : Lay out the global domain over processors.
378	!! CAUTION:
379	!! This part has been extracted from the mpp_init
380	!! subroutine and names of variables/arrays have been
381	!! slightly changed to avoid confusion but the computation
382	!! is exactly the same. Any modification about indices of
383	!! each sub-domain in the mppini.F90 module should be reported
384	!! here.
385	!!
386	!! ** Method : Global domain is distributed in smaller local domains.
387	!! Periodic condition is a function of the local domain position
388	!! (global boundary or neighbouring domain) and of the global
389	!! periodic
390	!! Type : jperio global periodic condition
391	!!
392	!! ** Action : - set domain parameters
393	!! nimpp : longitudinal index
394	!! njmpp : latitudinal index
395	!! narea : number for local area
396	!! nlcil : first dimension
397	!! nlcjl : second dimension
398	!! nbondil : mark for "east-west local boundary"
399	!! nbondjl : mark for "north-south local boundary"
400	!!
401	!! History :
402	!! ! 94-11 (M. Guyon) Original code
403	!! ! 95-04 (J. Escobar, M. Imbard)
404	!! ! 98-02 (M. Guyon) FETI method
405	!! ! 98-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI versions
406	!! 8.5 ! 02-08 (G. Madec) F90 : free form
407	!!----------------------------------------------------------------------
408	INTEGER :: ji, jj, jn ! dummy loop indices
409	INTEGER :: &
410	ii, ij, & ! temporary integers
411	irestil, irestjl, & ! " "
412	ijpi , ijpj, nlcil, & ! temporary logical unit
413	nlcjl , nbondil, nbondjl, &
414	nrecil, nrecjl, nldil, nleil, nldjl, nlejl
415
416	INTEGER, DIMENSION(jpi,jpj) :: iimpptl, ijmpptl, ilcitl, ilcjtl ! workspace
417	REAL(wp) :: zidom, zjdom ! temporary scalars
418	INTEGER :: inum ! local logical unit
419	!!----------------------------------------------------------------------
420
421	!
422	!
423	! 1. Dimension arrays for subdomains
424	! -----------------------------------
425	! Computation of local domain sizes ilcitl() ilcjtl()
426	! These dimensions depend on global sizes isplt,jsplt and jpiglo,jpjglo
427	! The subdomains are squares leeser than or equal to the global
428	! dimensions divided by the number of processors minus the overlap
429	! array (cf. par_oce.F90).
430
431	#if defined key_nemocice_decomp
432	ijpi = ( nx_global+2-2nn_hls + (isplt-1) ) / isplt + 2nn_hls
433	ijpj = ( ny_global+2-2nn_hls + (jsplt-1) ) / jsplt + 2nn_hls
434	#else
435	ijpi = ( jpiglo-2nn_hls + (isplt-1) ) / isplt + 2nn_hls
436	ijpj = ( jpjglo-2nn_hls + (jsplt-1) ) / jsplt + 2nn_hls
437	#endif
438
439
440	nrecil = 2 * nn_hls
441	nrecjl = 2 * nn_hls
442	irestil = MOD( jpiglo - nrecil , isplt )
443	irestjl = MOD( jpjglo - nrecjl , jsplt )
444
445	IF( irestil == 0 ) irestil = isplt
446	#if defined key_nemocice_decomp
447
448	! In order to match CICE the size of domains in NEMO has to be changed
449	! The last line of blocks (west) will have fewer points
450	DO jj = 1, jsplt
451	DO ji=1, isplt-1
452	ilcitl(ji,jj) = ijpi
453	END DO
454	ilcitl(isplt,jj) = jpiglo - (isplt - 1) * (ijpi - nrecil)
455	END DO
456
457	#else
458
459	DO jj = 1, jsplt
460	DO ji = 1, irestil
461	ilcitl(ji,jj) = ijpi
462	END DO
463	DO ji = irestil+1, isplt
464	ilcitl(ji,jj) = ijpi -1
465	END DO
466	END DO
467
468	#endif
469
470	IF( irestjl == 0 ) irestjl = jsplt
471	#if defined key_nemocice_decomp
472
473	! Same change to domains in North-South direction as in East-West.
474	DO ji = 1, isplt
475	DO jj=1, jsplt-1
476	ilcjtl(ji,jj) = ijpj
477	END DO
478	ilcjtl(ji,jsplt) = jpjglo - (jsplt - 1) * (ijpj - nrecjl)
479	END DO
480
481	#else
482
483	DO ji = 1, isplt
484	DO jj = 1, irestjl
485	ilcjtl(ji,jj) = ijpj
486	END DO
487	DO jj = irestjl+1, jsplt
488	ilcjtl(ji,jj) = ijpj -1
489	END DO
490	END DO
491
492	#endif
493	zidom = nrecil
494	DO ji = 1, isplt
495	zidom = zidom + ilcitl(ji,1) - nrecil
496	END DO
497	IF(lwp) WRITE(numout,*)
498	IF(lwp) WRITE(numout,*)' sum ilcitl(i,1) = ', zidom, ' jpiglo = ', jpiglo
499
500	zjdom = nrecjl
501	DO jj = 1, jsplt
502	zjdom = zjdom + ilcjtl(1,jj) - nrecjl
503	END DO
504	IF(lwp) WRITE(numout,*)' sum ilcitl(1,j) = ', zjdom, ' jpjglo = ', jpjglo
505	IF(lwp) WRITE(numout,*)
506
507
508	! 2. Index arrays for subdomains
509	! -------------------------------
510
511	iimpptl(:,:) = 1
512	ijmpptl(:,:) = 1
513
514	IF( isplt > 1 ) THEN
515	DO jj = 1, jsplt
516	DO ji = 2, isplt
517	iimpptl(ji,jj) = iimpptl(ji-1,jj) + ilcitl(ji-1,jj) - nrecil
518	END DO
519	END DO
520	ENDIF
521
522	IF( jsplt > 1 ) THEN
523	DO jj = 2, jsplt
524	DO ji = 1, isplt
525	ijmpptl(ji,jj) = ijmpptl(ji,jj-1)+ilcjtl(ji,jj-1)-nrecjl
526	END DO
527	END DO
528	ENDIF
529
530	! 3. Subdomain description
531	! ------------------------
532
533	DO jn = 1, ijsplt
534	ii = 1 + MOD( jn-1, isplt )
535	ij = 1 + (jn-1) / isplt
536	nimpptl(jn) = iimpptl(ii,ij)
537	njmpptl(jn) = ijmpptl(ii,ij)
538	nlcitl (jn) = ilcitl (ii,ij)
539	nlcil = nlcitl (jn)
540	nlcjtl (jn) = ilcjtl (ii,ij)
541	nlcjl = nlcjtl (jn)
542	nbondjl = -1 ! general case
543	IF( jn > isplt ) nbondjl = 0 ! first row of processor
544	IF( jn > (jsplt-1)*isplt ) nbondjl = 1 ! last row of processor
545	IF( jsplt == 1 ) nbondjl = 2 ! one processor only in j-direction
546	ibonjtl(jn) = nbondjl
547
548	nbondil = 0 !
549	IF( MOD( jn, isplt ) == 1 ) nbondil = -1 !
550	IF( MOD( jn, isplt ) == 0 ) nbondil = 1 !
551	IF( isplt == 1 ) nbondil = 2 ! one processor only in i-direction
552	ibonitl(jn) = nbondil
553
554	nldil = 1 + nn_hls
555	nleil = nlcil - nn_hls
556	IF( nbondil == -1 .OR. nbondil == 2 ) nldil = 1
557	IF( nbondil == 1 .OR. nbondil == 2 ) nleil = nlcil
558	nldjl = 1 + nn_hls
559	nlejl = nlcjl - nn_hls
560	IF( nbondjl == -1 .OR. nbondjl == 2 ) nldjl = 1
561	IF( nbondjl == 1 .OR. nbondjl == 2 ) nlejl = nlcjl
562	nlditl(jn) = nldil
563	nleitl(jn) = nleil
564	nldjtl(jn) = nldjl
565	nlejtl(jn) = nlejl
566	END DO
567	!
568	! Save processor layout in layout_prtctl.dat file
569	IF(lwp) THEN
570	CALL ctl_opn( inum, 'layout_prtctl.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea )
571	WRITE(inum,'(a)') 'nproc nlcil nlcjl nldil nldjl nleil nlejl nimpptl njmpptl ibonitl ibonjtl'
572	!
573	DO jn = 1, ijsplt
574	WRITE(inum,'(i5,6i6,4i8)') jn-1,nlcitl(jn), nlcjtl(jn), &
575	& nlditl(jn), nldjtl(jn), &
576	& nleitl(jn), nlejtl(jn), &
577	& nimpptl(jn), njmpptl(jn), &
578	& ibonitl(jn), ibonjtl(jn)
579	END DO
580	CLOSE(inum)
581	END IF
582	!
583	!
584	END SUBROUTINE sub_dom
585
586	!!======================================================================
587	END MODULE prtctl

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

Download in other formats: