| blob | 8bb3b8a7b4b318597d4c4a52dc1517e34f99e84d |
1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2 ! Module: source_data_module
3 !
4 ! Description:
5 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6 module source_data_module
8 use hash_module
9 use list_module
10 use module_debug
11 use misc_definitions_module
13 ! Parameters
14 integer, parameter :: RETURN_LANDMASK = 0, &
15 RETURN_DOMCAT_LM = 1, &
16 RETURN_DFDX_LM = 2, &
17 RETURN_DFDY_LM = 3, &
18 RETURN_FIELDNAME = 4, &
19 RETURN_DOMCAT = 5, &
20 RETURN_DFDX = 6, &
21 RETURN_DFDY = 7
22 integer, parameter :: MAX_LANDMASK_CATEGORIES = 100
24 ! Module variables
25 integer :: num_entries
26 integer :: next_field = 1
27 integer :: output_field_state = RETURN_LANDMASK
28 integer, pointer, dimension(:) :: source_proj, source_wordsize, source_endian, source_fieldtype, &
29 source_dest_fieldtype, source_priority, source_tile_x, source_tile_y, &
30 source_tile_z, source_tile_z_start, source_tile_z_end, source_tile_bdr, &
31 source_category_min, source_category_max, source_smooth_option, &
32 source_smooth_passes, source_output_stagger, source_row_order
33 integer :: source_iswater, source_islake, source_isice, source_isurban, source_isoilwater
34 real, pointer, dimension(:) :: source_dx, source_dy, source_known_x, source_known_y, &
35 source_known_lat, source_known_lon, source_masked, source_truelat1, source_truelat2, &
36 source_stdlon, source_scale_factor, source_missing_value, source_fill_missing
37 character (len=128), pointer, dimension(:) :: source_fieldname, source_path, source_interp_string, &
38 source_dominant_category, source_dominant_only, source_dfdx, source_dfdy, &
39 source_z_dim_name, source_units, source_descr, source_output_flag
40 character (len=128) :: source_mminlu
41 logical, pointer, dimension(:) :: is_proj, is_wordsize, is_endian, is_fieldtype, &
42 is_dest_fieldtype, is_priority, is_tile_x, is_tile_y, is_tile_z, &
43 is_tile_z_start, is_tile_z_end, is_tile_bdr, is_category_min, &
44 is_category_max, is_masked, &
45 is_dx, is_dy, is_known_x, is_known_y, &
46 is_known_lat, is_known_lon, is_truelat1, is_truelat2, is_stdlon, &
47 is_scale_factor, is_fieldname, is_path, is_dominant_category, &
48 is_dominant_only, is_dfdx, is_dfdy, is_z_dim_name, &
49 is_smooth_option, is_smooth_passes, is_signed, is_missing_value, &
50 is_fill_missing, is_halt_missing, is_output_stagger, is_row_order, &
51 is_units, is_descr, is_subgrid, is_output_flag
53 type (list), pointer, dimension(:) :: source_res_path, source_interp_option, source_landmask_land, &
54 source_landmask_water
55 type (hashtable) :: bad_files ! Track which files produce errors when we try to open them
56 type (hashtable) :: duplicate_fnames ! Remember which output fields we have returned
59 contains
62 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
63 ! Name: get_datalist
64 !
65 ! Purpose:
66 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
67 subroutine get_datalist()
69 use gridinfo_module
70 use stringutil
72 implicit none
74 ! Parameters
75 integer, parameter :: BUFSIZE = 256
77 ! Local variables
78 integer :: nparams, idx, eos, ispace, comma, i, j, funit
79 logical :: have_specification, is_used
80 character (len=128) :: res_string, path_string, interp_string, landmask_string
81 character (len=BUFSIZE) :: buffer
83 nparams = 0
84 num_entries = 0
86 do funit=10,100
87 inquire(unit=funit, opened=is_used)
88 if (.not. is_used) exit
89 end do
90 open(funit,file=trim(opt_geogrid_tbl_path)//'GEOGRID.TBL',form='formatted',status='old',err=1000)
92 !
93 ! We will first go through the file to determine how many field
94 ! specifications there are
95 !
96 10 read(funit,'(a)',end=20,err=1001) buffer
97 call despace(buffer)
99 ! Is this line a comment?
100 if (buffer(1:1) == '#') then
102 ! Are we beginning a new field specification?
103 else if (index(buffer,'=====') /= 0) then
104 if (nparams > 0) num_entries = num_entries + 1
105 nparams = 0
107 else
108 eos = index(buffer,'#')
109 if (eos /= 0) buffer(eos:BUFSIZE) = ' '
111 ! Does this line contain at least one parameter specification?
112 if (index(buffer,'=') /= 0) then
113 nparams = nparams + 1
114 end if
115 end if
116 go to 10
118 20 rewind(funit)
120 ! In case the last entry ended without a ======== line
121 if (nparams > 0) num_entries = num_entries + 1
123 call mprintf(.true.,STDOUT,'Parsed %i entries in GEOGRID.TBL', i1=num_entries)
125 !
126 ! Now that we know how many fields the user has specified, allocate
127 ! the properly sized arrays
128 !
129 allocate(source_wordsize(num_entries))
130 allocate(source_endian(num_entries))
131 allocate(source_fieldtype(num_entries))
132 allocate(source_dest_fieldtype(num_entries))
133 allocate(source_proj(num_entries))
134 allocate(source_priority(num_entries))
135 allocate(source_dx(num_entries))
136 allocate(source_dy(num_entries))
137 allocate(source_known_x(num_entries))
138 allocate(source_known_y(num_entries))
139 allocate(source_known_lat(num_entries))
140 allocate(source_known_lon(num_entries))
141 allocate(source_truelat1(num_entries))
142 allocate(source_truelat2(num_entries))
143 allocate(source_stdlon(num_entries))
144 allocate(source_fieldname(num_entries))
145 allocate(source_path(num_entries))
146 allocate(source_interp_string(num_entries))
147 allocate(source_tile_x(num_entries))
148 allocate(source_tile_y(num_entries))
149 allocate(source_tile_z(num_entries))
150 allocate(source_tile_z_start(num_entries))
151 allocate(source_tile_z_end(num_entries))
152 allocate(source_category_min(num_entries))
153 allocate(source_category_max(num_entries))
154 allocate(source_tile_bdr(num_entries))
155 allocate(source_masked(num_entries))
156 allocate(source_output_stagger(num_entries))
157 allocate(source_row_order(num_entries))
158 allocate(source_dominant_category(num_entries))
159 allocate(source_dominant_only(num_entries))
160 allocate(source_dfdx(num_entries))
161 allocate(source_dfdy(num_entries))
162 allocate(source_scale_factor(num_entries))
163 allocate(source_z_dim_name(num_entries))
164 allocate(source_units(num_entries))
165 allocate(source_descr(num_entries))
166 allocate(source_smooth_option(num_entries))
167 allocate(source_smooth_passes(num_entries))
168 allocate(source_missing_value(num_entries))
169 allocate(source_fill_missing(num_entries))
170 allocate(source_res_path(num_entries))
171 allocate(source_interp_option(num_entries))
172 allocate(source_landmask_land(num_entries))
173 allocate(source_landmask_water(num_entries))
174 allocate(source_output_flag(num_entries))
175 do i=1,num_entries
176 call list_init(source_res_path(i))
177 call list_init(source_interp_option(i))
178 call list_init(source_landmask_land(i))
179 call list_init(source_landmask_water(i))
180 end do
182 allocate(is_wordsize(num_entries))
183 allocate(is_endian(num_entries))
184 allocate(is_fieldtype(num_entries))
185 allocate(is_dest_fieldtype(num_entries))
186 allocate(is_proj(num_entries))
187 allocate(is_priority(num_entries))
188 allocate(is_dx(num_entries))
189 allocate(is_dy(num_entries))
190 allocate(is_known_x(num_entries))
191 allocate(is_known_y(num_entries))
192 allocate(is_known_lat(num_entries))
193 allocate(is_known_lon(num_entries))
194 allocate(is_truelat1(num_entries))
195 allocate(is_truelat2(num_entries))
196 allocate(is_stdlon(num_entries))
197 allocate(is_fieldname(num_entries))
198 allocate(is_path(num_entries))
199 allocate(is_tile_x(num_entries))
200 allocate(is_tile_y(num_entries))
201 allocate(is_tile_z(num_entries))
202 allocate(is_tile_z_start(num_entries))
203 allocate(is_tile_z_end(num_entries))
204 allocate(is_category_min(num_entries))
205 allocate(is_category_max(num_entries))
206 allocate(is_tile_bdr(num_entries))
207 allocate(is_masked(num_entries))
208 allocate(is_halt_missing(num_entries))
209 allocate(is_output_stagger(num_entries))
210 allocate(is_row_order(num_entries))
211 allocate(is_dominant_category(num_entries))
212 allocate(is_dominant_only(num_entries))
213 allocate(is_dfdx(num_entries))
214 allocate(is_dfdy(num_entries))
215 allocate(is_scale_factor(num_entries))
216 allocate(is_z_dim_name(num_entries))
217 allocate(is_units(num_entries))
218 allocate(is_descr(num_entries))
219 allocate(is_smooth_option(num_entries))
220 allocate(is_smooth_passes(num_entries))
221 allocate(is_signed(num_entries))
222 allocate(is_missing_value(num_entries))
223 allocate(is_fill_missing(num_entries))
224 allocate(is_subgrid(num_entries))
225 allocate(is_output_flag(num_entries))
227 source_wordsize=0
228 source_endian=0
229 source_fieldtype=0
230 source_dest_fieldtype=0
231 source_proj=0
232 source_priority=0
233 source_dx=0
234 source_dy=0
235 source_known_x=0
236 source_known_y=0
237 source_known_lat=0
238 source_known_lon=0
239 source_truelat1=0
240 source_truelat2=0
241 source_stdlon=0
242 source_fieldname=' '
243 source_path=' '
244 source_interp_string=' '
245 source_tile_x=0
246 source_tile_y=0
247 source_tile_z=0
248 source_tile_z_start=0
249 source_tile_z_end=0
250 source_category_min=0
251 source_category_max=0
252 source_tile_bdr=0
253 source_masked=0
254 source_output_stagger=0
255 source_row_order=0
256 source_dominant_category=' '
257 source_dominant_only=' '
258 source_dfdx=' '
259 source_dfdy=' '
260 source_scale_factor=0
261 source_z_dim_name=' '
262 source_units=' '
263 source_descr=' '
264 source_smooth_option=0
265 source_smooth_passes=0
266 source_missing_value=0
267 source_fill_missing=0
268 source_output_flag=' '
270 is_wordsize=.false.
271 is_endian=.false.
272 is_fieldtype=.false.
273 is_dest_fieldtype=.false.
274 is_proj=.false.
275 is_priority=.false.
276 is_dx=.false.
277 is_dy=.false.
278 is_known_x=.false.
279 is_known_y=.false.
280 is_known_lat=.false.
281 is_known_lon=.false.
282 is_truelat1=.false.
283 is_truelat2=.false.
284 is_stdlon=.false.
285 is_fieldname=.false.
286 is_path=.false.
287 is_tile_x=.false.
288 is_tile_y=.false.
289 is_tile_z=.false.
290 is_tile_z_start=.false.
291 is_tile_z_end=.false.
292 is_category_min=.false.
293 is_category_max=.false.
294 is_tile_bdr=.false.
295 is_masked=.false.
296 is_halt_missing=.false.
297 is_output_stagger=.false.
298 is_row_order=.false.
299 is_dominant_category=.false.
300 is_dominant_only=.false.
301 is_dfdx=.false.
302 is_dfdy=.false.
303 is_scale_factor=.false.
304 is_z_dim_name=.false.
305 is_units=.false.
306 is_descr=.false.
307 is_smooth_option=.false.
308 is_smooth_passes=.false.
309 is_signed=.false.
310 is_missing_value=.false.
311 is_fill_missing=.false.
312 is_subgrid=.false.
313 is_output_flag=.false.
315 write(source_mminlu,'(a4)') 'USGS'
316 source_iswater = 16
317 source_islake = -1
318 source_isice = 24
319 source_isurban = 1
320 source_isoilwater = 14
322 !
323 ! Actually read and save the specifications
324 !
325 nparams = 0
326 i = 1
327 30 buffer = ' '
328 read(funit,'(a)',end=40,err=1001) buffer
329 call despace(buffer)
331 ! Is this line a comment?
332 if (buffer(1:1) == '#') then
333 ! Do nothing.
335 ! Are we beginning a new field specification?
336 else if (index(buffer,'=====') /= 0) then !{
337 if (nparams > 0) i = i + 1
338 nparams = 0
339 if (i <= num_entries) then
340 !BUG: Are these initializations needed now that we've added initializations for
341 ! all options after their initial allocation above?
342 is_path(i) = .false.
343 is_masked(i) = .false.
344 is_halt_missing(i) = .false.
345 is_output_stagger(i) = .false.
346 is_dominant_category(i) = .false.
347 is_dominant_only(i) = .false.
348 is_dfdx(i) = .false.
349 is_dfdy(i) = .false.
350 is_dest_fieldtype(i) = .false.
351 is_priority(i) = .false.
352 is_z_dim_name(i) = .false.
353 is_smooth_option(i) = .false.
354 is_smooth_passes(i) = .false.
355 is_fill_missing(i) = .false.
356 is_subgrid(i) = .false.
357 is_output_flag(i) = .false.
358 end if
360 else
361 ! Check whether the current line is a comment
362 if (buffer(1:1) /= '#') then
363 have_specification = .true.
364 else
365 have_specification = .false.
366 end if
368 ! If only part of the line is a comment, just turn the comment into spaces
369 eos = index(buffer,'#')
370 if (eos /= 0) buffer(eos:BUFSIZE) = ' '
372 do while (have_specification) !{
374 ! If this line has no semicolon, it may contain a single specification,
375 ! so we set have_specification = .false. to prevent the line from being
376 ! processed again and "pretend" that the last character was a semicolon
377 eos = index(buffer,';')
378 if (eos == 0) then
379 have_specification = .false.
380 eos = BUFSIZE
381 end if
383 idx = index(buffer(1:eos-1),'=')
385 if (idx /= 0) then !{
386 nparams = nparams + 1
388 if (index('name',trim(buffer(1:idx-1))) /= 0) then
389 ispace = idx+1
390 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
391 ispace = ispace + 1
392 end do
393 is_fieldname(i) = .true.
394 source_fieldname(i) = ' '
395 source_fieldname(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
397 else if (index('priority',trim(buffer(1:idx-1))) /= 0) then
398 is_priority(i) = .true.
399 read(buffer(idx+1:eos-1),'(i10)') source_priority(i)
401 else if (index('dest_type',trim(buffer(1:idx-1))) /= 0) then
402 if (index('continuous',trim(buffer(idx+1:eos-1))) /= 0) then
403 is_dest_fieldtype(i) = .true.
404 source_dest_fieldtype(i) = CONTINUOUS
405 else if (index('categorical',trim(buffer(idx+1:eos-1))) /= 0) then
406 is_dest_fieldtype(i) = .true.
407 source_dest_fieldtype(i) = CATEGORICAL
408 end if
410 else if (index('interp_option',trim(buffer(1:idx-1))) /= 0) then
411 ispace = idx+1
412 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
413 ispace = ispace + 1
414 end do
415 interp_string = ' '
416 interp_string(1:ispace-idx-1) = buffer(idx+1:ispace-1)
417 ispace = index(interp_string,':')
418 if (ispace /= 0) then
419 write(res_string,'(a)') interp_string(1:ispace-1)
420 else
421 res_string = 'default'
422 end if
423 write(interp_string,'(a)') trim(interp_string(ispace+1:128))
424 if (list_search(source_interp_option(i), ckey=res_string, cvalue=interp_string)) then
425 call mprintf(.true., WARN, &
426 'In GEOGRID.TBL entry %i, multiple interpolation methods are '// &
427 'given for resolution %s. %s will be used.', &
428 i1=i, s1=trim(res_string), s2=trim(interp_string))
429 else
430 call list_insert(source_interp_option(i), ckey=res_string, cvalue=interp_string)
431 end if
433 else if (index('smooth_option',trim(buffer(1:idx-1))) /= 0) then
434 if ((index('1-2-1',trim(buffer(idx+1:eos-1))) /= 0) .and. &
435 (len_trim(buffer(idx+1:eos-1)) == len('1-2-1'))) then
436 is_smooth_option(i) = .true.
437 source_smooth_option(i) = ONETWOONE
438 else if ((index('smth-desmth',trim(buffer(idx+1:eos-1))) /= 0) .and. &
439 (len_trim(buffer(idx+1:eos-1)) == len('smth-desmth'))) then
440 is_smooth_option(i) = .true.
441 source_smooth_option(i) = SMTHDESMTH
442 else if ((index('smth-desmth_special',trim(buffer(idx+1:eos-1))) /= 0) .and. &
443 (len_trim(buffer(idx+1:eos-1)) == len('smth-desmth_special'))) then
444 is_smooth_option(i) = .true.
445 source_smooth_option(i) = SMTHDESMTH_SPECIAL
446 end if
448 else if (index('smooth_passes',trim(buffer(1:idx-1))) /= 0) then
449 is_smooth_passes(i) = .true.
450 read(buffer(idx+1:eos-1),'(i10)') source_smooth_passes(i)
452 else if (index('rel_path',trim(buffer(1:idx-1))) /= 0) then
453 ispace = idx+1
454 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
455 ispace = ispace + 1
456 end do
457 path_string = ' '
458 path_string(1:ispace-idx-1) = buffer(idx+1:ispace-1)
459 if (path_string(ispace-idx-1:ispace-idx-1) /= '/') &
460 path_string(ispace-idx:ispace-idx) = '/'
461 if (path_string(1:1) == '/') then
462 path_string(1:127) = path_string(2:128)
463 path_string(128:128) = ' '
464 end if
465 ispace = index(path_string,':')
466 if (ispace /= 0) then
467 write(res_string,'(a)') path_string(1:ispace-1)
468 else
469 res_string = 'default'
470 end if
471 write(path_string,'(a)') trim(geog_data_path)//trim(path_string(ispace+1:128))
472 if (list_search(source_res_path(i), ckey=res_string, cvalue=path_string)) then
473 call mprintf(.true., WARN, &
474 'In GEOGRID.TBL entry %i, multiple paths are given for '// &
475 'resolution %s. %s will be used.', &
476 i1=i, s1=trim(res_string), s2=trim(path_string))
477 else
478 call list_insert(source_res_path(i), ckey=res_string, cvalue=path_string)
479 end if
481 else if (index('abs_path',trim(buffer(1:idx-1))) /= 0) then
482 ispace = idx+1
483 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
484 ispace = ispace + 1
485 end do
486 path_string = ' '
487 path_string(1:ispace-idx-1) = buffer(idx+1:ispace-1)
488 if (path_string(ispace-idx-1:ispace-idx-1) /= '/') &
489 path_string(ispace-idx:ispace-idx) = '/'
490 ispace = index(path_string,':')
491 if (ispace /= 0) then
492 write(res_string,'(a)') path_string(1:ispace-1)
493 else
494 res_string = 'default'
495 end if
496 write(path_string,'(a)') trim(path_string(ispace+1:128))
497 if (list_search(source_res_path(i), ckey=res_string, cvalue=path_string)) then
498 call mprintf(.true., WARN, &
499 'In GEOGRID.TBL entry %i, multiple paths are given for '// &
500 'resolution %s. %s will be used.', &
501 i1=i, s1=trim(res_string), s2=trim(path_string))
502 else
503 call list_insert(source_res_path(i), ckey=res_string, cvalue=path_string)
504 end if
506 else if (index('output_stagger',trim(buffer(1:idx-1))) /= 0) then
507 if (index('M',trim(buffer(idx+1:eos-1))) /= 0) then
508 is_output_stagger(i) = .true.
509 source_output_stagger(i) = M
510 else if (index('U',trim(buffer(idx+1:eos-1))) /= 0) then
511 is_output_stagger(i) = .true.
512 source_output_stagger(i) = U
513 else if (index('V',trim(buffer(idx+1:eos-1))) /= 0) then
514 is_output_stagger(i) = .true.
515 source_output_stagger(i) = V
516 else if (index('HH',trim(buffer(idx+1:eos-1))) /= 0) then
517 is_output_stagger(i) = .true.
518 source_output_stagger(i) = HH
519 else if (index('VV',trim(buffer(idx+1:eos-1))) /= 0) then
520 is_output_stagger(i) = .true.
521 source_output_stagger(i) = VV
522 end if
524 else if ((index('landmask_water',trim(buffer(1:idx-1))) /= 0) .and. &
525 (len_trim(buffer(1:idx-1)) == 14)) then
526 ispace = idx+1
527 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
528 ispace = ispace + 1
529 end do
530 landmask_string = ' '
531 landmask_string(1:ispace-idx-1) = buffer(idx+1:ispace-1)
532 ispace = index(landmask_string,':')
533 if (ispace /= 0) then
534 write(res_string,'(a)') landmask_string(1:ispace-1)
535 else
536 res_string = 'default'
537 end if
538 write(landmask_string,'(a)') trim(landmask_string(ispace+1:128))
539 if (list_search(source_landmask_water(i), ckey=res_string, cvalue=landmask_string)) then
540 call mprintf(.true., WARN, &
541 'In GEOGRID.TBL entry %i, multiple landmask category specifications are given for '// &
542 'resolution %s. %s will be used.', &
543 i1=i, s1=trim(res_string), s2=trim(landmask_string))
544 else
545 call list_insert(source_landmask_water(i), ckey=res_string, cvalue=landmask_string)
546 end if
548 else if ((index('landmask_land',trim(buffer(1:idx-1))) /= 0) .and. &
549 (len_trim(buffer(1:idx-1)) == 13)) then
550 ispace = idx+1
551 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
552 ispace = ispace + 1
553 end do
554 landmask_string = ' '
555 landmask_string(1:ispace-idx-1) = buffer(idx+1:ispace-1)
556 ispace = index(landmask_string,':')
557 if (ispace /= 0) then
558 write(res_string,'(a)') landmask_string(1:ispace-1)
559 else
560 res_string = 'default'
561 end if
562 write(landmask_string,'(a)') trim(landmask_string(ispace+1:128))
563 if (list_search(source_landmask_land(i), ckey=res_string, cvalue=landmask_string)) then
564 call mprintf(.true., WARN, &
565 'In GEOGRID.TBL entry %i, multiple landmask category specifications are given for '// &
566 'resolution %s. %s will be used.', &
567 i1=i, s1=trim(res_string), s2=trim(landmask_string))
568 else
569 call list_insert(source_landmask_land(i), ckey=res_string, cvalue=landmask_string)
570 end if
572 else if ((index('masked',trim(buffer(1:idx-1))) /= 0) .and. &
573 (len_trim(buffer(1:idx-1)) == 6)) then
574 if (index('water',trim(buffer(idx+1:eos-1))) /= 0) then
575 is_masked(i) = .true.
576 source_masked(i) = 0.
577 else if (index('land',trim(buffer(idx+1:eos-1))) /= 0) then
578 is_masked(i) = .true.
579 source_masked(i) = 1.
580 end if
582 else if (index('fill_missing',trim(buffer(1:idx-1))) /= 0) then
583 is_fill_missing(i) = .true.
584 read(buffer(idx+1:eos-1),*) source_fill_missing(i)
586 else if (index('halt_on_missing',trim(buffer(1:idx-1))) /= 0) then
587 if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then
588 is_halt_missing(i) = .true.
589 else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then
590 is_halt_missing(i) = .false.
591 end if
593 else if (index('dominant_category',trim(buffer(1:idx-1))) /= 0) then
594 ispace = idx+1
595 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
596 ispace = ispace + 1
597 end do
598 is_dominant_category(i) = .true.
599 source_dominant_category(i) = ' '
600 source_dominant_category(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
602 else if (index('dominant_only',trim(buffer(1:idx-1))) /= 0) then
603 ispace = idx+1
604 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
605 ispace = ispace + 1
606 end do
607 is_dominant_only(i) = .true.
608 source_dominant_only(i) = ' '
609 source_dominant_only(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
611 else if (index('df_dx',trim(buffer(1:idx-1))) /= 0) then
612 ispace = idx+1
613 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
614 ispace = ispace + 1
615 end do
616 is_dfdx(i) = .true.
617 source_dfdx(i) = ' '
618 source_dfdx(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
620 else if (index('df_dy',trim(buffer(1:idx-1))) /= 0) then
621 ispace = idx+1
622 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
623 ispace = ispace + 1
624 end do
625 is_dfdy(i) = .true.
626 source_dfdy(i) = ' '
627 source_dfdy(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
629 else if (index('z_dim_name',trim(buffer(1:idx-1))) /= 0) then
630 ispace = idx+1
631 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
632 ispace = ispace + 1
633 end do
634 is_z_dim_name(i) = .true.
635 source_z_dim_name(i) = ' '
636 source_z_dim_name(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
638 else if (index('subgrid',trim(buffer(1:idx-1))) /= 0) then
639 if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then
640 is_subgrid(i) = .true.
641 else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then
642 is_subgrid(i) = .false.
643 end if
645 else if (index('flag_in_output',trim(buffer(1:idx-1))) /= 0) then
646 ispace = idx+1
647 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
648 ispace = ispace + 1
649 end do
650 is_output_flag(i) = .true.
651 source_output_flag(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
653 else
654 call mprintf(.true., WARN, 'In GEOGRID.TBL, unrecognized option %s in '// &
655 'entry %i.',i1=idx, s1=buffer(i:idx-1))
657 end if
659 end if !} index(buffer(1:eos-1),'=') /= 0
661 buffer = buffer(eos+1:BUFSIZE)
662 end do ! while eos /= 0 }
664 end if !} index(buffer, '=====') /= 0
665 go to 30
667 40 close(funit)
669 ! Check the user specifications for gross errors
670 if ( .not. check_data_specification() ) then
671 call datalist_destroy()
672 call mprintf(.true.,ERROR,'Errors were found in either index files or GEOGRID.TBL.')
673 end if
675 call hash_init(bad_files)
677 return
679 1000 call mprintf(.true.,ERROR,'Could not open GEOGRID.TBL')
681 1001 call mprintf(.true.,ERROR,'Encountered error while reading GEOGRID.TBL')
683 end subroutine get_datalist
686 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
687 ! Name: get_source_params
688 !
689 ! Purpose: For each field, this routine reads in the metadata in the index file
690 ! for the first available resolution of data specified by res_string. Also
691 ! based on res_string, this routine sets the interpolation sequence for the
692 ! field. This routine should be called prior to processing a field for each
693 ! domain.
694 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
695 subroutine get_source_params(res_string)
697 use stringutil
699 implicit none
701 ! Parameters
702 integer, parameter :: BUFSIZE = 256
704 ! Arguments
705 character (len=128), intent(in) :: res_string
707 ! Local variables
708 integer :: idx, i, is, ie, ispace, eos, iquoted, funit
709 character (len=128) :: temp_data, temp_interp
710 character (len=256) :: test_fname
711 character (len=BUFSIZE) :: buffer
712 logical :: have_specification, is_used
714 ! For each entry in the GEOGRID.TBL file
715 do idx=1,num_entries
717 ! Initialize metadata
718 is_wordsize(idx) = .false.
719 is_endian(idx) = .false.
720 is_row_order(idx) = .false.
721 is_fieldtype(idx) = .false.
722 is_proj(idx) = .false.
723 is_dx(idx) = .false.
724 is_dy(idx) = .false.
725 is_known_x(idx) = .false.
726 is_known_y(idx) = .false.
727 is_known_lat(idx) = .false.
728 is_known_lon(idx) = .false.
729 is_truelat1(idx) = .false.
730 is_truelat2(idx) = .false.
731 is_stdlon(idx) = .false.
732 is_tile_x(idx) = .false.
733 is_tile_y(idx) = .false.
734 is_tile_z(idx) = .false.
735 is_tile_z_start(idx) = .false.
736 is_tile_z_end(idx) = .false.
737 is_category_min(idx) = .false.
738 is_category_max(idx) = .false.
739 is_tile_bdr(idx) = .false.
740 is_fieldname(idx) = .false.
741 is_scale_factor(idx) = .false.
742 is_units(idx) = .false.
743 is_descr(idx) = .false.
744 is_signed(idx) = .false.
745 is_missing_value(idx) = .false.
748 ! Set the interpolator sequence for the field to be the first value in res_string that matches
749 ! the resolution keyword for an interp_sequence specification
750 is = 1
751 ie = index(res_string(is:128),'+') - 1
752 if (ie <= 0) ie = 128
753 temp_interp = res_string(is:ie)
754 do while (.not. list_search(source_interp_option(idx), ckey=temp_interp, cvalue=source_interp_string(idx)) &
755 .and. is <= 128)
756 call mprintf(.true., INFORM, 'For %s, couldn''t find interpolator sequence for '// &
757 'resolution %s.', &
758 s1=trim(source_fieldname(idx)), s2=trim(temp_interp))
759 is = ie+2
760 ie = is + index(res_string(is:128),'+') - 2
761 if (ie - is <= 0) ie = 128
762 temp_interp = res_string(is:ie)
763 end do
765 if (is > 128) then
766 temp_interp = 'default'
767 if (list_search(source_interp_option(idx), ckey=temp_interp, cvalue=source_interp_string(idx))) then
768 call mprintf(.true., INFORM, 'Using default interpolator sequence for %s.', &
769 s1=trim(source_fieldname(idx)))
770 else
771 call mprintf(.true., ERROR, 'Could not find interpolator sequence for requested resolution for %s.'// &
772 ' The sources specified in namelist.wps is not listed in GEOGRID.TBL.', &
773 s1=trim(source_fieldname(idx)))
774 end if
775 else
776 call mprintf(.true., INFORM, 'Using %s interpolator sequence for %s.', &
777 s1=temp_interp, s2=trim(source_fieldname(idx)))
778 end if
780 ! Set the data source for the field to be the first value in res_string that matches
781 ! the resolution keyword for an abs_path or rel_path specification
782 is = 1
783 ie = index(res_string(is:128),'+') - 1
784 if (ie <= 0) ie = 128
785 temp_data = res_string(is:ie)
786 do while (.not. list_search(source_res_path(idx), ckey=temp_data, cvalue=source_path(idx)) &
787 .and. is <= 128)
788 call mprintf(.true., INFORM, 'For %s, couldn''t find %s data source.', &
789 s1=trim(source_fieldname(idx)), s2=trim(temp_data))
790 is = ie+2
791 ie = is + index(res_string(is:128),'+') - 2
792 if (ie - is <= 0) ie = 128
793 temp_data = res_string(is:ie)
794 end do
796 if (is > 128) then
797 temp_data = 'default'
798 if (list_search(source_res_path(idx), ckey=temp_data, cvalue=source_path(idx))) then
799 call mprintf(.true., INFORM, 'Using default data source for %s.', &
800 s1=trim(source_fieldname(idx)))
801 else
802 call mprintf(.true., ERROR, 'Could not find data resolution for requested resolution for %s. '// &
803 'The source specified in namelist.wps is not listed in GEOGRID.TBL.', &
804 s1=trim(source_fieldname(idx)))
805 end if
806 else
807 call mprintf(.true., INFORM, 'Using %s data source for %s.', &
808 s1=temp_data, s2=trim(source_fieldname(idx)))
809 end if
811 call mprintf(trim(temp_data) /= trim(temp_interp),WARN,'For %s, using %s data source with %s interpolation sequence.', &
812 s1=source_fieldname(idx), s2=temp_data, s3=temp_interp)
814 write(test_fname, '(a)') trim(source_path(idx))//'index'
816 !
817 ! Open the index file for the data source for this field, and read in metadata specs
818 !
819 do funit=10,100
820 inquire(unit=funit, opened=is_used)
821 if (.not. is_used) exit
822 end do
823 open(funit,file=trim(test_fname),form='formatted',status='old',err=1000)
825 30 buffer = ' '
826 read(funit,'(a)',end=40, err=1001) buffer
827 call despace(buffer)
829 ! Is this line a comment?
830 if (buffer(1:1) == '#') then
831 ! Do nothing.
833 else
834 have_specification = .true.
836 ! If only part of the line is a comment, just turn the comment into spaces
837 eos = index(buffer,'#')
838 if (eos /= 0) buffer(eos:BUFSIZE) = ' '
840 do while (have_specification) !{
842 ! If this line has no semicolon, it may contain a single specification,
843 ! so we set have_specification = .false. to prevent the line from being
844 ! processed again and pretend that the last character was a semicolon
845 eos = index(buffer,';')
846 if (eos == 0) then
847 have_specification = .false.
848 eos = BUFSIZE
849 end if
851 i = index(buffer(1:eos-1),'=')
853 if (i /= 0) then !{
855 if (index('projection',trim(buffer(1:i-1))) /= 0) then
856 if (index('lambert',trim(buffer(i+1:eos-1))) /= 0) then
857 is_proj(idx) = .true.
858 source_proj(idx) = PROJ_LC
859 else if (index('polar_wgs84',trim(buffer(i+1:eos-1))) /= 0 .and. &
860 len_trim('polar_wgs84') == len_trim(buffer(i+1:eos-1))) then
861 is_proj(idx) = .true.
862 source_proj(idx) = PROJ_PS_WGS84
863 else if (index('albers_nad83',trim(buffer(i+1:eos-1))) /= 0 .and. &
864 len_trim('albers_nad83') == len_trim(buffer(i+1:eos-1))) then
865 is_proj(idx) = .true.
866 source_proj(idx) = PROJ_ALBERS_NAD83
867 else if (index('polar',trim(buffer(i+1:eos-1))) /= 0 .and. &
868 len_trim('polar') == len_trim(buffer(i+1:eos-1))) then
869 is_proj(idx) = .true.
870 source_proj(idx) = PROJ_PS
871 else if (index('mercator',trim(buffer(i+1:eos-1))) /= 0) then
872 is_proj(idx) = .true.
873 source_proj(idx) = PROJ_MERC
874 else if (index('regular_ll',trim(buffer(i+1:eos-1))) /= 0) then
875 is_proj(idx) = .true.
876 source_proj(idx) = PROJ_LATLON
877 end if
879 else if (index('type',trim(buffer(1:i-1))) /= 0) then
880 if (index('continuous',trim(buffer(i+1:eos-1))) /= 0) then
881 is_fieldtype(idx) = .true.
882 source_fieldtype(idx) = CONTINUOUS
883 else if (index('categorical',trim(buffer(i+1:eos-1))) /= 0) then
884 is_fieldtype(idx) = .true.
885 source_fieldtype(idx) = CATEGORICAL
886 end if
888 else if (index('signed',trim(buffer(1:i-1))) /= 0) then
889 if (index('yes',trim(buffer(i+1:eos-1))) /= 0) then
890 is_signed(idx) = .true.
891 else if (index('no',trim(buffer(i+1:eos-1))) /= 0) then
892 is_signed(idx) = .false.
893 end if
895 else if (index('units',trim(buffer(1:i-1))) /= 0) then
896 ispace = i+1
897 iquoted = 0
898 do while (((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) .or. (iquoted == 1))
899 if (buffer(ispace:ispace) == '"' .or. buffer(ispace:ispace) == '''') iquoted = mod(iquoted+1,2)
900 ispace = ispace + 1
901 end do
902 is_units(idx) = .true.
903 source_units(idx) = ' '
904 if (buffer(i+1:i+1) == '"' .or. buffer(i+1:i+1) == '''') i = i + 1
905 if (buffer(ispace-1:ispace-1) == '"' .or. buffer(ispace-1:ispace-1) == '''') ispace = ispace - 1
906 source_units(idx)(1:ispace-i) = buffer(i+1:ispace-1)
908 else if (index('description',trim(buffer(1:i-1))) /= 0) then
909 ispace = i+1
910 iquoted = 0
911 do while (((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) .or. (iquoted == 1))
912 if (buffer(ispace:ispace) == '"' .or. buffer(ispace:ispace) == '''') iquoted = mod(iquoted+1,2)
913 ispace = ispace + 1
914 end do
915 is_descr(idx) = .true.
916 source_descr(idx) = ' '
917 if (buffer(i+1:i+1) == '"' .or. buffer(i+1:i+1) == '''') i = i + 1
918 if (buffer(ispace-1:ispace-1) == '"' .or. buffer(ispace-1:ispace-1) == '''') ispace = ispace - 1
919 source_descr(idx)(1:ispace-i) = buffer(i+1:ispace-1)
921 else if (index('mminlu',trim(buffer(1:i-1))) /= 0) then
922 ispace = i+1
923 iquoted = 0
924 do while (((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) .or. (iquoted == 1))
925 if (buffer(ispace:ispace) == '"' .or. buffer(ispace:ispace) == '''') iquoted = mod(iquoted+1,2)
926 ispace = ispace + 1
927 end do
928 if (buffer(i+1:i+1) == '"' .or. buffer(i+1:i+1) == '''') i = i + 1
929 if (buffer(ispace-1:ispace-1) == '"' .or. buffer(ispace-1:ispace-1) == '''') ispace = ispace - 1
930 source_mminlu(1:ispace-i) = buffer(i+1:ispace-1)
932 else if (index('iswater',trim(buffer(1:i-1))) /= 0) then
933 read(buffer(i+1:eos-1),*) source_iswater
935 else if (index('islake',trim(buffer(1:i-1))) /= 0) then
936 read(buffer(i+1:eos-1),*) source_islake
938 else if (index('isice',trim(buffer(1:i-1))) /= 0) then
939 read(buffer(i+1:eos-1),*) source_isice
941 else if (index('isurban',trim(buffer(1:i-1))) /= 0) then
942 read(buffer(i+1:eos-1),*) source_isurban
944 else if (index('isoilwater',trim(buffer(1:i-1))) /= 0) then
945 read(buffer(i+1:eos-1),*) source_isoilwater
947 else if (index('dx',trim(buffer(1:i-1))) /= 0) then
948 is_dx(idx) = .true.
949 read(buffer(i+1:eos-1),*) source_dx(idx)
951 else if (index('dy',trim(buffer(1:i-1))) /= 0) then
952 is_dy(idx) = .true.
953 read(buffer(i+1:eos-1),*) source_dy(idx)
955 else if (index('known_x',trim(buffer(1:i-1))) /= 0) then
956 is_known_x(idx) = .true.
957 read(buffer(i+1:eos-1),*) source_known_x(idx)
959 else if (index('known_y',trim(buffer(1:i-1))) /= 0) then
960 is_known_y(idx) = .true.
961 read(buffer(i+1:eos-1),*) source_known_y(idx)
963 else if (index('known_lat',trim(buffer(1:i-1))) /= 0) then
964 is_known_lat(idx) = .true.
965 read(buffer(i+1:eos-1),*) source_known_lat(idx)
967 else if (index('known_lon',trim(buffer(1:i-1))) /= 0) then
968 is_known_lon(idx) = .true.
969 read(buffer(i+1:eos-1),*) source_known_lon(idx)
971 else if (index('stdlon',trim(buffer(1:i-1))) /= 0) then
972 is_stdlon(idx) = .true.
973 read(buffer(i+1:eos-1),*) source_stdlon(idx)
975 else if (index('truelat1',trim(buffer(1:i-1))) /= 0) then
976 is_truelat1(idx) = .true.
977 read(buffer(i+1:eos-1),*) source_truelat1(idx)
979 else if (index('truelat2',trim(buffer(1:i-1))) /= 0) then
980 is_truelat2(idx) = .true.
981 read(buffer(i+1:eos-1),*) source_truelat2(idx)
983 else if (index('wordsize',trim(buffer(1:i-1))) /= 0) then
984 is_wordsize(idx) = .true.
985 read(buffer(i+1:eos-1),'(i10)') source_wordsize(idx)
987 else if (index('endian',trim(buffer(1:i-1))) /= 0) then
988 if (index('big',trim(buffer(i+1:eos-1))) /= 0) then
989 is_endian(idx) = .true.
990 source_endian(idx) = BIG_ENDIAN
991 else if (index('little',trim(buffer(i+1:eos-1))) /= 0) then
992 is_endian(idx) = .true.
993 source_endian(idx) = LITTLE_ENDIAN
994 else
995 call mprintf(.true.,WARN,'Invalid value for keyword ''endian'' '// &
996 'specified in index file. BIG_ENDIAN will be used.')
997 end if
999 else if (index('row_order',trim(buffer(1:i-1))) /= 0) then
1000 if (index('bottom_top',trim(buffer(i+1:eos-1))) /= 0) then
1001 is_row_order(idx) = .true.
1002 source_row_order(idx) = BOTTOM_TOP
1003 else if (index('top_bottom',trim(buffer(i+1:eos-1))) /= 0) then
1004 is_row_order(idx) = .true.
1005 source_row_order(idx) = TOP_BOTTOM
1006 end if
1008 else if (index('tile_x',trim(buffer(1:i-1))) /= 0) then
1009 is_tile_x(idx) = .true.
1010 read(buffer(i+1:eos-1),'(i10)') source_tile_x(idx)
1012 else if (index('tile_y',trim(buffer(1:i-1))) /= 0) then
1013 is_tile_y(idx) = .true.
1014 read(buffer(i+1:eos-1),'(i10)') source_tile_y(idx)
1016 else if (index('tile_z',trim(buffer(1:i-1))) /= 0) then
1017 is_tile_z(idx) = .true.
1018 read(buffer(i+1:eos-1),'(i10)') source_tile_z(idx)
1020 else if (index('tile_z_start',trim(buffer(1:i-1))) /= 0) then
1021 is_tile_z_start(idx) = .true.
1022 read(buffer(i+1:eos-1),'(i10)') source_tile_z_start(idx)
1024 else if (index('tile_z_end',trim(buffer(1:i-1))) /= 0) then
1025 is_tile_z_end(idx) = .true.
1026 read(buffer(i+1:eos-1),'(i10)') source_tile_z_end(idx)
1028 else if (index('category_min',trim(buffer(1:i-1))) /= 0) then
1029 is_category_min(idx) = .true.
1030 read(buffer(i+1:eos-1),'(i10)') source_category_min(idx)
1032 else if (index('category_max',trim(buffer(1:i-1))) /= 0) then
1033 is_category_max(idx) = .true.
1034 read(buffer(i+1:eos-1),'(i10)') source_category_max(idx)
1036 else if (index('tile_bdr',trim(buffer(1:i-1))) /= 0) then
1037 is_tile_bdr(idx) = .true.
1038 read(buffer(i+1:eos-1),'(i10)') source_tile_bdr(idx)
1040 else if (index('missing_value',trim(buffer(1:i-1))) /= 0) then
1041 is_missing_value(idx) = .true.
1042 read(buffer(i+1:eos-1),*) source_missing_value(idx)
1044 else if (index('scale_factor',trim(buffer(1:i-1))) /= 0) then
1045 is_scale_factor(idx) = .true.
1046 read(buffer(i+1:eos-1),*) source_scale_factor(idx)
1048 else
1049 call mprintf(.true., WARN, 'In %s, unrecognized option %s in entry %i.', &
1050 s1=trim(test_fname), s2=buffer(i:i-1), i1=i)
1052 end if
1054 end if !} index(buffer(1:eos-1),'=') /= 0
1056 buffer = buffer(eos+1:BUFSIZE)
1057 end do ! while eos /= 0 }
1059 end if !} index(buffer, '=====') /= 0
1061 go to 30
1063 40 close(funit)
1065 end do
1067 return
1069 1000 call mprintf(.true.,ERROR,'Could not open %s', s1=trim(test_fname))
1070 1001 call mprintf(.true.,ERROR,'Encountered error while reading %s', s1=trim(test_fname))
1072 end subroutine get_source_params
1075 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1076 ! Name: datalist_destroy()
1077 !
1078 ! Purpose: This routine deallocates any memory that was allocated by the
1079 ! get_datalist() subroutine.
1080 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1081 subroutine datalist_destroy()
1083 implicit none
1085 ! Local variables
1086 integer :: i
1088 if (associated(source_wordsize)) then
1089 deallocate(source_wordsize)
1090 deallocate(source_endian)
1091 deallocate(source_fieldtype)
1092 deallocate(source_dest_fieldtype)
1093 deallocate(source_proj)
1094 deallocate(source_priority)
1095 deallocate(source_dx)
1096 deallocate(source_dy)
1097 deallocate(source_known_x)
1098 deallocate(source_known_y)
1099 deallocate(source_known_lat)
1100 deallocate(source_known_lon)
1101 deallocate(source_truelat1)
1102 deallocate(source_truelat2)
1103 deallocate(source_stdlon)
1104 deallocate(source_fieldname)
1105 deallocate(source_path)
1106 deallocate(source_interp_string)
1107 deallocate(source_tile_x)
1108 deallocate(source_tile_y)
1109 deallocate(source_tile_z)
1110 deallocate(source_tile_z_start)
1111 deallocate(source_tile_z_end)
1112 deallocate(source_tile_bdr)
1113 deallocate(source_category_min)
1114 deallocate(source_category_max)
1115 deallocate(source_masked)
1116 deallocate(source_output_stagger)
1117 deallocate(source_row_order)
1118 deallocate(source_dominant_category)
1119 deallocate(source_dominant_only)
1120 deallocate(source_dfdx)
1121 deallocate(source_dfdy)
1122 deallocate(source_scale_factor)
1123 deallocate(source_z_dim_name)
1124 deallocate(source_smooth_option)
1125 deallocate(source_smooth_passes)
1126 deallocate(source_units)
1127 deallocate(source_descr)
1128 deallocate(source_missing_value)
1129 deallocate(source_fill_missing)
1130 do i=1,num_entries
1131 call list_destroy(source_res_path(i))
1132 call list_destroy(source_interp_option(i))
1133 call list_destroy(source_landmask_land(i))
1134 call list_destroy(source_landmask_water(i))
1135 end do
1136 deallocate(source_res_path)
1137 deallocate(source_interp_option)
1138 deallocate(source_landmask_land)
1139 deallocate(source_landmask_water)
1140 deallocate(source_output_flag)
1142 deallocate(is_wordsize)
1143 deallocate(is_endian)
1144 deallocate(is_fieldtype)
1145 deallocate(is_dest_fieldtype)
1146 deallocate(is_proj)
1147 deallocate(is_priority)
1148 deallocate(is_dx)
1149 deallocate(is_dy)
1150 deallocate(is_known_x)
1151 deallocate(is_known_y)
1152 deallocate(is_known_lat)
1153 deallocate(is_known_lon)
1154 deallocate(is_truelat1)
1155 deallocate(is_truelat2)
1156 deallocate(is_stdlon)
1157 deallocate(is_fieldname)
1158 deallocate(is_path)
1159 deallocate(is_tile_x)
1160 deallocate(is_tile_y)
1161 deallocate(is_tile_z)
1162 deallocate(is_tile_z_start)
1163 deallocate(is_tile_z_end)
1164 deallocate(is_tile_bdr)
1165 deallocate(is_category_min)
1166 deallocate(is_category_max)
1167 deallocate(is_masked)
1168 deallocate(is_halt_missing)
1169 deallocate(is_output_stagger)
1170 deallocate(is_row_order)
1171 deallocate(is_dominant_category)
1172 deallocate(is_dominant_only)
1173 deallocate(is_dfdx)
1174 deallocate(is_dfdy)
1175 deallocate(is_scale_factor)
1176 deallocate(is_z_dim_name)
1177 deallocate(is_smooth_option)
1178 deallocate(is_smooth_passes)
1179 deallocate(is_signed)
1180 deallocate(is_units)
1181 deallocate(is_descr)
1182 deallocate(is_missing_value)
1183 deallocate(is_fill_missing)
1184 deallocate(is_subgrid)
1185 deallocate(is_output_flag)
1186 end if
1188 call hash_destroy(bad_files)
1190 end subroutine datalist_destroy
1193 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1194 ! Name: reset_next_field
1195 !
1196 ! Purpose: To reset the pointer to the next field in the list of fields
1197 ! specified by the user.
1198 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1199 subroutine reset_next_field()
1201 implicit none
1203 next_field = 1
1205 end subroutine reset_next_field
1208 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1209 ! Name: get_next_fieldname
1210 !
1211 ! Purpose: Calling this routine results in field_name being set to the name of
1212 ! the field currently pointed to. If istatus /= 0 upon return, an error
1213 ! occurred, and the value of field_name is undefined.
1214 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1215 subroutine get_next_fieldname(field_name, istatus)
1217 implicit none
1219 ! Arguments
1220 integer, intent(out) :: istatus
1221 character (len=128), intent(out) :: field_name
1223 istatus = 1
1225 if (next_field <= num_entries) then
1227 field_name = source_fieldname(next_field)
1228 next_field = next_field + 1
1229 istatus = 0
1231 end if
1233 end subroutine get_next_fieldname
1236 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1237 ! Name: get_next_output_fieldname
1238 !
1239 ! Purpose:
1240 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1241 recursive subroutine get_next_output_fieldname(nest_num, field_name, ndims, &
1242 min_cat, max_cat, &
1243 istagger, memorder, dimnames, units, &
1244 description, sr_x, sr_y, istatus)
1246 use gridinfo_module
1248 implicit none
1250 #include "wrf_io_flags.h"
1252 ! Arguments
1253 integer, intent(in) :: nest_num
1254 integer, intent(out) :: istatus, ndims, istagger, min_cat, max_cat
1255 integer, intent(out) :: sr_x, sr_y
1256 character (len=128), intent(out) :: memorder, field_name, units, description
1257 character (len=128), dimension(3), intent(out) :: dimnames
1259 ! Local variables
1260 integer :: temp_fieldtype
1261 integer, dimension(MAX_LANDMASK_CATEGORIES) :: landmask
1262 logical :: is_water_mask, is_dom_only
1263 character (len=128) :: domcat_name, dfdx_name, dfdy_name
1264 character (len=256) :: temphash
1266 istatus = 1
1268 if (output_field_state == RETURN_LANDMASK) then
1269 call hash_init(duplicate_fnames)
1270 call get_landmask_field(geog_data_res(nest_num), field_name, is_water_mask, landmask, istatus)
1271 if (istatus == 0) then
1272 temphash(129:256) = ' '
1273 temphash(1:128) = field_name(1:128)
1274 call hash_insert(duplicate_fnames, temphash)
1275 call get_domcategory_name(field_name, domcat_name, is_dom_only, istatus)
1276 ! We will only save the dominant category
1277 if (is_dom_only .and. (istatus == 0)) then
1278 output_field_state = RETURN_DOMCAT_LM
1279 call get_next_output_fieldname(nest_num, field_name, ndims, &
1280 min_cat, max_cat, istagger, &
1281 memorder, dimnames, units, description, &
1282 sr_x, sr_y, istatus)
1283 return
1284 else
1285 ndims = 2
1286 min_cat = 1
1287 max_cat = 1
1288 temp_fieldtype = iget_fieldtype(field_name, istatus)
1289 if (istatus == 0) then
1290 if (temp_fieldtype == CONTINUOUS) then
1291 call get_max_levels(field_name, min_cat, max_cat, istatus)
1292 else if (temp_fieldtype == CATEGORICAL) then
1293 call get_max_categories(field_name, min_cat, max_cat, istatus)
1294 end if
1295 if (max_cat - min_cat > 0) ndims = 3
1296 end if
1297 call get_output_stagger(field_name, istagger, istatus)
1298 if (istagger == M) then
1299 dimnames(1) = 'west_east'
1300 dimnames(2) = 'south_north'
1301 else if (istagger == U) then
1302 dimnames(1) = 'west_east_stag'
1303 dimnames(2) = 'south_north'
1304 else if (istagger == V) then
1305 dimnames(1) = 'west_east'
1306 dimnames(2) = 'south_north_stag'
1307 else if (istagger == HH) then
1308 dimnames(1) = 'west_east'
1309 dimnames(2) = 'south_north'
1310 else if (istagger == VV) then
1311 dimnames(1) = 'west_east'
1312 dimnames(2) = 'south_north'
1313 end if
1314 if (ndims == 2) then
1315 memorder = 'XY '
1316 dimnames(3) = ' '
1317 else if (ndims == 3) then
1318 memorder = 'XYZ'
1319 call get_z_dim_name(field_name, dimnames(3), istatus)
1320 istatus = 0
1321 else
1322 memorder = ' '
1323 dimnames(3) = ' '
1324 end if
1325 call get_subgrid_dim_name(nest_num, field_name, dimnames(1:2), sr_x, sr_y, istatus)
1326 call get_source_units(field_name, 1, units, istatus)
1327 if (istatus /= 0) units = '-'
1328 call get_source_descr(field_name, 1, description, istatus)
1329 if (istatus /= 0) description = '-'
1330 istatus = 0
1331 output_field_state = RETURN_DOMCAT_LM
1332 end if
1333 else
1334 output_field_state = RETURN_FIELDNAME
1335 call get_next_output_fieldname(nest_num, field_name, ndims, &
1336 min_cat, max_cat, istagger, &
1337 memorder, dimnames, units, description, &
1338 sr_x, sr_y, istatus)
1339 return
1340 end if
1342 else if (output_field_state == RETURN_FIELDNAME) then
1343 call get_next_fieldname(field_name, istatus)
1344 temphash(129:256) = ' '
1345 temphash(1:128) = field_name(1:128)
1346 if (istatus == 0 .and. (.not. hash_search(duplicate_fnames, temphash))) then
1347 call hash_insert(duplicate_fnames, temphash)
1348 call get_domcategory_name(field_name, domcat_name, is_dom_only, istatus)
1349 ! We will only save the dominant category
1350 if (is_dom_only .and. (istatus == 0)) then
1351 output_field_state = RETURN_DOMCAT
1352 call get_next_output_fieldname(nest_num, field_name, ndims, &
1353 min_cat, max_cat, istagger, &
1354 memorder, dimnames, units, description, &
1355 sr_x, sr_y, istatus)
1356 return
1358 ! Return the fractional field
1359 else
1360 ndims = 2
1361 min_cat = 1
1362 max_cat = 1
1363 temp_fieldtype = iget_fieldtype(field_name, istatus)
1364 if (istatus == 0) then
1365 if (temp_fieldtype == CONTINUOUS) then
1366 call get_max_levels(field_name, min_cat, max_cat, istatus)
1367 else if (temp_fieldtype == CATEGORICAL) then
1368 call get_max_categories(field_name, min_cat, max_cat, istatus)
1369 end if
1370 if (max_cat - min_cat > 0) ndims = 3
1371 end if
1372 call get_output_stagger(field_name, istagger, istatus)
1373 if (istagger == M) then
1374 dimnames(1) = 'west_east'
1375 dimnames(2) = 'south_north'
1376 else if (istagger == U) then
1377 dimnames(1) = 'west_east_stag'
1378 dimnames(2) = 'south_north'
1379 else if (istagger == V) then
1380 dimnames(1) = 'west_east'
1381 dimnames(2) = 'south_north_stag'
1382 else if (istagger == HH) then
1383 dimnames(1) = 'west_east'
1384 dimnames(2) = 'south_north'
1385 else if (istagger == VV) then
1386 dimnames(1) = 'west_east'
1387 dimnames(2) = 'south_north'
1388 end if
1389 if (ndims == 2) then
1390 memorder = 'XY '
1391 dimnames(3) = ' '
1392 else if (ndims == 3) then
1393 memorder = 'XYZ'
1394 call get_z_dim_name(field_name, dimnames(3), istatus)
1395 istatus = 0
1396 else
1397 memorder = ' '
1398 dimnames(3) = ' '
1399 end if
1400 call get_subgrid_dim_name(nest_num, field_name, dimnames(1:2), sr_x, sr_y, istatus)
1401 call get_source_units(field_name, 1, units, istatus)
1402 if (istatus /= 0) units = '-'
1403 call get_source_descr(field_name, 1, description, istatus)
1404 if (istatus /= 0) description = '-'
1405 istatus = 0
1406 output_field_state = RETURN_DOMCAT
1407 end if
1408 else if (istatus /= 0) then
1409 output_field_state = RETURN_LANDMASK
1410 call hash_destroy(duplicate_fnames)
1411 return
1412 else if (hash_search(duplicate_fnames, temphash)) then
1413 call get_next_output_fieldname(nest_num, field_name, ndims, &
1414 min_cat, max_cat, istagger, &
1415 memorder, dimnames, units, description, &
1416 sr_x, sr_y, istatus)
1417 return
1418 end if
1420 else if (output_field_state == RETURN_DOMCAT .or. &
1421 output_field_state == RETURN_DOMCAT_LM ) then
1422 if (output_field_state == RETURN_DOMCAT) then
1423 next_field = next_field - 1
1424 call get_next_fieldname(field_name, istatus)
1425 else
1426 call get_landmask_field(geog_data_res(nest_num), field_name, is_water_mask, landmask, istatus)
1427 end if
1428 if (istatus == 0) then
1429 call get_domcategory_name(field_name, domcat_name, is_dom_only, istatus)
1430 if (istatus == 0) then
1431 ndims = 2
1432 min_cat = 1
1433 max_cat = 1
1434 call get_output_stagger(field_name, istagger, istatus)
1435 if (istagger == M) then
1436 dimnames(1) = 'west_east'
1437 dimnames(2) = 'south_north'
1438 else if (istagger == U) then
1439 dimnames(1) = 'west_east_stag'
1440 dimnames(2) = 'south_north'
1441 else if (istagger == V) then
1442 dimnames(1) = 'west_east'
1443 dimnames(2) = 'south_north_stag'
1444 else if (istagger == HH) then
1445 dimnames(1) = 'west_east'
1446 dimnames(2) = 'south_north'
1447 else if (istagger == VV) then
1448 dimnames(1) = 'west_east'
1449 dimnames(2) = 'south_north'
1450 end if
1451 dimnames(3) = ' '
1452 memorder = 'XY '
1454 call get_subgrid_dim_name(nest_num, field_name, dimnames(1:2), sr_x, sr_y, istatus)
1455 field_name = domcat_name
1456 units = 'category'
1457 description = 'Dominant category'
1458 if (output_field_state == RETURN_DOMCAT) then
1459 output_field_state = RETURN_DFDX
1460 else
1461 output_field_state = RETURN_DFDX_LM
1462 end if
1463 else
1464 if (output_field_state == RETURN_DOMCAT) then
1465 output_field_state = RETURN_DFDX
1466 else
1467 output_field_state = RETURN_DFDX_LM
1468 end if
1469 call get_next_output_fieldname(nest_num, field_name, ndims, &
1470 min_cat, max_cat, istagger, &
1471 memorder, dimnames, units, description, &
1472 sr_x, sr_y, istatus)
1473 return
1474 end if
1475 else
1476 call mprintf(.true., ERROR, 'get_next_output_fieldname(): In state DOMCAT, '// &
1477 'but no field name is found.')
1478 end if
1480 else if (output_field_state == RETURN_DFDX .or. &
1481 output_field_state == RETURN_DFDX_LM) then
1482 if (output_field_state == RETURN_DFDX) then
1483 next_field = next_field - 1
1484 call get_next_fieldname(field_name, istatus)
1485 else
1486 call get_landmask_field(geog_data_res(nest_num), field_name, is_water_mask, landmask, istatus)
1487 end if
1488 if (istatus == 0) then
1489 call get_dfdx_name(field_name, dfdx_name, istatus)
1490 if (istatus == 0) then
1491 ndims = 2
1492 min_cat = 1
1493 max_cat = 1
1494 temp_fieldtype = iget_fieldtype(field_name, istatus)
1495 if (istatus == 0) then
1496 if (temp_fieldtype == CONTINUOUS) then
1497 call get_max_levels(field_name, min_cat, max_cat, istatus)
1498 else if (temp_fieldtype == CATEGORICAL) then
1499 call get_max_categories(field_name, min_cat, max_cat, istatus)
1500 end if
1501 if (max_cat - min_cat > 0) ndims = 3
1502 end if
1503 call get_output_stagger(field_name, istagger, istatus)
1504 if (istagger == M) then
1505 dimnames(1) = 'west_east'
1506 dimnames(2) = 'south_north'
1507 else if (istagger == U) then
1508 dimnames(1) = 'west_east_stag'
1509 dimnames(2) = 'south_north'
1510 else if (istagger == V) then
1511 dimnames(1) = 'west_east'
1512 dimnames(2) = 'south_north_stag'
1513 else if (istagger == HH) then
1514 dimnames(1) = 'west_east'
1515 dimnames(2) = 'south_north'
1516 else if (istagger == VV) then
1517 dimnames(1) = 'west_east'
1518 dimnames(2) = 'south_north'
1519 end if
1520 if (ndims == 2) then
1521 memorder = 'XY '
1522 dimnames(3) = ' '
1523 else if (ndims == 3) then
1524 memorder = 'XYZ'
1525 call get_z_dim_name(field_name, dimnames(3), istatus)
1526 istatus = 0
1527 else
1528 memorder = ' '
1529 dimnames(3) = ' '
1530 end if
1531 field_name = dfdx_name
1532 units = '-'
1534 call get_subgrid_dim_name(nest_num, field_name, dimnames(1:2), sr_x, sr_y, istatus)
1535 description = 'df/dx'
1536 if (output_field_state == RETURN_DFDX) then
1537 output_field_state = RETURN_DFDY
1538 else
1539 output_field_state = RETURN_DFDY_LM
1540 end if
1541 else
1542 if (output_field_state == RETURN_DFDX) then
1543 output_field_state = RETURN_DFDY
1544 else
1545 output_field_state = RETURN_DFDY_LM
1546 end if
1547 call get_next_output_fieldname(nest_num, field_name, ndims, &
1548 min_cat, max_cat, istagger, &
1549 memorder, dimnames, units, description, &
1550 sr_x, sr_y, istatus)
1551 return
1552 end if
1553 else
1554 call mprintf(.true., ERROR, 'get_next_output_fieldname(): In state DFDX, '// &
1555 'but no field name is found.')
1556 end if
1558 else if (output_field_state == RETURN_DFDY .or. &
1559 output_field_state == RETURN_DFDY_LM) then
1560 if (output_field_state == RETURN_DFDY) then
1561 next_field = next_field - 1
1562 call get_next_fieldname(field_name, istatus)
1563 else
1564 call get_landmask_field(geog_data_res(nest_num), field_name, is_water_mask, landmask, istatus)
1565 end if
1566 if (istatus == 0) then
1567 call get_dfdy_name(field_name, dfdy_name, istatus)
1568 if (istatus == 0) then
1569 ndims = 2
1570 min_cat = 1
1571 max_cat = 1
1572 temp_fieldtype = iget_fieldtype(field_name, istatus)
1573 if (istatus == 0) then
1574 if (temp_fieldtype == CONTINUOUS) then
1575 call get_max_levels(field_name, min_cat, max_cat, istatus)
1576 else if (temp_fieldtype == CATEGORICAL) then
1577 call get_max_categories(field_name, min_cat, max_cat, istatus)
1578 end if
1579 if (max_cat - min_cat > 0) ndims = 3
1580 end if
1581 call get_output_stagger(field_name, istagger, istatus)
1582 if (istagger == M) then
1583 dimnames(1) = 'west_east'
1584 dimnames(2) = 'south_north'
1585 else if (istagger == U) then
1586 dimnames(1) = 'west_east_stag'
1587 dimnames(2) = 'south_north'
1588 else if (istagger == V) then
1589 dimnames(1) = 'west_east'
1590 dimnames(2) = 'south_north_stag'
1591 else if (istagger == HH) then
1592 dimnames(1) = 'west_east'
1593 dimnames(2) = 'south_north'
1594 else if (istagger == VV) then
1595 dimnames(1) = 'west_east'
1596 dimnames(2) = 'south_north'
1597 end if
1598 if (ndims == 2) then
1599 memorder = 'XY '
1600 dimnames(3) = ' '
1601 else if (ndims == 3) then
1602 memorder = 'XYZ'
1603 call get_z_dim_name(field_name, dimnames(3), istatus)
1604 istatus = 0
1605 else
1606 memorder = ' '
1607 dimnames(3) = ' '
1608 end if
1610 call get_subgrid_dim_name(nest_num, field_name, dimnames(1:2), sr_x, sr_y, istatus)
1611 field_name = dfdy_name
1612 units = '-'
1613 description = 'df/dy'
1614 output_field_state = RETURN_FIELDNAME
1615 else
1616 output_field_state = RETURN_FIELDNAME
1617 call get_next_output_fieldname(nest_num, field_name, ndims, &
1618 min_cat, max_cat, istagger, &
1619 memorder, dimnames, units, description, &
1620 sr_x, sr_y, istatus)
1621 return
1622 end if
1623 else
1624 call mprintf(.true., ERROR, 'get_next_output_fieldname(): In state DFDY, but no '// &
1625 'field name is found.')
1626 end if
1628 end if
1630 end subroutine get_next_output_fieldname
1633 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1634 ! Name: get_landmask_field
1635 !
1636 ! Purpose: To return the name of the field from which the landmask is to be
1637 ! computed. If no error occurs, is_water_mask is .true. if the landmask
1638 ! value specifies the value of water, and .false. if the landmask value
1639 ! specifies the value of land.
1640 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1641 subroutine get_landmask_field(res_string, landmask_name, is_water_mask, landmask, istatus)
1643 implicit none
1645 ! Arguments
1646 character (len=128), intent(in) :: res_string
1647 integer, dimension(:), intent(out) :: landmask
1648 integer, intent(out) :: istatus
1649 logical, intent(out) :: is_water_mask
1650 character (len=128), intent(out) :: landmask_name
1652 ! Local variables
1653 integer :: j
1654 integer :: ilen
1655 integer :: idx
1656 integer :: is, ie, sos, eos, comma
1657 character (len=128) :: temp_res, mask_cat_string
1659 istatus = 1
1661 do idx=1,num_entries
1663 if (list_length(source_landmask_land(idx)) > 0) then
1664 is = 1
1665 ie = index(res_string(is:128),'+') - 1
1666 if (ie <= 0) ie = 128
1667 temp_res = res_string(is:ie)
1668 do while (.not. list_search(source_landmask_land(idx), ckey=temp_res, cvalue=mask_cat_string) &
1669 .and. is <= 128)
1670 is = ie+2
1671 ie = is + index(res_string(is:128),'+') - 2
1672 if (ie - is <= 0) ie = 128
1673 temp_res = res_string(is:ie)
1674 end do
1676 if (is > 128) then
1677 temp_res = 'default'
1678 if (list_search(source_landmask_land(idx), ckey=temp_res, cvalue=mask_cat_string)) then
1679 is_water_mask = .false.
1680 landmask_name = source_fieldname(idx)
1681 istatus = 0
1682 end if
1683 else
1684 is_water_mask = .false.
1685 landmask_name = source_fieldname(idx)
1686 istatus = 0
1687 end if
1689 end if
1691 ! Note: The following cannot be an else-if, since different resolutions of data may
1692 ! specify, alternately, a land or a water mask, and in general we need to search
1693 ! both lists
1695 if (list_length(source_landmask_water(idx)) > 0) then
1696 is = 1
1697 ie = index(res_string(is:128),'+') - 1
1698 if (ie <= 0) ie = 128
1699 temp_res = res_string(is:ie)
1700 do while (.not. list_search(source_landmask_water(idx), ckey=temp_res, cvalue=mask_cat_string) &
1701 .and. is <= 128)
1702 is = ie+2
1703 ie = is + index(res_string(is:128),'+') - 2
1704 if (ie - is <= 0) ie = 128
1705 temp_res = res_string(is:ie)
1706 end do
1708 if (is > 128) then
1709 temp_res = 'default'
1710 if (list_search(source_landmask_water(idx), ckey=temp_res, cvalue=mask_cat_string)) then
1711 is_water_mask = .true.
1712 landmask_name = source_fieldname(idx)
1713 istatus = 0
1714 end if
1715 else
1716 is_water_mask = .true.
1717 landmask_name = source_fieldname(idx)
1718 istatus = 0
1719 end if
1720 end if
1722 if (istatus == 0) then
1723 j = 1
1724 sos = 0
1725 eos = 128
1726 comma = index(mask_cat_string(sos+1:eos-1),',')
1727 do while (comma > 0 .and. j < MAX_LANDMASK_CATEGORIES)
1728 read(mask_cat_string(sos+1:sos+comma-1),'(i10)') landmask(j)
1729 sos = sos + comma
1730 comma = index(mask_cat_string(sos+1:eos-1),',')
1731 j = j + 1
1732 end do
1733 read(mask_cat_string(sos+1:eos-1),'(i10)') landmask(j)
1734 j = j + 1
1735 if (j <= MAX_LANDMASK_CATEGORIES) then ! Terminate list with a flag value
1736 landmask(j) = INVALID
1737 end if
1738 exit
1739 end if
1741 end do
1743 end subroutine get_landmask_field
1746 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1747 ! Name: get_missing_value
1748 !
1749 ! Pupose: Return the value used in the source data to indicate missing data.
1750 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1751 subroutine get_missing_value(fieldnm, ilevel, rmissing, istatus)
1753 implicit none
1755 ! Arguments
1756 integer, intent(in) :: ilevel
1757 integer, intent(out) :: istatus
1758 real, intent(out) :: rmissing
1759 character (len=128), intent(in) :: fieldnm
1761 ! Local variables
1762 integer :: idx
1764 istatus = 1
1766 do idx=1,num_entries
1767 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
1768 (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) .and. &
1769 (source_priority(idx) == ilevel)) then
1771 if (is_missing_value(idx)) then
1772 rmissing = source_missing_value(idx)
1773 istatus = 0
1774 exit
1775 end if
1777 end if
1778 end do
1780 end subroutine get_missing_value
1783 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1784 ! Name: get_source_units
1785 !
1786 ! Pupose: Return a string giving the units of the specified source data.
1787 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1788 subroutine get_source_units(fieldnm, ilevel, cunits, istatus)
1790 implicit none
1792 ! Arguments
1793 integer, intent(in) :: ilevel
1794 integer, intent(out) :: istatus
1795 character (len=128), intent(in) :: fieldnm
1796 character (len=128), intent(out) :: cunits
1798 ! Local variables
1799 integer :: idx
1801 istatus = 1
1803 do idx=1,num_entries
1804 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
1805 (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) .and. &
1806 (source_priority(idx) == ilevel)) then
1808 if (is_units(idx)) then
1809 cunits = source_units(idx)
1810 istatus = 0
1811 exit
1812 end if
1814 end if
1815 end do
1817 end subroutine get_source_units
1820 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1821 ! Name: get_source_descr
1822 !
1823 ! Pupose: Return a string giving a description of the specified source data.
1824 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1825 subroutine get_source_descr(fieldnm, ilevel, descr, istatus)
1827 implicit none
1829 ! Arguments
1830 integer, intent(in) :: ilevel
1831 integer, intent(out) :: istatus
1832 character (len=128), intent(in) :: fieldnm
1833 character (len=128), intent(out) :: descr
1835 ! Local variables
1836 integer :: idx
1838 istatus = 1
1840 do idx=1,num_entries
1841 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
1842 (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) .and. &
1843 (source_priority(idx) == ilevel)) then
1845 if (is_units(idx)) then
1846 descr = source_descr(idx)
1847 istatus = 0
1848 exit
1849 end if
1851 end if
1852 end do
1854 end subroutine get_source_descr
1857 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1858 ! Name: get_missing_fill_value
1859 !
1860 ! Pupose: Return the value to fill missing points with.
1861 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1862 subroutine get_missing_fill_value(fieldnm, rmissing, istatus)
1864 implicit none
1866 ! Arguments
1867 integer, intent(out) :: istatus
1868 real, intent(out) :: rmissing
1869 character (len=128), intent(in) :: fieldnm
1871 ! Local variables
1872 integer :: idx
1874 istatus = 1
1876 do idx=1,num_entries
1877 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
1878 (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) ) then
1880 if (is_fill_missing(idx)) then
1881 rmissing = source_fill_missing(idx)
1882 istatus = 0
1883 exit
1884 end if
1886 end if
1887 end do
1889 end subroutine get_missing_fill_value
1892 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1893 ! Name: get_halt_on_missing
1894 !
1895 ! Pupose: Returns 1 if the program should halt upon encountering a missing
1896 ! value in the final output field, and 0 otherwise.
1897 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1898 subroutine get_halt_on_missing(fieldnm, halt, istatus)
1900 implicit none
1902 ! Arguments
1903 integer, intent(out) :: istatus
1904 logical, intent(out) :: halt
1905 character (len=128), intent(in) :: fieldnm
1907 ! Local variables
1908 integer :: idx
1910 istatus = 0
1911 halt = .false.
1913 do idx=1,num_entries
1914 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
1915 (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) ) then
1917 if (is_halt_missing(idx)) halt = .true.
1919 end if
1920 end do
1922 end subroutine get_halt_on_missing
1925 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1926 ! Name: get_masked_value
1927 !
1928 ! Pupose: If the field is to be masked by the landmask, returns 0 if the field
1929 ! is masked over water and 1 if the field is masked over land. If no mask is
1930 ! to be applied, -1 is returned.
1931 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1932 subroutine get_masked_value(fieldnm, ilevel, masked, istatus)
1934 implicit none
1936 ! Arguments
1937 integer, intent(in) :: ilevel
1938 integer, intent(out) :: istatus
1939 real, intent(out) :: masked
1940 character (len=128), intent(in) :: fieldnm
1942 ! Local variables
1943 integer :: idx
1945 istatus = 0
1946 masked = -1.
1948 do idx=1,num_entries
1949 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
1950 (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) .and. &
1951 (source_priority(idx) == ilevel)) then
1953 if (is_masked(idx)) then
1954 masked = source_masked(idx)
1955 exit
1956 end if
1958 end if
1959 end do
1961 end subroutine get_masked_value
1964 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1965 ! Name: get_max_levels
1966 !
1967 ! Purpose: Returns the number of levels for the field given by fieldnm.
1968 ! The number of levels will generally be specified for continuous fields,
1969 ! whereas min/max category will generally be specified for categorical ones.
1970 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1971 subroutine get_max_levels(fieldnm, min_level, max_level, istatus)
1973 implicit none
1975 ! Arguments
1976 integer, intent(out) :: min_level, max_level, istatus
1977 character (len=128), intent(in) :: fieldnm
1979 ! Local variables
1980 integer :: idx
1981 logical :: have_found_field
1983 have_found_field = .false.
1984 istatus = 1
1986 do idx=1,num_entries
1987 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
1988 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
1990 if (is_dest_fieldtype(idx) .and. (source_dest_fieldtype(idx) /= CONTINUOUS)) then
1991 call mprintf(.true., WARN, 'In GEOGRID.TBL, destination field type for %s is '// &
1992 'not continuous and min/max levels specified.', s1=trim(fieldnm))
1993 end if
1994 if (.not. have_found_field) then
1995 if (is_tile_z_start(idx) .and. is_tile_z_end(idx)) then
1996 have_found_field = .true.
1997 istatus = 0
1998 min_level = source_tile_z_start(idx)
1999 max_level = source_tile_z_end(idx)
2000 else if (is_tile_z(idx)) then
2001 have_found_field = .true.
2002 istatus = 0
2003 min_level = 1
2004 max_level = source_tile_z(idx)
2005 end if
2007 if (.not. (is_tile_z_start(idx) .and. is_tile_z_end(idx))) then
2008 if (is_tile_z_start(idx) .or. is_tile_z_end(idx)) then
2009 call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of tile_z_start '// &
2010 'and tile_z_end specified for entry %i.',i1=idx)
2011 end if
2012 end if
2013 else
2014 if (is_tile_z_start(idx) .and. is_tile_z_end(idx)) then
2015 if (source_tile_z_start(idx) < min_level) min_level = source_tile_z_start(idx)
2016 if (source_tile_z_end(idx) > max_level) max_level = source_tile_z_end(idx)
2017 else if (is_tile_z(idx)) then
2018 if (min_level > 1) min_level = 1
2019 if (source_tile_z(idx) > max_level) max_level = source_tile_z(idx)
2020 end if
2022 if (.not. (is_tile_z_start(idx) .and. is_tile_z_end(idx))) then
2023 if (is_tile_z_start(idx) .or. is_tile_z_end(idx)) then
2024 call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of tile_z_start '// &
2025 'and tile_z_end specified for entry %i.',i1=idx)
2026 end if
2027 end if
2028 end if
2030 end if
2031 end do
2033 end subroutine get_max_levels
2036 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2037 ! Name: get_source_levels
2038 !
2039 ! Purpose: Return the min and max z-index for the source data for fieldname
2040 ! at a specified priority level (compared with the min/max level over
2041 ! all priority levels, as given by get_max_levels).
2042 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2043 subroutine get_source_levels(fieldnm, ilevel, min_level, max_level, istatus)
2045 implicit none
2047 ! Arguments
2048 integer, intent(in) :: ilevel
2049 integer, intent(out) :: min_level, max_level, istatus
2050 character (len=128), intent(in) :: fieldnm
2052 ! Local variables
2053 integer :: idx
2055 istatus = 1
2057 do idx=1,num_entries
2058 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2059 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2060 if (ilevel == source_priority(idx)) then
2062 if (is_tile_z_start(idx) .and. is_tile_z_end(idx)) then
2063 istatus = 0
2064 min_level = source_tile_z_start(idx)
2065 max_level = source_tile_z_end(idx)
2066 else if (is_tile_z(idx)) then
2067 istatus = 0
2068 min_level = 1
2069 max_level = source_tile_z(idx)
2070 end if
2072 if (.not. (is_tile_z_start(idx) .and. is_tile_z_end(idx))) then
2073 if (is_tile_z_start(idx) .or. is_tile_z_end(idx)) then
2074 call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of tile_z_start '// &
2075 'and tile_z_end specified for entry %i.',i1=idx)
2076 end if
2077 end if
2079 end if
2080 end if
2081 end do
2083 end subroutine get_source_levels
2086 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2087 ! Name: get_max_categories
2088 !
2089 ! Purpose: Returns the minimum category and the maximum category for the field
2090 ! given by fieldnm.
2091 ! Min/max category will generally be specified for categorical fields,
2092 ! whereas the number of levels will generally be specified for continuous
2093 ! fields.
2094 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2095 subroutine get_max_categories(fieldnm, min_category, max_category, istatus)
2097 implicit none
2099 ! Arguments
2100 integer, intent(out) :: min_category, max_category, istatus
2101 character (len=128), intent(in) :: fieldnm
2103 ! Local variables
2104 integer :: idx
2105 logical :: have_found_field
2107 have_found_field = .false.
2108 istatus = 1
2110 do idx=1,num_entries
2111 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2112 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2114 if (is_dest_fieldtype(idx) .and. (source_dest_fieldtype(idx) /= CATEGORICAL)) then
2115 call mprintf(.true., WARN, &
2116 'In GEOGRID.TBL, cannot get min/max categories for continuous '// &
2117 'field %s at entry %i. Perhaps the user has requested to '// &
2118 'perform a strange operation on the field.', s1=trim(fieldnm), i1=idx)
2119 end if
2120 if (.not. have_found_field) then
2121 if (is_category_min(idx) .and. is_category_max(idx)) then
2122 have_found_field = .true.
2123 istatus = 0
2124 min_category = source_category_min(idx)
2125 max_category = source_category_max(idx)
2126 else if (is_category_min(idx) .or. is_category_max(idx)) then
2127 call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of min_category and '// &
2128 'max_category specified for entry %i.',i1=idx)
2129 end if
2130 else
2131 if (is_category_min(idx) .and. is_category_max(idx)) then
2132 if (source_category_min(idx) < min_category) min_category = source_category_min(idx)
2133 if (source_category_max(idx) > max_category) max_category = source_category_max(idx)
2134 else if (is_category_min(idx) .or. is_category_max(idx)) then
2135 call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of min_category and '// &
2136 'max_category specified for entry %i.',i1=idx)
2137 end if
2138 end if
2140 end if
2141 end do
2143 end subroutine get_max_categories
2146 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2147 ! Name: get_source_categories
2148 !
2149 ! Purpose: Return the min and max category for the source data for fieldname
2150 ! at a specified priority level (compared with the min/max category over
2151 ! all priority levels, as given by get_max_categories).
2152 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2153 subroutine get_source_categories(fieldnm, ilevel, min_category, max_category, istatus)
2155 implicit none
2157 ! Arguments
2158 integer, intent(in) :: ilevel
2159 integer, intent(out) :: min_category, max_category, istatus
2160 character (len=128), intent(in) :: fieldnm
2162 ! Local variables
2163 integer :: idx
2165 istatus = 1
2167 do idx=1,num_entries
2168 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2169 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2170 if (ilevel == source_priority(idx)) then
2172 if (is_category_min(idx) .and. is_category_max(idx)) then
2173 istatus = 0
2174 min_category = source_category_min(idx)
2175 max_category = source_category_max(idx)
2176 else if (is_category_min(idx) .or. is_category_max(idx)) then
2177 call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of min_category '// &
2178 'and max_category specified for entry %i.',i1=idx)
2179 end if
2181 end if
2182 end if
2183 end do
2185 end subroutine get_source_categories
2188 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2189 ! Name: get_domcategory_name
2190 !
2191 ! Purpose:
2192 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2193 subroutine get_domcategory_name(fieldnm, domcat_name, ldominant_only, istatus)
2195 implicit none
2197 ! Arguments
2198 integer, intent(out) :: istatus
2199 logical, intent(out) :: ldominant_only
2200 character (len=128), intent(in) :: fieldnm
2201 character (len=128), intent(out) :: domcat_name
2203 ! Local variables
2204 integer :: idx
2206 istatus = 1
2207 ldominant_only = .false.
2209 do idx=1,num_entries
2210 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2211 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2213 if (is_dominant_category(idx)) then
2214 domcat_name = source_dominant_category(idx)
2215 istatus = 0
2216 if (is_dominant_only(idx)) then
2217 call mprintf(.true., WARN, 'In GEOGRID.TBL, both dominant_category and '// &
2218 'dominant_only are specified in entry %i. Using specification '// &
2219 'for dominant_category.',i1=idx)
2220 is_dominant_only(idx) = .false.
2221 end if
2222 exit
2224 else if (is_dominant_only(idx)) then
2225 domcat_name = source_dominant_only(idx)
2226 ldominant_only = .true.
2227 istatus = 0
2228 exit
2229 end if
2231 end if
2232 end do
2234 end subroutine get_domcategory_name
2237 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2238 ! Name: get_dfdx_name
2239 !
2240 ! Purpose:
2241 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2242 subroutine get_dfdx_name(fieldnm, dfdx_name, istatus)
2244 implicit none
2246 ! Arguments
2247 integer, intent(out) :: istatus
2248 character (len=128), intent(in) :: fieldnm
2249 character (len=128), intent(out) :: dfdx_name
2251 ! Local variables
2252 integer :: idx
2254 istatus = 1
2256 do idx=1,num_entries
2257 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2258 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2260 if (is_dfdx(idx)) then
2261 dfdx_name = source_dfdx(idx)
2262 istatus = 0
2263 exit
2264 end if
2266 end if
2267 end do
2269 end subroutine get_dfdx_name
2272 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2273 ! Name: get_dfdy_name
2274 !
2275 ! Purpose:
2276 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2277 subroutine get_dfdy_name(fieldnm, dfdy_name, istatus)
2279 implicit none
2281 ! Arguments
2282 integer, intent(out) :: istatus
2283 character (len=128), intent(in) :: fieldnm
2284 character (len=128), intent(out) :: dfdy_name
2286 ! Local variables
2287 integer :: idx
2289 istatus = 1
2291 do idx=1,num_entries
2292 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2293 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2295 if (is_dfdy(idx)) then
2296 dfdy_name = source_dfdy(idx)
2297 istatus = 0
2298 exit
2299 end if
2301 end if
2302 end do
2304 end subroutine get_dfdy_name
2307 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2308 ! Name: get_z_dim_name
2309 !
2310 ! Purpose:
2311 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2312 subroutine get_z_dim_name(fieldnm, z_dim, istatus)
2314 implicit none
2316 ! Arguments
2317 integer, intent(out) :: istatus
2318 character (len=128), intent(in) :: fieldnm
2319 character (len=128), intent(out) :: z_dim
2321 ! Local variables
2322 integer :: idx
2324 istatus = 1
2326 do idx=1,num_entries
2327 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2328 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2329 if (is_z_dim_name(idx)) then
2330 z_dim = source_z_dim_name(idx)
2331 istatus = 0
2332 exit
2333 end if
2334 end if
2335 end do
2337 end subroutine get_z_dim_name
2340 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2341 ! Name: get_field_scale_factor
2342 !
2343 ! Purpose:
2344 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2345 subroutine get_field_scale_factor(fieldnm, ilevel, scale_factor, istatus)
2347 implicit none
2349 ! Arguments
2350 integer, intent(in) :: ilevel
2351 integer, intent(out) :: istatus
2352 real, intent(out) :: scale_factor
2353 character (len=128), intent(in) :: fieldnm
2355 ! Local variables
2356 integer :: idx
2358 istatus = 1
2360 do idx=1,num_entries
2361 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2362 (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) .and. &
2363 (ilevel == source_priority(idx))) then
2365 if (is_scale_factor(idx)) then
2366 scale_factor = source_scale_factor(idx)
2367 istatus = 0
2368 end if
2370 end if
2371 end do
2373 end subroutine get_field_scale_factor
2376 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2377 ! Name: get_output_stagger
2378 !
2379 ! Pupose:
2380 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2381 subroutine get_output_stagger(fieldnm, istagger, istatus)
2383 use gridinfo_module
2385 implicit none
2387 ! Arguments
2388 integer, intent(out) :: istatus, istagger
2389 character (len=128), intent(in) :: fieldnm
2391 ! Local variables
2392 integer :: idx
2394 istatus = 1
2395 do idx=1,num_entries
2396 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2397 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2399 if (is_output_stagger(idx)) then
2400 istatus = 0
2401 istagger = source_output_stagger(idx)
2402 exit
2403 else
2404 if (gridtype == 'C') then
2405 istatus = 0
2406 istagger = M
2407 exit
2408 else if (gridtype == 'E') then
2409 istatus = 0
2410 istagger = HH
2411 exit
2412 end if
2413 end if
2415 end if
2416 end do
2418 end subroutine get_output_stagger
2421 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2422 ! Name: get_subgrid_dim_name
2423 !
2424 ! Pupose:
2425 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2426 subroutine get_subgrid_dim_name(nest_num, field_name, dimnames, &
2427 sub_x, sub_y, istatus)
2429 use gridinfo_module
2431 implicit none
2432 integer, intent(in) :: nest_num
2433 integer, intent(out) :: sub_x, sub_y, istatus
2434 character(len=128), intent(in) :: field_name
2435 character(len=128), dimension(2), intent(inout) :: dimnames
2436 integer :: idx, nlen
2438 sub_x = 1
2439 sub_y = 1
2441 istatus = 0
2442 do idx=1,num_entries
2443 if ((index(source_fieldname(idx),trim(field_name)) /= 0) .and. &
2444 (len_trim(source_fieldname(idx)) == len_trim(field_name))) then
2445 if (is_subgrid(idx)) then
2446 istatus = 0
2447 if (is_output_stagger(idx)) then
2448 call mprintf(.true.,ERROR,'Cannot use subgrids on variables with staggered grids')
2449 end if
2450 dimnames(1) = trim(dimnames(1))//"_subgrid"
2451 dimnames(2) = trim(dimnames(2))//"_subgrid"
2452 sub_x = subgrid_ratio_x(nest_num)
2453 sub_y = subgrid_ratio_y(nest_num)
2454 end if
2455 end if
2456 end do
2458 end subroutine get_subgrid_dim_name
2461 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2462 ! Name: get_output_flag
2463 !
2464 ! Purpose:
2465 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2466 subroutine get_output_flag(fieldnm, output_flag, istatus)
2468 implicit none
2470 ! Arguments
2471 integer, intent(out) :: istatus
2472 character (len=*), intent(in) :: fieldnm
2473 character (len=128), intent(out) :: output_flag
2475 ! Local variables
2476 integer :: idx
2478 istatus = 1
2480 do idx=1,num_entries
2481 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2482 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2484 if (is_output_flag(idx)) then
2485 output_flag = source_output_flag(idx)
2486 istatus = 0
2487 exit
2488 end if
2490 end if
2491 end do
2493 end subroutine get_output_flag
2496 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2497 ! Name: get_interp_option
2498 !
2499 ! Pupose:
2500 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2501 subroutine get_interp_option(fieldnm, ilevel, interp_opt, istatus)
2503 implicit none
2505 ! Arguments
2506 integer, intent(in) :: ilevel
2507 integer, intent(out) :: istatus
2508 character (len=128), intent(in) :: fieldnm
2509 character (len=128), intent(out) :: interp_opt
2511 ! Local variables
2512 integer :: idx
2514 istatus = 1
2515 do idx=1,num_entries
2516 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2517 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2518 if (ilevel == source_priority(idx)) then
2520 interp_opt = source_interp_string(idx)
2521 istatus = 0
2522 exit
2524 end if
2525 end if
2526 end do
2528 end subroutine get_interp_option
2531 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2532 ! Name: get_gcel_threshold
2533 !
2534 ! Pupose:
2535 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2536 subroutine get_gcell_threshold(interp_opt, threshold, istatus)
2538 implicit none
2540 ! Arguments
2541 integer, intent(out) :: istatus
2542 real, intent(out) :: threshold
2543 character (len=128), intent(in) :: interp_opt
2545 ! Local variables
2546 integer :: i, p1, p2
2548 istatus = 1
2549 threshold = 1.0
2551 i = index(interp_opt,'average_gcell')
2552 if (i /= 0) then
2553 ! Move the "average_gcell" option to the beginning
2554 ! if (i /= 1) then
2555 ! p1 =
2556 ! end if
2558 ! Check for a threshold
2559 p1 = index(interp_opt(i:128),'(')
2560 p2 = index(interp_opt(i:128),')')
2561 if (p1 /= 0 .and. p2 /= 0) then
2562 read(interp_opt(p1+1:p2-1),*,err=1000) threshold
2563 else
2564 call mprintf(.true., WARN, 'Problem with specified threshold '// &
2565 'for average_gcell interp option. Setting threshold to 0.0.')
2566 threshold = 0.0
2567 end if
2568 end if
2569 istatus = 0
2571 return
2573 1000 call mprintf(.true., ERROR, 'Threshold option to average_gcell interpolator '// &
2574 'must be a real number, enclosed in parentheses immediately '// &
2575 'after keyword "average_gcell"')
2577 end subroutine get_gcell_threshold
2580 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2581 ! Name: get_smooth_option
2582 !
2583 ! Pupose:
2584 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2585 subroutine get_smooth_option(fieldnm, smooth_opt, smooth_passes, istatus)
2587 implicit none
2589 ! Arguments
2590 integer, intent(out) :: istatus, smooth_opt, smooth_passes
2591 character (len=128), intent(in) :: fieldnm
2593 ! Local variables
2594 integer :: idx
2596 istatus = 1
2598 do idx=1,num_entries
2599 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2600 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2602 if (is_smooth_option(idx)) then
2603 istatus = 0
2604 smooth_opt = source_smooth_option(idx)
2606 if (is_smooth_passes(idx)) then
2607 smooth_passes = source_smooth_passes(idx)
2608 else
2609 smooth_passes = 1
2610 end if
2612 exit
2613 end if
2615 end if
2616 end do
2618 end subroutine get_smooth_option
2621 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2622 ! Name: iget_fieldtype
2623 !
2624 ! Purpose:
2625 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2626 function iget_fieldtype(fieldnm, istatus)
2628 implicit none
2630 ! Arguments
2631 integer, intent(out) :: istatus
2632 character (len=128), intent(in) :: fieldnm
2634 ! Local variables
2635 integer :: idx
2637 ! Return value
2638 integer :: iget_fieldtype
2640 istatus = 1
2642 do idx=1,num_entries
2643 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2644 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2646 if (is_dest_fieldtype(idx)) then
2647 iget_fieldtype = source_dest_fieldtype(idx)
2648 istatus = 0
2649 exit
2650 end if
2652 end if
2653 end do
2655 end function iget_fieldtype
2658 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2659 ! Name: iget_source_fieldtype
2660 !
2661 ! Purpose: Given a resolution, in degrees, and the name of a field, this
2662 ! function returns the type (categorical, continuous, etc.) of the source
2663 ! data that will be used. This may, in general, depend on the field name
2664 ! and the resolution; for example, near 30 second resolution, land use data
2665 ! may come from a categorical field, whereas for lower resolutions, it may
2666 ! come from arrays of land use fractions for each category.
2667 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2668 function iget_source_fieldtype(fieldnm, ilevel, istatus)
2670 implicit none
2672 ! Arguments
2673 integer, intent(in) :: ilevel
2674 integer, intent(out) :: istatus
2675 character (len=128), intent(in) :: fieldnm
2677 ! Return value
2678 integer :: iget_source_fieldtype
2680 ! Local variables
2681 integer :: idx
2683 ! Find information about the source tiles for the specified fieldname
2684 istatus = 1
2685 do idx=1,num_entries
2686 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2687 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2688 if (ilevel == source_priority(idx)) then
2689 istatus = 0
2690 iget_source_fieldtype = source_fieldtype(idx)
2691 exit
2692 end if
2693 end if
2694 end do
2696 end function iget_source_fieldtype
2699 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2700 ! Name: get_data_tile
2701 !
2702 ! Purpose:
2703 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2704 subroutine get_data_tile(xlat, xlon, ilevel, field_name, &
2705 file_name, array, start_x_dim, end_x_dim, start_y_dim, &
2706 end_y_dim, start_z_dim, end_z_dim, npts_bdr, &
2707 istatus)
2709 implicit none
2711 ! Arguments
2712 integer, intent(in) :: ilevel
2713 integer, intent(out) :: istatus
2714 integer, intent(out) :: start_x_dim, end_x_dim, &
2715 start_y_dim, end_y_dim, &
2716 start_z_dim, end_z_dim, &
2717 npts_bdr
2718 real, intent(in) :: xlat, xlon ! Location that tile should contain
2719 real, pointer, dimension(:,:,:) :: array ! The array to be allocated by this routine
2720 character (len=128), intent(in) :: field_name
2721 character (len=256), intent(out) :: file_name
2723 ! Local variables
2724 integer :: j, k
2725 integer :: local_wordsize, local_endian, sign_convention, irow_order, strlen
2726 integer :: xdim,ydim,zdim
2727 real :: scalefac
2728 real, allocatable, dimension(:) :: temprow
2730 call get_tile_fname(file_name, xlat, xlon, ilevel, field_name, istatus)
2732 if (index(file_name, 'OUTSIDE') /= 0) then
2733 istatus = 1
2734 return
2735 else if (hash_search(bad_files, file_name)) then
2736 istatus = 1
2737 return
2738 end if
2740 call get_tile_dimensions(xlat, xlon, start_x_dim, end_x_dim, start_y_dim, end_y_dim, &
2741 start_z_dim, end_z_dim, npts_bdr, local_wordsize, local_endian, &
2742 sign_convention, ilevel, field_name, istatus)
2744 xdim = (end_x_dim-start_x_dim+1)
2745 ydim = (end_y_dim-start_y_dim+1)
2746 zdim = (end_z_dim-start_z_dim+1)
2748 if (associated(array)) deallocate(array)
2749 allocate(array(xdim,ydim,zdim))
2751 call get_row_order(field_name, ilevel, irow_order, istatus)
2752 if (istatus /= 0) irow_order = BOTTOM_TOP
2754 call s_len(file_name,strlen)
2756 scalefac = 1.0
2758 call read_geogrid(file_name, strlen, array, xdim, ydim, zdim, &
2759 sign_convention, local_endian, scalefac, local_wordsize, istatus)
2761 if (irow_order == TOP_BOTTOM) then
2762 allocate(temprow(xdim))
2763 do k=1,zdim
2764 do j=1,ydim
2765 if (ydim-j+1 <= j) exit
2766 temprow(1:xdim) = array(1:xdim,j,k)
2767 array(1:xdim,j,k) = array(1:xdim,ydim-j+1,k)
2768 array(1:xdim,ydim-j+1,k) = temprow(1:xdim)
2769 end do
2770 end do
2771 deallocate(temprow)
2772 end if
2774 if (istatus /= 0) then
2775 start_x_dim = INVALID
2776 start_y_dim = INVALID
2777 end_x_dim = INVALID
2778 end_y_dim = INVALID
2780 call hash_insert(bad_files, file_name)
2781 end if
2783 end subroutine get_data_tile
2786 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2787 ! Name: get_row_order
2788 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2789 subroutine get_row_order(fieldnm, ilevel, irow_order, istatus)
2791 implicit none
2793 ! Arguments
2794 integer, intent(in) :: ilevel
2795 character (len=128), intent(in) :: fieldnm
2796 integer, intent(out) :: irow_order, istatus
2798 ! Local variables
2799 integer :: idx
2801 istatus = 1
2802 do idx=1,num_entries
2803 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2804 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2805 if (ilevel == source_priority(idx)) then
2806 if (is_row_order(idx)) then
2807 irow_order = source_row_order(idx)
2808 istatus = 0
2809 exit
2810 end if
2811 end if
2812 end if
2813 end do
2815 end subroutine get_row_order
2818 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2819 ! Name: get_tile_dimensions
2820 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2821 subroutine get_tile_dimensions(xlat, xlon, start_x_dim, end_x_dim, start_y_dim, end_y_dim, &
2822 start_z_dim, end_z_dim, npts_bdr, bytes_per_datum, endianness, &
2823 sign_convention, ilevel, fieldnm, istatus)
2825 use llxy_module
2827 implicit none
2829 ! Arguments
2830 integer, intent(in) :: ilevel
2831 integer, intent(out) :: start_x_dim, end_x_dim, &
2832 start_y_dim, end_y_dim, &
2833 start_z_dim, end_z_dim, &
2834 npts_bdr, &
2835 bytes_per_datum, endianness, &
2836 sign_convention, istatus
2837 real, intent(in) :: xlat, xlon
2838 character (len=128), intent(in) :: fieldnm
2840 ! Local variables
2841 integer :: idx, current_domain
2842 real :: rx, ry
2844 istatus = 1
2845 do idx=1,num_entries
2846 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2847 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2848 if (ilevel == source_priority(idx)) then
2849 istatus = 0
2850 exit
2851 end if
2852 end if
2853 end do
2855 if (istatus /= 0) then
2856 start_x_dim = 1
2857 start_y_dim = 1
2858 start_z_dim = 1
2859 end_x_dim = 1
2860 end_y_dim = 1
2861 end_z_dim = 1
2862 bytes_per_datum = 0
2863 return
2864 end if
2866 current_domain = iget_selected_domain()
2867 call select_domain(SOURCE_PROJ)
2868 call lltoxy(xlat, xlon, rx, ry, M)
2869 call select_domain(current_domain)
2871 start_x_dim = source_tile_x(idx) * nint(real(floor((rx-0.5) / real(source_tile_x(idx))))) + 1
2872 end_x_dim = start_x_dim + source_tile_x(idx) - 1
2874 start_y_dim = source_tile_y(idx) * nint(real(floor((ry-0.5) / real(source_tile_y(idx))))) + 1
2875 end_y_dim = start_y_dim + source_tile_y(idx) - 1
2877 if (is_tile_z_start(idx) .and. is_tile_z_end(idx)) then
2878 start_z_dim = source_tile_z_start(idx)
2879 end_z_dim = source_tile_z_end(idx)
2880 else if (is_tile_z(idx)) then
2881 start_z_dim = 1
2882 end_z_dim = source_tile_z(idx)
2883 end if
2885 if (.not. (is_tile_z_start(idx) .and. is_tile_z_end(idx))) then
2886 if (is_tile_z_start(idx) .or. is_tile_z_end(idx)) then
2887 call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of tile_z_start and '// &
2888 'tile_z_end specified for entry %i.',i1=idx)
2889 end if
2890 end if
2892 if (is_tile_bdr(idx)) then
2893 npts_bdr = source_tile_bdr(idx)
2894 else
2895 npts_bdr = 0
2896 end if
2898 start_x_dim = start_x_dim - npts_bdr
2899 end_x_dim = end_x_dim + npts_bdr
2900 start_y_dim = start_y_dim - npts_bdr
2901 end_y_dim = end_y_dim + npts_bdr
2903 if (is_wordsize(idx)) then
2904 bytes_per_datum = source_wordsize(idx)
2905 else
2906 bytes_per_datum = 1
2907 call mprintf(.true.,ERROR,'In GEOGRID.TBL, no wordsize specified for data in entry %i.',i1=idx)
2908 end if
2910 if (is_endian(idx)) then
2911 endianness = source_endian(idx)
2912 else
2913 endianness = BIG_ENDIAN
2914 end if
2916 if (is_signed(idx)) then
2917 sign_convention = 1
2918 else
2919 sign_convention = 0
2920 end if
2922 end subroutine get_tile_dimensions
2925 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2926 ! Name: get_tile_fname
2927 !
2928 ! Purpose:
2929 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2930 subroutine get_tile_fname(test_fname, xlat, xlon, ilevel, fieldname, istatus)
2932 use llxy_module
2933 use gridinfo_module
2935 implicit none
2937 ! Arguments
2938 integer, intent(in) :: ilevel
2939 integer, intent(out) :: istatus
2940 real, intent(in) :: xlat, xlon
2941 character (len=*), intent(in) :: fieldname
2942 character (len=256), intent(out) :: test_fname
2944 ! Local variables
2945 integer :: current_domain, idx
2946 real :: rx, ry
2948 istatus = 1
2949 write(test_fname, '(a)') 'TILE.OUTSIDE.DOMAIN'
2951 do idx=1,num_entries
2952 if ((index(source_fieldname(idx),trim(fieldname)) /= 0) .and. &
2953 (len_trim(source_fieldname(idx)) == len_trim(fieldname))) then
2954 if (ilevel == source_priority(idx)) then
2955 istatus = 0
2956 exit
2957 end if
2958 end if
2959 end do
2961 if (istatus /= 0) return
2963 current_domain = iget_selected_domain()
2964 call select_domain(SOURCE_PROJ)
2965 call lltoxy(xlat, xlon, rx, ry, M)
2966 call select_domain(current_domain)
2968 ! rx = real(source_tile_x(idx)) * real(floor((rx-0.5*source_dx(idx))/ real(source_tile_x(idx)))) + 1.0
2969 ! ry = real(source_tile_y(idx)) * real(floor((ry-0.5*source_dy(idx))/ real(source_tile_y(idx)))) + 1.0
2970 rx = real(source_tile_x(idx)) * real(floor((rx-0.5) / real(source_tile_x(idx)))) + 1.0
2971 ry = real(source_tile_y(idx)) * real(floor((ry-0.5) / real(source_tile_y(idx)))) + 1.0
2973 if (rx > 0. .and. ry > 0.) then
2974 write(test_fname, '(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(source_path(idx)), &
2975 nint(rx),'-',nint(rx)+source_tile_x(idx)-1,'.',nint(ry),'-',nint(ry)+source_tile_y(idx)-1
2976 end if
2978 end subroutine get_tile_fname
2981 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2982 ! Name: get_source_resolution
2983 !
2984 ! Purpose:
2985 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2986 subroutine get_source_resolution(fieldnm, ilevel, src_dx, src_dy, istatus)
2988 implicit none
2990 ! Arguments
2991 integer, intent(in) :: ilevel
2992 integer, intent(out) :: istatus
2993 real, intent(out) :: src_dx, src_dy
2994 character (len=*), intent(in) :: fieldnm
2996 ! Local variables
2997 integer :: idx
2999 istatus = 1
3000 do idx=1,num_entries
3001 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
3002 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
3003 if (ilevel == source_priority(idx)) then
3004 if (is_dx(idx) .and. is_dy(idx)) then
3005 src_dx = source_dx(idx)
3006 src_dy = source_dy(idx)
3007 if (source_proj(idx) /= PROJ_LATLON) then
3008 src_dx = src_dx / 111000.
3009 src_dy = src_dy / 111000.
3010 end if
3011 istatus = 0
3012 exit
3013 end if
3014 end if
3015 end if
3016 end do
3018 end subroutine get_source_resolution
3021 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3022 ! Name: get_data_projection
3023 !
3024 ! Purpose: To acquire the parameters necessary in defining the grid on which
3025 ! the user-specified data for field 'fieldnm' are given.
3026 !
3027 ! NOTES: If the routine successfully acquires values for all necessary
3028 ! parameters, istatus is set to 0. In case of an error,
3029 ! OR IF THE USER HAS NOT SPECIFIED A TILE OF DATA FOR FIELDNM,
3030 ! istatus is set to 1.
3031 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3032 subroutine get_data_projection(fieldnm, iproj, stand_lon, truelat1, truelat2, &
3033 dxkm, dykm, known_x, known_y, known_lat, known_lon, ilevel, istatus)
3035 implicit none
3037 ! Arguments
3038 integer, intent(in) :: ilevel
3039 integer, intent(out) :: iproj, istatus
3040 real, intent(out) :: stand_lon, truelat1, truelat2, dxkm, dykm, &
3041 known_x, known_y, known_lat, known_lon
3042 character (len=*), intent(in) :: fieldnm
3044 ! Local variables
3045 integer :: idx
3047 istatus = 1
3048 do idx=1,num_entries
3049 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
3050 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
3051 if (ilevel == source_priority(idx)) then
3052 istatus = 0
3053 if (is_proj(idx)) then
3054 iproj = source_proj(idx)
3055 else
3056 iproj = 1
3057 call mprintf(.true., ERROR, &
3058 'In GEOGRID.TBL, no specification for projection in entry %i.',i1=idx)
3059 end if
3060 if (is_known_x(idx)) then
3061 known_x = source_known_x(idx)
3062 else
3063 known_x = 1.
3064 call mprintf(.true., ERROR, &
3065 'In GEOGRID.TBL, no specification for known_x in entry %i.',i1=idx)
3066 end if
3067 if (is_known_y(idx)) then
3068 known_y = source_known_y(idx)
3069 else
3070 known_y = 1.
3071 call mprintf(.true., ERROR, &
3072 'In GEOGRID.TBL, no specification for known_y in entry %i.',i1=idx)
3073 end if
3074 if (is_known_lat(idx)) then
3075 known_lat = source_known_lat(idx)
3076 else
3077 known_lat = 1.
3078 call mprintf(.true., ERROR, &
3079 'In GEOGRID.TBL, no specification for known_lat in entry %i.',i1=idx)
3080 end if
3081 if (is_known_lon(idx)) then
3082 known_lon = source_known_lon(idx)
3083 else
3084 known_lon = 1.
3085 call mprintf(.true., ERROR, &
3086 'In GEOGRID.TBL, no specification for known_lon in entry %i.',i1=idx)
3087 end if
3088 if (is_truelat1(idx)) then
3089 truelat1 = source_truelat1(idx)
3090 else if (is_proj(idx) .and. source_proj(idx) /= PROJ_LATLON) then
3091 truelat1 = 1.
3092 call mprintf(.true., WARN, &
3093 'In GEOGRID.TBL, no specification for truelat1 in entry %i.',i1=idx)
3094 end if
3095 if (is_truelat2(idx)) then
3096 truelat2 = source_truelat2(idx)
3097 else if (is_proj(idx) .and. source_proj(idx) /= PROJ_LATLON) then
3098 truelat2 = 1.
3099 call mprintf(.true., WARN, &
3100 'In GEOGRID.TBL, no specification for truelat2 in entry %i.',i1=idx)
3101 end if
3102 if (is_stdlon(idx)) then
3103 stand_lon = source_stdlon(idx)
3104 else if (is_proj(idx) .and. source_proj(idx) /= PROJ_LATLON) then
3105 stand_lon = 1.
3106 call mprintf(.true., WARN, &
3107 'In GEOGRID.TBL, no specification for stdlon in entry %i.',i1=idx)
3108 end if
3109 if (is_dx(idx)) then
3110 dxkm = source_dx(idx)
3111 else
3112 dxkm = 1.
3113 call mprintf(.true., ERROR, &
3114 'In GEOGRID.TBL, no specification for dx in entry %i.',i1=idx)
3115 end if
3116 if (is_dy(idx)) then
3117 dykm = source_dy(idx)
3118 else
3119 dykm = 1.
3120 call mprintf(.true., ERROR, &
3121 'In GEOGRID.TBL, no specification for dy in entry %i.',i1=idx)
3122 end if
3123 exit
3124 end if
3125 end if
3126 end do
3128 end subroutine get_data_projection
3131 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3132 ! Name: check_data_specification
3133 !
3134 ! Purpose: To check for obvious errors in the user source data specifications.
3135 ! Returns .true. if specification passes all checks, and .false. otherwise.
3136 ! For failing checks, diagnostic messages are printed.
3137 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3138 function check_data_specification( )
3140 implicit none
3142 ! Return value
3143 logical :: check_data_specification
3145 ! Local variables
3146 integer :: i, j, istatus
3147 integer, pointer, dimension(:) :: priorities
3148 real :: rmissing
3149 logical :: begin_priority, halt
3150 character (len=128) :: cur_name
3152 check_data_specification = .false.
3154 ! Check that each specification has a name, priority level, and path
3155 do i=1,num_entries
3156 if (.not. is_fieldname(i)) then
3157 call mprintf(.true., ERROR, &
3158 'In GEOGRID.TBL, specification %i does not have a name.',i1=i)
3159 end if
3160 if (.not. is_priority(i)) then
3161 call mprintf(.true., ERROR, &
3162 'In GEOGRID.TBL, specification %i does not have a priority.',i1=i)
3163 end if
3164 if (list_length(source_res_path(i)) == 0) then
3165 call mprintf(.true., ERROR, &
3166 'In GEOGRID.TBL, no path (relative or absolute) is specified '// &
3167 'for entry %i.',i1=i)
3168 end if
3169 end do
3171 ! The fill_missing and halt_on_missing options are mutually exclusive
3172 do i=1,num_entries
3173 call get_halt_on_missing(source_fieldname(i), halt, istatus)
3174 call get_missing_fill_value(source_fieldname(i), rmissing, istatus)
3175 if (halt .and. (istatus == 0)) then
3176 call mprintf(.true., ERROR, 'In GEOGRID.TBL, the halt_on_missing and fill_missing '// &
3177 'options are mutually exclusive, but both are given for field %s', &
3178 s1=trim(source_fieldname(i)))
3179 end if
3180 end do
3182 ! Check that the field from which landmask is calculated is not output on a staggering
3183 do i=1,num_entries
3184 if (list_length(source_landmask_land(i)) > 0 .or. list_length(source_landmask_water(i)) > 0) then
3185 if (is_output_stagger(i)) then
3186 if (source_output_stagger(i) /= M) then
3187 call mprintf(.true., ERROR, 'In GEOGRID.TBL, landmask cannot be derived from '// &
3188 'a field that is computed on a staggered grid at entry %i.',i1=i)
3189 end if
3190 end if
3191 end if
3192 end do
3194 ! Also check that any field that is to be masked by the landmask is not output on a staggering
3195 do i=1,num_entries
3196 if (is_masked(i) .and. is_output_stagger(i)) then
3197 if (source_output_stagger(i) /= M) then
3198 call mprintf(.true., ERROR, 'In GEOGRID.TBL, landmask cannot be used with '// &
3199 'a field that is computed on a staggered grid at entry %i.',i1=i)
3200 end if
3201 end if
3202 end do
3204 allocate(priorities(num_entries))
3206 ! Now check that priorities for each source are unique and in the interval [1,n], n <= num_entries
3207 do i=1,num_entries
3208 priorities = 0
3209 cur_name = source_fieldname(i)
3210 do j=1,num_entries
3211 if (source_fieldname(j) == cur_name) then
3213 if (source_priority(j) > num_entries .or. source_priority(j) < 1) then
3214 call mprintf(.true., ERROR, 'In GEOGRID.TBL, priorities for %s do not '// &
3215 'form a sequence 1,2,...,n.', s1=trim(cur_name))
3217 else
3218 if (priorities(source_priority(j)) == 1) then
3219 call mprintf(.true., ERROR, 'In GEOGRID.TBL, more than one entry for %s '// &
3220 'has priority %i.', s1=trim(cur_name), i1=source_priority(j))
3222 else
3223 priorities(source_priority(j)) = 1
3224 end if
3225 end if
3227 end if
3228 end do
3230 begin_priority = .false.
3231 do j=num_entries,1,-1
3232 if (.not.begin_priority .and. priorities(j) == 1) then
3233 begin_priority = .true.
3234 else if (begin_priority .and. priorities(j) == 0) then
3235 call mprintf(.true., ERROR, 'In GEOGRID.TBL, no entry for %s has '// &
3236 'priority %i, but an entry has priority %i.', &
3237 s1=trim(cur_name), i1=j, i2=j+1)
3238 end if
3239 end do
3240 end do
3242 deallocate(priorities)
3244 ! Units must match for all priority levels of a field
3245 do i=1,num_entries
3246 if (source_priority(i) == 1) then
3247 do j=1,num_entries
3248 if ((source_fieldname(i) == source_fieldname(j)) .and. &
3249 (source_units(i) /= source_units(j))) then
3250 call mprintf(.true., ERROR, 'In GEOGRID.TBL, units for %s at entry %i '// &
3251 'do not match units at entry %i (%s)', &
3252 s1=trim(source_fieldname(i)), i1=j, i2=i, s2=trim(source_units(i)))
3253 end if
3254 end do
3255 end if
3256 end do
3258 ! Make sure that user has not asked to calculate landmask from a continuous field
3259 do i=1,num_entries
3260 if (is_dest_fieldtype(i)) then
3261 if (source_dest_fieldtype(i) == CONTINUOUS) then
3262 if (list_length(source_landmask_water(i)) > 0 .or. list_length(source_landmask_land(i)) > 0) then
3263 call mprintf(.true., ERROR, 'In GEOGRID.TBL, landmask cannot be '// &
3264 'calculated from a continuous destination field at entry %i.',i1=i)
3265 end if
3266 end if
3267 end if
3268 end do
3270 ! If either min_category or max_category is specified, then both must be specified
3271 do i=1,num_entries
3272 if (is_category_min(i) .or. is_category_max(i)) then
3273 if (.not. is_category_min(i)) then
3274 call mprintf(.true., ERROR, 'In GEOGRID.TBL, for index file of data at '// &
3275 'entry %i, category_max is specified, but category_min is '// &
3276 'not. Both must be specified.',i1=i)
3277 else if (.not. is_category_max(i)) then
3278 call mprintf(.true., ERROR, 'In GEOGRID.TBL, for index file of data at '// &
3279 'entry %i, category_min is specified, but category_max is '// &
3280 'not. Both must be specified.',i1=i)
3281 end if
3282 end if
3283 end do
3285 ! For continuous data, (category_max - category_min + 1) should equal tile_z
3286 do i=1,num_entries
3287 if (is_fieldtype(i)) then
3288 if (source_fieldtype(i) == CONTINUOUS) then
3289 if (is_category_max(i) .and. is_category_min(i) .and. is_tile_z(i)) then
3290 if (source_tile_z(i) /= (source_category_max(i) - source_category_min(i) + 1)) then
3291 call mprintf(.true., ERROR, 'In GEOGRID.TBL, tile_z must equal '// &
3292 '(category_max - category_min + 1) at entry %i.',i1=i)
3293 end if
3294 else if (is_category_max(i) .and. is_category_min(i) .and. &
3295 is_tile_z_start(i) .and. is_tile_z_end(i)) then
3296 if (source_tile_z_end(i) /= source_category_max(i) .or. &
3297 source_tile_z_start(i) /= source_category_min(i)) then
3298 call mprintf(.true., ERROR, 'In GEOGRID.TBL, tile_z_end must equal '// &
3299 'category_max, and tile_z_start must equal category_min '// &
3300 'at entry %i.',i1=i)
3301 end if
3302 end if
3303 end if
3304 end if
3305 end do
3307 ! Make sure that user has not named a dominant category or computed slope field
3308 ! the same as a fractional field
3309 do i=1,num_entries
3310 if (source_dominant_category(i) == source_fieldname(i)) then
3311 call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant category cannot have '// &
3312 'the same name as the field at entry %i.',i1=i)
3313 end if
3315 do j=1,num_entries
3316 if (.not. is_dominant_only(i)) then
3317 if (is_dfdx(j)) then
3318 if (source_dfdx(j) == source_fieldname(i)) then
3319 call mprintf(.true., ERROR, 'In GEOGRID.TBL, field name at entry %i '// &
3320 'cannot have the same name as the slope field df_dx at entry %i.', &
3321 i1=i, i2=j)
3322 end if
3323 end if
3324 if (is_dfdy(j)) then
3325 if (source_dfdy(j) == source_fieldname(i)) then
3326 call mprintf(.true., ERROR, 'In GEOGRID.TBL, field name at entry %i '// &
3327 'cannot have the same name as the slope field df_dy at entry %i.', &
3328 i1=i, i2=j)
3329 end if
3330 end if
3331 if (is_dfdx(j) .and. is_dominant_category(i)) then
3332 if (source_dfdx(j) == source_dominant_category(i)) then
3333 call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant field name at '// &
3334 'entry %i cannot have the same name as the slope field df_dx '// &
3335 'at entry %i.',i1=i, i2=j)
3336 end if
3337 end if
3338 if (is_dfdy(j) .and. is_dominant_category(i)) then
3339 if (source_dfdy(j) == source_dominant_category(i)) then
3340 call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant field name at '// &
3341 'entry %i cannot have the same name as the slope field '// &
3342 'df_dy at entry %i.',i1=i, i2=j)
3343 end if
3344 end if
3345 else
3346 if (is_dfdx(j)) then
3347 if (source_dfdx(j) == source_dominant_only(i)) then
3348 call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant field name at '// &
3349 'entry %i cannot have the same name as the slope field '// &
3350 'df_dx at entry %i.',i1=i, i2=j)
3351 end if
3352 end if
3353 if (is_dfdy(j)) then
3354 if (source_dfdy(j) == source_dominant_only(i)) then
3355 call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant field name at '// &
3356 'entry %i cannot have the same name as the slope field '// &
3357 'df_dy at entry %i.',i1=i, i2=j)
3358 end if
3359 end if
3360 end if
3361 if (i /= j) then
3362 if (is_dfdx(i)) then
3363 if (is_dfdx(j)) then
3364 if (source_dfdx(j) == source_dfdx(i)) then
3365 call mprintf(.true., ERROR, 'In GEOGRID.TBL, slope field df_dx at '// &
3366 'entry %i cannot have the same name as the slope '// &
3367 'field df_dx at entry %i.',i1=i, i2=j)
3368 end if
3369 end if
3370 if (is_dfdy(j)) then
3371 if (source_dfdy(j) == source_dfdx(i)) then
3372 call mprintf(.true., ERROR, 'In GEOGRID.TBL, slope field df_dx at '// &
3373 'entry %i cannot have the same name as the slope field '// &
3374 'df_dy at entry %i.',i1=i, i2=j)
3375 end if
3376 end if
3377 end if
3378 if (is_dfdy(i)) then
3379 if (is_dfdx(j)) then
3380 if (source_dfdx(j) == source_dfdy(i)) then
3381 call mprintf(.true., ERROR, 'In GEOGRID.TBL, slope field df_dy at '// &
3382 'entry %i cannot have the same name as the slope field '// &
3383 'df_dx at entry %i.',i1=i, i2=j)
3384 end if
3385 end if
3386 if (is_dfdy(j)) then
3387 if (source_dfdy(j) == source_dfdy(i)) then
3388 call mprintf(.true., ERROR, 'In GEOGRID.TBL, slope field df_dy at '// &
3389 'entry %i cannot have the same name as the slope field '// &
3390 'df_dy at entry %i.',i1=i, i2=j)
3391 end if
3392 end if
3393 end if
3394 if (is_dominant_category(i)) then
3395 if (source_dominant_category(i) == source_fieldname(j)) then ! Possible exception
3396 if (.not. (is_dominant_only(j) .and. (source_dominant_category(i) /= source_dominant_only(j)))) then
3397 call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant category at '// &
3398 'entry %i cannot have the same name as the field at '// &
3399 'entry %i.',i1=i, i2=j)
3400 end if
3401 else if (is_dominant_category(j) .and. &
3402 (source_dominant_category(i) == source_dominant_category(j))) then
3403 call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant category at entry '// &
3404 '%i cannot have the same name as dominant category at '// &
3405 'entry %i.',i1=i, i2=j)
3406 else if (is_dominant_only(j) .and. &
3407 (source_dominant_category(i) == source_dominant_only(j))) then
3408 call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant category at '// &
3409 'entry %i cannot have the same name as dominant_only '// &
3410 'category at entry %i.',i1=i, i2=j)
3411 end if
3412 else if (is_dominant_only(i)) then
3413 if (source_dominant_only(i) == source_fieldname(j)) then ! Possible exception
3414 if (.not. (is_dominant_only(j) .and. (source_dominant_only(i) /= source_dominant_only(j)))) then
3415 call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant_only category '// &
3416 'at entry %i cannot have the same name as the field at '// &
3417 'entry %i.',i1=i, i2=j)
3418 end if
3419 else if (is_dominant_category(j) .and. &
3420 (source_dominant_only(i) == source_dominant_category(j))) then
3421 call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant_only category '// &
3422 'at entry %i cannot have the same name as dominant '// &
3423 'category at entry %i.',i1=i, i2=j)
3424 else if (is_dominant_only(j) .and. &
3425 (source_dominant_only(i) == source_dominant_only(j))) then
3426 call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant_only category '// &
3427 'at entry %i cannot have the same name as dominant_only '// &
3428 'category at entry %i.',i1=i, i2=j)
3429 end if
3430 end if
3431 end if
3432 end do
3433 end do
3435 check_data_specification = .true.
3436 end function check_data_specification
3439 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3440 ! Name: s_len
3441 !
3442 ! Purpose: This routine receives a fortran string, and returns the number of
3443 ! characters in the string before the first "space" is encountered. It
3444 ! considers ascii characters 33 to 126 to be valid characters, and ascii
3445 ! 0 to 32, and 127 to be "space" characters.
3446 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3447 subroutine s_len(string, s_length)
3449 implicit none
3451 ! Arguments
3452 character (len=*), intent(in) :: string
3453 integer, intent(out) :: s_length
3455 ! Local variables
3456 integer :: i, len_str, aval
3457 logical :: space
3459 space = .false.
3460 i = 1
3461 len_str = len(string)
3462 s_length = len_str
3463 do while ((i .le. len_str) .and. (.not. space))
3464 aval = ichar(string(i:i))
3465 if ((aval .lt. 33) .or. (aval .gt. 126)) then
3466 s_length = i - 1
3467 space = .true.
3468 endif
3469 i = i + 1
3470 enddo
3472 end subroutine s_len
3474 end module source_data_module