Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

module_io_quilt.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: 140.7 KB

Rev	Line
[2759]	1	!WRF:DRIVER_LAYER:IO
	2	!
	3	#define DEBUG_LVL 50
	4	!#define mpi_x_comm_size(i,j,k) Mpi_Comm_Size ( i,j,k ) ; write(0,*) __LINE__
	5	#define mpi_x_comm_size(i,j,k) Mpi_Comm_Size ( i,j,k )
	6
	7	MODULE module_wrf_quilt
	8	!<DESCRIPTION>
	9	!<PRE>
	10	! This module contains WRF-specific I/O quilt routines called by both
	11	! client (compute) and server (I/O quilt) tasks. I/O quilt servers are
	12	! a run-time optimization that allow I/O operations, executed on the I/O
	13	! quilt server tasks, to be overlapped with useful computation, executed on
	14	! the compute tasks. Since I/O operations are often quite slow compared to
	15	! computation, this performance optimization can increase parallel
	16	! efficiency.
	17	!
	18	! Currently, one group of I/O servers can be specified at run-time. Namelist
	19	! variable "nio_tasks_per_group" is used to specify the number of I/O server
	20	! tasks in this group. In most cases, parallel efficiency is optimized when
	21	! the minimum number of I/O server tasks are used. If memory needed to cache
	22	! I/O operations fits on a single processor, then set nio_tasks_per_group=1.
	23	! If not, increase the number of I/O server tasks until I/O operations fit in
	24	! memory. In the future, multiple groups of I/O server tasks will be
	25	! supported. The number of groups will be specified by namelist variable
	26	! "nio_groups". For now, nio_groups must be set to 1. Currently, I/O servers
	27	! only support overlap of output operations with computation. Also, only I/O
	28	! packages that do no support native parallel I/O may be used with I/O server
	29	! tasks. This excludes PHDF5 and MCEL.
	30	!
	31	! In this module, the I/O quilt server tasks call package-dependent
	32	! WRF-specific I/O interfaces to perform I/O operations requested by the
	33	! client (compute) tasks. All of these calls occur inside subroutine
	34	! quilt().
	35	!
	36	! The client (compute) tasks call package-independent WRF-specific "quilt I/O"
	37	! interfaces that send requests to the I/O quilt servers. All of these calls
	38	! are made from module_io.F.
	39	!
	40	! These routines have the same names and (roughly) the same arguments as those
	41	! specified in the WRF I/O API except that:
	42	! - "Quilt I/O" routines defined in this file and called by routines in
	43	! module_io.F have the "wrf_quilt_" prefix.
	44	! - Package-dependent routines called from routines in this file are defined
	45	! in the external I/O packages and have the "ext_" prefix.
	46	!
	47	! Both client (compute) and server tasks call routine init_module_wrf_quilt()
	48	! which then calls setup_quilt_servers() determine which tasks are compute
	49	! tasks and which are server tasks. Before the end of init_module_wrf_quilt()
	50	! server tasks call routine quilt() and remain there for the rest of the model
	51	! run. Compute tasks return from init_module_wrf_quilt() to perform model
	52	! computations.
	53	!
	54	! See http://www.mmm.ucar.edu/wrf/WG2/software_2.0/IOAPI.doc for the latest
	55	! version of the WRF I/O API. This document includes detailed descriptions
	56	! of subroutines and their arguments that are not duplicated here.
	57	!</PRE>
	58	!</DESCRIPTION>
	59	USE module_internal_header_util
	60	USE module_timing
	61
	62	INTEGER, PARAMETER :: int_num_handles = 99
	63	LOGICAL, DIMENSION(int_num_handles) :: okay_to_write, int_handle_in_use, okay_to_commit
	64	INTEGER, DIMENSION(int_num_handles) :: int_num_bytes_to_write, io_form
	65	REAL, POINTER :: int_local_output_buffer(:)
	66	INTEGER :: int_local_output_cursor
	67	LOGICAL :: quilting_enabled
	68	LOGICAL :: disable_quilt = .FALSE.
	69	INTEGER :: prev_server_for_handle = -1
	70	INTEGER :: server_for_handle(int_num_handles)
	71	INTEGER :: reduced(2), reduced_dummy(2)
	72	LOGICAL, EXTERNAL :: wrf_dm_on_monitor
	73
	74	INTEGER nio_groups
	75	#ifdef DM_PARALLEL
	76	INTEGER mpi_comm_local
	77	INTEGER mpi_comm_io_groups(100)
	78	INTEGER nio_tasks_in_group
	79	INTEGER nio_tasks_per_group
	80	INTEGER ncompute_tasks
	81	INTEGER ntasks
	82	INTEGER mytask
	83
	84	INTEGER, PARAMETER :: onebyte = 1
	85	INTEGER comm_io_servers, iserver, hdrbufsize, obufsize
	86	INTEGER, DIMENSION(4096) :: hdrbuf
	87	INTEGER, DIMENSION(int_num_handles) :: handle
	88	#endif
	89
	90	CONTAINS
	91
	92	#if defined(DM_PARALLEL) && !defined( STUBMPI )
	93	INTEGER FUNCTION get_server_id ( dhandle )
	94	!<DESCRIPTION>
	95	! Logic in the client side to know which io server
	96	! group to send to. If the unit corresponds to a file that's
	97	! already been opened, then we have no choice but to send the
	98	! data to that group again, regardless of whether there are
	99	! other server-groups. If it's a new file, we can chose a new
	100	! server group. I.e. opening a file locks it onto a server
	101	! group. Closing the file unlocks it.
	102	!</DESCRIPTION>
	103	IMPLICIT NONE
	104	INTEGER, INTENT(IN) :: dhandle
	105	IF ( dhandle .GE. 1 .AND. dhandle .LE. int_num_handles ) THEN
	106	IF ( server_for_handle ( dhandle ) .GE. 1 ) THEN
	107	get_server_id = server_for_handle ( dhandle )
	108	ELSE
	109	prev_server_for_handle = mod ( prev_server_for_handle + 1 , nio_groups )
	110	server_for_handle( dhandle ) = prev_server_for_handle+1
	111	get_server_id = prev_server_for_handle+1
	112	ENDIF
	113	ELSE
	114	CALL wrf_message('module_io_quilt: get_server_id bad dhandle' )
	115	ENDIF
	116	END FUNCTION get_server_id
	117	#endif
	118
	119	SUBROUTINE set_server_id ( dhandle, value )
	120	IMPLICIT NONE
	121	INTEGER, INTENT(IN) :: dhandle, value
	122	IF ( dhandle .GE. 1 .AND. dhandle .LE. int_num_handles ) THEN
	123	server_for_handle(dhandle) = value
	124	ELSE
	125	CALL wrf_message('module_io_quilt: set_server_id bad dhandle' )
	126	ENDIF
	127	END SUBROUTINE set_server_id
	128
	129	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	130	SUBROUTINE int_get_fresh_handle( retval )
	131	!<DESCRIPTION>
	132	! Find an unused "client file handle" and return it in retval.
	133	! The "client file handle" is used to remember how a file was opened
	134	! so clients do not need to ask the I/O quilt servers for this information.
	135	! It is also used as a file identifier in communications with the I/O
	136	! server task.
	137	!
	138	! Note that client tasks know nothing about package-specific handles.
	139	! Only the I/O quilt servers know about them.
	140	!</DESCRIPTION>
	141	INTEGER i, retval
	142	retval = -1
	143	DO i = 1, int_num_handles
	144	IF ( .NOT. int_handle_in_use(i) ) THEN
	145	retval = i
	146	GOTO 33
	147	ENDIF
	148	ENDDO
	149	33 CONTINUE
	150	IF ( retval < 0 ) THEN
	151	CALL wrf_error_fatal("frame/module_io_quilt.F: int_get_fresh_handle() can not")
	152	ENDIF
	153	int_handle_in_use(i) = .TRUE.
	154	NULLIFY ( int_local_output_buffer )
	155	END SUBROUTINE int_get_fresh_handle
	156
	157	SUBROUTINE setup_quilt_servers ( nio_tasks_per_group, &
	158	mytask, &
	159	ntasks, &
	160	n_groups_arg, &
	161	nio, &
	162	mpi_comm_wrld, &
	163	mpi_comm_local, &
	164	mpi_comm_io_groups)
	165	!<DESCRIPTION>
	166	! Both client (compute) and server tasks call this routine to
	167	! determine which tasks are compute tasks and which are I/O server tasks.
	168	!
	169	! Module variables MPI_COMM_LOCAL and MPI_COMM_IO_GROUPS(:) are set up to
	170	! contain MPI communicators as follows:
	171	!
	172	! MPI_COMM_LOCAL is the Communicator for the local groups of tasks. For the
	173	! compute tasks it is the group of compute tasks; for a server group it the
	174	! communicator of tasks in the server group.
	175	!
	176	! Elements of MPI_COMM_IO_GROUPS are communicators that each contain one or
	177	! more compute tasks and a single I/O server assigned to those compute tasks.
	178	! The I/O server tasks is always the last task in these communicators.
	179	! On a compute task, which has a single associate in each of the server
	180	! groups, MPI_COMM_IO_GROUPS is treated as an array; each element corresponds
	181	! to a different server group.
	182	! On a server task only the first element of MPI_COMM_IO_GROUPS is used
	183	! because each server task is part of only one io_group.
	184	!
	185	! I/O server tasks in each I/O server group are divided among compute tasks as
	186	! evenly as possible.
	187	!
	188	! When multiple I/O server groups are used, each must have the same number of
	189	! tasks. When the total number of extra I/O tasks does not divide evenly by
	190	! the number of io server groups requested, the remainder tasks are not used
	191	! (wasted).
	192	!
	193	! For example, communicator membership for 18 tasks with nio_groups=2 and
	194	! nio_tasks_per_group=3 is shown below:
	195	!
	196	!<PRE>
	197	! Membership for MPI_COMM_LOCAL communicators:
	198	! COMPUTE TASKS: 0 1 2 3 4 5 6 7 8 9 10 11
	199	! 1ST I/O SERVER GROUP: 12 13 14
	200	! 2ND I/O SERVER GROUP: 15 16 17
	201	!
	202	! Membership for MPI_COMM_IO_GROUPS(1):
	203	! COMPUTE TASKS 0, 3, 6, 9: 0 3 6 9 12
	204	! COMPUTE TASKS 1, 4, 7,10: 1 4 7 10 13
	205	! COMPUTE TASKS 2, 5, 8,11: 2 5 8 11 14
	206	! I/O SERVER TASK 12: 0 3 6 9 12
	207	! I/O SERVER TASK 13: 1 4 7 10 13
	208	! I/O SERVER TASK 14: 2 5 8 11 14
	209	! I/O SERVER TASK 15: 0 3 6 9 15
	210	! I/O SERVER TASK 16: 1 4 7 10 16
	211	! I/O SERVER TASK 17: 2 5 8 11 17
	212	!
	213	! Membership for MPI_COMM_IO_GROUPS(2):
	214	! COMPUTE TASKS 0, 3, 6, 9: 0 3 6 9 15
	215	! COMPUTE TASKS 1, 4, 7,10: 1 4 7 10 16
	216	! COMPUTE TASKS 2, 5, 8,11: 2 5 8 11 17
	217	! I/O SERVER TASK 12: not used
	218	! I/O SERVER TASK 13: not used
	219	! I/O SERVER TASK 14: not used
	220	! I/O SERVER TASK 15: not used
	221	! I/O SERVER TASK 16: not used
	222	! I/O SERVER TASK 17: not used
	223	!</PRE>
	224	!</DESCRIPTION>
	225	USE module_configure
	226	IMPLICIT NONE
	227	INCLUDE 'mpif.h'
	228	INTEGER, INTENT(IN) :: nio_tasks_per_group, mytask, ntasks, &
	229	n_groups_arg, mpi_comm_wrld
	230	INTEGER, INTENT(OUT) :: mpi_comm_local, nio
	231	INTEGER, DIMENSION(100), INTENT(OUT) :: mpi_comm_io_groups
	232	! Local
	233	INTEGER :: i, j, ii, comdup, ierr, niotasks, n_groups, iisize
	234	INTEGER, DIMENSION(ntasks) :: icolor
	235	CHARACTER*128 mess
	236
	237	INTEGER io_form_setting
	238
	239	!check the namelist and make sure there are no output forms specified
	240	!that cannot be quilted
	241	CALL nl_get_io_form_history(1, io_form_setting) ; call sokay( 'history', io_form_setting )
	242	CALL nl_get_io_form_restart(1, io_form_setting) ; call sokay( 'restart', io_form_setting )
	243	CALL nl_get_io_form_auxhist1(1, io_form_setting) ; call sokay( 'auxhist1', io_form_setting )
	244	CALL nl_get_io_form_auxhist2(1, io_form_setting) ; call sokay( 'auxhist2', io_form_setting )
	245	CALL nl_get_io_form_auxhist3(1, io_form_setting) ; call sokay( 'auxhist3', io_form_setting )
	246	CALL nl_get_io_form_auxhist4(1, io_form_setting) ; call sokay( 'auxhist4', io_form_setting )
	247	CALL nl_get_io_form_auxhist5(1, io_form_setting) ; call sokay( 'auxhist5', io_form_setting )
	248	CALL nl_get_io_form_auxhist6(1, io_form_setting) ; call sokay( 'auxhist6', io_form_setting )
	249	CALL nl_get_io_form_auxhist7(1, io_form_setting) ; call sokay( 'auxhist7', io_form_setting )
	250	CALL nl_get_io_form_auxhist8(1, io_form_setting) ; call sokay( 'auxhist8', io_form_setting )
	251	CALL nl_get_io_form_auxhist9(1, io_form_setting) ; call sokay( 'auxhist9', io_form_setting )
	252	CALL nl_get_io_form_auxhist10(1, io_form_setting) ; call sokay( 'auxhist10', io_form_setting )
	253	CALL nl_get_io_form_auxhist11(1, io_form_setting) ; call sokay( 'auxhist11', io_form_setting )
	254
	255	n_groups = n_groups_arg
	256	IF ( n_groups .LT. 1 ) n_groups = 1
	257
	258	!<DESCRIPTION>
	259	! nio is number of io tasks per group. If there arent enough tasks to satisfy
	260	! the requirement that there be at least as many compute tasks as io tasks in
	261	! each group, then just print a warning and dump out of quilting
	262	!</DESCRIPTION>
	263
	264	nio = nio_tasks_per_group
	265	ncompute_tasks = ntasks - (nio * n_groups)
	266	IF ( ncompute_tasks .LT. nio ) THEN
	267	WRITE(mess,'("Not enough tasks to have ",I3," groups of ",I3," I/O tasks. No quilting.")')n_groups,nio
	268	nio = 0
	269	ncompute_tasks = ntasks
	270	ELSE
	271	WRITE(mess,'("Quilting with ",I3," groups of ",I3," I/O tasks.")')n_groups,nio
	272	ENDIF
	273	CALL wrf_message(mess)
	274
	275	IF ( nio .LT. 0 ) THEN
	276	nio = 0
	277	ENDIF
	278	IF ( nio .EQ. 0 ) THEN
	279	quilting_enabled = .FALSE.
	280	mpi_comm_local = mpi_comm_wrld
	281	mpi_comm_io_groups = mpi_comm_wrld
	282	RETURN
	283	ENDIF
	284	quilting_enabled = .TRUE.
	285
	286	! First construct the local communicators
	287	! prepare to split the communicator by designating compute-only tasks
	288	DO i = 1, ncompute_tasks
	289	icolor(i) = 0
	290	ENDDO
	291	ii = 1
	292	! and designating the groups of i/o tasks
	293	DO i = ncompute_tasks+1, ntasks, nio
	294	DO j = i, i+nio-1
	295	icolor(j) = ii
	296	ENDDO
	297	ii = ii+1
	298	ENDDO
	299	CALL MPI_Comm_dup(mpi_comm_wrld,comdup,ierr)
	300	CALL MPI_Comm_split(comdup,icolor(mytask+1),mytask,mpi_comm_local,ierr)
	301
	302	! Now construct the communicators for the io_groups; round-robining the compute tasks
	303	DO i = 1, ncompute_tasks
	304	icolor(i) = mod(i-1,nio)
	305	ENDDO
	306	! ... and add the io servers as the last task in each group
	307	DO j = 1, n_groups
	308	! TBH: each I/O group will contain only one I/O server
	309	DO i = ncompute_tasks+1,ntasks
	310	icolor(i) = MPI_UNDEFINED
	311	ENDDO
	312	ii = 0
	313	DO i = ncompute_tasks+(j-1)nio+1,ncompute_tasks+jnio
	314	icolor(i) = ii
	315	ii = ii+1
	316	ENDDO
	317	CALL MPI_Comm_dup(mpi_comm_wrld,comdup,ierr)
	318	CALL MPI_Comm_split(comdup,icolor(mytask+1),mytask,mpi_comm_io_groups(j),ierr)
	319	!CALL MPI_Comm_Size( mpi_comm_io_groups(j) , iisize, ierr )
	320	ENDDO
	321	! If I am an I/O server, figure out which group I'm in and make that group's
	322	! communicator the first element in the mpi_comm_io_groups array (I will ignore
	323	! all of the other elements).
	324	IF ( mytask+1 .GT. ncompute_tasks ) THEN
	325	niotasks = ntasks - ncompute_tasks
	326	i = mytask - ncompute_tasks
	327	j = i / nio + 1
	328	mpi_comm_io_groups(1) = mpi_comm_io_groups(j)
	329	ENDIF
	330
	331	END SUBROUTINE setup_quilt_servers
	332
	333	SUBROUTINE sokay ( stream, io_form )
	334	USE module_state_description
	335	CHARACTER() stream
	336	CHARACTER*256 mess
	337	INTEGER io_form
	338
	339	SELECT CASE (io_form)
	340	#ifdef NETCDF
	341	CASE ( IO_NETCDF )
	342	RETURN
	343	#endif
	344	#ifdef INTIO
	345	CASE ( IO_INTIO )
	346	RETURN
	347	#endif
	348	#ifdef YYY
	349	CASE ( IO_YYY )
	350	RETURN
	351	#endif
	352	#ifdef GRIB1
	353	CASE ( IO_GRIB1 )
	354	RETURN
	355	#endif
	356	#ifdef GRIB2
	357	CASE ( IO_GRIB2 )
	358	RETURN
	359	#endif
	360	CASE (0)
	361	RETURN
	362	CASE DEFAULT
	363	WRITE(mess,*)' An output format has been specified that is incompatible with quilting: io_form: ',io_form,' ',TRIM(stream)
	364	CALL wrf_error_fatal(mess)
	365	END SELECT
	366	END SUBROUTINE sokay
	367
	368	SUBROUTINE quilt
	369	!<DESCRIPTION>
	370	! I/O server tasks call this routine and remain in it for the rest of the
	371	! model run. I/O servers receive I/O requests from compute tasks and
	372	! perform requested I/O operations by calling package-dependent WRF-specific
	373	! I/O interfaces. Requests are sent in the form of "data headers". Each
	374	! request has a unique "header" message associated with it. For requests that
	375	! contain large amounts of data, the data is appended to the header. See
	376	! file module_internal_header_util.F for detailed descriptions of all
	377	! headers.
	378	!
	379	! We wish to be able to link to different packages depending on whether
	380	! the I/O is restart, initial, history, or boundary.
	381	!</DESCRIPTION>
	382	USE module_state_description
	383	USE module_quilt_outbuf_ops
	384	IMPLICIT NONE
	385	INCLUDE 'mpif.h'
	386	#include "intio_tags.h"
	387	#include "wrf_io_flags.h"
	388	INTEGER itag, ninbuf, ntasks_io_group, ntasks_local_group, mytask_local, ierr
	389	INTEGER istat
	390	INTEGER mytask_io_group
	391	INTEGER :: nout_set = 0
	392	INTEGER :: obufsize, bigbufsize, chunksize, sz
	393	REAL, DIMENSION(1) :: dummy
	394	INTEGER, ALLOCATABLE, DIMENSION(:) :: obuf, bigbuf
	395	REAL, ALLOCATABLE, DIMENSION(:) :: RDATA
	396	INTEGER, ALLOCATABLE, DIMENSION(:) :: IDATA
	397	CHARACTER (LEN=512) :: CDATA
	398	CHARACTER (LEN=80) :: fname
	399	INTEGER icurs, hdrbufsize, itypesize, ftypesize, rtypesize, Status, fstat, io_form_arg
	400	INTEGER :: DataHandle, FieldType, Comm, IOComm, DomainDesc, code, Count
	401	INTEGER, DIMENSION(3) :: DomainStart , DomainEnd , MemoryStart , MemoryEnd , PatchStart , PatchEnd
	402	INTEGER :: dummybuf(1)
	403	INTEGER :: num_noops, num_commit_messages, num_field_training_msgs, hdr_tag
	404	CHARACTER (len=256) :: DateStr , Element, VarName, MemoryOrder , Stagger , DimNames(3), FileName, SysDepInfo, mess
	405	INTEGER, EXTERNAL :: use_package
	406	LOGICAL :: stored_write_record, retval
	407	INTEGER iii, jjj, vid, CC, DD
	408
	409	logical okay_to_w
	410	character*120 sysline
	411
	412	!
	413
	414	! Call ext_pkg_ioinit() routines to initialize I/O packages.
	415	SysDepInfo = " "
	416	#ifdef NETCDF
	417	CALL ext_ncd_ioinit( SysDepInfo, ierr)
	418	#endif
	419	#ifdef INTIO
	420	CALL ext_int_ioinit( SysDepInfo, ierr )
	421	#endif
	422	#ifdef XXX
	423	CALL ext_xxx_ioinit( SysDepInfo, ierr)
	424	#endif
	425	#ifdef YYY
	426	CALL ext_yyy_ioinit( SysDepInfo, ierr)
	427	#endif
	428	#ifdef ZZZ
	429	CALL ext_zzz_ioinit( SysDepInfo, ierr)
	430	#endif
	431	#ifdef GRIB1
	432	CALL ext_gr1_ioinit( SysDepInfo, ierr)
	433	#endif
	434	#ifdef GRIB2
	435	CALL ext_gr2_ioinit( SysDepInfo, ierr)
	436	#endif
	437
	438	okay_to_commit = .false.
	439	stored_write_record = .false.
	440	ninbuf = 0
	441	! get info. about the I/O server group that this I/O server task
	442	! belongs to
	443	! Last task in this I/O server group is the I/O server "root"
	444	! The I/O server "root" actually writes data to disk
	445	! TBH: WARNING: This is also implicit in the call to collect_on_comm().
	446	CALL mpi_x_comm_size( mpi_comm_io_groups(1), ntasks_io_group, ierr )
	447	CALL MPI_COMM_RANK( mpi_comm_io_groups(1), mytask_io_group, ierr )
	448	CALL mpi_x_comm_size( mpi_comm_local, ntasks_local_group, ierr )
	449	CALL MPI_COMM_RANK( mpi_comm_local, mytask_local, ierr )
	450
	451	CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
	452	IF ( itypesize <= 0 ) THEN
	453	CALL wrf_error_fatal("external/RSL/module_dm.F: quilt: type size <= 0 invalid")
	454	ENDIF
	455
	456	! Work out whether this i/o server processor has one fewer associated compute proc than
	457	! the most any processor has. Can happen when number of i/o tasks does not evenly divide
	458	! the number of compute tasks. This is needed to keep the i/o tasks sychronized on the
	459	! same message when they start commmunicating to stitch together an output.
	460	!
	461	! Compute processes associated with this task:
	462	CC = ntasks_io_group - 1
	463	! Number of compute tasks per I/O task (less remainder)
	464	DD = ncompute_tasks / ntasks_local_group
	465	!
	466	! If CC-DD is 1 on servrs with the maximum number of compute clients,
	467	! 0 on servrs with one less than maximum
	468
	469
	470	! infinite loop until shutdown message received
	471	! This is the main request-handling loop. I/O quilt servers stay in this loop
	472	! until the model run ends.
	473	okay_to_w = .false.
	474	DO WHILE (.TRUE.) ! {
	475
	476	!<DESCRIPTION>
	477	! Each I/O server receives requests from its compute tasks. Each request
	478	! is contained in a data header (see module_internal_header_util.F for
	479	! detailed descriptions of data headers).
	480	! Each request is sent in two phases. First, sizes of all messages that
	481	! will be sent from the compute tasks to this I/O server are summed on the
	482	! I/O server via MPI_reduce(). The I/O server then allocates buffer "obuf"
	483	! and receives concatenated messages from the compute tasks in it via the
	484	! call to collect_on_comm(). Note that "sizes" are generally expressed in
	485	! bytes in this code so conversion to "count" (number of Fortran words) is
	486	! required for Fortran indexing and MPI calls.
	487	!</DESCRIPTION>
	488	! wait for info from compute tasks in the I/O group that we're ready to rock
	489	! obufsize will contain number of bytes
	490	!JMTIMINGCALL start_timing
	491	! first element of reduced is obufsize, second is DataHandle
	492	! if needed (currently needed only for ioclose).
	493	reduced_dummy = 0
	494	CALL MPI_Reduce( reduced_dummy, reduced, 2, MPI_INTEGER, &
	495	MPI_SUM, mytask_io_group, &
	496	mpi_comm_io_groups(1), ierr )
	497	obufsize = reduced(1)
	498	!JMTIMING CALL end_timing("MPI_Reduce at top of forever loop")
	499	!JMDEBUGwrite(0,*)'obufsize = ',obufsize
	500	! Negative obufsize will trigger I/O server exit.
	501	IF ( obufsize .LT. 0 ) THEN
	502	IF ( obufsize .EQ. -100 ) THEN ! magic number
	503	#ifdef NETCDF
	504	CALL ext_ncd_ioexit( Status )
	505	#endif
	506	#ifdef INTIO
	507	CALL ext_int_ioexit( Status )
	508	#endif
	509	#ifdef XXX
	510	CALL ext_xxx_ioexit( Status )
	511	#endif
	512	#ifdef YYY
	513	CALL ext_yyy_ioexit( Status )
	514	#endif
	515	#ifdef ZZZ
	516	CALL ext_zzz_ioexit( Status )
	517	#endif
	518	#ifdef GRIB1
	519	CALL ext_gr1_ioexit( Status )
	520	#endif
	521	#ifdef GRIB2
	522	CALL ext_gr2_ioexit( Status )
	523	#endif
	524	CALL wrf_message ( 'I/O QUILT SERVERS DONE' )
	525	CALL mpi_finalize(ierr)
	526	STOP
	527	ELSE
	528	WRITE(mess,*)'Possible 32-bit overflow on output server. Try larger nio_tasks_per_group in namelist.'
	529	CALL wrf_error_fatal(mess)
	530	ENDIF
	531	ENDIF
	532
	533	!JMTIMING CALL start_timing
	534	! Obufsize of zero signals a close
	535
	536	! Allocate buffer obuf to be big enough for the data the compute tasks
	537	! will send. Note: obuf is size in bytes so we need to pare this
	538	! down, since the buffer is INTEGER.
	539	IF ( obufsize .GT. 0 ) THEN
	540	ALLOCATE( obuf( (obufsize+1)/itypesize ) )
	541
	542	! let's roll; get the data from the compute procs and put in obuf
	543	CALL collect_on_comm_debug(__FILE__,__LINE__, mpi_comm_io_groups(1), &
	544	onebyte, &
	545	dummy, 0, &
	546	obuf, obufsize )
	547	!JMTIMING CALL end_timing( "quilt on server: collecting data from compute procs" )
	548	ELSE
	549	! Necessarily, the compute processes send the ioclose signal,
	550	! if there is one, after the iosync, which means they
	551	! will stall on the ioclose message waiting for the quilt
	552	! processes if we handle the way other messages are collected,
	553	! using collect_on_comm. This avoids this, but we need
	554	! a special signal (obufsize zero) and the DataHandle
	555	! to be closed. That handle is send as the second
	556	! word of the io_close message received by the MPI_Reduce above.
	557	! Then a header representing the ioclose message is constructed
	558	! here and handled below as if it were received from the
	559	! compute processes. The clients (compute processes) must be
	560	! careful to send this correctly (one compule process sends the actual
	561	! handle and everone else sends a zero, so the result sums to
	562	! the value of the handle).
	563	!
	564	ALLOCATE( obuf( 4096 ) )
	565	! DataHandle is provided as second element of reduced
	566	CALL int_gen_handle_header( obuf, obufsize, itypesize, &
	567	reduced(2) , int_ioclose )
	568	ENDIF
	569
	570	!write(0,*)'calling init_store_piece_of_field'
	571	! Now all messages received from the compute clients are stored in
	572	! obuf. Scan through obuf and extract headers and field data and store in
	573	! internal buffers. The scan is done twice, first to determine sizes of
	574	! internal buffers required for storage of headers and fields and second to
	575	! actually store the headers and fields. This bit of code does not do the
	576	! "quilting" (assembly of patches into full domains). For each field, it
	577	! simply concatenates all received patches for the field into a separate
	578	! internal buffer (i.e. one buffer per field). Quilting is done later by
	579	! routine store_patch_in_outbuf().
	580	CALL init_store_piece_of_field
	581	CALL mpi_type_size ( MPI_INTEGER , itypesize , ierr )
	582	!write(0,*)'mpi_type_size returns ', itypesize
	583	! Scan obuf the first time to calculate the size of the buffer required for
	584	! each field. Calls to add_to_bufsize_for_field() accumulate sizes.
	585	vid = 0
	586	icurs = itypesize
	587	num_noops = 0
	588	num_commit_messages = 0
	589	num_field_training_msgs = 0
	590	DO WHILE ( icurs .lt. obufsize ) ! {
	591	hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) )
	592	SELECT CASE ( hdr_tag )
	593	CASE ( int_field )
	594	CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, &
	595	DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, &
	596	DomainDesc , MemoryOrder , Stagger , DimNames , &
	597	DomainStart , DomainEnd , &
	598	MemoryStart , MemoryEnd , &
	599	PatchStart , PatchEnd )
	600	chunksize = (PatchEnd(1)-PatchStart(1)+1)(PatchEnd(2)-PatchStart(2)+1) &
	601	(PatchEnd(3)-PatchStart(3)+1)*ftypesize
	602
	603	IF ( DomainDesc .EQ. 333933 ) THEN ! Training write, only one per group of tasks
	604	IF ( num_field_training_msgs .EQ. 0 ) THEN
	605	call add_to_bufsize_for_field( VarName, hdrbufsize )
	606	!write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
	607	ENDIF
	608	num_field_training_msgs = num_field_training_msgs + 1
	609	ELSE
	610	call add_to_bufsize_for_field( VarName, hdrbufsize )
	611	!write(0,*) 'X-2a', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
	612	ENDIF
	613	icurs = icurs + hdrbufsize
	614
	615	!write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
	616
	617	! If this is a real write (i.e. not a training write), accumulate
	618	! buffersize for this field.
	619	IF ( DomainDesc .NE. 333933 ) THEN ! magic number
	620	!write(0,*) 'X-1a', chunksize, TRIM(VarName)
	621	call add_to_bufsize_for_field( VarName, chunksize )
	622	icurs = icurs + chunksize
	623	ENDIF
	624	CASE ( int_open_for_write_commit ) ! only one per group of tasks
	625	hdrbufsize = obuf(icurs/itypesize)
	626	IF (num_commit_messages.EQ.0) THEN
	627	call add_to_bufsize_for_field( 'COMMIT', hdrbufsize )
	628	ENDIF
	629	num_commit_messages = num_commit_messages + 1
	630	icurs = icurs + hdrbufsize
	631	CASE DEFAULT
	632	hdrbufsize = obuf(icurs/itypesize)
	633
	634	! This logic and the logic in the loop below is used to determine whether
	635	! to send a noop records sent by the compute processes to allow to go
	636	! through. The purpose is to make sure that the communications between this
	637	! server and the other servers in this quilt group stay synchronized in
	638	! the collection loop below, even when the servers are serving different
	639	! numbers of clients. Here are some conditions:
	640	!
	641	! 1. The number of compute clients served will not differ by more than 1
	642	! 2. The servers with +1 number of compute clients begin with task 0
	643	! of mpi_comm_local, the commicator shared by this group of servers
	644	!
	645	! 3. For each collective field or metadata output from the compute tasks,
	646	! there will be one record sent to the associated i/o server task. The
	647	! i/o server task collects these records and stores them contiguously
	648	! in a buffer (obuf) using collect_on_comm above. Thus, obuf on this
	649	! server task will contain one record from each associated compute
	650	! task, in order.
	651	!
	652	! 4. In the case of replicated output from the compute tasks
	653	! (e.g. put_dom_ti records and control records like
	654	! open_for_write_commit type records), compute task 0 is the only
	655	! one that sends the record. The other compute tasks send noop
	656	! records. Thus, obuf on server task zero will contain the output
	657	! record from task 0 followed by noop records from the rest of the
	658	! compute tasks associated with task 0. Obuf on the other server
	659	! tasks will contain nothing but noop records.
	660	!
	661	! 5. The logic below will not allow any noop records from server task 0.
	662	! It allows only one noop record from each of the other server tasks
	663	! in the i/o group. This way, for replicated output, when the records
	664	! are collected on one server task below, using collect_on_comm on
	665	! mpi_comm_local, each task will provide exactly one record for each
	666	! call to collect_on_comm: 1 bona fide output record from server task
	667	! 0 and noops from the rest.
	668
	669	IF ((hdr_tag.EQ.int_noop.AND.mytask_local.NE.0.AND.num_noops.LE.0) &
	670	.OR.hdr_tag.NE.int_noop) THEN
	671	write(VarName,'(I5.5)')vid
	672	!write(0,*) 'X-2', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
	673	call add_to_bufsize_for_field( VarName, hdrbufsize )
	674	vid = vid+1
	675	ENDIF
	676	IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1
	677	icurs = icurs + hdrbufsize
	678	END SELECT
	679	ENDDO ! }
	680	! Store the headers and field data in internal buffers. The first call to
	681	! store_piece_of_field() allocates internal buffers using sizes computed by
	682	! calls to add_to_bufsize_for_field().
	683	vid = 0
	684	icurs = itypesize
	685	num_noops = 0
	686	num_commit_messages = 0
	687	num_field_training_msgs = 0
	688	DO WHILE ( icurs .lt. obufsize ) !{
	689	!write(0,*) 'A icurs ', icurs, ' obufsize ', obufsize
	690	hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) )
	691	SELECT CASE ( hdr_tag )
	692	CASE ( int_field )
	693	CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, &
	694	DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, &
	695	DomainDesc , MemoryOrder , Stagger , DimNames , &
	696	DomainStart , DomainEnd , &
	697	MemoryStart , MemoryEnd , &
	698	PatchStart , PatchEnd )
	699	chunksize = (PatchEnd(1)-PatchStart(1)+1)(PatchEnd(2)-PatchStart(2)+1) &
	700	(PatchEnd(3)-PatchStart(3)+1)*ftypesize
	701
	702	IF ( DomainDesc .EQ. 333933 ) THEN ! Training write, only one per group of tasks
	703	IF ( num_field_training_msgs .EQ. 0 ) THEN
	704	call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize )
	705	!write(0,*) 'A-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
	706	ENDIF
	707	num_field_training_msgs = num_field_training_msgs + 1
	708	ELSE
	709	call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize )
	710	!write(0,*) 'A-2a', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
	711	ENDIF
	712	icurs = icurs + hdrbufsize
	713	! If this is a real write (i.e. not a training write), store
	714	! this piece of this field.
	715	IF ( DomainDesc .NE. 333933 ) THEN ! magic number
	716	!write(0,*) 'A-1a', chunksize, TRIM(VarName)
	717	call store_piece_of_field( obuf(icurs/itypesize), VarName, chunksize )
	718	icurs = icurs + chunksize
	719	ENDIF
	720	CASE ( int_open_for_write_commit ) ! only one per group of tasks
	721	hdrbufsize = obuf(icurs/itypesize)
	722	IF (num_commit_messages.EQ.0) THEN
	723	call store_piece_of_field( obuf(icurs/itypesize), 'COMMIT', hdrbufsize )
	724	ENDIF
	725	num_commit_messages = num_commit_messages + 1
	726	icurs = icurs + hdrbufsize
	727	CASE DEFAULT
	728	hdrbufsize = obuf(icurs/itypesize)
	729	IF ((hdr_tag.EQ.int_noop.AND.mytask_local.NE.0.AND.num_noops.LE.0) &
	730	.OR.hdr_tag.NE.int_noop) THEN
	731	write(VarName,'(I5.5)')vid
	732	!write(0,*) 'A-2b', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
	733	call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize )
	734	vid = vid+1
	735	ENDIF
	736	IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1
	737	icurs = icurs + hdrbufsize
	738	END SELECT
	739	ENDDO !}
	740
	741	! Now, for each field, retrieve headers and patches (data) from the internal
	742	! buffers and collect them all on the I/O quilt server "root" task.
	743	CALL init_retrieve_pieces_of_field
	744	! Retrieve header and all patches for the first field from the internal
	745	! buffers.
	746	CALL retrieve_pieces_of_field ( obuf , VarName, obufsize, sz, retval )
	747	! Sum sizes of all headers and patches (data) for this field from all I/O
	748	! servers in this I/O server group onto the I/O server "root".
	749	CALL MPI_Reduce( sz, bigbufsize, 1, MPI_INTEGER, &
	750	MPI_SUM, ntasks_local_group-1, &
	751	mpi_comm_local, ierr )
	752	!write(0,*)'seed: sz ',sz,' bigbufsize ',bigbufsize,' VarName ', TRIM(VarName),' retval ',retval
	753
	754	! Loop until there are no more fields to retrieve from the internal buffers.
	755	DO WHILE ( retval ) !{
	756	#if 0
	757	#else
	758
	759	! I/O server "root" allocates space to collect headers and fields from all
	760	! other servers in this I/O server group.
	761	IF ( mytask_local .EQ. ntasks_local_group-1 ) THEN
	762	ALLOCATE( bigbuf( (bigbufsize+1)/itypesize ) )
	763	ENDIF
	764
	765	! Collect buffers and fields from all I/O servers in this I/O server group
	766	! onto the I/O server "root"
	767	CALL collect_on_comm_debug2(__FILE__,__LINE__,Trim(VarName), &
	768	get_hdr_tag(obuf),sz,get_hdr_rec_size(obuf), &
	769	mpi_comm_local, &
	770	onebyte, &
	771	obuf, sz, &
	772	bigbuf, bigbufsize )
	773	! The I/O server "root" now handles collected requests from all compute
	774	! tasks served by this I/O server group (i.e. all compute tasks).
	775	IF ( mytask_local .EQ. ntasks_local_group-1 ) THEN
	776	!jjj = 4
	777	!do iii = 1, ntasks_local_group
	778	! write(0,*)'i,j,tag,size ', iii, jjj, get_hdr_tag(bigbuf(jjj/4)),get_hdr_rec_size(bigbuf(jjj/4))
	779	! jjj = jjj + get_hdr_rec_size(bigbuf(jjj/4))
	780	!enddo
	781
	782	icurs = itypesize ! icurs is a byte counter, but buffer is integer
	783
	784	stored_write_record = .false.
	785
	786	! The I/O server "root" loops over the collected requests.
	787	DO WHILE ( icurs .lt. bigbufsize ) !{
	788	CALL mpi_type_size ( MPI_INTEGER , itypesize , ierr )
	789
	790	!write(0,*)'B tag,size ',icurs,get_hdr_tag( bigbuf(icurs/itypesize) ),get_hdr_rec_size( bigbuf(icurs/itypesize) )
	791	! The I/O server "root" gets the request out of the next header and
	792	! handles it by, in most cases, calling the appropriate external I/O package
	793	! interface.
	794	SELECT CASE ( get_hdr_tag( bigbuf(icurs/itypesize) ) )
	795	! The I/O server "root" handles the "noop" (do nothing) request. This is
	796	! actually quite easy. "Noop" requests exist to help avoid race conditions.
	797	! In some cases, only one compute task will everything about a request so
	798	! other compute tasks send "noop" requests.
	799	CASE ( int_noop )
	800	CALL int_get_noop_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize )
	801	icurs = icurs + hdrbufsize
	802
	803	! The I/O server "root" handles the "put_dom_td_real" request.
	804	CASE ( int_dom_td_real )
	805	CALL mpi_type_size( MPI_REAL, ftypesize, ierr )
	806	ALLOCATE( RData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c
	807	CALL int_get_td_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, &
	808	DataHandle, DateStr, Element, RData, Count, code )
	809	icurs = icurs + hdrbufsize
	810
	811	SELECT CASE (use_package(io_form(DataHandle)))
	812	#ifdef NETCDF
	813	CASE ( IO_NETCDF )
	814	CALL ext_ncd_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status )
	815	#endif
	816	#ifdef INTIO
	817	CASE ( IO_INTIO )
	818	CALL ext_int_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status )
	819	#endif
	820	#ifdef YYY
	821	CASE ( IO_YYY )
	822	CALL ext_yyy_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status )
	823	#endif
	824	#ifdef GRIB1
	825	CASE ( IO_GRIB1 )
	826	CALL ext_gr1_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status )
	827	#endif
	828	#ifdef GRIB2
	829	CASE ( IO_GRIB2 )
	830	CALL ext_gr2_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status )
	831	#endif
	832	CASE DEFAULT
	833	Status = 0
	834	END SELECT
	835
	836	DEALLOCATE( RData )
	837	! The I/O server "root" handles the "put_dom_ti_real" request.
	838	CASE ( int_dom_ti_real )
	839	!write(0,*)' int_dom_ti_real '
	840	CALL mpi_type_size( MPI_REAL, ftypesize, ierr )
	841	ALLOCATE( RData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c
	842	CALL int_get_ti_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, &
	843	DataHandle, Element, RData, Count, code )
	844	icurs = icurs + hdrbufsize
	845
	846	SELECT CASE (use_package(io_form(DataHandle)))
	847	#ifdef NETCDF
	848	CASE ( IO_NETCDF )
	849	CALL ext_ncd_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status )
	850	!write(0,*)'ext_ncd_put_dom_ti_real ',handle(DataHandle),TRIM(Element),RData,Status
	851	#endif
	852	#ifdef INTIO
	853	CASE ( IO_INTIO )
	854	CALL ext_int_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status )
	855	#endif
	856	#ifdef YYY
	857	CASE ( IO_YYY )
	858	CALL ext_yyy_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status )
	859	#endif
	860	#ifdef GRIB1
	861	CASE ( IO_GRIB1 )
	862	CALL ext_gr1_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status )
	863	#endif
	864	#ifdef GRIB2
	865	CASE ( IO_GRIB2 )
	866	CALL ext_gr2_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status )
	867	#endif
	868	CASE DEFAULT
	869	Status = 0
	870	END SELECT
	871
	872	DEALLOCATE( RData )
	873
	874	! The I/O server "root" handles the "put_dom_td_integer" request.
	875	CASE ( int_dom_td_integer )
	876	!write(0,*)' int_dom_td_integer '
	877	CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr )
	878	ALLOCATE( IData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c
	879	CALL int_get_td_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, &
	880	DataHandle, DateStr, Element, IData, Count, code )
	881	icurs = icurs + hdrbufsize
	882
	883	SELECT CASE (use_package(io_form(DataHandle)))
	884	#ifdef NETCDF
	885	CASE ( IO_NETCDF )
	886	CALL ext_ncd_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status )
	887	#endif
	888	#ifdef INTIO
	889	CASE ( IO_INTIO )
	890	CALL ext_int_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status )
	891	#endif
	892	#ifdef YYY
	893	CASE ( IO_YYY )
	894	CALL ext_yyy_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status )
	895	#endif
	896	#ifdef GRIB1
	897	CASE ( IO_GRIB1 )
	898	CALL ext_gr1_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status )
	899	#endif
	900	#ifdef GRIB2
	901	CASE ( IO_GRIB2 )
	902	CALL ext_gr2_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status )
	903	#endif
	904	CASE DEFAULT
	905	Status = 0
	906	END SELECT
	907
	908	DEALLOCATE( IData )
	909
	910	! The I/O server "root" handles the "put_dom_ti_integer" request.
	911	CASE ( int_dom_ti_integer )
	912	!write(0,*)' int_dom_ti_integer '
	913
	914	CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr )
	915	ALLOCATE( IData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c
	916	CALL int_get_ti_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, &
	917	DataHandle, Element, IData, Count, code )
	918	icurs = icurs + hdrbufsize
	919	SELECT CASE (use_package(io_form(DataHandle)))
	920	#ifdef NETCDF
	921	CASE ( IO_NETCDF )
	922	CALL ext_ncd_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status )
	923	!write(0,*)'ext_ncd_put_dom_ti_integer ',handle(DataHandle),TRIM(Element),IData,Status
	924	#endif
	925	#ifdef INTIO
	926	CASE ( IO_INTIO )
	927	CALL ext_int_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status )
	928	#endif
	929	#ifdef YYY
	930	CASE ( IO_YYY )
	931	CALL ext_yyy_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status )
	932	#endif
	933	#ifdef GRIB1
	934	CASE ( IO_GRIB1 )
	935	CALL ext_gr1_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status )
	936	#endif
	937	#ifdef GRIB2
	938	CASE ( IO_GRIB2 )
	939	CALL ext_gr2_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status )
	940	#endif
	941
	942	CASE DEFAULT
	943	Status = 0
	944	END SELECT
	945
	946	DEALLOCATE( IData)
	947
	948	! The I/O server "root" handles the "set_time" request.
	949	CASE ( int_set_time )
	950	!write(0,*)' int_set_time '
	951	CALL int_get_ti_header_char( bigbuf(icurs/itypesize), hdrbufsize, itypesize, &
	952	DataHandle, Element, VarName, CData, code )
	953	SELECT CASE (use_package(io_form(DataHandle)))
	954	#ifdef INTIO
	955	CASE ( IO_INTIO )
	956	CALL ext_int_set_time ( handle(DataHandle), TRIM(CData), Status)
	957	#endif
	958	CASE DEFAULT
	959	Status = 0
	960	END SELECT
	961
	962	icurs = icurs + hdrbufsize
	963
	964	! The I/O server "root" handles the "put_dom_ti_char" request.
	965	CASE ( int_dom_ti_char )
	966	!write(0,*)' before int_get_ti_header_char '
	967	CALL int_get_ti_header_char( bigbuf(icurs/itypesize), hdrbufsize, itypesize, &
	968	DataHandle, Element, VarName, CData, code )
	969	!write(0,*)' after int_get_ti_header_char ',VarName
	970
	971	SELECT CASE (use_package(io_form(DataHandle)))
	972	#ifdef NETCDF
	973	CASE ( IO_NETCDF )
	974	CALL ext_ncd_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status)
	975	#endif
	976	#ifdef INTIO
	977	CASE ( IO_INTIO )
	978	CALL ext_int_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status)
	979	#endif
	980	#ifdef YYY
	981	CASE ( IO_YYY )
	982	CALL ext_yyy_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status)
	983	#endif
	984	#ifdef GRIB1
	985	CASE ( IO_GRIB1 )
	986	CALL ext_gr1_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status)
	987	#endif
	988	#ifdef GRIB2
	989	CASE ( IO_GRIB2 )
	990	CALL ext_gr2_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status)
	991	#endif
	992	CASE DEFAULT
	993	Status = 0
	994	END SELECT
	995
	996	icurs = icurs + hdrbufsize
	997
	998	! The I/O server "root" handles the "put_var_ti_char" request.
	999	CASE ( int_var_ti_char )
	1000	!write(0,*)' int_var_ti_char '
	1001	CALL int_get_ti_header_char( bigbuf(icurs/itypesize), hdrbufsize, itypesize, &
	1002	DataHandle, Element, VarName, CData, code )
	1003
	1004	SELECT CASE (use_package(io_form(DataHandle)))
	1005	#ifdef NETCDF
	1006	CASE ( IO_NETCDF )
	1007	CALL ext_ncd_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status)
	1008	#endif
	1009	#ifdef INTIO
	1010	CASE ( IO_INTIO )
	1011	CALL ext_int_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status)
	1012	#endif
	1013	#ifdef YYY
	1014	CASE ( IO_YYY )
	1015	CALL ext_yyy_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status)
	1016	#endif
	1017	#ifdef GRIB1
	1018	CASE ( IO_GRIB1 )
	1019	CALL ext_gr1_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status)
	1020	#endif
	1021	#ifdef GRIB2
	1022	CASE ( IO_GRIB2 )
	1023	CALL ext_gr2_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status)
	1024	#endif
	1025	CASE DEFAULT
	1026	Status = 0
	1027	END SELECT
	1028
	1029	icurs = icurs + hdrbufsize
	1030
	1031	CASE ( int_ioexit )
	1032	! ioexit is now handled by sending negative message length to server
	1033	CALL wrf_error_fatal( &
	1034	"quilt: should have handled int_ioexit already")
	1035	! The I/O server "root" handles the "ioclose" request.
	1036	CASE ( int_ioclose )
	1037	CALL int_get_handle_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, &
	1038	DataHandle , code )
	1039	icurs = icurs + hdrbufsize
	1040
	1041	IF ( DataHandle .GE. 1 ) THEN
	1042	!JMDEBUGwrite(0,*)'closing DataHandle ',DataHandle,' io_form ',io_form(DataHandle)
	1043
	1044	SELECT CASE (use_package(io_form(DataHandle)))
	1045	#ifdef NETCDF
	1046	CASE ( IO_NETCDF )
	1047	CALL ext_ncd_inquire_filename( handle(DataHandle), fname, fstat, Status )
	1048	IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
	1049	CALL ext_ncd_ioclose(handle(DataHandle),Status)
	1050	!write(sysline,*)'msrcp -a -overwrite always -srcdelete ',TRIM(fname),' mss:/MICHALAK'
	1051	!write(0,*)trim(sysline)
	1052	!CALL system(sysline)
	1053	ENDIF
	1054	#endif
	1055	#ifdef INTIO
	1056	CASE ( IO_INTIO )
	1057	CALL ext_int_inquire_filename( handle(DataHandle), fname, fstat, Status )
	1058	IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
	1059	CALL ext_int_ioclose(handle(DataHandle),Status)
	1060	ENDIF
	1061	#endif
	1062	#ifdef YYY
	1063	CASE ( IO_YYY )
	1064	CALL ext_yyy_inquire_filename( handle(DataHandle), fname, fstat, Status )
	1065	IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
	1066	CALL ext_yyy_ioclose(handle(DataHandle),Status)
	1067	ENDIF
	1068	#endif
	1069	#ifdef GRIB1
	1070	CASE ( IO_GRIB1 )
	1071	CALL ext_gr1_inquire_filename( handle(DataHandle), fname, fstat, Status )
	1072	IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
	1073	CALL ext_gr1_ioclose(handle(DataHandle),Status)
	1074	ENDIF
	1075	#endif
	1076	#ifdef GRIB2
	1077	CASE ( IO_GRIB2 )
	1078	CALL ext_gr2_inquire_filename( handle(DataHandle), fname, fstat, Status )
	1079	IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
	1080	CALL ext_gr2_ioclose(handle(DataHandle),Status)
	1081	ENDIF
	1082	#endif
	1083	CASE DEFAULT
	1084	Status = 0
	1085	END SELECT
	1086	ENDIF
	1087
	1088	! The I/O server "root" handles the "open_for_write_begin" request.
	1089	CASE ( int_open_for_write_begin )
	1090
	1091	CALL int_get_ofwb_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, &
	1092	FileName,SysDepInfo,io_form_arg,DataHandle )
	1093
	1094	!write(0,*)' int_open_for_write_begin itypesize ',itypesize,' itypesize ',itypesize
	1095	!write(0,*)' int_open_for_write_begin icurs ', icurs, hdrbufsize
	1096	!JMDEBUGwrite(0,*)' int_open_for_write_begin FileName ',TRIM(FileName) , ' DataHandle ', DataHandle
	1097	!write(0,*)' int_open_for_write_begin SysDepInfo ',TRIM(SysDepInfo)
	1098	icurs = icurs + hdrbufsize
	1099	!write(0,*)' int_open_for_write_begin new icurs,tag,size ', icurs, get_hdr_tag( bigbuf(icurs/itypesize) ),get_hdr_rec_size( bigbuf(icurs/itypesize) )
	1100
	1101	io_form(DataHandle) = io_form_arg
	1102
	1103	SELECT CASE (use_package(io_form(DataHandle)))
	1104	#ifdef NETCDF
	1105	CASE ( IO_NETCDF )
	1106	CALL ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status)
	1107	!write(0,*)'ext_ncd_open_for_write_begin ',Trim(FileName),DataHandle,handle(DataHandle),Status
	1108	#endif
	1109	#ifdef INTIO
	1110	CASE ( IO_INTIO )
	1111	CALL ext_int_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status)
	1112	#endif
	1113	#ifdef YYY
	1114	CASE ( IO_YYY )
	1115	CALL ext_yyy_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status)
	1116	#endif
	1117	#ifdef GRIB1
	1118	CASE ( IO_GRIB1 )
	1119	CALL ext_gr1_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status)
	1120	#endif
	1121	#ifdef GRIB2
	1122	CASE ( IO_GRIB2 )
	1123	CALL ext_gr2_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status)
	1124	#endif
	1125	CASE DEFAULT
	1126	Status = 0
	1127	END SELECT
	1128
	1129	okay_to_write(DataHandle) = .false.
	1130
	1131	! The I/O server "root" handles the "open_for_write_commit" request.
	1132	! In this case, the "okay_to_commit" is simply set to .true. so "write_field"
	1133	! requests will initiate writes to disk. Actual commit will be done after
	1134	! all requests in this batch have been handled.
	1135	CASE ( int_open_for_write_commit )
	1136
	1137	CALL int_get_handle_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, &
	1138	DataHandle , code )
	1139	icurs = icurs + hdrbufsize
	1140	okay_to_commit(DataHandle) = .true.
	1141
	1142	! The I/O server "root" handles the "write_field" (int_field) request.
	1143	! If okay_to_write(DataHandle) is .true. then the patch in the
	1144	! header (bigbuf) is written to a globally-sized internal output buffer via
	1145	! the call to store_patch_in_outbuf(). Note that this is where the actual
	1146	! "quilting" (reassembly of patches onto a full-size domain) is done. If
	1147	! okay_to_write(DataHandle) is .false. then external I/O package interfaces
	1148	! are called to write metadata for I/O formats that support native metadata.
	1149	!
	1150	! NOTE that the I/O server "root" will only see write_field (int_field)
	1151	! requests AFTER an "iosync" request.
	1152	CASE ( int_field )
	1153	CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr )
	1154	CALL int_get_write_field_header ( bigbuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, &
	1155	DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, &
	1156	DomainDesc , MemoryOrder , Stagger , DimNames , &
	1157	DomainStart , DomainEnd , &
	1158	MemoryStart , MemoryEnd , &
	1159	PatchStart , PatchEnd )
	1160	!write(0,*)' int_field ',TRIM(VarName),DataHandle,okay_to_write(DataHandle)
	1161	icurs = icurs + hdrbufsize
	1162
	1163	IF ( okay_to_write(DataHandle) ) THEN
	1164
	1165	! WRITE(0,*)'>>> ',TRIM(DateStr), ' ', TRIM(VarName), ' ', TRIM(MemoryOrder), ' ', &
	1166	! (PatchEnd(1)-PatchStart(1)+1)(PatchEnd(2)-PatchStart(2)+1)(PatchEnd(3)-PatchStart(3)+1)
	1167
	1168	IF ( FieldType .EQ. WRF_FLOAT .OR. FieldType .EQ. WRF_DOUBLE) THEN
	1169	! Note that the WRF_DOUBLE branch of this IF statement must come first since
	1170	! WRF_FLOAT is set equal to WRF_DOUBLE during autopromotion builds.
	1171	IF ( FieldType .EQ. WRF_DOUBLE) THEN
	1172	! this branch has not been tested TBH: 20050406
	1173	CALL mpi_type_size( MPI_DOUBLE_PRECISION, ftypesize, ierr )
	1174	ELSE
	1175	CALL mpi_type_size( MPI_REAL, ftypesize, ierr )
	1176	ENDIF
	1177	stored_write_record = .true.
	1178	CALL store_patch_in_outbuf ( bigbuf(icurs/itypesize), dummybuf, TRIM(DateStr), TRIM(VarName) , &
	1179	FieldType, TRIM(MemoryOrder), TRIM(Stagger), DimNames, &
	1180	DomainStart , DomainEnd , &
	1181	MemoryStart , MemoryEnd , &
	1182	PatchStart , PatchEnd )
	1183
	1184	ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
	1185	CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr )
	1186	stored_write_record = .true.
	1187	CALL store_patch_in_outbuf ( dummybuf, bigbuf(icurs/itypesize), TRIM(DateStr), TRIM(VarName) , &
	1188	FieldType, TRIM(MemoryOrder), TRIM(Stagger), DimNames, &
	1189	DomainStart , DomainEnd , &
	1190	MemoryStart , MemoryEnd , &
	1191	PatchStart , PatchEnd )
	1192	ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
	1193	ftypesize = LWORDSIZE
	1194	ENDIF
	1195	icurs = icurs + (PatchEnd(1)-PatchStart(1)+1)(PatchEnd(2)-PatchStart(2)+1) &
	1196	(PatchEnd(3)-PatchStart(3)+1)*ftypesize
	1197	ELSE
	1198	SELECT CASE (use_package(io_form(DataHandle)))
	1199	#ifdef NETCDF
	1200	CASE ( IO_NETCDF )
	1201	CALL ext_ncd_write_field ( handle(DataHandle) , TRIM(DateStr) , &
	1202	TRIM(VarName) , dummy , FieldType , Comm , IOComm, &
	1203	DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger) , DimNames , &
	1204	DomainStart , DomainEnd , &
	1205	DomainStart , DomainEnd , &
	1206	DomainStart , DomainEnd , &
	1207	Status )
	1208	#endif
	1209	#if 0
	1210	! since this is training and the grib output doesn't need training, disable this branch.
	1211	#ifdef YYY
	1212	CASE ( IO_YYY )
	1213	CALL ext_YYY_write_field ( handle(DataHandle) , TRIM(DateStr) , &
	1214	TRIM(VarName) , dummy , FieldType , Comm , IOComm, &
	1215	DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger) , DimNames , &
	1216	DomainStart , DomainEnd , &
	1217	DomainStart , DomainEnd , &
	1218	DomainStart , DomainEnd , &
	1219	Status )
	1220	#endif
	1221	#endif
	1222	CASE DEFAULT
	1223	Status = 0
	1224	END SELECT
	1225	ENDIF
	1226	CASE ( int_iosync )
	1227	CALL int_get_handle_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, &
	1228	DataHandle , code )
	1229	icurs = icurs + hdrbufsize
	1230	CASE DEFAULT
	1231	WRITE(mess,*)'quilt: bad tag: ',get_hdr_tag( bigbuf(icurs/itypesize) ),' icurs ',icurs/itypesize
	1232	CALL wrf_error_fatal( mess )
	1233	END SELECT
	1234
	1235	ENDDO !}
	1236	! Now, the I/O server "root" has finshed handling all commands from the latest
	1237	! call to retrieve_pieces_of_field().
	1238
	1239	IF (stored_write_record) THEN
	1240	! If any fields have been stored in a globally-sized internal output buffer
	1241	! (via a call to store_patch_in_outbuf()) then call write_outbuf() to write
	1242	! them to disk now.
	1243	! NOTE that the I/O server "root" will only have called
	1244	! store_patch_in_outbuf() when handling write_field (int_field)
	1245	! commands which only arrive AFTER an "iosync" command.
	1246	! CALL start_timing
	1247	CALL write_outbuf ( handle(DataHandle), use_package(io_form(DataHandle)))
	1248	! CALL end_timing( "quilt: call to write_outbuf" )
	1249	ENDIF
	1250
	1251	! If one or more "open_for_write_commit" commands were encountered from the
	1252	! latest call to retrieve_pieces_of_field() then call the package-specific
	1253	! routine to do the commit.
	1254	IF (okay_to_commit(DataHandle)) THEN
	1255
	1256	SELECT CASE (use_package(io_form(DataHandle)))
	1257	#ifdef NETCDF
	1258	CASE ( IO_NETCDF )
	1259	CALL ext_ncd_inquire_filename( handle(DataHandle), fname, fstat, Status )
	1260	IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
	1261	CALL ext_ncd_open_for_write_commit(handle(DataHandle),Status)
	1262	okay_to_write(DataHandle) = .true.
	1263	ENDIF
	1264	#endif
	1265	#ifdef INTIO
	1266	CASE ( IO_INTIO )
	1267	CALL ext_int_inquire_filename( handle(DataHandle), fname, fstat, Status )
	1268	IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
	1269	CALL ext_int_open_for_write_commit(handle(DataHandle),Status)
	1270	okay_to_write(DataHandle) = .true.
	1271	ENDIF
	1272	#endif
	1273	#ifdef YYY
	1274	CASE ( IO_YYY )
	1275	CALL ext_yyy_inquire_filename( handle(DataHandle), fname, fstat, Status )
	1276	IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
	1277	CALL ext_yyy_open_for_write_commit(handle(DataHandle),Status)
	1278	okay_to_write(DataHandle) = .true.
	1279	ENDIF
	1280	#endif
	1281	#ifdef GRIB1
	1282	CASE ( IO_GRIB1 )
	1283	CALL ext_gr1_inquire_filename( handle(DataHandle), fname, fstat, Status )
	1284	IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
	1285	CALL ext_gr1_open_for_write_commit(handle(DataHandle),Status)
	1286	okay_to_write(DataHandle) = .true.
	1287	ENDIF
	1288	#endif
	1289	#ifdef GRIB2
	1290	CASE ( IO_GRIB2 )
	1291	CALL ext_gr2_inquire_filename( handle(DataHandle), fname, fstat, Status )
	1292	IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
	1293	CALL ext_gr2_open_for_write_commit(handle(DataHandle),Status)
	1294	okay_to_write(DataHandle) = .true.
	1295	ENDIF
	1296	#endif
	1297
	1298	CASE DEFAULT
	1299	Status = 0
	1300	END SELECT
	1301
	1302	okay_to_commit(DataHandle) = .false.
	1303	ENDIF
	1304	DEALLOCATE( bigbuf )
	1305	ENDIF
	1306	#endif
	1307
	1308	! Retrieve header and all patches for the next field from the internal
	1309	! buffers.
	1310	CALL retrieve_pieces_of_field ( obuf , VarName, obufsize, sz, retval )
	1311	! Sum sizes of all headers and patches (data) for this field from all I/O
	1312	! servers in this I/O server group onto the I/O server "root".
	1313	CALL MPI_Reduce( sz, bigbufsize, 1, MPI_INTEGER, &
	1314	MPI_SUM, ntasks_local_group-1, &
	1315	mpi_comm_local, ierr )
	1316	! Then, return to the top of the loop to collect headers and data from all
	1317	! I/O servers in this I/O server group onto the I/O server "root" and handle
	1318	! the next batch of commands.
	1319	END DO !}
	1320
	1321	DEALLOCATE( obuf )
	1322
	1323	! flush output files if needed
	1324	IF (stored_write_record) THEN
	1325	!JM TIMING CALL start_timing
	1326	SELECT CASE ( use_package(io_form) )
	1327	#ifdef NETCDF
	1328	CASE ( IO_NETCDF )
	1329	CALL ext_ncd_iosync( handle(DataHandle), Status )
	1330	#endif
	1331	#ifdef XXX
	1332	CASE ( IO_XXX )
	1333	CALL ext_xxx_iosync( handle(DataHandle), Status )
	1334	#endif
	1335	#ifdef YYY
	1336	CASE ( IO_YYY )
	1337	CALL ext_yyy_iosync( handle(DataHandle), Status )
	1338	#endif
	1339	#ifdef ZZZ
	1340	CASE ( IO_ZZZ )
	1341	CALL ext_zzz_iosync( handle(DataHandle), Status )
	1342	#endif
	1343	#ifdef GRIB1
	1344	CASE ( IO_GRIB1 )
	1345	CALL ext_gr1_iosync( handle(DataHandle), Status )
	1346	#endif
	1347	#ifdef GRIB2
	1348	CASE ( IO_GRIB2 )
	1349	CALL ext_gr2_iosync( handle(DataHandle), Status )
	1350	#endif
	1351	#ifdef INTIO
	1352	CASE ( IO_INTIO )
	1353	CALL ext_int_iosync( handle(DataHandle), Status )
	1354	#endif
	1355	CASE DEFAULT
	1356	Status = 0
	1357	END SELECT
	1358	!JM TIMING CALL end_timing( "quilt: flush" )
	1359	ENDIF
	1360
	1361	END DO ! }
	1362
	1363	END SUBROUTINE quilt
	1364
	1365	! end of #endif of DM_PARALLEL
	1366	#endif
	1367
	1368	SUBROUTINE init_module_wrf_quilt
	1369	!<DESCRIPTION>
	1370	! Both client (compute) and server tasks call this routine to initialize the
	1371	! module. Routine setup_quilt_servers() is called from this routine to
	1372	! determine which tasks are compute tasks and which are server tasks. Server
	1373	! tasks then call routine quilt() and remain there for the rest of the model
	1374	! run. Compute tasks return from init_module_wrf_quilt() to perform model
	1375	! computations.
	1376	!</DESCRIPTION>
	1377	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	1378	IMPLICIT NONE
	1379	INCLUDE 'mpif.h'
	1380	INTEGER i
	1381	NAMELIST /namelist_quilt/ nio_tasks_per_group, nio_groups
	1382	INTEGER ntasks, mytask, ierr, io_status
	1383	# if defined(_OPENMP) && defined(MPI2_THREAD_SUPPORT)
	1384	INTEGER thread_support_provided, thread_support_requested
	1385	#endif
	1386	INTEGER mpi_comm_here
	1387	LOGICAL mpi_inited
	1388	LOGICAL esmf_coupling
	1389
	1390	!TODO: Change this to run-time switch
	1391	#ifdef ESMFIO
	1392	esmf_coupling = .TRUE.
	1393	#else
	1394	esmf_coupling = .FALSE.
	1395	#endif
	1396
	1397	quilting_enabled = .FALSE.
	1398	IF ( disable_quilt ) RETURN
	1399
	1400	DO i = 1,int_num_handles
	1401	okay_to_write(i) = .FALSE.
	1402	int_handle_in_use(i) = .FALSE.
	1403	server_for_handle(i) = 0
	1404	int_num_bytes_to_write(i) = 0
	1405	ENDDO
	1406
	1407	CALL MPI_INITIALIZED( mpi_inited, ierr )
	1408	IF ( .NOT. mpi_inited ) THEN
	1409	# if defined(_OPENMP) && defined(MPI2_THREAD_SUPPORT)
	1410	thread_support_requested = MPI_THREAD_FUNNELED
	1411	CALL mpi_init_thread ( thread_support_requested, thread_support_provided, ierr )
	1412	IF ( thread_support_provided .lt. thread_support_requested ) THEN
	1413	CALL WRF_ERROR_FATAL( "failed to initialize MPI thread support")
	1414	ENDIF
	1415	# else
	1416	CALL mpi_init ( ierr )
	1417	# endif
	1418	CALL wrf_set_dm_communicator( MPI_COMM_WORLD )
	1419	CALL wrf_termio_dup
	1420	ENDIF
	1421	CALL wrf_get_dm_communicator( mpi_comm_here )
	1422
	1423	CALL MPI_Comm_rank ( mpi_comm_here, mytask, ierr ) ;
	1424	CALL mpi_x_comm_size ( mpi_comm_here, ntasks, ierr ) ;
	1425
	1426	IF ( mytask .EQ. 0 ) THEN
	1427	OPEN ( unit=27, file="namelist.input", form="formatted", status="old" )
	1428	nio_groups = 1
	1429	nio_tasks_per_group = 0
	1430	READ ( 27 , NML = namelist_quilt, IOSTAT=io_status )
	1431	IF (io_status .NE. 0) THEN
	1432	CALL wrf_error_fatal( "ERROR reading namelist namelist_quilt" )
	1433	ENDIF
	1434	CLOSE ( 27 )
	1435	IF ( esmf_coupling ) THEN
	1436	IF ( nio_tasks_per_group > 0 ) THEN
	1437	CALL wrf_error_fatal("frame/module_io_quilt.F: cannot use "// &
	1438	"ESMF coupling with quilt tasks") ;
	1439	ENDIF
	1440	ENDIF
	1441	ENDIF
	1442	CALL mpi_bcast( nio_tasks_per_group , 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr )
	1443	CALL mpi_bcast( nio_groups , 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr )
	1444
	1445	CALL setup_quilt_servers( nio_tasks_per_group, &
	1446	mytask, &
	1447	ntasks, &
	1448	nio_groups, &
	1449	nio_tasks_in_group, &
	1450	mpi_comm_here, &
	1451	mpi_comm_local, &
	1452	mpi_comm_io_groups)
	1453
	1454	! provide the communicator for the integration tasks to RSL
	1455	IF ( mytask .lt. ncompute_tasks ) THEN
	1456	CALL wrf_set_dm_communicator( mpi_comm_local )
	1457	ELSE
	1458	CALL quilt ! will not return on io server tasks
	1459	ENDIF
	1460	#endif
	1461	RETURN
	1462	END SUBROUTINE init_module_wrf_quilt
	1463	END MODULE module_wrf_quilt
	1464
	1465	!<DESCRIPTION>
	1466	! Remaining routines in this file are defined outside of the module
	1467	! either to defeat arg/param type checking or to avoid an explicit use
	1468	! dependence.
	1469	!</DESCRIPTION>
	1470
	1471	SUBROUTINE disable_quilting
	1472	!<DESCRIPTION>
	1473	! Call this in programs that you never want to be quilting (e.g. real)
	1474	! Must call before call to init_module_wrf_quilt().
	1475	!</DESCRIPTION>
	1476	USE module_wrf_quilt
	1477	disable_quilt = .TRUE.
	1478	RETURN
	1479	END SUBROUTINE disable_quilting
	1480
	1481	LOGICAL FUNCTION use_output_servers()
	1482	!<DESCRIPTION>
	1483	! Returns .TRUE. if I/O quilt servers are in-use for write operations.
	1484	! This routine is called only by client (compute) tasks.
	1485	!</DESCRIPTION>
	1486	USE module_wrf_quilt
	1487	use_output_servers = quilting_enabled
	1488	RETURN
	1489	END FUNCTION use_output_servers
	1490
	1491	LOGICAL FUNCTION use_input_servers()
	1492	!<DESCRIPTION>
	1493	! Returns .TRUE. if I/O quilt servers are in-use for read operations.
	1494	! This routine is called only by client (compute) tasks.
	1495	!</DESCRIPTION>
	1496	USE module_wrf_quilt
	1497	use_input_servers = .FALSE.
	1498	RETURN
	1499	END FUNCTION use_input_servers
	1500
	1501	SUBROUTINE wrf_quilt_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInfo, &
	1502	DataHandle , io_form_arg, Status )
	1503	!<DESCRIPTION>
	1504	! Instruct the I/O quilt servers to begin data definition ("training") phase
	1505	! for writing to WRF dataset FileName. io_form_arg indicates file format.
	1506	! This routine is called only by client (compute) tasks.
	1507	!</DESCRIPTION>
	1508	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	1509	USE module_wrf_quilt
	1510	IMPLICIT NONE
	1511	INCLUDE 'mpif.h'
	1512	#include "intio_tags.h"
	1513	CHARACTER (), INTENT(IN) :: FileName
	1514	INTEGER , INTENT(IN) :: Comm_compute , Comm_io
	1515	CHARACTER (), INTENT(IN) :: SysDepInfo
	1516	INTEGER , INTENT(OUT) :: DataHandle
	1517	INTEGER , INTENT(IN) :: io_form_arg
	1518	INTEGER , INTENT(OUT) :: Status
	1519	! Local
	1520	CHARACTER*132 :: locFileName, locSysDepInfo
	1521	INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group
	1522	REAL dummy
	1523
	1524	CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_open_for_write_begin' )
	1525	CALL int_get_fresh_handle(i)
	1526	okay_to_write(i) = .false.
	1527	DataHandle = i
	1528
	1529	locFileName = FileName
	1530	locSysDepInfo = SysDepInfo
	1531
	1532	CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
	1533	IF ( wrf_dm_on_monitor() ) THEN
	1534	CALL int_gen_ofwb_header( hdrbuf, hdrbufsize, itypesize, &
	1535	locFileName,locSysDepInfo,io_form_arg,DataHandle )
	1536	ELSE
	1537	CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
	1538	ENDIF
	1539
	1540	iserver = get_server_id ( DataHandle )
	1541	!JMDEBUGwrite(0,*)'wrf_quilt_open_for_write_begin iserver = ', iserver
	1542	CALL get_mpi_comm_io_groups( comm_io_group , iserver )
	1543	!JMDEBUGwrite(0,*)'wrf_quilt_open_for_write_begin comm_io_group = ', comm_io_group
	1544
	1545	CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
	1546	!JMDEBUGwrite(0,*)'mpi_x_comm_size tasks_in_group ',tasks_in_group, ierr
	1547
	1548	!JMTIMING CALL start_timing
	1549	! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
	1550	reduced = 0
	1551	reduced(1) = hdrbufsize
	1552	IF ( wrf_dm_on_monitor() ) reduced(2) = i
	1553	CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, &
	1554	MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me
	1555	comm_io_group, ierr )
	1556	!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_open_for_write_begin")
	1557
	1558	! send data to the i/o processor
	1559	CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, &
	1560	onebyte, &
	1561	hdrbuf, hdrbufsize , &
	1562	dummy, 0 )
	1563
	1564	Status = 0
	1565
	1566
	1567	#endif
	1568	RETURN
	1569	END SUBROUTINE wrf_quilt_open_for_write_begin
	1570
	1571	SUBROUTINE wrf_quilt_open_for_write_commit( DataHandle , Status )
	1572	!<DESCRIPTION>
	1573	! Instruct the I/O quilt servers to switch an internal flag to enable output
	1574	! for the dataset referenced by DataHandle. The call to
	1575	! wrf_quilt_open_for_write_commit() must be paired with a call to
	1576	! wrf_quilt_open_for_write_begin().
	1577	! This routine is called only by client (compute) tasks.
	1578	!</DESCRIPTION>
	1579	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	1580	USE module_wrf_quilt
	1581	IMPLICIT NONE
	1582	INCLUDE 'mpif.h'
	1583	#include "intio_tags.h"
	1584	INTEGER , INTENT(IN ) :: DataHandle
	1585	INTEGER , INTENT(OUT) :: Status
	1586	INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group
	1587	REAL dummy
	1588
	1589	CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_open_for_write_commit' )
	1590	IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
	1591	IF ( int_handle_in_use( DataHandle ) ) THEN
	1592	okay_to_write( DataHandle ) = .true.
	1593	ENDIF
	1594	ENDIF
	1595
	1596	CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
	1597
	1598	! IF ( wrf_dm_on_monitor() ) THEN
	1599	CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, &
	1600	DataHandle, int_open_for_write_commit )
	1601	! ELSE
	1602	! CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
	1603	! ENDIF
	1604
	1605	iserver = get_server_id ( DataHandle )
	1606	CALL get_mpi_comm_io_groups( comm_io_group , iserver )
	1607
	1608	CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
	1609
	1610	!JMTIMING CALL start_timing
	1611	! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
	1612	reduced = 0
	1613	reduced(1) = hdrbufsize
	1614	IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
	1615	CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, &
	1616	MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me
	1617	comm_io_group, ierr )
	1618	!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_open_for_write_commit")
	1619
	1620	! send data to the i/o processor
	1621	CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, &
	1622	onebyte, &
	1623	hdrbuf, hdrbufsize , &
	1624	dummy, 0 )
	1625
	1626	Status = 0
	1627
	1628	#endif
	1629	RETURN
	1630	END SUBROUTINE wrf_quilt_open_for_write_commit
	1631
	1632	SUBROUTINE wrf_quilt_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
	1633	DataHandle , Status )
	1634	!<DESCRIPTION>
	1635	! Instruct the I/O quilt servers to open WRF dataset FileName for reading.
	1636	! This routine is called only by client (compute) tasks.
	1637	! This is not yet supported.
	1638	!</DESCRIPTION>
	1639	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	1640	IMPLICIT NONE
	1641	CHARACTER (), INTENT(IN) :: FileName
	1642	INTEGER , INTENT(IN) :: Comm_compute , Comm_io
	1643	CHARACTER (), INTENT(IN) :: SysDepInfo
	1644	INTEGER , INTENT(OUT) :: DataHandle
	1645	INTEGER , INTENT(OUT) :: Status
	1646
	1647	CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_open_for_read' )
	1648	DataHandle = -1
	1649	Status = -1
	1650	CALL wrf_error_fatal ( "frame/module_io_quilt.F: wrf_quilt_open_for_read not yet supported" )
	1651	#endif
	1652	RETURN
	1653	END SUBROUTINE wrf_quilt_open_for_read
	1654
	1655	SUBROUTINE wrf_quilt_inquire_opened ( DataHandle, FileName , FileStatus, Status )
	1656	!<DESCRIPTION>
	1657	! Inquire if the dataset referenced by DataHandle is open.
	1658	! Does not require communication with I/O servers.
	1659	! This routine is called only by client (compute) tasks.
	1660	!</DESCRIPTION>
	1661	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	1662	USE module_wrf_quilt
	1663	IMPLICIT NONE
	1664	#include "wrf_io_flags.h"
	1665	INTEGER , INTENT(IN) :: DataHandle
	1666	CHARACTER (), INTENT(IN) :: FileName
	1667	INTEGER , INTENT(OUT) :: FileStatus
	1668	INTEGER , INTENT(OUT) :: Status
	1669
	1670	Status = 0
	1671
	1672	CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_inquire_opened' )
	1673	IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
	1674	IF ( int_handle_in_use( DataHandle ) ) THEN
	1675	IF ( okay_to_write( DataHandle ) ) THEN
	1676	FileStatus = WRF_FILE_OPENED_FOR_WRITE
	1677	ENDIF
	1678	ENDIF
	1679	ENDIF
	1680	Status = 0
	1681
	1682	#endif
	1683	RETURN
	1684	END SUBROUTINE wrf_quilt_inquire_opened
	1685
	1686	SUBROUTINE wrf_quilt_inquire_filename ( DataHandle, FileName , FileStatus, Status )
	1687	!<DESCRIPTION>
	1688	! Return the Filename and FileStatus associated with DataHandle.
	1689	! Does not require communication with I/O servers.
	1690	!
	1691	! Note that the current implementation does not actually return FileName.
	1692	! Currenlty, WRF does not use this returned value. Fixing this would simply
	1693	! require saving the file names on the client tasks in an array similar to
	1694	! okay_to_write().
	1695	! This routine is called only by client (compute) tasks.
	1696	!</DESCRIPTION>
	1697	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	1698	USE module_wrf_quilt
	1699	IMPLICIT NONE
	1700	#include "wrf_io_flags.h"
	1701	INTEGER , INTENT(IN) :: DataHandle
	1702	CHARACTER (), INTENT(OUT) :: FileName
	1703	INTEGER , INTENT(OUT) :: FileStatus
	1704	INTEGER , INTENT(OUT) :: Status
	1705	CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_inquire_filename' )
	1706	Status = 0
	1707	IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
	1708	IF ( int_handle_in_use( DataHandle ) ) THEN
	1709	IF ( okay_to_write( DataHandle ) ) THEN
	1710	FileStatus = WRF_FILE_OPENED_FOR_WRITE
	1711	ELSE
	1712	FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
	1713	ENDIF
	1714	ELSE
	1715	FileStatus = WRF_FILE_NOT_OPENED
	1716	ENDIF
	1717	Status = 0
	1718	FileName = "bogusfornow"
	1719	ELSE
	1720	Status = -1
	1721	ENDIF
	1722	#endif
	1723	RETURN
	1724	END SUBROUTINE wrf_quilt_inquire_filename
	1725
	1726	SUBROUTINE wrf_quilt_iosync ( DataHandle, Status )
	1727	!<DESCRIPTION>
	1728	! Instruct the I/O quilt servers to synchronize the disk copy of a dataset
	1729	! with memory buffers.
	1730	!
	1731	! After the "iosync" header (request) is sent to the I/O quilt server,
	1732	! the compute tasks will then send the entire contents (headers and data) of
	1733	! int_local_output_buffer to their I/O quilt server. This communication is
	1734	! done in subroutine send_to_io_quilt_servers(). After the I/O quilt servers
	1735	! receive this data, they will write all accumulated fields to disk.
	1736	!
	1737	! Significant time may be required for the I/O quilt servers to organize
	1738	! fields and write them to disk. Therefore, the "iosync" request should be
	1739	! sent only when the compute tasks are ready to run for a while without
	1740	! needing to communicate with the servers. Otherwise, the compute tasks
	1741	! will end up waiting for the servers to finish writing to disk, thus wasting
	1742	! any performance benefits of having servers at all.
	1743	!
	1744	! This routine is called only by client (compute) tasks.
	1745	!</DESCRIPTION>
	1746	#if defined( DM_PARALLEL ) && ! defined (STUBMPI)
	1747	USE module_wrf_quilt
	1748	IMPLICIT NONE
	1749	include "mpif.h"
	1750	INTEGER , INTENT(IN) :: DataHandle
	1751	INTEGER , INTENT(OUT) :: Status
	1752
	1753	INTEGER locsize , itypesize
	1754	INTEGER ierr, tasks_in_group, comm_io_group, dummy, i
	1755
	1756	CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_iosync' )
	1757
	1758	!JMTIMING CALL start_timing
	1759	IF ( associated ( int_local_output_buffer ) ) THEN
	1760
	1761	iserver = get_server_id ( DataHandle )
	1762	CALL get_mpi_comm_io_groups( comm_io_group , iserver )
	1763
	1764	CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
	1765
	1766	locsize = int_num_bytes_to_write(DataHandle)
	1767
	1768	!JMTIMING CALL start_timing
	1769	! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
	1770	reduced = 0
	1771	reduced(1) = locsize
	1772	IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
	1773	CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, &
	1774	MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me
	1775	comm_io_group, ierr )
	1776	!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_iosync")
	1777
	1778	! send data to the i/o processor
	1779	#ifdef DEREF_KLUDGE
	1780	CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, &
	1781	onebyte, &
	1782	int_local_output_buffer(1), locsize , &
	1783	dummy, 0 )
	1784	#else
	1785	CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, &
	1786	onebyte, &
	1787	int_local_output_buffer, locsize , &
	1788	dummy, 0 )
	1789	#endif
	1790
	1791
	1792	int_local_output_cursor = 1
	1793	! int_num_bytes_to_write(DataHandle) = 0
	1794	DEALLOCATE ( int_local_output_buffer )
	1795	NULLIFY ( int_local_output_buffer )
	1796	ELSE
	1797	CALL wrf_message ("frame/module_io_quilt.F: wrf_quilt_iosync: no buffer allocated")
	1798	ENDIF
	1799	!JMTIMING CALL end_timing("wrf_quilt_iosync")
	1800	Status = 0
	1801	#endif
	1802	RETURN
	1803	END SUBROUTINE wrf_quilt_iosync
	1804
	1805	SUBROUTINE wrf_quilt_ioclose ( DataHandle, Status )
	1806	!<DESCRIPTION>
	1807	! Instruct the I/O quilt servers to close the dataset referenced by
	1808	! DataHandle.
	1809	! This routine also clears the client file handle and, if needed, deallocates
	1810	! int_local_output_buffer.
	1811	! This routine is called only by client (compute) tasks.
	1812	!</DESCRIPTION>
	1813	#if defined( DM_PARALLEL ) && ! defined( STUBMPI)
	1814	USE module_wrf_quilt
	1815	USE module_timing
	1816	IMPLICIT NONE
	1817	INCLUDE 'mpif.h'
	1818	#include "intio_tags.h"
	1819	INTEGER , INTENT(IN) :: DataHandle
	1820	INTEGER , INTENT(OUT) :: Status
	1821	INTEGER i, itypesize, tasks_in_group, comm_io_group, ierr
	1822	REAL dummy
	1823
	1824	!JMTIMING CALL start_timing
	1825	CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_ioclose' )
	1826	CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
	1827
	1828	IF ( wrf_dm_on_monitor() ) THEN
	1829	CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, &
	1830	DataHandle , int_ioclose )
	1831	ELSE
	1832	CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
	1833	ENDIF
	1834
	1835	iserver = get_server_id ( DataHandle )
	1836	CALL get_mpi_comm_io_groups( comm_io_group , iserver )
	1837
	1838	CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
	1839
	1840	!JMTIMING CALL start_timing
	1841	! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
	1842	reduced = 0
	1843	IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
	1844	CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, &
	1845	MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me
	1846	comm_io_group, ierr )
	1847	!JMTIMING CALL end_timing("MPI_Reduce in ioclose")
	1848
	1849	#if 0
	1850	! send data to the i/o processor
	1851	!JMTIMING CALL start_timing
	1852	CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, &
	1853	onebyte, &
	1854	hdrbuf, hdrbufsize , &
	1855	dummy, 0 )
	1856	!JMTIMING CALL end_timing("collect_on_comm in io_close")
	1857	#endif
	1858
	1859	int_handle_in_use(DataHandle) = .false.
	1860	CALL set_server_id( DataHandle, 0 )
	1861	okay_to_write(DataHandle) = .false.
	1862	okay_to_commit(DataHandle) = .false.
	1863	int_local_output_cursor = 1
	1864	int_num_bytes_to_write(DataHandle) = 0
	1865	IF ( associated ( int_local_output_buffer ) ) THEN
	1866	DEALLOCATE ( int_local_output_buffer )
	1867	NULLIFY ( int_local_output_buffer )
	1868	ENDIF
	1869
	1870	Status = 0
	1871	!JMTIMING CALL end_timing( "wrf_quilt_ioclose" )
	1872
	1873	#endif
	1874	RETURN
	1875	END SUBROUTINE wrf_quilt_ioclose
	1876
	1877	SUBROUTINE wrf_quilt_ioexit( Status )
	1878	!<DESCRIPTION>
	1879	! Instruct the I/O quilt servers to shut down the WRF I/O system.
	1880	! Do not call any wrf_quilt_*() routines after this routine has been called.
	1881	! This routine is called only by client (compute) tasks.
	1882	!</DESCRIPTION>
	1883	#if defined( DM_PARALLEL ) && ! defined (STUBMPI )
	1884	USE module_wrf_quilt
	1885	IMPLICIT NONE
	1886	INCLUDE 'mpif.h'
	1887	#include "intio_tags.h"
	1888	INTEGER , INTENT(OUT) :: Status
	1889	INTEGER :: DataHandle
	1890	INTEGER i, itypesize, tasks_in_group, comm_io_group, me, ierr
	1891	REAL dummy
	1892
	1893	CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_ioexit' )
	1894	CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
	1895
	1896	IF ( wrf_dm_on_monitor() ) THEN
	1897	CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, &
	1898	DataHandle , int_ioexit ) ! Handle is dummy
	1899	ELSE
	1900	CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
	1901	ENDIF
	1902
	1903	DO iserver = 1, nio_groups
	1904	CALL get_mpi_comm_io_groups( comm_io_group , iserver )
	1905
	1906	CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
	1907	CALL mpi_comm_rank( comm_io_group , me , ierr )
	1908
	1909	! BY SENDING A NEGATIVE SIZE WE GET THE SERVERS TO SHUT DOWN
	1910	hdrbufsize = -100
	1911	reduced = 0
	1912	IF ( me .eq. 0 ) reduced(1) = hdrbufsize
	1913	CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, &
	1914	MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me
	1915	comm_io_group, ierr )
	1916
	1917	ENDDO
	1918	Status = 0
	1919
	1920	#endif
	1921	RETURN
	1922	END SUBROUTINE wrf_quilt_ioexit
	1923
	1924	SUBROUTINE wrf_quilt_get_next_time ( DataHandle, DateStr, Status )
	1925	!<DESCRIPTION>
	1926	! Instruct the I/O quilt servers to return the next time stamp.
	1927	! This is not yet supported.
	1928	! This routine is called only by client (compute) tasks.
	1929	!</DESCRIPTION>
	1930	#if defined( DM_PARALLEL ) && ! defined (STUBMPI)
	1931	IMPLICIT NONE
	1932	INTEGER , INTENT(IN) :: DataHandle
	1933	CHARACTER() :: DateStr
	1934	INTEGER :: Status
	1935	#endif
	1936	RETURN
	1937	END SUBROUTINE wrf_quilt_get_next_time
	1938
	1939	SUBROUTINE wrf_quilt_get_previous_time ( DataHandle, DateStr, Status )
	1940	!<DESCRIPTION>
	1941	! Instruct the I/O quilt servers to return the previous time stamp.
	1942	! This is not yet supported.
	1943	! This routine is called only by client (compute) tasks.
	1944	!</DESCRIPTION>
	1945	#if defined( DM_PARALLEL ) && ! defined (STUBMPI)
	1946	IMPLICIT NONE
	1947	INTEGER , INTENT(IN) :: DataHandle
	1948	CHARACTER() :: DateStr
	1949	INTEGER :: Status
	1950	#endif
	1951	RETURN
	1952	END SUBROUTINE wrf_quilt_get_previous_time
	1953
	1954	SUBROUTINE wrf_quilt_set_time ( DataHandle, Data, Status )
	1955	!<DESCRIPTION>
	1956	! Instruct the I/O quilt servers to set the time stamp in the dataset
	1957	! referenced by DataHandle.
	1958	! This routine is called only by client (compute) tasks.
	1959	!</DESCRIPTION>
	1960	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	1961	USE module_wrf_quilt
	1962	IMPLICIT NONE
	1963	INCLUDE 'mpif.h'
	1964	#include "intio_tags.h"
	1965	INTEGER , INTENT(IN) :: DataHandle
	1966	CHARACTER() , INTENT(IN) :: Data
	1967	INTEGER :: Status
	1968	INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group
	1969	REAL dummy
	1970	INTEGER :: Count
	1971	!
	1972	CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_set_time' )
	1973
	1974	IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
	1975	IF ( int_handle_in_use( DataHandle ) ) THEN
	1976	CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
	1977	Count = 0 ! there is no count for character strings
	1978
	1979	IF ( wrf_dm_on_monitor() ) THEN
	1980	CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
	1981	DataHandle, "TIMESTAMP", "", Data, int_set_time )
	1982	ELSE
	1983	CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
	1984	ENDIF
	1985
	1986	iserver = get_server_id ( DataHandle )
	1987	CALL get_mpi_comm_io_groups( comm_io_group , iserver )
	1988	CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
	1989
	1990	! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
	1991	reduced = 0
	1992	reduced(1) = hdrbufsize
	1993	IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
	1994	CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, &
	1995	MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me
	1996	comm_io_group, ierr )
	1997	! send data to the i/o processor
	1998	CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, &
	1999	onebyte, &
	2000	hdrbuf, hdrbufsize , &
	2001	dummy, 0 )
	2002	ENDIF
	2003	ENDIF
	2004
	2005	#endif
	2006	RETURN
	2007	END SUBROUTINE wrf_quilt_set_time
	2008
	2009	SUBROUTINE wrf_quilt_get_next_var ( DataHandle, VarName, Status )
	2010	!<DESCRIPTION>
	2011	! When reading, instruct the I/O quilt servers to return the name of the next
	2012	! variable in the current time frame.
	2013	! This is not yet supported.
	2014	! This routine is called only by client (compute) tasks.
	2015	!</DESCRIPTION>
	2016	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2017	IMPLICIT NONE
	2018	INTEGER , INTENT(IN) :: DataHandle
	2019	CHARACTER() :: VarName
	2020	INTEGER :: Status
	2021	#endif
	2022	RETURN
	2023	END SUBROUTINE wrf_quilt_get_next_var
	2024
	2025	SUBROUTINE wrf_quilt_get_dom_ti_real ( DataHandle,Element, Data, Count, Outcount, Status )
	2026	!<DESCRIPTION>
	2027	! Instruct the I/O quilt servers to attempt to read Count words of time
	2028	! independent domain metadata named "Element"
	2029	! from the open dataset described by DataHandle.
	2030	! Metadata of type real are
	2031	! stored in array Data.
	2032	! Actual number of words read is returned in OutCount.
	2033	! This routine is called only by client (compute) tasks.
	2034
	2035	! This is not yet supported.
	2036	!</DESCRIPTION>
	2037	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2038	IMPLICIT NONE
	2039	INTEGER , INTENT(IN) :: DataHandle
	2040	CHARACTER() , INTENT(IN) :: Element
	2041	REAL, INTENT(IN) :: Data(*)
	2042	INTEGER , INTENT(IN) :: Count
	2043	INTEGER :: Outcount
	2044	INTEGER :: Status
	2045	CALL wrf_message('wrf_quilt_get_dom_ti_real not supported yet')
	2046	#endif
	2047	RETURN
	2048	END SUBROUTINE wrf_quilt_get_dom_ti_real
	2049
	2050	SUBROUTINE wrf_quilt_put_dom_ti_real ( DataHandle,Element, Data, Count, Status )
	2051	!<DESCRIPTION>
	2052	! Instruct the I/O quilt servers to write Count words of time independent
	2053	! domain metadata named "Element"
	2054	! to the open dataset described by DataHandle.
	2055	! Metadata of type real are
	2056	! copied from array Data.
	2057	! This routine is called only by client (compute) tasks.
	2058	!</DESCRIPTION>
	2059	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2060	USE module_wrf_quilt
	2061	IMPLICIT NONE
	2062	INCLUDE 'mpif.h'
	2063	#include "intio_tags.h"
	2064	INTEGER , INTENT(IN) :: DataHandle
	2065	CHARACTER() , INTENT(IN) :: Element
	2066	real , INTENT(IN) :: Data(*)
	2067	INTEGER , INTENT(IN) :: Count
	2068	INTEGER :: Status
	2069	!Local
	2070	CHARACTER*132 :: locElement
	2071	INTEGER i, typesize, itypesize, tasks_in_group, ierr, comm_io_group
	2072	REAL dummy
	2073	!
	2074	!JMTIMING CALL start_timing
	2075	CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_dom_ti_real' )
	2076	CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
	2077	locElement = Element
	2078
	2079	IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
	2080	IF ( int_handle_in_use( DataHandle ) ) THEN
	2081	CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
	2082	CALL MPI_TYPE_SIZE( MPI_REAL, typesize, ierr )
	2083	IF ( wrf_dm_on_monitor() ) THEN
	2084	CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, &
	2085	DataHandle, locElement, Data, Count, int_dom_ti_real )
	2086	ELSE
	2087	CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
	2088	ENDIF
	2089	iserver = get_server_id ( DataHandle )
	2090	CALL get_mpi_comm_io_groups( comm_io_group , iserver )
	2091	CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
	2092
	2093	!JMTIMING CALL start_timing
	2094	! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
	2095	reduced = 0
	2096	reduced(1) = hdrbufsize
	2097	IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
	2098	CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, &
	2099	MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me
	2100	comm_io_group, ierr )
	2101	!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_dom_ti_real")
	2102	! send data to the i/o processor
	2103	CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, &
	2104	onebyte, &
	2105	hdrbuf, hdrbufsize , &
	2106	dummy, 0 )
	2107	ENDIF
	2108	ENDIF
	2109
	2110	Status = 0
	2111	!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_real")
	2112	#endif
	2113	RETURN
	2114	END SUBROUTINE wrf_quilt_put_dom_ti_real
	2115
	2116	SUBROUTINE wrf_quilt_get_dom_ti_double ( DataHandle,Element, Data, Count, Outcount, Status )
	2117	!<DESCRIPTION>
	2118	! Instruct the I/O quilt servers to attempt to read Count words of time
	2119	! independent domain metadata named "Element"
	2120	! from the open dataset described by DataHandle.
	2121	! Metadata of type double are
	2122	! stored in array Data.
	2123	! Actual number of words read is returned in OutCount.
	2124	! This routine is called only by client (compute) tasks.
	2125	!
	2126	! This is not yet supported.
	2127	!</DESCRIPTION>
	2128	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2129	IMPLICIT NONE
	2130	INTEGER , INTENT(IN) :: DataHandle
	2131	CHARACTER() , INTENT(IN) :: Element
	2132	real8 :: Data()
	2133	INTEGER , INTENT(IN) :: Count
	2134	INTEGER :: OutCount
	2135	INTEGER :: Status
	2136	CALL wrf_error_fatal('wrf_quilt_get_dom_ti_double not supported yet')
	2137	#endif
	2138	RETURN
	2139	END SUBROUTINE wrf_quilt_get_dom_ti_double
	2140
	2141	SUBROUTINE wrf_quilt_put_dom_ti_double ( DataHandle,Element, Data, Count, Status )
	2142	!<DESCRIPTION>
	2143	! Instruct the I/O quilt servers to write Count words of time independent
	2144	! domain metadata named "Element"
	2145	! to the open dataset described by DataHandle.
	2146	! Metadata of type double are
	2147	! copied from array Data.
	2148	! This routine is called only by client (compute) tasks.
	2149	!
	2150	! This is not yet supported.
	2151	!</DESCRIPTION>
	2152	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2153	IMPLICIT NONE
	2154	INTEGER , INTENT(IN) :: DataHandle
	2155	CHARACTER() , INTENT(IN) :: Element
	2156	real8 , INTENT(IN) :: Data()
	2157	INTEGER , INTENT(IN) :: Count
	2158	INTEGER :: Status
	2159	CALL wrf_error_fatal('wrf_quilt_put_dom_ti_double not supported yet')
	2160	#endif
	2161	RETURN
	2162	END SUBROUTINE wrf_quilt_put_dom_ti_double
	2163
	2164	SUBROUTINE wrf_quilt_get_dom_ti_integer ( DataHandle,Element, Data, Count, Outcount, Status )
	2165	!<DESCRIPTION>
	2166	! Instruct the I/O quilt servers to attempt to read Count words of time
	2167	! independent domain metadata named "Element"
	2168	! from the open dataset described by DataHandle.
	2169	! Metadata of type integer are
	2170	! stored in array Data.
	2171	! Actual number of words read is returned in OutCount.
	2172	! This routine is called only by client (compute) tasks.
	2173	!
	2174	! This is not yet supported.
	2175	!</DESCRIPTION>
	2176	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2177	IMPLICIT NONE
	2178	INTEGER , INTENT(IN) :: DataHandle
	2179	CHARACTER() , INTENT(IN) :: Element
	2180	integer :: Data(*)
	2181	INTEGER , INTENT(IN) :: Count
	2182	INTEGER :: OutCount
	2183	INTEGER :: Status
	2184	CALL wrf_message('wrf_quilt_get_dom_ti_integer not supported yet')
	2185	#endif
	2186	RETURN
	2187	END SUBROUTINE wrf_quilt_get_dom_ti_integer
	2188
	2189	SUBROUTINE wrf_quilt_put_dom_ti_integer ( DataHandle,Element, Data, Count, Status )
	2190	!<DESCRIPTION>
	2191	! Instruct the I/O quilt servers to write Count words of time independent
	2192	! domain metadata named "Element"
	2193	! to the open dataset described by DataHandle.
	2194	! Metadata of type integer are
	2195	! copied from array Data.
	2196	! This routine is called only by client (compute) tasks.
	2197	!</DESCRIPTION>
	2198	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2199	USE module_wrf_quilt
	2200	IMPLICIT NONE
	2201	INCLUDE 'mpif.h'
	2202	#include "intio_tags.h"
	2203	INTEGER , INTENT(IN) :: DataHandle
	2204	CHARACTER() , INTENT(IN) :: Element
	2205	INTEGER , INTENT(IN) :: Data(*)
	2206	INTEGER , INTENT(IN) :: Count
	2207	INTEGER :: Status
	2208	! Local
	2209	CHARACTER*132 :: locElement
	2210	INTEGER i, typesize, itypesize, tasks_in_group, ierr, comm_io_group
	2211	REAL dummy
	2212	!
	2213
	2214	!JMTIMING CALL start_timing
	2215	locElement = Element
	2216
	2217	CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_dom_ti_integer' )
	2218
	2219	IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
	2220	IF ( int_handle_in_use( DataHandle ) ) THEN
	2221	CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
	2222	CALL MPI_TYPE_SIZE( MPI_INTEGER, typesize, ierr )
	2223	IF ( wrf_dm_on_monitor() ) THEN
	2224	CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, &
	2225	DataHandle, locElement, Data, Count, int_dom_ti_integer )
	2226	ELSE
	2227	CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
	2228	ENDIF
	2229	iserver = get_server_id ( DataHandle )
	2230	CALL get_mpi_comm_io_groups( comm_io_group , iserver )
	2231	CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
	2232
	2233	!JMTIMING CALL start_timing
	2234	! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
	2235	reduced = 0
	2236	reduced(1) = hdrbufsize
	2237	IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
	2238	CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, &
	2239	MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me
	2240	comm_io_group, ierr )
	2241
	2242	!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_dom_ti_integer")
	2243	! send data to the i/o processor
	2244	CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, &
	2245	onebyte, &
	2246	hdrbuf, hdrbufsize , &
	2247	dummy, 0 )
	2248	ENDIF
	2249	ENDIF
	2250	CALL wrf_debug ( DEBUG_LVL, 'returning from wrf_quilt_put_dom_ti_integer' )
	2251	!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_integer" )
	2252
	2253	#endif
	2254	RETURN
	2255	END SUBROUTINE wrf_quilt_put_dom_ti_integer
	2256
	2257	SUBROUTINE wrf_quilt_get_dom_ti_logical ( DataHandle,Element, Data, Count, Outcount, Status )
	2258	!<DESCRIPTION>
	2259	! Instruct the I/O quilt servers to attempt to read Count words of time
	2260	! independent domain metadata named "Element"
	2261	! from the open dataset described by DataHandle.
	2262	! Metadata of type logical are
	2263	! stored in array Data.
	2264	! Actual number of words read is returned in OutCount.
	2265	! This routine is called only by client (compute) tasks.
	2266	!
	2267	! This is not yet supported.
	2268	!</DESCRIPTION>
	2269	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2270	IMPLICIT NONE
	2271	INTEGER , INTENT(IN) :: DataHandle
	2272	CHARACTER() , INTENT(IN) :: Element
	2273	logical :: Data(*)
	2274	INTEGER , INTENT(IN) :: Count
	2275	INTEGER :: OutCount
	2276	INTEGER :: Status
	2277	! CALL wrf_message('wrf_quilt_get_dom_ti_logical not supported yet')
	2278	#endif
	2279	RETURN
	2280	END SUBROUTINE wrf_quilt_get_dom_ti_logical
	2281
	2282	SUBROUTINE wrf_quilt_put_dom_ti_logical ( DataHandle,Element, Data, Count, Status )
	2283	!<DESCRIPTION>
	2284	! Instruct the I/O quilt servers to write Count words of time independent
	2285	! domain metadata named "Element"
	2286	! to the open dataset described by DataHandle.
	2287	! Metadata of type logical are
	2288	! copied from array Data.
	2289	! This routine is called only by client (compute) tasks.
	2290	!
	2291	! This is not yet supported.
	2292	!</DESCRIPTION>
	2293	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2294	IMPLICIT NONE
	2295	INTEGER , INTENT(IN) :: DataHandle
	2296	CHARACTER() , INTENT(IN) :: Element
	2297	logical , INTENT(IN) :: Data(*)
	2298	INTEGER , INTENT(IN) :: Count
	2299	INTEGER :: Status
	2300	! Local
	2301	INTEGER i
	2302	INTEGER one_or_zero(Count)
	2303
	2304	DO i = 1, Count
	2305	IF ( Data(i) ) THEN
	2306	one_or_zero(i) = 1
	2307	ELSE
	2308	one_or_zero(i) = 0
	2309	ENDIF
	2310	ENDDO
	2311
	2312	CALL wrf_quilt_put_dom_ti_integer ( DataHandle,Element, one_or_zero, Count, Status )
	2313	#endif
	2314	RETURN
	2315	END SUBROUTINE wrf_quilt_put_dom_ti_logical
	2316
	2317	SUBROUTINE wrf_quilt_get_dom_ti_char ( DataHandle,Element, Data, Status )
	2318	!<DESCRIPTION>
	2319	! Instruct the I/O quilt servers to attempt to read time independent
	2320	! domain metadata named "Element"
	2321	! from the open dataset described by DataHandle.
	2322	! Metadata of type char are
	2323	! stored in string Data.
	2324	! This routine is called only by client (compute) tasks.
	2325	!
	2326	! This is not yet supported.
	2327	!</DESCRIPTION>
	2328	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2329	IMPLICIT NONE
	2330	INTEGER , INTENT(IN) :: DataHandle
	2331	CHARACTER() , INTENT(IN) :: Element
	2332	CHARACTER() :: Data
	2333	INTEGER :: Status
	2334	CALL wrf_message('wrf_quilt_get_dom_ti_char not supported yet')
	2335	#endif
	2336	RETURN
	2337	END SUBROUTINE wrf_quilt_get_dom_ti_char
	2338
	2339	SUBROUTINE wrf_quilt_put_dom_ti_char ( DataHandle, Element, Data, Status )
	2340	!<DESCRIPTION>
	2341	! Instruct the I/O quilt servers to write time independent
	2342	! domain metadata named "Element"
	2343	! to the open dataset described by DataHandle.
	2344	! Metadata of type char are
	2345	! copied from string Data.
	2346	! This routine is called only by client (compute) tasks.
	2347	!</DESCRIPTION>
	2348	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2349	USE module_wrf_quilt
	2350	IMPLICIT NONE
	2351	INCLUDE 'mpif.h'
	2352	#include "intio_tags.h"
	2353	INTEGER , INTENT(IN) :: DataHandle
	2354	CHARACTER() , INTENT(IN) :: Element
	2355	CHARACTER() , INTENT(IN) :: Data
	2356	INTEGER :: Status
	2357	INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group, me
	2358	REAL dummy
	2359	!
	2360	!JMTIMING CALL start_timing
	2361	CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_dom_ti_char' )
	2362
	2363	IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
	2364	IF ( int_handle_in_use( DataHandle ) ) THEN
	2365	CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
	2366	IF ( wrf_dm_on_monitor() ) THEN
	2367	CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
	2368	DataHandle, Element, "", Data, int_dom_ti_char )
	2369	ELSE
	2370	CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
	2371	ENDIF
	2372	iserver = get_server_id ( DataHandle )
	2373	! write(0,*)'wrf_quilt_put_dom_ti_char ',iserver
	2374	CALL get_mpi_comm_io_groups( comm_io_group , iserver )
	2375	CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
	2376	! send the size of my local buffer to the i/o task (obufsize doesnt mean anything here)
	2377	!JMTIMING! CALL start_timing
	2378	!write(0,*)'calling MPI_Barrier'
	2379	! CALL MPI_Barrier( mpi_comm_local, ierr )
	2380	!write(0,*)'back from MPI_Barrier'
	2381	!JMTIMING! CALL end_timing("MPI_Barrier in wrf_quilt_put_dom_ti_char")
	2382
	2383	!JMTIMING CALL start_timing
	2384	! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
	2385	reduced_dummy = 0
	2386	reduced = 0
	2387	reduced(1) = hdrbufsize
	2388	IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
	2389
	2390	!call mpi_comm_rank( comm_io_group , me, ierr )
	2391
	2392	CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, &
	2393	MPI_SUM, tasks_in_group-1, & ! nio_tasks_in_group-1 is me
	2394	comm_io_group, ierr )
	2395
	2396	!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_dom_ti_char")
	2397	! send data to the i/o processor
	2398	!JMTIMING CALL start_timing
	2399
	2400	CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, &
	2401	onebyte, &
	2402	hdrbuf, hdrbufsize , &
	2403	dummy, 0 )
	2404	!JMTIMING CALL end_timing("collect_on_comm in wrf_quilt_put_dom_ti_char")
	2405	ENDIF
	2406	ENDIF
	2407	!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_char")
	2408
	2409	#endif
	2410	RETURN
	2411	END SUBROUTINE wrf_quilt_put_dom_ti_char
	2412
	2413	SUBROUTINE wrf_quilt_get_dom_td_real ( DataHandle,Element, DateStr, Data, Count, Outcount, Status )
	2414	!<DESCRIPTION>
	2415	! Instruct the I/O quilt servers to attempt to read Count words of time
	2416	! dependent domain metadata named "Element" valid at time DateStr
	2417	! from the open dataset described by DataHandle.
	2418	! Metadata of type real are
	2419	! stored in array Data.
	2420	! Actual number of words read is returned in OutCount.
	2421	! This routine is called only by client (compute) tasks.
	2422	!
	2423	! This is not yet supported.
	2424	!</DESCRIPTION>
	2425	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2426	IMPLICIT NONE
	2427	INTEGER , INTENT(IN) :: DataHandle
	2428	CHARACTER() , INTENT(IN) :: Element
	2429	CHARACTER() , INTENT(IN) :: DateStr
	2430	real :: Data(*)
	2431	INTEGER , INTENT(IN) :: Count
	2432	INTEGER :: OutCount
	2433	INTEGER :: Status
	2434	#endif
	2435	RETURN
	2436	END SUBROUTINE wrf_quilt_get_dom_td_real
	2437
	2438	SUBROUTINE wrf_quilt_put_dom_td_real ( DataHandle,Element, DateStr, Data, Count, Status )
	2439	!<DESCRIPTION>
	2440	! Instruct the I/O quilt servers to write Count words of time dependent
	2441	! domain metadata named "Element" valid at time DateStr
	2442	! to the open dataset described by DataHandle.
	2443	! Metadata of type real are
	2444	! copied from array Data.
	2445	! This routine is called only by client (compute) tasks.
	2446	!
	2447	! This is not yet supported.
	2448	!</DESCRIPTION>
	2449	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2450	IMPLICIT NONE
	2451	INTEGER , INTENT(IN) :: DataHandle
	2452	CHARACTER() , INTENT(IN) :: Element
	2453	CHARACTER() , INTENT(IN) :: DateStr
	2454	real , INTENT(IN) :: Data(*)
	2455	INTEGER , INTENT(IN) :: Count
	2456	INTEGER :: Status
	2457	#endif
	2458	RETURN
	2459	END SUBROUTINE wrf_quilt_put_dom_td_real
	2460
	2461	SUBROUTINE wrf_quilt_get_dom_td_double ( DataHandle,Element, DateStr, Data, Count, Outcount, Status )
	2462	!<DESCRIPTION>
	2463	! Instruct the I/O quilt servers to attempt to read Count words of time
	2464	! dependent domain metadata named "Element" valid at time DateStr
	2465	! from the open dataset described by DataHandle.
	2466	! Metadata of type double are
	2467	! stored in array Data.
	2468	! Actual number of words read is returned in OutCount.
	2469	! This routine is called only by client (compute) tasks.
	2470	!
	2471	! This is not yet supported.
	2472	!</DESCRIPTION>
	2473	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2474	IMPLICIT NONE
	2475	INTEGER , INTENT(IN) :: DataHandle
	2476	CHARACTER() , INTENT(IN) :: Element
	2477	CHARACTER() , INTENT(IN) :: DateStr
	2478	real8 :: Data()
	2479	INTEGER , INTENT(IN) :: Count
	2480	INTEGER :: OutCount
	2481	INTEGER :: Status
	2482	#endif
	2483	CALL wrf_error_fatal('wrf_quilt_get_dom_td_double not supported yet')
	2484	RETURN
	2485	END SUBROUTINE wrf_quilt_get_dom_td_double
	2486
	2487	SUBROUTINE wrf_quilt_put_dom_td_double ( DataHandle,Element, DateStr, Data, Count, Status )
	2488	!<DESCRIPTION>
	2489	! Instruct the I/O quilt servers to write Count words of time dependent
	2490	! domain metadata named "Element" valid at time DateStr
	2491	! to the open dataset described by DataHandle.
	2492	! Metadata of type double are
	2493	! copied from array Data.
	2494	! This routine is called only by client (compute) tasks.
	2495	!
	2496	! This is not yet supported.
	2497	!</DESCRIPTION>
	2498	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2499	IMPLICIT NONE
	2500	INTEGER , INTENT(IN) :: DataHandle
	2501	CHARACTER() , INTENT(IN) :: Element
	2502	CHARACTER() , INTENT(IN) :: DateStr
	2503	real8 , INTENT(IN) :: Data()
	2504	INTEGER , INTENT(IN) :: Count
	2505	INTEGER :: Status
	2506	#endif
	2507	CALL wrf_error_fatal('wrf_quilt_put_dom_td_double not supported yet')
	2508	RETURN
	2509	END SUBROUTINE wrf_quilt_put_dom_td_double
	2510
	2511	SUBROUTINE wrf_quilt_get_dom_td_integer ( DataHandle,Element, DateStr, Data, Count, Outcount, Status )
	2512	!<DESCRIPTION>
	2513	! Instruct the I/O quilt servers to attempt to read Count words of time
	2514	! dependent domain metadata named "Element" valid at time DateStr
	2515	! from the open dataset described by DataHandle.
	2516	! Metadata of type integer are
	2517	! stored in array Data.
	2518	! Actual number of words read is returned in OutCount.
	2519	! This routine is called only by client (compute) tasks.
	2520	!
	2521	! This is not yet supported.
	2522	!</DESCRIPTION>
	2523	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2524	IMPLICIT NONE
	2525	INTEGER , INTENT(IN) :: DataHandle
	2526	CHARACTER() , INTENT(IN) :: Element
	2527	CHARACTER() , INTENT(IN) :: DateStr
	2528	integer :: Data(*)
	2529	INTEGER , INTENT(IN) :: Count
	2530	INTEGER :: OutCount
	2531	INTEGER :: Status
	2532	#endif
	2533	RETURN
	2534	END SUBROUTINE wrf_quilt_get_dom_td_integer
	2535
	2536	SUBROUTINE wrf_quilt_put_dom_td_integer ( DataHandle,Element, DateStr, Data, Count, Status )
	2537	!<DESCRIPTION>
	2538	! Instruct the I/O quilt servers to write Count words of time dependent
	2539	! domain metadata named "Element" valid at time DateStr
	2540	! to the open dataset described by DataHandle.
	2541	! Metadata of type integer are
	2542	! copied from array Data.
	2543	! This routine is called only by client (compute) tasks.
	2544	!
	2545	! This is not yet supported.
	2546	!</DESCRIPTION>
	2547	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2548	IMPLICIT NONE
	2549	INTEGER , INTENT(IN) :: DataHandle
	2550	CHARACTER() , INTENT(IN) :: Element
	2551	CHARACTER() , INTENT(IN) :: DateStr
	2552	integer , INTENT(IN) :: Data(*)
	2553	INTEGER , INTENT(IN) :: Count
	2554	INTEGER :: Status
	2555	#endif
	2556	RETURN
	2557	END SUBROUTINE wrf_quilt_put_dom_td_integer
	2558
	2559	SUBROUTINE wrf_quilt_get_dom_td_logical ( DataHandle,Element, DateStr, Data, Count, Outcount, Status )
	2560	!<DESCRIPTION>
	2561	! Instruct the I/O quilt servers to attempt to read Count words of time
	2562	! dependent domain metadata named "Element" valid at time DateStr
	2563	! from the open dataset described by DataHandle.
	2564	! Metadata of type logical are
	2565	! stored in array Data.
	2566	! Actual number of words read is returned in OutCount.
	2567	! This routine is called only by client (compute) tasks.
	2568	!
	2569	! This is not yet supported.
	2570	!</DESCRIPTION>
	2571	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2572	IMPLICIT NONE
	2573	INTEGER , INTENT(IN) :: DataHandle
	2574	CHARACTER() , INTENT(IN) :: Element
	2575	CHARACTER() , INTENT(IN) :: DateStr
	2576	logical :: Data(*)
	2577	INTEGER , INTENT(IN) :: Count
	2578	INTEGER :: OutCount
	2579	INTEGER :: Status
	2580	#endif
	2581	RETURN
	2582	END SUBROUTINE wrf_quilt_get_dom_td_logical
	2583
	2584	SUBROUTINE wrf_quilt_put_dom_td_logical ( DataHandle,Element, DateStr, Data, Count, Status )
	2585	!<DESCRIPTION>
	2586	! Instruct the I/O quilt servers to write Count words of time dependent
	2587	! domain metadata named "Element" valid at time DateStr
	2588	! to the open dataset described by DataHandle.
	2589	! Metadata of type logical are
	2590	! copied from array Data.
	2591	! This routine is called only by client (compute) tasks.
	2592	!
	2593	! This is not yet supported.
	2594	!</DESCRIPTION>
	2595	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2596	IMPLICIT NONE
	2597	INTEGER , INTENT(IN) :: DataHandle
	2598	CHARACTER() , INTENT(IN) :: Element
	2599	CHARACTER() , INTENT(IN) :: DateStr
	2600	logical , INTENT(IN) :: Data(*)
	2601	INTEGER , INTENT(IN) :: Count
	2602	INTEGER :: Status
	2603	#endif
	2604	RETURN
	2605	END SUBROUTINE wrf_quilt_put_dom_td_logical
	2606
	2607	SUBROUTINE wrf_quilt_get_dom_td_char ( DataHandle,Element, DateStr, Data, Status )
	2608	!<DESCRIPTION>
	2609	! Instruct the I/O quilt servers to attempt to read time dependent
	2610	! domain metadata named "Element" valid at time DateStr
	2611	! from the open dataset described by DataHandle.
	2612	! Metadata of type char are
	2613	! stored in string Data.
	2614	! This routine is called only by client (compute) tasks.
	2615	!
	2616	! This is not yet supported.
	2617	!</DESCRIPTION>
	2618	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2619	IMPLICIT NONE
	2620	INTEGER , INTENT(IN) :: DataHandle
	2621	CHARACTER() , INTENT(IN) :: Element
	2622	CHARACTER() , INTENT(IN) :: DateStr
	2623	CHARACTER() :: Data
	2624	INTEGER :: Status
	2625	#endif
	2626	RETURN
	2627	END SUBROUTINE wrf_quilt_get_dom_td_char
	2628
	2629	SUBROUTINE wrf_quilt_put_dom_td_char ( DataHandle,Element, DateStr, Data, Status )
	2630	!<DESCRIPTION>
	2631	! Instruct $he I/O quilt servers to write time dependent
	2632	! domain metadata named "Element" valid at time DateStr
	2633	! to the open dataset described by DataHandle.
	2634	! Metadata of type char are
	2635	! copied from string Data.
	2636	! This routine is called only by client (compute) tasks.
	2637	!
	2638	! This is not yet supported.
	2639	!</DESCRIPTION>
	2640	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2641	IMPLICIT NONE
	2642	INTEGER , INTENT(IN) :: DataHandle
	2643	CHARACTER() , INTENT(IN) :: Element
	2644	CHARACTER() , INTENT(IN) :: DateStr
	2645	CHARACTER() , INTENT(IN) :: Data
	2646	INTEGER :: Status
	2647	#endif
	2648	RETURN
	2649	END SUBROUTINE wrf_quilt_put_dom_td_char
	2650
	2651	SUBROUTINE wrf_quilt_get_var_ti_real ( DataHandle,Element, Varname, Data, Count, Outcount, Status )
	2652	!<DESCRIPTION>
	2653	! Instruct the I/O quilt servers to attempt to read Count words of time
	2654	! independent attribute "Element" of variable "Varname"
	2655	! from the open dataset described by DataHandle.
	2656	! Attribute of type real is
	2657	! stored in array Data.
	2658	! Actual number of words read is returned in OutCount.
	2659	! This routine is called only by client (compute) tasks.
	2660	!
	2661	! This is not yet supported.
	2662	!</DESCRIPTION>
	2663	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2664	IMPLICIT NONE
	2665	INTEGER , INTENT(IN) :: DataHandle
	2666	CHARACTER() , INTENT(IN) :: Element
	2667	CHARACTER() , INTENT(IN) :: VarName
	2668	real :: Data(*)
	2669	INTEGER , INTENT(IN) :: Count
	2670	INTEGER :: OutCount
	2671	INTEGER :: Status
	2672	#endif
	2673	RETURN
	2674	END SUBROUTINE wrf_quilt_get_var_ti_real
	2675
	2676	SUBROUTINE wrf_quilt_put_var_ti_real ( DataHandle,Element, Varname, Data, Count, Status )
	2677	!<DESCRIPTION>
	2678	! Instruct the I/O quilt servers to write Count words of time independent
	2679	! attribute "Element" of variable "Varname"
	2680	! to the open dataset described by DataHandle.
	2681	! Attribute of type real is
	2682	! copied from array Data.
	2683	! This routine is called only by client (compute) tasks.
	2684	!
	2685	! This is not yet supported.
	2686	!</DESCRIPTION>
	2687	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2688	IMPLICIT NONE
	2689	INTEGER , INTENT(IN) :: DataHandle
	2690	CHARACTER() , INTENT(IN) :: Element
	2691	CHARACTER() , INTENT(IN) :: VarName
	2692	real , INTENT(IN) :: Data(*)
	2693	INTEGER , INTENT(IN) :: Count
	2694	INTEGER :: Status
	2695	#endif
	2696	RETURN
	2697	END SUBROUTINE wrf_quilt_put_var_ti_real
	2698
	2699	SUBROUTINE wrf_quilt_get_var_ti_double ( DataHandle,Element, Varname, Data, Count, Outcount, Status )
	2700	!<DESCRIPTION>
	2701	! Instruct the I/O quilt servers to attempt to read Count words of time
	2702	! independent attribute "Element" of variable "Varname"
	2703	! from the open dataset described by DataHandle.
	2704	! Attribute of type double is
	2705	! stored in array Data.
	2706	! Actual number of words read is returned in OutCount.
	2707	! This routine is called only by client (compute) tasks.
	2708	!
	2709	! This is not yet supported.
	2710	!</DESCRIPTION>
	2711	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2712	IMPLICIT NONE
	2713	INTEGER , INTENT(IN) :: DataHandle
	2714	CHARACTER() , INTENT(IN) :: Element
	2715	CHARACTER() , INTENT(IN) :: VarName
	2716	real8 :: Data()
	2717	INTEGER , INTENT(IN) :: Count
	2718	INTEGER :: OutCount
	2719	INTEGER :: Status
	2720	#endif
	2721	CALL wrf_error_fatal('wrf_quilt_get_var_ti_double not supported yet')
	2722	RETURN
	2723	END SUBROUTINE wrf_quilt_get_var_ti_double
	2724
	2725	SUBROUTINE wrf_quilt_put_var_ti_double ( DataHandle,Element, Varname, Data, Count, Status )
	2726	!<DESCRIPTION>
	2727	! Instruct the I/O quilt servers to write Count words of time independent
	2728	! attribute "Element" of variable "Varname"
	2729	! to the open dataset described by DataHandle.
	2730	! Attribute of type double is
	2731	! copied from array Data.
	2732	! This routine is called only by client (compute) tasks.
	2733	!
	2734	! This is not yet supported.
	2735	!</DESCRIPTION>
	2736	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2737	IMPLICIT NONE
	2738	INTEGER , INTENT(IN) :: DataHandle
	2739	CHARACTER() , INTENT(IN) :: Element
	2740	CHARACTER() , INTENT(IN) :: VarName
	2741	real8 , INTENT(IN) :: Data()
	2742	INTEGER , INTENT(IN) :: Count
	2743	INTEGER :: Status
	2744	#endif
	2745	CALL wrf_error_fatal('wrf_quilt_put_var_ti_double not supported yet')
	2746	RETURN
	2747	END SUBROUTINE wrf_quilt_put_var_ti_double
	2748
	2749	SUBROUTINE wrf_quilt_get_var_ti_integer ( DataHandle,Element, Varname, Data, Count, Outcount, Status )
	2750	!<DESCRIPTION>
	2751	! Instruct the I/O quilt servers to attempt to read Count words of time
	2752	! independent attribute "Element" of variable "Varname"
	2753	! from the open dataset described by DataHandle.
	2754	! Attribute of type integer is
	2755	! stored in array Data.
	2756	! Actual number of words read is returned in OutCount.
	2757	! This routine is called only by client (compute) tasks.
	2758	!
	2759	! This is not yet supported.
	2760	!</DESCRIPTION>
	2761	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2762	IMPLICIT NONE
	2763	INTEGER , INTENT(IN) :: DataHandle
	2764	CHARACTER() , INTENT(IN) :: Element
	2765	CHARACTER() , INTENT(IN) :: VarName
	2766	integer :: Data(*)
	2767	INTEGER , INTENT(IN) :: Count
	2768	INTEGER :: OutCount
	2769	INTEGER :: Status
	2770	#endif
	2771	RETURN
	2772	END SUBROUTINE wrf_quilt_get_var_ti_integer
	2773
	2774	SUBROUTINE wrf_quilt_put_var_ti_integer ( DataHandle,Element, Varname, Data, Count, Status )
	2775	!<DESCRIPTION>
	2776	! Instruct the I/O quilt servers to write Count words of time independent
	2777	! attribute "Element" of variable "Varname"
	2778	! to the open dataset described by DataHandle.
	2779	! Attribute of type integer is
	2780	! copied from array Data.
	2781	! This routine is called only by client (compute) tasks.
	2782	!
	2783	! This is not yet supported.
	2784	!</DESCRIPTION>
	2785	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2786	IMPLICIT NONE
	2787	INTEGER , INTENT(IN) :: DataHandle
	2788	CHARACTER() , INTENT(IN) :: Element
	2789	CHARACTER() , INTENT(IN) :: VarName
	2790	integer , INTENT(IN) :: Data(*)
	2791	INTEGER , INTENT(IN) :: Count
	2792	INTEGER :: Status
	2793	#endif
	2794	RETURN
	2795	END SUBROUTINE wrf_quilt_put_var_ti_integer
	2796
	2797	SUBROUTINE wrf_quilt_get_var_ti_logical ( DataHandle,Element, Varname, Data, Count, Outcount, Status )
	2798	!<DESCRIPTION>
	2799	! Instruct the I/O quilt servers to attempt to read Count words of time
	2800	! independent attribute "Element" of variable "Varname"
	2801	! from the open dataset described by DataHandle.
	2802	! Attribute of type logical is
	2803	! stored in array Data.
	2804	! Actual number of words read is returned in OutCount.
	2805	! This routine is called only by client (compute) tasks.
	2806	!
	2807	! This is not yet supported.
	2808	!</DESCRIPTION>
	2809	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2810	IMPLICIT NONE
	2811	INTEGER , INTENT(IN) :: DataHandle
	2812	CHARACTER() , INTENT(IN) :: Element
	2813	CHARACTER() , INTENT(IN) :: VarName
	2814	logical :: Data(*)
	2815	INTEGER , INTENT(IN) :: Count
	2816	INTEGER :: OutCount
	2817	INTEGER :: Status
	2818	#endif
	2819	RETURN
	2820	END SUBROUTINE wrf_quilt_get_var_ti_logical
	2821
	2822	SUBROUTINE wrf_quilt_put_var_ti_logical ( DataHandle,Element, Varname, Data, Count, Status )
	2823	!<DESCRIPTION>
	2824	! Instruct the I/O quilt servers to write Count words of time independent
	2825	! attribute "Element" of variable "Varname"
	2826	! to the open dataset described by DataHandle.
	2827	! Attribute of type logical is
	2828	! copied from array Data.
	2829	! This routine is called only by client (compute) tasks.
	2830	!
	2831	! This is not yet supported.
	2832	!</DESCRIPTION>
	2833	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2834	IMPLICIT NONE
	2835	INTEGER , INTENT(IN) :: DataHandle
	2836	CHARACTER() , INTENT(IN) :: Element
	2837	CHARACTER() , INTENT(IN) :: VarName
	2838	logical , INTENT(IN) :: Data(*)
	2839	INTEGER , INTENT(IN) :: Count
	2840	INTEGER :: Status
	2841	#endif
	2842	RETURN
	2843	END SUBROUTINE wrf_quilt_put_var_ti_logical
	2844
	2845	SUBROUTINE wrf_quilt_get_var_ti_char ( DataHandle,Element, Varname, Data, Status )
	2846	!<DESCRIPTION>
	2847	! Instruct the I/O quilt servers to attempt to read time independent
	2848	! attribute "Element" of variable "Varname"
	2849	! from the open dataset described by DataHandle.
	2850	! Attribute of type char is
	2851	! stored in string Data.
	2852	! This routine is called only by client (compute) tasks.
	2853	!
	2854	! This is not yet supported.
	2855	!</DESCRIPTION>
	2856	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2857	IMPLICIT NONE
	2858	INTEGER , INTENT(IN) :: DataHandle
	2859	CHARACTER() , INTENT(IN) :: Element
	2860	CHARACTER() , INTENT(IN) :: VarName
	2861	CHARACTER() :: Data
	2862	INTEGER :: Status
	2863	#endif
	2864	RETURN
	2865	END SUBROUTINE wrf_quilt_get_var_ti_char
	2866
	2867	SUBROUTINE wrf_quilt_put_var_ti_char ( DataHandle,Element, Varname, Data, Status )
	2868	!<DESCRIPTION>
	2869	! Instruct the I/O quilt servers to write time independent
	2870	! attribute "Element" of variable "Varname"
	2871	! to the open dataset described by DataHandle.
	2872	! Attribute of type char is
	2873	! copied from string Data.
	2874	! This routine is called only by client (compute) tasks.
	2875	!</DESCRIPTION>
	2876
	2877	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2878	USE module_wrf_quilt
	2879	IMPLICIT NONE
	2880	INCLUDE 'mpif.h'
	2881	#include "intio_tags.h"
	2882	INTEGER , INTENT(IN) :: DataHandle
	2883	CHARACTER() , INTENT(IN) :: Element
	2884	CHARACTER() , INTENT(IN) :: VarName
	2885	CHARACTER() , INTENT(IN) :: Data
	2886	INTEGER :: Status
	2887	INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group
	2888	REAL dummy
	2889	!
	2890
	2891	!JMTIMING CALL start_timing
	2892	CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_var_ti_char' )
	2893
	2894	IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
	2895	IF ( int_handle_in_use( DataHandle ) ) THEN
	2896	CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr )
	2897	IF ( wrf_dm_on_monitor() ) THEN
	2898	CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
	2899	DataHandle, TRIM(Element), TRIM(VarName), TRIM(Data), int_var_ti_char )
	2900	ELSE
	2901	CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
	2902	ENDIF
	2903	iserver = get_server_id ( DataHandle )
	2904	CALL get_mpi_comm_io_groups( comm_io_group , iserver )
	2905	CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
	2906
	2907	!JMTIMING CALL start_timing
	2908	! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
	2909	reduced = 0
	2910	reduced(1) = hdrbufsize
	2911	IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
	2912	CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, &
	2913	MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me
	2914	comm_io_group, ierr )
	2915	!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_var_ti_char")
	2916	! send data to the i/o processor
	2917	CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, &
	2918	onebyte, &
	2919	hdrbuf, hdrbufsize , &
	2920	dummy, 0 )
	2921	ENDIF
	2922	ENDIF
	2923	!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_char" )
	2924
	2925	#endif
	2926	RETURN
	2927	END SUBROUTINE wrf_quilt_put_var_ti_char
	2928
	2929	SUBROUTINE wrf_quilt_get_var_td_real ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status )
	2930	!<DESCRIPTION>
	2931	! Instruct the I/O quilt servers to attempt to read Count words of time
	2932	! dependent attribute "Element" of variable "Varname" valid at time DateStr
	2933	! from the open dataset described by DataHandle.
	2934	! Attribute of type real is
	2935	! stored in array Data.
	2936	! Actual number of words read is returned in OutCount.
	2937	! This routine is called only by client (compute) tasks.
	2938	!
	2939	! This is not yet supported.
	2940	!</DESCRIPTION>
	2941	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2942	IMPLICIT NONE
	2943	INTEGER , INTENT(IN) :: DataHandle
	2944	CHARACTER() , INTENT(IN) :: Element
	2945	CHARACTER() , INTENT(IN) :: DateStr
	2946	CHARACTER() , INTENT(IN) :: VarName
	2947	real :: Data(*)
	2948	INTEGER , INTENT(IN) :: Count
	2949	INTEGER :: OutCount
	2950	INTEGER :: Status
	2951	#endif
	2952	RETURN
	2953	END SUBROUTINE wrf_quilt_get_var_td_real
	2954
	2955	SUBROUTINE wrf_quilt_put_var_td_real ( DataHandle,Element, DateStr,Varname, Data, Count, Status )
	2956	!<DESCRIPTION>
	2957	! Instruct the I/O quilt servers to write Count words of time dependent
	2958	! attribute "Element" of variable "Varname" valid at time DateStr
	2959	! to the open dataset described by DataHandle.
	2960	! Attribute of type real is
	2961	! copied from array Data.
	2962	! This routine is called only by client (compute) tasks.
	2963	!
	2964	! This is not yet supported.
	2965	!</DESCRIPTION>
	2966	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2967	IMPLICIT NONE
	2968	INTEGER , INTENT(IN) :: DataHandle
	2969	CHARACTER() , INTENT(IN) :: Element
	2970	CHARACTER() , INTENT(IN) :: DateStr
	2971	CHARACTER() , INTENT(IN) :: VarName
	2972	real , INTENT(IN) :: Data(*)
	2973	INTEGER , INTENT(IN) :: Count
	2974	INTEGER :: Status
	2975	#endif
	2976	RETURN
	2977	END SUBROUTINE wrf_quilt_put_var_td_real
	2978
	2979	SUBROUTINE wrf_quilt_get_var_td_double ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status )
	2980	!<DESCRIPTION>
	2981	! Instruct the I/O quilt servers to attempt to read Count words of time
	2982	! dependent attribute "Element" of variable "Varname" valid at time DateStr
	2983	! from the open dataset described by DataHandle.
	2984	! Attribute of type double is
	2985	! stored in array Data.
	2986	! Actual number of words read is returned in OutCount.
	2987	! This routine is called only by client (compute) tasks.
	2988	!
	2989	! This is not yet supported.
	2990	!</DESCRIPTION>
	2991	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	2992	IMPLICIT NONE
	2993	INTEGER , INTENT(IN) :: DataHandle
	2994	CHARACTER() , INTENT(IN) :: Element
	2995	CHARACTER() , INTENT(IN) :: DateStr
	2996	CHARACTER() , INTENT(IN) :: VarName
	2997	real8 :: Data()
	2998	INTEGER , INTENT(IN) :: Count
	2999	INTEGER :: OutCount
	3000	INTEGER :: Status
	3001	#endif
	3002	CALL wrf_error_fatal('wrf_quilt_get_var_td_double not supported yet')
	3003	RETURN
	3004	END SUBROUTINE wrf_quilt_get_var_td_double
	3005
	3006	SUBROUTINE wrf_quilt_put_var_td_double ( DataHandle,Element, DateStr,Varname, Data, Count, Status )
	3007	!<DESCRIPTION>
	3008	! Instruct the I/O quilt servers to write Count words of time dependent
	3009	! attribute "Element" of variable "Varname" valid at time DateStr
	3010	! to the open dataset described by DataHandle.
	3011	! Attribute of type double is
	3012	! copied from array Data.
	3013	! This routine is called only by client (compute) tasks.
	3014	!
	3015	! This is not yet supported.
	3016	!</DESCRIPTION>
	3017	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	3018	IMPLICIT NONE
	3019	INTEGER , INTENT(IN) :: DataHandle
	3020	CHARACTER() , INTENT(IN) :: Element
	3021	CHARACTER() , INTENT(IN) :: DateStr
	3022	CHARACTER() , INTENT(IN) :: VarName
	3023	real8 , INTENT(IN) :: Data()
	3024	INTEGER , INTENT(IN) :: Count
	3025	INTEGER :: Status
	3026	#endif
	3027	CALL wrf_error_fatal('wrf_quilt_put_var_td_double not supported yet')
	3028	RETURN
	3029	END SUBROUTINE wrf_quilt_put_var_td_double
	3030
	3031	SUBROUTINE wrf_quilt_get_var_td_integer ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount,Status)
	3032	!<DESCRIPTION>
	3033	! Instruct the I/O quilt servers to attempt to read Count words of time
	3034	! dependent attribute "Element" of variable "Varname" valid at time DateStr
	3035	! from the open dataset described by DataHandle.
	3036	! Attribute of type integer is
	3037	! stored in array Data.
	3038	! Actual number of words read is returned in OutCount.
	3039	! This routine is called only by client (compute) tasks.
	3040	!
	3041	! This is not yet supported.
	3042	!</DESCRIPTION>
	3043	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	3044	IMPLICIT NONE
	3045	INTEGER , INTENT(IN) :: DataHandle
	3046	CHARACTER() , INTENT(IN) :: Element
	3047	CHARACTER() , INTENT(IN) :: DateStr
	3048	CHARACTER() , INTENT(IN) :: VarName
	3049	integer :: Data(*)
	3050	INTEGER , INTENT(IN) :: Count
	3051	INTEGER :: OutCount
	3052	INTEGER :: Status
	3053	#endif
	3054	RETURN
	3055	END SUBROUTINE wrf_quilt_get_var_td_integer
	3056
	3057	SUBROUTINE wrf_quilt_put_var_td_integer ( DataHandle,Element, DateStr,Varname, Data, Count, Status )
	3058	!<DESCRIPTION>
	3059	! Instruct the I/O quilt servers to write Count words of time dependent
	3060	! attribute "Element" of variable "Varname" valid at time DateStr
	3061	! to the open dataset described by DataHandle.
	3062	! Attribute of type integer is
	3063	! copied from array Data.
	3064	! This routine is called only by client (compute) tasks.
	3065	!
	3066	! This is not yet supported.
	3067	!</DESCRIPTION>
	3068	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	3069	IMPLICIT NONE
	3070	INTEGER , INTENT(IN) :: DataHandle
	3071	CHARACTER() , INTENT(IN) :: Element
	3072	CHARACTER() , INTENT(IN) :: DateStr
	3073	CHARACTER() , INTENT(IN) :: VarName
	3074	integer , INTENT(IN) :: Data(*)
	3075	INTEGER , INTENT(IN) :: Count
	3076	INTEGER :: Status
	3077	#endif
	3078	RETURN
	3079	END SUBROUTINE wrf_quilt_put_var_td_integer
	3080
	3081	SUBROUTINE wrf_quilt_get_var_td_logical ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status )
	3082	!<DESCRIPTION>
	3083	! Instruct the I/O quilt servers to attempt to read Count words of time
	3084	! dependent attribute "Element" of variable "Varname" valid at time DateStr
	3085	! from the open dataset described by DataHandle.
	3086	! Attribute of type logical is
	3087	! stored in array Data.
	3088	! Actual number of words read is returned in OutCount.
	3089	! This routine is called only by client (compute) tasks.
	3090	!
	3091	! This is not yet supported.
	3092	!</DESCRIPTION>
	3093	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	3094	IMPLICIT NONE
	3095	INTEGER , INTENT(IN) :: DataHandle
	3096	CHARACTER() , INTENT(IN) :: Element
	3097	CHARACTER() , INTENT(IN) :: DateStr
	3098	CHARACTER() , INTENT(IN) :: VarName
	3099	logical :: Data(*)
	3100	INTEGER , INTENT(IN) :: Count
	3101	INTEGER :: OutCount
	3102	INTEGER :: Status
	3103	#endif
	3104	RETURN
	3105	END SUBROUTINE wrf_quilt_get_var_td_logical
	3106
	3107	SUBROUTINE wrf_quilt_put_var_td_logical ( DataHandle,Element, DateStr,Varname, Data, Count, Status )
	3108	!<DESCRIPTION>
	3109	! Instruct the I/O quilt servers to write Count words of time dependent
	3110	! attribute "Element" of variable "Varname" valid at time DateStr
	3111	! to the open dataset described by DataHandle.
	3112	! Attribute of type logical is
	3113	! copied from array Data.
	3114	! This routine is called only by client (compute) tasks.
	3115	!
	3116	! This is not yet supported.
	3117	!</DESCRIPTION>
	3118	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	3119	IMPLICIT NONE
	3120	INTEGER , INTENT(IN) :: DataHandle
	3121	CHARACTER() , INTENT(IN) :: Element
	3122	CHARACTER() , INTENT(IN) :: DateStr
	3123	CHARACTER() , INTENT(IN) :: VarName
	3124	logical , INTENT(IN) :: Data(*)
	3125	INTEGER , INTENT(IN) :: Count
	3126	INTEGER :: Status
	3127	#endif
	3128	RETURN
	3129	END SUBROUTINE wrf_quilt_put_var_td_logical
	3130
	3131	SUBROUTINE wrf_quilt_get_var_td_char ( DataHandle,Element, DateStr,Varname, Data, Status )
	3132	!<DESCRIPTION>
	3133	! Instruct the I/O quilt servers to attempt to read time dependent
	3134	! attribute "Element" of variable "Varname" valid at time DateStr
	3135	! from the open dataset described by DataHandle.
	3136	! Attribute of type char is
	3137	! stored in string Data.
	3138	! This routine is called only by client (compute) tasks.
	3139	!
	3140	! This is not yet supported.
	3141	!</DESCRIPTION>
	3142	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	3143	IMPLICIT NONE
	3144	INTEGER , INTENT(IN) :: DataHandle
	3145	CHARACTER() , INTENT(IN) :: Element
	3146	CHARACTER() , INTENT(IN) :: DateStr
	3147	CHARACTER() , INTENT(IN) :: VarName
	3148	CHARACTER() :: Data
	3149	INTEGER :: Status
	3150	#endif
	3151	RETURN
	3152	END SUBROUTINE wrf_quilt_get_var_td_char
	3153
	3154	SUBROUTINE wrf_quilt_put_var_td_char ( DataHandle,Element, DateStr,Varname, Data, Status )
	3155	!<DESCRIPTION>
	3156	! Instruct the I/O quilt servers to write time dependent
	3157	! attribute "Element" of variable "Varname" valid at time DateStr
	3158	! to the open dataset described by DataHandle.
	3159	! Attribute of type char is
	3160	! copied from string Data.
	3161	! This routine is called only by client (compute) tasks.
	3162	!
	3163	! This is not yet supported.
	3164	!</DESCRIPTION>
	3165	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	3166	IMPLICIT NONE
	3167	INTEGER , INTENT(IN) :: DataHandle
	3168	CHARACTER() , INTENT(IN) :: Element
	3169	CHARACTER() , INTENT(IN) :: DateStr
	3170	CHARACTER() , INTENT(IN) :: VarName
	3171	CHARACTER() , INTENT(IN) :: Data
	3172	INTEGER :: Status
	3173	#endif
	3174	RETURN
	3175	END SUBROUTINE wrf_quilt_put_var_td_char
	3176
	3177	SUBROUTINE wrf_quilt_read_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, &
	3178	DomainDesc , MemoryOrder , Stagger , DimNames , &
	3179	DomainStart , DomainEnd , &
	3180	MemoryStart , MemoryEnd , &
	3181	PatchStart , PatchEnd , &
	3182	Status )
	3183	!<DESCRIPTION>
	3184	! Instruct the I/O quilt servers to read the variable named VarName from the
	3185	! dataset pointed to by DataHandle.
	3186	! This routine is called only by client (compute) tasks.
	3187	!
	3188	! This is not yet supported.
	3189	!</DESCRIPTION>
	3190	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	3191	IMPLICIT NONE
	3192	INTEGER , INTENT(IN) :: DataHandle
	3193	CHARACTER() , INTENT(INOUT) :: DateStr
	3194	CHARACTER() , INTENT(INOUT) :: VarName
	3195	INTEGER , INTENT(INOUT) :: Field(*)
	3196	integer ,intent(in) :: FieldType
	3197	integer ,intent(inout) :: Comm
	3198	integer ,intent(inout) :: IOComm
	3199	integer ,intent(in) :: DomainDesc
	3200	character() ,intent(in) :: MemoryOrder
	3201	character() ,intent(in) :: Stagger
	3202	character() , dimension (*) ,intent(in) :: DimNames
	3203	integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd
	3204	integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd
	3205	integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd
	3206	integer ,intent(out) :: Status
	3207	Status = 0
	3208	#endif
	3209	RETURN
	3210	END SUBROUTINE wrf_quilt_read_field
	3211
	3212	SUBROUTINE wrf_quilt_write_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, &
	3213	DomainDesc , MemoryOrder , Stagger , DimNames , &
	3214	DomainStart , DomainEnd , &
	3215	MemoryStart , MemoryEnd , &
	3216	PatchStart , PatchEnd , &
	3217	Status )
	3218	!<DESCRIPTION>
	3219	! Prepare instructions for the I/O quilt servers to write the variable named
	3220	! VarName to the dataset pointed to by DataHandle.
	3221	!
	3222	! During a "training" write this routine accumulates number and sizes of
	3223	! messages that will be sent to the I/O server associated with this compute
	3224	! (client) task.
	3225	!
	3226	! During a "real" write, this routine begins by allocating
	3227	! int_local_output_buffer if it has not already been allocated. Sizes
	3228	! accumulated during "training" are used to determine how big
	3229	! int_local_output_buffer must be. This routine then stores "int_field"
	3230	! headers and associated field data in int_local_output_buffer. The contents
	3231	! of int_local_output_buffer are actually sent to the I/O quilt server in
	3232	! routine wrf_quilt_iosync(). This scheme allows output of multiple variables
	3233	! to be aggregated into a single "iosync" operation.
	3234	! This routine is called only by client (compute) tasks.
	3235	!</DESCRIPTION>
	3236	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	3237	USE module_state_description
	3238	USE module_wrf_quilt
	3239	IMPLICIT NONE
	3240	INCLUDE 'mpif.h'
	3241	#include "wrf_io_flags.h"
	3242	INTEGER , INTENT(IN) :: DataHandle
	3243	CHARACTER() , INTENT(IN) :: DateStr
	3244	CHARACTER() , INTENT(IN) :: VarName
	3245	! INTEGER , INTENT(IN) :: Field(*)
	3246	integer ,intent(in) :: FieldType
	3247	integer ,intent(inout) :: Comm
	3248	integer ,intent(inout) :: IOComm
	3249	integer ,intent(in) :: DomainDesc
	3250	character() ,intent(in) :: MemoryOrder
	3251	character() ,intent(in) :: Stagger
	3252	character() , dimension (*) ,intent(in) :: DimNames
	3253	integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd
	3254	integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd
	3255	integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd
	3256	integer ,intent(out) :: Status
	3257
	3258	integer ii,jj,kk,myrank
	3259
	3260	REAL, DIMENSION( MemoryStart(1):MemoryEnd(1), &
	3261	MemoryStart(2):MemoryEnd(2), &
	3262	MemoryStart(3):MemoryEnd(3) ) :: Field
	3263	INTEGER locsize , typesize, itypesize
	3264	INTEGER ierr, tasks_in_group, comm_io_group, dummy, i
	3265	INTEGER, EXTERNAL :: use_package
	3266
	3267	!JMTIMING CALL start_timing
	3268	CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_write_field' )
	3269
	3270	IF ( .NOT. (DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles) ) THEN
	3271	CALL wrf_error_fatal("frame/module_io_quilt.F: wrf_quilt_write_field: invalid data handle" )
	3272	ENDIF
	3273	IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
	3274	CALL wrf_error_fatal("frame/module_io_quilt.F: wrf_quilt_write_field: DataHandle not opened" )
	3275	ENDIF
	3276
	3277	locsize = (PatchEnd(1)-PatchStart(1)+1)* &
	3278	(PatchEnd(2)-PatchStart(2)+1)* &
	3279	(PatchEnd(3)-PatchStart(3)+1)
	3280
	3281	CALL mpi_type_size( MPI_INTEGER, itypesize, ierr )
	3282	! Note that the WRF_DOUBLE branch of this IF statement must come first since
	3283	! WRF_FLOAT is set equal to WRF_DOUBLE during autopromotion builds.
	3284	IF ( FieldType .EQ. WRF_DOUBLE ) THEN
	3285	CALL mpi_type_size( MPI_DOUBLE_PRECISION, typesize, ierr )
	3286	ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
	3287	CALL mpi_type_size( MPI_REAL, typesize, ierr )
	3288	ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
	3289	CALL mpi_type_size( MPI_INTEGER, typesize, ierr )
	3290	ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
	3291	CALL mpi_type_size( MPI_LOGICAL, typesize, ierr )
	3292	ENDIF
	3293
	3294	IF ( .NOT. okay_to_write( DataHandle ) ) THEN
	3295
	3296	! This is a "training" write.
	3297	! it is not okay to actually write; what we do here is just "bookkeep": count up
	3298	! the number and size of messages that we will output to io server associated with
	3299	! this task
	3300
	3301	CALL int_gen_write_field_header ( hdrbuf, hdrbufsize, itypesize, typesize, &
	3302	DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, &
	3303	333933 , MemoryOrder , Stagger , DimNames , & ! 333933 means training; magic number
	3304	DomainStart , DomainEnd , &
	3305	MemoryStart , MemoryEnd , &
	3306	PatchStart , PatchEnd )
	3307
	3308	int_num_bytes_to_write(DataHandle) = int_num_bytes_to_write(DataHandle) + locsize * typesize + hdrbufsize
	3309
	3310	! Send the hdr for the write in case the interface is calling the I/O API in "learn" mode
	3311
	3312	iserver = get_server_id ( DataHandle )
	3313	!JMDEBUGwrite(0,*)'wrf_quilt_write_field (dryrun) ',iserver
	3314	CALL get_mpi_comm_io_groups( comm_io_group , iserver )
	3315	! send the size of my local buffer to the i/o task (obufsize doesnt mean anything here)
	3316
	3317	CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr )
	3318
	3319	#if 0
	3320	IF ( .NOT. wrf_dm_on_monitor() ) THEN ! only one task in compute grid sends this message; send noops on others
	3321	CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
	3322	ENDIF
	3323	#endif
	3324
	3325
	3326	!JMTIMING CALL start_timing
	3327	! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side)
	3328	reduced = 0
	3329	reduced(1) = hdrbufsize
	3330	IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle
	3331	CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, &
	3332	MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me
	3333	comm_io_group, ierr )
	3334	!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_write_field dryrun")
	3335	! send data to the i/o processor
	3336
	3337	CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, &
	3338	onebyte, &
	3339	hdrbuf, hdrbufsize , &
	3340	dummy, 0 )
	3341
	3342	ELSE
	3343
	3344	IF ( .NOT. associated( int_local_output_buffer ) ) THEN
	3345	ALLOCATE ( int_local_output_buffer( (int_num_bytes_to_write( DataHandle )+1)/itypesize ) )
	3346	int_local_output_cursor = 1
	3347	ENDIF
	3348	iserver = get_server_id ( DataHandle )
	3349	!JMDEBUGwrite(0,*)'wrf_quilt_write_field (writing) ',iserver
	3350
	3351	! This is NOT a "training" write. It is OK to write now.
	3352	CALL int_gen_write_field_header ( hdrbuf, hdrbufsize, itypesize, typesize, &
	3353	DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, &
	3354	0 , MemoryOrder , Stagger , DimNames , & ! non-333933 means okay to write; magic number
	3355	DomainStart , DomainEnd , &
	3356	MemoryStart , MemoryEnd , &
	3357	PatchStart , PatchEnd )
	3358
	3359	! Pack header into int_local_output_buffer. It will be sent to the
	3360	! I/O servers during the next "iosync" operation.
	3361	#ifdef DEREF_KLUDGE
	3362	CALL int_pack_data ( hdrbuf , hdrbufsize , int_local_output_buffer(1), int_local_output_cursor )
	3363	#else
	3364	CALL int_pack_data ( hdrbuf , hdrbufsize , int_local_output_buffer, int_local_output_cursor )
	3365	#endif
	3366
	3367	! Pack field data into int_local_output_buffer. It will be sent to the
	3368	! I/O servers during the next "iosync" operation.
	3369	#ifdef DEREF_KLUDGE
	3370	CALL int_pack_data ( Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3) ), &
	3371	locsize * typesize , int_local_output_buffer(1), int_local_output_cursor )
	3372	#else
	3373	CALL int_pack_data ( Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3) ), &
	3374	locsize * typesize , int_local_output_buffer, int_local_output_cursor )
	3375	#endif
	3376
	3377	ENDIF
	3378	Status = 0
	3379	!JMTIMING CALL end_timing("wrf_quilt_write_field")
	3380
	3381	#endif
	3382	RETURN
	3383	END SUBROUTINE wrf_quilt_write_field
	3384
	3385	SUBROUTINE wrf_quilt_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagger , &
	3386	DomainStart , DomainEnd , Status )
	3387	!<DESCRIPTION>
	3388	! This routine applies only to a dataset that is open for read. It instructs
	3389	! the I/O quilt servers to return information about variable VarName.
	3390	! This routine is called only by client (compute) tasks.
	3391	!
	3392	! This is not yet supported.
	3393	!</DESCRIPTION>
	3394	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	3395	IMPLICIT NONE
	3396	integer ,intent(in) :: DataHandle
	3397	character() ,intent(in) :: VarName
	3398	integer :: NDim
	3399	character() :: MemoryOrder
	3400	character() :: Stagger
	3401	integer ,dimension(*) :: DomainStart, DomainEnd
	3402	integer :: Status
	3403	#endif
	3404	RETURN
	3405	END SUBROUTINE wrf_quilt_get_var_info
	3406
	3407	SUBROUTINE get_mpi_comm_io_groups( retval, isrvr )
	3408	!<DESCRIPTION>
	3409	! This routine returns the compute+io communicator to which this
	3410	! compute task belongs for I/O server group "isrvr".
	3411	! This routine is called only by client (compute) tasks.
	3412	!</DESCRIPTION>
	3413	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	3414	USE module_wrf_quilt
	3415	IMPLICIT NONE
	3416	INTEGER, INTENT(IN ) :: isrvr
	3417	INTEGER, INTENT(OUT) :: retval
	3418	retval = mpi_comm_io_groups(isrvr)
	3419	#endif
	3420	RETURN
	3421	END SUBROUTINE get_mpi_comm_io_groups
	3422
	3423	SUBROUTINE get_nio_tasks_in_group( retval )
	3424	!<DESCRIPTION>
	3425	! This routine returns the number of I/O server tasks in each
	3426	! I/O server group. It can be called by both clients and
	3427	! servers.
	3428	!</DESCRIPTION>
	3429	#if defined( DM_PARALLEL ) && !defined( STUBMPI )
	3430	USE module_wrf_quilt
	3431	IMPLICIT NONE
	3432	INTEGER, INTENT(OUT) :: retval
	3433	retval = nio_tasks_in_group
	3434	#endif
	3435	RETURN
	3436	END SUBROUTINE get_nio_tasks_in_group
	3437
	3438	SUBROUTINE collect_on_comm_debug(file,line, comm_io_group, &
	3439	sze, &
	3440	hdrbuf, hdrbufsize , &
	3441	outbuf, outbufsize )
	3442	IMPLICIT NONE
	3443	CHARACTER() file
	3444	INTEGER line
	3445	INTEGER comm_io_group
	3446	INTEGER sze
	3447	INTEGER hdrbuf(), outbuf()
	3448	INTEGER hdrbufsize, outbufsize
	3449
	3450	! write(0,*)'collect_on_comm_debug ',trim(file),line,sze,hdrbufsize,outbufsize
	3451	CALL collect_on_comm( comm_io_group, &
	3452	sze, &
	3453	hdrbuf, hdrbufsize , &
	3454	outbuf, outbufsize )
	3455	! write(0,*)trim(file),line,'returning'
	3456	RETURN
	3457	END
	3458
	3459
	3460	SUBROUTINE collect_on_comm_debug2(file,line,var,tag,sz,hdr_rec_size, comm_io_group, &
	3461	sze, &
	3462	hdrbuf, hdrbufsize , &
	3463	outbuf, outbufsize )
	3464	IMPLICIT NONE
	3465	CHARACTER() file,var
	3466	INTEGER line,tag,sz,hdr_rec_size
	3467	INTEGER comm_io_group
	3468	INTEGER sze
	3469	INTEGER hdrbuf(), outbuf()
	3470	INTEGER hdrbufsize, outbufsize
	3471
	3472	! write(0,*)'collect_on_comm_debug2 ',trim(file),line,trim(var),tag,sz,hdr_rec_size,sze,hdrbufsize,outbufsize
	3473	CALL collect_on_comm( comm_io_group, &
	3474	sze, &
	3475	hdrbuf, hdrbufsize , &
	3476	outbuf, outbufsize )
	3477	! write(0,*)'collect_on_comm_debug2 ',trim(file),line,'returning for ',trim(var)
	3478	RETURN
	3479	END

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

Download in other formats:

Original Format