source: palm/tags/release-3.8/SOURCE/data_output_mask.f90 @ 4343

Last change on this file since 4343 was 668, checked in by suehring, 11 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 oliver.maas $
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.