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

Last change on this file since 720 was 668, checked in by suehring, 14 years ago

last commit documented

  • Property svn:keywords set to Id
File size: 15.2 KB
RevLine 
[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 gryschka $
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.