Context Navigation

prtctl.F90 @ 15148

Last change on this file since 15148 was 15148, checked in by gsamson, 3 years ago
reintroduce missing 'kdim' argument in 'prt_ctl_t' calls for 3D/4D arrays
Property svn:keywords set to `Id`
File size: 25.4 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	USE domutl, ONLY : is_tile
11	USE in_out_manager ! I/O manager
12	USE mppini ! distributed memory computing
13	USE lib_mpp ! distributed memory computing
14
15	IMPLICIT NONE
16	PRIVATE
17
18	INTEGER , DIMENSION( :), ALLOCATABLE :: numprt_oce, numprt_top
19	INTEGER , DIMENSION( :), ALLOCATABLE :: nall_ictls, nall_ictle ! first, last indoor index for each i-domain
20	INTEGER , DIMENSION( :), ALLOCATABLE :: nall_jctls, nall_jctle ! first, last indoor index for each j-domain
21	REAL(wp), DIMENSION( :), ALLOCATABLE :: t_ctl , s_ctl ! previous tracer trend values
22	REAL(wp), DIMENSION( :), ALLOCATABLE :: u_ctl , v_ctl ! previous velocity trend values
23	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: tra_ctl ! previous top trend values
24	!
25	PUBLIC prt_ctl ! called by all subroutines
26	PUBLIC prt_ctl_info ! called by all subroutines
27	PUBLIC prt_ctl_init ! called by nemogcm.F90 and prt_ctl_trc_init
28
29	!! * Substitutions
30	# include "do_loop_substitute.h90"
31	!!----------------------------------------------------------------------
32	!! NEMO/OCE 4.0 , NEMO Consortium (2018)
33	!! $Id$
34	!! Software governed by the CeCILL license (see ./LICENSE)
35	!!----------------------------------------------------------------------
36	CONTAINS
37
38	SUBROUTINE prt_ctl (tab2d_1, tab3d_1, tab4d_1, tab2d_2, tab3d_2, mask1, mask2, &
39	& clinfo, clinfo1, clinfo2, clinfo3, kdim )
40	!!
41	REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_1
42	REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_1
43	REAL(wp), DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: tab4d_1
44	REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_2
45	REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_2
46	REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask1
47	REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask2
48	CHARACTER(len=*), DIMENSION(:) , INTENT(in), OPTIONAL :: clinfo ! information about the tab3d array
49	CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo1
50	CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo2
51	CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo3
52	INTEGER , INTENT(in), OPTIONAL :: kdim
53	!
54	IF( PRESENT(tab2d_2) ) THEN
55	CALL prt_ctl_t(ktab2d_1 = is_tile(tab2d_1), ktab3d_1 = 0, ktab4d_1 = 0, ktab2d_2 = is_tile(tab2d_2), ktab3d_2 = 0, &
56	& tab2d_1 = REAL(tab2d_1, 2wp), tab2d_2 = REAL(tab2d_2, 2wp), &
57	& mask1 = mask1, mask2 = mask2, &
58	& clinfo = clinfo, clinfo1 = clinfo1, clinfo2 = clinfo2, clinfo3 = clinfo3 )
59	ELSEIF( PRESENT(tab3d_2) ) THEN
60	CALL prt_ctl_t(ktab2d_1 = 0, ktab3d_1 = is_tile(tab3d_1), ktab4d_1 = 0, ktab2d_2 = 0, ktab3d_2 = is_tile(tab3d_2), &
61	& tab3d_1 = REAL(tab3d_1, 2wp), tab3d_2 = REAL(tab3d_2, 2wp), &
62	& mask1 = mask1, mask2 = mask2, &
63	& clinfo = clinfo, clinfo1 = clinfo1, clinfo2 = clinfo2, clinfo3 = clinfo3, kdim = kdim )
64	ELSEIF( PRESENT(tab2d_1) ) THEN
65	CALL prt_ctl_t(ktab2d_1 = is_tile(tab2d_1), ktab3d_1 = 0, ktab4d_1 = 0, ktab2d_2 = 0, ktab3d_2 = 0, &
66	& tab2d_1 = REAL(tab2d_1,2*wp), &
67	& mask1 = mask1, &
68	& clinfo = clinfo, clinfo1 = clinfo1, clinfo3 = clinfo3 )
69	ELSEIF( PRESENT(tab3d_1) ) THEN
70	CALL prt_ctl_t(ktab2d_1 = 0, ktab3d_1 = is_tile(tab3d_1), ktab4d_1 = 0, ktab2d_2 = 0, ktab3d_2 = 0, &
71	& tab3d_1 = REAL(tab3d_1, 2*wp), &
72	& mask1 = mask1, &
73	& clinfo = clinfo, clinfo1 = clinfo1, clinfo3 = clinfo3, kdim = kdim )
74	ELSEIF( PRESENT(tab4d_1) ) THEN
75	CALL prt_ctl_t(ktab2d_1 = 0, ktab3d_1 = 0, ktab4d_1 = is_tile(tab4d_1), ktab2d_2 = 0, ktab3d_2 = 0, &
76	& tab4d_1 = REAL(tab4d_1, 2*wp), &
77	& mask1 = mask1, &
78	& clinfo = clinfo, clinfo1 = clinfo1, clinfo3 = clinfo3, kdim = kdim )
79	ENDIF
80
81	END SUBROUTINE prt_ctl
82
83
84	SUBROUTINE prt_ctl_t (tab2d_1, ktab2d_1, tab3d_1, ktab3d_1, tab4d_1, ktab4d_1, tab2d_2, ktab2d_2, tab3d_2, ktab3d_2, &
85	& mask1, mask2, clinfo, clinfo1, clinfo2, clinfo3, kdim )
86	!!----------------------------------------------------------------------
87	!! * ROUTINE prt_ctl *
88	!!
89	!! ** Purpose : - print sum control of 2D or 3D arrays over the same area
90	!! in mono and mpp case. This way can be usefull when
91	!! debugging a new parametrization in mono or mpp.
92	!!
93	!! ** Method : 2 possibilities exist when setting the sn_cfctl%prtctl parameter to
94	!! .true. in the ocean namelist:
95	!! - to debug a MPI run .vs. a mono-processor one;
96	!! the control print will be done over each sub-domain.
97	!! The nictl[se] and njctl[se] parameters in the namelist must
98	!! be set to zero and [ij]splt to the corresponding splitted
99	!! domain in MPI along respectively i-, j- directions.
100	!! - to debug a mono-processor run over the whole domain/a specific area;
101	!! in the first case the nictl[se] and njctl[se] parameters must be set
102	!! to zero else to the indices of the area to be controled. In both cases
103	!! isplt and jsplt must be set to 1.
104	!! - All arguments of the above calling sequence are optional so their
105	!! name must be explicitly typed if used. For instance if the 3D
106	!! array tn(:,:,:) must be passed through the prt_ctl subroutine,
107	!! it must look like: CALL prt_ctl(tab3d_1=tn).
108	!!
109	!! tab2d_1 : first 2D array
110	!! tab3d_1 : first 3D array
111	!! tab4d_1 : first 4D array
112	!! mask1 : mask (3D) to apply to the tab[23]d_1 array
113	!! clinfo1 : information about the tab[23]d_1 array
114	!! tab2d_2 : second 2D array
115	!! tab3d_2 : second 3D array
116	!! mask2 : mask (3D) to apply to the tab[23]d_2 array
117	!! clinfo2 : information about the tab[23]d_2 array
118	!! kdim : k- direction for 3D arrays
119	!! clinfo3 : additional information
120	!!----------------------------------------------------------------------
121	INTEGER , INTENT(in) :: ktab2d_1, ktab3d_1, ktab4d_1, ktab2d_2, ktab3d_2
122	REAL(2*wp), DIMENSION(A2D_T(ktab2d_1)) , INTENT(in), OPTIONAL :: tab2d_1
123	REAL(2*wp), DIMENSION(A2D_T(ktab3d_1),:) , INTENT(in), OPTIONAL :: tab3d_1
124	REAL(2*wp), DIMENSION(A2D_T(ktab4d_1),:,:), INTENT(in), OPTIONAL :: tab4d_1
125	REAL(2*wp), DIMENSION(A2D_T(ktab2d_2)) , INTENT(in), OPTIONAL :: tab2d_2
126	REAL(2*wp), DIMENSION(A2D_T(ktab3d_2),:) , INTENT(in), OPTIONAL :: tab3d_2
127	REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask1
128	REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask2
129	CHARACTER(len=*), DIMENSION(:) , INTENT(in), OPTIONAL :: clinfo ! information about the tab3d array
130	CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo1
131	CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo2
132	CHARACTER(len=*) , INTENT(in), OPTIONAL :: clinfo3
133	INTEGER , INTENT(in), OPTIONAL :: kdim
134	!
135	CHARACTER(len=30) :: cl1, cl2
136	CHARACTER(len=6) :: clfmt
137	INTEGER :: jn, jl, kdir
138	INTEGER :: iis, iie, jjs, jje
139	INTEGER :: itra, inum
140	REAL(2*wp) :: zsum1, zsum2, zvctl1, zvctl2
141	!!----------------------------------------------------------------------
142	!
143	! Arrays, scalars initialization
144	cl1 = ''
145	cl2 = ''
146	kdir = jpkm1
147	itra = 1
148
149	! Control of optional arguments
150	IF( PRESENT(clinfo1) ) cl1 = clinfo1
151	IF( PRESENT(clinfo2) ) cl2 = clinfo2
152	IF( PRESENT(kdim) ) kdir = kdim
153	IF( PRESENT(tab4d_1) ) itra = SIZE(tab4d_1,dim=4)
154
155	IF( wp == sp ) clfmt = 'D23.16' ! 16 significant numbers
156	IF( wp == dp ) clfmt = 'D41.34' ! 34 significant numbers
157
158	! Loop over each sub-domain, i.e. the total number of processors ijsplt
159	DO jl = 1, SIZE(nall_ictls)
160
161	! define shoter names...
162	iis = MAX( nall_ictls(jl), ntsi )
163	iie = MIN( nall_ictle(jl), ntei )
164	jjs = MAX( nall_jctls(jl), ntsj )
165	jje = MIN( nall_jctle(jl), ntej )
166
167	IF( PRESENT(clinfo) ) THEN ; inum = numprt_top(jl)
168	ELSE ; inum = numprt_oce(jl)
169	ENDIF
170
171	! Compute the sum control only where the tile domain and control print area overlap
172	IF( iie >= iis .AND. jje >= jjs ) THEN
173	DO jn = 1, itra
174
175	IF( PRESENT(clinfo3) ) THEN
176	IF ( clinfo3 == 'tra-ta' ) THEN
177	zvctl1 = t_ctl(jl)
178	ELSEIF( clinfo3 == 'tra' ) THEN
179	zvctl1 = t_ctl(jl)
180	zvctl2 = s_ctl(jl)
181	ELSEIF( clinfo3 == 'dyn' ) THEN
182	zvctl1 = u_ctl(jl)
183	zvctl2 = v_ctl(jl)
184	ELSE
185	zvctl1 = tra_ctl(jn,jl)
186	ENDIF
187	ENDIF
188
189	! 2D arrays
190	IF( PRESENT(tab2d_1) ) THEN
191	IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) * mask1(iis:iie,jjs:jje,1) )
192	ELSE ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) )
193	ENDIF
194	ENDIF
195	IF( PRESENT(tab2d_2) ) THEN
196	IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) * mask2(iis:iie,jjs:jje,1) )
197	ELSE ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) )
198	ENDIF
199	ENDIF
200
201	! 3D arrays
202	IF( PRESENT(tab3d_1) ) THEN
203	IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) * mask1(iis:iie,jjs:jje,1:kdir) )
204	ELSE ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) )
205	ENDIF
206	ENDIF
207	IF( PRESENT(tab3d_2) ) THEN
208	IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) * mask2(iis:iie,jjs:jje,1:kdir) )
209	ELSE ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) )
210	ENDIF
211	ENDIF
212
213	! 4D arrays
214	IF( PRESENT(tab4d_1) ) THEN
215	IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) * mask1(iis:iie,jjs:jje,1:kdir) )
216	ELSE ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) )
217	ENDIF
218	ENDIF
219
220	! Print the result
221	IF( PRESENT(clinfo ) ) cl1 = clinfo(jn)
222	IF( PRESENT(clinfo3) ) THEN
223	!
224	IF( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN
225	WRITE(inum, "(3x,a,' : ',"//clfmt//",3x,a,' : ',"//clfmt//")") cl1, zsum1 - zvctl1, cl2, zsum2 - zvctl2
226	ELSE
227	WRITE(inum, "(3x,a,' : ',"//clfmt//" )") cl1, zsum1 - zvctl1
228	ENDIF
229	!
230	SELECT CASE( clinfo3 )
231	CASE ( 'tra-ta' )
232	t_ctl(jl) = zsum1
233	CASE ( 'tra' )
234	t_ctl(jl) = zsum1
235	s_ctl(jl) = zsum2
236	CASE ( 'dyn' )
237	u_ctl(jl) = zsum1
238	v_ctl(jl) = zsum2
239	CASE default
240	tra_ctl(jn,jl) = zsum1
241	END SELECT
242	ELSEIF ( PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN
243	WRITE(inum, "(3x,a,' : ',"//clfmt//",3x,a,' : ',"//clfmt//")") cl1, zsum1, cl2, zsum2
244	ELSE
245	WRITE(inum, "(3x,a,' : ',"//clfmt//" )") cl1, zsum1
246	ENDIF
247
248	END DO
249	ENDIF
250	END DO
251	!
252	END SUBROUTINE prt_ctl_t
253
254
255	SUBROUTINE prt_ctl_info (clinfo, ivar, cdcomp )
256	!!----------------------------------------------------------------------
257	!! * ROUTINE prt_ctl_info *
258	!!
259	!! ** Purpose : - print information without any computation
260	!!
261	!! ** Action : - input arguments
262	!! clinfo : information about the ivar
263	!! ivar : value to print
264	!!----------------------------------------------------------------------
265	CHARACTER(len=*), INTENT(in) :: clinfo
266	INTEGER , OPTIONAL, INTENT(in) :: ivar
267	CHARACTER(len=3), OPTIONAL, INTENT(in) :: cdcomp ! only 'top' is accepted
268	!
269	CHARACTER(len=3) :: clcomp
270	INTEGER :: jl, inum
271	!!----------------------------------------------------------------------
272	!
273	IF( PRESENT(cdcomp) ) THEN ; clcomp = cdcomp
274	ELSE ; clcomp = 'oce'
275	ENDIF
276	!
277	DO jl = 1, SIZE(nall_ictls)
278	!
279	IF( clcomp == 'oce' ) inum = numprt_oce(jl)
280	IF( clcomp == 'top' ) inum = numprt_top(jl)
281	!
282	IF ( PRESENT(ivar) ) THEN ; WRITE(inum,*) clinfo, ivar
283	ELSE ; WRITE(inum,*) clinfo
284	ENDIF
285	!
286	END DO
287	!
288	END SUBROUTINE prt_ctl_info
289
290
291	SUBROUTINE prt_ctl_init( cdcomp, kntra )
292	!!----------------------------------------------------------------------
293	!! * ROUTINE prt_ctl_init *
294	!!
295	!! ** Purpose : open ASCII files & compute indices
296	!!----------------------------------------------------------------------
297	CHARACTER(len=3), OPTIONAL, INTENT(in ) :: cdcomp ! only 'top' is accepted
298	INTEGER , OPTIONAL, INTENT(in ) :: kntra ! only for 'top': number of tracers
299	!
300	INTEGER :: ji, jj, jl
301	INTEGER :: inum, idg, idg2
302	INTEGER :: ijsplt, iimax, ijmax
303	INTEGER, DIMENSION(:,:), ALLOCATABLE :: iimppt, ijmppt, ijpi, ijpj, iproc
304	INTEGER, DIMENSION( :), ALLOCATABLE :: iipos, ijpos
305	LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llisoce
306	CHARACTER(len=64) :: clfile_out
307	CHARACTER(LEN=64) :: clfmt, clfmt2, clfmt3, clfmt4
308	CHARACTER(len=32) :: clname, cl_run
309	CHARACTER(len= 3) :: clcomp
310	!!----------------------------------------------------------------------
311	!
312	clname = 'output'
313	IF( PRESENT(cdcomp) ) THEN
314	clname = TRIM(clname)//'.'//TRIM(cdcomp)
315	clcomp = cdcomp
316	ELSE
317	clcomp = 'oce'
318	ENDIF
319	!
320	IF( jpnij > 1 ) THEN ! MULTI processor run
321	cl_run = 'MULTI processor run'
322	idg = MAX( INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9
323	WRITE(clfmt, "('(a,i', i1, '.', i1, ')')") idg, idg ! '(a,ix.x)'
324	WRITE(clfile_out,clfmt) 'mpp.'//trim(clname)//'_', narea - 1
325	ijsplt = 1
326	ELSE ! MONO processor run
327	cl_run = 'MONO processor run '
328	IF(lwp) THEN ! control print
329	WRITE(numout,*)
330	WRITE(numout,*) 'prt_ctl_init: sn_cfctl%l_prtctl parameters'
331	WRITE(numout,*) '~~~~~~~~~~~~~'
332	ENDIF
333	IF( nn_ictls+nn_ictle+nn_jctls+nn_jctle == 0 ) THEN ! print control done over the default area
334	nn_isplt = MAX(1, nn_isplt) ! number of processors following i-direction
335	nn_jsplt = MAX(1, nn_jsplt) ! number of processors following j-direction
336	ijsplt = nn_isplt * nn_jsplt ! total number of processors ijsplt
337	IF( ijsplt == 1 ) CALL ctl_warn( 'nn_isplt & nn_jsplt are equal to 1 -> control sum done over the whole domain' )
338	IF(lwp) WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt
339	IF(lwp) WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt
340	idg = MAX( INT(LOG10(REAL(MAX(1,ijsplt-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9
341	WRITE(clfmt, "('(a,i', i1, '.', i1, ')')") idg, idg ! '(a,ix.x)'
342	IF( ijsplt == 1 ) WRITE(clfile_out,clfmt) 'mono.'//trim(clname)//'_', 0
343	ELSE ! print control done over a specific area
344	ijsplt = 1
345	IF( nn_ictls < 1 .OR. nn_ictls > Ni0glo ) THEN
346	CALL ctl_warn( ' - nictls must be 1<=nictls>=Ni0glo, it is forced to 1' )
347	nn_ictls = 1
348	ENDIF
349	IF( nn_ictle < 1 .OR. nn_ictle > Ni0glo ) THEN
350	CALL ctl_warn( ' - nictle must be 1<=nictle>=Ni0glo, it is forced to Ni0glo' )
351	nn_ictle = Ni0glo
352	ENDIF
353	IF( nn_jctls < 1 .OR. nn_jctls > Nj0glo ) THEN
354	CALL ctl_warn( ' - njctls must be 1<=njctls>=Nj0glo, it is forced to 1' )
355	nn_jctls = 1
356	ENDIF
357	IF( nn_jctle < 1 .OR. nn_jctle > Nj0glo ) THEN
358	CALL ctl_warn( ' - njctle must be 1<=njctle>=Nj0glo, it is forced to Nj0glo' )
359	nn_jctle = Nj0glo
360	ENDIF
361	WRITE(numout,*) ' Start i indice for SUM control nn_ictls = ', nn_ictls
362	WRITE(numout,*) ' End i indice for SUM control nn_ictle = ', nn_ictle
363	WRITE(numout,*) ' Start j indice for SUM control nn_jctls = ', nn_jctls
364	WRITE(numout,*) ' End j indice for SUM control nn_jctle = ', nn_jctle
365	idg = MAXVAL( (/ nn_ictls,nn_ictle,nn_jctls,nn_jctle /) ) ! temporary use of idg to store the largest index
366	idg = MAX( INT(LOG10(REAL(idg,wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9
367	WRITE(clfmt, "('(4(a,i', i1, '.', i1, '))')") idg, idg ! '(4(a,ix.x))'
368	WRITE(clfile_out,clfmt) 'mono.'//trim(clname)//'_', nn_ictls, '_', nn_ictle, '_', nn_jctls, '_', nn_jctle
369	ENDIF
370	ENDIF
371
372	! Allocate arrays
373	IF( .NOT. ALLOCATED(nall_ictls) ) ALLOCATE( nall_ictls(ijsplt), nall_ictle(ijsplt), nall_jctls(ijsplt), nall_jctle(ijsplt) )
374
375	IF( jpnij > 1 ) THEN ! MULTI processor run
376	!
377	nall_ictls(1) = Nis0
378	nall_ictle(1) = Nie0
379	nall_jctls(1) = Njs0
380	nall_jctle(1) = Nje0
381	!
382	ELSE ! MONO processor run
383	!
384	IF( nn_ictls+nn_ictle+nn_jctls+nn_jctle == 0 ) THEN ! print control done over the default area
385	!
386	ALLOCATE( iimppt(nn_isplt,nn_jsplt), ijmppt(nn_isplt,nn_jsplt), ijpi(nn_isplt,nn_jsplt), ijpj(nn_isplt,nn_jsplt), &
387	& llisoce(nn_isplt,nn_jsplt), iproc(nn_isplt,nn_jsplt), iipos(nn_ispltnn_jsplt), ijpos(nn_ispltnn_jsplt) )
388	CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, nn_isplt, nn_jsplt, iimax, ijmax, iimppt, ijmppt, ijpi, ijpj )
389	CALL mpp_is_ocean( llisoce )
390	CALL mpp_getnum( llisoce, iproc, iipos, ijpos )
391	!
392	DO jj = 1,nn_jsplt
393	DO ji = 1, nn_isplt
394	jl = iproc(ji,jj) + 1
395	nall_ictls(jl) = iimppt(ji,jj) - 1 + 1 + nn_hls
396	nall_ictle(jl) = iimppt(ji,jj) - 1 + ijpi(ji,jj) - nn_hls
397	nall_jctls(jl) = ijmppt(ji,jj) - 1 + 1 + nn_hls
398	nall_jctle(jl) = ijmppt(ji,jj) - 1 + ijpj(ji,jj) - nn_hls
399	END DO
400	END DO
401	!
402	DEALLOCATE( iimppt, ijmppt, ijpi, ijpj, llisoce, iproc, iipos, ijpos )
403	!
404	ELSE ! print control done over a specific area
405	!
406	nall_ictls(1) = nn_ictls + nn_hls
407	nall_ictle(1) = nn_ictle + nn_hls
408	nall_jctls(1) = nn_jctls + nn_hls
409	nall_jctle(1) = nn_jctle + nn_hls
410	!
411	ENDIF
412	ENDIF
413
414	! Initialization
415	IF( clcomp == 'oce' ) THEN
416	ALLOCATE( t_ctl(ijsplt), s_ctl(ijsplt), u_ctl(ijsplt), v_ctl(ijsplt), numprt_oce(ijsplt) )
417	t_ctl(:) = 0.e0
418	s_ctl(:) = 0.e0
419	u_ctl(:) = 0.e0
420	v_ctl(:) = 0.e0
421	ENDIF
422	IF( clcomp == 'top' ) THEN
423	ALLOCATE( tra_ctl(kntra,ijsplt), numprt_top(ijsplt) )
424	tra_ctl(:,:) = 0.e0
425	ENDIF
426
427	DO jl = 1,ijsplt
428
429	IF( ijsplt > 1 ) WRITE(clfile_out,clfmt) 'mono.'//trim(clname)//'_', jl-1
430
431	CALL ctl_opn( inum, clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', 1, numout, .FALSE. )
432	IF( clcomp == 'oce' ) numprt_oce(jl) = inum
433	IF( clcomp == 'top' ) numprt_top(jl) = inum
434	WRITE(inum,*)
435	WRITE(inum,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - CMCC'
436	WRITE(inum,*) ' NEMO team'
437	WRITE(inum,*) ' Ocean General Circulation Model'
438	IF( clcomp == 'oce' ) WRITE(inum,*) ' NEMO version 4.x (2020) '
439	IF( clcomp == 'top' ) WRITE(inum,*) ' TOP vversion x (2020) '
440	WRITE(inum,*)
441	IF( ijsplt > 1 ) &
442	& WRITE(inum,*) ' MPI-subdomain number: ', jl-1
443	IF( jpnij > 1 ) &
444	& WRITE(inum,*) ' MPI-subdomain number: ', narea-1
445	WRITE(inum,*)
446	WRITE(inum,'(19x,a20)') cl_run
447	WRITE(inum,*)
448	WRITE(inum,*) 'prt_ctl : Sum control indices'
449	WRITE(inum,*) '~~~~~~~'
450	WRITE(inum,*)
451	!
452	! clfmt2: ' ----- jctle = XXX (YYY) -----' -> '(18x, 13a1, a9, iM, a2, iN, a2, 13a1)'
453	! clfmt3: ' \| \|' -> '(18x, a1, Nx, a1)'
454	! clfmt4: ' ictls = XXX (YYY) ictle = XXX (YYY)' -> '(Nx, a9, iM, a2, iP, a2, Qx, a9, iM, a2, iP, a2)'
455	! ' \| \|'
456	! ' ----- jctle = XXX (YYY) -----'
457	! clfmt5: ' njmpp = XXX' -> '(Nx, a9, iM)'
458	! clfmt6: ' nimpp = XXX' -> '(Nx, a9, iM)'
459	!
460	idg = MAXVAL( (/ nall_ictls(jl), nall_ictle(jl), nall_jctls(jl), nall_jctle(jl) /) ) ! temporary use of idg
461	idg = INT(LOG10(REAL(idg,wp))) + 1 ! how many digits do we use?
462	idg2 = MAXVAL( (/ mig0(nall_ictls(jl)), mig0(nall_ictle(jl)), mjg0(nall_jctls(jl)), mjg0(nall_jctle(jl)) /) )
463	idg2 = INT(LOG10(REAL(idg2,wp))) + 1 ! how many digits do we use?
464	WRITE(clfmt2, "('(18x, 13a1, a9, i', i1, ', a2, i',i1,', a2, 13a1)')") idg, idg2
465	WRITE(clfmt3, "('(18x, a1, ', i2,'x, a1)')") 13+9+idg+2+idg2+2+13 - 2
466	WRITE(clfmt4, "('(', i2,'x, a9, i', i1,', a2, i', i1,', a2, ', i2,'x, a9, i', i1,', a2, i', i1,', a2)')") &
467	& 18-7, idg, idg2, 13+9+idg+2+idg2+2+13 - (2+idg+2+idg2+2+8), idg, idg2
468	WRITE(inum,clfmt2) ('-', ji=1,13), ' jctle = ', nall_jctle(jl), ' (', mjg0(nall_jctle(jl)), ') ', ('-', ji=1,13)
469	WRITE(inum,clfmt3) '\|', '\|'
470	WRITE(inum,clfmt3) '\|', '\|'
471	WRITE(inum,clfmt3) '\|', '\|'
472	WRITE(inum,clfmt4) ' ictls = ', nall_ictls(jl), ' (', mig0(nall_ictls(jl)), ') ', &
473	& ' ictle = ', nall_ictle(jl), ' (', mig0(nall_ictle(jl)), ') '
474	WRITE(inum,clfmt3) '\|', '\|'
475	WRITE(inum,clfmt3) '\|', '\|'
476	WRITE(inum,clfmt3) '\|', '\|'
477	WRITE(inum,clfmt2) ('-', ji=1,13), ' jctls = ', nall_jctls(jl), ' (', mjg0(nall_jctls(jl)), ') ', ('-', ji=1,13)
478	WRITE(inum,*)
479	WRITE(inum,*)
480	!
481	END DO
482	!
483	END SUBROUTINE prt_ctl_init
484
485
486	!!======================================================================
487	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: NEMO/trunk/src/OCE/IOM/prtctl.F90 @ 15148

Download in other formats: