Context Navigation

module_io.F

Last change on this file was 1, checked in by lfita, 10 years ago

-- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 171.4 KB

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

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

Download in other formats:

Original Format