Context Navigation

module_io_quilt.F

Last change on this file 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

Line
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