Home

Context Navigation

source: palm/trunk/SOURCE/init_masks.f90 @ 564

Last change on this file since 564 was 564, checked in by helmke, 14 years ago
several changes for an unlimited output of mask data and message IDs changed
Property svn:keywords set to `Id`
File size: 23.9 KB

Line
1	SUBROUTINE init_masks
2
3	!------------------------------------------------------------------------------!
4	! Current revisions:
5	! -----------------
6	! assignment of mask_xyz_loop added, palm message identifiers of masked output
7	! changed
8	!
9	! Former revisions:
10	! -----------------
11	! $Id: init_masks.f90 564 2010-09-30 13:18:59Z helmke $
12	!
13	! 557 2010-09-07 14:50:07Z weinreis
14	! bugfix message string in set_mask_locations
15	!
16	! 553 2010-09-01 14:09:06Z weinreis
17	! parameters for masked output are replaced by arrays
18	!
19	! 493 2010-03-01 08:30:24Z raasch
20	! netcdf_format_mask* and format_parallel_io replaced by netcdf_data_format
21	!
22	! 410 2009-12-04 17:05:40Z letzel
23	! Initial revision
24	!
25	!
26	! Description:
27	! ------------
28	! Initialize masked data output
29	!------------------------------------------------------------------------------!
30
31	USE arrays_3d
32	USE control_parameters
33	USE grid_variables
34	USE indices
35	USE netcdf_control
36	USE particle_attributes
37	USE pegrid
38
39	IMPLICIT NONE
40
41	CHARACTER (LEN=6) :: var
42	CHARACTER (LEN=7) :: unit
43	CHARACTER (LEN=10), DIMENSION(max_masks,100) :: do_mask, do_mask_user
44
45	INTEGER :: i, ilen, ind(6), ind_array(1), j, k, n, sender
46	INTEGER, DIMENSION(:), ALLOCATABLE :: tmp_array
47
48	LOGICAL :: found
49	!
50	!-- Allocation and initialization
51	ALLOCATE( tmp_array( MAX(nx,ny,nz)+1 ) )
52
53	ALLOCATE( mask_i(max_masks,nxr-nxl+1), &
54	mask_j(max_masks,nyn-nys+1), &
55	mask_k(max_masks,nzt-nzb+1) )
56	!
57	!-- internal mask arrays ("mask,dimension,selection")
58	ALLOCATE( mask(max_masks,3,mask_xyz_dimension), &
59	mask_loop(max_masks,3,3) )
60
61	!
62	!-- Parallel mask output not yet tested
63	IF ( netcdf_data_format > 2 ) THEN
64	message_string = 'NetCDF file formats '// &
65	'3 (NetCDF 4) and 4 (NetCDF 4 Classic model)'// &
66	'&are currently not supported (not yet tested).'
67	CALL message( 'init_masks', 'PA0328', 1, 2, 0, 6, 0 )
68	ENDIF
69
70	!
71	!-- Store data output parameters for masked data output in few shared arrays
72	DO mid = 1, masks
73
74	do_mask (mid,:) = data_output_masks(mid,:)
75	do_mask_user(mid,:) = data_output_masks_user(mid,:)
76	mask (mid,1,:) = mask_x(mid,:)
77	mask (mid,2,:) = mask_y(mid,:)
78	mask (mid,3,:) = mask_z(mid,:)
79
80	IF ( mask_x_loop(mid,1) == -1.0 .AND. mask_x_loop(mid,2) == -1.0 &
81	.AND. mask_x_loop(mid,3) == -1.0 ) THEN
82	mask_loop(mid,1,1:2) = -1.0
83	mask_loop(mid,1,3) = 0.0
84	ELSE
85	mask_loop(mid,1,:) = mask_x_loop(mid,:)
86	ENDIF
87	IF ( mask_y_loop(mid,1) == -1.0 .AND. mask_y_loop(mid,2) == -1.0 &
88	.AND. mask_y_loop(mid,3) == -1.0 ) THEN
89	mask_loop(mid,2,1:2) = -1.0
90	mask_loop(mid,2,3) = 0.0
91	ELSE
92	mask_loop(mid,2,:) = mask_y_loop(mid,:)
93	ENDIF
94	IF ( mask_z_loop(mid,1) == -1.0 .AND. mask_z_loop(mid,2) == -1.0 &
95	.AND. mask_z_loop(mid,3) == -1.0 ) THEN
96	mask_loop(mid,3,1:2) = -1.0
97	mask_loop(mid,3,3) = 0.0
98	ELSE
99	mask_loop(mid,3,:) = mask_z_loop(mid,:)
100	ENDIF
101
102	ENDDO
103
104	mask_i = -1; mask_j = -1; mask_k = -1
105
106	!
107	!-- Global arrays are required by define_netcdf_header.
108	IF ( myid == 0 .OR. netcdf_data_format > 2 ) THEN
109	ALLOCATE( mask_i_global(max_masks,nx+1), &
110	mask_j_global(max_masks,ny+1), &
111	mask_k_global(max_masks,nz+1) )
112	mask_i_global = -1; mask_j_global = -1; mask_k_global = -1
113	ENDIF
114
115	!
116	!-- Determine variable names for each mask
117	DO mid = 1, masks
118	!
119	!-- Append user-defined data output variables to the standard data output
120	IF ( do_mask_user(mid,1) /= ' ' ) THEN
121	i = 1
122	DO WHILE ( do_mask(mid,i) /= ' ' .AND. i <= 100 )
123	i = i + 1
124	ENDDO
125	j = 1
126	DO WHILE ( do_mask_user(mid,j) /= ' ' .AND. j <= 100 )
127	IF ( i > 100 ) THEN
128	WRITE ( message_string, * ) 'number of output quantitities ', &
129	'given by data_output_mask and data_output_mask_user ', &
130	'exceeds the limit of 100'
131	CALL message( 'init_masks', 'PA0329', 1, 2, 0, 6, 0 )
132	ENDIF
133	do_mask(mid,i) = do_mask_user(mid,j)
134	i = i + 1
135	j = j + 1
136	ENDDO
137	ENDIF
138
139	!
140	!-- Check and set steering parameters for mask data output and averaging
141	i = 1
142	DO WHILE ( do_mask(mid,i) /= ' ' .AND. i <= 100 )
143	!
144	!-- Check for data averaging
145	ilen = LEN_TRIM( do_mask(mid,i) )
146	j = 0 ! no data averaging
147	IF ( ilen > 3 ) THEN
148	IF ( do_mask(mid,i)(ilen-2:ilen) == '_av' ) THEN
149	j = 1 ! data averaging
150	do_mask(mid,i) = do_mask(mid,i)(1:ilen-3)
151	ENDIF
152	ENDIF
153	var = TRIM( do_mask(mid,i) )
154	!
155	!-- Check for allowed value and set units
156	SELECT CASE ( TRIM( var ) )
157
158	CASE ( 'e' )
159	IF ( constant_diffusion ) THEN
160	WRITE ( message_string, * ) 'output of "', TRIM( var ), &
161	'" requires constant_diffusion = .FALSE.'
162	CALL message( 'init_masks', 'PA0103', 1, 2, 0, 6, 0 )
163	ENDIF
164	unit = 'm2/s2'
165
166	CASE ( 'pc', 'pr' )
167	IF ( .NOT. particle_advection ) THEN
168	WRITE ( message_string, * ) 'output of "', TRIM( var ), &
169	'" requires a "particles_par"-NAMELIST in the ', &
170	'parameter file (PARIN)'
171	CALL message( 'init_masks', 'PA0104', 1, 2, 0, 6, 0 )
172	ENDIF
173	IF ( TRIM( var ) == 'pc' ) unit = 'number'
174	IF ( TRIM( var ) == 'pr' ) unit = 'm'
175
176	CASE ( 'q', 'vpt' )
177	IF ( .NOT. humidity ) THEN
178	WRITE ( message_string, * ) 'output of "', TRIM( var ), &
179	'" requires humidity = .TRUE.'
180	CALL message( 'init_masks', 'PA0105', 1, 2, 0, 6, 0 )
181	ENDIF
182	IF ( TRIM( var ) == 'q' ) unit = 'kg/kg'
183	IF ( TRIM( var ) == 'vpt' ) unit = 'K'
184
185	CASE ( 'ql' )
186	IF ( .NOT. ( cloud_physics .OR. cloud_droplets ) ) THEN
187	WRITE ( message_string, * ) 'output of "', TRIM( var ), &
188	'" requires cloud_physics = .TRUE. or cloud_droplets', &
189	' = .TRUE.'
190	CALL message( 'init_masks', 'PA0108', 1, 2, 0, 6, 0 )
191	ENDIF
192	unit = 'kg/kg'
193
194	CASE ( 'ql_c', 'ql_v', 'ql_vp' )
195	IF ( .NOT. cloud_droplets ) THEN
196	WRITE ( message_string, * ) 'output of "', TRIM( var ), &
197	'" requires cloud_droplets = .TRUE.'
198	CALL message( 'init_masks', 'PA0107', 1, 2, 0, 6, 0 )
199	ENDIF
200	IF ( TRIM( var ) == 'ql_c' ) unit = 'kg/kg'
201	IF ( TRIM( var ) == 'ql_v' ) unit = 'm3'
202	IF ( TRIM( var ) == 'ql_vp' ) unit = 'none'
203
204	CASE ( 'qv' )
205	IF ( .NOT. cloud_physics ) THEN
206	WRITE ( message_string, * ) 'output of "', TRIM( var ), &
207	'" requires cloud_physics = .TRUE.'
208	CALL message( 'init_masks', 'PA0108', 1, 2, 0, 6, 0 )
209	ENDIF
210	unit = 'kg/kg'
211
212	CASE ( 'rho' )
213	IF ( .NOT. ocean ) THEN
214	WRITE ( message_string, * ) 'output of "', TRIM( var ), &
215	'" requires ocean = .TRUE.'
216	CALL message( 'init_masks', 'PA0109', 1, 2, 0, 6, 0 )
217	ENDIF
218	unit = 'kg/m3'
219
220	CASE ( 's' )
221	IF ( .NOT. passive_scalar ) THEN
222	WRITE ( message_string, * ) 'output of "', TRIM( var ), &
223	'" requires passive_scalar = .TRUE.'
224	CALL message( 'init_masks', 'PA0110', 1, 2, 0, 6, 0 )
225	ENDIF
226	unit = 'conc'
227
228	CASE ( 'sa' )
229	IF ( .NOT. ocean ) THEN
230	WRITE ( message_string, * ) 'output of "', TRIM( var ), &
231	'" requires ocean = .TRUE.'
232	CALL message( 'init_masks', 'PA0109', 1, 2, 0, 6, 0 )
233	ENDIF
234	unit = 'psu'
235
236	CASE ( 'u', 't', 'lwp', 'pra', 'prr', 'z0' )
237	WRITE ( message_string, * ) 'illegal value for data_',&
238	'output: "', TRIM( var ), '" is only allowed', &
239	'for horizontal cross section'
240	CALL message( 'init_masks', 'PA0111', 1, 2, 0, 6, 0 )
241	! IF ( TRIM( var ) == 'lwp*' .AND. .NOT. cloud_physics ) THEN
242	! WRITE ( message_string, * ) 'output of "', TRIM( var ), &
243	! '" requires cloud_physics = .TRUE.'
244	! CALL message( 'init_masks', 'PA0108', 1, 2, 0, 6, 0 )
245	! ENDIF
246	! IF ( TRIM( var ) == 'pra*' .AND. .NOT. precipitation ) THEN
247	! WRITE ( message_string, * ) 'output of "', TRIM( var ), &
248	! '" requires precipitation = .TRUE.'
249	! CALL message( 'init_masks', 'PA0112', 1, 2, 0, 6, 0 )
250	! ENDIF
251	! IF ( TRIM( var ) == 'pra*' .AND. j == 1 ) THEN
252	! WRITE ( message_string, * ) 'temporal averaging of ', &
253	! ' precipitation amount "', TRIM( var ), &
254	! '" not possible'
255	! CALL message( 'init_masks', 'PA0113', 1, 2, 0, 6, 0 )
256	! ENDIF
257	! IF ( TRIM( var ) == 'prr*' .AND. .NOT. precipitation ) THEN
258	! WRITE ( message_string, * ) 'output of "', TRIM( var ), &
259	! '" requires precipitation = .TRUE.'
260	! CALL message( 'init_masks', 'PA0112', 1, 2, 0, 6, 0 )
261	! ENDIF
262	!
263	! IF ( TRIM( var ) == 'u*' ) unit = 'm/s'
264	! IF ( TRIM( var ) == 't*' ) unit = 'K'
265	! IF ( TRIM( var ) == 'lwp' ) unit = 'kg/kgm'
266	! IF ( TRIM( var ) == 'pra*' ) unit = 'mm'
267	! IF ( TRIM( var ) == 'prr*' ) unit = 'mm/s'
268	! IF ( TRIM( var ) == 'z0*' ) unit = 'm'
269
270	CASE ( 'p', 'pt', 'u', 'v', 'w' )
271	IF ( TRIM( var ) == 'p' ) unit = 'Pa'
272	IF ( TRIM( var ) == 'pt' ) unit = 'K'
273	IF ( TRIM( var ) == 'u' ) unit = 'm/s'
274	IF ( TRIM( var ) == 'v' ) unit = 'm/s'
275	IF ( TRIM( var ) == 'w' ) unit = 'm/s'
276	CONTINUE
277
278	CASE DEFAULT
279	CALL user_check_data_output( var, unit )
280
281	IF ( unit == 'illegal' ) THEN
282	IF ( do_mask_user(mid,1) /= ' ' ) THEN
283	WRITE ( message_string, * ) 'illegal value for data_',&
284	'output or data_output_user: "', &
285	TRIM( do_mask(mid,i) ), '"'
286	CALL message( 'init_masks', 'PA0114', 1, 2, 0, 6, 0 )
287	ELSE
288	WRITE ( message_string, * ) 'illegal value for data_',&
289	'output: "', TRIM( do_mask(mid,i) ), '"'
290	CALL message( 'init_masks', 'PA0330', 1, 2, 0, 6, 0 )
291	ENDIF
292	ENDIF
293
294	END SELECT
295	!
296	!-- Set the internal steering parameters appropriately
297	domask_no(mid,j) = domask_no(mid,j) + 1
298	domask(mid,j,domask_no(mid,j)) = do_mask(mid,i)
299	domask_unit(mid,j,domask_no(mid,j)) = unit
300
301	IF ( j == 1 ) THEN
302	!
303	!-- Check, if variable is already subject to averaging
304	found = .FALSE.
305	DO k = 1, doav_n
306	IF ( TRIM( doav(k) ) == TRIM( var ) ) found = .TRUE.
307	ENDDO
308
309	IF ( .NOT. found ) THEN
310	doav_n = doav_n + 1
311	doav(doav_n) = var
312	ENDIF
313	ENDIF
314
315	i = i + 1
316
317	ENDDO ! do_mask(mid,i)
318	ENDDO ! mid
319
320
321	!
322	!-- Determine mask locations for each mask
323	DO mid = 1, masks
324	!
325	!-- Set local masks for each subdomain along all three dimensions
326	CALL set_mask_locations( 1, dx, 'dx', nx, 'nx', nxl, nxr )
327	CALL set_mask_locations( 2, dy, 'dy', ny, 'ny', nys, nyn )
328	CALL set_mask_locations( 3, dz, 'dz', nz, 'nz', nzb, nzt )
329	!
330	!-- Set global masks along all three dimensions (required by
331	!-- define_netcdf_header).
332	#if defined( __parallel )
333	!
334	!-- PE0 receives partial arrays from all processors of the respective mask
335	!-- and outputs them. Here a barrier has to be set, because otherwise
336	!-- "-MPI- FATAL: Remote protocol queue full" may occur.
337	CALL MPI_BARRIER( comm2d, ierr )
338
339	IF ( myid == 0 ) THEN
340	!
341	!-- Local arrays can be relocated directly.
342	mask_i_global(mid,mask_start_l(mid,1): &
343	mask_start_l(mid,1)+mask_size_l(mid,1)-1) = &
344	mask_i(mid,:mask_size_l(mid,1))
345	mask_j_global(mid,mask_start_l(mid,2): &
346	mask_start_l(mid,2)+mask_size_l(mid,2)-1) = &
347	mask_j(mid,:mask_size_l(mid,2))
348	mask_k_global(mid,mask_start_l(mid,3): &
349	mask_start_l(mid,3)+mask_size_l(mid,3)-1) = &
350	mask_k(mid,:mask_size_l(mid,3))
351	!
352	!-- Receive data from all other PEs.
353	DO n = 1, numprocs-1
354	!
355	!-- Receive index limits first, then arrays.
356	!-- Index limits are received in arbitrary order from the PEs.
357	CALL MPI_RECV( ind(1), 6, MPI_INTEGER, MPI_ANY_SOURCE, 0, &
358	comm2d, status, ierr )
359	!
360	!-- Not all PEs have data for the mask.
361	IF ( ind(1) /= -9999 ) THEN
362	sender = status(MPI_SOURCE)
363	CALL MPI_RECV( tmp_array(ind(1)), ind(2)-ind(1)+1, &
364	MPI_INTEGER, sender, 1, comm2d, status, ierr )
365	mask_i_global(mid,ind(1):ind(2)) = tmp_array(ind(1):ind(2))
366	CALL MPI_RECV( tmp_array(ind(3)), ind(4)-ind(3)+1, &
367	MPI_INTEGER, sender, 2, comm2d, status, ierr )
368	mask_j_global(mid,ind(3):ind(4)) = tmp_array(ind(3):ind(4))
369	CALL MPI_RECV( tmp_array(ind(5)), ind(6)-ind(5)+1, &
370	MPI_INTEGER, sender, 3, comm2d, status, ierr )
371	mask_k_global(mid,ind(5):ind(6)) = tmp_array(ind(5):ind(6))
372	ENDIF
373	ENDDO
374
375	ELSE
376	!
377	!-- If at least part of the mask resides on the PE, send the index limits
378	!-- for the target array, otherwise send -9999 to PE0.
379	IF ( mask_size_l(mid,1) > 0 .AND. mask_size_l(mid,2) > 0 .AND. &
380	mask_size_l(mid,3) > 0 ) &
381	THEN
382	ind(1) = mask_start_l(mid,1)
383	ind(2) = mask_start_l(mid,1) + mask_size_l(mid,1) - 1
384	ind(3) = mask_start_l(mid,2)
385	ind(4) = mask_start_l(mid,2) + mask_size_l(mid,2) - 1
386	ind(5) = mask_start_l(mid,3)
387	ind(6) = mask_start_l(mid,3) + mask_size_l(mid,3) - 1
388	ELSE
389	ind(1) = -9999; ind(2) = -9999
390	ind(3) = -9999; ind(4) = -9999
391	ind(5) = -9999; ind(6) = -9999
392	ENDIF
393	CALL MPI_SEND( ind(1), 6, MPI_INTEGER, 0, 0, comm2d, ierr )
394	!
395	!-- If applicable, send data to PE0.
396	IF ( ind(1) /= -9999 ) THEN
397	tmp_array(:mask_size_l(mid,1)) = mask_i(mid,:mask_size_l(mid,1))
398	CALL MPI_SEND( tmp_array(1), mask_size_l(mid,1), &
399	MPI_INTEGER, 0, 1, comm2d, ierr )
400	tmp_array(:mask_size_l(mid,2)) = mask_j(mid,:mask_size_l(mid,2))
401	CALL MPI_SEND( tmp_array(1), mask_size_l(mid,2), &
402	MPI_INTEGER, 0, 2, comm2d, ierr )
403	tmp_array(:mask_size_l(mid,3)) = mask_k(mid,:mask_size_l(mid,3))
404	CALL MPI_SEND( tmp_array(1), mask_size_l(mid,3), &
405	MPI_INTEGER, 0, 3, comm2d, ierr )
406	ENDIF
407	ENDIF
408	!
409	!-- A barrier has to be set, because otherwise some PEs may proceed too fast
410	!-- so that PE0 may receive wrong data on tag 0.
411	CALL MPI_BARRIER( comm2d, ierr )
412
413	IF ( netcdf_data_format > 2 ) THEN
414
415	CALL MPI_BCAST( mask_i_global(mid,:), nx+1, MPI_INTEGER, 0, comm2d, &
416	ierr )
417	CALL MPI_BCAST( mask_j_global(mid,:), ny+1, MPI_INTEGER, 0, comm2d, &
418	ierr )
419	CALL MPI_BCAST( mask_k_global(mid,:), nz+1, MPI_INTEGER, 0, comm2d, &
420	ierr )
421
422	ENDIF
423
424	#else
425	!
426	!-- Local arrays can be relocated directly.
427	mask_i_global(mid,:) = mask_i(mid,:)
428	mask_j_global(mid,:) = mask_j(mid,:)
429	mask_k_global(mid,:) = mask_k(mid,:)
430	#endif
431	ENDDO ! mid
432
433	DEALLOCATE( tmp_array )
434	!
435	!-- Internal mask arrays cannot be deallocated on PE 0 because they are
436	!-- required for header output on PE 0.
437	IF ( myid /= 0 ) DEALLOCATE( mask, mask_loop )
438
439	CONTAINS
440
441	SUBROUTINE set_mask_locations( dim, dxyz, dxyz_string, nxyz, nxyz_string, &
442	lb, ub )
443	!------------------------------------------------------------------------------!
444	!
445	! Description:
446	! ------------
447	! Set local mask for each subdomain along 'dim' direction.
448	!------------------------------------------------------------------------------!
449
450	IMPLICIT NONE
451
452	CHARACTER (LEN=2) :: dxyz_string, nxyz_string
453	INTEGER :: count, count_l, dim, m, loop_begin, loop_end, loop_stride, &
454	lb, nxyz, ub
455	REAL :: dxyz, ddxyz, tmp1, tmp2
456
457	count = 0; count_l = 0; ddxyz = 1.0 / dxyz; tmp1 = 0.0; tmp2 = 0.0
458
459	IF ( mask(mid,dim,1) >= 0.0 ) THEN
460	!
461	!-- use predefined mask_* array
462	DO WHILE ( mask(mid,dim,count+1) >= 0.0 )
463	count = count + 1
464	IF ( dim == 1 .OR. dim == 2 ) THEN
465	m = NINT( mask(mid,dim,count) * mask_scale(dim) * ddxyz )
466	ELSEIF ( dim == 3 ) THEN
467	ind_array = &
468	MINLOC( ABS( mask(mid,dim,count) * mask_scale(dim) - zw ) )
469	m = ind_array(1) - 1 + nzb ! MINLOC uses lower array bound 1
470	ENDIF
471	IF ( m > nxyz ) THEN
472	WRITE ( message_string, '(I3,A,I3,A,I1,3A,I3)' ) &
473	m,' in mask ',mid,' along dimension ',dim, &
474	' exceeds ',nxyz_string,' = ',nxyz
475	CALL message( 'init_masks', 'PA0331', 1, 2, 0, 6, 0 )
476	ENDIF
477	IF ( m >= lb .AND. m <= ub ) THEN
478	IF ( count_l == 0 ) mask_start_l(mid,dim) = count
479	count_l = count_l + 1
480	IF ( dim == 1 ) THEN
481	mask_i(mid,count_l) = m
482	ELSEIF ( dim == 2 ) THEN
483	mask_j(mid,count_l) = m
484	ELSEIF ( dim == 3 ) THEN
485	mask_k(mid,count_l) = m
486	ENDIF
487	ENDIF
488	IF ( count == mask_xyz_dimension ) EXIT
489	ENDDO
490	mask_size(mid,dim) = count
491	mask_size_l(mid,dim) = count_l
492
493	ELSE
494	!
495	!-- use predefined mask_loop_* array, or use the default (all grid points
496	!-- along this direction)
497	IF ( mask_loop(mid,dim,1) < 0.0 ) THEN
498	tmp1 = mask_loop(mid,dim,1)
499	mask_loop(mid,dim,1) = 0.0 ! (default)
500	ENDIF
501	IF ( dim == 1 .OR. dim == 2 ) THEN
502	IF ( mask_loop(mid,dim,2) < 0.0 ) THEN
503	tmp2 = mask_loop(mid,dim,2)
504	mask_loop(mid,dim,2) = nxyz*dxyz / mask_scale(dim) ! (default)
505	ENDIF
506	IF ( MAXVAL( mask_loop(mid,dim,1:2) ) &
507	> nxyz * dxyz / mask_scale(dim) ) THEN
508	WRITE ( message_string, '(2(A,I3,A,I1,A,F9.3),5A,I1,A,F9.3)' ) &
509	'mask_loop(',mid,',',dim,',1)=',mask_loop(mid,dim,1), &
510	' and/or mask_loop(',mid,',',dim,',2)=', &
511	mask_loop(mid,dim,2),'&exceed ', &
512	nxyz_string,'*',dxyz_string,'/mask_scale(',dim,')=', &
513	nxyz*dxyz/mask_scale(dim)
514	CALL message( 'init_masks', 'PA0332', 1, 2, 0, 6, 0 )
515	ENDIF
516	loop_begin = NINT( mask_loop(mid,dim,1) * mask_scale(dim) * ddxyz )
517	loop_end = NINT( mask_loop(mid,dim,2) * mask_scale(dim) * ddxyz )
518	loop_stride = NINT( mask_loop(mid,dim,3) * mask_scale(dim) * ddxyz )
519	ELSEIF ( dim == 3 ) THEN
520	IF ( mask_loop(mid,dim,2) < 0.0 ) THEN
521	tmp2 = mask_loop(mid,dim,2)
522	mask_loop(mid,dim,2) = zw(nz) / mask_scale(dim) ! (default)
523	ENDIF
524	IF ( MAXVAL( mask_loop(mid,dim,1:2) ) &
525	> zw(nz) / mask_scale(dim) ) THEN
526	WRITE ( message_string, '(2(A,I3,A,I1,A,F9.3),A,I1,A,F9.3)' ) &
527	'mask_loop(',mid,',',dim,',1)=',mask_loop(mid,dim,1), &
528	' and/or mask_loop(',mid,',',dim,',2)=', &
529	mask_loop(mid,dim,2),'&exceed zw(nz)/mask_scale(',dim, &
530	')=',zw(nz)/mask_scale(dim)
531	CALL message( 'init_masks', 'PA0333', 1, 2, 0, 6, 0 )
532	ENDIF
533	ind_array = &
534	MINLOC( ABS( mask_loop(mid,dim,1) * mask_scale(dim) - zw ) )
535	loop_begin = &
536	ind_array(1) - 1 + nzb ! MINLOC uses lower array bound 1
537	ind_array = &
538	MINLOC( ABS( mask_loop(mid,dim,2) * mask_scale(dim) - zw ) )
539	loop_end = ind_array(1) - 1 + nzb ! MINLOC uses lower array bound 1
540	!
541	!-- The following line assumes a constant vertical grid spacing within
542	!-- the vertical mask range; it fails for vertical grid stretching.
543	!-- Maybe revise later. Issue warning but continue execution.
544	loop_stride = NINT( mask_loop(mid,dim,3) * mask_scale(dim) * ddxyz )
545
546	IF ( mask_loop(mid,dim,2) * mask_scale(dim) > dz_stretch_level ) &
547	THEN
548	WRITE ( message_string, '(A,I3,A,I1,A,F9.3,A,F8.2,3A)' ) &
549	'mask_loop(',mid,',',dim,',2)=', mask_loop(mid,dim,2),&
550	' exceeds dz_stretch_level=',dz_stretch_level, &
551	'.&Vertical mask locations will not ', &
552	'match the desired heights&within the stretching ', &
553	'region. Recommendation: use mask instead of mask_loop.'
554	CALL message( 'init_masks', 'PA0334', 0, 1, 0, 6, 0 )
555	ENDIF
556
557	ENDIF
558	!
559	!-- If necessary, reset mask_loop(mid,dim,1) and mask_loop(mid,dim,2).
560	IF ( tmp1 < 0.0 ) mask_loop(mid,dim,1) = tmp1
561	IF ( tmp2 < 0.0 ) mask_loop(mid,dim,2) = tmp2
562	!
563	!-- The default stride +/-1 (every grid point) applies if
564	!-- mask_loop(mid,dim,3) is not specified (its default is zero).
565	IF ( loop_stride == 0 ) THEN
566	IF ( loop_end >= loop_begin ) THEN
567	loop_stride = 1
568	ELSE
569	loop_stride = -1
570	ENDIF
571	ENDIF
572	DO m = loop_begin, loop_end, loop_stride
573	count = count + 1
574	IF ( m >= lb .AND. m <= ub ) THEN
575	IF ( count_l == 0 ) mask_start_l(mid,dim) = count
576	count_l = count_l + 1
577	IF ( dim == 1 ) THEN
578	mask_i(mid,count_l) = m
579	ELSEIF ( dim == 2 ) THEN
580	mask_j(mid,count_l) = m
581	ELSEIF ( dim == 3 ) THEN
582	mask_k(mid,count_l) = m
583	ENDIF
584	ENDIF
585	ENDDO
586	mask_size(mid,dim) = count
587	mask_size_l(mid,dim) = count_l
588	ENDIF
589
590	END SUBROUTINE set_mask_locations
591
592	END SUBROUTINE init_masks

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |