Context Navigation

prtctl_trc.F90 @ 2704

Last change on this file since 2704 was 2704, checked in by cetlod, 13 years ago
Used correct working arrays in print control routines used for debugging : prtctl.F90 & prtctl_trc.F90
Property svn:keywords set to `Id`
File size: 20.2 KB

Line
1	MODULE prtctl_trc
2	!!======================================================================
3	!! * MODULE prtctl_trc *
4	!! TOP : print all SUM trends for each processor domain
5	!!======================================================================
6	!! History : - ! 2005-07 (C. Talandier) original code for OPA
7	!! 1.0 ! 2005-10 (C. Ethe ) adapted to passive tracer
8	!!----------------------------------------------------------------------
9	#if defined key_top
10	!!----------------------------------------------------------------------
11	!! 'key_top' TOP models
12	!!----------------------------------------------------------------------
13	!! prt_ctl_trc : control print in mpp for passive tracers
14	!! prt_ctl_trc_info : ???
15	!! prt_ctl_trc_init : ???
16	!!----------------------------------------------------------------------
17	USE par_trc ! TOP parameters
18	USE oce_trc ! ocean space and time domain variables
19
20	IMPLICIT NONE
21	PRIVATE
22
23	INTEGER , DIMENSION(:), ALLOCATABLE :: numid_trc !: logical unit
24	INTEGER , DIMENSION(:), ALLOCATABLE :: nlditl , nldjtl !: first, last indoor index for each i-domain
25	INTEGER , DIMENSION(:), ALLOCATABLE :: nleitl , nlejtl !: first, last indoor index for each j-domain
26	INTEGER , DIMENSION(:), ALLOCATABLE :: nimpptl, njmpptl !: i-, j-indexes for each processor
27	INTEGER , DIMENSION(:), ALLOCATABLE :: nlcitl , nlcjtl !: dimensions of every subdomain
28	INTEGER , DIMENSION(:), ALLOCATABLE :: ibonitl, ibonjtl
29
30	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: tra_ctl !: previous trend values
31
32	PUBLIC prt_ctl_trc ! called by all subroutines
33	PUBLIC prt_ctl_trc_info !
34	PUBLIC prt_ctl_trc_init ! called by opa.F90
35
36	CONTAINS
37
38	SUBROUTINE prt_ctl_trc( tab4d, mask, clinfo, ovlap, kdim, clinfo2 )
39	!!----------------------------------------------------------------------
40	!! * ROUTINE prt_ctl *
41	!!
42	!! ** Purpose : - print sum control 3D arrays over the same area
43	!! in mono and mpp case. This way can be usefull when
44	!! debugging a new parametrization in mono or mpp.
45	!!
46	!! ** Method : 2 possibilities exist when setting the ln_ctl parameter to
47	!! .true. in the ocean namelist:
48	!! - to debug a MPI run .vs. a mono-processor one;
49	!! the control print will be done over each sub-domain.
50	!! The nictl[se] and njctl[se] parameters in the namelist must
51	!! be set to zero and [ij]splt to the corresponding splitted
52	!! domain in MPI along respectively i-, j- directions.
53	!! - to debug a mono-processor run over the whole domain/a specific area;
54	!! in the first case the nictl[se] and njctl[se] parameters must be set
55	!! to zero else to the indices of the area to be controled. In both cases
56	!! isplt and jsplt must be set to 1.
57	!! - All arguments of the above calling sequence are optional so their
58	!! name must be explicitly typed if used. For instance if the mask
59	!! array tmask(:,:,:) must be passed through the prt_ctl subroutine,
60	!! it must looks like: CALL prt_ctl( mask=tmask ).
61	!!----------------------------------------------------------------------
62	REAL(wp) , DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: tab4d ! 4D array
63	REAL(wp) , DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask ! 3D mask to apply to the tab4d array
64	CHARACTER (len=*), DIMENSION(:) , INTENT(in), OPTIONAL :: clinfo ! information about the tab3d array
65	CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo2 ! ???
66	INTEGER , INTENT(in), OPTIONAL :: ovlap ! overlap value
67	INTEGER , INTENT(in), OPTIONAL :: kdim ! k- direction for 4D arrays
68	!!
69	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zmask, ztab3d
70	INTEGER :: overlap, jn, js, sind, eind, kdir, j_id
71	REAL(wp) :: zsum, zvctl
72	CHARACTER (len=20), DIMENSION(jptra) :: cl
73	CHARACTER (len=10) :: cl2
74	!!----------------------------------------------------------------------
75
76	ALLOCATE( zmask (jpi,jpj,jpk) )
77	ALLOCATE( ztab3d(jpi,jpj,jpk) )
78	! ! Arrays, scalars initialization
79	overlap = 0
80	kdir = jpkm1
81	zsum = 0.e0
82	zvctl = 0.e0
83	cl(:) = ''
84	cl2 = ''
85	ztab3d(:,:,:) = 0.e0
86	zmask (:,:,:) = 1.e0
87
88	! ! Control of optional arguments
89	IF( PRESENT(ovlap) ) overlap = ovlap
90	IF( PRESENT(kdim) ) kdir = kdim
91	IF( PRESENT(clinfo ) ) cl(:) = clinfo(:)
92	IF( PRESENT(clinfo2) ) cl2 = clinfo2
93	IF( PRESENT(mask) ) zmask (:,:,:) = mask(:,:,:)
94
95	IF( lk_mpp ) THEN ! processor number
96	sind = narea
97	eind = narea
98	ELSE ! processors total number
99	sind = 1
100	eind = ijsplt
101	ENDIF
102
103	! Loop over each sub-domain, i.e. the total number of processors ijsplt
104	DO js = sind, eind
105	!
106	! Set logical unit
107	j_id = numid_trc( js - narea + 1 )
108	! Set indices for the SUM control
109	IF( .NOT. lsp_area ) THEN
110	IF (lk_mpp ) THEN
111	nictls = MAX( 1, nlditl(js) - overlap )
112	nictle = nleitl(js) + overlap * MIN( 1, nlcitl(js) - nleitl(js))
113	njctls = MAX( 1, nldjtl(js) - overlap )
114	njctle = nlejtl(js) + overlap * MIN( 1, nlcjtl(js) - nlejtl(js))
115	! Do not take into account the bound of the domain
116	IF( ibonitl(js) == -1 .OR. ibonitl(js) == 2 ) nictls = MAX( 2, nictls )
117	IF( ibonitl(js) == 1 .OR. ibonitl(js) == 2 ) nictle = MIN( nictle, nleitl(js) - 1 )
118	IF( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 ) njctls = MAX( 2, njctls )
119	IF( ibonjtl(js) == 1 .OR. ibonjtl(js) == 2 ) njctle = MIN( njctle, nlejtl(js) - 1 )
120	ELSE
121	nictls = MAX( 1, nimpptl(js) + nlditl(js) - 1 - overlap )
122	nictle = nimpptl(js) + nleitl(js) - 1 + overlap * MIN( 1, nlcitl(js) - nleitl(js) )
123	njctls = MAX( 1, njmpptl(js) + nldjtl(js) - 1 - overlap )
124	njctle = njmpptl(js) + nlejtl(js) - 1 + overlap * MIN( 1, nlcjtl(js) - nlejtl(js) )
125	! Do not take into account the bound of the domain
126	IF( ibonitl(js) == -1 .OR. ibonitl(js) == 2 ) nictls = MAX( 2, nictls )
127	IF( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 ) njctls = MAX( 2, njctls )
128	IF( ibonitl(js) == 1 .OR. ibonitl(js) == 2 ) nictle = MIN( nictle, nimpptl(js) + nleitl(js) - 2 )
129	IF( ibonjtl(js) == 1 .OR. ibonjtl(js) == 2 ) njctle = MIN( njctle, njmpptl(js) + nlejtl(js) - 2 )
130	ENDIF
131	ENDIF
132	!
133	IF( PRESENT(clinfo2) ) THEN
134	DO jn = 1, jptra
135	zvctl = tra_ctl(jn,js)
136	ztab3d(:,:,:) = tab4d(:,:,:,jn)
137	zsum = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir) &
138	& * zmask(nictls:nictle,njctls:njctle,1:kdir) )
139	WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum-zvctl
140	tra_ctl(jn,js) = zsum
141	END DO
142	ELSE
143	DO jn = 1, jptra
144	ztab3d(:,:,:) = tab4d(:,:,:,jn)
145	zsum = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir) &
146	& * zmask(nictls:nictle,njctls:njctle,1:kdir) )
147	WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum
148	END DO
149	ENDIF
150	!
151	END DO
152	!
153	DEALLOCATE( zmask )
154	DEALLOCATE( ztab3d )
155	!
156	END SUBROUTINE prt_ctl_trc
157
158
159	SUBROUTINE prt_ctl_trc_info( clinfo )
160	!!----------------------------------------------------------------------
161	!! * ROUTINE prt_ctl_trc_info *
162	!!
163	!! ** Purpose : - print information without any computation
164	!!----------------------------------------------------------------------
165	CHARACTER (len=*), INTENT(in) :: clinfo ! information to print
166	!!
167	INTEGER :: js, sind, eind, j_id
168	!!----------------------------------------------------------------------
169
170	IF( lk_mpp ) THEN ! processor number
171	sind = narea
172	eind = narea
173	ELSE ! total number of processors
174	sind = 1
175	eind = ijsplt
176	ENDIF
177
178	! Loop over each sub-domain, i.e. number of processors ijsplt
179	DO js = sind, eind
180	j_id = numid_trc(js - narea + 1)
181	WRITE(j_id,*) clinfo
182	END DO
183	!
184	END SUBROUTINE prt_ctl_trc_info
185
186
187	SUBROUTINE prt_ctl_trc_init
188	!!----------------------------------------------------------------------
189	!! * ROUTINE prt_ctl_trc_init *
190	!!
191	!! ** Purpose : open ASCII files & compute indices
192	!!----------------------------------------------------------------------
193	INTEGER :: js, sind, eind, j_id
194	CHARACTER (len=31) :: clfile_out
195	CHARACTER (len=27) :: clb_name
196	CHARACTER (len=19) :: cl_run
197	!!----------------------------------------------------------------------
198
199	! ! Allocate arrays
200	ALLOCATE( nlditl (ijsplt) )
201	ALLOCATE( nldjtl (ijsplt) )
202	ALLOCATE( nleitl (ijsplt) )
203	ALLOCATE( nlejtl (ijsplt) )
204	ALLOCATE( nimpptl(ijsplt) )
205	ALLOCATE( njmpptl(ijsplt) )
206	ALLOCATE( nlcitl (ijsplt) )
207	ALLOCATE( nlcjtl (ijsplt) )
208	ALLOCATE( tra_ctl(jptra,ijsplt) )
209	ALLOCATE( ibonitl(ijsplt) )
210	ALLOCATE( ibonjtl(ijsplt) )
211
212	tra_ctl(:,:) = 0.e0 ! Initialization to zero
213
214	IF( lk_mpp ) THEN
215	sind = narea
216	eind = narea
217	clb_name = "('mpp.top.output_',I3.3)"
218	cl_run = 'MULTI processor run'
219	! use indices for each area computed by mpp_init subroutine
220	nlditl(:) = nldit(:)
221	nleitl(:) = nleit(:)
222	nldjtl(:) = nldjt(:)
223	nlejtl(:) = nlejt(:)
224	!
225	nimpptl(:) = nimppt(:)
226	njmpptl(:) = njmppt(:)
227	!
228	nlcitl(:) = nlcit(:)
229	nlcjtl(:) = nlcjt(:)
230	!
231	ibonitl(:) = ibonit(:)
232	ibonjtl(:) = ibonjt(:)
233	ELSE
234	sind = 1
235	eind = ijsplt
236	clb_name = "('mono.top.output_',I3.3)"
237	cl_run = 'MONO processor run '
238	! compute indices for each area as done in mpp_init subroutine
239	CALL sub_dom
240	ENDIF
241
242	ALLOCATE( numid_trc(eind-sind+1) )
243
244	DO js = sind, eind
245	WRITE(clfile_out,FMT=clb_name) js-1
246	CALL ctl_opn( numid_trc(js -narea + 1), clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
247	j_id = numid_trc(js -narea + 1)
248	WRITE(j_id,*)
249	WRITE(j_id,*) ' L O D Y C - I P S L'
250	WRITE(j_id,*) ' N E M 0 '
251	WRITE(j_id,*) ' Ocean General Circulation Model'
252	WRITE(j_id,*) ' version TOP 1.0 (2005) '
253	WRITE(j_id,*)
254	WRITE(j_id,*) ' PROC number: ', js
255	WRITE(j_id,*)
256	WRITE(j_id,FMT="(19x,a20)") cl_run
257
258	! Print the SUM control indices
259	IF( .NOT. lsp_area ) THEN
260	IF ( lk_mpp ) THEN
261	nictls = nlditl(js)
262	nictle = nleitl(js)
263	njctls = nldjtl(js)
264	njctle = nlejtl(js)
265	ELSE
266	nictls = nimpptl(js) + nlditl(js) - 1
267	nictle = nimpptl(js) + nleitl(js) - 1
268	njctls = njmpptl(js) + nldjtl(js) - 1
269	njctle = njmpptl(js) + nlejtl(js) - 1
270	ENDIF
271	ENDIF
272	WRITE(j_id,*)
273	WRITE(j_id,*) 'prt_tra_ctl : Sum control indices'
274	WRITE(j_id,*) '~~~~~~~'
275	WRITE(j_id,*)
276	WRITE(j_id,9000)' nlej = ', nlejtl(js), ' '
277	WRITE(j_id,9000)' ------------- njctle = ', njctle, ' -------------'
278	WRITE(j_id,9001)' \| \|'
279	WRITE(j_id,9001)' \| \|'
280	WRITE(j_id,9001)' \| \|'
281	WRITE(j_id,9002)' nictls = ', nictls, ' nictle = ', nictle
282	WRITE(j_id,9002)' nldi = ', nlditl(js), ' nlei = ', nleitl(js)
283	WRITE(j_id,9001)' \| \|'
284	WRITE(j_id,9001)' \| \|'
285	WRITE(j_id,9001)' \| \|'
286	WRITE(j_id,9004)' njmpp = ',njmpptl(js),' ------------- njctls = ', njctls, ' -------------'
287	WRITE(j_id,9003)' nimpp = ', nimpptl(js), ' nldj = ', nldjtl(js), ' '
288	WRITE(j_id,*)
289	WRITE(j_id,*)
290
291	9000 FORMAT(a41,i4.4,a14)
292	9001 FORMAT(a59)
293	9002 FORMAT(a20,i4.4,a36,i3.3)
294	9003 FORMAT(a20,i4.4,a17,i4.4)
295	9004 FORMAT(a11,i4.4,a26,i4.4,a14)
296	END DO
297	!
298	END SUBROUTINE prt_ctl_trc_init
299
300
301	SUBROUTINE sub_dom
302	!!----------------------------------------------------------------------
303	!! * ROUTINE sub_dom *
304	!!
305	!! ** Purpose : Lay out the global domain over processors.
306	!! CAUTION:
307	!! This part has been extracted from the mpp_init
308	!! subroutine and names of variables/arrays have been
309	!! slightly changed to avoid confusion but the computation
310	!! is exactly the same. Any modification about indices of
311	!! each sub-domain in the mppini.F90 module should be reported
312	!! here.
313	!!
314	!! ** Method : Global domain is distributed in smaller local domains.
315	!! Periodic condition is a function of the local domain position
316	!! (global boundary or neighbouring domain) and of the global
317	!! periodic
318	!! Type : jperio global periodic condition
319	!! nperio local periodic condition
320	!!
321	!! ** Action : - set domain parameters
322	!! nimpp : longitudinal index
323	!! njmpp : latitudinal index
324	!! nperio : lateral condition type
325	!! narea : number for local area
326	!! nlcil : first dimension
327	!! nlcjl : second dimension
328	!! nbondil : mark for "east-west local boundary"
329	!! nbondjl : mark for "north-south local boundary"
330	!!----------------------------------------------------------------------
331	INTEGER :: ji, jj, js ! dummy loop indices
332	INTEGER :: ii, ij ! temporary integers
333	INTEGER :: irestil, irestjl ! " "
334	INTEGER :: ijpi , ijpj, nlcil ! temporary logical unit
335	INTEGER :: nlcjl , nbondil, nbondjl
336	INTEGER :: nrecil, nrecjl, nldil, nleil, nldjl, nlejl
337	REAL(wp) :: zidom, zjdom ! temporary scalars
338	INTEGER, DIMENSION(:,:), ALLOCATABLE :: iimpptl, ijmpptl, ilcitl, ilcjtl ! temporary workspace
339	!!----------------------------------------------------------------------
340
341	! Dimension arrays for subdomains
342	! -------------------------------
343	! Computation of local domain sizes ilcitl() ilcjtl()
344	! These dimensions depend on global sizes isplt,jsplt and jpiglo,jpjglo
345	! The subdomains are squares leeser than or equal to the global
346	! dimensions divided by the number of processors minus the overlap
347	! array (cf. par_oce.F90).
348
349	ijpi = ( jpiglo-2jpreci + (isplt-1) ) / isplt + 2jpreci
350	ijpj = ( jpjglo-2jprecj + (jsplt-1) ) / jsplt + 2jprecj
351
352	ALLOCATE( ilcitl (isplt,jsplt) )
353	ALLOCATE( ilcjtl (isplt,jsplt) )
354
355	nrecil = 2 * jpreci
356	nrecjl = 2 * jprecj
357	irestil = MOD( jpiglo - nrecil , isplt )
358	irestjl = MOD( jpjglo - nrecjl , jsplt )
359
360	IF( irestil == 0 ) irestil = isplt
361	DO jj = 1, jsplt
362	DO ji = 1, irestil
363	ilcitl(ji,jj) = ijpi
364	END DO
365	DO ji = irestil+1, isplt
366	ilcitl(ji,jj) = ijpi -1
367	END DO
368	END DO
369
370	IF( irestjl == 0 ) irestjl = jsplt
371	DO ji = 1, isplt
372	DO jj = 1, irestjl
373	ilcjtl(ji,jj) = ijpj
374	END DO
375	DO jj = irestjl+1, jsplt
376	ilcjtl(ji,jj) = ijpj -1
377	END DO
378	END DO
379
380	zidom = nrecil
381	DO ji = 1, isplt
382	zidom = zidom + ilcitl(ji,1) - nrecil
383	END DO
384
385	zjdom = nrecjl
386	DO jj = 1, jsplt
387	zjdom = zjdom + ilcjtl(1,jj) - nrecjl
388	END DO
389
390	! Index arrays for subdomains
391	! ---------------------------
392
393	ALLOCATE( iimpptl(isplt,jsplt) )
394	ALLOCATE( ijmpptl(isplt,jsplt) )
395
396	iimpptl(:,:) = 1
397	ijmpptl(:,:) = 1
398
399	IF( isplt > 1 ) THEN
400	DO jj = 1, jsplt
401	DO ji = 2, isplt
402	iimpptl(ji,jj) = iimpptl(ji-1,jj) + ilcitl(ji-1,jj) - nrecil
403	END DO
404	END DO
405	ENDIF
406
407	IF( jsplt > 1 ) THEN
408	DO jj = 2, jsplt
409	DO ji = 1, isplt
410	ijmpptl(ji,jj) = ijmpptl(ji,jj-1)+ilcjtl(ji,jj-1)-nrecjl
411	END DO
412	END DO
413	ENDIF
414
415	! Subdomain description
416	! ---------------------
417
418	DO js = 1, ijsplt
419	ii = 1 + MOD( js-1, isplt )
420	ij = 1 + (js-1) / isplt
421	nimpptl(js) = iimpptl(ii,ij)
422	njmpptl(js) = ijmpptl(ii,ij)
423	nlcitl (js) = ilcitl (ii,ij)
424	nlcil = nlcitl (js)
425	nlcjtl (js) = ilcjtl (ii,ij)
426	nlcjl = nlcjtl (js)
427	nbondjl = -1 ! general case
428	IF( js > isplt ) nbondjl = 0 ! first row of processor
429	IF( js > (jsplt-1)*isplt ) nbondjl = 1 ! last row of processor
430	IF( jsplt == 1 ) nbondjl = 2 ! one processor only in j-direction
431	ibonjtl(js) = nbondjl
432
433	nbondil = 0 !
434	IF( MOD( js, isplt ) == 1 ) nbondil = -1 !
435	IF( MOD( js, isplt ) == 0 ) nbondil = 1 !
436	IF( isplt == 1 ) nbondil = 2 ! one processor only in i-direction
437	ibonitl(js) = nbondil
438
439	nldil = 1 + jpreci
440	nleil = nlcil - jpreci
441	IF( nbondil == -1 .OR. nbondil == 2 ) nldil = 1
442	IF( nbondil == 1 .OR. nbondil == 2 ) nleil = nlcil
443	nldjl = 1 + jprecj
444	nlejl = nlcjl - jprecj
445	IF( nbondjl == -1 .OR. nbondjl == 2 ) nldjl = 1
446	IF( nbondjl == 1 .OR. nbondjl == 2 ) nlejl = nlcjl
447	nlditl(js) = nldil
448	nleitl(js) = nleil
449	nldjtl(js) = nldjl
450	nlejtl(js) = nlejl
451	END DO
452
453	DEALLOCATE( iimpptl )
454	DEALLOCATE( ijmpptl )
455	DEALLOCATE( ilcitl )
456	DEALLOCATE( ilcjtl )
457	!
458	END SUBROUTINE sub_dom
459
460	#else
461	!!----------------------------------------------------------------------
462	!! Dummy module : NO passive tracer
463	!!----------------------------------------------------------------------
464	#endif
465
466	!!----------------------------------------------------------------------
467	!! NEMO/TOP 3.3 , NEMO Consortium (2010)
468	!! $Id$
469	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
470	!!======================================================================
471	END MODULE prtctl_trc

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

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

Context Navigation

source: branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/TOP_SRC/prtctl_trc.F90 @ 2704

Download in other formats: