Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

module_quilt_outbuf_ops.F @ 1400

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

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

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 69.6 KB

Line
1	MODULE module_quilt_outbuf_ops
2	!<DESCRIPTION>
3	!<PRE>
4	! This module contains routines and data structures used by the I/O quilt
5	! servers to assemble fields ("quilting") and write them to disk.
6	!</PRE>
7	!</DESCRIPTION>
8	INTEGER, PARAMETER :: tabsize = 1000
9	INTEGER, SAVE :: num_entries
10
11	! ARP, for PNC-enabled quilting, 02/06/2010
12	TYPE varpatch
13	LOGICAL :: forDeletion ! TRUE if patch to be
14	! deleted
15	INTEGER, DIMENSION(3) :: PatchStart, PatchEnd, PatchExtent
16	REAL, POINTER, DIMENSION(:,:,:) :: rptr
17	INTEGER, POINTER, DIMENSION(:,:,:) :: iptr
18	END TYPE varpatch
19
20	! With PNC-enabled quilting, each table entry consists of a series of
21	! 'npatch' patches (one for each of the compute PEs that this IOServer has
22	! as clients). We attempt to stitch these together before finally
23	! writing the data to disk.
24	TYPE outpatchlist
25	CHARACTER*80 :: VarName, DateStr, MemoryOrder, &
26	Stagger, DimNames(3)
27	INTEGER, DIMENSION(3) :: DomainStart, DomainEnd
28	INTEGER :: FieldType
29	! Total no. of patches in the list PatchList
30	INTEGER :: nPatch
31	! How many of the patches remain active in PatchList
32	INTEGER :: nActivePatch
33	TYPE(varpatch), DIMENSION(tabsize) :: PatchList
34	END TYPE outpatchlist
35
36	TYPE(outpatchlist), DIMENSION(tabsize), SAVE :: outpatch_table
37
38	! List of which of the initial set of patches saved by the IOServer have
39	! been successfully stitched together. Without any stitching, each patch's
40	! entry contains just itself:
41	! JoinedPatches(1,ipatch) = ipatch
42	! If jpatch is then stitched to ipatch then we do:
43	! JoinedPatches(2,ipatch) = jpatch
44	! and so on.
45	INTEGER, ALLOCATABLE, DIMENSION(:,:), SAVE :: JoinedPatches
46
47	! The no. of original patches to be stitched together to make each new patch
48	! i.e. if the 2nd new patch consists of 4 of the original patches stitched
49	! together then:
50	! PatchCount(2) = 4
51	INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: PatchCount
52
53	! endARP, for PNC-enabled quilting, 02/06/2010
54
55	TYPE outrec
56	CHARACTER*80 :: VarName, DateStr, MemoryOrder, &
57	Stagger, DimNames(3)
58	INTEGER :: ndim
59	INTEGER, DIMENSION(3) :: DomainStart, DomainEnd
60	INTEGER :: FieldType
61	REAL, POINTER, DIMENSION(:,:,:) :: rptr
62	INTEGER, POINTER, DIMENSION(:,:,:) :: iptr
63	END TYPE outrec
64
65	TYPE(outrec), DIMENSION(tabsize) :: outbuf_table
66
67	CONTAINS
68
69	SUBROUTINE init_outbuf
70	!<DESCRIPTION>
71	!<PRE>
72	! This routine re-initializes module data structures.
73	!</PRE>
74	!</DESCRIPTION>
75	IMPLICIT NONE
76	INTEGER :: i, j
77	DO i = 1, tabsize
78
79	#ifdef PNETCDF_QUILT
80	! This section for PNC-enabled IO quilting
81	outpatch_table(i)%VarName = ""
82	outpatch_table(i)%DateStr = ""
83	outpatch_table(i)%MemoryOrder = ""
84	outpatch_table(i)%Stagger = ""
85	outpatch_table(i)%DimNames(1:3) = ""
86	outpatch_table(i)%DomainStart(1:3) = 0
87	outpatch_table(i)%DomainEnd(1:3) = 0
88	outpatch_table(i)%npatch = 0
89	outpatch_table(i)%nActivePatch = 0
90	! We don't free any memory here - that is done immediately after the
91	! write of each patch is completed
92	DO j = 1, tabsize
93	outpatch_table(i)%PatchList(j)%forDeletion = .FALSE.
94	outpatch_table(i)%PatchList(j)%PatchStart(:) = 0
95	outpatch_table(i)%PatchList(j)%PatchEnd(:) = 0
96	outpatch_table(i)%PatchList(j)%PatchExtent(:)= 0
97	NULLIFY( outpatch_table(i)%PatchList(j)%rptr )
98	NULLIFY( outpatch_table(i)%PatchList(j)%iptr )
99	END DO
100	#else
101	outbuf_table(i)%VarName = ""
102	outbuf_table(i)%DateStr = ""
103	outbuf_table(i)%MemoryOrder = ""
104	outbuf_table(i)%Stagger = ""
105	outbuf_table(i)%DimNames(1) = ""
106	outbuf_table(i)%DimNames(2) = ""
107	outbuf_table(i)%DimNames(3) = ""
108	outbuf_table(i)%ndim = 0
109	NULLIFY( outbuf_table(i)%rptr )
110	NULLIFY( outbuf_table(i)%iptr )
111	#endif
112
113	ENDDO
114	num_entries = 0
115	END SUBROUTINE init_outbuf
116
117	#ifdef PNETCDF_QUILT
118	SUBROUTINE write_outbuf_pnc ( DataHandle, io_form_arg, local_comm, &
119	mytask, ntasks )
120	!<DESCRIPTION>
121	!<PRE>
122	! This routine writes all of the records stored in outpatch_table to the
123	! file referenced by DataHandle using pNetCDF. The patches constituting
124	! each record are stitched together as far as is possible before
125	! the pNetCDF I/O routines are called to accomplish the write.
126	!
127	! It then re-initializes module data structures.
128	!</PRE>
129	!</DESCRIPTION>
130	USE module_state_description
131	IMPLICIT NONE
132	INCLUDE 'mpif.h'
133	#include "wrf_io_flags.h"
134	INTEGER , INTENT(IN) :: DataHandle, io_form_arg, &
135	local_comm, mytask, ntasks
136	INTEGER :: ii, jj
137	INTEGER :: DomainDesc ! dummy
138	INTEGER :: Status
139	INTEGER :: ipatch, icnt
140	! INTEGER, DIMENSION(1) :: count_in, count_out
141	INTEGER, ALLOCATABLE, DIMENSION(:) :: count_buf
142	INTEGER :: min_count
143	LOGICAL :: do_indep_write ! If no. of patches differs between
144	! IO Servers then we will have to
145	! switch pnetcdf into
146	! independent-writes mode for some
147	! of them
148	CHARACTER*256 :: mess
149
150	DomainDesc = 0
151
152	ALLOCATE(count_buf(ntasks), Stat=Status)
153	IF(Status /= 0)THEN
154	CALL wrf_error_fatal("write_outbuf_pnc: allocate failed")
155	END IF
156
157	WRITE(mess,"('write_outbuf_pnc: table has ', I3,' entries')") num_entries
158	CALL wrf_message(mess)
159
160	DO ii = 1, num_entries
161
162	WRITE(mess,*)'write_outbuf_pnc: writing ', &
163	TRIM(outpatch_table(ii)%DateStr)," ", &
164	TRIM(outpatch_table(ii)%VarName)," ", &
165	TRIM(outpatch_table(ii)%MemoryOrder)
166	CALL wrf_message(mess)
167
168	SELECT CASE ( io_form_arg )
169
170	CASE ( IO_PNETCDF )
171
172	! Situation is more complicated in this case since field data stored
173	! as a list of patches rather than in one array of global-domain
174	! extent.
175	! PatchStart(1) - PatchEnd(1) is dimension with unit stride.
176
177	! Quilt patches back together where possible in order to minimise
178	! number of individual writes
179	CALL stitch_outbuf_patches(ii)
180
181	! Check how many patches each of the other IO servers has - we can
182	! only use pNetCDF in collective mode for the same no. of writes
183	! on each IO server. Any other patches will have to be written in
184	! independent mode.
185	!!$ count_in(1) = outpatch_table(ii)%npatch
186	!!$ CALL MPI_AllReduce( count_in, count_out, 1, MPI_INTEGER, &
187	!!$ MPI_MIN, local_comm, Status )
188	!!$ WRITE(mess,*) 'ARPDBG: Min. no. of patches is ',count_out(1)
189	!!$ CALL wrf_message(mess)
190	!!$ WRITE(mess,*) 'ARPDBG: I have ',count_in(1),' patches.'
191	!!$ CALL wrf_message(mess)
192	do_indep_write = .FALSE.
193	count_buf(:) = 0
194	min_count = outpatch_table(ii)%nActivePatch
195	! WRITE(mess,*) 'ARPDBG: before gather, I have ',min_count,' patches.'
196	! CALL wrf_message(mess)
197
198	CALL MPI_AllGather(min_count, 1, MPI_INTEGER, &
199	count_buf, 1, MPI_INTEGER, &
200	local_comm, Status)
201	! count_buf(mytask+1) = outpatch_table(ii)%npatch
202	! CALL MPI_AllGather(MPI_IN_PLACE,0, MPI_DATATYPE_NULL, &
203	! count_buf, ntasks, MPI_INTEGER, &
204	! local_comm, Status)
205
206	! Work out the minimum no. of patches on any IO Server and whether
207	! or not we will have to enter independent IO mode.
208	min_count = outpatch_table(ii)%nActivePatch
209	DO jj=1,ntasks, 1
210	IF(count_buf(jj) < min_count) min_count = count_buf(jj)
211	IF(outpatch_table(ii)%npatch /= count_buf(jj)) do_indep_write = .TRUE.
212
213	END DO
214
215	! WRITE(mess,*) 'ARPDBG: Min. no. of patches is ', min_count
216	! CALL wrf_message(mess)
217	! WRITE(mess,*) 'ARPDBG: I have ',count_buf(mytask+1),' patches.'
218	! CALL wrf_message(mess)
219
220	! WRITE(mess,"('Field: ',I3, ' domain start = ',3I4)") ii, outpatch_table(ii)%DomainStart(1:3)
221	! CALL wrf_message(mess)
222	! WRITE(mess,"(10x,' domain end = ',3I4)") outpatch_table(ii)%DomainEnd(1:3)
223	! CALL wrf_message(mess)
224
225	IF ( outpatch_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN
226
227	! Loop over the patches in this field up to the number that
228	! every IO Server has. This is slightly tricky now
229	! that some of them may be 'deleted.'
230
231	ipatch = 0
232	icnt = 0
233	DO WHILE ( icnt < min_count )
234
235	ipatch = ipatch + 1
236
237	IF(outpatch_table(ii)%PatchList(ipatch)%forDeletion) CYCLE
238
239	icnt = icnt + 1
240
241	WRITE (mess, "('Calling write for patch: ',I3, ' Start = ',3I4)") ipatch, outpatch_table(ii)%PatchList(ipatch)%PatchStart(1:3)
242	CALL wrf_message(mess)
243	WRITE (mess,"(29x,'End = ',3I4)") outpatch_table(ii)%PatchList(ipatch)%PatchEnd(1:3)
244	CALL wrf_message(mess)
245
246	CALL ext_pnc_write_field ( DataHandle , &
247	TRIM(outpatch_table(ii)%DateStr), &
248	TRIM(outpatch_table(ii)%VarName), &
249	outpatch_table(ii)%PatchList(ipatch)%rptr, &
250	outpatch_table(ii)%FieldType, &!*
251	local_comm, local_comm, DomainDesc , &
252	TRIM(outpatch_table(ii)%MemoryOrder), &
253	TRIM(outpatch_table(ii)%Stagger), &!*
254	outpatch_table(ii)%DimNames , &!*
255	outpatch_table(ii)%DomainStart, &
256	outpatch_table(ii)%DomainEnd, &
257	! ARP supply magic number as MemoryStart and
258	! MemoryEnd to signal that this routine is
259	! being called from quilting.
260	-998899, &
261	-998899, &
262	outpatch_table(ii)%PatchList(ipatch)%PatchStart,&
263	outpatch_table(ii)%PatchList(ipatch)%PatchEnd, &
264	Status )
265
266	! Free memory associated with this patch
267	DEALLOCATE(outpatch_table(ii)%PatchList(ipatch)%rptr)
268
269	END DO
270
271	IF( do_indep_write )THEN
272	! We must do the next few patches (if any) in independent IO
273	! mode as not all of the IO Servers have the same no. of
274	! patches.
275	! outpatch_table(ii)%npatch holds the no. of live patches for
276	! this IO Server
277
278	CALL ext_pnc_start_independent_mode(DataHandle, Status)
279
280	DO WHILE ( icnt<outpatch_table(ii)%nActivePatch )
281
282	ipatch = ipatch + 1
283
284	IF(outpatch_table(ii)%PatchList(ipatch)%forDeletion) CYCLE
285
286	icnt = icnt + 1
287
288	CALL ext_pnc_write_field ( DataHandle , &
289	TRIM(outpatch_table(ii)%DateStr), &
290	TRIM(outpatch_table(ii)%VarName), &
291	outpatch_table(ii)%PatchList(ipatch)%rptr, &
292	outpatch_table(ii)%FieldType, &!*
293	local_comm, local_comm, DomainDesc , &
294	TRIM(outpatch_table(ii)%MemoryOrder), &
295	TRIM(outpatch_table(ii)%Stagger), &!*
296	outpatch_table(ii)%DimNames , &!*
297	outpatch_table(ii)%DomainStart, &
298	outpatch_table(ii)%DomainEnd, &
299	! ARP supply magic number as MemoryStart and
300	! MemoryEnd to signal that this routine is
301	! being called from quilting.
302	-998899, &
303	-998899, &
304	outpatch_table(ii)%PatchList(ipatch)%PatchStart,&
305	outpatch_table(ii)%PatchList(ipatch)%PatchEnd, &
306	Status )
307
308	! Free memory associated with this patch
309	DEALLOCATE(outpatch_table(ii)%PatchList(ipatch)%rptr)
310
311	END DO
312
313	! End of patches that not every IO Server has so can switch
314	! back to collective mode.
315	CALL ext_pnc_end_independent_mode(DataHandle, Status)
316
317
318	END IF ! Additional patches
319
320	ELSE IF ( outpatch_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN
321
322	! Loop over the patches in this field up to the number that
323	! every IO Server has. This is slightly tricky now
324	! that some of them may be 'deleted.'
325	ipatch = 0
326	icnt = 0
327	DO WHILE ( icnt < min_count )
328
329	ipatch = ipatch + 1
330
331	IF(outpatch_table(ii)%PatchList(ipatch)%forDeletion) CYCLE
332
333	icnt = icnt + 1
334
335	CALL ext_pnc_write_field ( DataHandle , &
336	TRIM(outpatch_table(ii)%DateStr), &
337	TRIM(outpatch_table(ii)%VarName), &
338	outpatch_table(ii)%PatchList(ipatch)%iptr, &
339	outpatch_table(ii)%FieldType, &!*
340	local_comm, local_comm, DomainDesc, &
341	TRIM(outpatch_table(ii)%MemoryOrder), &
342	TRIM(outpatch_table(ii)%Stagger), &!*
343	outpatch_table(ii)%DimNames , &!*
344	outpatch_table(ii)%DomainStart, &
345	outpatch_table(ii)%DomainEnd, &
346	! ARP supply magic number as MemoryStart and
347	! MemoryEnd to signal that this routine is
348	! being called from quilting.
349	-998899, &
350	-998899, &
351	outpatch_table(ii)%PatchList(ipatch)%PatchStart, &
352	outpatch_table(ii)%PatchList(ipatch)%PatchEnd, &
353	Status )
354
355	! Free memory associated with this patch
356	DEALLOCATE(outpatch_table(ii)%PatchList(ipatch)%iptr)
357
358	END DO
359
360	IF( do_indep_write )THEN
361
362	! We have to do the next few patches in independent IO mode as
363	! not all of the IO Servers have this many patches.
364	! outpatch_table(ii)%npatch holds the no. of live patches for
365	! this IO Server
366	CALL ext_pnc_start_independent_mode(DataHandle, Status)
367
368	DO WHILE ( icnt<outpatch_table(ii)%nActivePatch )
369
370	ipatch = ipatch + 1
371
372	IF(outpatch_table(ii)%PatchList(ipatch)%forDeletion) CYCLE
373
374	icnt = icnt + 1
375
376	CALL ext_pnc_write_field ( DataHandle , &
377	TRIM(outpatch_table(ii)%DateStr), &
378	TRIM(outpatch_table(ii)%VarName), &
379	outpatch_table(ii)%PatchList(ipatch)%iptr, &
380	outpatch_table(ii)%FieldType, &!*
381	local_comm, local_comm, DomainDesc , &
382	TRIM(outpatch_table(ii)%MemoryOrder), &
383	TRIM(outpatch_table(ii)%Stagger), &!*
384	outpatch_table(ii)%DimNames , &!*
385	outpatch_table(ii)%DomainStart, &
386	outpatch_table(ii)%DomainEnd, &
387	! ARP supply magic number as MemoryStart and
388	! MemoryEnd to signal that this routine is
389	! being called from quilting.
390	-998899, &
391	-998899, &
392	outpatch_table(ii)%PatchList(ipatch)%PatchStart,&
393	outpatch_table(ii)%PatchList(ipatch)%PatchEnd, &
394	Status )
395
396	! Free memory associated with this patch
397	DEALLOCATE(outpatch_table(ii)%PatchList(ipatch)%iptr)
398
399	END DO
400
401	! End of patches that not every IO Server has so can switch
402	! back to collective mode.
403	CALL ext_pnc_end_independent_mode(DataHandle, Status)
404
405	ENDIF ! Have additional patches
406	ENDIF
407
408	CASE DEFAULT
409	END SELECT
410
411	ENDDO ! Loop over output buffers
412
413	! Reset the table of output buffers
414	CALL init_outbuf()
415
416	DEALLOCATE(count_buf)
417
418	END SUBROUTINE write_outbuf_pnc
419	#endif
420
421	SUBROUTINE write_outbuf ( DataHandle , io_form_arg )
422	!<DESCRIPTION>
423	!<PRE>
424	! This routine writes all of the records stored in outbuf_table to the
425	! file referenced by DataHandle using format specified by io_form_arg.
426	! This routine calls the package-specific I/O routines to accomplish
427	! the write.
428	! It then re-initializes module data structures.
429	!</PRE>
430	!</DESCRIPTION>
431	USE module_state_description
432	IMPLICIT NONE
433	#include "wrf_io_flags.h"
434	INTEGER , INTENT(IN) :: DataHandle, io_form_arg
435	INTEGER :: ii,ds1,de1,ds2,de2,ds3,de3
436	INTEGER :: Comm, IOComm, DomainDesc ! dummy
437	INTEGER :: Status
438	CHARACTER*256 :: mess
439	Comm = 0 ; IOComm = 0 ; DomainDesc = 0
440
441	DO ii = 1, num_entries
442	WRITE(mess,*)'writing ', &
443	TRIM(outbuf_table(ii)%DateStr)," ", &
444	TRIM(outbuf_table(ii)%VarName)," ", &
445	TRIM(outbuf_table(ii)%MemoryOrder)
446	ds1 = outbuf_table(ii)%DomainStart(1) ; de1 = outbuf_table(ii)%DomainEnd(1)
447	ds2 = outbuf_table(ii)%DomainStart(2) ; de2 = outbuf_table(ii)%DomainEnd(2)
448	ds3 = outbuf_table(ii)%DomainStart(3) ; de3 = outbuf_table(ii)%DomainEnd(3)
449
450	SELECT CASE ( io_form_arg )
451
452	#ifdef NETCDF
453	CASE ( IO_NETCDF )
454
455	IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN
456
457	CALL ext_ncd_write_field ( DataHandle , &
458	TRIM(outbuf_table(ii)%DateStr), &
459	TRIM(outbuf_table(ii)%VarName), &
460	outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3), &
461	outbuf_table(ii)%FieldType, & !*
462	Comm, IOComm, DomainDesc , &
463	TRIM(outbuf_table(ii)%MemoryOrder), &
464	TRIM(outbuf_table(ii)%Stagger), & !*
465	outbuf_table(ii)%DimNames , & !*
466	outbuf_table(ii)%DomainStart, &
467	outbuf_table(ii)%DomainEnd, &
468	outbuf_table(ii)%DomainStart, &
469	outbuf_table(ii)%DomainEnd, &
470	outbuf_table(ii)%DomainStart, &
471	outbuf_table(ii)%DomainEnd, &
472	Status )
473
474	ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN
475	CALL ext_ncd_write_field ( DataHandle , &
476	TRIM(outbuf_table(ii)%DateStr), &
477	TRIM(outbuf_table(ii)%VarName), &
478	outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3), &
479	outbuf_table(ii)%FieldType, & !*
480	Comm, IOComm, DomainDesc , &
481	TRIM(outbuf_table(ii)%MemoryOrder), &
482	TRIM(outbuf_table(ii)%Stagger), & !*
483	outbuf_table(ii)%DimNames , & !*
484	outbuf_table(ii)%DomainStart, &
485	outbuf_table(ii)%DomainEnd, &
486	outbuf_table(ii)%DomainStart, &
487	outbuf_table(ii)%DomainEnd, &
488	outbuf_table(ii)%DomainStart, &
489	outbuf_table(ii)%DomainEnd, &
490	Status )
491	ENDIF
492	#endif
493	#ifdef YYY
494	CASE ( IO_YYY )
495
496	IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN
497
498	CALL ext_yyy_write_field ( DataHandle , &
499	TRIM(outbuf_table(ii)%DateStr), &
500	TRIM(outbuf_table(ii)%VarName), &
501	outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3), &
502	outbuf_table(ii)%FieldType, & !*
503	Comm, IOComm, DomainDesc , &
504	TRIM(outbuf_table(ii)%MemoryOrder), &
505	TRIM(outbuf_table(ii)%Stagger), & !*
506	outbuf_table(ii)%DimNames , & !*
507	outbuf_table(ii)%DomainStart, &
508	outbuf_table(ii)%DomainEnd, &
509	outbuf_table(ii)%DomainStart, &
510	outbuf_table(ii)%DomainEnd, &
511	outbuf_table(ii)%DomainStart, &
512	outbuf_table(ii)%DomainEnd, &
513	Status )
514
515	ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN
516	CALL ext_yyy_write_field ( DataHandle , &
517	TRIM(outbuf_table(ii)%DateStr), &
518	TRIM(outbuf_table(ii)%VarName), &
519	outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3), &
520	outbuf_table(ii)%FieldType, & !*
521	Comm, IOComm, DomainDesc , &
522	TRIM(outbuf_table(ii)%MemoryOrder), &
523	TRIM(outbuf_table(ii)%Stagger), & !*
524	outbuf_table(ii)%DimNames , & !*
525	outbuf_table(ii)%DomainStart, &
526	outbuf_table(ii)%DomainEnd, &
527	outbuf_table(ii)%DomainStart, &
528	outbuf_table(ii)%DomainEnd, &
529	outbuf_table(ii)%DomainStart, &
530	outbuf_table(ii)%DomainEnd, &
531	Status )
532	ENDIF
533	#endif
534	#ifdef GRIB1
535	CASE ( IO_GRIB1 )
536
537	IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN
538
539	CALL ext_gr1_write_field ( DataHandle , &
540	TRIM(outbuf_table(ii)%DateStr), &
541	TRIM(outbuf_table(ii)%VarName), &
542	outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3), &
543	outbuf_table(ii)%FieldType, & !*
544	Comm, IOComm, DomainDesc , &
545	TRIM(outbuf_table(ii)%MemoryOrder), &
546	TRIM(outbuf_table(ii)%Stagger), & !*
547	outbuf_table(ii)%DimNames , & !*
548	outbuf_table(ii)%DomainStart, &
549	outbuf_table(ii)%DomainEnd, &
550	outbuf_table(ii)%DomainStart, &
551	outbuf_table(ii)%DomainEnd, &
552	outbuf_table(ii)%DomainStart, &
553	outbuf_table(ii)%DomainEnd, &
554	Status )
555
556	ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN
557	CALL ext_gr1_write_field ( DataHandle , &
558	TRIM(outbuf_table(ii)%DateStr), &
559	TRIM(outbuf_table(ii)%VarName), &
560	outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3), &
561	outbuf_table(ii)%FieldType, & !*
562	Comm, IOComm, DomainDesc , &
563	TRIM(outbuf_table(ii)%MemoryOrder), &
564	TRIM(outbuf_table(ii)%Stagger), & !*
565	outbuf_table(ii)%DimNames , & !*
566	outbuf_table(ii)%DomainStart, &
567	outbuf_table(ii)%DomainEnd, &
568	outbuf_table(ii)%DomainStart, &
569	outbuf_table(ii)%DomainEnd, &
570	outbuf_table(ii)%DomainStart, &
571	outbuf_table(ii)%DomainEnd, &
572	Status )
573	ENDIF
574	#endif
575	#ifdef GRIB2
576	CASE ( IO_GRIB2 )
577
578	IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN
579
580	CALL ext_gr2_write_field ( DataHandle , &
581	TRIM(outbuf_table(ii)%DateStr), &
582	TRIM(outbuf_table(ii)%VarName), &
583	outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3), &
584	outbuf_table(ii)%FieldType, & !*
585	Comm, IOComm, DomainDesc , &
586	TRIM(outbuf_table(ii)%MemoryOrder), &
587	TRIM(outbuf_table(ii)%Stagger), & !*
588	outbuf_table(ii)%DimNames , & !*
589	outbuf_table(ii)%DomainStart, &
590	outbuf_table(ii)%DomainEnd, &
591	outbuf_table(ii)%DomainStart, &
592	outbuf_table(ii)%DomainEnd, &
593	outbuf_table(ii)%DomainStart, &
594	outbuf_table(ii)%DomainEnd, &
595	Status )
596
597	ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN
598	CALL ext_gr2_write_field ( DataHandle , &
599	TRIM(outbuf_table(ii)%DateStr), &
600	TRIM(outbuf_table(ii)%VarName), &
601	outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3), &
602	outbuf_table(ii)%FieldType, & !*
603	Comm, IOComm, DomainDesc , &
604	TRIM(outbuf_table(ii)%MemoryOrder), &
605	TRIM(outbuf_table(ii)%Stagger), & !*
606	outbuf_table(ii)%DimNames , & !*
607	outbuf_table(ii)%DomainStart, &
608	outbuf_table(ii)%DomainEnd, &
609	outbuf_table(ii)%DomainStart, &
610	outbuf_table(ii)%DomainEnd, &
611	outbuf_table(ii)%DomainStart, &
612	outbuf_table(ii)%DomainEnd, &
613	Status )
614	ENDIF
615	#endif
616	#ifdef INTIO
617	CASE ( IO_INTIO )
618	IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN
619
620	CALL ext_int_write_field ( DataHandle , &
621	TRIM(outbuf_table(ii)%DateStr), &
622	TRIM(outbuf_table(ii)%VarName), &
623	outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3), &
624	outbuf_table(ii)%FieldType, & !*
625	Comm, IOComm, DomainDesc , &
626	TRIM(outbuf_table(ii)%MemoryOrder), &
627	TRIM(outbuf_table(ii)%Stagger), & !*
628	outbuf_table(ii)%DimNames , & !*
629	outbuf_table(ii)%DomainStart, &
630	outbuf_table(ii)%DomainEnd, &
631	outbuf_table(ii)%DomainStart, &
632	outbuf_table(ii)%DomainEnd, &
633	outbuf_table(ii)%DomainStart, &
634	outbuf_table(ii)%DomainEnd, &
635	Status )
636
637	ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN
638
639	CALL ext_int_write_field ( DataHandle , &
640	TRIM(outbuf_table(ii)%DateStr), &
641	TRIM(outbuf_table(ii)%VarName), &
642	outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3), &
643	outbuf_table(ii)%FieldType, & !*
644	Comm, IOComm, DomainDesc , &
645	TRIM(outbuf_table(ii)%MemoryOrder), &
646	TRIM(outbuf_table(ii)%Stagger), & !*
647	outbuf_table(ii)%DimNames , & !*
648	outbuf_table(ii)%DomainStart, &
649	outbuf_table(ii)%DomainEnd, &
650	outbuf_table(ii)%DomainStart, &
651	outbuf_table(ii)%DomainEnd, &
652	outbuf_table(ii)%DomainStart, &
653	outbuf_table(ii)%DomainEnd, &
654	Status )
655
656	ENDIF
657	#endif
658	CASE DEFAULT
659	END SELECT
660
661
662	IF ( ASSOCIATED( outbuf_table(ii)%rptr) ) DEALLOCATE(outbuf_table(ii)%rptr)
663	IF ( ASSOCIATED( outbuf_table(ii)%iptr) ) DEALLOCATE(outbuf_table(ii)%iptr)
664	NULLIFY( outbuf_table(ii)%rptr )
665	NULLIFY( outbuf_table(ii)%iptr )
666	ENDDO
667	CALL init_outbuf
668	END SUBROUTINE write_outbuf
669
670
671	SUBROUTINE stitch_outbuf_patches(ibuf)
672	USE module_timing
673	IMPLICIT none
674	INTEGER, INTENT(in) :: ibuf
675	!<DESCRIPTION>
676	!<PRE>
677	! This routine does the "output quilting" for the case where quilting has been
678	! built to use Parallel NetCDF. Unlike store_patch_in_outbuf() we do not have
679	! data for the whole domain --- instead we aim to quilt as much of the data as
680	! possible in order to reduce the number of separate writes that we must do.
681	!</PRE>
682	!</DESCRIPTION>
683	#include "wrf_io_flags.h"
684	INTEGER :: ipatch, jpatch, ii
685	INTEGER :: ierr
686	INTEGER :: npatches
687	INTEGER, DIMENSION(3) :: newExtent, pos
688	INTEGER, ALLOCATABLE, DIMENSION(:,:) :: OldPatchStart
689	INTEGER, POINTER, DIMENSION(:,:,:) :: ibuffer
690	REAL, POINTER, DIMENSION(:,:,:) :: rbuffer
691	CHARACTER*256 :: mess
692	integer i,j
693
694	! CALL start_timing()
695
696	IF(LEN_TRIM(outpatch_table(ibuf)%MemoryOrder) < 2)THEN
697	! This field is a scalar or 1D array. Such quantities are replicated
698	! across compute nodes and therefore we need only keep a single
699	! patch - delete all but the first in the list
700	IF ( outpatch_table(ibuf)%FieldType .EQ. WRF_FLOAT ) THEN
701
702	DO jpatch=2,outpatch_table(ibuf)%npatch,1
703	outpatch_table(ibuf)%PatchList(jpatch)%forDeletion = .TRUE.
704	outpatch_table(ibuf)%nActivePatch = &
705	outpatch_table(ibuf)%nActivePatch - 1
706	DEALLOCATE(outpatch_table(ibuf)%PatchList(jpatch)%rptr)
707	END DO
708
709	ELSE IF ( outpatch_table(ibuf)%FieldType .EQ. WRF_INTEGER ) THEN
710
711	DO jpatch=2,outpatch_table(ibuf)%npatch,1
712	outpatch_table(ibuf)%PatchList(jpatch)%forDeletion = .TRUE.
713	outpatch_table(ibuf)%nActivePatch = &
714	outpatch_table(ibuf)%nActivePatch - 1
715	DEALLOCATE(outpatch_table(ibuf)%PatchList(jpatch)%iptr)
716	END DO
717
718	ELSE
719	CALL wrf_error_fatal("stitch_outbuf_patches: unrecognised Field Type")
720	END IF
721
722
723	! CALL end_timing("stitch_outbuf_patches: deleting replicated patches")
724
725	RETURN
726
727	END IF ! Field is scalar or 1D
728
729	! Otherwise, this field _is_ distributed across compute PEs and therefore
730	! it's worth trying to stitch patches together...
731	ALLOCATE(OldPatchStart(3,outpatch_table(ibuf)%npatch), &
732	JoinedPatches(outpatch_table(ibuf)%npatch, &
733	outpatch_table(ibuf)%npatch), &
734	PatchCount(outpatch_table(ibuf)%npatch), &
735	Stat=ierr)
736	IF(ierr /= 0)THEN
737	CALL wrf_message('stitch_outbuf_patches: unable to stitch patches as allocate failed.')
738	RETURN
739	END IF
740
741	JoinedPatches(:,:) = -1
742	NULLIFY(ibuffer)
743	NULLIFY(rbuffer)
744
745	#if 0
746	! ! ARPDBG
747	WRITE(mess,*) "--------------------------"
748	CALL wrf_message(mess)
749	WRITE(mess,"('Field ',I3,': domain end = ', 3I4)") &
750	ibuf, outpatch_table(ibuf)%DomainEnd(1:3)
751	CALL wrf_message(mess)
752	WRITE(mess,*) "stitch_outbuf_patches: initial list of patches:"
753	CALL wrf_message(mess)
754
755	DO jpatch=1,outpatch_table(ibuf)%npatch,1
756
757	! Each patch consists of just itself initially
758	JoinedPatches(1,jpatch) = jpatch
759	PatchCount(jpatch) = 1
760
761	! Store the location of each patch for use after we've decided how to
762	! stitch them together
763	OldPatchStart(:,jpatch) = outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(:)
764
765	WRITE(mess,"('Patch ',I3,': [',I3,': ',I3,'],[',I3,':',I3,'],[',I3,':',I3,']')") jpatch, &
766	outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1), &
767	outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1), &
768	outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2), &
769	outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2), &
770	outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3), &
771	outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3)
772	CALL wrf_message(mess)
773	END DO
774	WRITE(mess,*) "--------------------------"
775	CALL wrf_message(mess)
776	! ARPDBGend
777	#endif
778
779	! Search through patches to find pairs that we can stitch together
780	ipatch = 1
781	OUTER: DO WHILE(ipatch < outpatch_table(ibuf)%npatch)
782
783	IF( outpatch_table(ibuf)%PatchList(ipatch)%forDeletion )THEN
784	ipatch = ipatch + 1
785	CYCLE OUTER
786	END IF
787
788	INNER: DO jpatch=ipatch+1,outpatch_table(ibuf)%npatch,1
789
790	IF(outpatch_table(ibuf)%PatchList(ipatch)%forDeletion )THEN
791	CYCLE INNER
792	END IF
793
794	! Look for patches that can be concatenated with ipatch in the first
795	! dimension (preferred since that is contiguous in memory in F90)
796	! ________________ ____________
797	! \| \| \| \|
798	! Startx(j) Endx(j) Startx(i) Endx(i)
799	!
800	IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1) == &
801	(outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) - 1) )THEN
802
803	! Patches contiguous in first dimension - do they have the same
804	! extents in the other two dimensions?
805	IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2)== &
806	outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) ) .AND.&
807	(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2) == &
808	outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2) ) .AND.&
809	(outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3)== &
810	outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) ) .AND.&
811	(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3) == &
812	outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3)) )THEN
813
814	! We can concatenate these two patches in first dimension
815	! WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 1')") ipatch, jpatch
816	! CALL wrf_message(mess)
817
818	! Grow patch ipatch to include jpatch
819	outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) = &
820	outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1)
821	CALL merge_patches(ibuf, ipatch, jpatch)
822	! Go again...
823	! CALL wrf_message('Re-starting search...')
824	ipatch = 1
825	CYCLE OUTER
826	END IF
827	END IF
828	! ______________ ____________
829	! \| \| \| \|
830	! Startx(i) Endx(i) Startx(j) Endx(j)
831	!
832	IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1) == &
833	(outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1) + 1))THEN
834
835	! Patches contiguous in first dimension - do they have the same
836	! extents in the other two dimensions?
837	IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2)== &
838	outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) ) .AND.&
839	(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2) == &
840	outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2) ) .AND.&
841	(outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3)== &
842	outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) ) .AND.&
843	(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3) == &
844	outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3)) )THEN
845
846	! We can concatenate these two patches in first dimension
847	! WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 1')") ipatch, jpatch
848	! CALL wrf_message(mess)
849
850	! Grow patch ipatch to include jpatch
851	outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1) = &
852	outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1)
853	CALL merge_patches(ibuf, ipatch, jpatch)
854	! Go again...
855	! CALL wrf_message('Re-starting search...')
856	ipatch = 1
857	CYCLE OUTER
858	END IF
859	END IF
860
861	! Try the second dimension
862	IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2) == &
863	(outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) - 1))THEN
864
865	! Patches contiguous in second dimension - do they have the same
866	! extents in the other two dimensions?
867	IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1)== &
868	outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) ) .AND.&
869	(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1) == &
870	outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1) ) .AND.&
871	(outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3)== &
872	outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) ) .AND.&
873	(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3) == &
874	outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3)) )THEN
875
876	! We can concatenate these two patches in second dimension
877	! WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 2')") ipatch, jpatch
878	! CALL wrf_message(mess)
879
880	! Grow patch ipatch to include jpatch
881	outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) = &
882	outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2)
883	CALL merge_patches(ibuf, ipatch, jpatch)
884	! Go again...
885	! CALL wrf_message('Re-starting search...')
886	ipatch = 1
887	CYCLE OUTER
888	END IF
889	END IF
890
891	IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2) == &
892	(outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2) + 1) )THEN
893
894	! Patches contiguous in second dimension - do they have the same
895	! extents in the other two dimensions?
896	IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1)== &
897	outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) ) .AND.&
898	(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1) == &
899	outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1) ) .AND.&
900	(outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3)== &
901	outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) ) .AND.&
902	(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3) == &
903	outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3)) )THEN
904
905	! We can concatenate these two patches in second dimension
906	! WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 2')") ipatch, jpatch
907	! CALL wrf_message(mess)
908
909	! Grow patch ipatch to include jpatch
910	outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2) = &
911	outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2)
912	CALL merge_patches(ibuf, ipatch, jpatch)
913	! Go again...
914	! CALL wrf_message('Re-starting search...')
915	ipatch = 1
916	CYCLE OUTER
917	END IF
918	END IF
919
920	! Try the third dimension
921	IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3) == &
922	(outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) - 1) )THEN
923
924	! Patches contiguous in second dimension - do they have the same
925	! extents in the other two dimensions?
926	IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1)== &
927	outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) ) .AND.&
928	(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1) == &
929	outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1) ) .AND.&
930	(outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2)== &
931	outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) ) .AND.&
932	(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2) == &
933	outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2)) )THEN
934
935	! We can concatenate these two patches in the third dimension
936	! WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 3')") ipatch, jpatch
937	! CALL wrf_message(mess)
938
939	! Grow patch ipatch to include jpatch
940	outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) = &
941	outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3)
942	CALL merge_patches(ibuf, ipatch, jpatch)
943	! Go again...
944	! CALL wrf_message('Re-starting search...')
945	ipatch = 1
946	CYCLE OUTER
947	END IF
948	END IF
949
950	IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3) == &
951	(outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3) + 1))THEN
952
953	! Patches contiguous in second dimension - do they have the same
954	! extents in the other two dimensions?
955	IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1)== &
956	outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) ) .AND.&
957	(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1) == &
958	outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1) ) .AND.&
959	(outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2)== &
960	outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) ) .AND.&
961	(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2) == &
962	outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2)) )THEN
963
964	! We can concatenate these two patches in the third dimension
965	! WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 3')") ipatch, jpatch
966	! CALL wrf_message(mess)
967
968	! Grow patch ipatch to include jpatch
969	outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3) = &
970	outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3)
971	CALL merge_patches(ibuf, ipatch, jpatch)
972	! Go again...
973	! CALL wrf_message('Re-starting search...')
974	ipatch = 1
975	CYCLE OUTER
976	END IF
977	END IF
978
979	END DO INNER
980
981	ipatch = ipatch + 1
982
983	END DO OUTER
984
985	#if 0
986	! ARPDBG
987	CALL wrf_message("--------------------------")
988	CALL wrf_message("Final list of patches:")
989
990	npatches = 0
991
992	DO jpatch=1,outpatch_table(ibuf)%npatch,1
993
994	IF ( outpatch_table(ibuf)%PatchList(jpatch)%forDeletion ) CYCLE
995
996	WRITE(mess,"('Patch ',I3,': [',I3,': ',I3,'],[',I3,':',I3,'],[',I3,':',I3,']')") jpatch, outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1), &
997	outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1), &
998	outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2), &
999	outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2), &
1000	outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3), &
1001	outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3)
1002	CALL wrf_message(mess)
1003
1004	! Count how many patches we're left with
1005	npatches = npatches + 1
1006
1007	! If no patches have been merged together to make this patch then we
1008	! don't have to do any more with it
1009	IF(PatchCount(jpatch) == 1) CYCLE
1010
1011	! Get the extent of this patch
1012	newExtent(:) = outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(:) - &
1013	outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(:) + 1
1014	! Allocate a buffer to hold all of its data
1015	IF ( outpatch_table(ibuf)%FieldType .EQ. WRF_FLOAT ) THEN
1016	ALLOCATE(rbuffer(newExtent(1), newExtent(2), newExtent(3)), &
1017	Stat=ierr)
1018	ELSE IF ( outpatch_table(ibuf)%FieldType .EQ. WRF_INTEGER ) THEN
1019	ALLOCATE(ibuffer(newExtent(1), newExtent(2), newExtent(3)), &
1020	Stat=ierr)
1021	END IF
1022	IF(ierr /= 0)THEN
1023	CALL wrf_error_fatal('stitch_outbuf_patches: unable to stitch patches as allocate for merge buffer failed.')
1024	RETURN
1025	END IF
1026
1027	! Copy data into this buffer from each of the patches that are being
1028	! stitched together
1029	IF( ASSOCIATED(rbuffer) )THEN
1030
1031	! CALL start_timing()
1032
1033	DO ipatch=1,PatchCount(jpatch),1
1034
1035	ii = JoinedPatches(ipatch, jpatch)
1036
1037	! Work out where to put it - the PatchList(i)PatchStart() has been
1038	! updated to hold the start of the newly quilted patch i. It will
1039	! therefore be less than or equal to the starts of each of the
1040	! constituent patches.
1041	pos(:) = OldPatchStart(:,ii) - &
1042	outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(:) + 1
1043	! Do the copy - can use the PatchExtent data here because that
1044	! wasn't modified during the stitching of the patches.
1045
1046	rbuffer(pos(1): pos(1)+outpatch_table(ibuf)%PatchList(ii)%PatchExtent(1)-1, &
1047	pos(2): pos(2)+outpatch_table(ibuf)%PatchList(ii)%PatchExtent(2)-1, &
1048	pos(3): pos(3)+outpatch_table(ibuf)%PatchList(ii)%PatchExtent(3)-1 ) &
1049	= &
1050	outpatch_table(ibuf)%PatchList(ii)%rptr(:, :, :)
1051
1052	! Having copied the data from this patch, we can free-up the
1053	! associated buffer
1054	DEALLOCATE(outpatch_table(ibuf)%PatchList(ii)%rptr)
1055	END DO
1056
1057	! CALL end_timing("Data copy into new real patch")
1058
1059	! Re-assign the pointer associated with this patch to the new,
1060	! larger, buffer containing the quilted patches
1061	outpatch_table(ibuf)%PatchList(jpatch)%rptr => rbuffer
1062
1063	! Unset the original pointer to this buffer
1064	NULLIFY(rbuffer)
1065
1066	ELSE IF( ASSOCIATED(ibuffer) )THEN
1067
1068	! CALL start_timing()
1069
1070	DO ipatch=1,PatchCount(jpatch),1
1071
1072	ii = JoinedPatches(ipatch, jpatch)
1073
1074	! Work out where to put it
1075	pos(:) = OldPatchStart(:,ii) - &
1076	outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(:) + 1
1077	! Do the copy - can use the PatchExtent data here because that
1078	! wasn't modified during the stitching of the patches.
1079	ibuffer(pos(1): &
1080	pos(1)+outpatch_table(ibuf)%PatchList(ii)%PatchExtent(1)-1, &
1081	pos(2): &
1082	pos(2)+outpatch_table(ibuf)%PatchList(ii)%PatchExtent(2)-1, &
1083	pos(3): &
1084	pos(3)+outpatch_table(ibuf)%PatchList(ii)%PatchExtent(3)-1 ) = &
1085	outpatch_table(ibuf)%PatchList(ii)%iptr(:, :, :)
1086
1087	DEALLOCATE(outpatch_table(ibuf)%PatchList(ii)%iptr)
1088	END DO
1089
1090	! CALL end_timing("Data copy into new integer patch")
1091
1092	! Re-assign the pointer associated with this patch to the new,
1093	! larger, buffer containing the quilted patches
1094	outpatch_table(ibuf)%PatchList(jpatch)%iptr => ibuffer
1095	NULLIFY(ibuffer)
1096
1097	END IF
1098
1099	END DO
1100
1101	WRITE(mess,*) "--------------------------"
1102	CALL wrf_message(mess)
1103	! ARPDBGend
1104	#endif
1105
1106	! Record how many patches we're left with
1107	outpatch_table(ibuf)%nPatch = npatches
1108
1109	DEALLOCATE(OldPatchStart, JoinedPatches, PatchCount)
1110
1111	! CALL end_timing("stitch patches")
1112
1113	END SUBROUTINE stitch_outbuf_patches
1114
1115	!-------------------------------------------------------------------------
1116	SUBROUTINE merge_patches(itab, ipatch, jpatch)
1117	INTEGER, INTENT(in) :: itab, ipatch, jpatch
1118	! Merge patch jpatch into patch ipatch and then 'delete' jpatch
1119	INTEGER :: ii
1120
1121	! Keep track of which patches we've merged: ipatch takes
1122	! on all of the original patches which currently make up
1123	! jpatch.
1124	DO ii=1,PatchCount(jpatch),1
1125	PatchCount(ipatch) = PatchCount(ipatch) + 1
1126	JoinedPatches(PatchCount(ipatch),ipatch) = JoinedPatches(ii,jpatch)
1127	END DO
1128	! and mark patch jpatch for deletion
1129	outpatch_table(itab)%PatchList(jpatch)%forDeletion = .TRUE.
1130	! decrement the count of active patches
1131	outpatch_table(itab)%nActivePatch = outpatch_table(itab)%nActivePatch - 1
1132
1133	END SUBROUTINE merge_patches
1134
1135	END MODULE module_quilt_outbuf_ops
1136
1137	! don't let other programs see the definition of this; type mismatches
1138	! on inbuf will result; may want to make a module program at some point
1139	SUBROUTINE store_patch_in_outbuf( inbuf_r, inbuf_i, DateStr, VarName , FieldType, MemoryOrder, Stagger, DimNames, &
1140	DomainStart , DomainEnd , &
1141	MemoryStart , MemoryEnd , &
1142	PatchStart , PatchEnd )
1143	!<DESCRIPTION>
1144	!<PRE>
1145	! This routine does the "output quilting".
1146	!
1147	! It stores a patch in the appropriate location in a domain-sized array
1148	! within an element of the outbuf_table data structure. DateStr, VarName, and
1149	! MemoryOrder are used to uniquely identify which element of outbuf_table is
1150	! associated with this array. If no element is associated, then this routine
1151	! first assigns an unused element and allocates space within that element for
1152	! the globally-sized array. This routine also stores DateStr, VarName,
1153	! FieldType, MemoryOrder, Stagger, DimNames, DomainStart, and DomainEnd within
1154	! the same element of outbuf.
1155	!</PRE>
1156	!</DESCRIPTION>
1157	USE module_quilt_outbuf_ops
1158	IMPLICIT NONE
1159	#include "wrf_io_flags.h"
1160	INTEGER , INTENT(IN) :: FieldType
1161	REAL , DIMENSION(*) , INTENT(IN) :: inbuf_r
1162	INTEGER , DIMENSION(*) , INTENT(IN) :: inbuf_i
1163	INTEGER , DIMENSION(3) , INTENT(IN) :: DomainStart , DomainEnd , MemoryStart , MemoryEnd , PatchStart , PatchEnd
1164	CHARACTER() , INTENT(IN) :: DateStr , VarName, MemoryOrder , Stagger, DimNames(3)
1165	! Local
1166	CHARACTER*256 :: mess
1167	INTEGER :: l,m,n,ii,jj
1168	LOGICAL :: found
1169
1170	! Find the VarName if it's in the buffer already
1171	ii = 1
1172	found = .false.
1173	DO WHILE ( .NOT. found .AND. ii .LE. num_entries )
1174	!TBH: need to test other attributes too!
1175	IF ( TRIM(VarName) .EQ. TRIM(outbuf_table(ii)%VarName) ) THEN
1176	IF ( TRIM(DateStr) .EQ. TRIM(outbuf_table(ii)%DateStr) ) THEN
1177	IF ( TRIM(MemoryOrder) .EQ. TRIM(outbuf_table(ii)%MemoryOrder) ) THEN
1178	found = .true.
1179	ELSE
1180	CALL wrf_error_fatal("store_patch_in_outbuf: memory order disagreement")
1181	ENDIF
1182	ELSE
1183	CALL wrf_error_fatal("store_patch_in_outbuf: multiple dates in buffer")
1184	ENDIF
1185	ELSE
1186	ii = ii + 1
1187	ENDIF
1188	ENDDO
1189	IF ( .NOT. found ) THEN
1190	num_entries = num_entries + 1
1191	IF ( FieldType .EQ. WRF_FLOAT ) THEN
1192	ALLOCATE( outbuf_table(num_entries)%rptr(DomainStart(1):DomainEnd(1), &
1193	DomainStart(2):DomainEnd(2),DomainStart(3):DomainEnd(3)) )
1194	ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
1195	ALLOCATE( outbuf_table(num_entries)%iptr(DomainStart(1):DomainEnd(1), &
1196	DomainStart(2):DomainEnd(2),DomainStart(3):DomainEnd(3)) )
1197	ELSE
1198	write(mess,*)"store_patch_in_outbuf: unsupported type ", FieldType
1199	CALL wrf_error_fatal(mess)
1200	ENDIF
1201	outbuf_table(num_entries)%VarName = TRIM(VarName)
1202	outbuf_table(num_entries)%DateStr = TRIM(DateStr)
1203	outbuf_table(num_entries)%MemoryOrder = TRIM(MemoryOrder)
1204	outbuf_table(num_entries)%Stagger = TRIM(Stagger)
1205	outbuf_table(num_entries)%DimNames(1) = TRIM(DimNames(1))
1206	outbuf_table(num_entries)%DimNames(2) = TRIM(DimNames(2))
1207	outbuf_table(num_entries)%DimNames(3) = TRIM(DimNames(3))
1208	outbuf_table(num_entries)%DomainStart = DomainStart
1209	outbuf_table(num_entries)%DomainEnd = DomainEnd
1210	outbuf_table(num_entries)%FieldType = FieldType
1211	ii = num_entries
1212	ENDIF
1213	jj = 1
1214	IF ( FieldType .EQ. WRF_FLOAT ) THEN
1215	DO n = PatchStart(3),PatchEnd(3)
1216	DO m = PatchStart(2),PatchEnd(2)
1217	DO l = PatchStart(1),PatchEnd(1)
1218	outbuf_table(ii)%rptr(l,m,n) = inbuf_r(jj)
1219	jj = jj + 1
1220	ENDDO
1221	ENDDO
1222	ENDDO
1223	ENDIF
1224	IF ( FieldType .EQ. WRF_INTEGER ) THEN
1225	DO n = PatchStart(3),PatchEnd(3)
1226	DO m = PatchStart(2),PatchEnd(2)
1227	DO l = PatchStart(1),PatchEnd(1)
1228	outbuf_table(ii)%iptr(l,m,n) = inbuf_i(jj)
1229	jj = jj + 1
1230	ENDDO
1231	ENDDO
1232	ENDDO
1233	ENDIF
1234
1235	RETURN
1236
1237	END SUBROUTINE store_patch_in_outbuf
1238
1239	! don't let other programs see the definition of this; type mismatches
1240	! on inbuf will result; may want to make a module program at some point
1241	SUBROUTINE store_patch_in_outbuf_pnc( inbuf_r, inbuf_i, DateStr, VarName , &
1242	FieldType, MemoryOrder, Stagger, &
1243	DimNames,&
1244	DomainStart , DomainEnd , &
1245	MemoryStart , MemoryEnd , &
1246	PatchStart , PatchEnd )
1247	!<DESCRIPTION>
1248	!<PRE>
1249	! This routine stores a patch in an array within an element of the
1250	! outpatch_table%PatchList data structure. DateStr, VarName, and
1251	! MemoryOrder are used to uniquely identify which element of outbuf_table is
1252	! associated with this array. If no element is associated, then this routine
1253	! first assigns an unused element and allocates space within that element.
1254	! This routine also stores DateStr, VarName,
1255	! FieldType, MemoryOrder, Stagger, DimNames, DomainStart, and DomainEnd within
1256	! the same element of outpatch.
1257	!</PRE>
1258	!</DESCRIPTION>
1259	USE module_quilt_outbuf_ops, Only: outpatch_table, tabsize, num_entries
1260	USE module_timing
1261	IMPLICIT NONE
1262	#include "wrf_io_flags.h"
1263	INTEGER , INTENT(IN) :: FieldType
1264	REAL , DIMENSION(*) , INTENT(IN) :: inbuf_r
1265	INTEGER , DIMENSION(*) , INTENT(IN) :: inbuf_i
1266	INTEGER , DIMENSION(3) , INTENT(IN) :: DomainStart , DomainEnd , MemoryStart , MemoryEnd , PatchStart , PatchEnd
1267	CHARACTER() , INTENT(IN) :: DateStr , VarName, MemoryOrder , Stagger, DimNames(3)
1268	! Local
1269	CHARACTER*256 :: mess
1270	INTEGER :: l,m,n,ii,jj,ipatch,ierr
1271	LOGICAL :: found
1272
1273	! CALL start_timing()
1274
1275	! Find the VarName if it's in the buffer already
1276	ii = 1
1277	found = .false.
1278	DO WHILE ( .NOT. found .AND. ii .LE. num_entries )
1279	!TBH: need to test other attributes too!
1280	IF ( TRIM(VarName) .EQ. TRIM(outpatch_table(ii)%VarName) ) THEN
1281	IF ( TRIM(DateStr) .EQ. TRIM(outpatch_table(ii)%DateStr) ) THEN
1282	IF ( TRIM(MemoryOrder) .EQ. TRIM(outpatch_table(ii)%MemoryOrder) ) THEN
1283	found = .true.
1284	ELSE
1285	CALL wrf_error_fatal("store_patch_in_outbuf_pnc: memory order disagreement")
1286	ENDIF
1287	ELSE
1288	CALL wrf_error_fatal("store_patch_in_outbuf_pnc: multiple dates in buffer")
1289	ENDIF
1290	ELSE
1291	ii = ii + 1
1292	ENDIF
1293	ENDDO
1294	IF ( .NOT. found ) THEN
1295	num_entries = num_entries + 1
1296
1297	outpatch_table(num_entries)%npatch = 0
1298
1299	outpatch_table(num_entries)%VarName = TRIM(VarName)
1300	outpatch_table(num_entries)%DateStr = TRIM(DateStr)
1301	outpatch_table(num_entries)%MemoryOrder = TRIM(MemoryOrder)
1302	outpatch_table(num_entries)%Stagger = TRIM(Stagger)
1303	outpatch_table(num_entries)%DimNames(1) = TRIM(DimNames(1))
1304	outpatch_table(num_entries)%DimNames(2) = TRIM(DimNames(2))
1305	outpatch_table(num_entries)%DimNames(3) = TRIM(DimNames(3))
1306	outpatch_table(num_entries)%DomainStart = DomainStart
1307	outpatch_table(num_entries)%DomainEnd = DomainEnd
1308	outpatch_table(num_entries)%FieldType = FieldType
1309	ii = num_entries
1310
1311	WRITE(mess,*)'Adding field entry no. ',num_entries
1312	CALL wrf_message(mess)
1313	WRITE(mess,*)'Variable = ',TRIM(VarName)
1314	CALL wrf_message(mess)
1315	WRITE(mess,*)'Domain start = ',DomainStart(:)
1316	CALL wrf_message(mess)
1317	WRITE(mess,*)'Domain end = ',DomainEnd(:)
1318	CALL wrf_message(mess)
1319	ENDIF
1320
1321	! We only store > 1 patch if the field has two or more dimensions. Scalars
1322	! and 1D arrays are replicated across compute nodes and therefore we only
1323	! need keep a single patch.
1324	IF(LEN_TRIM(outpatch_table(ii)%MemoryOrder) >= 2 .OR. &
1325	outpatch_table(ii)%npatch < 1)THEN
1326
1327	! Add another patch
1328	outpatch_table(ii)%npatch = outpatch_table(ii)%npatch + 1
1329	outpatch_table(ii)%nActivePatch = outpatch_table(ii)%npatch
1330
1331	ipatch = outpatch_table(ii)%npatch
1332
1333	outpatch_table(ii)%PatchList(ipatch)%PatchStart(:) = PatchStart(:)
1334	outpatch_table(ii)%PatchList(ipatch)%PatchEnd(:) = PatchEnd(:)
1335	outpatch_table(ii)%PatchList(ipatch)%PatchExtent(:)= PatchEnd(:) - PatchStart(:) + 1
1336
1337	ierr = 0
1338
1339	IF ( FieldType .EQ. WRF_FLOAT ) THEN
1340	ALLOCATE( outpatch_table(ii)%PatchList(ipatch)%rptr( &
1341	outpatch_table(ii)%PatchList(ipatch)%PatchExtent(1), &
1342	outpatch_table(ii)%PatchList(ipatch)%PatchExtent(2), &
1343	outpatch_table(ii)%PatchList(ipatch)%PatchExtent(3)),&
1344	Stat=ierr)
1345	ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
1346	ALLOCATE( outpatch_table(ii)%PatchList(ipatch)%iptr( &
1347	outpatch_table(ii)%PatchList(ipatch)%PatchExtent(1), &
1348	outpatch_table(ii)%PatchList(ipatch)%PatchExtent(2), &
1349	outpatch_table(ii)%PatchList(ipatch)%PatchExtent(3)),&
1350	Stat=ierr)
1351	ELSE
1352	WRITE(mess,*)"store_patch_in_outbuf_pnc: unsupported type ", FieldType
1353	CALL wrf_error_fatal(mess)
1354	ENDIF
1355
1356	IF(ierr /= 0)THEN
1357	WRITE(mess,*)"store_patch_in_outbuf_pnc: failed to allocate memory to hold patch for var. ", TRIM(VarName)
1358	CALL wrf_error_fatal(mess)
1359	END IF
1360
1361	jj = 1
1362
1363	WRITE(mess,"('Variable ',(A),', patch ',I3,': (',I3,':',I3,',',I3,':',I3,',',I3,':',I3,')')")&
1364	TRIM(outpatch_table(ii)%VarName), &
1365	ipatch, &
1366	PatchStart(1),PatchEnd(1), &
1367	PatchStart(2),PatchEnd(2), &
1368	PatchStart(3),PatchEnd(3)
1369	CALL wrf_message(mess)
1370
1371	IF ( FieldType .EQ. WRF_FLOAT ) THEN
1372	DO n = 1,outpatch_table(ii)%PatchList(ipatch)%PatchExtent(3),1
1373	DO m = 1,outpatch_table(ii)%PatchList(ipatch)%PatchExtent(2),1
1374	DO l = 1,outpatch_table(ii)%PatchList(ipatch)%PatchExtent(1),1
1375	outpatch_table(ii)%PatchList(ipatch)%rptr(l,m,n) = inbuf_r(jj)
1376	jj = jj + 1
1377	ENDDO
1378	ENDDO
1379	ENDDO
1380	ENDIF
1381	IF ( FieldType .EQ. WRF_INTEGER ) THEN
1382	DO n = 1,outpatch_table(ii)%PatchList(ipatch)%PatchExtent(3),1
1383	DO m = 1,outpatch_table(ii)%PatchList(ipatch)%PatchExtent(2),1
1384	DO l = 1,outpatch_table(ii)%PatchList(ipatch)%PatchExtent(1),1
1385	outpatch_table(ii)%PatchList(ipatch)%iptr(l,m,n) = inbuf_i(jj)
1386	jj = jj + 1
1387	ENDDO
1388	ENDDO
1389	ENDDO
1390	ENDIF
1391
1392	END IF ! We need to add another patch
1393
1394	! CALL end_timing("store patch in outbuf")
1395
1396	RETURN
1397
1398	END SUBROUTINE store_patch_in_outbuf_pnc
1399
1400	!call add_to_bufsize_for_field( VarName, hdrbufsize+chunksize )
1401
1402	SUBROUTINE add_to_bufsize_for_field( VarName, Nbytes )
1403	!<DESCRIPTION>
1404	!<PRE>
1405	! This routine is a wrapper for C routine add_to_bufsize_for_field_c() that
1406	! is used to accumulate buffer sizes. Buffer size Nbytes is added to the
1407	! curent buffer size for the buffer named VarName. Any buffer space
1408	! associated with VarName is freed. If a buffer named VarName does not exist,
1409	! a new one is assigned and its size is set to Nbytes.
1410	!</PRE>
1411	!</DESCRIPTION>
1412	USE module_quilt_outbuf_ops
1413	IMPLICIT NONE
1414	CHARACTER() , INTENT(IN) :: VarName
1415	INTEGER , INTENT(IN) :: Nbytes
1416	! Local
1417	CHARACTER*256 :: mess
1418	INTEGER :: i, ierr
1419	INTEGER :: VarNameAsInts( 256 )
1420	VarNameAsInts( 1 ) = len(trim(VarName))
1421	DO i = 2, len(trim(VarName)) + 1
1422	VarNameAsInts( i ) = ICHAR( VarName(i-1:i-1) )
1423	ENDDO
1424	CALL add_to_bufsize_for_field_c ( VarNameAsInts, Nbytes )
1425	RETURN
1426	END SUBROUTINE add_to_bufsize_for_field
1427
1428	SUBROUTINE store_piece_of_field( inbuf, VarName, Nbytes )
1429	!<DESCRIPTION>
1430	!<PRE>
1431	! This routine is a wrapper for C routine store_piece_of_field_c() that
1432	! is used to store pieces of a field in an internal buffer. Nbytes bytes of
1433	! buffer inbuf are appended to the end of the internal buffer named VarName.
1434	! An error occurs if either an internal buffer named VarName does not exist or
1435	! if there are fewer than Nbytes bytes left in the internal buffer.
1436	!</PRE>
1437	!</DESCRIPTION>
1438	USE module_quilt_outbuf_ops
1439	IMPLICIT NONE
1440	INTEGER , INTENT(IN) :: Nbytes
1441	INTEGER , DIMENSION(*) , INTENT(IN) :: inbuf
1442	CHARACTER() , INTENT(IN) :: VarName
1443	! Local
1444	CHARACTER*256 :: mess
1445	INTEGER :: i, ierr
1446	INTEGER :: VarNameAsInts( 256 )
1447
1448	VarNameAsInts( 1 ) = len(trim(VarName))
1449	DO i = 2, len(trim(VarName)) + 1
1450	VarNameAsInts( i ) = ICHAR( VarName(i-1:i-1) )
1451	ENDDO
1452	CALL store_piece_of_field_c ( inbuf, VarNameAsInts, Nbytes, ierr )
1453	IF ( ierr .NE. 0 ) CALL wrf_error_fatal ( "store_piece_of_field" )
1454	RETURN
1455	END SUBROUTINE store_piece_of_field
1456
1457	SUBROUTINE retrieve_pieces_of_field( outbuf, VarName, obufsz, Nbytes_tot, lret )
1458	!<DESCRIPTION>
1459	!<PRE>
1460	! This routine is a wrapper for C routine retrieve_pieces_of_field_c() that
1461	! is used to extract the entire contents (i.e. all previously stored pieces of
1462	! fields) of the next internal buffer. The name associated with this internal
1463	! buffer is returned in VarName. The number of bytes read is returned in
1464	! Nbytes_tot. Bytes are stored in outbuf whose size (in bytes) is obufsz.
1465	! If there are more than obufsz bytes left in the next internal buffer, then
1466	! only obufsz bytes are returned and the rest are discarded (probably an error
1467	! in the making!). The internal buffer is then freed. Flag lret is set to
1468	! .TRUE. iff there are more fields left to extract.
1469	!</PRE>
1470	!</DESCRIPTION>
1471	USE module_quilt_outbuf_ops
1472	IMPLICIT NONE
1473	INTEGER , INTENT(IN) :: obufsz
1474	INTEGER , INTENT(OUT) :: Nbytes_tot
1475	INTEGER , DIMENSION(*) , INTENT(OUT) :: outbuf
1476	CHARACTER() , INTENT(OUT) :: VarName
1477	LOGICAL :: lret ! true if more, false if not
1478	! Local
1479	CHARACTER*256 :: mess
1480	INTEGER :: i, iret
1481	INTEGER :: VarNameAsInts( 256 )
1482
1483	CALL retrieve_pieces_of_field_c ( outbuf, VarNameAsInts, obufsz, Nbytes_tot, iret )
1484	IF ( iret .NE. 0 ) THEN
1485	lret = .FALSE.
1486	ELSE
1487	lret = .TRUE.
1488	VarName = ' '
1489	DO i = 2, VarNameAsInts(1) + 1
1490	VarName(i-1:i-1) = CHAR(VarNameAsInts( i ))
1491	ENDDO
1492	ENDIF
1493	RETURN
1494	END SUBROUTINE retrieve_pieces_of_field
1495

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

Download in other formats:

Original Format