Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

module_io.F @ 3567

Last change on this file since 3567 was 2759, checked in by aslmd, 2 years ago
adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 176.0 KB

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

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

Download in other formats:

Original Format