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