Home

Context Navigation

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

Last change on this file since 757 was 668, checked in by suehring, 14 years ago
last commit documented
Property svn:keywords set to `Id`
File size: 15.2 KB

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |