Context Navigation

prtctl.F90

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

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_r5518_GO6_package_text_diagnostics/NEMOGCM/NEMO/OPA_SRC/IOM/prtctl.F90

Download in other formats: