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