Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

module_quilt_outbuf_ops.F @ 3567

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

Rev	Line
[2759]	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 :: num_entries
	10
	11	TYPE outrec
	12	CHARACTER*80 :: VarName, DateStr, MemoryOrder, Stagger, DimNames(3)
	13	INTEGER :: ndim
	14	INTEGER, DIMENSION(3) :: DomainStart, DomainEnd
	15	INTEGER :: FieldType
	16	REAL, POINTER, DIMENSION(:,:,:) :: rptr
	17	INTEGER, POINTER, DIMENSION(:,:,:) :: iptr
	18	END TYPE outrec
	19
	20	TYPE(outrec), DIMENSION(tabsize) :: outbuf_table
	21
	22	CONTAINS
	23
	24	SUBROUTINE init_outbuf
	25	!<DESCRIPTION>
	26	!<PRE>
	27	! This routine re-initializes module data structures.
	28	!</PRE>
	29	!</DESCRIPTION>
	30	IMPLICIT NONE
	31	INTEGER i
	32	DO i = 1, tabsize
	33	outbuf_table(i)%VarName = ""
	34	outbuf_table(i)%DateStr = ""
	35	outbuf_table(i)%MemoryOrder = ""
	36	outbuf_table(i)%Stagger = ""
	37	outbuf_table(i)%DimNames(1) = ""
	38	outbuf_table(i)%DimNames(2) = ""
	39	outbuf_table(i)%DimNames(3) = ""
	40	outbuf_table(i)%ndim = 0
	41	NULLIFY( outbuf_table(i)%rptr )
	42	NULLIFY( outbuf_table(i)%iptr )
	43	ENDDO
	44	num_entries = 0
	45	END SUBROUTINE init_outbuf
	46
	47
	48	SUBROUTINE write_outbuf ( DataHandle , io_form_arg )
	49	!<DESCRIPTION>
	50	!<PRE>
	51	! This routine writes all of the records stored in outbuf_table to the
	52	! file referenced by DataHandle using format specified by io_form_arg.
	53	! This routine calls the package-specific I/O routines to accomplish
	54	! the write.
	55	! It then re-initializes module data structures.
	56	!</PRE>
	57	!</DESCRIPTION>
	58	USE module_state_description
	59	IMPLICIT NONE
	60	#include "wrf_io_flags.h"
	61	INTEGER , INTENT(IN) :: DataHandle, io_form_arg
	62	INTEGER :: ii,ds1,de1,ds2,de2,ds3,de3
	63	INTEGER :: Comm, IOComm, DomainDesc ! dummy
	64	INTEGER :: Status
	65	CHARACTER*80 :: mess
	66	Comm = 0 ; IOComm = 0 ; DomainDesc = 0
	67	DO ii = 1, num_entries
	68	WRITE(mess,*)'writing ', &
	69	TRIM(outbuf_table(ii)%DateStr)," ", &
	70	TRIM(outbuf_table(ii)%VarName)," ", &
	71	TRIM(outbuf_table(ii)%MemoryOrder)
	72	ds1 = outbuf_table(ii)%DomainStart(1) ; de1 = outbuf_table(ii)%DomainEnd(1)
	73	ds2 = outbuf_table(ii)%DomainStart(2) ; de2 = outbuf_table(ii)%DomainEnd(2)
	74	ds3 = outbuf_table(ii)%DomainStart(3) ; de3 = outbuf_table(ii)%DomainEnd(3)
	75
	76	SELECT CASE ( io_form_arg )
	77
	78	#ifdef NETCDF
	79	CASE ( IO_NETCDF )
	80
	81	IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN
	82
	83	CALL ext_ncd_write_field ( DataHandle , &
	84	TRIM(outbuf_table(ii)%DateStr), &
	85	TRIM(outbuf_table(ii)%VarName), &
	86	outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3), &
	87	outbuf_table(ii)%FieldType, & !*
	88	Comm, IOComm, DomainDesc , &
	89	TRIM(outbuf_table(ii)%MemoryOrder), &
	90	TRIM(outbuf_table(ii)%Stagger), & !*
	91	outbuf_table(ii)%DimNames , & !*
	92	outbuf_table(ii)%DomainStart, &
	93	outbuf_table(ii)%DomainEnd, &
	94	outbuf_table(ii)%DomainStart, &
	95	outbuf_table(ii)%DomainEnd, &
	96	outbuf_table(ii)%DomainStart, &
	97	outbuf_table(ii)%DomainEnd, &
	98	Status )
	99
	100	ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN
	101	CALL ext_ncd_write_field ( DataHandle , &
	102	TRIM(outbuf_table(ii)%DateStr), &
	103	TRIM(outbuf_table(ii)%VarName), &
	104	outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3), &
	105	outbuf_table(ii)%FieldType, & !*
	106	Comm, IOComm, DomainDesc , &
	107	TRIM(outbuf_table(ii)%MemoryOrder), &
	108	TRIM(outbuf_table(ii)%Stagger), & !*
	109	outbuf_table(ii)%DimNames , & !*
	110	outbuf_table(ii)%DomainStart, &
	111	outbuf_table(ii)%DomainEnd, &
	112	outbuf_table(ii)%DomainStart, &
	113	outbuf_table(ii)%DomainEnd, &
	114	outbuf_table(ii)%DomainStart, &
	115	outbuf_table(ii)%DomainEnd, &
	116	Status )
	117	ENDIF
	118	#endif
	119	#ifdef YYY
	120	CASE ( IO_YYY )
	121
	122	IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN
	123
	124	CALL ext_yyy_write_field ( DataHandle , &
	125	TRIM(outbuf_table(ii)%DateStr), &
	126	TRIM(outbuf_table(ii)%VarName), &
	127	outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3), &
	128	outbuf_table(ii)%FieldType, & !*
	129	Comm, IOComm, DomainDesc , &
	130	TRIM(outbuf_table(ii)%MemoryOrder), &
	131	TRIM(outbuf_table(ii)%Stagger), & !*
	132	outbuf_table(ii)%DimNames , & !*
	133	outbuf_table(ii)%DomainStart, &
	134	outbuf_table(ii)%DomainEnd, &
	135	outbuf_table(ii)%DomainStart, &
	136	outbuf_table(ii)%DomainEnd, &
	137	outbuf_table(ii)%DomainStart, &
	138	outbuf_table(ii)%DomainEnd, &
	139	Status )
	140
	141	ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN
	142	CALL ext_yyy_write_field ( DataHandle , &
	143	TRIM(outbuf_table(ii)%DateStr), &
	144	TRIM(outbuf_table(ii)%VarName), &
	145	outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3), &
	146	outbuf_table(ii)%FieldType, & !*
	147	Comm, IOComm, DomainDesc , &
	148	TRIM(outbuf_table(ii)%MemoryOrder), &
	149	TRIM(outbuf_table(ii)%Stagger), & !*
	150	outbuf_table(ii)%DimNames , & !*
	151	outbuf_table(ii)%DomainStart, &
	152	outbuf_table(ii)%DomainEnd, &
	153	outbuf_table(ii)%DomainStart, &
	154	outbuf_table(ii)%DomainEnd, &
	155	outbuf_table(ii)%DomainStart, &
	156	outbuf_table(ii)%DomainEnd, &
	157	Status )
	158	ENDIF
	159	#endif
	160	#ifdef GRIB1
	161	CASE ( IO_GRIB1 )
	162
	163	IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN
	164
	165	CALL ext_gr1_write_field ( DataHandle , &
	166	TRIM(outbuf_table(ii)%DateStr), &
	167	TRIM(outbuf_table(ii)%VarName), &
	168	outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3), &
	169	outbuf_table(ii)%FieldType, & !*
	170	Comm, IOComm, DomainDesc , &
	171	TRIM(outbuf_table(ii)%MemoryOrder), &
	172	TRIM(outbuf_table(ii)%Stagger), & !*
	173	outbuf_table(ii)%DimNames , & !*
	174	outbuf_table(ii)%DomainStart, &
	175	outbuf_table(ii)%DomainEnd, &
	176	outbuf_table(ii)%DomainStart, &
	177	outbuf_table(ii)%DomainEnd, &
	178	outbuf_table(ii)%DomainStart, &
	179	outbuf_table(ii)%DomainEnd, &
	180	Status )
	181
	182	ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN
	183	CALL ext_gr1_write_field ( DataHandle , &
	184	TRIM(outbuf_table(ii)%DateStr), &
	185	TRIM(outbuf_table(ii)%VarName), &
	186	outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3), &
	187	outbuf_table(ii)%FieldType, & !*
	188	Comm, IOComm, DomainDesc , &
	189	TRIM(outbuf_table(ii)%MemoryOrder), &
	190	TRIM(outbuf_table(ii)%Stagger), & !*
	191	outbuf_table(ii)%DimNames , & !*
	192	outbuf_table(ii)%DomainStart, &
	193	outbuf_table(ii)%DomainEnd, &
	194	outbuf_table(ii)%DomainStart, &
	195	outbuf_table(ii)%DomainEnd, &
	196	outbuf_table(ii)%DomainStart, &
	197	outbuf_table(ii)%DomainEnd, &
	198	Status )
	199	ENDIF
	200	#endif
	201	#ifdef GRIB2
	202	CASE ( IO_GRIB2 )
	203
	204	IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN
	205
	206	CALL ext_gr2_write_field ( DataHandle , &
	207	TRIM(outbuf_table(ii)%DateStr), &
	208	TRIM(outbuf_table(ii)%VarName), &
	209	outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3), &
	210	outbuf_table(ii)%FieldType, & !*
	211	Comm, IOComm, DomainDesc , &
	212	TRIM(outbuf_table(ii)%MemoryOrder), &
	213	TRIM(outbuf_table(ii)%Stagger), & !*
	214	outbuf_table(ii)%DimNames , & !*
	215	outbuf_table(ii)%DomainStart, &
	216	outbuf_table(ii)%DomainEnd, &
	217	outbuf_table(ii)%DomainStart, &
	218	outbuf_table(ii)%DomainEnd, &
	219	outbuf_table(ii)%DomainStart, &
	220	outbuf_table(ii)%DomainEnd, &
	221	Status )
	222
	223	ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN
	224	CALL ext_gr2_write_field ( DataHandle , &
	225	TRIM(outbuf_table(ii)%DateStr), &
	226	TRIM(outbuf_table(ii)%VarName), &
	227	outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3), &
	228	outbuf_table(ii)%FieldType, & !*
	229	Comm, IOComm, DomainDesc , &
	230	TRIM(outbuf_table(ii)%MemoryOrder), &
	231	TRIM(outbuf_table(ii)%Stagger), & !*
	232	outbuf_table(ii)%DimNames , & !*
	233	outbuf_table(ii)%DomainStart, &
	234	outbuf_table(ii)%DomainEnd, &
	235	outbuf_table(ii)%DomainStart, &
	236	outbuf_table(ii)%DomainEnd, &
	237	outbuf_table(ii)%DomainStart, &
	238	outbuf_table(ii)%DomainEnd, &
	239	Status )
	240	ENDIF
	241	#endif
	242	#ifdef INTIO
	243	CASE ( IO_INTIO )
	244	IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN
	245
	246	CALL ext_int_write_field ( DataHandle , &
	247	TRIM(outbuf_table(ii)%DateStr), &
	248	TRIM(outbuf_table(ii)%VarName), &
	249	outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3), &
	250	outbuf_table(ii)%FieldType, & !*
	251	Comm, IOComm, DomainDesc , &
	252	TRIM(outbuf_table(ii)%MemoryOrder), &
	253	TRIM(outbuf_table(ii)%Stagger), & !*
	254	outbuf_table(ii)%DimNames , & !*
	255	outbuf_table(ii)%DomainStart, &
	256	outbuf_table(ii)%DomainEnd, &
	257	outbuf_table(ii)%DomainStart, &
	258	outbuf_table(ii)%DomainEnd, &
	259	outbuf_table(ii)%DomainStart, &
	260	outbuf_table(ii)%DomainEnd, &
	261	Status )
	262
	263	ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN
	264
	265	CALL ext_int_write_field ( DataHandle , &
	266	TRIM(outbuf_table(ii)%DateStr), &
	267	TRIM(outbuf_table(ii)%VarName), &
	268	outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3), &
	269	outbuf_table(ii)%FieldType, & !*
	270	Comm, IOComm, DomainDesc , &
	271	TRIM(outbuf_table(ii)%MemoryOrder), &
	272	TRIM(outbuf_table(ii)%Stagger), & !*
	273	outbuf_table(ii)%DimNames , & !*
	274	outbuf_table(ii)%DomainStart, &
	275	outbuf_table(ii)%DomainEnd, &
	276	outbuf_table(ii)%DomainStart, &
	277	outbuf_table(ii)%DomainEnd, &
	278	outbuf_table(ii)%DomainStart, &
	279	outbuf_table(ii)%DomainEnd, &
	280	Status )
	281
	282	ENDIF
	283	#endif
	284	CASE DEFAULT
	285	END SELECT
	286
	287
	288	IF ( ASSOCIATED( outbuf_table(ii)%rptr) ) DEALLOCATE(outbuf_table(ii)%rptr)
	289	IF ( ASSOCIATED( outbuf_table(ii)%iptr) ) DEALLOCATE(outbuf_table(ii)%iptr)
	290	NULLIFY( outbuf_table(ii)%rptr )
	291	NULLIFY( outbuf_table(ii)%iptr )
	292	ENDDO
	293	CALL init_outbuf
	294	END SUBROUTINE write_outbuf
	295
	296	END MODULE module_quilt_outbuf_ops
	297
	298	! don't let other programs see the definition of this; type mismatches
	299	! on inbuf will result; may want to make a module program at some point
	300	SUBROUTINE store_patch_in_outbuf( inbuf_r, inbuf_i, DateStr, VarName , FieldType, MemoryOrder, Stagger, DimNames, &
	301	DomainStart , DomainEnd , &
	302	MemoryStart , MemoryEnd , &
	303	PatchStart , PatchEnd )
	304	!<DESCRIPTION>
	305	!<PRE>
	306	! This routine does the "output quilting".
	307	!
	308	! It stores a patch in the appropriate location in a domain-sized array
	309	! within an element of the outbuf_table data structure. DateStr, VarName, and
	310	! MemoryOrder are used to uniquely identify which element of outbuf_table is
	311	! associated with this array. If no element is associated, then this routine
	312	! first assigns an unused element and allocates space within that element for
	313	! the globally-sized array. This routine also stores DateStr, VarName,
	314	! FieldType, MemoryOrder, Stagger, DimNames, DomainStart, and DomainEnd within
	315	! the same element of outbuf.
	316	!</PRE>
	317	!</DESCRIPTION>
	318	USE module_quilt_outbuf_ops
	319	IMPLICIT NONE
	320	#include "wrf_io_flags.h"
	321	INTEGER , INTENT(IN) :: FieldType
	322	REAL , DIMENSION(*) , INTENT(IN) :: inbuf_r
	323	INTEGER , DIMENSION(*) , INTENT(IN) :: inbuf_i
	324	INTEGER , DIMENSION(3) , INTENT(IN) :: DomainStart , DomainEnd , MemoryStart , MemoryEnd , PatchStart , PatchEnd
	325	CHARACTER() , INTENT(IN) :: DateStr , VarName, MemoryOrder , Stagger, DimNames(3)
	326	! Local
	327	CHARACTER*120 mess
	328	INTEGER :: l,m,n,ii,jj
	329	LOGICAL :: found
	330
	331	! Find the VarName if it's in the buffer already
	332	ii = 1
	333	found = .false.
	334	DO WHILE ( .NOT. found .AND. ii .LE. num_entries )
	335	!TBH: need to test other attributes too!
	336	IF ( TRIM(VarName) .EQ. TRIM(outbuf_table(ii)%VarName) ) THEN
	337	IF ( TRIM(DateStr) .EQ. TRIM(outbuf_table(ii)%DateStr) ) THEN
	338	IF ( TRIM(MemoryOrder) .EQ. TRIM(outbuf_table(ii)%MemoryOrder) ) THEN
	339	found = .true.
	340	ELSE
	341	CALL wrf_error_fatal("store_patch_in_outbuf: memory order disagreement")
	342	ENDIF
	343	ELSE
	344	CALL wrf_error_fatal("store_patch_in_outbuf: multiple dates in buffer")
	345	ENDIF
	346	ELSE
	347	ii = ii + 1
	348	ENDIF
	349	ENDDO
	350	IF ( .NOT. found ) THEN
	351	num_entries = num_entries + 1
	352	IF ( FieldType .EQ. WRF_FLOAT ) THEN
	353	ALLOCATE( outbuf_table(num_entries)%rptr(DomainStart(1):DomainEnd(1), &
	354	DomainStart(2):DomainEnd(2),DomainStart(3):DomainEnd(3)) )
	355	ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
	356	ALLOCATE( outbuf_table(num_entries)%iptr(DomainStart(1):DomainEnd(1), &
	357	DomainStart(2):DomainEnd(2),DomainStart(3):DomainEnd(3)) )
	358	ELSE
	359	write(mess,*)"store_patch_in_outbuf: unsupported type ", FieldType
	360	CALL wrf_error_fatal(mess)
	361	ENDIF
	362	outbuf_table(num_entries)%VarName = TRIM(VarName)
	363	outbuf_table(num_entries)%DateStr = TRIM(DateStr)
	364	outbuf_table(num_entries)%MemoryOrder = TRIM(MemoryOrder)
	365	outbuf_table(num_entries)%Stagger = TRIM(Stagger)
	366	outbuf_table(num_entries)%DimNames(1) = TRIM(DimNames(1))
	367	outbuf_table(num_entries)%DimNames(2) = TRIM(DimNames(2))
	368	outbuf_table(num_entries)%DimNames(3) = TRIM(DimNames(3))
	369	outbuf_table(num_entries)%DomainStart = DomainStart
	370	outbuf_table(num_entries)%DomainEnd = DomainEnd
	371	outbuf_table(num_entries)%FieldType = FieldType
	372	ii = num_entries
	373	ENDIF
	374	jj = 1
	375	IF ( FieldType .EQ. WRF_FLOAT ) THEN
	376	DO n = PatchStart(3),PatchEnd(3)
	377	DO m = PatchStart(2),PatchEnd(2)
	378	DO l = PatchStart(1),PatchEnd(1)
	379	outbuf_table(ii)%rptr(l,m,n) = inbuf_r(jj)
	380	jj = jj + 1
	381	ENDDO
	382	ENDDO
	383	ENDDO
	384	ENDIF
	385	IF ( FieldType .EQ. WRF_INTEGER ) THEN
	386	DO n = PatchStart(3),PatchEnd(3)
	387	DO m = PatchStart(2),PatchEnd(2)
	388	DO l = PatchStart(1),PatchEnd(1)
	389	outbuf_table(ii)%iptr(l,m,n) = inbuf_i(jj)
	390	jj = jj + 1
	391	ENDDO
	392	ENDDO
	393	ENDDO
	394	ENDIF
	395
	396	RETURN
	397
	398	END SUBROUTINE store_patch_in_outbuf
	399
	400	!call add_to_bufsize_for_field( VarName, hdrbufsize+chunksize )
	401
	402	SUBROUTINE add_to_bufsize_for_field( VarName, Nbytes )
	403	!<DESCRIPTION>
	404	!<PRE>
	405	! This routine is a wrapper for C routine add_to_bufsize_for_field_c() that
	406	! is used to accumulate buffer sizes. Buffer size Nbytes is added to the
	407	! curent buffer size for the buffer named VarName. Any buffer space
	408	! associated with VarName is freed. If a buffer named VarName does not exist,
	409	! a new one is assigned and its size is set to Nbytes.
	410	!</PRE>
	411	!</DESCRIPTION>
	412	USE module_quilt_outbuf_ops
	413	IMPLICIT NONE
	414	CHARACTER() , INTENT(IN) :: VarName
	415	INTEGER , INTENT(IN) :: Nbytes
	416	! Local
	417	CHARACTER*120 mess
	418	INTEGER :: i, ierr
	419	INTEGER :: VarNameAsInts( 256 )
	420	VarNameAsInts( 1 ) = len(trim(VarName))
	421	DO i = 2, len(trim(VarName)) + 1
	422	VarNameAsInts( i ) = ICHAR( VarName(i-1:i-1) )
	423	ENDDO
	424	CALL add_to_bufsize_for_field_c ( VarNameAsInts, Nbytes )
	425	RETURN
	426	END SUBROUTINE add_to_bufsize_for_field
	427
	428	SUBROUTINE store_piece_of_field( inbuf, VarName, Nbytes )
	429	!<DESCRIPTION>
	430	!<PRE>
	431	! This routine is a wrapper for C routine store_piece_of_field_c() that
	432	! is used to store pieces of a field in an internal buffer. Nbytes bytes of
	433	! buffer inbuf are appended to the end of the internal buffer named VarName.
	434	! An error occurs if either an internal buffer named VarName does not exist or
	435	! if there are fewer than Nbytes bytes left in the internal buffer.
	436	!</PRE>
	437	!</DESCRIPTION>
	438	USE module_quilt_outbuf_ops
	439	IMPLICIT NONE
	440	INTEGER , INTENT(IN) :: Nbytes
	441	INTEGER , DIMENSION(*) , INTENT(IN) :: inbuf
	442	CHARACTER() , INTENT(IN) :: VarName
	443	! Local
	444	CHARACTER*120 mess
	445	INTEGER :: i, ierr
	446	INTEGER :: VarNameAsInts( 256 )
	447
	448	VarNameAsInts( 1 ) = len(trim(VarName))
	449	DO i = 2, len(trim(VarName)) + 1
	450	VarNameAsInts( i ) = ICHAR( VarName(i-1:i-1) )
	451	ENDDO
	452	CALL store_piece_of_field_c ( inbuf, VarNameAsInts, Nbytes, ierr )
	453	IF ( ierr .NE. 0 ) CALL wrf_error_fatal ( "store_piece_of_field" )
	454	RETURN
	455	END SUBROUTINE store_piece_of_field
	456
	457	SUBROUTINE retrieve_pieces_of_field( outbuf, VarName, obufsz, Nbytes_tot, lret )
	458	!<DESCRIPTION>
	459	!<PRE>
	460	! This routine is a wrapper for C routine retrieve_pieces_of_field_c() that
	461	! is used to extract the entire contents (i.e. all previously stored pieces of
	462	! fields) of the next internal buffer. The name associated with this internal
	463	! buffer is returned in VarName. The number of bytes read is returned in
	464	! Nbytes_tot. Bytes are stored in outbuf whose size (in bytes) is obufsz.
	465	! If there are more than obufsz bytes left in the next internal buffer, then
	466	! only obufsz bytes are returned and the rest are discarded (probably an error
	467	! in the making!). The internal buffer is then freed. Flag lret is set to
	468	! .TRUE. iff there are more fields left to extract.
	469	!</PRE>
	470	!</DESCRIPTION>
	471	USE module_quilt_outbuf_ops
	472	IMPLICIT NONE
	473	INTEGER , INTENT(IN) :: obufsz
	474	INTEGER , INTENT(OUT) :: Nbytes_tot
	475	INTEGER , DIMENSION(*) , INTENT(OUT) :: outbuf
	476	CHARACTER() , INTENT(OUT) :: VarName
	477	LOGICAL :: lret ! true if more, false if not
	478	! Local
	479	CHARACTER*120 mess
	480	INTEGER :: i, iret
	481	INTEGER :: VarNameAsInts( 256 )
	482
	483	CALL retrieve_pieces_of_field_c ( outbuf, VarNameAsInts, obufsz, Nbytes_tot, iret )
	484	IF ( iret .NE. 0 ) THEN
	485	lret = .FALSE.
	486	ELSE
	487	lret = .TRUE.
	488	VarName = ' '
	489	DO i = 2, VarNameAsInts(1) + 1
	490	VarName(i-1:i-1) = CHAR(VarNameAsInts( i ))
	491	ENDDO
	492	ENDIF
	493	RETURN
	494	END SUBROUTINE retrieve_pieces_of_field
	495

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

Download in other formats:

Original Format