| blob | 83e7e1cf54f67e3701e322c0662ef8e0ef5e5c30 |
1 !WRF:DRIVER_LAYER:IO
2 !
3 #define DEBUG_LVL 500
5 MODULE module_io
6 !<DESCRIPTION>
7 !<PRE>
8 ! WRF-specific package-independent interface to package-dependent WRF-specific
9 ! I/O packages.
10 !
11 ! These routines have the same names as those specified in the WRF I/O API
12 ! except that:
13 ! - Routines defined in this file and called by users of this module have
14 ! the "wrf_" prefix.
15 ! - Routines defined in the I/O packages and called from routines in this
16 ! file have the "ext_" prefix.
17 ! - Routines called from routines in this file to initiate communication
18 ! with I/O quilt servers have the "wrf_quilt_" prefix.
19 !
20 ! See http://www.mmm.ucar.edu/wrf/WG2/software_2.0/IOAPI.doc for the latest
21 ! version of the WRF I/O API. This document includes detailed descriptions
22 ! of subroutines and their arguments that are not duplicated in this file.
23 !
24 ! We wish to be able to link to different packages depending on whether
25 ! the I/O is restart, initial, history, or boundary.
26 !</PRE>
27 !</DESCRIPTION>
29 USE module_configure
31 LOGICAL :: is_inited = .FALSE.
32 INTEGER, PARAMETER, PRIVATE :: MAX_WRF_IO_HANDLE = 1000
33 INTEGER :: wrf_io_handles(MAX_WRF_IO_HANDLE), how_opened(MAX_WRF_IO_HANDLE)
34 LOGICAL :: for_output(MAX_WRF_IO_HANDLE), first_operation(MAX_WRF_IO_HANDLE)
35 INTEGER :: filtno = 0
36 LOGICAL, PRIVATE :: bdy_dist_flag = .TRUE. ! false is old style undecomposed boundary data structs,
37 ! true is new style decomposed boundary data structs
38 ! are_bdys_distributed, bdys_are_distributed and
39 ! bdys_not_distributed routines access this flag
40 CHARACTER*256 extradims
42 !<DESCRIPTION>
43 !<PRE>
44 !
45 ! include the file generated from md_calls.m4 using the m4 preprocessor
46 ! note that this file also includes the CONTAINS declaration for the module
47 !
48 !</PRE>
49 !</DESCRIPTION>
50 #include "md_calls.inc"
52 !--- registry-generated routine that gets the io format being used for a dataset
54 INTEGER FUNCTION io_form_for_dataset ( DataSet )
55 IMPLICIT NONE
56 CHARACTER*(*), INTENT(IN) :: DataSet
57 INTEGER :: io_form
58 #include "io_form_for_dataset.inc"
59 io_form_for_dataset = io_form
60 RETURN
61 END FUNCTION io_form_for_dataset
63 !--- ioinit
65 SUBROUTINE wrf_ioinit( Status )
66 !<DESCRIPTION>
67 !<PRE>
68 ! Initialize the WRF I/O system.
69 !</PRE>
70 !</DESCRIPTION>
71 IMPLICIT NONE
72 INTEGER, INTENT(INOUT) :: Status
73 !Local
74 CHARACTER(len=80) :: SysDepInfo
75 INTEGER :: ierr(10), minerr, maxerr
76 !
77 Status = 0
78 ierr = 0
79 SysDepInfo = " "
80 CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_ioinit' )
81 CALL init_io_handles ! defined below
82 #ifdef NETCDF
83 CALL ext_ncd_ioinit( SysDepInfo, ierr(1) )
84 #endif
85 #ifdef INTIO
86 CALL ext_int_ioinit( SysDepInfo, ierr(2) )
87 #endif
88 #ifdef PHDF5
89 CALL ext_phdf5_ioinit( SysDepInfo, ierr(3) )
90 #endif
91 #ifdef PNETCDF
92 CALL ext_pnc_ioinit( SysDepInfo, ierr(3) )
93 #endif
94 #ifdef MCELIO
95 CALL ext_mcel_ioinit( SysDepInfo, ierr(4) )
96 #endif
97 #ifdef XXX
98 CALL ext_xxx_ioinit( SysDepInfo, ierr(5) )
99 #endif
100 #ifdef YYY
101 CALL ext_yyy_ioinit( SysDepInfo, ierr(6) )
102 #endif
103 #ifdef ZZZ
104 CALL ext_zzz_ioinit( SysDepInfo, ierr(7) )
105 #endif
106 #ifdef ESMFIO
107 CALL ext_esmf_ioinit( SysDepInfo, ierr(8) )
108 #endif
109 #ifdef GRIB1
110 CALL ext_gr1_ioinit( SysDepInfo, ierr(9) )
111 #endif
112 #ifdef GRIB2
113 CALL ext_gr2_ioinit( SysDepInfo, ierr(10) )
114 #endif
115 minerr = MINVAL(ierr)
116 maxerr = MAXVAL(ierr)
117 IF ( minerr < 0 ) THEN
118 Status = minerr
119 ELSE IF ( maxerr > 0 ) THEN
120 Status = maxerr
121 ELSE
122 Status = 0
123 ENDIF
124 END SUBROUTINE wrf_ioinit
126 !--- ioexit
128 SUBROUTINE wrf_ioexit( Status )
129 !<DESCRIPTION>
130 !<PRE>
131 ! Shut down the WRF I/O system.
132 !</PRE>
133 !</DESCRIPTION>
134 IMPLICIT NONE
135 INTEGER, INTENT(INOUT) :: Status
136 !Local
137 LOGICAL, EXTERNAL :: use_output_servers
138 INTEGER :: ierr(11), minerr, maxerr
139 !
140 Status = 0
141 ierr = 0
142 CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_ioexit' )
143 #ifdef NETCDF
144 CALL ext_ncd_ioexit( ierr(1) )
145 #endif
146 #ifdef INTIO
147 CALL ext_int_ioexit( ierr(2) )
148 #endif
149 #ifdef PHDF5
150 CALL ext_phdf5_ioexit(ierr(3) )
151 #endif
152 #ifdef PNETCDF
153 CALL ext_pnc_ioexit(ierr(3) )
154 #endif
155 #ifdef MCELIO
156 CALL ext_mcel_ioexit( ierr(4) )
157 #endif
158 #ifdef XXX
159 CALL ext_xxx_ioexit( ierr(5) )
160 #endif
161 #ifdef YYY
162 CALL ext_yyy_ioexit( ierr(6) )
163 #endif
164 #ifdef ZZZ
165 CALL ext_zzz_ioexit( ierr(7) )
166 #endif
167 #ifdef ESMFIO
168 CALL ext_esmf_ioexit( ierr(8) )
169 #endif
170 #ifdef GRIB1
171 CALL ext_gr1_ioexit( ierr(9) )
172 #endif
173 #ifdef GRIB2
174 CALL ext_gr2_ioexit( ierr(10) )
175 #endif
177 IF ( use_output_servers() ) CALL wrf_quilt_ioexit( ierr(11) )
178 minerr = MINVAL(ierr)
179 maxerr = MAXVAL(ierr)
180 IF ( minerr < 0 ) THEN
181 Status = minerr
182 ELSE IF ( maxerr > 0 ) THEN
183 Status = maxerr
184 ELSE
185 Status = 0
186 ENDIF
187 END SUBROUTINE wrf_ioexit
189 !--- open_for_write_begin
191 SUBROUTINE wrf_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInfo, &
192 DataHandle , Status )
193 !<DESCRIPTION>
194 !<PRE>
195 ! Begin data definition ("training") phase for writing to WRF dataset
196 ! FileName.
197 !</PRE>
198 !</DESCRIPTION>
199 USE module_state_description
200 IMPLICIT NONE
201 #include "wrf_io_flags.h"
202 CHARACTER*(*) :: FileName
203 INTEGER , INTENT(IN) :: Comm_compute , Comm_io
204 CHARACTER*(*), INTENT(INOUT):: SysDepInfo
205 INTEGER , INTENT(OUT) :: DataHandle
206 INTEGER , INTENT(OUT) :: Status
207 !Local
208 CHARACTER*128 :: DataSet
209 INTEGER :: io_form
210 INTEGER :: Hndl
211 INTEGER, EXTERNAL :: use_package
212 LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers
213 CHARACTER*128 :: LocFilename ! for appending the process ID if necessary
214 INTEGER :: myproc
215 CHARACTER*128 :: mess
216 CHARACTER*1028 :: tstr
218 WRITE(mess,*) 'module_io.F: in wrf_open_for_write_begin, FileName = ',TRIM(FileName)
219 CALL wrf_debug( DEBUG_LVL, mess )
221 CALL get_value_from_pairs ( "DATASET" , SysDepInfo , DataSet )
223 io_form = io_form_for_dataset( DataSet )
225 Status = 0
226 Hndl = -1
227 IF ( multi_files( io_form ) .OR. .NOT. use_output_servers() ) THEN
228 SELECT CASE ( use_package(io_form) )
229 #ifdef NETCDF
230 CASE ( IO_NETCDF )
231 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
232 IF ( multi_files(io_form) ) THEN
233 CALL wrf_get_myproc ( myproc )
234 CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
235 ELSE
236 LocFilename = FileName
237 ENDIF
238 CALL ext_ncd_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
239 Hndl , Status )
240 ENDIF
241 IF ( .NOT. multi_files(io_form) ) THEN
242 CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
243 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
244 ENDIF
245 #endif
246 #ifdef PHDF5
247 CASE (IO_PHDF5 )
248 CALL ext_phdf5_open_for_write_begin( FileName, Comm_compute, Comm_io, SysDepInfo, &
249 Hndl, Status)
250 #endif
251 #ifdef PNETCDF
252 CASE (IO_PNETCDF )
253 CALL ext_pnc_open_for_write_begin( FileName, Comm_compute, Comm_io, SysDepInfo, &
254 Hndl, Status)
255 #endif
256 #ifdef XXX
257 CASE ( IO_XXX )
258 CALL ext_xxx_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
259 Hndl , Status )
260 #endif
261 #ifdef YYY
262 CASE ( IO_YYY )
263 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
264 IF ( multi_files(io_form) ) THEN
265 CALL wrf_get_myproc ( myproc )
266 CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
267 ELSE
268 LocFilename = FileName
269 ENDIF
270 CALL ext_yyy_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
271 Hndl , Status )
272 ENDIF
273 IF ( .NOT. multi_files(io_form) ) THEN
274 CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
275 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
276 ENDIF
277 #endif
278 #ifdef ZZZ
279 CASE ( IO_ZZZ )
280 CALL ext_zzz_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
281 Hndl , Status )
282 #endif
283 #ifdef GRIB1
284 CASE ( IO_GRIB1 )
285 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
286 IF ( multi_files(io_form) ) THEN
287 CALL wrf_get_myproc ( myproc )
288 CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
289 ELSE
290 LocFilename = FileName
291 ENDIF
292 CALL ext_gr1_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
293 Hndl , Status )
294 ENDIF
295 IF ( .NOT. multi_files(io_form) ) THEN
296 CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
297 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
298 ENDIF
299 #endif
300 #ifdef GRIB2
301 CASE ( IO_GRIB2 )
302 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
303 IF ( multi_files(io_form) ) THEN
304 CALL wrf_get_myproc ( myproc )
305 CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
306 ELSE
307 LocFilename = FileName
308 ENDIF
309 CALL ext_gr2_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
310 Hndl , Status )
311 ENDIF
312 IF ( .NOT. multi_files(io_form) ) THEN
313 CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
314 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
315 ENDIF
316 #endif
317 #ifdef MCELIO
318 CASE ( IO_MCEL )
319 IF ( wrf_dm_on_monitor() ) THEN
320 tstr = TRIM(SysDepInfo) // ',' // 'LAT_R=XLAT,LON_R=XLONG,LANDMASK_I=LU_MASK'
321 CALL ext_mcel_open_for_write_begin ( FileName , Comm_compute, Comm_io, tstr, &
322 Hndl , Status )
323 ENDIF
324 CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
325 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
326 #endif
327 #ifdef ESMFIO
328 CASE ( IO_ESMF )
329 CALL ext_esmf_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
330 Hndl , Status )
331 #endif
332 #ifdef INTIO
333 CASE ( IO_INTIO )
334 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
335 IF ( multi_files(io_form) ) THEN
336 CALL wrf_get_myproc ( myproc )
337 CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
338 ELSE
339 LocFilename = FileName
340 ENDIF
341 CALL ext_int_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
342 Hndl , Status )
343 ENDIF
344 IF ( .NOT. multi_files(io_form) ) THEN
345 CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
346 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
347 ENDIF
348 #endif
349 CASE DEFAULT
350 IF ( io_form .NE. 0 ) THEN
351 WRITE(mess,*)'Tried to open ',FileName,' writing: no valid io_form (',io_form,')'
352 CALL wrf_debug(1, mess)
353 Status = WRF_FILE_NOT_OPENED
354 ENDIF
355 END SELECT
356 ELSE IF ( use_output_servers() ) THEN
357 IF ( io_form .GT. 0 ) THEN
358 CALL wrf_quilt_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
359 Hndl , io_form, Status )
360 ENDIF
361 ELSE
362 Status = 0
363 ENDIF
364 CALL add_new_handle( Hndl, io_form, .TRUE., DataHandle )
365 END SUBROUTINE wrf_open_for_write_begin
367 !--- open_for_write_commit
369 SUBROUTINE wrf_open_for_write_commit( DataHandle , Status )
370 !<DESCRIPTION>
371 !<PRE>
372 ! This routine switches an internal flag to enable output for the data set
373 ! referenced by DataHandle. The call to wrf_open_for_write_commit() must be
374 ! paired with a call to wrf_open_for_write_begin().
375 !</PRE>
376 !</DESCRIPTION>
377 USE module_state_description
378 IMPLICIT NONE
379 INTEGER , INTENT(IN ) :: DataHandle
380 INTEGER , INTENT(OUT) :: Status
382 CHARACTER (128) :: DataSet
383 INTEGER :: io_form
384 INTEGER :: Hndl
385 LOGICAL :: for_out
386 INTEGER, EXTERNAL :: use_package
387 LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers
388 #include "wrf_io_flags.h"
390 CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_write_commit' )
392 Status = 0
393 CALL get_handle ( Hndl, io_form , for_out, DataHandle )
394 CALL set_first_operation( DataHandle )
395 IF ( Hndl .GT. -1 ) THEN
396 IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN
397 SELECT CASE ( use_package(io_form) )
398 #ifdef NETCDF
399 CASE ( IO_NETCDF )
400 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
401 CALL ext_ncd_open_for_write_commit ( Hndl , Status )
402 ENDIF
403 IF ( .NOT. multi_files(io_form) ) CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
404 #endif
405 #ifdef MCELIO
406 CASE ( IO_MCEL )
407 IF ( wrf_dm_on_monitor() ) THEN
408 CALL ext_mcel_open_for_write_commit ( Hndl , Status )
409 ENDIF
410 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
411 #endif
412 #ifdef ESMFIO
413 CASE ( IO_ESMF )
414 CALL ext_esmf_open_for_write_commit ( Hndl , Status )
415 #endif
416 #ifdef PHDF5
417 CASE ( IO_PHDF5 )
418 CALL ext_phdf5_open_for_write_commit ( Hndl , Status )
419 #endif
420 #ifdef PNETCDF
421 CASE ( IO_PNETCDF )
422 CALL ext_pnc_open_for_write_commit ( Hndl , Status )
423 #endif
424 #ifdef XXX
425 CASE ( IO_XXX )
426 CALL ext_xxx_open_for_write_commit ( Hndl , Status )
427 #endif
428 #ifdef YYY
429 CASE ( IO_YYY )
430 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
431 CALL ext_yyy_open_for_write_commit ( Hndl , Status )
432 ENDIF
433 IF ( .NOT. multi_files(io_form) ) CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
434 #endif
435 #ifdef ZZZ
436 CASE ( IO_ZZZ )
437 CALL ext_zzz_open_for_write_commit ( Hndl , Status )
438 #endif
439 #ifdef GRIB1
440 CASE ( IO_GRIB1 )
441 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
442 CALL ext_gr1_open_for_write_commit ( Hndl , Status )
443 ENDIF
444 IF ( .NOT. multi_files(io_form) ) CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
445 #endif
446 #ifdef GRIB2
447 CASE ( IO_GRIB2 )
448 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
449 CALL ext_gr2_open_for_write_commit ( Hndl , Status )
450 ENDIF
451 IF ( .NOT. multi_files(io_form) ) CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
452 #endif
453 #ifdef INTIO
454 CASE ( IO_INTIO )
455 CALL ext_int_open_for_write_commit ( Hndl , Status )
456 #endif
457 CASE DEFAULT
458 Status = 0
459 END SELECT
460 ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN
461 CALL wrf_quilt_open_for_write_commit ( Hndl , Status )
462 ELSE
463 Status = 0
464 ENDIF
465 ELSE
466 Status = 0
467 ENDIF
468 RETURN
469 END SUBROUTINE wrf_open_for_write_commit
471 !--- open_for_read_begin
473 SUBROUTINE wrf_open_for_read_begin( FileName , Comm_compute, Comm_io, SysDepInfo, &
474 DataHandle , Status )
475 !<DESCRIPTION>
476 !<PRE>
477 ! Begin data definition ("training") phase for reading from WRF dataset
478 ! FileName.
479 !</PRE>
480 !</DESCRIPTION>
481 USE module_state_description
482 IMPLICIT NONE
483 #include "wrf_io_flags.h"
484 CHARACTER*(*) :: FileName
485 INTEGER , INTENT(IN) :: Comm_compute , Comm_io
486 CHARACTER*(*) :: SysDepInfo
487 INTEGER , INTENT(OUT) :: DataHandle
488 INTEGER , INTENT(OUT) :: Status
490 CHARACTER*128 :: DataSet
491 INTEGER :: io_form
492 INTEGER :: Hndl
493 LOGICAL :: also_for_out
494 INTEGER, EXTERNAL :: use_package
495 LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers
497 CHARACTER*128 :: LocFilename ! for appending the process ID if necessary
498 INTEGER myproc
499 CHARACTER*128 :: mess, fhand
500 CHARACTER*1028 :: tstr
502 CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_read_begin' )
504 CALL get_value_from_pairs ( "DATASET" , SysDepInfo , DataSet )
506 io_form = io_form_for_dataset( DataSet )
508 Status = 0
509 Hndl = -1
510 also_for_out = .FALSE.
511 ! IF ( .NOT. use_output_servers() ) THEN
512 SELECT CASE ( use_package(io_form) )
513 #ifdef NETCDF
514 CASE ( IO_NETCDF )
515 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
516 IF ( multi_files(io_form) ) THEN
517 CALL wrf_get_myproc ( myproc )
518 CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
519 ELSE
520 LocFilename = FileName
521 ENDIF
522 CALL ext_ncd_open_for_read_begin ( LocFilename , Comm_compute, Comm_io, SysDepInfo, &
523 Hndl , Status )
524 ENDIF
525 IF ( .NOT. multi_files(io_form) ) THEN
526 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
527 CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
528 ENDIF
529 #endif
530 #ifdef XXX
531 CASE ( IO_XXX )
532 CALL ext_xxx_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
533 Hndl , Status )
534 #endif
535 #ifdef YYY
536 CASE ( IO_YYY )
537 CALL ext_yyy_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
538 Hndl , Status )
539 #endif
540 #ifdef ZZZ
541 CASE ( IO_ZZZ )
542 CALL ext_zzz_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
543 Hndl , Status )
544 #endif
545 #ifdef MCELIO
546 CASE ( IO_MCEL )
547 also_for_out = .TRUE.
548 IF ( wrf_dm_on_monitor() ) THEN
550 WRITE(fhand,'(a,i0)')"filter_",filtno
551 filtno = filtno + 1
552 tstr = TRIM(SysDepInfo) // ',' // 'READ_MODE=UPDATE,LAT_R=XLAT,LON_R=XLONG,LANDMASK_I=LU_MASK,FILTER_HANDLE=' // TRIM(fhand)
553 CALL ext_mcel_open_for_read_begin ( FileName , Comm_compute, Comm_io, tstr, &
554 Hndl , Status )
555 ENDIF
556 CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
557 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
558 #endif
559 #ifdef ESMFIO
560 CASE ( IO_ESMF )
561 also_for_out = .TRUE.
562 CALL ext_esmf_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
563 Hndl , Status )
564 #endif
565 #ifdef GRIB1
566 CASE ( IO_GRIB1 )
567 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
568 IF ( multi_files(io_form) ) THEN
569 CALL wrf_get_myproc ( myproc )
570 CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
571 ELSE
572 LocFilename = FileName
573 ENDIF
574 CALL ext_gr1_open_for_read_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
575 Hndl , Status )
576 ENDIF
577 IF ( .NOT. multi_files(io_form) ) THEN
578 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
579 CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
580 ENDIF
581 #endif
582 #ifdef GRIB2
583 CASE ( IO_GRIB2 )
584 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
585 IF ( multi_files(io_form) ) THEN
586 CALL wrf_get_myproc ( myproc )
587 CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
588 ELSE
589 LocFilename = FileName
590 ENDIF
591 CALL ext_gr2_open_for_read_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
592 Hndl , Status )
593 ENDIF
594 IF ( .NOT. multi_files(io_form) ) THEN
595 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
596 CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
597 ENDIF
598 #endif
599 #ifdef INTIO
600 CASE ( IO_INTIO )
601 #endif
602 CASE DEFAULT
603 IF ( io_form .NE. 0 ) THEN
604 WRITE(mess,*)'Tried to open ',FileName,' reading: no valid io_form (',io_form,')'
605 CALL wrf_message(mess)
606 ENDIF
607 Status = WRF_FILE_NOT_OPENED
608 END SELECT
609 ! ELSE
610 ! Status = 0
611 ! ENDIF
612 CALL add_new_handle( Hndl, io_form, also_for_out, DataHandle )
613 END SUBROUTINE wrf_open_for_read_begin
615 !--- open_for_read_commit
617 SUBROUTINE wrf_open_for_read_commit( DataHandle , Status )
618 !<DESCRIPTION>
619 !<PRE>
620 ! End "training" phase for WRF dataset FileName. The call to
621 ! wrf_open_for_read_commit() must be paired with a call to
622 ! wrf_open_for_read_begin().
623 !</PRE>
624 !</DESCRIPTION>
625 USE module_state_description
626 IMPLICIT NONE
627 INTEGER , INTENT(IN ) :: DataHandle
628 INTEGER , INTENT(OUT) :: Status
630 CHARACTER (128) :: DataSet
631 INTEGER :: io_form
632 INTEGER :: Hndl
633 LOGICAL :: for_out
634 INTEGER, EXTERNAL :: use_package
635 LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers
636 #include "wrf_io_flags.h"
638 CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_read_commit' )
640 Status = 0
641 CALL get_handle ( Hndl, io_form , for_out, DataHandle )
642 CALL set_first_operation( DataHandle )
643 IF ( Hndl .GT. -1 ) THEN
644 IF ( .NOT. (for_out .AND. use_output_servers()) ) THEN
645 SELECT CASE ( use_package(io_form) )
646 #ifdef NETCDF
647 CASE ( IO_NETCDF )
648 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
649 CALL ext_ncd_open_for_read_commit ( Hndl , Status )
650 ENDIF
651 IF ( .NOT. multi_files(io_form) ) CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
652 #endif
653 #ifdef MCELIO
654 CASE ( IO_MCEL )
655 IF ( wrf_dm_on_monitor() ) THEN
656 CALL ext_mcel_open_for_read_commit ( Hndl , Status )
657 ENDIF
658 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
659 #endif
660 #ifdef ESMFIO
661 CASE ( IO_ESMF )
662 CALL ext_esmf_open_for_read_commit ( Hndl , Status )
663 #endif
664 #ifdef XXX
665 CASE ( IO_XXX )
666 CALL ext_xxx_open_for_read_commit ( Hndl , Status )
667 #endif
668 #ifdef YYY
669 CASE ( IO_YYY )
670 CALL ext_yyy_open_for_read_commit ( Hndl , Status )
671 #endif
672 #ifdef ZZZ
673 CASE ( IO_ZZZ )
674 CALL ext_zzz_open_for_read_commit ( Hndl , Status )
675 #endif
676 #ifdef GRIB1
677 CASE ( IO_GRIB1 )
678 CALL ext_gr1_open_for_read_commit ( Hndl , Status )
679 #endif
680 #ifdef GRIB2
681 CASE ( IO_GRIB2 )
682 CALL ext_gr2_open_for_read_commit ( Hndl , Status )
683 #endif
684 #ifdef INTIO
685 CASE ( IO_INTIO )
686 #endif
687 CASE DEFAULT
688 Status = 0
689 END SELECT
690 ELSE
691 Status = 0
692 ENDIF
693 ELSE
694 Status = WRF_FILE_NOT_OPENED
695 ENDIF
696 RETURN
697 END SUBROUTINE wrf_open_for_read_commit
699 !--- open_for_read
701 SUBROUTINE wrf_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
702 DataHandle , Status )
703 !<DESCRIPTION>
704 !<PRE>
705 ! Opens a WRF dataset for reading.
706 !</PRE>
707 !</DESCRIPTION>
708 USE module_state_description
709 IMPLICIT NONE
710 CHARACTER*(*) :: FileName
711 INTEGER , INTENT(IN) :: Comm_compute , Comm_io
712 CHARACTER*(*) :: SysDepInfo
713 INTEGER , INTENT(OUT) :: DataHandle
714 INTEGER , INTENT(OUT) :: Status
716 CHARACTER (128) :: DataSet, LocFileName
717 INTEGER :: io_form, myproc
718 INTEGER :: Hndl
719 INTEGER, EXTERNAL :: use_package
720 LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers
722 CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_read' )
724 CALL get_value_from_pairs ( "DATASET" , SysDepInfo , DataSet )
726 io_form = io_form_for_dataset( DataSet )
728 Hndl = -1
729 Status = 0
730 SELECT CASE ( use_package(io_form) )
731 #ifdef NETCDF
732 CASE ( IO_NETCDF )
733 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
734 IF ( multi_files(io_form) ) THEN
735 CALL wrf_get_myproc ( myproc )
736 CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
737 ELSE
738 LocFilename = FileName
739 ENDIF
741 CALL ext_ncd_open_for_read ( LocFilename , Comm_compute, Comm_io, SysDepInfo, &
742 Hndl , Status )
743 ENDIF
744 IF ( .NOT. multi_files(io_form) ) THEN
745 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
746 CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
747 ENDIF
748 #endif
749 #ifdef PHDF5
750 CASE ( IO_PHDF5 )
751 CALL ext_phdf5_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
752 Hndl , Status )
753 #endif
754 #ifdef PNETCDF
755 CASE ( IO_PNETCDF )
756 CALL ext_pnc_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
757 Hndl , Status )
758 #endif
759 #ifdef XXX
760 CASE ( IO_XXX )
761 CALL ext_xxx_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
762 Hndl , Status )
763 #endif
764 #ifdef YYY
765 CASE ( IO_YYY )
766 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
767 IF ( multi_files(io_form) ) THEN
768 CALL wrf_get_myproc ( myproc )
769 CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
770 ELSE
771 LocFilename = FileName
772 ENDIF
774 CALL ext_yyy_open_for_read ( LocFilename , Comm_compute, Comm_io, SysDepInfo, &
775 Hndl , Status )
776 ENDIF
777 IF ( .NOT. multi_files(io_form) ) THEN
778 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
779 CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
780 ENDIF
781 #endif
782 #ifdef ZZZ
783 CASE ( IO_ZZZ )
784 CALL ext_zzz_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
785 Hndl , Status )
786 #endif
787 #ifdef GRIB1
788 CASE ( IO_GRIB1 )
789 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
790 IF ( multi_files(io_form) ) THEN
791 CALL wrf_get_myproc ( myproc )
792 CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
793 ELSE
794 LocFilename = FileName
795 ENDIF
797 CALL ext_gr1_open_for_read ( LocFilename , Comm_compute, Comm_io, SysDepInfo, &
798 Hndl , Status )
799 ENDIF
800 IF ( .NOT. multi_files(io_form) ) THEN
801 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
802 CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
803 ENDIF
804 #endif
805 #ifdef GRIB2
806 CASE ( IO_GRIB2 )
807 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
808 IF ( multi_files(io_form) ) THEN
809 CALL wrf_get_myproc ( myproc )
810 CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
811 ELSE
812 LocFilename = FileName
813 ENDIF
815 CALL ext_gr2_open_for_read ( LocFilename , Comm_compute, Comm_io, SysDepInfo, &
816 Hndl , Status )
817 ENDIF
818 IF ( .NOT. multi_files(io_form) ) THEN
819 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
820 CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
821 ENDIF
822 #endif
823 #ifdef INTIO
824 CASE ( IO_INTIO )
825 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
826 IF ( multi_files(io_form) ) THEN
827 CALL wrf_get_myproc ( myproc )
828 CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
829 ELSE
830 LocFilename = FileName
831 ENDIF
832 CALL ext_int_open_for_read ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
833 Hndl , Status )
834 ENDIF
835 IF ( .NOT. multi_files(io_form) ) THEN
836 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
837 CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
838 ENDIF
839 #endif
840 CASE DEFAULT
841 Status = 0
842 END SELECT
843 CALL add_new_handle( Hndl, io_form, .FALSE., DataHandle )
844 RETURN
845 END SUBROUTINE wrf_open_for_read
847 !--- inquire_opened
849 SUBROUTINE wrf_inquire_opened ( DataHandle, FileName , FileStatus, Status )
850 !<DESCRIPTION>
851 !<PRE>
852 ! Inquire if the dataset referenced by DataHandle is open.
853 !</PRE>
854 !</DESCRIPTION>
855 USE module_state_description
856 IMPLICIT NONE
857 INTEGER , INTENT(IN) :: DataHandle
858 CHARACTER*(*) :: FileName
859 INTEGER , INTENT(OUT) :: FileStatus
860 INTEGER , INTENT(OUT) :: Status
861 LOGICAL :: for_out
862 INTEGER, EXTERNAL :: use_package
863 LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers
864 #include "wrf_io_flags.h"
865 #include "wrf_status_codes.h"
867 INTEGER io_form , Hndl
869 CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_inquire_opened' )
871 Status = 0
872 CALL get_handle ( Hndl, io_form , for_out, DataHandle )
873 IF ( Hndl .GT. -1 ) THEN
874 IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN
875 SELECT CASE ( use_package(io_form) )
876 #ifdef NETCDF
877 CASE ( IO_NETCDF )
878 IF (wrf_dm_on_monitor()) CALL ext_ncd_inquire_opened ( Hndl, FileName , FileStatus, Status )
879 CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
880 CALL wrf_dm_bcast_bytes( Status , IWORDSIZE )
881 #endif
882 #ifdef PHDF5
883 CASE ( IO_PHDF5 )
884 CALL ext_phdf5_inquire_opened ( Hndl, FileName , FileStatus, Status )
885 #endif
886 #ifdef PNETCDF
887 CASE ( IO_PNETCDF )
888 CALL ext_pnc_inquire_opened ( Hndl, FileName , FileStatus, Status )
889 #endif
890 #ifdef XXX
891 CASE ( IO_XXX )
892 CALL ext_xxx_inquire_opened ( Hndl, FileName , FileStatus, Status )
893 #endif
894 #ifdef YYY
895 CASE ( IO_YYY )
896 IF (wrf_dm_on_monitor()) CALL ext_yyy_inquire_opened ( Hndl, FileName , FileStatus, Status )
897 CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
898 CALL wrf_dm_bcast_bytes( Status , IWORDSIZE )
899 #endif
900 #ifdef ZZZ
901 CASE ( IO_ZZZ )
902 CALL ext_zzz_inquire_opened ( Hndl, FileName , FileStatus, Status )
903 #endif
904 #ifdef GRIB1
905 CASE ( IO_GRIB1 )
906 IF (wrf_dm_on_monitor()) CALL ext_gr1_inquire_opened ( Hndl, FileName , FileStatus, Status )
907 CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
908 CALL wrf_dm_bcast_bytes( Status , IWORDSIZE )
909 #endif
910 #ifdef GRIB2
911 CASE ( IO_GRIB2 )
912 IF (wrf_dm_on_monitor()) CALL ext_gr2_inquire_opened ( Hndl, FileName , FileStatus, Status )
913 CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
914 CALL wrf_dm_bcast_bytes( Status , IWORDSIZE )
915 #endif
916 #ifdef INTIO
917 CASE ( IO_INTIO )
918 IF (wrf_dm_on_monitor()) CALL ext_int_inquire_opened ( Hndl, FileName , FileStatus, Status )
919 CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
920 CALL wrf_dm_bcast_bytes( Status , IWORDSIZE )
921 #endif
922 CASE DEFAULT
923 FileStatus = WRF_FILE_NOT_OPENED
924 Status = 0
925 END SELECT
926 ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN
927 CALL wrf_quilt_inquire_opened ( Hndl, FileName , FileStatus, Status )
928 ENDIF
929 ELSE
930 FileStatus = WRF_FILE_NOT_OPENED
931 Status = 0
932 ENDIF
933 RETURN
934 END SUBROUTINE wrf_inquire_opened
936 !--- inquire_filename
939 SUBROUTINE wrf_inquire_filename ( DataHandle, FileName , FileStatus, Status )
940 !<DESCRIPTION>
941 !<PRE>
942 ! Returns the Filename and FileStatus associated with DataHandle.
943 !</PRE>
944 !</DESCRIPTION>
945 USE module_state_description
946 IMPLICIT NONE
947 INTEGER , INTENT(IN) :: DataHandle
948 CHARACTER*(*) :: FileName
949 INTEGER , INTENT(OUT) :: FileStatus
950 INTEGER , INTENT(OUT) :: Status
951 #include "wrf_status_codes.h"
952 INTEGER, EXTERNAL :: use_package
953 LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers
954 LOGICAL :: for_out
956 INTEGER io_form , Hndl
958 CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_inquire_filename' )
960 Status = 0
961 CALL get_handle ( Hndl, io_form , for_out, DataHandle )
962 IF ( Hndl .GT. -1 ) THEN
963 IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN
964 SELECT CASE ( use_package( io_form ) )
965 #ifdef NETCDF
966 CASE ( IO_NETCDF )
967 IF (wrf_dm_on_monitor()) CALL ext_ncd_inquire_filename ( Hndl, FileName , FileStatus, Status )
968 CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
969 CALL wrf_dm_bcast_bytes( Status , IWORDSIZE )
970 #endif
971 #ifdef PHDF5
972 CASE ( IO_PHDF5 )
973 CALL ext_phdf5_inquire_filename ( Hndl, FileName , FileStatus, Status )
974 #endif
975 #ifdef PNETCDF
976 CASE ( IO_PNETCDF )
977 CALL ext_pnc_inquire_filename ( Hndl, FileName , FileStatus, Status )
978 #endif
979 #ifdef XXX
980 CASE ( IO_XXX )
981 CALL ext_xxx_inquire_filename ( Hndl, FileName , FileStatus, Status )
982 #endif
983 #ifdef YYY
984 CASE ( IO_YYY )
985 IF (wrf_dm_on_monitor()) CALL ext_yyy_inquire_filename ( Hndl, FileName , FileStatus, Status )
986 CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
987 CALL wrf_dm_bcast_bytes( Status , IWORDSIZE )
988 #endif
989 #ifdef ZZZ
990 CASE ( IO_ZZZ )
991 CALL ext_zzz_inquire_filename ( Hndl, FileName , FileStatus, Status )
992 #endif
993 #ifdef GRIB1
994 CASE ( IO_GRIB1 )
995 IF (wrf_dm_on_monitor()) CALL ext_gr1_inquire_filename ( Hndl, FileName , FileStatus, Status )
996 CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
997 CALL wrf_dm_bcast_bytes( Status , IWORDSIZE )
998 #endif
999 #ifdef GRIB2
1000 CASE ( IO_GRIB2 )
1001 IF (wrf_dm_on_monitor()) CALL ext_gr2_inquire_filename ( Hndl, FileName , FileStatus, Status )
1002 CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
1003 CALL wrf_dm_bcast_bytes( Status , IWORDSIZE )
1004 #endif
1005 #ifdef INTIO
1006 CASE ( IO_INTIO )
1007 IF (wrf_dm_on_monitor()) CALL ext_int_inquire_filename ( Hndl, FileName , FileStatus, Status )
1008 CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
1009 CALL wrf_dm_bcast_bytes( Status , IWORDSIZE )
1010 #endif
1011 CASE DEFAULT
1012 Status = 0
1013 END SELECT
1014 ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN
1015 CALL wrf_quilt_inquire_filename ( Hndl, FileName , FileStatus, Status )
1016 ENDIF
1017 ELSE
1018 FileName = ""
1019 Status = 0
1020 ENDIF
1021 RETURN
1022 END SUBROUTINE wrf_inquire_filename
1024 !--- sync
1026 SUBROUTINE wrf_iosync ( DataHandle, Status )
1027 !<DESCRIPTION>
1028 !<PRE>
1029 ! Synchronize the disk copy of a dataset with memory buffers.
1030 !</PRE>
1031 !</DESCRIPTION>
1032 USE module_state_description
1033 IMPLICIT NONE
1034 INTEGER , INTENT(IN) :: DataHandle
1035 INTEGER , INTENT(OUT) :: Status
1036 #include "wrf_status_codes.h"
1037 INTEGER, EXTERNAL :: use_package
1038 LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers
1039 LOGICAL :: for_out
1041 INTEGER io_form , Hndl
1043 CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_iosync' )
1045 Status = 0
1046 CALL get_handle ( Hndl, io_form , for_out, DataHandle )
1047 IF ( Hndl .GT. -1 ) THEN
1048 IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN
1049 SELECT CASE ( use_package(io_form) )
1050 #ifdef NETCDF
1051 CASE ( IO_NETCDF )
1052 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_ncd_iosync( Hndl, Status )
1053 CALL wrf_dm_bcast_bytes( Status , IWORDSIZE )
1054 #endif
1055 #ifdef XXX
1056 CASE ( IO_XXX )
1057 CALL ext_xxx_iosync( Hndl, Status )
1058 #endif
1059 #ifdef YYY
1060 CASE ( IO_YYY )
1061 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_yyy_iosync( Hndl, Status )
1062 CALL wrf_dm_bcast_bytes( Status , IWORDSIZE )
1063 #endif
1064 #ifdef GRIB1
1065 CASE ( IO_GRIB1 )
1066 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr1_iosync( Hndl, Status )
1067 CALL wrf_dm_bcast_bytes( Status , IWORDSIZE )
1068 #endif
1069 #ifdef GRIB2
1070 CASE ( IO_GRIB2 )
1071 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr2_iosync( Hndl, Status )
1072 CALL wrf_dm_bcast_bytes( Status , IWORDSIZE )
1073 #endif
1074 #ifdef ZZZ
1075 CASE ( IO_ZZZ )
1076 CALL ext_zzz_iosync( Hndl, Status )
1077 #endif
1078 #ifdef INTIO
1079 CASE ( IO_INTIO )
1080 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_int_iosync( Hndl, Status )
1081 CALL wrf_dm_bcast_bytes( Status , IWORDSIZE )
1082 #endif
1083 CASE DEFAULT
1084 Status = 0
1085 END SELECT
1086 ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN
1087 CALL wrf_quilt_iosync( Hndl, Status )
1088 ELSE
1089 Status = 0
1090 ENDIF
1091 ELSE
1092 Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1093 ENDIF
1094 RETURN
1095 END SUBROUTINE wrf_iosync
1097 !--- close
1099 SUBROUTINE wrf_ioclose ( DataHandle, Status )
1100 !<DESCRIPTION>
1101 !<PRE>
1102 ! Close the dataset referenced by DataHandle.
1103 !</PRE>
1104 !</DESCRIPTION>
1105 USE module_state_description
1106 IMPLICIT NONE
1107 INTEGER , INTENT(IN) :: DataHandle
1108 INTEGER , INTENT(OUT) :: Status
1109 #include "wrf_status_codes.h"
1110 INTEGER, EXTERNAL :: use_package
1111 LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers
1112 INTEGER io_form , Hndl
1113 LOGICAL :: for_out
1115 CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_ioclose' )
1117 Status = 0
1118 CALL get_handle ( Hndl, io_form , for_out, DataHandle )
1119 IF ( Hndl .GT. -1 ) THEN
1120 IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN
1121 SELECT CASE ( use_package(io_form) )
1122 #ifdef NETCDF
1123 CASE ( IO_NETCDF )
1124 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_ncd_ioclose( Hndl, Status )
1125 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1126 #endif
1127 #ifdef PHDF5
1128 CASE ( IO_PHDF5 )
1129 CALL ext_phdf5_ioclose( Hndl, Status )
1130 #endif
1131 #ifdef PNETCDF
1132 CASE ( IO_PNETCDF )
1133 CALL ext_pnc_ioclose( Hndl, Status )
1134 #endif
1135 #ifdef XXX
1136 CASE ( IO_XXX )
1137 CALL ext_xxx_ioclose( Hndl, Status )
1138 #endif
1139 #ifdef YYY
1140 CASE ( IO_YYY )
1141 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_yyy_ioclose( Hndl, Status )
1142 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1143 #endif
1144 #ifdef ZZZ
1145 CASE ( IO_ZZZ )
1146 CALL ext_zzz_ioclose( Hndl, Status )
1147 #endif
1148 #ifdef GRIB1
1149 CASE ( IO_GRIB1 )
1150 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr1_ioclose( Hndl, Status )
1151 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1152 #endif
1153 #ifdef GRIB2
1154 CASE ( IO_GRIB2 )
1155 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr2_ioclose( Hndl, Status )
1156 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1157 #endif
1158 #ifdef MCELIO
1159 CASE ( IO_MCEL )
1160 CALL ext_mcel_ioclose( Hndl, Status )
1161 #endif
1162 #ifdef ESMFIO
1163 CASE ( IO_ESMF )
1164 CALL ext_esmf_ioclose( Hndl, Status )
1165 #endif
1166 #ifdef INTIO
1167 CASE ( IO_INTIO )
1168 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_int_ioclose( Hndl, Status )
1169 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1170 #endif
1171 CASE DEFAULT
1172 Status = 0
1173 END SELECT
1174 ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN
1175 CALL wrf_quilt_ioclose( Hndl, Status )
1176 ELSE
1177 Status = 0
1178 ENDIF
1179 CALL free_handle( DataHandle )
1180 ELSE
1181 Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1182 ENDIF
1183 RETURN
1184 END SUBROUTINE wrf_ioclose
1186 !--- get_next_time (not defined for IntIO )
1188 SUBROUTINE wrf_get_next_time ( DataHandle, DateStr, Status )
1189 !<DESCRIPTION>
1190 !<PRE>
1191 ! Returns the next time stamp.
1192 !</PRE>
1193 !</DESCRIPTION>
1194 USE module_state_description
1195 IMPLICIT NONE
1196 INTEGER , INTENT(IN) :: DataHandle
1197 CHARACTER*(*) :: DateStr
1198 INTEGER , INTENT(OUT) :: Status
1199 #include "wrf_status_codes.h"
1201 INTEGER, EXTERNAL :: use_package
1202 LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers
1203 INTEGER io_form , Hndl, len_of_str
1204 LOGICAL :: for_out
1206 CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_get_next_time' )
1208 Status = 0
1209 CALL get_handle ( Hndl, io_form , for_out, DataHandle )
1210 IF ( Hndl .GT. -1 ) THEN
1211 IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN
1212 SELECT CASE ( use_package(io_form) )
1213 #ifdef NETCDF
1214 CASE ( IO_NETCDF )
1215 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_ncd_get_next_time( Hndl, DateStr, Status )
1216 IF ( .NOT. multi_files(io_form) ) THEN
1217 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1218 len_of_str = LEN(DateStr)
1219 CALL wrf_dm_bcast_string ( DateStr , len_of_str )
1220 ENDIF
1221 #endif
1222 #ifdef PHDF5
1223 CASE ( IO_PHDF5 )
1224 CALL ext_phdf5_get_next_time( Hndl, DateStr, Status )
1225 #endif
1226 #ifdef PNETCDF
1227 CASE ( IO_PNETCDF )
1228 CALL ext_pnc_get_next_time( Hndl, DateStr, Status )
1229 #endif
1230 #ifdef XXX
1231 CASE ( IO_XXX )
1232 CALL ext_xxx_get_next_time( Hndl, DateStr, Status )
1233 #endif
1234 #ifdef YYY
1235 CASE ( IO_YYY )
1236 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_yyy_get_next_time( Hndl, DateStr, Status )
1237 IF ( .NOT. multi_files(io_form) ) THEN
1238 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1239 len_of_str = LEN(DateStr)
1240 CALL wrf_dm_bcast_string ( DateStr , len_of_str )
1241 ENDIF
1242 #endif
1243 #ifdef ZZZ
1244 CASE ( IO_ZZZ )
1245 CALL ext_zzz_get_next_time( Hndl, DateStr, Status )
1246 #endif
1247 #ifdef GRIB1
1248 CASE ( IO_GRIB1 )
1249 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr1_get_next_time( Hndl, DateStr, Status )
1250 IF ( .NOT. multi_files(io_form) ) THEN
1251 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1252 len_of_str = LEN(DateStr)
1253 CALL wrf_dm_bcast_string ( DateStr , len_of_str )
1254 ENDIF
1255 #endif
1256 #ifdef GRIB2
1257 CASE ( IO_GRIB2 )
1258 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr2_get_next_time( Hndl, DateStr, Status )
1259 IF ( .NOT. multi_files(io_form) ) THEN
1260 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1261 len_of_str = LEN(DateStr)
1262 CALL wrf_dm_bcast_string ( DateStr , len_of_str )
1263 ENDIF
1264 #endif
1265 #ifdef INTIO
1266 CASE ( IO_INTIO )
1267 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_int_get_next_time( Hndl, DateStr, Status )
1268 IF ( .NOT. multi_files(io_form) ) THEN
1269 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1270 len_of_str = LEN(DateStr)
1271 CALL wrf_dm_bcast_string ( DateStr , len_of_str )
1272 ENDIF
1273 #endif
1274 CASE DEFAULT
1275 Status = 0
1276 END SELECT
1277 ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN
1278 CALL wrf_quilt_get_next_time( Hndl, DateStr, Status )
1279 ELSE
1280 Status = 0
1281 ENDIF
1282 ELSE
1283 Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1284 ENDIF
1285 RETURN
1286 END SUBROUTINE wrf_get_next_time
1288 !--- get_previous_time (not defined for IntIO )
1290 SUBROUTINE wrf_get_previous_time ( DataHandle, DateStr, Status )
1291 !<DESCRIPTION>
1292 !<PRE>
1293 ! Returns the previous time stamp.
1294 !</PRE>
1295 !</DESCRIPTION>
1296 USE module_state_description
1297 IMPLICIT NONE
1298 INTEGER , INTENT(IN) :: DataHandle
1299 CHARACTER*(*) :: DateStr
1300 INTEGER , INTENT(OUT) :: Status
1301 #include "wrf_status_codes.h"
1303 INTEGER, EXTERNAL :: use_package
1304 LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers
1305 INTEGER io_form , Hndl, len_of_str
1306 LOGICAL :: for_out
1308 CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_get_previous_time' )
1310 Status = 0
1311 CALL get_handle ( Hndl, io_form , for_out, DataHandle )
1312 IF ( Hndl .GT. -1 ) THEN
1313 IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN
1314 SELECT CASE ( use_package(io_form) )
1315 #ifdef NETCDF
1316 CASE ( IO_NETCDF )
1317 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_ncd_get_previous_time( Hndl, DateStr, Status )
1318 IF ( .NOT. multi_files(io_form) ) THEN
1319 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1320 len_of_str = LEN(DateStr)
1321 CALL wrf_dm_bcast_string ( DateStr , len_of_str )
1322 ENDIF
1323 #endif
1324 #ifdef PHDF5
1325 CASE ( IO_PHDF5 )
1326 CALL ext_phdf5_get_previous_time( Hndl, DateStr, Status )
1327 #endif
1328 #ifdef PNETCDF
1329 CASE ( IO_PNETCDF )
1330 CALL ext_pnc_get_previous_time( Hndl, DateStr, Status )
1331 #endif
1332 #ifdef XXX
1333 CASE ( IO_XXX )
1334 CALL ext_xxx_get_previous_time( Hndl, DateStr, Status )
1335 #endif
1336 #ifdef YYY
1337 CASE ( IO_YYY )
1338 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_yyy_get_previous_time( Hndl, DateStr, Status )
1339 IF ( .NOT. multi_files(io_form) ) THEN
1340 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1341 len_of_str = LEN(DateStr)
1342 CALL wrf_dm_bcast_string ( DateStr , len_of_str )
1343 ENDIF
1344 #endif
1345 #ifdef ZZZ
1346 CASE ( IO_ZZZ )
1347 CALL ext_zzz_get_previous_time( Hndl, DateStr, Status )
1348 #endif
1349 #ifdef GRIB1
1350 CASE ( IO_GRIB1 )
1351 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr1_get_previous_time( Hndl, DateStr, Status )
1352 IF ( .NOT. multi_files(io_form) ) THEN
1353 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1354 len_of_str = LEN(DateStr)
1355 CALL wrf_dm_bcast_string ( DateStr , len_of_str )
1356 ENDIF
1357 #endif
1358 #ifdef GRIB2
1359 CASE ( IO_GRIB2 )
1360 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr2_get_previous_time( Hndl, DateStr, Status )
1361 IF ( .NOT. multi_files(io_form) ) THEN
1362 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1363 len_of_str = LEN(DateStr)
1364 CALL wrf_dm_bcast_string ( DateStr , len_of_str )
1365 ENDIF
1366 #endif
1367 #ifdef INTIO
1368 #endif
1369 CASE DEFAULT
1370 Status = 0
1371 END SELECT
1372 ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN
1373 CALL wrf_quilt_get_previous_time( Hndl, DateStr, Status )
1374 ELSE
1375 Status = 0
1376 ENDIF
1377 ELSE
1378 Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1379 ENDIF
1380 RETURN
1381 END SUBROUTINE wrf_get_previous_time
1383 !--- set_time
1385 SUBROUTINE wrf_set_time ( DataHandle, DateStr, Status )
1386 !<DESCRIPTION>
1387 !<PRE>
1388 ! Sets the time stamp.
1389 !</PRE>
1390 !</DESCRIPTION>
1391 USE module_state_description
1392 IMPLICIT NONE
1393 INTEGER , INTENT(IN) :: DataHandle
1394 CHARACTER*(*) :: DateStr
1395 INTEGER , INTENT(OUT) :: Status
1396 #include "wrf_status_codes.h"
1398 INTEGER, EXTERNAL :: use_package
1399 LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers
1400 INTEGER io_form , Hndl
1401 LOGICAL :: for_out
1403 CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_set_time' )
1405 Status = 0
1406 CALL get_handle ( Hndl, io_form , for_out, DataHandle )
1407 IF ( Hndl .GT. -1 ) THEN
1408 IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN
1409 SELECT CASE ( use_package( io_form ) )
1410 #ifdef NETCDF
1411 CASE ( IO_NETCDF )
1412 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_ncd_set_time( Hndl, DateStr, Status )
1413 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1414 #endif
1415 #ifdef PHDF5
1416 CASE ( IO_PHDF5 )
1417 CALL ext_phdf5_set_time( Hndl, DateStr, Status )
1418 #endif
1419 #ifdef PNETCDF
1420 CASE ( IO_PNETCDF )
1421 CALL ext_pnc_set_time( Hndl, DateStr, Status )
1422 #endif
1423 #ifdef XXX
1424 CASE ( IO_XXX )
1425 CALL ext_xxx_set_time( Hndl, DateStr, Status )
1426 #endif
1427 #ifdef YYY
1428 CASE ( IO_YYY )
1429 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_yyy_set_time( Hndl, DateStr, Status )
1430 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1431 #endif
1432 #ifdef ZZZ
1433 CASE ( IO_ZZZ )
1434 CALL ext_zzz_set_time( Hndl, DateStr, Status )
1435 #endif
1436 #ifdef GRIB1
1437 CASE ( IO_GRIB1 )
1438 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr1_set_time( Hndl, DateStr, Status )
1439 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1440 #endif
1441 #ifdef GRIB2
1442 CASE ( IO_GRIB2 )
1443 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr2_set_time( Hndl, DateStr, Status )
1444 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1445 #endif
1446 #ifdef INTIO
1447 CASE ( IO_INTIO )
1448 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_int_set_time( Hndl, DateStr, Status )
1449 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1450 #endif
1451 CASE DEFAULT
1452 Status = 0
1453 END SELECT
1454 ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN
1455 CALL wrf_quilt_set_time( Hndl, DateStr, Status )
1456 ELSE
1457 Status = 0
1458 ENDIF
1459 ELSE
1460 Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1461 ENDIF
1462 RETURN
1463 END SUBROUTINE wrf_set_time
1465 !--- get_next_var (not defined for IntIO)
1467 SUBROUTINE wrf_get_next_var ( DataHandle, VarName, Status )
1468 !<DESCRIPTION>
1469 !<PRE>
1470 ! On reading, this routine returns the name of the next variable in the
1471 ! current time frame.
1472 !</PRE>
1473 !</DESCRIPTION>
1474 USE module_state_description
1475 IMPLICIT NONE
1476 INTEGER , INTENT(IN) :: DataHandle
1477 CHARACTER*(*) :: VarName
1478 INTEGER , INTENT(OUT) :: Status
1479 #include "wrf_status_codes.h"
1481 INTEGER, EXTERNAL :: use_package
1482 LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers
1483 INTEGER io_form , Hndl
1484 LOGICAL :: for_out
1486 CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_get_next_var' )
1488 Status = 0
1489 CALL get_handle ( Hndl, io_form , for_out, DataHandle )
1490 IF ( Hndl .GT. -1 ) THEN
1491 IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN
1492 SELECT CASE ( use_package( io_form ) )
1493 #ifdef NETCDF
1494 CASE ( IO_NETCDF )
1495 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_ncd_get_next_var( Hndl, VarName, Status )
1496 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1497 #endif
1498 #ifdef XXX
1499 CASE ( IO_XXX )
1500 CALL ext_xxx_get_next_var( Hndl, VarName, Status )
1501 #endif
1502 #ifdef YYY
1503 CASE ( IO_YYY )
1504 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_yyy_get_next_var( Hndl, VarName, Status )
1505 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1506 #endif
1507 #ifdef ZZZ
1508 CASE ( IO_ZZZ )
1509 CALL ext_zzz_get_next_var( Hndl, VarName, Status )
1510 #endif
1511 #ifdef GRIB1
1512 CASE ( IO_GRIB1 )
1513 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr1_get_next_var( Hndl, VarName, Status )
1514 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1515 #endif
1516 #ifdef GRIB2
1517 CASE ( IO_GRIB2 )
1518 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr2_get_next_var( Hndl, VarName, Status )
1519 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1520 #endif
1521 #ifdef INTIO
1522 CASE ( IO_INTIO )
1523 IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_int_get_next_var( Hndl, VarName, Status )
1524 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1525 #endif
1526 CASE DEFAULT
1527 Status = 0
1528 END SELECT
1529 ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN
1530 CALL wrf_quilt_get_next_var( Hndl, VarName, Status )
1531 ELSE
1532 Status = 0
1533 ENDIF
1534 ELSE
1535 Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1536 ENDIF
1537 RETURN
1538 END SUBROUTINE wrf_get_next_var
1541 ! wrf_get_var_info (not implemented for IntIO)
1543 SUBROUTINE wrf_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagger , &
1544 DomainStart , DomainEnd , Status )
1545 !<DESCRIPTION>
1546 !<PRE>
1547 ! This routine applies only to a dataset that is open for read. It returns
1548 ! information about a variable.
1549 !</PRE>
1550 !</DESCRIPTION>
1551 USE module_state_description
1552 IMPLICIT NONE
1553 INTEGER ,INTENT(IN) :: DataHandle
1554 CHARACTER*(*) ,INTENT(IN) :: VarName
1555 INTEGER ,INTENT(OUT) :: NDim
1556 CHARACTER*(*) ,INTENT(OUT) :: MemoryOrder
1557 CHARACTER*(*) ,INTENT(OUT) :: Stagger
1558 INTEGER ,dimension(*) ,INTENT(OUT) :: DomainStart, DomainEnd
1559 INTEGER ,INTENT(OUT) :: Status
1560 #include "wrf_status_codes.h"
1561 INTEGER io_form , Hndl
1562 LOGICAL :: for_out
1563 INTEGER, EXTERNAL :: use_package
1564 LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers
1566 CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_get_var_info' )
1568 Status = 0
1569 CALL get_handle ( Hndl, io_form , for_out, DataHandle )
1570 IF ( Hndl .GT. -1 ) THEN
1571 IF (( multi_files(io_form) .OR. wrf_dm_on_monitor() ) .AND. .NOT. (for_out .AND. use_output_servers()) ) THEN
1572 SELECT CASE ( use_package( io_form ) )
1573 #ifdef NETCDF
1574 CASE ( IO_NETCDF )
1575 CALL ext_ncd_get_var_info ( Hndl , VarName , NDim , &
1576 MemoryOrder , Stagger , &
1577 DomainStart , DomainEnd , &
1578 Status )
1579 #endif
1580 #ifdef PHDF5
1581 CASE ( IO_PHDF5)
1582 CALL ext_phdf5_get_var_info ( Hndl , VarName , NDim , &
1583 MemoryOrder , Stagger , &
1584 DomainStart , DomainEnd , &
1585 Status )
1586 #endif
1587 #ifdef PNETCDF
1588 CASE ( IO_PNETCDF)
1589 CALL ext_pnc_get_var_info ( Hndl , VarName , NDim , &
1590 MemoryOrder , Stagger , &
1591 DomainStart , DomainEnd , &
1592 Status )
1593 #endif
1594 #ifdef XXX
1595 CASE ( IO_XXX )
1596 CALL ext_xxx_get_var_info ( Hndl , VarName , NDim , &
1597 MemoryOrder , Stagger , &
1598 DomainStart , DomainEnd , &
1599 Status )
1600 #endif
1601 #ifdef YYY
1602 CASE ( IO_YYY )
1603 CALL ext_yyy_get_var_info ( Hndl , VarName , NDim , &
1604 MemoryOrder , Stagger , &
1605 DomainStart , DomainEnd , &
1606 Status )
1607 #endif
1608 #ifdef GRIB1
1609 CASE ( IO_GRIB1 )
1610 CALL ext_gr1_get_var_info ( Hndl , VarName , NDim , &
1611 MemoryOrder , Stagger , &
1612 DomainStart , DomainEnd , &
1613 Status )
1614 #endif
1615 #ifdef GRIB2
1616 CASE ( IO_GRIB2 )
1617 CALL ext_gr2_get_var_info ( Hndl , VarName , NDim , &
1618 MemoryOrder , Stagger , &
1619 DomainStart , DomainEnd , &
1620 Status )
1621 #endif
1622 CASE DEFAULT
1623 Status = 0
1624 END SELECT
1625 ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN
1626 CALL wrf_quilt_get_var_info ( Hndl , VarName , NDim , &
1627 MemoryOrder , Stagger , &
1628 DomainStart , DomainEnd , &
1629 Status )
1630 ELSE
1631 Status = 0
1632 ENDIF
1633 ELSE
1634 Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1635 ENDIF
1636 RETURN
1638 END SUBROUTINE wrf_get_var_info
1642 !---------------------------------------------------------------------------------
1645 SUBROUTINE init_io_handles()
1646 !<DESCRIPTION>
1647 !<PRE>
1648 ! Initialize all I/O handles.
1649 !</PRE>
1650 !</DESCRIPTION>
1651 IMPLICIT NONE
1652 INTEGER i
1653 IF ( .NOT. is_inited ) THEN
1654 DO i = 1, MAX_WRF_IO_HANDLE
1655 wrf_io_handles(i) = -999319
1656 ENDDO
1657 is_inited = .TRUE.
1658 ENDIF
1659 RETURN
1660 END SUBROUTINE init_io_handles
1662 SUBROUTINE add_new_handle( Hndl, Hopened, for_out, DataHandle )
1663 !<DESCRIPTION>
1664 !<PRE>
1665 ! Stash the package-specific I/O handle (Hndl) and return a WRF I/O handle
1666 ! (DataHandle).
1667 ! File format ID is passed in via Hopened.
1668 ! for_out will be .TRUE. if this routine was called from an
1669 ! open-for-read/write-begin operation and .FALSE. otherwise.
1670 !</PRE>
1671 !</DESCRIPTION>
1672 IMPLICIT NONE
1673 INTEGER, INTENT(IN) :: Hndl
1674 INTEGER, INTENT(IN) :: Hopened
1675 LOGICAL, INTENT(IN) :: for_out
1676 INTEGER, INTENT(OUT) :: DataHandle
1677 INTEGER i
1678 INTEGER, EXTERNAL :: use_package
1679 LOGICAL, EXTERNAL :: multi_files
1680 IF ( .NOT. is_inited ) THEN
1681 CALL wrf_error_fatal( 'add_new_handle: not initialized' )
1682 ENDIF
1683 IF ( multi_files( Hopened ) ) THEN
1684 SELECT CASE ( use_package( Hopened ) )
1685 CASE ( IO_PHDF5 )
1686 CALL wrf_error_fatal( 'add_new_handle: multiple output files not supported for PHDF5' )
1687 CASE ( IO_PNETCDF )
1688 CALL wrf_error_fatal( 'add_new_handle: multiple output files not supported for PNETCDF' )
1689 #ifdef MCELIO
1690 CASE ( IO_MCEL )
1691 CALL wrf_error_fatal( 'add_new_handle: multiple output files not supported for MCEL' )
1692 #endif
1693 #ifdef ESMFIO
1694 CASE ( IO_ESMF )
1695 CALL wrf_error_fatal( 'add_new_handle: multiple output files not supported for ESMF' )
1696 #endif
1697 END SELECT
1698 ENDIF
1699 DataHandle = -1
1700 DO i = 1, MAX_WRF_IO_HANDLE
1701 IF ( wrf_io_handles(i) .EQ. -999319 ) THEN
1702 DataHandle = i
1703 wrf_io_handles(i) = Hndl
1704 how_opened(i) = Hopened
1705 for_output(DataHandle) = for_out
1706 first_operation(DataHandle) = .TRUE.
1707 EXIT
1708 ENDIF
1709 ENDDO
1710 IF ( DataHandle .EQ. -1 ) THEN
1711 CALL wrf_error_fatal( 'add_new_handle: no handles left' )
1712 ENDIF
1713 RETURN
1714 END SUBROUTINE add_new_handle
1716 SUBROUTINE get_handle ( Hndl, Hopened, for_out, DataHandle )
1717 !<DESCRIPTION>
1718 !<PRE>
1719 ! Return the package-specific handle (Hndl) from a WRF handle
1720 ! (DataHandle).
1721 ! Return file format ID via Hopened.
1722 ! Also, for_out will be set to .TRUE. if the file was opened
1723 ! with an open-for-read/write-begin operation and .FALSE.
1724 ! otherwise.
1725 !</PRE>
1726 !</DESCRIPTION>
1727 IMPLICIT NONE
1728 INTEGER, INTENT(OUT) :: Hndl
1729 INTEGER, INTENT(OUT) :: Hopened
1730 LOGICAL, INTENT(OUT) :: for_out
1731 INTEGER, INTENT(IN) :: DataHandle
1732 CHARACTER*128 mess
1733 INTEGER i
1734 IF ( .NOT. is_inited ) THEN
1735 CALL wrf_error_fatal( 'module_io.F: get_handle: not initialized' )
1736 ENDIF
1737 IF ( DataHandle .GE. 1 .AND. DataHandle .LE. MAX_WRF_IO_HANDLE ) THEN
1738 Hndl = wrf_io_handles(DataHandle)
1739 Hopened = how_opened(DataHandle)
1740 for_out = for_output(DataHandle)
1741 ELSE
1742 Hndl = -1
1743 ENDIF
1744 RETURN
1745 END SUBROUTINE get_handle
1747 SUBROUTINE set_first_operation( DataHandle )
1748 !<DESCRIPTION>
1749 !<PRE>
1750 ! Sets internal flag to indicate that the first read or write has not yet
1751 ! happened for the dataset referenced by DataHandle.
1752 !</PRE>
1753 !</DESCRIPTION>
1754 IMPLICIT NONE
1755 INTEGER, INTENT(IN) :: DataHandle
1756 IF ( .NOT. is_inited ) THEN
1757 CALL wrf_error_fatal( 'module_io.F: get_handle: not initialized' )
1758 ENDIF
1759 IF ( DataHandle .GE. 1 .AND. DataHandle .LE. MAX_WRF_IO_HANDLE ) THEN
1760 first_operation(DataHandle) = .TRUE.
1761 ENDIF
1762 RETURN
1763 END SUBROUTINE set_first_operation
1765 SUBROUTINE reset_first_operation( DataHandle )
1766 !<DESCRIPTION>
1767 !<PRE>
1768 ! Resets internal flag to indicate that the first read or write has already
1769 ! happened for the dataset referenced by DataHandle.
1770 !</PRE>
1771 !</DESCRIPTION>
1772 IMPLICIT NONE
1773 INTEGER, INTENT(IN) :: DataHandle
1774 IF ( .NOT. is_inited ) THEN
1775 CALL wrf_error_fatal( 'module_io.F: get_handle: not initialized' )
1776 ENDIF
1777 IF ( DataHandle .GE. 1 .AND. DataHandle .LE. MAX_WRF_IO_HANDLE ) THEN
1778 first_operation(DataHandle) = .FALSE.
1779 ENDIF
1780 RETURN
1781 END SUBROUTINE reset_first_operation
1783 LOGICAL FUNCTION is_first_operation( DataHandle )
1784 !<DESCRIPTION>
1785 !<PRE>
1786 ! Returns .TRUE. the first read or write has not yet happened for the dataset
1787 ! referenced by DataHandle.
1788 !</PRE>
1789 !</DESCRIPTION>
1790 IMPLICIT NONE
1791 INTEGER, INTENT(IN) :: DataHandle
1792 IF ( .NOT. is_inited ) THEN
1793 CALL wrf_error_fatal( 'module_io.F: get_handle: not initialized' )
1794 ENDIF
1795 IF ( DataHandle .GE. 1 .AND. DataHandle .LE. MAX_WRF_IO_HANDLE ) THEN
1796 is_first_operation = first_operation(DataHandle)
1797 ENDIF
1798 RETURN
1799 END FUNCTION is_first_operation
1801 SUBROUTINE free_handle ( DataHandle )
1802 !<DESCRIPTION>
1803 !<PRE>
1804 ! Trash a handle and return to "unused" pool.
1805 !</PRE>
1806 !</DESCRIPTION>
1807 IMPLICIT NONE
1808 INTEGER, INTENT(IN) :: DataHandle
1809 INTEGER i
1810 IF ( .NOT. is_inited ) THEN
1811 CALL wrf_error_fatal( 'free_handle: not initialized' )
1812 ENDIF
1813 IF ( DataHandle .GE. 1 .AND. DataHandle .LE. MAX_WRF_IO_HANDLE ) THEN
1814 wrf_io_handles(DataHandle) = -999319
1815 ENDIF
1816 RETURN
1817 END SUBROUTINE free_handle
1819 !--------------------------------------------------------------
1821 SUBROUTINE init_module_io
1822 !<DESCRIPTION>
1823 !<PRE>
1824 ! Initialize this module. Must be called before any other operations are
1825 ! attempted.
1826 !</PRE>
1827 !</DESCRIPTION>
1828 CALL init_io_handles
1829 END SUBROUTINE init_module_io
1831 SUBROUTINE are_bdys_distributed( res )
1832 IMPLICIT NONE
1833 LOGICAL, INTENT(OUT) :: res
1834 res = bdy_dist_flag
1835 END SUBROUTINE are_bdys_distributed
1837 SUBROUTINE bdys_not_distributed
1838 IMPLICIT NONE
1839 bdy_dist_flag = .FALSE.
1840 END SUBROUTINE bdys_not_distributed
1842 SUBROUTINE bdys_are_distributed
1843 IMPLICIT NONE
1844 bdy_dist_flag = .TRUE.
1845 END SUBROUTINE bdys_are_distributed
1847 LOGICAL FUNCTION on_stream ( mask , switch )
1848 IMPLICIT NONE
1849 INTEGER, INTENT(IN) :: mask(*), switch
1850 INTEGER :: result
1851 ! get_mask is a C routine defined in frame/pack_utils.c
1852 ! switch is decremented from its fortran value so it is zero based
1853 CALL get_mask( mask, switch-1, result )
1854 on_stream = ( result .NE. 0 )
1855 END FUNCTION on_stream
1857 END MODULE module_io
1860 !<DESCRIPTION>
1861 !<PRE>
1862 ! Remaining routines in this file are defined outside of the module to
1863 ! defeat arg/param type checking.
1864 !</PRE>
1865 !</DESCRIPTION>
1866 SUBROUTINE wrf_read_field ( DataHandle , DateStr , VarName , Field , FieldType , &
1867 Comm , IOComm , &
1868 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
1869 DomainStart , DomainEnd , &
1870 MemoryStart , MemoryEnd , &
1871 PatchStart , PatchEnd , &
1872 Status )
1873 !<DESCRIPTION>
1874 !<PRE>
1875 ! Read the variable named VarName from the dataset pointed to by DataHandle.
1876 ! This routine is a wrapper that ensures uniform treatment of logicals across
1877 ! platforms by reading as integer and then converting to logical.
1878 !</PRE>
1879 !</DESCRIPTION>
1880 USE module_state_description
1881 USE module_configure
1882 IMPLICIT NONE
1883 INTEGER , INTENT(IN) :: DataHandle
1884 CHARACTER*(*) :: DateStr
1885 CHARACTER*(*) :: VarName
1886 LOGICAL , INTENT(INOUT) :: Field(*)
1887 INTEGER ,INTENT(IN) :: FieldType
1888 INTEGER ,INTENT(INOUT) :: Comm
1889 INTEGER ,INTENT(INOUT) :: IOComm
1890 INTEGER ,INTENT(IN) :: DomainDesc
1891 LOGICAL, DIMENSION(4) :: bdy_mask
1892 CHARACTER*(*) ,INTENT(IN) :: MemoryOrder
1893 CHARACTER*(*) ,INTENT(IN) :: Stagger
1894 CHARACTER*(*) , dimension (*) ,INTENT(IN) :: DimNames
1895 INTEGER ,dimension(*) ,INTENT(IN) :: DomainStart, DomainEnd
1896 INTEGER ,dimension(*) ,INTENT(IN) :: MemoryStart, MemoryEnd
1897 INTEGER ,dimension(*) ,INTENT(IN) :: PatchStart, PatchEnd
1898 INTEGER ,INTENT(OUT) :: Status
1899 #include "wrf_status_codes.h"
1900 #include "wrf_io_flags.h"
1901 INTEGER, ALLOCATABLE :: ICAST(:)
1902 LOGICAL perturb_input
1903 IF ( FieldType .EQ. WRF_LOGICAL ) THEN
1904 ALLOCATE(ICAST((MemoryEnd(1)-MemoryStart(1)+1)*(MemoryEnd(2)-MemoryStart(2)+1)*(MemoryEnd(3)-MemoryStart(3)+1)))
1906 CALL wrf_read_field1 ( DataHandle , DateStr , VarName , ICAST , WRF_INTEGER , &
1907 Comm , IOComm , &
1908 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
1909 DomainStart , DomainEnd , &
1910 MemoryStart , MemoryEnd , &
1911 PatchStart , PatchEnd , &
1912 Status )
1913 Field(1:(MemoryEnd(1)-MemoryStart(1)+1)*(MemoryEnd(2)-MemoryStart(2)+1)*(MemoryEnd(3)-MemoryStart(3)+1)) = ICAST == 1
1914 DEALLOCATE(ICAST)
1915 ELSE
1916 CALL wrf_read_field1 ( DataHandle , DateStr , VarName , Field , FieldType , &
1917 Comm , IOComm , &
1918 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
1919 DomainStart , DomainEnd , &
1920 MemoryStart , MemoryEnd , &
1921 PatchStart , PatchEnd , &
1922 Status )
1923 CALL nl_get_perturb_input( 1, perturb_input )
1924 IF ( perturb_input .AND. FieldType .EQ. WRF_FLOAT .AND. TRIM(MemoryOrder) .EQ. 'XZY' ) THEN
1925 CALL perturb_real ( Field, DomainStart, DomainEnd, &
1926 MemoryStart, MemoryEnd, &
1927 PatchStart, PatchEnd )
1928 ENDIF
1929 ENDIF
1930 END SUBROUTINE wrf_read_field
1932 SUBROUTINE wrf_read_field1 ( DataHandle , DateStr , VarName , Field , FieldType , &
1933 Comm , IOComm , &
1934 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
1935 DomainStart , DomainEnd , &
1936 MemoryStart , MemoryEnd , &
1937 PatchStart , PatchEnd , &
1938 Status )
1939 !<DESCRIPTION>
1940 !<PRE>
1941 ! Read the variable named VarName from the dataset pointed to by DataHandle.
1942 ! Calls ext_pkg_read_field() via call_pkg_and_dist().
1943 !</PRE>
1944 !</DESCRIPTION>
1945 USE module_state_description
1946 USE module_configure
1947 USE module_io
1948 IMPLICIT NONE
1949 INTEGER , INTENT(IN) :: DataHandle
1950 CHARACTER*(*) :: DateStr
1951 CHARACTER*(*) :: VarName
1952 INTEGER , INTENT(INOUT) :: Field(*)
1953 INTEGER ,INTENT(IN) :: FieldType
1954 INTEGER ,INTENT(INOUT) :: Comm
1955 INTEGER ,INTENT(INOUT) :: IOComm
1956 INTEGER ,INTENT(IN) :: DomainDesc
1957 LOGICAL, DIMENSION(4) :: bdy_mask
1958 CHARACTER*(*) ,INTENT(IN) :: MemoryOrder
1959 CHARACTER*(*) ,INTENT(IN) :: Stagger
1960 CHARACTER*(*) , dimension (*) ,INTENT(IN) :: DimNames
1961 INTEGER ,dimension(*) ,INTENT(IN) :: DomainStart, DomainEnd
1962 INTEGER ,dimension(*) ,INTENT(IN) :: MemoryStart, MemoryEnd
1963 INTEGER ,dimension(*) ,INTENT(IN) :: PatchStart, PatchEnd
1964 INTEGER ,INTENT(OUT) :: Status
1965 #include "wrf_status_codes.h"
1966 INTEGER io_form , Hndl
1967 LOGICAL :: for_out
1968 INTEGER, EXTERNAL :: use_package
1969 LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers, use_input_servers
1970 #ifdef NETCDF
1971 EXTERNAL ext_ncd_read_field
1972 #endif
1973 #ifdef MCELIO
1974 EXTERNAL ext_mcel_read_field
1975 #endif
1976 #ifdef ESMFIO
1977 EXTERNAL ext_esmf_read_field
1978 #endif
1979 #ifdef INTIO
1980 EXTERNAL ext_int_read_field
1981 #endif
1982 #ifdef XXX
1983 EXTERNAL ext_xxx_read_field
1984 #endif
1985 #ifdef YYY
1986 EXTERNAL ext_yyy_read_field
1987 #endif
1988 #ifdef GRIB1
1989 EXTERNAL ext_gr1_read_field
1990 #endif
1991 #ifdef GRIB2
1992 EXTERNAL ext_gr2_read_field
1993 #endif
1995 CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_read_field' )
1997 Status = 0
1998 CALL get_handle ( Hndl, io_form , for_out, DataHandle )
1999 CALL reset_first_operation( DataHandle )
2000 IF ( Hndl .GT. -1 ) THEN
2001 IF ( .NOT. io_form .GT. 0 ) THEN
2002 Status = 0
2003 ELSE IF ( .NOT. use_input_servers() ) THEN
2004 SELECT CASE ( use_package( io_form ) )
2005 #ifdef NETCDF
2006 CASE ( IO_NETCDF )
2008 CALL call_pkg_and_dist ( ext_ncd_read_field, multi_files(io_form), .false. , &
2009 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2010 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2011 DomainStart , DomainEnd , &
2012 MemoryStart , MemoryEnd , &
2013 PatchStart , PatchEnd , &
2014 Status )
2016 #endif
2017 #ifdef PHDF5
2018 CASE ( IO_PHDF5)
2019 CALL ext_phdf5_read_field ( &
2020 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2021 DomainDesc , MemoryOrder , Stagger , DimNames , &
2022 DomainStart , DomainEnd , &
2023 MemoryStart , MemoryEnd , &
2024 PatchStart , PatchEnd , &
2025 Status )
2026 #endif
2027 #ifdef PNETCDF
2028 CASE ( IO_PNETCDF)
2029 CALL ext_pnc_read_field ( &
2030 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2031 DomainDesc , MemoryOrder , Stagger , DimNames , &
2032 DomainStart , DomainEnd , &
2033 MemoryStart , MemoryEnd , &
2034 PatchStart , PatchEnd , &
2035 Status )
2036 #endif
2037 #ifdef MCELIO
2038 CASE ( IO_MCEL )
2039 CALL call_pkg_and_dist ( ext_mcel_read_field, multi_files(io_form), .true. , &
2040 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2041 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2042 DomainStart , DomainEnd , &
2043 MemoryStart , MemoryEnd , &
2044 PatchStart , PatchEnd , &
2045 Status )
2046 #endif
2047 #ifdef ESMFIO
2048 CASE ( IO_ESMF )
2049 CALL ext_esmf_read_field( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2050 DomainDesc , MemoryOrder , Stagger , DimNames , &
2051 DomainStart , DomainEnd , &
2052 MemoryStart , MemoryEnd , &
2053 PatchStart , PatchEnd , &
2054 Status )
2055 #endif
2056 #ifdef XXX
2057 CASE ( IO_XXX )
2058 CALL call_pkg_and_dist ( ext_xxx_read_field, multi_files(io_form), .false., &
2059 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2060 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2061 DomainStart , DomainEnd , &
2062 MemoryStart , MemoryEnd , &
2063 PatchStart , PatchEnd , &
2064 Status )
2065 #endif
2066 #ifdef YYY
2067 CASE ( IO_YYY )
2068 CALL call_pkg_and_dist ( ext_yyy_read_field, multi_files(io_form), .false., &
2069 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2070 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2071 DomainStart , DomainEnd , &
2072 MemoryStart , MemoryEnd , &
2073 PatchStart , PatchEnd , &
2074 Status )
2075 #endif
2076 #ifdef INTIO
2077 CASE ( IO_INTIO )
2078 CALL call_pkg_and_dist ( ext_int_read_field, multi_files(io_form), .false., &
2079 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2080 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2081 DomainStart , DomainEnd , &
2082 MemoryStart , MemoryEnd , &
2083 PatchStart , PatchEnd , &
2084 Status )
2085 #endif
2086 #ifdef GRIB1
2087 CASE ( IO_GRIB1 )
2088 CALL call_pkg_and_dist ( ext_gr1_read_field, multi_files(io_form), .false., &
2089 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2090 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2091 DomainStart , DomainEnd , &
2092 MemoryStart , MemoryEnd , &
2093 PatchStart , PatchEnd , &
2094 Status )
2095 #endif
2096 #ifdef GRIB2
2097 CASE ( IO_GRIB2 )
2098 CALL call_pkg_and_dist ( ext_gr2_read_field, multi_files(io_form), .false., &
2099 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2100 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2101 DomainStart , DomainEnd , &
2102 MemoryStart , MemoryEnd , &
2103 PatchStart , PatchEnd , &
2104 Status )
2105 #endif
2106 CASE DEFAULT
2107 Status = 0
2108 END SELECT
2109 ELSE
2110 CALL wrf_error_fatal('module_io.F: wrf_read_field: input_servers not implemented yet')
2111 ENDIF
2112 ELSE
2113 Status = WRF_ERR_FATAL_BAD_FILE_STATUS
2114 ENDIF
2115 RETURN
2116 END SUBROUTINE wrf_read_field1
2118 SUBROUTINE wrf_write_field ( DataHandle , DateStr , VarName , Field , FieldType , &
2119 Comm , IOComm , &
2120 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2121 DomainStart , DomainEnd , &
2122 MemoryStart , MemoryEnd , &
2123 PatchStart , PatchEnd , &
2124 Status )
2125 !<DESCRIPTION>
2126 !<PRE>
2127 ! Write the variable named VarName to the dataset pointed to by DataHandle.
2128 ! This routine is a wrapper that ensures uniform treatment of logicals across
2129 ! platforms by converting to integer before writing.
2130 !</PRE>
2131 !</DESCRIPTION>
2132 USE module_state_description
2133 USE module_configure
2134 IMPLICIT NONE
2135 INTEGER , INTENT(IN) :: DataHandle
2136 CHARACTER*(*) :: DateStr
2137 CHARACTER*(*) :: VarName
2138 LOGICAL , INTENT(IN) :: Field(*)
2139 INTEGER ,INTENT(IN) :: FieldType
2140 INTEGER ,INTENT(INOUT) :: Comm
2141 INTEGER ,INTENT(INOUT) :: IOComm
2142 INTEGER ,INTENT(IN) :: DomainDesc
2143 LOGICAL, DIMENSION(4) ,INTENT(IN) :: bdy_mask
2144 CHARACTER*(*) ,INTENT(IN) :: MemoryOrder
2145 CHARACTER*(*) ,INTENT(IN) :: Stagger
2146 CHARACTER*(*) , dimension (*) ,INTENT(IN) :: DimNames
2147 INTEGER ,dimension(*) ,INTENT(IN) :: DomainStart, DomainEnd
2148 INTEGER ,dimension(*) ,INTENT(IN) :: MemoryStart, MemoryEnd
2149 INTEGER ,dimension(*) ,INTENT(IN) :: PatchStart, PatchEnd
2150 INTEGER ,INTENT(OUT) :: Status
2151 #include "wrf_status_codes.h"
2152 #include "wrf_io_flags.h"
2153 INTEGER, ALLOCATABLE :: ICAST(:)
2154 IF ( FieldType .EQ. WRF_LOGICAL ) THEN
2155 ALLOCATE(ICAST((MemoryEnd(1)-MemoryStart(1)+1)*(MemoryEnd(2)-MemoryStart(2)+1)*(MemoryEnd(3)-MemoryStart(3)+1)))
2156 ICAST = 0
2157 WHERE ( Field(1:(MemoryEnd(1)-MemoryStart(1)+1)*(MemoryEnd(2)-MemoryStart(2)+1)*(MemoryEnd(3)-MemoryStart(3)+1)) )
2158 ICAST = 1
2159 END WHERE
2160 CALL wrf_write_field1 ( DataHandle , DateStr , VarName , ICAST , WRF_INTEGER , &
2161 Comm , IOComm , &
2162 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2163 DomainStart , DomainEnd , &
2164 MemoryStart , MemoryEnd , &
2165 PatchStart , PatchEnd , &
2166 Status )
2167 DEALLOCATE(ICAST)
2168 ELSE
2169 CALL wrf_write_field1 ( DataHandle , DateStr , VarName , Field , FieldType , &
2170 Comm , IOComm , &
2171 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2172 DomainStart , DomainEnd , &
2173 MemoryStart , MemoryEnd , &
2174 PatchStart , PatchEnd , &
2175 Status )
2176 ENDIF
2177 END SUBROUTINE wrf_write_field
2179 SUBROUTINE wrf_write_field1 ( DataHandle , DateStr , VarName , Field , FieldType , &
2180 Comm , IOComm , &
2181 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2182 DomainStart , DomainEnd , &
2183 MemoryStart , MemoryEnd , &
2184 PatchStart , PatchEnd , &
2185 Status )
2186 !<DESCRIPTION>
2187 !<PRE>
2188 ! Write the variable named VarName to the dataset pointed to by DataHandle.
2189 ! Calls ext_pkg_write_field() via collect_fld_and_call_pkg().
2190 !</PRE>
2191 !</DESCRIPTION>
2193 USE module_state_description
2194 USE module_configure
2195 USE module_io
2196 IMPLICIT NONE
2197 INTEGER , INTENT(IN) :: DataHandle
2198 CHARACTER*(*) :: DateStr
2199 CHARACTER*(*) :: VarName
2200 INTEGER , INTENT(IN) :: Field(*)
2201 INTEGER ,INTENT(IN) :: FieldType
2202 INTEGER ,INTENT(INOUT) :: Comm
2203 INTEGER ,INTENT(INOUT) :: IOComm
2204 INTEGER ,INTENT(IN) :: DomainDesc
2205 LOGICAL, DIMENSION(4) ,INTENT(IN) :: bdy_mask
2206 CHARACTER*(*) ,INTENT(IN) :: MemoryOrder
2207 CHARACTER*(*) ,INTENT(IN) :: Stagger
2208 CHARACTER*(*) , dimension (*) ,INTENT(IN) :: DimNames
2209 INTEGER ,dimension(*) ,INTENT(IN) :: DomainStart, DomainEnd
2210 INTEGER ,dimension(*) ,INTENT(IN) :: MemoryStart, MemoryEnd
2211 INTEGER ,dimension(*) ,INTENT(IN) :: PatchStart, PatchEnd
2212 INTEGER ,INTENT(OUT) :: Status
2213 #include "wrf_status_codes.h"
2214 INTEGER, DIMENSION(3) :: starts, ends
2215 INTEGER io_form , Hndl
2216 CHARACTER*3 MemOrd
2217 LOGICAL :: for_out, okay_to_call
2218 INTEGER, EXTERNAL :: use_package
2219 LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers
2220 #ifdef NETCDF
2221 EXTERNAL ext_ncd_write_field
2222 #endif
2223 #ifdef MCELIO
2224 EXTERNAL ext_mcel_write_field
2225 #endif
2226 #ifdef ESMFIO
2227 EXTERNAL ext_esmf_write_field
2228 #endif
2229 #ifdef INTIO
2230 EXTERNAL ext_int_write_field
2231 #endif
2232 #ifdef XXX
2233 EXTERNAL ext_xxx_write_field
2234 #endif
2235 #ifdef YYY
2236 EXTERNAL ext_yyy_write_field
2237 #endif
2238 #ifdef GRIB1
2239 EXTERNAL ext_gr1_write_field
2240 #endif
2241 #ifdef GRIB2
2242 EXTERNAL ext_gr2_write_field
2243 #endif
2245 CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_write_field' )
2247 Status = 0
2248 CALL get_handle ( Hndl, io_form , for_out, DataHandle )
2249 CALL reset_first_operation ( DataHandle )
2250 IF ( Hndl .GT. -1 ) THEN
2251 IF ( multi_files( io_form ) .OR. .NOT. use_output_servers() ) THEN
2252 SELECT CASE ( use_package( io_form ) )
2253 #ifdef NETCDF
2254 CASE ( IO_NETCDF )
2255 CALL collect_fld_and_call_pkg ( ext_ncd_write_field, multi_files(io_form), &
2256 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2257 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2258 DomainStart , DomainEnd , &
2259 MemoryStart , MemoryEnd , &
2260 PatchStart , PatchEnd , &
2261 Status )
2262 #endif
2263 #ifdef MCELIO
2264 CASE ( IO_MCEL )
2265 CALL collect_fld_and_call_pkg ( ext_mcel_write_field, multi_files(io_form), &
2266 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2267 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2268 DomainStart , DomainEnd , &
2269 MemoryStart , MemoryEnd , &
2270 PatchStart , PatchEnd , &
2271 Status )
2272 #endif
2273 #ifdef ESMFIO
2274 CASE ( IO_ESMF )
2275 CALL ext_esmf_write_field( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2276 DomainDesc , MemoryOrder , Stagger , DimNames , &
2277 DomainStart , DomainEnd , &
2278 MemoryStart , MemoryEnd , &
2279 PatchStart , PatchEnd , &
2280 Status )
2281 #endif
2282 #ifdef PHDF5
2283 CASE ( IO_PHDF5 )
2284 CALL ext_phdf5_write_field( &
2285 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2286 DomainDesc , MemoryOrder , Stagger , DimNames , &
2287 DomainStart , DomainEnd , &
2288 MemoryStart , MemoryEnd , &
2289 PatchStart , PatchEnd , &
2290 Status )
2291 #endif
2292 #ifdef PNETCDF
2293 CASE ( IO_PNETCDF )
2294 CALL lower_case( MemoryOrder, MemOrd )
2295 okay_to_call = .TRUE.
2296 IF ((TRIM(MemOrd).EQ.'xsz' .OR. TRIM(MemOrd).EQ.'xs').AND. .NOT. bdy_mask(P_XSB)) okay_to_call = .FALSE.
2297 IF ((TRIM(MemOrd).EQ.'xez' .OR. TRIM(MemOrd).EQ.'xe').AND. .NOT. bdy_mask(P_XEB)) okay_to_call = .FALSE.
2298 IF ((TRIM(MemOrd).EQ.'ysz' .OR. TRIM(MemOrd).EQ.'ys').AND. .NOT. bdy_mask(P_YSB)) okay_to_call = .FALSE.
2299 IF ((TRIM(MemOrd).EQ.'yez' .OR. TRIM(MemOrd).EQ.'ye').AND. .NOT. bdy_mask(P_YEB)) okay_to_call = .FALSE.
2300 IF ( okay_to_call ) THEN
2301 starts(1:3) = PatchStart(1:3) ; ends(1:3) = PatchEnd(1:3)
2302 ELSE
2303 starts(1:3) = PatchStart(1:3) ; ends(1:3) = PatchStart(1:3)-1
2304 ENDIF
2306 CALL ext_pnc_write_field( &
2307 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2308 DomainDesc , MemoryOrder , Stagger , DimNames , &
2309 DomainStart , DomainEnd , &
2310 MemoryStart , MemoryEnd , &
2311 starts , ends , &
2312 Status )
2313 #endif
2314 #ifdef XXX
2315 CASE ( IO_XXX )
2316 CALL collect_fld_and_call_pkg ( ext_xxx_write_field, multi_files(io_form), &
2317 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2318 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2319 DomainStart , DomainEnd , &
2320 MemoryStart , MemoryEnd , &
2321 PatchStart , PatchEnd , &
2322 Status )
2323 #endif
2324 #ifdef YYY
2325 CASE ( IO_YYY )
2326 CALL collect_fld_and_call_pkg ( ext_yyy_write_field, multi_files(io_form), &
2327 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2328 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2329 DomainStart , DomainEnd , &
2330 MemoryStart , MemoryEnd , &
2331 PatchStart , PatchEnd , &
2332 Status )
2333 #endif
2334 #ifdef GRIB1
2335 CASE ( IO_GRIB1 )
2336 CALL collect_fld_and_call_pkg ( ext_gr1_write_field, multi_files(io_form), &
2337 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2338 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2339 DomainStart , DomainEnd , &
2340 MemoryStart , MemoryEnd , &
2341 PatchStart , PatchEnd , &
2342 Status )
2343 #endif
2344 #ifdef GRIB2
2345 CASE ( IO_GRIB2 )
2346 CALL collect_fld_and_call_pkg ( ext_gr2_write_field, multi_files(io_form), &
2347 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2348 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2349 DomainStart , DomainEnd , &
2350 MemoryStart , MemoryEnd , &
2351 PatchStart , PatchEnd , &
2352 Status )
2353 #endif
2354 #ifdef INTIO
2355 CASE ( IO_INTIO )
2356 CALL collect_fld_and_call_pkg ( ext_int_write_field, multi_files(io_form), &
2357 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2358 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2359 DomainStart , DomainEnd , &
2360 MemoryStart , MemoryEnd , &
2361 PatchStart , PatchEnd , &
2362 Status )
2363 #endif
2364 CASE DEFAULT
2365 Status = 0
2366 END SELECT
2367 ELSE IF ( use_output_servers() ) THEN
2368 IF ( io_form .GT. 0 ) THEN
2369 CALL wrf_quilt_write_field ( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2370 DomainDesc , MemoryOrder , Stagger , DimNames , &
2371 DomainStart , DomainEnd , &
2372 MemoryStart , MemoryEnd , &
2373 PatchStart , PatchEnd , &
2374 Status )
2375 ENDIF
2376 ENDIF
2377 ELSE
2378 Status = WRF_ERR_FATAL_BAD_FILE_STATUS
2379 ENDIF
2380 RETURN
2381 END SUBROUTINE wrf_write_field1
2383 SUBROUTINE get_value_from_pairs ( varname , str , retval )
2384 !<DESCRIPTION>
2385 !<PRE>
2386 ! parse comma separated list of VARIABLE=VALUE strings and return the
2387 ! value for the matching variable if such exists, otherwise return
2388 ! the empty string
2389 !</PRE>
2390 !</DESCRIPTION>
2391 IMPLICIT NONE
2392 CHARACTER*(*) :: varname
2393 CHARACTER*(*) :: str
2394 CHARACTER*(*) :: retval
2396 CHARACTER (128) varstr, tstr
2397 INTEGER i,j,n,varstrn
2398 LOGICAL nobreak, nobreakouter
2400 varstr = TRIM(varname)//"="
2401 varstrn = len(TRIM(varstr))
2402 n = len(str)
2403 retval = ""
2404 i = 1
2405 nobreakouter = .TRUE.
2406 DO WHILE ( nobreakouter )
2407 j = 1
2408 nobreak = .TRUE.
2409 tstr = ""
2410 ! Potential for out of bounds array ref on str(i:i) for i > n; reported by jedwards
2411 ! DO WHILE ( nobreak )
2412 ! IF ( str(i:i) .NE. ',' .AND. i .LE. n ) THEN
2413 ! tstr(j:j) = str(i:i)
2414 ! ELSE
2415 ! nobreak = .FALSE.
2416 ! ENDIF
2417 ! j = j + 1
2418 ! i = i + 1
2419 ! ENDDO
2420 ! fix 20021112, JM
2421 DO WHILE ( nobreak )
2422 nobreak = .FALSE.
2423 IF ( i .LE. n ) THEN
2424 IF (str(i:i) .NE. ',' ) THEN
2425 tstr(j:j) = str(i:i)
2426 nobreak = .TRUE.
2427 ENDIF
2428 ENDIF
2429 j = j + 1
2430 i = i + 1
2431 ENDDO
2432 IF ( i .GT. n ) nobreakouter = .FALSE.
2433 IF ( varstr(1:varstrn) .EQ. tstr(1:varstrn) ) THEN
2434 retval(1:) = TRIM(tstr(varstrn+1:))
2435 nobreakouter = .FALSE.
2436 ENDIF
2437 ENDDO
2438 RETURN
2439 END SUBROUTINE get_value_from_pairs
2441 LOGICAL FUNCTION multi_files ( io_form )
2442 !<DESCRIPTION>
2443 !<PRE>
2444 ! Returns .TRUE. iff io_form is a multi-file format. A multi-file format
2445 ! results in one file for each compute process and can be used with any
2446 ! I/O package. A multi-file dataset can only be read by the same number
2447 ! of tasks that were used to write it. This feature can be useful for
2448 ! speeding up restarts on machines that support efficient parallel I/O.
2449 ! Multi-file formats cannot be used with I/O quilt servers.
2450 !</PRE>
2451 !</DESCRIPTION>
2452 IMPLICIT NONE
2453 INTEGER, INTENT(IN) :: io_form
2454 #ifdef DM_PARALLEL
2455 multi_files = io_form > 99
2456 #else
2457 multi_files = .FALSE.
2458 #endif
2459 END FUNCTION multi_files
2461 INTEGER FUNCTION use_package ( io_form )
2462 !<DESCRIPTION>
2463 !<PRE>
2464 ! Returns the ID of the external I/O package referenced by io_form.
2465 !</PRE>
2466 !</DESCRIPTION>
2467 IMPLICIT NONE
2468 INTEGER, INTENT(IN) :: io_form
2469 use_package = MOD( io_form, 100 )
2470 END FUNCTION use_package
2473 SUBROUTINE collect_fld_and_call_pkg ( fcn, donotcollect_arg, &
2474 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2475 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2476 DomainStart , DomainEnd , &
2477 MemoryStart , MemoryEnd , &
2478 PatchStart , PatchEnd , &
2479 Status )
2480 !<DESCRIPTION>
2481 !<PRE>
2482 ! The collect_*_and_call_pkg routines collect a distributed array onto one
2483 ! processor and then call an I/O function to write the result (or in the
2484 ! case of replicated data simply write monitor node's copy of the data)
2485 ! This routine handle cases where collection can be skipped and deals with
2486 ! different data types for Field.
2487 !</PRE>
2488 !</DESCRIPTION>
2489 IMPLICIT NONE
2490 #include "wrf_io_flags.h"
2491 EXTERNAL fcn
2492 LOGICAL, INTENT(IN) :: donotcollect_arg
2493 INTEGER , INTENT(IN) :: Hndl
2494 CHARACTER*(*) :: DateStr
2495 CHARACTER*(*) :: VarName
2496 INTEGER , INTENT(IN) :: Field(*)
2497 INTEGER ,INTENT(IN) :: FieldType
2498 INTEGER ,INTENT(INOUT) :: Comm
2499 INTEGER ,INTENT(INOUT) :: IOComm
2500 INTEGER ,INTENT(IN) :: DomainDesc
2501 LOGICAL, DIMENSION(4) :: bdy_mask
2502 CHARACTER*(*) ,INTENT(IN) :: MemoryOrder
2503 CHARACTER*(*) ,INTENT(IN) :: Stagger
2504 CHARACTER*(*) , dimension (*) ,INTENT(IN) :: DimNames
2505 INTEGER ,dimension(*) ,INTENT(IN) :: DomainStart, DomainEnd
2506 INTEGER ,dimension(*) ,INTENT(IN) :: MemoryStart, MemoryEnd
2507 INTEGER ,dimension(*) ,INTENT(IN) :: PatchStart, PatchEnd
2508 INTEGER ,INTENT(OUT) :: Status
2509 LOGICAL donotcollect
2510 INTEGER ndims, nproc
2512 CALL dim_from_memorder( MemoryOrder , ndims)
2513 CALL wrf_get_nproc( nproc )
2514 donotcollect = donotcollect_arg .OR. (nproc .EQ. 1)
2516 IF ( donotcollect ) THEN
2518 CALL fcn ( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2519 DomainDesc , MemoryOrder , Stagger , DimNames , &
2520 DomainStart , DomainEnd , &
2521 MemoryStart , MemoryEnd , &
2522 PatchStart , PatchEnd , &
2523 Status )
2525 ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
2527 CALL collect_double_and_call_pkg ( fcn, &
2528 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2529 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2530 DomainStart , DomainEnd , &
2531 MemoryStart , MemoryEnd , &
2532 PatchStart , PatchEnd , &
2533 Status )
2535 ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
2537 CALL collect_real_and_call_pkg ( fcn, &
2538 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2539 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2540 DomainStart , DomainEnd , &
2541 MemoryStart , MemoryEnd , &
2542 PatchStart , PatchEnd , &
2543 Status )
2545 ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
2547 CALL collect_int_and_call_pkg ( fcn, &
2548 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2549 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2550 DomainStart , DomainEnd , &
2551 MemoryStart , MemoryEnd , &
2552 PatchStart , PatchEnd , &
2553 Status )
2555 ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
2557 CALL collect_logical_and_call_pkg ( fcn, &
2558 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2559 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2560 DomainStart , DomainEnd , &
2561 MemoryStart , MemoryEnd , &
2562 PatchStart , PatchEnd , &
2563 Status )
2565 ENDIF
2566 RETURN
2567 END SUBROUTINE collect_fld_and_call_pkg
2569 SUBROUTINE collect_real_and_call_pkg ( fcn, &
2570 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2571 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2572 DomainStart , DomainEnd , &
2573 MemoryStart , MemoryEnd , &
2574 PatchStart , PatchEnd , &
2575 Status )
2576 !<DESCRIPTION>
2577 !<PRE>
2578 ! The collect_*_and_call_pkg routines collect a distributed array onto one
2579 ! processor and then call an I/O function to write the result (or in the
2580 ! case of replicated data simply write monitor node's copy of the data)
2581 ! The sole purpose of this wrapper is to allocate a big real buffer and
2582 ! pass it down to collect_generic_and_call_pkg() to do the actual work.
2583 !</PRE>
2584 !</DESCRIPTION>
2585 USE module_state_description
2586 USE module_driver_constants
2587 IMPLICIT NONE
2588 EXTERNAL fcn
2589 INTEGER , INTENT(IN) :: Hndl
2590 CHARACTER*(*) :: DateStr
2591 CHARACTER*(*) :: VarName
2592 REAL , INTENT(IN) :: Field(*)
2593 INTEGER ,INTENT(IN) :: FieldType
2594 INTEGER ,INTENT(INOUT) :: Comm
2595 INTEGER ,INTENT(INOUT) :: IOComm
2596 INTEGER ,INTENT(IN) :: DomainDesc
2597 LOGICAL, DIMENSION(4) :: bdy_mask
2598 CHARACTER*(*) ,INTENT(IN) :: MemoryOrder
2599 CHARACTER*(*) ,INTENT(IN) :: Stagger
2600 CHARACTER*(*) , dimension (*) ,INTENT(IN) :: DimNames
2601 INTEGER ,dimension(*) ,INTENT(IN) :: DomainStart, DomainEnd
2602 INTEGER ,dimension(*) ,INTENT(IN) :: MemoryStart, MemoryEnd
2603 INTEGER ,dimension(*) ,INTENT(IN) :: PatchStart, PatchEnd
2604 INTEGER ,INTENT(INOUT) :: Status
2605 REAL, ALLOCATABLE :: globbuf (:)
2606 LOGICAL, EXTERNAL :: wrf_dm_on_monitor
2608 IF ( wrf_dm_on_monitor() ) THEN
2609 ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) )
2610 ELSE
2611 ALLOCATE( globbuf( 1 ) )
2612 ENDIF
2614 #ifdef DEREF_KLUDGE
2615 # define FRSTELEM (1)
2616 #else
2617 # define FRSTELEM
2618 #endif
2620 CALL collect_generic_and_call_pkg ( fcn, globbuf FRSTELEM, &
2621 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2622 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2623 DomainStart , DomainEnd , &
2624 MemoryStart , MemoryEnd , &
2625 PatchStart , PatchEnd , &
2626 Status )
2627 DEALLOCATE ( globbuf )
2628 RETURN
2630 END SUBROUTINE collect_real_and_call_pkg
2632 SUBROUTINE collect_int_and_call_pkg ( fcn, &
2633 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2634 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2635 DomainStart , DomainEnd , &
2636 MemoryStart , MemoryEnd , &
2637 PatchStart , PatchEnd , &
2638 Status )
2639 !<DESCRIPTION>
2640 !<PRE>
2641 ! The collect_*_and_call_pkg routines collect a distributed array onto one
2642 ! processor and then call an I/O function to write the result (or in the
2643 ! case of replicated data simply write monitor node's copy of the data)
2644 ! The sole purpose of this wrapper is to allocate a big integer buffer and
2645 ! pass it down to collect_generic_and_call_pkg() to do the actual work.
2646 !</PRE>
2647 !</DESCRIPTION>
2648 USE module_state_description
2649 USE module_driver_constants
2650 IMPLICIT NONE
2651 EXTERNAL fcn
2652 INTEGER , INTENT(IN) :: Hndl
2653 CHARACTER*(*) :: DateStr
2654 CHARACTER*(*) :: VarName
2655 INTEGER , INTENT(IN) :: Field(*)
2656 INTEGER ,INTENT(IN) :: FieldType
2657 INTEGER ,INTENT(INOUT) :: Comm
2658 INTEGER ,INTENT(INOUT) :: IOComm
2659 INTEGER ,INTENT(IN) :: DomainDesc
2660 LOGICAL, DIMENSION(4) :: bdy_mask
2661 CHARACTER*(*) ,INTENT(IN) :: MemoryOrder
2662 CHARACTER*(*) ,INTENT(IN) :: Stagger
2663 CHARACTER*(*) , dimension (*) ,INTENT(IN) :: DimNames
2664 INTEGER ,dimension(*) ,INTENT(IN) :: DomainStart, DomainEnd
2665 INTEGER ,dimension(*) ,INTENT(IN) :: MemoryStart, MemoryEnd
2666 INTEGER ,dimension(*) ,INTENT(IN) :: PatchStart, PatchEnd
2667 INTEGER ,INTENT(INOUT) :: Status
2668 INTEGER, ALLOCATABLE :: globbuf (:)
2669 LOGICAL, EXTERNAL :: wrf_dm_on_monitor
2671 IF ( wrf_dm_on_monitor() ) THEN
2672 ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) )
2673 ELSE
2674 ALLOCATE( globbuf( 1 ) )
2675 ENDIF
2677 CALL collect_generic_and_call_pkg ( fcn, globbuf FRSTELEM , &
2678 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2679 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2680 DomainStart , DomainEnd , &
2681 MemoryStart , MemoryEnd , &
2682 PatchStart , PatchEnd , &
2683 Status )
2684 DEALLOCATE ( globbuf )
2685 RETURN
2687 END SUBROUTINE collect_int_and_call_pkg
2689 SUBROUTINE collect_double_and_call_pkg ( fcn, &
2690 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2691 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2692 DomainStart , DomainEnd , &
2693 MemoryStart , MemoryEnd , &
2694 PatchStart , PatchEnd , &
2695 Status )
2696 !<DESCRIPTION>
2697 !<PRE>
2698 ! The collect_*_and_call_pkg routines collect a distributed array onto one
2699 ! processor and then call an I/O function to write the result (or in the
2700 ! case of replicated data simply write monitor node's copy of the data)
2701 ! The sole purpose of this wrapper is to allocate a big double precision
2702 ! buffer and pass it down to collect_generic_and_call_pkg() to do the
2703 ! actual work.
2704 !</PRE>
2705 !</DESCRIPTION>
2706 USE module_state_description
2707 USE module_driver_constants
2708 IMPLICIT NONE
2709 EXTERNAL fcn
2710 INTEGER , INTENT(IN) :: Hndl
2711 CHARACTER*(*) :: DateStr
2712 CHARACTER*(*) :: VarName
2713 DOUBLE PRECISION , INTENT(IN) :: Field(*)
2714 INTEGER ,INTENT(IN) :: FieldType
2715 INTEGER ,INTENT(INOUT) :: Comm
2716 INTEGER ,INTENT(INOUT) :: IOComm
2717 INTEGER ,INTENT(IN) :: DomainDesc
2718 LOGICAL, DIMENSION(4) :: bdy_mask
2719 CHARACTER*(*) ,INTENT(IN) :: MemoryOrder
2720 CHARACTER*(*) ,INTENT(IN) :: Stagger
2721 CHARACTER*(*) , dimension (*) ,INTENT(IN) :: DimNames
2722 INTEGER ,dimension(*) ,INTENT(IN) :: DomainStart, DomainEnd
2723 INTEGER ,dimension(*) ,INTENT(IN) :: MemoryStart, MemoryEnd
2724 INTEGER ,dimension(*) ,INTENT(IN) :: PatchStart, PatchEnd
2725 INTEGER ,INTENT(INOUT) :: Status
2726 DOUBLE PRECISION, ALLOCATABLE :: globbuf (:)
2727 LOGICAL, EXTERNAL :: wrf_dm_on_monitor
2729 IF ( wrf_dm_on_monitor() ) THEN
2730 ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) )
2731 ELSE
2732 ALLOCATE( globbuf( 1 ) )
2733 ENDIF
2735 CALL collect_generic_and_call_pkg ( fcn, globbuf FRSTELEM , &
2736 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2737 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2738 DomainStart , DomainEnd , &
2739 MemoryStart , MemoryEnd , &
2740 PatchStart , PatchEnd , &
2741 Status )
2742 DEALLOCATE ( globbuf )
2743 RETURN
2745 END SUBROUTINE collect_double_and_call_pkg
2747 SUBROUTINE collect_logical_and_call_pkg ( fcn, &
2748 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2749 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2750 DomainStart , DomainEnd , &
2751 MemoryStart , MemoryEnd , &
2752 PatchStart , PatchEnd , &
2753 Status )
2754 !<DESCRIPTION>
2755 !<PRE>
2756 ! The collect_*_and_call_pkg routines collect a distributed array onto one
2757 ! processor and then call an I/O function to write the result (or in the
2758 ! case of replicated data simply write monitor node's copy of the data)
2759 ! The sole purpose of this wrapper is to allocate a big logical buffer
2760 ! and pass it down to collect_generic_and_call_pkg() to do the actual work.
2761 !</PRE>
2762 !</DESCRIPTION>
2763 USE module_state_description
2764 USE module_driver_constants
2765 IMPLICIT NONE
2766 EXTERNAL fcn
2767 INTEGER , INTENT(IN) :: Hndl
2768 CHARACTER*(*) :: DateStr
2769 CHARACTER*(*) :: VarName
2770 LOGICAL , INTENT(IN) :: Field(*)
2771 INTEGER ,INTENT(IN) :: FieldType
2772 INTEGER ,INTENT(INOUT) :: Comm
2773 INTEGER ,INTENT(INOUT) :: IOComm
2774 INTEGER ,INTENT(IN) :: DomainDesc
2775 LOGICAL, DIMENSION(4) :: bdy_mask
2776 CHARACTER*(*) ,INTENT(IN) :: MemoryOrder
2777 CHARACTER*(*) ,INTENT(IN) :: Stagger
2778 CHARACTER*(*) , dimension (*) ,INTENT(IN) :: DimNames
2779 INTEGER ,dimension(*) ,INTENT(IN) :: DomainStart, DomainEnd
2780 INTEGER ,dimension(*) ,INTENT(IN) :: MemoryStart, MemoryEnd
2781 INTEGER ,dimension(*) ,INTENT(IN) :: PatchStart, PatchEnd
2782 INTEGER ,INTENT(INOUT) :: Status
2783 LOGICAL, ALLOCATABLE :: globbuf (:)
2784 LOGICAL, EXTERNAL :: wrf_dm_on_monitor
2786 IF ( wrf_dm_on_monitor() ) THEN
2787 ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) )
2788 ELSE
2789 ALLOCATE( globbuf( 1 ) )
2790 ENDIF
2792 CALL collect_generic_and_call_pkg ( fcn, globbuf FRSTELEM , &
2793 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2794 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2795 DomainStart , DomainEnd , &
2796 MemoryStart , MemoryEnd , &
2797 PatchStart , PatchEnd , &
2798 Status )
2799 DEALLOCATE ( globbuf )
2800 RETURN
2802 END SUBROUTINE collect_logical_and_call_pkg
2805 SUBROUTINE collect_generic_and_call_pkg ( fcn, globbuf, &
2806 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2807 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
2808 DomainStart , DomainEnd , &
2809 MemoryStart , MemoryEnd , &
2810 PatchStart , PatchEnd , &
2811 Status )
2812 !<DESCRIPTION>
2813 !<PRE>
2814 ! The collect_*_and_call_pkg routines collect a distributed array onto one
2815 ! processor and then call an I/O function to write the result (or in the
2816 ! case of replicated data simply write monitor node's copy of the data)
2817 ! This routine calls the distributed memory communication routines that
2818 ! collect the array and then calls I/O function fcn to write it to disk.
2819 !</PRE>
2820 !</DESCRIPTION>
2821 USE module_state_description
2822 USE module_driver_constants
2823 IMPLICIT NONE
2824 #include "wrf_io_flags.h"
2825 #if defined( DM_PARALLEL ) && ! defined(STUBMPI)
2826 include "mpif.h"
2827 #endif
2828 EXTERNAL fcn
2829 REAL , DIMENSION(*) , INTENT(INOUT) :: globbuf
2830 INTEGER , INTENT(IN) :: Hndl
2831 CHARACTER*(*) :: DateStr
2832 CHARACTER*(*) :: VarName
2833 REAL , INTENT(IN) :: Field(*)
2834 INTEGER ,INTENT(IN) :: FieldType
2835 INTEGER ,INTENT(INOUT) :: Comm
2836 INTEGER ,INTENT(INOUT) :: IOComm
2837 INTEGER ,INTENT(IN) :: DomainDesc
2838 LOGICAL, DIMENSION(4) :: bdy_mask
2839 CHARACTER*(*) ,INTENT(IN) :: MemoryOrder
2840 CHARACTER*(*) ,INTENT(IN) :: Stagger
2841 CHARACTER*(*) , dimension (*) ,INTENT(IN) :: DimNames
2842 INTEGER ,dimension(*) ,INTENT(IN) :: DomainStart, DomainEnd
2843 INTEGER ,dimension(*) ,INTENT(IN) :: MemoryStart, MemoryEnd
2844 INTEGER ,dimension(*) ,INTENT(IN) :: PatchStart, PatchEnd
2845 INTEGER ,INTENT(OUT) :: Status
2846 CHARACTER*3 MemOrd
2847 LOGICAL, EXTERNAL :: has_char
2848 INTEGER ids, ide, jds, jde, kds, kde
2849 INTEGER ims, ime, jms, jme, kms, kme
2850 INTEGER ips, ipe, jps, jpe, kps, kpe
2851 INTEGER, ALLOCATABLE :: counts(:), displs(:)
2852 INTEGER nproc, communicator, mpi_bdyslice_type, ierr, my_displ
2853 INTEGER my_count
2854 INTEGER , dimension(3) :: dom_end_rev
2855 LOGICAL, EXTERNAL :: wrf_dm_on_monitor
2856 INTEGER, EXTERNAL :: wrf_dm_monitor_rank
2857 LOGICAL distributed_field
2858 INTEGER i,j,k,idx,lx,idx2,lx2
2859 INTEGER collective_root
2861 CALL wrf_get_nproc( nproc )
2862 CALL wrf_get_dm_communicator ( communicator )
2864 ALLOCATE( counts( nproc ) )
2865 ALLOCATE( displs( nproc ) )
2866 CALL lower_case( MemoryOrder, MemOrd )
2868 collective_root = wrf_dm_monitor_rank()
2870 dom_end_rev(1) = DomainEnd(1)
2871 dom_end_rev(2) = DomainEnd(2)
2872 dom_end_rev(3) = DomainEnd(3)
2874 SELECT CASE (TRIM(MemOrd))
2875 CASE ( 'xzy' )
2876 IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
2877 IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
2878 IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
2879 CASE ( 'zxy' )
2880 IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
2881 IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
2882 IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
2883 CASE ( 'xyz' )
2884 IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
2885 IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
2886 IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
2887 CASE ( 'xy' )
2888 IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
2889 IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
2890 CASE ( 'yxz' )
2891 IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
2892 IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
2893 IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
2894 CASE ( 'yx' )
2895 IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
2896 IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
2897 CASE DEFAULT
2898 ! do nothing; the boundary orders and others either dont care or set themselves
2899 END SELECT
2901 SELECT CASE (TRIM(MemOrd))
2902 #ifndef STUBMPI
2903 CASE ( 'xzy','zxy','xyz','yxz','xy','yx' )
2905 distributed_field = .TRUE.
2906 IF ( FieldType .EQ. WRF_DOUBLE ) THEN
2907 CALL wrf_patch_to_global_double ( Field , globbuf , DomainDesc, Stagger, MemOrd , &
2908 DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
2909 MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
2910 PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
2911 ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
2912 CALL wrf_patch_to_global_real ( Field , globbuf , DomainDesc, Stagger, MemOrd , &
2913 DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
2914 MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
2915 PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
2916 ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
2917 CALL wrf_patch_to_global_integer ( Field , globbuf , DomainDesc, Stagger, MemOrd , &
2918 DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
2919 MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
2920 PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
2921 ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
2922 CALL wrf_patch_to_global_logical ( Field , globbuf , DomainDesc, Stagger, MemOrd , &
2923 DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
2924 MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
2925 PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
2926 ENDIF
2928 #if defined(DM_PARALLEL) && !defined(STUBMPI)
2929 CASE ( 'xsz', 'xez' )
2930 distributed_field = .FALSE.
2931 IF ( nproc .GT. 1 ) THEN
2932 jds = DomainStart(1) ; jde = DomainEnd(1) ; IF ( .NOT. has_char( Stagger, 'y' ) ) jde = jde+1 ! ns strip
2933 kds = DomainStart(2) ; kde = DomainEnd(2) ; IF ( .NOT. has_char( Stagger, 'z' ) ) kde = kde+1 ! levels
2934 ids = DomainStart(3) ; ide = DomainEnd(3) ; ! bdy_width
2935 dom_end_rev(1) = jde
2936 dom_end_rev(2) = kde
2937 dom_end_rev(3) = ide
2938 distributed_field = .TRUE.
2939 IF ( (MemOrd .eq. 'xsz' .AND. bdy_mask( P_XSB )) .OR. &
2940 (MemOrd .eq. 'xez' .AND. bdy_mask( P_XEB )) ) THEN
2941 my_displ = PatchStart(1)-1
2942 my_count = PatchEnd(1)-PatchStart(1)+1
2943 ELSE
2944 my_displ = 0
2945 my_count = 0
2946 ENDIF
2947 CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr )
2948 CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr )
2949 do i = DomainStart(3),DomainEnd(3) ! bdy_width
2950 do k = DomainStart(2),DomainEnd(2) ! levels
2951 lx = MemoryEnd(1)-MemoryStart(1)+1
2952 lx2 = dom_end_rev(1)-DomainStart(1)+1
2953 idx = lx*((k-1)+(i-1)*(MemoryEnd(2)-MemoryStart(2)+1))
2954 idx2 = lx2*((k-1)+(i-1)*(MemoryEnd(2)-MemoryStart(2)+1))
2955 IF ( FieldType .EQ. WRF_DOUBLE ) THEN
2957 CALL wrf_gatherv_double ( Field, PatchStart(1)-MemoryStart(1)+1+idx , &
2958 my_count , & ! sendcount
2959 globbuf, 1+idx2 , & ! recvbuf
2960 counts , & ! recvcounts
2961 displs , & ! displs
2962 collective_root , & ! root
2963 communicator , & ! communicator
2964 ierr )
2966 ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
2968 CALL wrf_gatherv_real ( Field, PatchStart(1)-MemoryStart(1)+1+idx , &
2969 my_count , & ! sendcount
2970 globbuf, 1+idx2 , & ! recvbuf
2971 counts , & ! recvcounts
2972 displs , & ! displs
2973 collective_root , & ! root
2974 communicator , & ! communicator
2975 ierr )
2977 ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
2979 CALL wrf_gatherv_integer ( Field, PatchStart(1)-MemoryStart(1)+1+idx , &
2980 my_count , & ! sendcount
2981 globbuf, 1+idx2 , & ! recvbuf
2982 counts , & ! recvcounts
2983 displs , & ! displs
2984 collective_root , & ! root
2985 communicator , & ! communicator
2986 ierr )
2987 ENDIF
2989 enddo
2990 enddo
2991 ENDIF
2992 CASE ( 'xs', 'xe' )
2993 distributed_field = .FALSE.
2994 IF ( nproc .GT. 1 ) THEN
2995 jds = DomainStart(1) ; jde = DomainEnd(1) ; IF ( .NOT. has_char( Stagger, 'y' ) ) jde = jde+1 ! ns strip
2996 ids = DomainStart(2) ; ide = DomainEnd(2) ; ! bdy_width
2997 dom_end_rev(1) = jde
2998 dom_end_rev(2) = ide
2999 distributed_field = .TRUE.
3000 IF ( (MemOrd .eq. 'xs' .AND. bdy_mask( P_XSB )) .OR. &
3001 (MemOrd .eq. 'xe' .AND. bdy_mask( P_XEB )) ) THEN
3002 my_displ = PatchStart(1)-1
3003 my_count = PatchEnd(1)-PatchStart(1)+1
3004 ELSE
3005 my_displ = 0
3006 my_count = 0
3007 ENDIF
3008 CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr )
3009 CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr )
3010 do i = DomainStart(2),DomainEnd(2) ! bdy_width
3011 lx = MemoryEnd(1)-MemoryStart(1)+1
3012 idx = lx*(i-1)
3013 lx2 = dom_end_rev(1)-DomainStart(1)+1
3014 idx2 = lx2*(i-1)
3015 IF ( FieldType .EQ. WRF_DOUBLE ) THEN
3017 CALL wrf_gatherv_double ( Field, PatchStart(1)-MemoryStart(1)+1+idx , &
3018 my_count , & ! sendcount
3019 globbuf, 1+idx2 , & ! recvbuf
3020 counts , & ! recvcounts
3021 displs , & ! displs
3022 collective_root , & ! root
3023 communicator , & ! communicator
3024 ierr )
3026 ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
3028 CALL wrf_gatherv_real ( Field, PatchStart(1)-MemoryStart(1)+1+idx , &
3029 my_count , & ! sendcount
3030 globbuf, 1+idx2 , & ! recvbuf
3031 counts , & ! recvcounts
3032 displs , & ! displs
3033 collective_root , & ! root
3034 communicator , & ! communicator
3035 ierr )
3037 ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
3039 CALL wrf_gatherv_integer ( Field, PatchStart(1)-MemoryStart(1)+1+idx , &
3040 my_count , & ! sendcount
3041 globbuf, 1+idx2 , & ! recvbuf
3042 counts , & ! recvcounts
3043 displs , & ! displs
3044 collective_root , & ! root
3045 communicator , & ! communicator
3046 ierr )
3047 ENDIF
3049 enddo
3050 ENDIF
3051 CASE ( 'ysz', 'yez' )
3052 distributed_field = .FALSE.
3053 IF ( nproc .GT. 1 ) THEN
3054 ids = DomainStart(1) ; ide = DomainEnd(1) ; IF ( .NOT. has_char( Stagger, 'y' ) ) ide = ide+1 ! ns strip
3055 kds = DomainStart(2) ; kde = DomainEnd(2) ; IF ( .NOT. has_char( Stagger, 'z' ) ) kde = kde+1 ! levels
3056 jds = DomainStart(3) ; jde = DomainEnd(3) ; ! bdy_width
3057 dom_end_rev(1) = ide
3058 dom_end_rev(2) = kde
3059 dom_end_rev(3) = jde
3060 distributed_field = .TRUE.
3061 IF ( (MemOrd .eq. 'ysz' .AND. bdy_mask( P_YSB )) .OR. &
3062 (MemOrd .eq. 'yez' .AND. bdy_mask( P_YEB )) ) THEN
3063 my_displ = PatchStart(1)-1
3064 my_count = PatchEnd(1)-PatchStart(1)+1
3065 ELSE
3066 my_displ = 0
3067 my_count = 0
3068 ENDIF
3069 CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr )
3070 CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr )
3071 do j = DomainStart(3),DomainEnd(3) ! bdy_width
3072 do k = DomainStart(2),DomainEnd(2) ! levels
3073 lx = MemoryEnd(1)-MemoryStart(1)+1
3074 lx2 = dom_end_rev(1)-DomainStart(1)+1
3075 idx = lx*((k-1)+(j-1)*(MemoryEnd(2)-MemoryStart(2)+1))
3076 idx2 = lx2*((k-1)+(j-1)*(MemoryEnd(2)-MemoryStart(2)+1))
3078 IF ( FieldType .EQ. WRF_DOUBLE ) THEN
3080 CALL wrf_gatherv_double ( Field, PatchStart(1)-MemoryStart(1)+1+idx , & ! sendbuf
3081 my_count , & ! sendcount
3082 globbuf, 1+idx2 , & ! recvbuf
3083 counts , & ! recvcounts
3084 displs , & ! displs
3085 collective_root , & ! root
3086 communicator , & ! communicator
3087 ierr )
3089 ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
3091 CALL wrf_gatherv_real( Field, PatchStart(1)-MemoryStart(1)+1+idx , & ! sendbuf
3092 my_count , & ! sendcount
3093 globbuf, 1+idx2 , & ! recvbuf
3094 counts , & ! recvcounts
3095 displs , & ! displs
3096 collective_root , & ! root
3097 communicator , & ! communicator
3098 ierr )
3100 ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
3102 CALL wrf_gatherv_integer( Field, PatchStart(1)-MemoryStart(1)+1+idx , & ! sendbuf
3103 my_count , & ! sendcount
3104 globbuf, 1+idx2 , & ! recvbuf
3105 counts , & ! recvcounts
3106 displs , & ! displs
3107 collective_root , & ! root
3108 communicator , & ! communicator
3109 ierr )
3110 ENDIF
3112 enddo
3113 enddo
3114 ENDIF
3115 CASE ( 'ys', 'ye' )
3116 distributed_field = .FALSE.
3117 IF ( nproc .GT. 1 ) THEN
3118 ids = DomainStart(1) ; ide = DomainEnd(1) ; IF ( .NOT. has_char( Stagger, 'y' ) ) ide = ide+1 ! ns strip
3119 jds = DomainStart(2) ; jde = DomainEnd(2) ; ! bdy_width
3120 dom_end_rev(1) = ide
3121 dom_end_rev(2) = jde
3122 distributed_field = .TRUE.
3123 IF ( (MemOrd .eq. 'ys' .AND. bdy_mask( P_YSB )) .OR. &
3124 (MemOrd .eq. 'ye' .AND. bdy_mask( P_YEB )) ) THEN
3125 my_displ = PatchStart(1)-1
3126 my_count = PatchEnd(1)-PatchStart(1)+1
3127 ELSE
3128 my_displ = 0
3129 my_count = 0
3130 ENDIF
3131 CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr )
3132 CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr )
3133 do j = DomainStart(2),DomainEnd(2) ! bdy_width
3134 lx = MemoryEnd(1)-MemoryStart(1)+1
3135 idx = lx*(j-1)
3136 lx2 = dom_end_rev(1)-DomainStart(1)+1
3137 idx2 = lx2*(j-1)
3139 IF ( FieldType .EQ. WRF_DOUBLE ) THEN
3141 CALL wrf_gatherv_double( Field, PatchStart(1)-MemoryStart(1)+1+idx , & ! sendbuf
3142 my_count , & ! sendcount
3143 globbuf, 1+idx2 , & ! recvbuf
3144 counts , & ! recvcounts
3145 displs , & ! displs
3146 collective_root , & ! root
3147 communicator , & ! communicator
3148 ierr )
3150 ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
3152 CALL wrf_gatherv_real( Field, PatchStart(1)-MemoryStart(1)+1+idx , & ! sendbuf
3153 my_count , & ! sendcount
3154 globbuf, 1+idx2 , & ! recvbuf
3155 counts , & ! recvcounts
3156 displs , & ! displs
3157 collective_root , & ! root
3158 communicator , & ! communicator
3159 ierr )
3161 ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
3163 CALL wrf_gatherv_integer( Field, PatchStart(1)-MemoryStart(1)+1+idx , & ! sendbuf
3164 my_count , & ! sendcount
3165 globbuf, 1+idx2 , & ! recvbuf
3166 counts , & ! recvcounts
3167 displs , & ! displs
3168 collective_root , & ! root
3169 communicator , & ! communicator
3170 ierr )
3171 ENDIF
3173 enddo
3174 ENDIF
3175 #endif
3176 #endif
3177 CASE DEFAULT
3178 distributed_field = .FALSE.
3179 END SELECT
3180 IF ( wrf_dm_on_monitor() ) THEN
3181 IF ( distributed_field ) THEN
3182 CALL fcn ( Hndl , DateStr , VarName , globbuf , FieldType , Comm , IOComm , &
3183 DomainDesc , MemoryOrder , Stagger , DimNames , &
3184 DomainStart , DomainEnd , &
3185 DomainStart , dom_end_rev , & ! memory dims adjust out for unstag
3186 DomainStart , DomainEnd , &
3187 Status )
3188 ELSE
3189 CALL fcn ( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3190 DomainDesc , MemoryOrder , Stagger , DimNames , &
3191 DomainStart , DomainEnd , &
3192 MemoryStart , MemoryEnd , &
3193 PatchStart , PatchEnd , &
3194 Status )
3195 ENDIF
3196 ENDIF
3197 CALL wrf_dm_bcast_bytes( Status , IWORDSIZE )
3198 DEALLOCATE( counts )
3199 DEALLOCATE( displs )
3200 RETURN
3201 END SUBROUTINE collect_generic_and_call_pkg
3204 SUBROUTINE call_pkg_and_dist ( fcn, donotdist_arg, update_arg, &
3205 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3206 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
3207 DomainStart , DomainEnd , &
3208 MemoryStart , MemoryEnd , &
3209 PatchStart , PatchEnd , &
3210 Status )
3211 !<DESCRIPTION>
3212 !<PRE>
3213 ! The call_pkg_and_dist* routines call an I/O function to read a field and then
3214 ! distribute or replicate the field across compute tasks.
3215 ! This routine handle cases where distribution/replication can be skipped and
3216 ! deals with different data types for Field.
3217 !</PRE>
3218 !</DESCRIPTION>
3219 IMPLICIT NONE
3220 #include "wrf_io_flags.h"
3221 EXTERNAL fcn
3222 LOGICAL, INTENT(IN) :: donotdist_arg, update_arg ! update means collect old field update it and dist
3223 INTEGER , INTENT(IN) :: Hndl
3224 CHARACTER*(*) :: DateStr
3225 CHARACTER*(*) :: VarName
3226 INTEGER :: Field(*)
3227 INTEGER :: FieldType
3228 INTEGER :: Comm
3229 INTEGER :: IOComm
3230 INTEGER :: DomainDesc
3231 LOGICAL, DIMENSION(4) :: bdy_mask
3232 CHARACTER*(*) :: MemoryOrder
3233 CHARACTER*(*) :: Stagger
3234 CHARACTER*(*) , dimension (*) :: DimNames
3235 INTEGER ,dimension(*) :: DomainStart, DomainEnd
3236 INTEGER ,dimension(*) :: MemoryStart, MemoryEnd
3237 INTEGER ,dimension(*) :: PatchStart, PatchEnd
3238 INTEGER :: Status
3239 LOGICAL donotdist
3240 INTEGER ndims, nproc
3242 CALL dim_from_memorder( MemoryOrder , ndims)
3243 CALL wrf_get_nproc( nproc )
3244 donotdist = donotdist_arg .OR. (nproc .EQ. 1)
3246 IF ( donotdist ) THEN
3247 CALL fcn ( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3248 DomainDesc , MemoryOrder , Stagger , DimNames , &
3249 DomainStart , DomainEnd , &
3250 MemoryStart , MemoryEnd , &
3251 PatchStart , PatchEnd , &
3252 Status )
3254 ELSE IF (FieldType .EQ. WRF_DOUBLE) THEN
3256 CALL call_pkg_and_dist_double ( fcn, update_arg, &
3257 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3258 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
3259 DomainStart , DomainEnd , &
3260 MemoryStart , MemoryEnd , &
3261 PatchStart , PatchEnd , &
3262 Status )
3264 ELSE IF (FieldType .EQ. WRF_FLOAT) THEN
3266 CALL call_pkg_and_dist_real ( fcn, update_arg, &
3267 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3268 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
3269 DomainStart , DomainEnd , &
3270 MemoryStart , MemoryEnd , &
3271 PatchStart , PatchEnd , &
3272 Status )
3274 ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
3276 CALL call_pkg_and_dist_int ( fcn, update_arg, &
3277 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3278 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
3279 DomainStart , DomainEnd , &
3280 MemoryStart , MemoryEnd , &
3281 PatchStart , PatchEnd , &
3282 Status )
3284 ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
3286 CALL call_pkg_and_dist_logical ( fcn, update_arg, &
3287 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3288 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
3289 DomainStart , DomainEnd , &
3290 MemoryStart , MemoryEnd , &
3291 PatchStart , PatchEnd , &
3292 Status )
3294 ENDIF
3295 RETURN
3296 END SUBROUTINE call_pkg_and_dist
3298 SUBROUTINE call_pkg_and_dist_real ( fcn, update_arg, &
3299 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3300 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
3301 DomainStart , DomainEnd , &
3302 MemoryStart , MemoryEnd , &
3303 PatchStart , PatchEnd , &
3304 Status )
3305 !<DESCRIPTION>
3306 !<PRE>
3307 ! The call_pkg_and_dist* routines call an I/O function to read a field and then
3308 ! distribute or replicate the field across compute tasks.
3309 ! The sole purpose of this wrapper is to allocate a big real buffer and
3310 ! pass it down to call_pkg_and_dist_generic() to do the actual work.
3311 !</PRE>
3312 !</DESCRIPTION>
3313 IMPLICIT NONE
3314 EXTERNAL fcn
3315 INTEGER , INTENT(IN) :: Hndl
3316 LOGICAL , INTENT(IN) :: update_arg
3317 CHARACTER*(*) :: DateStr
3318 CHARACTER*(*) :: VarName
3319 REAL , INTENT(INOUT) :: Field(*)
3320 INTEGER ,INTENT(IN) :: FieldType
3321 INTEGER ,INTENT(INOUT) :: Comm
3322 INTEGER ,INTENT(INOUT) :: IOComm
3323 INTEGER ,INTENT(IN) :: DomainDesc
3324 LOGICAL, DIMENSION(4) :: bdy_mask
3325 CHARACTER*(*) ,INTENT(IN) :: MemoryOrder
3326 CHARACTER*(*) ,INTENT(IN) :: Stagger
3327 CHARACTER*(*) , dimension (*) ,INTENT(IN) :: DimNames
3328 INTEGER ,dimension(*) ,INTENT(IN) :: DomainStart, DomainEnd
3329 INTEGER ,dimension(*) ,INTENT(IN) :: MemoryStart, MemoryEnd
3330 INTEGER ,dimension(*) ,INTENT(IN) :: PatchStart, PatchEnd
3331 INTEGER ,INTENT(INOUT) :: Status
3332 REAL, ALLOCATABLE :: globbuf (:)
3333 LOGICAL, EXTERNAL :: wrf_dm_on_monitor
3334 INTEGER test
3335 CHARACTER*128 mess
3337 IF ( wrf_dm_on_monitor() ) THEN
3338 ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ), &
3339 STAT=test )
3340 IF ( test .NE. 0 ) THEN
3341 write(mess,*)"module_io.b",'allocating globbuf ',&
3342 (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3)
3343 CALL wrf_error_fatal(mess)
3344 ENDIF
3345 ELSE
3346 ALLOCATE( globbuf( 1 ), STAT=test )
3347 IF ( test .NE. 0 ) THEN
3348 write(mess,*)"module_io.b",'allocating globbuf ',1
3349 CALL wrf_error_fatal(mess)
3350 ENDIF
3351 ENDIF
3353 globbuf = 0.
3355 CALL call_pkg_and_dist_generic ( fcn, globbuf FRSTELEM , update_arg, &
3356 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3357 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
3358 DomainStart , DomainEnd , &
3359 MemoryStart , MemoryEnd , &
3360 PatchStart , PatchEnd , &
3361 Status )
3362 DEALLOCATE ( globbuf )
3363 RETURN
3364 END SUBROUTINE call_pkg_and_dist_real
3367 SUBROUTINE call_pkg_and_dist_double ( fcn, update_arg , &
3368 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3369 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
3370 DomainStart , DomainEnd , &
3371 MemoryStart , MemoryEnd , &
3372 PatchStart , PatchEnd , &
3373 Status )
3374 !<DESCRIPTION>
3375 !<PRE>
3376 ! The call_pkg_and_dist* routines call an I/O function to read a field and then
3377 ! distribute or replicate the field across compute tasks.
3378 ! The sole purpose of this wrapper is to allocate a big double precision buffer
3379 ! and pass it down to call_pkg_and_dist_generic() to do the actual work.
3380 !</PRE>
3381 !</DESCRIPTION>
3382 IMPLICIT NONE
3383 EXTERNAL fcn
3384 INTEGER , INTENT(IN) :: Hndl
3385 LOGICAL , INTENT(IN) :: update_arg
3386 CHARACTER*(*) :: DateStr
3387 CHARACTER*(*) :: VarName
3388 DOUBLE PRECISION , INTENT(INOUT) :: Field(*)
3389 INTEGER ,INTENT(IN) :: FieldType
3390 INTEGER ,INTENT(INOUT) :: Comm
3391 INTEGER ,INTENT(INOUT) :: IOComm
3392 INTEGER ,INTENT(IN) :: DomainDesc
3393 LOGICAL, DIMENSION(4) :: bdy_mask
3394 CHARACTER*(*) ,INTENT(IN) :: MemoryOrder
3395 CHARACTER*(*) ,INTENT(IN) :: Stagger
3396 CHARACTER*(*) , dimension (*) ,INTENT(IN) :: DimNames
3397 INTEGER ,dimension(*) ,INTENT(IN) :: DomainStart, DomainEnd
3398 INTEGER ,dimension(*) ,INTENT(IN) :: MemoryStart, MemoryEnd
3399 INTEGER ,dimension(*) ,INTENT(IN) :: PatchStart, PatchEnd
3400 INTEGER ,INTENT(INOUT) :: Status
3401 DOUBLE PRECISION , ALLOCATABLE :: globbuf (:)
3402 LOGICAL, EXTERNAL :: wrf_dm_on_monitor
3404 IF ( wrf_dm_on_monitor() ) THEN
3405 ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) )
3406 ELSE
3407 ALLOCATE( globbuf( 1 ) )
3408 ENDIF
3410 globbuf = 0
3412 CALL call_pkg_and_dist_generic ( fcn, globbuf FRSTELEM , update_arg , &
3413 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3414 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
3415 DomainStart , DomainEnd , &
3416 MemoryStart , MemoryEnd , &
3417 PatchStart , PatchEnd , &
3418 Status )
3419 DEALLOCATE ( globbuf )
3420 RETURN
3421 END SUBROUTINE call_pkg_and_dist_double
3424 SUBROUTINE call_pkg_and_dist_int ( fcn, update_arg , &
3425 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3426 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
3427 DomainStart , DomainEnd , &
3428 MemoryStart , MemoryEnd , &
3429 PatchStart , PatchEnd , &
3430 Status )
3431 !<DESCRIPTION>
3432 !<PRE>
3433 ! The call_pkg_and_dist* routines call an I/O function to read a field and then
3434 ! distribute or replicate the field across compute tasks.
3435 ! The sole purpose of this wrapper is to allocate a big integer buffer and
3436 ! pass it down to call_pkg_and_dist_generic() to do the actual work.
3437 !</PRE>
3438 !</DESCRIPTION>
3439 IMPLICIT NONE
3440 EXTERNAL fcn
3441 INTEGER , INTENT(IN) :: Hndl
3442 LOGICAL , INTENT(IN) :: update_arg
3443 CHARACTER*(*) :: DateStr
3444 CHARACTER*(*) :: VarName
3445 INTEGER , INTENT(INOUT) :: Field(*)
3446 INTEGER ,INTENT(IN) :: FieldType
3447 INTEGER ,INTENT(INOUT) :: Comm
3448 INTEGER ,INTENT(INOUT) :: IOComm
3449 INTEGER ,INTENT(IN) :: DomainDesc
3450 LOGICAL, DIMENSION(4) :: bdy_mask
3451 CHARACTER*(*) ,INTENT(IN) :: MemoryOrder
3452 CHARACTER*(*) ,INTENT(IN) :: Stagger
3453 CHARACTER*(*) , dimension (*) ,INTENT(IN) :: DimNames
3454 INTEGER ,dimension(*) ,INTENT(IN) :: DomainStart, DomainEnd
3455 INTEGER ,dimension(*) ,INTENT(IN) :: MemoryStart, MemoryEnd
3456 INTEGER ,dimension(*) ,INTENT(IN) :: PatchStart, PatchEnd
3457 INTEGER ,INTENT(INOUT) :: Status
3458 INTEGER , ALLOCATABLE :: globbuf (:)
3459 LOGICAL, EXTERNAL :: wrf_dm_on_monitor
3461 IF ( wrf_dm_on_monitor() ) THEN
3462 ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) )
3463 ELSE
3464 ALLOCATE( globbuf( 1 ) )
3465 ENDIF
3467 globbuf = 0
3469 CALL call_pkg_and_dist_generic ( fcn, globbuf FRSTELEM , update_arg , &
3470 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3471 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
3472 DomainStart , DomainEnd , &
3473 MemoryStart , MemoryEnd , &
3474 PatchStart , PatchEnd , &
3475 Status )
3476 DEALLOCATE ( globbuf )
3477 RETURN
3478 END SUBROUTINE call_pkg_and_dist_int
3481 SUBROUTINE call_pkg_and_dist_logical ( fcn, update_arg , &
3482 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3483 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
3484 DomainStart , DomainEnd , &
3485 MemoryStart , MemoryEnd , &
3486 PatchStart , PatchEnd , &
3487 Status )
3488 !<DESCRIPTION>
3489 !<PRE>
3490 ! The call_pkg_and_dist* routines call an I/O function to read a field and then
3491 ! distribute or replicate the field across compute tasks.
3492 ! The sole purpose of this wrapper is to allocate a big logical buffer and
3493 ! pass it down to call_pkg_and_dist_generic() to do the actual work.
3494 !</PRE>
3495 !</DESCRIPTION>
3496 IMPLICIT NONE
3497 EXTERNAL fcn
3498 INTEGER , INTENT(IN) :: Hndl
3499 LOGICAL , INTENT(IN) :: update_arg
3500 CHARACTER*(*) :: DateStr
3501 CHARACTER*(*) :: VarName
3502 logical , INTENT(INOUT) :: Field(*)
3503 INTEGER ,INTENT(IN) :: FieldType
3504 INTEGER ,INTENT(INOUT) :: Comm
3505 INTEGER ,INTENT(INOUT) :: IOComm
3506 INTEGER ,INTENT(IN) :: DomainDesc
3507 LOGICAL, DIMENSION(4) :: bdy_mask
3508 CHARACTER*(*) ,INTENT(IN) :: MemoryOrder
3509 CHARACTER*(*) ,INTENT(IN) :: Stagger
3510 CHARACTER*(*) , dimension (*) ,INTENT(IN) :: DimNames
3511 INTEGER ,dimension(*) ,INTENT(IN) :: DomainStart, DomainEnd
3512 INTEGER ,dimension(*) ,INTENT(IN) :: MemoryStart, MemoryEnd
3513 INTEGER ,dimension(*) ,INTENT(IN) :: PatchStart, PatchEnd
3514 INTEGER ,INTENT(INOUT) :: Status
3515 LOGICAL , ALLOCATABLE :: globbuf (:)
3516 LOGICAL, EXTERNAL :: wrf_dm_on_monitor
3518 IF ( wrf_dm_on_monitor() ) THEN
3519 ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) )
3520 ELSE
3521 ALLOCATE( globbuf( 1 ) )
3522 ENDIF
3524 globbuf = .false.
3526 CALL call_pkg_and_dist_generic ( fcn, globbuf FRSTELEM , update_arg , &
3527 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3528 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
3529 DomainStart , DomainEnd , &
3530 MemoryStart , MemoryEnd , &
3531 PatchStart , PatchEnd , &
3532 Status )
3533 DEALLOCATE ( globbuf )
3534 RETURN
3535 END SUBROUTINE call_pkg_and_dist_logical
3537 SUBROUTINE call_pkg_and_dist_generic ( fcn, globbuf , update_arg , &
3538 Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3539 DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
3540 DomainStart , DomainEnd , &
3541 MemoryStart , MemoryEnd , &
3542 PatchStart , PatchEnd , &
3543 Status )
3545 !<DESCRIPTION>
3546 !<PRE>
3547 ! The call_pkg_and_dist* routines call an I/O function to read a field and then
3548 ! distribute or replicate the field across compute tasks.
3549 ! This routine calls I/O function fcn to read the field from disk and then calls
3550 ! the distributed memory communication routines that distribute or replicate the
3551 ! array.
3552 !</PRE>
3553 !</DESCRIPTION>
3554 USE module_state_description
3555 USE module_driver_constants
3556 USE module_io
3557 IMPLICIT NONE
3558 #include "wrf_io_flags.h"
3559 #if defined( DM_PARALLEL ) && ! defined(STUBMPI)
3560 include "mpif.h"
3561 #endif
3563 EXTERNAL fcn
3564 REAL, DIMENSION(*) :: globbuf
3565 INTEGER , INTENT(IN) :: Hndl
3566 LOGICAL , INTENT(IN) :: update_arg
3567 CHARACTER*(*) :: DateStr
3568 CHARACTER*(*) :: VarName
3569 REAL :: Field(*)
3570 INTEGER ,INTENT(IN) :: FieldType
3571 INTEGER ,INTENT(INOUT) :: Comm
3572 INTEGER ,INTENT(INOUT) :: IOComm
3573 INTEGER ,INTENT(IN) :: DomainDesc
3574 LOGICAL, DIMENSION(4) :: bdy_mask
3575 CHARACTER*(*) ,INTENT(IN) :: MemoryOrder
3576 CHARACTER*(*) ,INTENT(IN) :: Stagger
3577 CHARACTER*(*) , dimension (*) ,INTENT(IN) :: DimNames
3578 INTEGER ,dimension(*) ,INTENT(IN) :: DomainStart, DomainEnd
3579 INTEGER ,dimension(*) ,INTENT(IN) :: MemoryStart, MemoryEnd
3580 INTEGER ,dimension(*) ,INTENT(IN) :: PatchStart, PatchEnd
3581 INTEGER ,INTENT(OUT) :: Status
3582 CHARACTER*3 MemOrd
3583 LOGICAL, EXTERNAL :: has_char
3584 INTEGER ids, ide, jds, jde, kds, kde
3585 INTEGER ims, ime, jms, jme, kms, kme
3586 INTEGER ips, ipe, jps, jpe, kps, kpe
3587 INTEGER , dimension(3) :: dom_end_rev
3588 INTEGER memsize
3589 LOGICAL, EXTERNAL :: wrf_dm_on_monitor
3590 INTEGER, EXTERNAL :: wrf_dm_monitor_rank
3592 INTEGER lx, lx2, i,j,k ,idx,idx2
3593 INTEGER my_count, nproc, communicator, ierr, my_displ
3595 INTEGER, ALLOCATABLE :: counts(:), displs(:)
3597 LOGICAL distributed_field
3598 INTEGER collective_root
3600 CALL lower_case( MemoryOrder, MemOrd )
3602 collective_root = wrf_dm_monitor_rank()
3604 CALL wrf_get_nproc( nproc )
3605 CALL wrf_get_dm_communicator ( communicator )
3607 ALLOCATE(displs( nproc ))
3608 ALLOCATE(counts( nproc ))
3610 dom_end_rev(1) = DomainEnd(1)
3611 dom_end_rev(2) = DomainEnd(2)
3612 dom_end_rev(3) = DomainEnd(3)
3614 SELECT CASE (TRIM(MemOrd))
3615 CASE ( 'xzy' )
3616 IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
3617 IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
3618 IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
3619 CASE ( 'zxy' )
3620 IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
3621 IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
3622 IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
3623 CASE ( 'xyz' )
3624 IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
3625 IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
3626 IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
3627 CASE ( 'xy' )
3628 IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
3629 IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
3630 CASE ( 'yxz' )
3631 IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
3632 IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
3633 IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
3634 CASE ( 'yx' )
3635 IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
3636 IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
3637 CASE DEFAULT
3638 ! do nothing; the boundary orders and others either dont care or set themselves
3639 END SELECT
3641 data_ordering : SELECT CASE ( model_data_order )
3642 CASE ( DATA_ORDER_XYZ )
3643 ids=DomainStart(1); ide=dom_end_rev(1); jds=DomainStart(2); jde=dom_end_rev(2); kds=DomainStart(3); kde=dom_end_rev(3);
3644 ims=MemoryStart(1); ime= MemoryEnd(1); jms=MemoryStart(2); jme= MemoryEnd(2); kms=MemoryStart(3); kme= MemoryEnd(3);
3645 ips= PatchStart(1); ipe= PatchEnd(1); jps= PatchStart(2); jpe= PatchEnd(2); kps= PatchStart(3); kpe= PatchEnd(3);
3646 CASE ( DATA_ORDER_YXZ )
3647 ids=DomainStart(2); ide=dom_end_rev(2); jds=DomainStart(1); jde=dom_end_rev(1); kds=DomainStart(3); kde=dom_end_rev(3);
3648 ims=MemoryStart(2); ime= MemoryEnd(2); jms=MemoryStart(1); jme= MemoryEnd(1); kms=MemoryStart(3); kme= MemoryEnd(3);
3649 ips= PatchStart(2); ipe= PatchEnd(2); jps= PatchStart(1); jpe= PatchEnd(1); kps= PatchStart(3); kpe= PatchEnd(3);
3650 CASE ( DATA_ORDER_ZXY )
3651 ids=DomainStart(2); ide=dom_end_rev(2); jds=DomainStart(3); jde=dom_end_rev(3); kds=DomainStart(1); kde=dom_end_rev(1);
3652 ims=MemoryStart(2); ime= MemoryEnd(2); jms=MemoryStart(3); jme= MemoryEnd(3); kms=MemoryStart(1); kme= MemoryEnd(1);
3653 ips= PatchStart(2); ipe= PatchEnd(2); jps= PatchStart(3); jpe= PatchEnd(3); kps= PatchStart(1); kpe= PatchEnd(1);
3654 CASE ( DATA_ORDER_ZYX )
3655 ids=DomainStart(3); ide=dom_end_rev(3); jds=DomainStart(2); jde=dom_end_rev(2); kds=DomainStart(1); kde=dom_end_rev(1);
3656 ims=MemoryStart(3); ime= MemoryEnd(3); jms=MemoryStart(2); jme= MemoryEnd(2); kms=MemoryStart(1); kme= MemoryEnd(1);
3657 ips= PatchStart(3); ipe= PatchEnd(3); jps= PatchStart(2); jpe= PatchEnd(2); kps= PatchStart(1); kpe= PatchEnd(1);
3658 CASE ( DATA_ORDER_XZY )
3659 ids=DomainStart(1); ide=dom_end_rev(1); jds=DomainStart(3); jde=dom_end_rev(3); kds=DomainStart(2); kde=dom_end_rev(2);
3660 ims=MemoryStart(1); ime= MemoryEnd(1); jms=MemoryStart(3); jme= MemoryEnd(3); kms=MemoryStart(2); kme= MemoryEnd(2);
3661 ips= PatchStart(1); ipe= PatchEnd(1); jps= PatchStart(3); jpe= PatchEnd(3); kps= PatchStart(2); kpe= PatchEnd(2);
3662 CASE ( DATA_ORDER_YZX )
3663 ids=DomainStart(3); ide=dom_end_rev(3); jds=DomainStart(1); jde=dom_end_rev(1); kds=DomainStart(2); kde=dom_end_rev(2);
3664 ims=MemoryStart(3); ime= MemoryEnd(3); jms=MemoryStart(1); jme= MemoryEnd(1); kms=MemoryStart(2); kme= MemoryEnd(2);
3665 ips= PatchStart(3); ipe= PatchEnd(3); jps= PatchStart(1); jpe= PatchEnd(1); kps= PatchStart(2); kpe= PatchEnd(2);
3666 END SELECT data_ordering
3669 SELECT CASE (MemOrd)
3670 #ifndef STUBMPI
3671 CASE ( 'xzy', 'yzx', 'xyz', 'yxz', 'zxy', 'zyx', 'xy', 'yx' )
3672 distributed_field = .TRUE.
3673 CASE ( 'xsz', 'xez', 'xs', 'xe' )
3674 CALL are_bdys_distributed( distributed_field )
3675 CASE ( 'ysz', 'yez', 'ys', 'ye' )
3676 CALL are_bdys_distributed( distributed_field )
3677 #endif
3678 CASE DEFAULT
3679 ! all other memory orders are replicated
3680 distributed_field = .FALSE.
3681 END SELECT
3683 IF ( distributed_field ) THEN
3685 ! added 8/2004 for interfaces, like MCEL, that want the old values so they can be updated
3686 IF ( update_arg ) THEN
3687 SELECT CASE (TRIM(MemOrd))
3688 CASE ( 'xzy','zxy','xyz','yxz','xy','yx' )
3689 IF ( FieldType .EQ. WRF_DOUBLE ) THEN
3690 CALL wrf_patch_to_global_double ( Field , globbuf , DomainDesc, Stagger, MemOrd , &
3691 DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
3692 MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
3693 PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
3694 ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
3695 CALL wrf_patch_to_global_real ( Field , globbuf , DomainDesc, Stagger, MemOrd , &
3696 DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
3697 MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
3698 PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
3699 ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
3700 CALL wrf_patch_to_global_integer ( Field , globbuf , DomainDesc, Stagger, MemOrd , &
3701 DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
3702 MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
3703 PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
3704 ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
3705 CALL wrf_patch_to_global_logical ( Field , globbuf , DomainDesc, Stagger, MemOrd , &
3706 DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
3707 MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
3708 PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
3709 ENDIF
3710 CASE DEFAULT
3711 END SELECT
3712 ENDIF
3714 IF ( wrf_dm_on_monitor()) THEN
3715 CALL fcn ( Hndl , DateStr , VarName , globbuf , FieldType , Comm , IOComm , &
3716 DomainDesc , MemoryOrder , Stagger , DimNames , &
3717 DomainStart , DomainEnd , &
3718 DomainStart , dom_end_rev , &
3719 DomainStart , DomainEnd , &
3720 Status )
3721 ENDIF
3723 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
3725 CALL lower_case( MemoryOrder, MemOrd )
3727 #if defined(DM_PARALLEL) && !defined(STUBMPI)
3728 ! handle boundaries separately
3729 IF ( TRIM(MemOrd) .EQ. 'xsz' .OR. TRIM(MemOrd) .EQ. 'xez' .OR. &
3730 TRIM(MemOrd) .EQ. 'xs' .OR. TRIM(MemOrd) .EQ. 'xe' .OR. &
3731 TRIM(MemOrd) .EQ. 'ysz' .OR. TRIM(MemOrd) .EQ. 'yez' .OR. &
3732 TRIM(MemOrd) .EQ. 'ys' .OR. TRIM(MemOrd) .EQ. 'ye' ) THEN
3734 IF ( TRIM(MemOrd) .EQ. 'xsz' .OR. TRIM(MemOrd) .EQ. 'xez' .OR. &
3735 TRIM(MemOrd) .EQ. 'xs' .OR. TRIM(MemOrd) .EQ. 'xe' ) THEN
3737 jds=DomainStart(1); jde=dom_end_rev(1); ids=DomainStart(3); ide=dom_end_rev(3); kds=DomainStart(2); kde=dom_end_rev(2);
3738 jms=MemoryStart(1); jme= MemoryEnd(1); ims=MemoryStart(3); ime= MemoryEnd(3); kms=MemoryStart(2); kme= MemoryEnd(2);
3739 jps= PatchStart(1); jpe= PatchEnd(1); ips= PatchStart(3); ipe= PatchEnd(3); kps= PatchStart(2); kpe= PatchEnd(2);
3741 IF ( nproc .GT. 1 ) THEN
3743 ! Will assume that the i,j, and k dimensions correspond to the model_data_order specified by the registry --
3744 ! eg. i is (1), j is (3), and k is (2) for XZY -- and that when these are passed in for xs/xe boundary arrays (left and right
3745 ! sides of domain) the j is fully dimensioned, i is the bdy_width, and k is k. corresponding arrangement for ys/ye
3746 ! boundaries (bottom and top). Note, however, that for the boundary arrays themselves, the innermost dimension is always
3747 ! the "full" dimension: for xs/xe, dimension 1 of the boundary arrays is j. For ys/ye, it's i. So there's a potential
3748 ! for confusion between the MODEL storage order, and which of the sd31:ed31/sd32:ed32/sd33:ed33 framework dimensions
3749 ! correspond to X/Y/Z as determined by the Registry dimespec definitions and what the storage order of the boundary
3750 ! slab arrays are (which depends on which boundaries they represent). The k memory and domain dimensions must be set
3751 ! properly for 2d (ks=1, ke=1) versus 3d fields.
3753 #if 1
3754 IF ( (MemOrd(1:2) .EQ. 'xs' .AND. bdy_mask( P_XSB )) .OR. &
3755 (MemOrd(1:2) .EQ. 'xe' .AND. bdy_mask( P_XEB )) ) THEN
3756 my_displ = jps-1
3757 my_count = jpe-jps+1
3758 ELSE
3759 my_displ = 0
3760 my_count = 0
3761 ENDIF
3762 #else
3763 IF ( (MemOrd(1:2) .EQ. 'xs' ) .OR. &
3764 (MemOrd(1:2) .EQ. 'xe' ) ) THEN
3765 my_displ = jps-1
3766 my_count = jpe-jps+1
3767 ELSE
3768 my_displ = 0
3769 my_count = 0
3770 ENDIF
3771 #endif
3773 CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr )
3774 CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr )
3776 do i = ips,ipe ! bdy_width
3777 do k = kds,kde ! levels
3778 lx = jme-jms+1
3779 lx2 = jde-jds+1
3780 idx = lx*((k-1)+(i-1)*(kme-kms+1))
3781 idx2 = lx2*((k-1)+(i-1)*(kde-kds+1))
3782 IF ( FieldType .EQ. WRF_DOUBLE ) THEN
3783 CALL wrf_scatterv_double ( &
3784 globbuf, 1+idx2 , & ! sendbuf
3785 counts , & ! sendcounts
3786 Field, jps-jms+1+idx , &
3787 my_count , & ! recvcount
3788 displs , & ! displs
3789 collective_root , & ! root
3790 communicator , & ! communicator
3791 ierr )
3792 ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
3794 CALL wrf_scatterv_real ( &
3795 globbuf, 1+idx2 , & ! sendbuf
3796 counts , & ! sendcounts
3797 Field, jps-jms+1+idx , &
3798 my_count , & ! recvcount
3799 displs , & ! displs
3800 collective_root , & ! root
3801 communicator , & ! communicator
3802 ierr )
3804 ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
3805 CALL wrf_scatterv_integer ( &
3806 globbuf, 1+idx2 , & ! sendbuf
3807 counts , & ! sendcounts
3808 Field, jps-jms+1+idx , &
3809 my_count , & ! recvcount
3810 displs , & ! displs
3811 collective_root , & ! root
3812 communicator , & ! communicator
3813 ierr )
3814 ENDIF
3815 enddo
3816 enddo
3817 ENDIF
3818 ENDIF
3820 IF ( TRIM(MemOrd) .EQ. 'ysz' .OR. TRIM(MemOrd) .EQ. 'yez' .OR. &
3821 TRIM(MemOrd) .EQ. 'ys' .OR. TRIM(MemOrd) .EQ. 'ye' ) THEN
3824 ids=DomainStart(1); ide=dom_end_rev(1); jds=DomainStart(3); jde=dom_end_rev(3); kds=DomainStart(2); kde=dom_end_rev(2);
3825 ims=MemoryStart(1); ime= MemoryEnd(1); jms=MemoryStart(3); jme= MemoryEnd(3); kms=MemoryStart(2); kme= MemoryEnd(2);
3826 ips= PatchStart(1); ipe= PatchEnd(1); jps= PatchStart(3); jpe= PatchEnd(3); kps= PatchStart(2); kpe= PatchEnd(2);
3828 IF ( nproc .GT. 1 ) THEN
3830 #if 1
3831 IF ( (MemOrd(1:2) .EQ. 'ys' .AND. bdy_mask( P_YSB )) .OR. &
3832 (MemOrd(1:2) .EQ. 'ye' .AND. bdy_mask( P_YEB )) ) THEN
3833 my_displ = ips-1
3834 my_count = ipe-ips+1
3835 ELSE
3836 my_displ = 0
3837 my_count = 0
3838 ENDIF
3839 #else
3840 IF ( (MemOrd(1:2) .EQ. 'ys' ) .OR. &
3841 (MemOrd(1:2) .EQ. 'ye' ) ) THEN
3842 my_displ = ips-1
3843 my_count = ipe-ips+1
3844 ELSE
3845 my_displ = 0
3846 my_count = 0
3847 ENDIF
3848 #endif
3850 CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr )
3851 CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr )
3853 do j = jds,jde ! bdy_width
3854 do k = kds,kde ! levels
3855 lx = ime-ims+1
3856 lx2 = ide-ids+1
3857 idx = lx*((k-1)+(j-1)*(kme-kms+1))
3858 idx2 = lx2*((k-1)+(j-1)*(kde-kds+1))
3860 IF ( FieldType .EQ. WRF_DOUBLE ) THEN
3861 CALL wrf_scatterv_double ( &
3862 globbuf, 1+idx2 , & ! sendbuf
3863 counts , & ! sendcounts
3864 Field, ips-ims+1+idx , &
3865 my_count , & ! recvcount
3866 displs , & ! displs
3867 collective_root , & ! root
3868 communicator , & ! communicator
3869 ierr )
3870 ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
3871 CALL wrf_scatterv_real ( &
3872 globbuf, 1+idx2 , & ! sendbuf
3873 counts , & ! sendcounts
3874 Field, ips-ims+1+idx , &
3875 my_count , & ! recvcount
3876 displs , & ! displs
3877 collective_root , & ! root
3878 communicator , & ! communicator
3879 ierr )
3880 ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
3881 CALL wrf_scatterv_integer ( &
3882 globbuf, 1+idx2 , & ! sendbuf
3883 counts , & ! sendcounts
3884 Field, ips-ims+1+idx , &
3885 my_count , & ! recvcount
3886 displs , & ! displs
3887 collective_root , & ! root
3888 communicator , & ! communicator
3889 ierr )
3890 ENDIF
3891 enddo
3892 enddo
3893 ENDIF
3894 ENDIF
3896 ELSE ! not a boundary
3898 IF ( FieldType .EQ. WRF_DOUBLE ) THEN
3900 SELECT CASE (MemOrd)
3901 CASE ( 'xzy','xyz','yxz','zxy' )
3902 CALL wrf_global_to_patch_double ( globbuf, Field , DomainDesc, Stagger, MemOrd , &
3903 DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
3904 MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
3905 PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
3906 CASE ( 'xy','yx' )
3907 CALL wrf_global_to_patch_double ( globbuf, Field , DomainDesc, Stagger, MemOrd , &
3908 DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), 1 , 1 , &
3909 MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), 1 , 1 , &
3910 PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , 1 , 1 )
3911 END SELECT
3913 ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
3915 SELECT CASE (MemOrd)
3916 CASE ( 'xzy','xyz','yxz','zxy' )
3917 CALL wrf_global_to_patch_real ( globbuf, Field , DomainDesc, Stagger, MemOrd , &
3918 DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
3919 MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
3920 PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
3921 CASE ( 'xy','yx' )
3922 CALL wrf_global_to_patch_real ( globbuf, Field , DomainDesc, Stagger, MemOrd , &
3923 DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), 1 , 1 , &
3924 MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), 1 , 1 , &
3925 PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , 1 , 1 )
3926 END SELECT
3928 ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
3930 SELECT CASE (MemOrd)
3931 CASE ( 'xzy','xyz','yxz','zxy' )
3932 CALL wrf_global_to_patch_integer ( globbuf, Field , DomainDesc, Stagger, MemOrd , &
3933 DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
3934 MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
3935 PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
3936 CASE ( 'xy','yx' )
3937 CALL wrf_global_to_patch_integer ( globbuf, Field , DomainDesc, Stagger, MemOrd , &
3938 DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), 1 , 1 , &
3939 MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), 1 , 1 , &
3940 PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , 1 , 1 )
3941 END SELECT
3943 ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
3945 SELECT CASE (MemOrd)
3946 CASE ( 'xzy','xyz','yxz','zxy' )
3947 CALL wrf_global_to_patch_logical ( globbuf, Field , DomainDesc, Stagger, MemOrd , &
3948 DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
3949 MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
3950 PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
3951 CASE ( 'xy','yx' )
3952 CALL wrf_global_to_patch_logical ( globbuf, Field , DomainDesc, Stagger, MemOrd , &
3953 DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), 1 , 1 , &
3954 MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), 1 , 1 , &
3955 PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , 1 , 1 )
3956 END SELECT
3958 ENDIF
3959 ENDIF
3960 #endif
3962 ELSE ! not a distributed field
3964 IF ( wrf_dm_on_monitor()) THEN
3965 CALL fcn ( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3966 DomainDesc , MemoryOrder , Stagger , DimNames , &
3967 DomainStart , DomainEnd , &
3968 MemoryStart , MemoryEnd , &
3969 PatchStart , PatchEnd , &
3970 Status )
3971 ENDIF
3972 CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
3973 memsize = (MemoryEnd(1)-MemoryStart(1)+1)*(MemoryEnd(2)-MemoryStart(2)+1)*(MemoryEnd(3)-MemoryStart(3)+1)
3974 IF ( FieldType .EQ. WRF_DOUBLE ) THEN
3975 CALL wrf_dm_bcast_bytes( Field , DWORDSIZE*memsize )
3976 ELSE IF ( FieldType .EQ. WRF_FLOAT) THEN
3977 CALL wrf_dm_bcast_bytes( Field , RWORDSIZE*memsize )
3978 ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
3979 CALL wrf_dm_bcast_bytes( Field , IWORDSIZE*memsize )
3980 ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
3981 CALL wrf_dm_bcast_bytes( Field , LWORDSIZE*memsize )
3982 ENDIF
3984 ENDIF
3986 DEALLOCATE(displs)
3987 DEALLOCATE(counts)
3988 RETURN
3989 END SUBROUTINE call_pkg_and_dist_generic
3991 !!!!!! Miscellaneous routines
3993 ! stole these routines from io_netcdf external package; changed names to avoid collisions
3994 SUBROUTINE dim_from_memorder(MemoryOrder,NDim)
3995 !<DESCRIPTION>
3996 !<PRE>
3997 ! Decodes array ranks from memory order.
3998 !</PRE>
3999 !</DESCRIPTION>
4000 CHARACTER*(*) ,INTENT(IN) :: MemoryOrder
4001 INTEGER ,INTENT(OUT) :: NDim
4002 !Local
4003 CHARACTER*3 :: MemOrd
4004 !
4005 CALL Lower_Case(MemoryOrder,MemOrd)
4006 SELECT CASE (MemOrd)
4007 CASE ('xyz','xzy','yxz','yzx','zxy','zyx')
4008 NDim = 3
4009 CASE ('xy','yx')
4010 NDim = 2
4011 CASE ('z','c','0')
4012 NDim = 1
4013 CASE DEFAULT
4014 NDim = 0
4015 RETURN
4016 END SELECT
4017 RETURN
4018 END SUBROUTINE dim_from_memorder
4020 SUBROUTINE lower_case(MemoryOrder,MemOrd)
4021 !<DESCRIPTION>
4022 !<PRE>
4023 ! Translates upper-case characters to lower-case.
4024 !</PRE>
4025 !</DESCRIPTION>
4026 CHARACTER*(*) ,INTENT(IN) :: MemoryOrder
4027 CHARACTER*(*) ,INTENT(OUT) :: MemOrd
4028 !Local
4029 CHARACTER*1 :: c
4030 INTEGER ,PARAMETER :: upper_to_lower =IACHAR('a')-IACHAR('A')
4031 INTEGER :: i,n,n1
4032 !
4033 MemOrd = ' '
4034 N = len(MemoryOrder)
4035 N1 = len(MemOrd)
4036 N = MIN(N,N1)
4037 MemOrd(1:N) = MemoryOrder(1:N)
4038 DO i=1,N
4039 c = MemoryOrder(i:i)
4040 if('A'<=c .and. c <='Z') MemOrd(i:i)=achar(iachar(c)+upper_to_lower)
4041 ENDDO
4042 RETURN
4043 END SUBROUTINE Lower_Case
4045 LOGICAL FUNCTION has_char( str, c )
4046 !<DESCRIPTION>
4047 !<PRE>
4048 ! Returns .TRUE. iff string str contains character c. Ignores character case.
4049 !</PRE>
4050 !</DESCRIPTION>
4051 IMPLICIT NONE
4052 CHARACTER*(*) str
4053 CHARACTER c, d
4054 CHARACTER*80 str1, str2, str3
4055 INTEGER i
4057 CALL lower_case( TRIM(str), str1 )
4058 str2 = ""
4059 str2(1:1) = c
4060 CALL lower_case( str2, str3 )
4061 d = str3(1:1)
4062 DO i = 1, LEN(TRIM(str1))
4063 IF ( str1(i:i) .EQ. d ) THEN
4064 has_char = .TRUE.
4065 RETURN
4066 ENDIF
4067 ENDDO
4068 has_char = .FALSE.
4069 RETURN
4070 END FUNCTION has_char