Home

Context Navigation

source: palm/trunk/SOURCE/data_output_mask.f90 @ 505

Last change on this file since 505 was 494, checked in by raasch, 15 years ago
last commit documented; configuration example file for netcdf4 added
Property svn:keywords set to `Id`
File size: 14.9 KB

Line
1	SUBROUTINE data_output_mask( av )
2
3	!------------------------------------------------------------------------------!
4	! Current revisions:
5	! -----------------
6	!
7	!
8	! Former revisions:
9	! -----------------
10	! $Id: data_output_mask.f90 494 2010-03-01 12:23:32Z raasch $
11	!
12	! 493 2010-03-01 08:30:24Z raasch
13	! netcdf_format_mask* and format_parallel_io replaced by netcdf_data_format
14	!
15	! 475 2010-02-04 02:26:16Z raasch
16	! Bugfix in serial branch: arguments from array local_pf removed in N90_PUT_VAR
17	!
18	! 410 2009-12-04 17:05:40Z letzel
19	! Initial version
20	!
21	! Description:
22	! ------------
23	! Masked data output in NetCDF format for current mask (current value of mid).
24	!------------------------------------------------------------------------------!
25
26	#if defined( __netcdf )
27	USE arrays_3d
28	USE averaging
29	USE cloud_parameters
30	USE control_parameters
31	USE cpulog
32	USE grid_variables
33	USE indices
34	USE interfaces
35	USE netcdf
36	USE netcdf_control
37	USE particle_attributes
38	USE pegrid
39
40	IMPLICIT NONE
41
42	INTEGER :: av, ngp, file_id, i, if, is, j, k, l, n, psi, s, sender, &
43	ind(6)
44	LOGICAL :: found, resorted
45	REAL :: mean_r, s_r3, s_r4
46	REAL, DIMENSION(:,:,:), ALLOCATABLE :: local_pf
47	#if defined( __parallel )
48	REAL, DIMENSION(:,:,:), ALLOCATABLE :: total_pf
49	#endif
50	REAL, DIMENSION(:,:,:), POINTER :: to_be_resorted
51
52	!
53	!-- Return, if nothing to output
54	IF ( domask_no(mid,av) == 0 ) RETURN
55
56	CALL cpu_log (log_point(49),'data_output_mask','start')
57
58	!
59	!-- Open output file.
60	IF ( netcdf_output .AND. ( myid == 0 .OR. netcdf_data_format > 2 ) ) &
61	THEN
62	CALL check_open( 120+mid+av*max_masks )
63	ENDIF
64
65	!
66	!-- Allocate total and local output arrays.
67	#if defined( __parallel )
68	IF ( myid == 0 ) THEN
69	ALLOCATE( total_pf(mask_size(mid,1),mask_size(mid,2),mask_size(mid,3)) )
70	ENDIF
71	#endif
72	ALLOCATE( local_pf(mask_size_l(mid,1),mask_size_l(mid,2), &
73	mask_size_l(mid,3)) )
74
75	!
76	!-- Update the NetCDF time axis.
77	domask_time_count(mid,av) = domask_time_count(mid,av) + 1
78	IF ( netcdf_output .AND. ( myid == 0 .OR. netcdf_data_format > 2 ) ) &
79	THEN
80	nc_stat = NF90_PUT_VAR( id_set_mask(mid,av), id_var_time_mask(mid,av), &
81	(/ simulated_time /), &
82	start = (/ domask_time_count(mid,av) /), &
83	count = (/ 1 /) )
84	CALL handle_netcdf_error( 'data_output_mask', 9998 )
85	ENDIF
86
87	!
88	!-- Loop over all variables to be written.
89	if = 1
90
91	DO WHILE ( domask(mid,av,if)(1:1) /= ' ' )
92	!
93	!-- Reallocate local_pf on PE 0 since its shape changes during MPI exchange
94	IF ( netcdf_data_format < 3 .AND. myid == 0 .AND. if > 1 ) THEN
95	DEALLOCATE( local_pf )
96	ALLOCATE( local_pf(mask_size_l(mid,1),mask_size_l(mid,2), &
97	mask_size_l(mid,3)) )
98	ENDIF
99	!
100	!-- Store the variable chosen.
101	resorted = .FALSE.
102	SELECT CASE ( TRIM( domask(mid,av,if) ) )
103
104	CASE ( 'e' )
105	IF ( av == 0 ) THEN
106	to_be_resorted => e
107	ELSE
108	to_be_resorted => e_av
109	ENDIF
110
111	CASE ( 'p' )
112	IF ( av == 0 ) THEN
113	to_be_resorted => p
114	ELSE
115	to_be_resorted => p_av
116	ENDIF
117
118	CASE ( 'pc' ) ! particle concentration (requires ghostpoint exchange)
119	IF ( av == 0 ) THEN
120	tend = prt_count
121	CALL exchange_horiz( tend )
122	DO i = 1, mask_size_l(mid,1)
123	DO j = 1, mask_size_l(mid,2)
124	DO k = 1, mask_size_l(mid,3)
125	local_pf(i,j,k) = tend(mask_k(mid,k), &
126	mask_j(mid,j),mask_i(mid,i))
127	ENDDO
128	ENDDO
129	ENDDO
130	resorted = .TRUE.
131	ELSE
132	CALL exchange_horiz( pc_av )
133	to_be_resorted => pc_av
134	ENDIF
135
136	CASE ( 'pr' ) ! mean particle radius
137	IF ( av == 0 ) THEN
138	DO i = nxl, nxr
139	DO j = nys, nyn
140	DO k = nzb, nzt+1
141	psi = prt_start_index(k,j,i)
142	s_r3 = 0.0
143	s_r4 = 0.0
144	DO n = psi, psi+prt_count(k,j,i)-1
145	s_r3 = s_r3 + particles(n)%radius**3
146	s_r4 = s_r4 + particles(n)%radius**4
147	ENDDO
148	IF ( s_r3 /= 0.0 ) THEN
149	mean_r = s_r4 / s_r3
150	ELSE
151	mean_r = 0.0
152	ENDIF
153	tend(k,j,i) = mean_r
154	ENDDO
155	ENDDO
156	ENDDO
157	CALL exchange_horiz( tend )
158	DO i = 1, mask_size_l(mid,1)
159	DO j = 1, mask_size_l(mid,2)
160	DO k = 1, mask_size_l(mid,3)
161	local_pf(i,j,k) = tend(mask_k(mid,k), &
162	mask_j(mid,j),mask_i(mid,i))
163	ENDDO
164	ENDDO
165	ENDDO
166	resorted = .TRUE.
167	ELSE
168	CALL exchange_horiz( pr_av )
169	to_be_resorted => pr_av
170	ENDIF
171
172	CASE ( 'pt' )
173	IF ( av == 0 ) THEN
174	IF ( .NOT. cloud_physics ) THEN
175	to_be_resorted => pt
176	ELSE
177	DO i = 1, mask_size_l(mid,1)
178	DO j = 1, mask_size_l(mid,2)
179	DO k = 1, mask_size_l(mid,3)
180	local_pf(i,j,k) = &
181	pt(mask_k(mid,k),mask_j(mid,j),mask_i(mid,i)) &
182	+ l_d_cp * pt_d_t(mask_k(mid,k)) * &
183	ql(mask_k(mid,k),mask_j(mid,j),mask_i(mid,i))
184	ENDDO
185	ENDDO
186	ENDDO
187	resorted = .TRUE.
188	ENDIF
189	ELSE
190	to_be_resorted => pt_av
191	ENDIF
192
193	CASE ( 'q' )
194	IF ( av == 0 ) THEN
195	to_be_resorted => q
196	ELSE
197	to_be_resorted => q_av
198	ENDIF
199
200	CASE ( 'ql' )
201	IF ( av == 0 ) THEN
202	to_be_resorted => ql
203	ELSE
204	to_be_resorted => ql_av
205	ENDIF
206
207	CASE ( 'ql_c' )
208	IF ( av == 0 ) THEN
209	to_be_resorted => ql_c
210	ELSE
211	to_be_resorted => ql_c_av
212	ENDIF
213
214	CASE ( 'ql_v' )
215	IF ( av == 0 ) THEN
216	to_be_resorted => ql_v
217	ELSE
218	to_be_resorted => ql_v_av
219	ENDIF
220
221	CASE ( 'ql_vp' )
222	IF ( av == 0 ) THEN
223	to_be_resorted => ql_vp
224	ELSE
225	to_be_resorted => ql_vp_av
226	ENDIF
227
228	CASE ( 'qv' )
229	IF ( av == 0 ) THEN
230	DO i = 1, mask_size_l(mid,1)
231	DO j = 1, mask_size_l(mid,2)
232	DO k = 1, mask_size_l(mid,3)
233	local_pf(i,j,k) = &
234	q(mask_k(mid,k),mask_j(mid,j),mask_i(mid,i)) - &
235	ql(mask_k(mid,k),mask_j(mid,j),mask_i(mid,i))
236	ENDDO
237	ENDDO
238	ENDDO
239	resorted = .TRUE.
240	ELSE
241	to_be_resorted => qv_av
242	ENDIF
243
244	CASE ( 'rho' )
245	IF ( av == 0 ) THEN
246	to_be_resorted => rho
247	ELSE
248	to_be_resorted => rho_av
249	ENDIF
250
251	CASE ( 's' )
252	IF ( av == 0 ) THEN
253	to_be_resorted => q
254	ELSE
255	to_be_resorted => s_av
256	ENDIF
257
258	CASE ( 'sa' )
259	IF ( av == 0 ) THEN
260	to_be_resorted => sa
261	ELSE
262	to_be_resorted => sa_av
263	ENDIF
264
265	CASE ( 'u' )
266	IF ( av == 0 ) THEN
267	to_be_resorted => u
268	ELSE
269	to_be_resorted => u_av
270	ENDIF
271
272	CASE ( 'v' )
273	IF ( av == 0 ) THEN
274	to_be_resorted => v
275	ELSE
276	to_be_resorted => v_av
277	ENDIF
278
279	CASE ( 'vpt' )
280	IF ( av == 0 ) THEN
281	to_be_resorted => vpt
282	ELSE
283	to_be_resorted => vpt_av
284	ENDIF
285
286	CASE ( 'w' )
287	IF ( av == 0 ) THEN
288	to_be_resorted => w
289	ELSE
290	to_be_resorted => w_av
291	ENDIF
292
293	CASE DEFAULT
294	!
295	!-- User defined quantity
296	CALL user_data_output_mask(av, domask(mid,av,if), found, local_pf )
297	resorted = .TRUE.
298
299	IF ( .NOT. found ) THEN
300	WRITE ( message_string, * ) 'no output available for: ', &
301	TRIM( domask(mid,av,if) )
302	CALL message( 'data_output_mask', 'PA9998', 0, 0, 0, 6, 0 )
303	ENDIF
304
305	END SELECT
306
307	!
308	!-- Resort the array to be output, if not done above
309	IF ( .NOT. resorted ) THEN
310	DO i = 1, mask_size_l(mid,1)
311	DO j = 1, mask_size_l(mid,2)
312	DO k = 1, mask_size_l(mid,3)
313	local_pf(i,j,k) = to_be_resorted(mask_k(mid,k), &
314	mask_j(mid,j),mask_i(mid,i))
315	ENDDO
316	ENDDO
317	ENDDO
318	ENDIF
319
320	!
321	!-- I/O block. I/O methods are implemented
322	!-- (1) for parallel execution
323	!-- a. with NetCDF 4 parallel I/O-enabled library
324	!-- b. with NetCDF 3 library
325	!-- (2) for serial execution.
326	!-- The choice of method depends on the correct setting of preprocessor
327	!-- directives __parallel and __netcdf4 as well as on the parameter
328	!-- netcdf_data_format.
329	#if defined( __parallel )
330	#if defined( __netcdf4 )
331	IF ( netcdf_data_format > 2 ) THEN
332	!
333	!-- (1) a. Parallel I/O using NetCDF 4 (not yet tested)
334	nc_stat = NF90_PUT_VAR( id_set_mask(mid,av), &
335	id_var_domask(mid,av,if), &
336	local_pf, &
337	start = (/ mask_start_l(mid,1), mask_start_l(mid,2), &
338	mask_start_l(mid,3), domask_time_count(mid,av) /), &
339	count = (/ mask_size_l(mid,1), mask_size_l(mid,2), &
340	mask_size_l(mid,3), 1 /) )
341	CALL handle_netcdf_error( 'data_output_mask', 9998 )
342	ELSE
343	#endif
344	!
345	!-- (1) b. Conventional I/O only through PE0
346	!-- PE0 receives partial arrays from all processors of the respective mask
347	!-- and outputs them. Here a barrier has to be set, because otherwise
348	!-- "-MPI- FATAL: Remote protocol queue full" may occur.
349	CALL MPI_BARRIER( comm2d, ierr )
350
351	ngp = mask_size_l(mid,1) * mask_size_l(mid,2) * mask_size_l(mid,3)
352	IF ( myid == 0 ) THEN
353	!
354	!-- Local array can be relocated directly.
355	total_pf( &
356	mask_start_l(mid,1):mask_start_l(mid,1)+mask_size_l(mid,1)-1, &
357	mask_start_l(mid,2):mask_start_l(mid,2)+mask_size_l(mid,2)-1, &
358	mask_start_l(mid,3):mask_start_l(mid,3)+mask_size_l(mid,3)-1 ) &
359	= local_pf
360	!
361	!-- Receive data from all other PEs.
362	DO n = 1, numprocs-1
363	!
364	!-- Receive index limits first, then array.
365	!-- Index limits are received in arbitrary order from the PEs.
366	CALL MPI_RECV( ind(1), 6, MPI_INTEGER, MPI_ANY_SOURCE, 0, &
367	comm2d, status, ierr )
368	!
369	!-- Not all PEs have data for the mask
370	IF ( ind(1) /= -9999 ) THEN
371	ngp = ( ind(2)-ind(1)+1 ) * (ind(4)-ind(3)+1 ) * &
372	( ind(6)-ind(5)+1 )
373	sender = status(MPI_SOURCE)
374	DEALLOCATE( local_pf )
375	ALLOCATE(local_pf(ind(1):ind(2),ind(3):ind(4),ind(5):ind(6)))
376	CALL MPI_RECV( local_pf(ind(1),ind(3),ind(5)), ngp, &
377	MPI_REAL, sender, 1, comm2d, status, ierr )
378	total_pf(ind(1):ind(2),ind(3):ind(4),ind(5):ind(6)) &
379	= local_pf
380	ENDIF
381	ENDDO
382
383	nc_stat = NF90_PUT_VAR( id_set_mask(mid,av), &
384	id_var_domask(mid,av,if), total_pf, &
385	start = (/ 1, 1, 1, domask_time_count(mid,av) /), &
386	count = (/ mask_size(mid,1), mask_size(mid,2), &
387	mask_size(mid,3), 1 /) )
388	CALL handle_netcdf_error( 'data_output_mask', 9998 )
389
390	ELSE
391	!
392	!-- If at least part of the mask resides on the PE, send the index
393	!-- limits for the target array, otherwise send -9999 to PE0.
394	IF ( mask_size_l(mid,1) > 0 .AND. mask_size_l(mid,2) > 0 .AND. &
395	mask_size_l(mid,3) > 0 ) &
396	THEN
397	ind(1) = mask_start_l(mid,1)
398	ind(2) = mask_start_l(mid,1) + mask_size_l(mid,1) - 1
399	ind(3) = mask_start_l(mid,2)
400	ind(4) = mask_start_l(mid,2) + mask_size_l(mid,2) - 1
401	ind(5) = mask_start_l(mid,3)
402	ind(6) = mask_start_l(mid,3) + mask_size_l(mid,3) - 1
403	ELSE
404	ind(1) = -9999; ind(2) = -9999
405	ind(3) = -9999; ind(4) = -9999
406	ind(5) = -9999; ind(6) = -9999
407	ENDIF
408	CALL MPI_SEND( ind(1), 6, MPI_INTEGER, 0, 0, comm2d, ierr )
409	!
410	!-- If applicable, send data to PE0.
411	IF ( ind(1) /= -9999 ) THEN
412	CALL MPI_SEND( local_pf(1,1,1), ngp, MPI_REAL, 0, 1, comm2d, &
413	ierr )
414	ENDIF
415	ENDIF
416	!
417	!-- A barrier has to be set, because otherwise some PEs may proceed too
418	!-- fast so that PE0 may receive wrong data on tag 0.
419	CALL MPI_BARRIER( comm2d, ierr )
420	#if defined( __netcdf4 )
421	ENDIF
422	#endif
423	#else
424	!
425	!-- (2) For serial execution of PALM, the single processor (PE0) holds all
426	!-- data and writes them directly to file.
427	nc_stat = NF90_PUT_VAR( id_set_mask(mid,av), &
428	id_var_domask(mid,av,if), &
429	local_pf, &
430	start = (/ 1, 1, 1, domask_time_count(mid,av) /), &
431	count = (/ mask_size_l(mid,1), mask_size_l(mid,2), &
432	mask_size_l(mid,3), 1 /) )
433	CALL handle_netcdf_error( 'data_output_mask', 9998 )
434	#endif
435
436	if = if + 1
437	ENDDO
438
439	!
440	!-- Deallocate temporary arrays.
441	DEALLOCATE( local_pf )
442	#if defined( __parallel )
443	IF ( myid == 0 ) THEN
444	DEALLOCATE( total_pf )
445	ENDIF
446	#endif
447
448
449	CALL cpu_log (log_point(49),'data_output_mask','stop','nobarrier')
450	#endif
451
452	END SUBROUTINE data_output_mask

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |