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 branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/IOM – NEMO

Context Navigation

source: branches/2012/dev_MERGE_2012/NEMOGCM/NEMO/OPA_SRC/IOM/prtctl.F90 @ 3680

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

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

Download in other formats: