Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

prtctl_trc.F90 @ 11738

Last change on this file since 11738 was 11738, checked in by marc, 5 years ago
The Dr Hook changes from my perl code.
File size: 15.4 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	USE prtctl ! print control for OPA
20
21	USE yomhook, ONLY: lhook, dr_hook
22	USE parkind1, ONLY: jprb, jpim
23
24	IMPLICIT NONE
25	PRIVATE
26
27	INTEGER , DIMENSION(:), ALLOCATABLE :: numid_trc !: logical unit
28	INTEGER , DIMENSION(:), ALLOCATABLE :: nlditl , nldjtl !: first, last indoor index for each i-domain
29	INTEGER , DIMENSION(:), ALLOCATABLE :: nleitl , nlejtl !: first, last indoor index for each j-domain
30	INTEGER , DIMENSION(:), ALLOCATABLE :: nimpptl, njmpptl !: i-, j-indexes for each processor
31	INTEGER , DIMENSION(:), ALLOCATABLE :: nlcitl , nlcjtl !: dimensions of every subdomain
32	INTEGER , DIMENSION(:), ALLOCATABLE :: ibonitl, ibonjtl
33
34	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: tra_ctl !: previous trend values
35
36	PUBLIC prt_ctl_trc ! called by all subroutines
37	PUBLIC prt_ctl_trc_info !
38	PUBLIC prt_ctl_trc_init ! called by opa.F90
39
40	CONTAINS
41
42	SUBROUTINE prt_ctl_trc( tab4d, mask, clinfo, ovlap, kdim, clinfo2 )
43	!!----------------------------------------------------------------------
44	!! * ROUTINE prt_ctl *
45	!!
46	!! ** Purpose : - print sum control 3D arrays over the same area
47	!! in mono and mpp case. This way can be usefull when
48	!! debugging a new parametrization in mono or mpp.
49	!!
50	!! ** Method : 2 possibilities exist when setting the ln_ctl parameter to
51	!! .true. in the ocean namelist:
52	!! - to debug a MPI run .vs. a mono-processor one;
53	!! the control print will be done over each sub-domain.
54	!! The nictl[se] and njctl[se] parameters in the namelist must
55	!! be set to zero and [ij]splt to the corresponding splitted
56	!! domain in MPI along respectively i-, j- directions.
57	!! - to debug a mono-processor run over the whole domain/a specific area;
58	!! in the first case the nictl[se] and njctl[se] parameters must be set
59	!! to zero else to the indices of the area to be controled. In both cases
60	!! isplt and jsplt must be set to 1.
61	!! - All arguments of the above calling sequence are optional so their
62	!! name must be explicitly typed if used. For instance if the mask
63	!! array tmask(:,:,:) must be passed through the prt_ctl subroutine,
64	!! it must looks like: CALL prt_ctl( mask=tmask ).
65	!!----------------------------------------------------------------------
66	REAL(wp) , DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: tab4d ! 4D array
67	REAL(wp) , DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask ! 3D mask to apply to the tab4d array
68	CHARACTER (len=*), DIMENSION(:) , INTENT(in), OPTIONAL :: clinfo ! information about the tab3d array
69	CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo2 ! ???
70	INTEGER , INTENT(in), OPTIONAL :: ovlap ! overlap value
71	INTEGER , INTENT(in), OPTIONAL :: kdim ! k- direction for 4D arrays
72	!!
73	INTEGER :: overlap, jn, js, sind, eind, kdir, j_id
74	REAL(wp) :: zsum, zvctl
75	CHARACTER (len=20), DIMENSION(jptra) :: cl
76	CHARACTER (len=10) :: cl2
77	REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask, ztab3d
78	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
79	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
80	REAL(KIND=jprb) :: zhook_handle
81
82	CHARACTER(LEN=*), PARAMETER :: RoutineName='PRT_CTL_TRC'
83
84	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
85
86	!!----------------------------------------------------------------------
87
88	CALL wrk_alloc( jpi, jpj, jpk, zmask, ztab3d )
89	! ! Arrays, scalars initialization
90	overlap = 0
91	kdir = jpkm1
92	zsum = 0.e0
93	zvctl = 0.e0
94	cl(:) = ''
95	cl2 = ''
96	ztab3d(:,:,:) = 0.e0
97	zmask (:,:,:) = 1.e0
98
99	! ! Control of optional arguments
100	IF( PRESENT(ovlap) ) overlap = ovlap
101	IF( PRESENT(kdim) ) kdir = kdim
102	IF( PRESENT(clinfo ) ) cl(:) = clinfo(:)
103	IF( PRESENT(clinfo2) ) cl2 = clinfo2
104	IF( PRESENT(mask) ) zmask (:,:,:) = mask(:,:,:)
105
106	IF( lk_mpp ) THEN ! processor number
107	sind = narea
108	eind = narea
109	ELSE ! processors total number
110	sind = 1
111	eind = ijsplt
112	ENDIF
113
114	! Loop over each sub-domain, i.e. the total number of processors ijsplt
115	DO js = sind, eind
116	!
117	! Set logical unit
118	j_id = numid_trc( js - narea + 1 )
119	! Set indices for the SUM control
120	IF( .NOT. lsp_area ) THEN
121	IF (lk_mpp ) THEN
122	nictls = MAX( 1, nlditl(js) - overlap )
123	nictle = nleitl(js) + overlap * MIN( 1, nlcitl(js) - nleitl(js))
124	njctls = MAX( 1, nldjtl(js) - overlap )
125	njctle = nlejtl(js) + overlap * MIN( 1, nlcjtl(js) - nlejtl(js))
126	! Do not take into account the bound of the domain
127	IF( ibonitl(js) == -1 .OR. ibonitl(js) == 2 ) nictls = MAX( 2, nictls )
128	IF( ibonitl(js) == 1 .OR. ibonitl(js) == 2 ) nictle = MIN( nictle, nleitl(js) - 1 )
129	IF( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 ) njctls = MAX( 2, njctls )
130	IF( ibonjtl(js) == 1 .OR. ibonjtl(js) == 2 ) njctle = MIN( njctle, nlejtl(js) - 1 )
131	ELSE
132	nictls = MAX( 1, nimpptl(js) + nlditl(js) - 1 - overlap )
133	nictle = nimpptl(js) + nleitl(js) - 1 + overlap * MIN( 1, nlcitl(js) - nleitl(js) )
134	njctls = MAX( 1, njmpptl(js) + nldjtl(js) - 1 - overlap )
135	njctle = njmpptl(js) + nlejtl(js) - 1 + overlap * MIN( 1, nlcjtl(js) - nlejtl(js) )
136	! Do not take into account the bound of the domain
137	IF( ibonitl(js) == -1 .OR. ibonitl(js) == 2 ) nictls = MAX( 2, nictls )
138	IF( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 ) njctls = MAX( 2, njctls )
139	IF( ibonitl(js) == 1 .OR. ibonitl(js) == 2 ) nictle = MIN( nictle, nimpptl(js) + nleitl(js) - 2 )
140	IF( ibonjtl(js) == 1 .OR. ibonjtl(js) == 2 ) njctle = MIN( njctle, njmpptl(js) + nlejtl(js) - 2 )
141	ENDIF
142	ENDIF
143	!
144	IF( PRESENT(clinfo2) ) THEN
145	DO jn = 1, jptra
146	zvctl = tra_ctl(jn,js)
147	ztab3d(:,:,:) = tab4d(:,:,:,jn)
148	zsum = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir) &
149	& * zmask(nictls:nictle,njctls:njctle,1:kdir) )
150	WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum-zvctl
151	tra_ctl(jn,js) = zsum
152	END DO
153	ELSE
154	DO jn = 1, jptra
155	ztab3d(:,:,:) = tab4d(:,:,:,jn)
156	zsum = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir) &
157	& * zmask(nictls:nictle,njctls:njctle,1:kdir) )
158	WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum
159	END DO
160	ENDIF
161	!
162	END DO
163	!
164	CALL wrk_dealloc( jpi, jpj, jpk, zmask, ztab3d )
165	!
166	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
167	END SUBROUTINE prt_ctl_trc
168
169
170	SUBROUTINE prt_ctl_trc_info( clinfo )
171	!!----------------------------------------------------------------------
172	!! * ROUTINE prt_ctl_trc_info *
173	!!
174	!! ** Purpose : - print information without any computation
175	!!----------------------------------------------------------------------
176	CHARACTER (len=*), INTENT(in) :: clinfo ! information to print
177	!!
178	INTEGER :: js, sind, eind, j_id
179	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
180	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
181	REAL(KIND=jprb) :: zhook_handle
182
183	CHARACTER(LEN=*), PARAMETER :: RoutineName='PRT_CTL_TRC_INFO'
184
185	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
186
187	!!----------------------------------------------------------------------
188
189	IF( lk_mpp ) THEN ! processor number
190	sind = narea
191	eind = narea
192	ELSE ! total number of processors
193	sind = 1
194	eind = ijsplt
195	ENDIF
196
197	! Loop over each sub-domain, i.e. number of processors ijsplt
198	DO js = sind, eind
199	j_id = numid_trc(js - narea + 1)
200	WRITE(j_id,*) clinfo
201	END DO
202	!
203	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
204	END SUBROUTINE prt_ctl_trc_info
205
206
207	SUBROUTINE prt_ctl_trc_init
208	!!----------------------------------------------------------------------
209	!! * ROUTINE prt_ctl_trc_init *
210	!!
211	!! ** Purpose : open ASCII files & compute indices
212	!!----------------------------------------------------------------------
213	INTEGER :: js, sind, eind, j_id
214	CHARACTER (len=31) :: clfile_out
215	CHARACTER (len=27) :: clb_name
216	CHARACTER (len=19) :: cl_run
217	INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
218	INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
219	REAL(KIND=jprb) :: zhook_handle
220
221	CHARACTER(LEN=*), PARAMETER :: RoutineName='PRT_CTL_TRC_INIT'
222
223	IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
224
225	!!----------------------------------------------------------------------
226
227	! ! Allocate arrays
228	ALLOCATE( nlditl (ijsplt) )
229	ALLOCATE( nldjtl (ijsplt) )
230	ALLOCATE( nleitl (ijsplt) )
231	ALLOCATE( nlejtl (ijsplt) )
232	ALLOCATE( nimpptl(ijsplt) )
233	ALLOCATE( njmpptl(ijsplt) )
234	ALLOCATE( nlcitl (ijsplt) )
235	ALLOCATE( nlcjtl (ijsplt) )
236	ALLOCATE( tra_ctl(jptra,ijsplt) )
237	ALLOCATE( ibonitl(ijsplt) )
238	ALLOCATE( ibonjtl(ijsplt) )
239
240	tra_ctl(:,:) = 0.e0 ! Initialization to zero
241
242	IF( lk_mpp ) THEN
243	sind = narea
244	eind = narea
245	clb_name = "('mpp.top.output_',I3.3)"
246	cl_run = 'MULTI processor run'
247	! use indices for each area computed by mpp_init subroutine
248	nlditl(1:jpnij) = nldit(:)
249	nleitl(1:jpnij) = nleit(:)
250	nldjtl(1:jpnij) = nldjt(:)
251	nlejtl(1:jpnij) = nlejt(:)
252	!
253	nimpptl(1:jpnij) = nimppt(:)
254	njmpptl(1:jpnij) = njmppt(:)
255	!
256	nlcitl(1:jpnij) = nlcit(:)
257	nlcjtl(1:jpnij) = nlcjt(:)
258	!
259	ibonitl(1:jpnij) = ibonit(:)
260	ibonjtl(1:jpnij) = ibonjt(:)
261	ELSE
262	sind = 1
263	eind = ijsplt
264	clb_name = "('mono.top.output_',I3.3)"
265	cl_run = 'MONO processor run '
266	! compute indices for each area as done in mpp_init subroutine
267	CALL sub_dom
268	ENDIF
269
270	ALLOCATE( numid_trc(eind-sind+1) )
271
272	DO js = sind, eind
273	WRITE(clfile_out,FMT=clb_name) js-1
274	CALL ctl_opn( numid_trc(js -narea + 1), clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. )
275	j_id = numid_trc(js -narea + 1)
276	WRITE(j_id,*)
277	WRITE(j_id,*) ' L O D Y C - I P S L'
278	WRITE(j_id,*) ' N E M 0 '
279	WRITE(j_id,*) ' Ocean General Circulation Model'
280	WRITE(j_id,*) ' version TOP 1.0 (2005) '
281	WRITE(j_id,*)
282	WRITE(j_id,*) ' PROC number: ', js
283	WRITE(j_id,*)
284	WRITE(j_id,FMT="(19x,a20)") cl_run
285
286	! Print the SUM control indices
287	IF( .NOT. lsp_area ) THEN
288	IF ( lk_mpp ) THEN
289	nictls = nlditl(js)
290	nictle = nleitl(js)
291	njctls = nldjtl(js)
292	njctle = nlejtl(js)
293	ELSE
294	nictls = nimpptl(js) + nlditl(js) - 1
295	nictle = nimpptl(js) + nleitl(js) - 1
296	njctls = njmpptl(js) + nldjtl(js) - 1
297	njctle = njmpptl(js) + nlejtl(js) - 1
298	ENDIF
299	ENDIF
300	WRITE(j_id,*)
301	WRITE(j_id,*) 'prt_tra_ctl : Sum control indices'
302	WRITE(j_id,*) '~~~~~~~'
303	WRITE(j_id,*)
304	WRITE(j_id,9000)' nlej = ', nlejtl(js), ' '
305	WRITE(j_id,9000)' ------------- njctle = ', njctle, ' -------------'
306	WRITE(j_id,9001)' \| \|'
307	WRITE(j_id,9001)' \| \|'
308	WRITE(j_id,9001)' \| \|'
309	WRITE(j_id,9002)' nictls = ', nictls, ' nictle = ', nictle
310	WRITE(j_id,9002)' nldi = ', nlditl(js), ' nlei = ', nleitl(js)
311	WRITE(j_id,9001)' \| \|'
312	WRITE(j_id,9001)' \| \|'
313	WRITE(j_id,9001)' \| \|'
314	WRITE(j_id,9004)' njmpp = ',njmpptl(js),' ------------- njctls = ', njctls, ' -------------'
315	WRITE(j_id,9003)' nimpp = ', nimpptl(js), ' nldj = ', nldjtl(js), ' '
316	WRITE(j_id,*)
317	WRITE(j_id,*)
318
319	9000 FORMAT(a41,i4.4,a14)
320	9001 FORMAT(a59)
321	9002 FORMAT(a20,i4.4,a36,i3.3)
322	9003 FORMAT(a20,i4.4,a17,i4.4)
323	9004 FORMAT(a11,i4.4,a26,i4.4,a14)
324	END DO
325	!
326	IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
327	END SUBROUTINE prt_ctl_trc_init
328
329	#else
330	!!----------------------------------------------------------------------
331	!! Dummy module : NO passive tracer
332	!!----------------------------------------------------------------------
333	#endif
334
335	!!----------------------------------------------------------------------
336	!! NEMO/TOP 3.3 , NEMO Consortium (2010)
337	!! $Id$
338	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
339	!!======================================================================
340	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/UKMO/dev_r5518_GO6_under_ice_relax_dr_hook/NEMOGCM/NEMO/TOP_SRC/prtctl_trc.F90 @ 11738

Download in other formats: