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 | |
---|