Home

Context Navigation

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

Last change on this file since 420 was 410, checked in by letzel, 15 years ago
reintegrate branch letzel/masked_output into trunk; new funtionality: masked data output (not yet documented)
Property svn:keywords set to `Id`
File size: 15.3 KB

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