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

Last change on this file since 4446 was 4444, checked in by raasch, 4 years ago

bugfix: cpp-directives for serial mode added

  • Property svn:keywords set to Id
File size: 31.1 KB
Line 
1!> @file init_masks.f90
2!------------------------------------------------------------------------------!
3! This file is part of the PALM model system.
4!
5! PALM is free software: you can redistribute it and/or modify it under the
6! terms of the GNU General Public License as published by the Free Software
7! Foundation, either version 3 of the License, or (at your option) any later
8! version.
9!
10! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
11! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
13!
14! You should have received a copy of the GNU General Public License along with
15! PALM. If not, see <http://www.gnu.org/licenses/>.
16!
17! Copyright 1997-2020 Leibniz Universitaet Hannover
18!------------------------------------------------------------------------------!
19!
20! Current revisions:
21! -----------------
22!
23!
24! Former revisions:
25! -----------------
26! $Id: init_masks.f90 4444 2020-03-05 15:59:50Z raasch $
27! bugfix: cpp-directives for serial mode added
28!
29! 4360 2020-01-07 11:25:50Z suehring
30! Corrected "Former revisions" section
31!
32! 4069 2019-07-01 14:05:51Z Giersch
33! Masked output running index mid has been introduced as a local variable to
34! avoid runtime error (Loop variable has been modified) in time_integration
35!
36! 3766 2019-02-26 16:23:41Z raasch
37! unused variables removed
38!
39! 3687 2019-01-22 10:42:06Z knoop
40! unused variables removed
41!
42! 3655 2019-01-07 16:51:22Z knoop
43! Move the control parameter "salsa" from salsa_mod to control_parameters
44! (M. Kurppa)
45!
46! 410 2009-12-04 17:05:40Z letzel
47! Initial revision
48!
49!
50! Description:
51! ------------
52!> Initialize masked data output
53!------------------------------------------------------------------------------!
54 SUBROUTINE init_masks
55
56    USE arrays_3d,                                                             &
57        ONLY:  zu, zw
58
59    USE bulk_cloud_model_mod,                                                  &
60        ONLY: bulk_cloud_model, microphysics_morrison, microphysics_seifert
61
62    USE control_parameters,                                                    &
63        ONLY:  constant_diffusion, cloud_droplets,                             &
64               data_output_masks, data_output_masks_user,                      &
65               doav, doav_n, domask, domask_no, dz, dz_stretch_level_start,    &
66               humidity, mask, masks, mask_scale, mask_i,                      &
67               mask_i_global, mask_j, mask_j_global, mask_k, mask_k_global,    &
68               mask_k_over_surface,                                            &
69               mask_loop, mask_size, mask_size_l, mask_start_l,                &
70               mask_surface, mask_x,                                           &
71               mask_x_loop, mask_xyz_dimension, mask_y, mask_y_loop, mask_z,   &
72               mask_z_loop, max_masks,  message_string,                        &
73               passive_scalar, ocean_mode, varnamelength
74
75    USE grid_variables,                                                        &
76        ONLY:  dx, dy
77
78    USE indices,                                                               &
79        ONLY:  nx, nxl, nxr, ny, nyn, nys, nz, nzb, nzt
80
81    USE kinds
82
83    USE module_interface,                                                      &
84        ONLY:  module_interface_init_masks
85
86    USE netcdf_interface,                                                      &
87        ONLY:  domask_unit, netcdf_data_format
88
89    USE particle_attributes,                                                   &
90        ONLY:  particle_advection
91
92    USE pegrid
93
94    IMPLICIT NONE
95
96    CHARACTER (LEN=varnamelength) ::  var  !< contains variable name
97    CHARACTER (LEN=7)             ::  unit !< contains unit of variable
98   
99    CHARACTER (LEN=varnamelength), DIMENSION(max_masks,100) ::  do_mask      !< list of output variables
100    CHARACTER (LEN=varnamelength), DIMENSION(max_masks,100) ::  do_mask_user !< list of user-specified output variables
101
102    INTEGER(iwp) ::  count        !< counting masking indices along a dimension
103    INTEGER(iwp) ::  i            !< loop index
104    INTEGER(iwp) ::  ilen         !< length of string saved in 'do_mask'
105    INTEGER(iwp) ::  ind_array(1) !< array index
106    INTEGER(iwp) ::  j            !< loop index
107    INTEGER(iwp) ::  k            !< loop index
108    INTEGER(iwp) ::  m            !< mask index
109    INTEGER(iwp) ::  mid            !< masked output running index
110#if defined( __parallel )
111    INTEGER(iwp) ::  ind(6)       !< index limits (lower/upper bounds) of output array
112    INTEGER(iwp) ::  n            !< loop index
113    INTEGER(iwp) ::  sender       !< PE id of sending PE
114#endif
115   
116    INTEGER(iwp), DIMENSION(:), ALLOCATABLE ::  tmp_array !< temporary 1D array
117
118    LOGICAL ::  found !< true if variable is found
119
120!
121!-- Initial values are explicitly set here due to a bug in the Cray compiler
122!-- in case of assignments of initial values in declaration statements for
123!-- arrays with more than 9999 elements (appears with -eD only)
124    domask = ' '
125
126!
127!-- Allocation and initialization
128    ALLOCATE( tmp_array( MAX(nx,ny,nz)+2 ) )
129
130    ALLOCATE( mask_i(max_masks,nxr-nxl+2), &
131              mask_j(max_masks,nyn-nys+2), &
132              mask_k(max_masks,nzt-nzb+2) )
133!
134!-- internal mask arrays ("mask,dimension,selection")
135    ALLOCATE( mask(max_masks,3,mask_xyz_dimension), &
136              mask_loop(max_masks,3,3) )
137   
138!
139!-- Parallel mask output not yet supported. In check_parameters data format
140!-- is restricted and is switched back to non-parallel output. Therefore the
141!-- following error can not occur at the moment.
142    IF ( netcdf_data_format > 4 )  THEN
143       message_string = 'netCDF file formats '//                               &
144                        '5 and 6 (with parallel I/O support)'//                &
145                        ' are currently not supported.'
146       CALL message( 'init_masks', 'PA0328', 1, 2, 0, 6, 0 )
147    ENDIF
148
149!
150!-- Store data output parameters for masked data output in few shared arrays
151    DO  mid = 1, masks
152   
153       do_mask     (mid,:) = data_output_masks(mid,:)
154       do_mask_user(mid,:) = data_output_masks_user(mid,:)
155       mask      (mid,1,:) = mask_x(mid,:) 
156       mask      (mid,2,:) = mask_y(mid,:)
157       mask      (mid,3,:) = mask_z(mid,:) 
158!
159!--    Flag a mask as terrain following
160       IF ( mask_k_over_surface(mid,1) /= -1_iwp )  THEN
161          mask_surface(mid) = .TRUE.
162       ENDIF
163
164       IF ( mask_x_loop(mid,1) == -1.0_wp  .AND.  mask_x_loop(mid,2) == -1.0_wp&
165            .AND.  mask_x_loop(mid,3) == -1.0_wp )  THEN
166          mask_loop(mid,1,1:2) = -1.0_wp
167          mask_loop(mid,1,3)   =  0.0_wp
168       ELSE
169          mask_loop(mid,1,:) = mask_x_loop(mid,:)
170       ENDIF
171       IF ( mask_y_loop(mid,1) == -1.0_wp  .AND.  mask_y_loop(mid,2) == -1.0_wp&
172            .AND.  mask_y_loop(mid,3) == -1.0_wp )  THEN
173          mask_loop(mid,2,1:2) = -1.0_wp
174          mask_loop(mid,2,3)   =  0.0_wp
175       ELSE
176          mask_loop(mid,2,:) = mask_y_loop(mid,:)
177       ENDIF
178       IF ( mask_z_loop(mid,1) == -1.0_wp  .AND.  mask_z_loop(mid,2) == -1.0_wp&
179            .AND.  mask_z_loop(mid,3) == -1.0_wp )  THEN
180          mask_loop(mid,3,1:2) = -1.0_wp
181          mask_loop(mid,3,3)   =  0.0_wp
182       ELSE
183          mask_loop(mid,3,:) = mask_z_loop(mid,:)
184       ENDIF
185       
186    ENDDO
187   
188    mask_i = -1; mask_j = -1; mask_k = -1
189   
190!
191!-- Global arrays are required by define_netcdf_header.
192    IF ( myid == 0  .OR.  netcdf_data_format > 4 )  THEN
193       ALLOCATE( mask_i_global(max_masks,nx+2), &
194                 mask_j_global(max_masks,ny+2), &
195                 mask_k_global(max_masks,nz+2) )
196       mask_i_global = -1; mask_j_global = -1; mask_k_global = -1
197    ENDIF
198
199!
200!-- Determine variable names for each mask
201    DO  mid = 1, masks
202!
203!--    Append user-defined data output variables to the standard data output
204       IF ( do_mask_user(mid,1) /= ' ' )  THEN
205          i = 1
206          DO  WHILE ( do_mask(mid,i) /= ' '  .AND.  i <= 100 )
207             i = i + 1
208          ENDDO
209          j = 1
210          DO  WHILE ( do_mask_user(mid,j) /= ' '  .AND.  j <= 100 )
211             IF ( i > 100 )  THEN
212                WRITE ( message_string, * ) 'number of output quantitities ',  &
213                     'given by data_output_mask and data_output_mask_user ',   &
214                     'exceeds the limit of 100'
215                CALL message( 'init_masks', 'PA0329', 1, 2, 0, 6, 0 )
216             ENDIF
217             do_mask(mid,i) = do_mask_user(mid,j)
218             i = i + 1
219             j = j + 1
220          ENDDO
221       ENDIF
222
223!
224!--    Check and set steering parameters for mask data output and averaging
225       i   = 1
226       DO WHILE ( do_mask(mid,i) /= ' '  .AND.  i <= 100 )
227!
228!--       Check for data averaging
229          ilen = LEN_TRIM( do_mask(mid,i) )
230          j = 0                                              ! no data averaging
231          IF ( ilen > 3 )  THEN
232             IF ( do_mask(mid,i)(ilen-2:ilen) == '_av' )  THEN
233                j = 1                                           ! data averaging
234                do_mask(mid,i) = do_mask(mid,i)(1:ilen-3)
235             ENDIF
236          ENDIF
237          var = TRIM( do_mask(mid,i) )
238!
239!--       Check for allowed value and set units
240          SELECT CASE ( TRIM( var ) )
241
242             CASE ( 'e' )
243                IF ( constant_diffusion )  THEN
244                   WRITE ( message_string, * ) 'output of "', TRIM( var ),     &
245                        '" requires constant_diffusion = .FALSE.'
246                   CALL message( 'init_masks', 'PA0103', 1, 2, 0, 6, 0 )
247                ENDIF
248                unit = 'm2/s2'
249
250             CASE ( 'thetal' )
251                IF ( .NOT. bulk_cloud_model )  THEN
252                   WRITE ( message_string, * ) 'output of "', TRIM( var ),     &
253                        '" requires bulk_cloud_model = .TRUE.'
254                   CALL message( 'init_masks', 'PA0108', 1, 2, 0, 6, 0 )
255                ENDIF
256                unit = 'K'
257
258             CASE ( 'nc' )
259                IF ( .NOT. bulk_cloud_model )  THEN
260                   WRITE ( message_string, * ) 'output of "', TRIM( var ),     &
261                        '" requires bulk_cloud_model = .TRUE.'
262                   CALL message( 'init_masks', 'PA0108', 1, 2, 0, 6, 0 )
263                 ELSEIF ( .NOT. microphysics_morrison ) THEN
264                   message_string = 'output of "' // TRIM( var ) // '" ' //    &
265                         'requires  = morrison'
266                   CALL message( 'check_parameters', 'PA0359', 1, 2, 0, 6, 0 )
267                ENDIF
268                unit = '1/m3'
269
270             CASE ( 'nr' )
271                IF ( .NOT. bulk_cloud_model )  THEN
272                   WRITE ( message_string, * ) 'output of "', TRIM( var ),     &
273                        '" requires bulk_cloud_model = .TRUE.'
274                   CALL message( 'init_masks', 'PA0108', 1, 2, 0, 6, 0 )
275                 ELSEIF ( .NOT. microphysics_seifert ) THEN
276                   message_string = 'output of "' // TRIM( var ) // '"' //     &
277                         'requires cloud_scheme = seifert_beheng'
278                   CALL message( 'check_parameters', 'PA0359', 1, 2, 0, 6, 0 )
279                ENDIF
280                unit = '1/m3'
281
282             CASE ( 'pc', 'pr' )
283                IF ( .NOT. particle_advection )  THEN
284                   WRITE ( message_string, * ) 'output of "', TRIM( var ),     &
285                        '" requires a "particles_par"-NAMELIST in the ',       &
286                        'parameter file (PARIN)'
287                   CALL message( 'init_masks', 'PA0104', 1, 2, 0, 6, 0 )
288                ENDIF
289                IF ( TRIM( var ) == 'pc' )  unit = 'number'
290                IF ( TRIM( var ) == 'pr' )  unit = 'm'
291
292             CASE ( 'q', 'thetav' )
293                IF ( .NOT. humidity )  THEN
294                   WRITE ( message_string, * ) 'output of "', TRIM( var ),     &
295                        '" requires humidity = .TRUE.'
296                   CALL message( 'init_masks', 'PA0105', 1, 2, 0, 6, 0 )
297                ENDIF
298                IF ( TRIM( var ) == 'q'   )  unit = 'kg/kg'
299                IF ( TRIM( var ) == 'thetav' )  unit = 'K'
300
301             CASE ( 'qc' )
302                IF ( .NOT. bulk_cloud_model )  THEN
303                   message_string = 'output of "' // TRIM( var ) // '"' //     &
304                            'requires bulk_cloud_model = .TRUE.'
305                   CALL message( 'check_parameters', 'PA0108', 1, 2, 0, 6, 0 )
306                ENDIF
307                unit = 'kg/kg'
308
309             CASE ( 'ql' )
310                IF ( .NOT. ( bulk_cloud_model  .OR.  cloud_droplets ) )  THEN
311                   WRITE ( message_string, * ) 'output of "', TRIM( var ),     &
312                        '" requires bulk_cloud_model = .TRUE. or ',            &
313                        'cloud_droplets = .TRUE.'
314                   CALL message( 'init_masks', 'PA0106', 1, 2, 0, 6, 0 )
315                ENDIF
316                unit = 'kg/kg'
317
318             CASE ( 'ql_c', 'ql_v', 'ql_vp' )
319                IF ( .NOT. cloud_droplets )  THEN
320                   WRITE ( message_string, * ) 'output of "', TRIM( var ),     &
321                        '" requires cloud_droplets = .TRUE.'
322                   CALL message( 'init_masks', 'PA0107', 1, 2, 0, 6, 0 )
323                ENDIF
324                IF ( TRIM( var ) == 'ql_c'  )  unit = 'kg/kg'
325                IF ( TRIM( var ) == 'ql_v'  )  unit = 'm3'
326                IF ( TRIM( var ) == 'ql_vp' )  unit = 'none'
327
328             CASE ( 'qv' )
329                IF ( .NOT. bulk_cloud_model )  THEN
330                   WRITE ( message_string, * ) 'output of "', TRIM( var ),     &
331                        '" requires bulk_cloud_model = .TRUE.'
332                   CALL message( 'init_masks', 'PA0108', 1, 2, 0, 6, 0 )
333                ENDIF
334                unit = 'kg/kg'
335
336             CASE ( 'qr' )
337                IF ( .NOT. bulk_cloud_model )  THEN
338                   message_string = 'output of "' // TRIM( var ) // '" ' //    &
339                            'requires bulk_cloud_model = .TRUE.'
340                   CALL message( 'check_parameters', 'PA0108', 1, 2, 0, 6, 0 )
341                ELSEIF ( .NOT. microphysics_seifert ) THEN
342                   message_string = 'output of "' // TRIM( var ) // '" ' //    &
343                            'requires cloud_scheme = seifert_beheng'
344                   CALL message( 'check_parameters', 'PA0359', 1, 2, 0, 6, 0 )
345                ENDIF
346                unit = 'kg/kg'
347
348             CASE ( 'rho_sea_water' )
349                IF ( .NOT. ocean_mode )  THEN
350                   WRITE ( message_string, * ) 'output of "', TRIM( var ),     &
351                        '" requires ocean mode'
352                   CALL message( 'init_masks', 'PA0109', 1, 2, 0, 6, 0 )
353                ENDIF
354                unit = 'kg/m3'
355
356             CASE ( 's' )
357                IF ( .NOT. passive_scalar )  THEN
358                   WRITE ( message_string, * ) 'output of "', TRIM( var ),     &
359                        '" requires passive_scalar = .TRUE.'
360                   CALL message( 'init_masks', 'PA0110', 1, 2, 0, 6, 0 )
361                ENDIF
362                unit = 'conc'
363
364             CASE ( 'sa' )
365                IF ( .NOT. ocean_mode )  THEN
366                   WRITE ( message_string, * ) 'output of "', TRIM( var ),     &
367                        '" requires ocean mode'
368                   CALL message( 'init_masks', 'PA0109', 1, 2, 0, 6, 0 )
369                ENDIF
370                unit = 'psu'
371
372             CASE ( 'us*', 't*', 'lwp*', 'pra*', 'prr*', 'z0*', 'z0h*' )
373                WRITE ( message_string, * ) 'illegal value for data_',         &
374                     'output: "', TRIM( var ), '" is only allowed',            &
375                     'for horizontal cross section'
376                CALL message( 'init_masks', 'PA0111', 1, 2, 0, 6, 0 )
377
378             CASE ( 'p', 'theta', 'u', 'v', 'w' )
379                IF ( TRIM( var ) == 'p'  )  unit = 'Pa'
380                IF ( TRIM( var ) == 'theta' )  unit = 'K'
381                IF ( TRIM( var ) == 'u'  )  unit = 'm/s'
382                IF ( TRIM( var ) == 'v'  )  unit = 'm/s'
383                IF ( TRIM( var ) == 'w'  )  unit = 'm/s'
384                CONTINUE
385
386             CASE DEFAULT
387!
388!--             Allocate arrays for other modules
389                CALL module_interface_init_masks( var, unit )
390
391                IF ( unit == 'illegal' )  THEN
392                   IF ( do_mask_user(mid,1) /= ' ' )  THEN
393                      WRITE ( message_string, * ) 'illegal value for data_',   &
394                           'output_masks or data_output_masks_user: "',        &
395                           TRIM( do_mask(mid,i) ), '"'
396                      CALL message( 'init_masks', 'PA0018', 1, 2, 0, 6, 0 )
397                   ELSE
398                      WRITE ( message_string, * ) 'illegal value for data_',   &
399                           ' output_masks : "', TRIM( do_mask(mid,i) ), '"'
400                      CALL message( 'init_masks', 'PA0330', 1, 2, 0, 6, 0 )
401                   ENDIF
402                ENDIF
403
404          END SELECT
405!
406!--       Set the internal steering parameters appropriately
407          domask_no(mid,j)                    = domask_no(mid,j) + 1
408          domask(mid,j,domask_no(mid,j))      = do_mask(mid,i)
409          domask_unit(mid,j,domask_no(mid,j)) = unit
410
411          IF ( j == 1 )  THEN
412!
413!--          Check, if variable is already subject to averaging
414             found = .FALSE.
415             DO  k = 1, doav_n
416                IF ( TRIM( doav(k) ) == TRIM( var ) )  found = .TRUE.
417             ENDDO
418
419             IF ( .NOT. found )  THEN
420                doav_n = doav_n + 1
421                doav(doav_n) = var
422             ENDIF
423          ENDIF
424
425          i = i + 1
426
427       ENDDO   ! do_mask(mid,i)
428    ENDDO   ! mid
429
430
431!
432!-- Determine mask locations for each mask
433    DO  mid = 1, masks
434!
435!--    Set local masks for each subdomain along all three dimensions
436       CALL set_mask_locations( 1, dx, 'dx', nx, 'nx', nxl, nxr )
437       CALL set_mask_locations( 2, dy, 'dy', ny, 'ny', nys, nyn )
438       IF ( .NOT. mask_surface(mid) )  THEN
439          CALL set_mask_locations( 3, dz(1), 'dz', nz, 'nz', nzb, nzt )
440       ELSE
441!
442!--       Set vertical mask locations and size in case of terrain-following
443!--       output
444          count = 0
445          DO  WHILE ( mask_k_over_surface(mid, count+1) >= 0 )
446             m = mask_k_over_surface(mid, count+1)
447             IF ( m > nz+1 )  THEN
448                WRITE ( message_string, '(I3,A,I3,A,I1,3A,I3)' )               &
449                     m,' in mask ',mid,' along dimension ', 3,                 &
450                     ' exceeds (nz+1) = ',nz+1
451                CALL message( 'init_masks', 'PA0331', 1, 2, 0, 6, 0 )
452             ENDIF
453             count = count + 1
454             mask_k(mid,count) = mask_k_over_surface(mid, count)
455             IF ( count == mask_xyz_dimension )  EXIT
456          ENDDO
457          mask_start_l(mid,3) = 1
458          mask_size(mid,3)    = count
459          mask_size_l(mid,3)  = count
460       ENDIF
461!
462!--    Set global masks along all three dimensions (required by
463!--    define_netcdf_header).
464#if defined( __parallel )
465!
466!--    PE0 receives partial arrays from all processors of the respective mask
467!--    and outputs them. Here a barrier has to be set, because otherwise
468!--    "-MPI- FATAL: Remote protocol queue full" may occur.
469
470       CALL MPI_BARRIER( comm2d, ierr )
471
472       IF ( myid == 0 )  THEN
473!
474!--       Local arrays can be relocated directly.
475          mask_i_global(mid,mask_start_l(mid,1): &
476                       mask_start_l(mid,1)+mask_size_l(mid,1)-1) = &
477                       mask_i(mid,:mask_size_l(mid,1))
478          mask_j_global(mid,mask_start_l(mid,2): &
479                       mask_start_l(mid,2)+mask_size_l(mid,2)-1) = &
480                       mask_j(mid,:mask_size_l(mid,2))
481          mask_k_global(mid,mask_start_l(mid,3): &
482                       mask_start_l(mid,3)+mask_size_l(mid,3)-1) = &
483                       mask_k(mid,:mask_size_l(mid,3))
484!
485!--       Receive data from all other PEs.
486          DO  n = 1, numprocs-1
487!
488!--          Receive index limits first, then arrays.
489!--          Index limits are received in arbitrary order from the PEs.
490             CALL MPI_RECV( ind(1), 6, MPI_INTEGER, MPI_ANY_SOURCE, 0,  &
491                  comm2d, status, ierr )
492!
493!--          Not all PEs have data for the mask.
494             IF ( ind(1) /= -9999 )  THEN
495                sender = status(MPI_SOURCE)
496                CALL MPI_RECV( tmp_array(ind(1)), ind(2)-ind(1)+1,  &
497                               MPI_INTEGER, sender, 1, comm2d, status, ierr )
498                mask_i_global(mid,ind(1):ind(2)) = tmp_array(ind(1):ind(2))
499                CALL MPI_RECV( tmp_array(ind(3)), ind(4)-ind(3)+1,  &
500                               MPI_INTEGER, sender, 2, comm2d, status, ierr )
501                mask_j_global(mid,ind(3):ind(4)) = tmp_array(ind(3):ind(4))
502                CALL MPI_RECV( tmp_array(ind(5)), ind(6)-ind(5)+1,  &
503                               MPI_INTEGER, sender, 3, comm2d, status, ierr )
504                mask_k_global(mid,ind(5):ind(6)) = tmp_array(ind(5):ind(6))
505             ENDIF
506          ENDDO
507
508       ELSE
509!
510!--       If at least part of the mask resides on the PE, send the index limits
511!--       for the target array, otherwise send -9999 to PE0.
512          IF ( mask_size_l(mid,1) > 0  .AND.  mask_size_l(mid,2) > 0  .AND.  &
513               mask_size_l(mid,3) > 0  )  THEN
514             ind(1) = mask_start_l(mid,1)
515             ind(2) = mask_start_l(mid,1) + mask_size_l(mid,1) - 1
516             ind(3) = mask_start_l(mid,2)
517             ind(4) = mask_start_l(mid,2) + mask_size_l(mid,2) - 1
518             ind(5) = mask_start_l(mid,3)
519             ind(6) = mask_start_l(mid,3) + mask_size_l(mid,3) - 1
520          ELSE
521             ind(1) = -9999; ind(2) = -9999
522             ind(3) = -9999; ind(4) = -9999
523             ind(5) = -9999; ind(6) = -9999
524          ENDIF
525          CALL MPI_SEND( ind(1), 6, MPI_INTEGER, 0, 0, comm2d, ierr )
526!
527!--       If applicable, send data to PE0.
528          IF ( ind(1) /= -9999 )  THEN
529             tmp_array(:mask_size_l(mid,1)) = mask_i(mid,:mask_size_l(mid,1))
530             CALL MPI_SEND( tmp_array(1), mask_size_l(mid,1),  &
531                            MPI_INTEGER, 0, 1, comm2d, ierr )
532             tmp_array(:mask_size_l(mid,2)) = mask_j(mid,:mask_size_l(mid,2))
533             CALL MPI_SEND( tmp_array(1), mask_size_l(mid,2),  &
534                            MPI_INTEGER, 0, 2, comm2d, ierr )
535             tmp_array(:mask_size_l(mid,3)) = mask_k(mid,:mask_size_l(mid,3))
536             CALL MPI_SEND( tmp_array(1), mask_size_l(mid,3),  &
537                            MPI_INTEGER, 0, 3, comm2d, ierr )
538          ENDIF
539       ENDIF
540!
541!--    A barrier has to be set, because otherwise some PEs may proceed too fast
542!--    so that PE0 may receive wrong data on tag 0.
543       CALL MPI_BARRIER( comm2d, ierr )
544       
545       IF ( netcdf_data_format > 4 )  THEN
546         
547          CALL MPI_BCAST( mask_i_global(mid,:), nx+2, MPI_INTEGER, 0, comm2d, &
548                          ierr )
549          CALL MPI_BCAST( mask_j_global(mid,:), ny+2, MPI_INTEGER, 0, comm2d, &
550                          ierr )
551          CALL MPI_BCAST( mask_k_global(mid,:), nz+2, MPI_INTEGER, 0, comm2d, &
552                          ierr ) 
553     
554       ENDIF
555
556#else
557!
558!--    Local arrays can be relocated directly.
559       mask_i_global(mid,:) = mask_i(mid,:)
560       mask_j_global(mid,:) = mask_j(mid,:)
561       mask_k_global(mid,:) = mask_k(mid,:)
562#endif
563    ENDDO   ! mid
564
565    DEALLOCATE( tmp_array )
566!
567!-- Internal mask arrays cannot be deallocated on PE 0 because they are
568!-- required for header output on PE 0.
569    IF ( myid /= 0 )  DEALLOCATE( mask, mask_loop )
570
571 CONTAINS
572
573!------------------------------------------------------------------------------!
574! Description:
575! ------------
576!> Set local mask for each subdomain along 'dim' direction.
577!------------------------------------------------------------------------------!
578    SUBROUTINE set_mask_locations( dim, dxyz, dxyz_string, nxyz, nxyz_string, &
579                                   lb, ub )
580
581       IMPLICIT NONE
582
583       CHARACTER (LEN=2) ::  dxyz_string !<
584       CHARACTER (LEN=2) ::  nxyz_string !<
585       
586       INTEGER(iwp)  ::  count       !<
587       INTEGER(iwp)  ::  count_l     !<
588       INTEGER(iwp)  ::  dim         !<
589       INTEGER(iwp)  ::  m           !<
590       INTEGER(iwp)  ::  loop_begin  !<
591       INTEGER(iwp)  ::  loop_end    !<
592       INTEGER(iwp)  ::  loop_stride !<
593       INTEGER(iwp)  ::  lb          !<
594       INTEGER(iwp)  ::  nxyz        !<
595       INTEGER(iwp)  ::  ub          !<
596       
597       REAL(wp)      ::  dxyz  !<
598       REAL(wp)      ::  ddxyz !<
599       REAL(wp)      ::  tmp1  !<
600       REAL(wp)      ::  tmp2  !<
601
602       count = 0;  count_l = 0 
603       ddxyz = 1.0_wp / dxyz 
604       tmp1  = 0.0_wp
605       tmp2  = 0.0_wp
606
607       IF ( mask(mid,dim,1) >= 0.0_wp )  THEN
608!
609!--       use predefined mask_* array
610          DO  WHILE ( mask(mid,dim,count+1) >= 0.0_wp )
611             count = count + 1
612             IF ( dim == 1 .OR. dim == 2 )  THEN
613                m = NINT( mask(mid,dim,count) * mask_scale(dim) * ddxyz - 0.5_wp )
614                IF ( m < 0 )  m = 0  ! avoid negative values
615             ELSEIF ( dim == 3 )  THEN
616                ind_array =  &
617                     MINLOC( ABS( mask(mid,dim,count) * mask_scale(dim) - zu ) )
618                m = ind_array(1) - 1 + nzb  ! MINLOC uses lower array bound 1
619             ENDIF
620             IF ( m > (nxyz+1) )  THEN
621                WRITE ( message_string, '(I3,A,I3,A,I1,3A,I3)' )               &
622                     m,' in mask ',mid,' along dimension ',dim,                &
623                     ' exceeds (',nxyz_string,'+1) = ',nxyz+1
624                CALL message( 'init_masks', 'PA0331', 1, 2, 0, 6, 0 )
625             ENDIF
626             IF ( ( m >= lb .AND. m <= ub ) .OR.     &
627                  ( m == (nxyz+1) .AND. ub == nxyz )  )  THEN
628                IF ( count_l == 0 )  mask_start_l(mid,dim) = count
629                count_l = count_l + 1
630                IF ( dim == 1 )  THEN
631                   mask_i(mid,count_l) = m
632                ELSEIF ( dim == 2 )  THEN
633                   mask_j(mid,count_l) = m
634                ELSEIF ( dim == 3 )  THEN
635                   mask_k(mid,count_l) = m
636                ENDIF
637             ENDIF
638             IF ( count == mask_xyz_dimension )  EXIT
639          ENDDO
640          mask_size(mid,dim)   = count
641          mask_size_l(mid,dim) = count_l
642
643       ELSE
644!
645!--       use predefined mask_loop_* array, or use the default (all grid points
646!--       along this direction)
647          IF ( mask_loop(mid,dim,1) < 0.0_wp )  THEN
648             tmp1 = mask_loop(mid,dim,1)
649             mask_loop(mid,dim,1) = zw(nzb)  !   lowest level  (default)
650          ENDIF
651          IF ( dim == 1 .OR. dim == 2 )  THEN
652             IF ( mask_loop(mid,dim,2) < 0.0_wp )  THEN
653                tmp2 = mask_loop(mid,dim,2)
654                mask_loop(mid,dim,2) = nxyz*dxyz / mask_scale(dim)   ! (default)
655             ENDIF
656             IF ( MAXVAL( mask_loop(mid,dim,1:2) )  &
657                  > (nxyz+1) * dxyz / mask_scale(dim) )  THEN
658                WRITE ( message_string, '(2(A,I3,A,I1,A,F9.3),5A,I1,A,F9.3)' ) &
659                     'mask_loop(',mid,',',dim,',1)=',mask_loop(mid,dim,1),     &
660                     ' and/or mask_loop(',mid,',',dim,',2)=', &
661                     mask_loop(mid,dim,2),' exceed (', &
662                     nxyz_string,'+1)*',dxyz_string,'/mask_scale(',dim,')=',   &
663                     (nxyz+1)*dxyz/mask_scale(dim)
664                CALL message( 'init_masks', 'PA0332', 1, 2, 0, 6, 0 )
665             ENDIF
666             loop_begin  = NINT( mask_loop(mid,dim,1) * mask_scale(dim)        &
667                  * ddxyz - 0.5_wp )
668             loop_end    = NINT( mask_loop(mid,dim,2) * mask_scale(dim)        &
669                  * ddxyz - 0.5_wp )
670             loop_stride = NINT( mask_loop(mid,dim,3) * mask_scale(dim)        &
671                  * ddxyz )
672             IF ( loop_begin == -1 )  loop_begin = 0  ! avoid negative values
673          ELSEIF ( dim == 3 )  THEN
674             IF ( mask_loop(mid,dim,2) < 0.0_wp )  THEN
675                tmp2 = mask_loop(mid,dim,2)
676                mask_loop(mid,dim,2) = zu(nz+1) / mask_scale(dim)   ! (default)
677             ENDIF
678             IF ( MAXVAL( mask_loop(mid,dim,1:2) )  &
679                  > zu(nz+1) / mask_scale(dim) )  THEN
680                WRITE ( message_string, '(2(A,I3,A,I1,A,F9.3),A,I1,A,F9.3)' )  &
681                     'mask_loop(',mid,',',dim,',1)=',mask_loop(mid,dim,1),     &
682                     ' and/or mask_loop(',mid,',',dim,',2)=', &
683                     mask_loop(mid,dim,2),' exceed zu(nz+1)/mask_scale(',dim,  &
684                     ')=',zu(nz+1)/mask_scale(dim)
685                CALL message( 'init_masks', 'PA0333', 1, 2, 0, 6, 0 )
686             ENDIF
687             ind_array =  &
688                  MINLOC( ABS( mask_loop(mid,dim,1) * mask_scale(dim) - zu ) )
689             loop_begin =  &
690                  ind_array(1) - 1 + nzb ! MINLOC uses lower array bound 1
691             ind_array =  &
692                  MINLOC( ABS( mask_loop(mid,dim,2) * mask_scale(dim) - zu ) )
693             loop_end = ind_array(1) - 1 + nzb ! MINLOC uses lower array bound 1
694!
695!--          The following line assumes a constant vertical grid spacing within
696!--          the vertical mask range; it fails for vertical grid stretching.
697!--          Maybe revise later. Issue warning but continue execution. ABS(...)
698!--          within the IF statement is necessary because the default value of
699!--          dz_stretch_level_start is -9999999.9_wp.
700             loop_stride = NINT( mask_loop(mid,dim,3) * mask_scale(dim) * ddxyz )
701
702             IF ( mask_loop(mid,dim,2) * mask_scale(dim) >                     &
703                  ABS( dz_stretch_level_start(1) ) )  THEN
704                WRITE ( message_string, '(A,I3,A,I1,A,F9.3,A,F8.2,3A)' )       &
705                     'mask_loop(',mid,',',dim,',2)=', mask_loop(mid,dim,2),    &
706                     ' exceeds dz_stretch_level=',dz_stretch_level_start(1),   &
707                     '.&Vertical mask locations will not ',                    &
708                     'match the desired heights within the stretching ',       &
709                     'region.'
710                CALL message( 'init_masks', 'PA0334', 0, 1, 0, 6, 0 )
711             ENDIF
712
713          ENDIF
714!
715!--       If necessary, reset mask_loop(mid,dim,1) and mask_loop(mid,dim,2).
716          IF ( tmp1 < 0.0_wp )  mask_loop(mid,dim,1) = tmp1
717          IF ( tmp2 < 0.0_wp )  mask_loop(mid,dim,2) = tmp2
718!
719!--       The default stride +/-1 (every grid point) applies if
720!--       mask_loop(mid,dim,3) is not specified (its default is zero).
721          IF ( loop_stride == 0 )  THEN
722             IF ( loop_end >= loop_begin )  THEN
723                loop_stride =  1
724             ELSE
725                loop_stride = -1
726             ENDIF
727          ENDIF
728          DO  m = loop_begin, loop_end, loop_stride
729             count = count + 1
730             IF ( ( m >= lb  .AND.  m <= ub ) .OR.   &
731                  ( m == (nxyz+1) .AND. ub == nxyz )  )  THEN
732                IF ( count_l == 0 )  mask_start_l(mid,dim) = count
733                count_l = count_l + 1
734                IF ( dim == 1 )  THEN
735                   mask_i(mid,count_l) = m
736                ELSEIF ( dim == 2 )  THEN
737                   mask_j(mid,count_l) = m
738                ELSEIF ( dim == 3 )  THEN
739                   mask_k(mid,count_l) = m
740                ENDIF
741             ENDIF
742          ENDDO
743          mask_size(mid,dim)   = count
744          mask_size_l(mid,dim) = count_l
745
746       ENDIF
747
748    END SUBROUTINE set_mask_locations
749
750 END SUBROUTINE init_masks
Note: See TracBrowser for help on using the repository browser.