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