Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

module_io.F @ 3094

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

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

Download in other formats:

Original Format