Home

Context Navigation

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

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

Rev	Line
[298]	1	SUBROUTINE data_output_mask( av )
	2
	3	!------------------------------------------------------------------------------!
[484]	4	! Current revisions:
[298]	5	! -----------------
	6	!
	7	! Former revisions:
	8	! -----------------
	9	! $Id: data_output_mask.f90 668 2010-12-23 13:22:58Z raasch $
	10	!
[668]	11	! 667 2010-12-23 12:06:00Z suehring/gryschka
	12	! Calls of exchange_horiz are modified.
	13	!
[565]	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	!
[494]	18	! 493 2010-03-01 08:30:24Z raasch
	19	! netcdf_format_mask* and format_parallel_io replaced by netcdf_data_format
	20	!
[482]	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	!
[449]	24	! 410 2009-12-04 17:05:40Z letzel
	25	! Initial version
[298]	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
[493]	64	!
[298]	65	!-- Open output file.
[493]	66	IF ( netcdf_output .AND. ( myid == 0 .OR. netcdf_data_format > 2 ) ) &
	67	THEN
[564]	68	CALL check_open( 200+mid+av*max_masks )
[409]	69	ENDIF
[298]	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
[493]	84	IF ( netcdf_output .AND. ( myid == 0 .OR. netcdf_data_format > 2 ) ) &
	85	THEN
[298]	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 /) )
[564]	90	CALL handle_netcdf_error( 'data_output_mask', 460 )
[298]	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
[493]	100	IF ( netcdf_data_format < 3 .AND. myid == 0 .AND. if > 1 ) THEN
[298]	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
[667]	127	CALL exchange_horiz( tend, nbgp )
[298]	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
[667]	138	CALL exchange_horiz( pc_av, nbgp )
[298]	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
[667]	163	CALL exchange_horiz( tend, nbgp )
[298]	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
[667]	174	CALL exchange_horiz( pr_av, nbgp )
[298]	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
[356]	261	to_be_resorted => s_av
[298]	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) )
[564]	308	CALL message( 'data_output_mask', 'PA0327', 0, 0, 0, 6, 0 )
[298]	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
[493]	334	!-- netcdf_data_format.
[298]	335	#if defined( __parallel )
	336	#if defined( __netcdf4 )
[493]	337	IF ( netcdf_data_format > 2 ) THEN
[298]	338	!
	339	!-- (1) a. Parallel I/O using NetCDF 4 (not yet tested)
	340	nc_stat = NF90_PUT_VAR( id_set_mask(mid,av), &
[340]	341	id_var_domask(mid,av,if), &
[409]	342	local_pf, &
[340]	343	start = (/ mask_start_l(mid,1), mask_start_l(mid,2), &
[409]	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 /) )
[564]	347	CALL handle_netcdf_error( 'data_output_mask', 461 )
[298]	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 /) )
[564]	394	CALL handle_netcdf_error( 'data_output_mask', 462 )
[298]	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), &
[475]	435	local_pf, &
[298]	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 /) )
[564]	439	CALL handle_netcdf_error( 'data_output_mask', 463 )
[298]	440	#endif
	441
	442	if = if + 1
[667]	443
[298]	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 |