Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

module_io.F @ 1780

Last change on this file since 1780 was 11, checked in by aslmd, 14 years ago
spiga@svn-planeto:ajoute le modele meso-echelle martien
File size: 162.4 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format