| blob | 74de96069c9f2715dd0af37dd20619090d3169e9 |
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 character (len=128) :: last_output_fieldname = ''
29 integer, pointer, dimension(:) :: source_proj, source_wordsize, source_endian, source_fieldtype, &
30 source_dest_fieldtype, source_priority, source_tile_x, source_tile_y, &
31 source_tile_z, source_tile_z_start, source_tile_z_end, source_tile_bdr, &
32 source_category_min, source_category_max, source_smooth_option, &
33 source_smooth_passes, source_output_stagger, source_row_order, &
34 source_filename_digits
35 integer :: source_iswater, source_islake, source_isice, source_isurban, source_isoilwater
36 real, pointer, dimension(:) :: source_dx, source_dy, source_known_x, source_known_y, &
37 source_known_lat, source_known_lon, source_masked, source_truelat1, source_truelat2, &
38 source_stdlon, source_scale_factor, source_missing_value, source_fill_missing
39 character (len=128), pointer, dimension(:) :: source_fieldname, source_path, source_interp_string, &
40 source_dominant_category, source_dominant_only, source_dfdx, source_dfdy, &
41 source_z_dim_name, source_units, source_descr, source_output_flag, source_res
42 character (len=128) :: source_mminlu
43 logical, pointer, dimension(:) :: is_proj, is_wordsize, is_endian, is_fieldtype, &
44 is_dest_fieldtype, is_priority, is_tile_x, is_tile_y, is_tile_z, &
45 is_tile_z_start, is_tile_z_end, is_tile_bdr, is_category_min, &
46 is_category_max, is_masked, &
47 is_dx, is_dy, is_known_x, is_known_y, &
48 is_known_lat, is_known_lon, is_truelat1, is_truelat2, is_stdlon, &
49 is_scale_factor, is_fieldname, is_path, is_dominant_category, &
50 is_dominant_only, is_dfdx, is_dfdy, is_z_dim_name, &
51 is_smooth_option, is_smooth_passes, is_signed, is_missing_value, &
52 is_fill_missing, is_halt_missing, is_output_stagger, is_row_order, &
53 is_units, is_descr, is_subgrid, is_output_flag, is_optional, is_not_found
55 type (list), pointer, dimension(:) :: source_res_path, source_interp_option, source_landmask_land, &
56 source_landmask_water
57 type (hashtable) :: bad_files ! Track which files produce errors when we try to open them
58 type (hashtable) :: duplicate_fnames ! Remember which output fields we have returned
61 contains
64 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
65 ! Name: get_datalist
66 !
67 ! Purpose:
68 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
69 subroutine get_datalist()
71 use gridinfo_module
72 use stringutil
74 implicit none
76 ! Parameters
77 integer, parameter :: BUFSIZE = 256
79 ! Local variables
80 integer :: nparams, idx, eos, ispace, comma, i, j, funit
81 logical :: have_specification, is_used
82 character (len=128) :: res_string, path_string, interp_string, landmask_string
83 character (len=BUFSIZE) :: buffer
85 nparams = 0
86 num_entries = 0
88 do funit=10,100
89 inquire(unit=funit, opened=is_used)
90 if (.not. is_used) exit
91 end do
92 open(funit,file=trim(opt_geogrid_tbl_path)//'GEOGRID.TBL',form='formatted',status='old',err=1000)
94 !
95 ! We will first go through the file to determine how many field
96 ! specifications there are
97 !
98 10 read(funit,'(a)',end=20,err=1001) buffer
99 call despace(buffer)
101 ! Is this line a comment?
102 if (buffer(1:1) == '#') then
104 ! Are we beginning a new field specification?
105 else if (index(buffer,'=====') /= 0) then
106 if (nparams > 0) num_entries = num_entries + 1
107 nparams = 0
109 else
110 eos = index(buffer,'#')
111 if (eos /= 0) buffer(eos:BUFSIZE) = ' '
113 ! Does this line contain at least one parameter specification?
114 if (index(buffer,'=') /= 0) then
115 nparams = nparams + 1
116 end if
117 end if
118 go to 10
120 20 rewind(funit)
122 ! In case the last entry ended without a ======== line
123 if (nparams > 0) num_entries = num_entries + 1
125 call mprintf(.true.,STDOUT,'Parsed %i entries in GEOGRID.TBL', i1=num_entries)
127 !
128 ! Now that we know how many fields the user has specified, allocate
129 ! the properly sized arrays
130 !
131 allocate(source_wordsize(num_entries))
132 allocate(source_endian(num_entries))
133 allocate(source_fieldtype(num_entries))
134 allocate(source_dest_fieldtype(num_entries))
135 allocate(source_proj(num_entries))
136 allocate(source_priority(num_entries))
137 allocate(source_dx(num_entries))
138 allocate(source_dy(num_entries))
139 allocate(source_known_x(num_entries))
140 allocate(source_known_y(num_entries))
141 allocate(source_known_lat(num_entries))
142 allocate(source_known_lon(num_entries))
143 allocate(source_truelat1(num_entries))
144 allocate(source_truelat2(num_entries))
145 allocate(source_stdlon(num_entries))
146 allocate(source_fieldname(num_entries))
147 allocate(source_path(num_entries))
148 allocate(source_interp_string(num_entries))
149 allocate(source_tile_x(num_entries))
150 allocate(source_tile_y(num_entries))
151 allocate(source_tile_z(num_entries))
152 allocate(source_tile_z_start(num_entries))
153 allocate(source_tile_z_end(num_entries))
154 allocate(source_filename_digits(num_entries))
155 allocate(source_category_min(num_entries))
156 allocate(source_category_max(num_entries))
157 allocate(source_tile_bdr(num_entries))
158 allocate(source_masked(num_entries))
159 allocate(source_output_stagger(num_entries))
160 allocate(source_row_order(num_entries))
161 allocate(source_dominant_category(num_entries))
162 allocate(source_dominant_only(num_entries))
163 allocate(source_dfdx(num_entries))
164 allocate(source_dfdy(num_entries))
165 allocate(source_scale_factor(num_entries))
166 allocate(source_z_dim_name(num_entries))
167 allocate(source_units(num_entries))
168 allocate(source_descr(num_entries))
169 allocate(source_res(num_entries))
170 allocate(source_smooth_option(num_entries))
171 allocate(source_smooth_passes(num_entries))
172 allocate(source_missing_value(num_entries))
173 allocate(source_fill_missing(num_entries))
174 allocate(source_res_path(num_entries))
175 allocate(source_interp_option(num_entries))
176 allocate(source_landmask_land(num_entries))
177 allocate(source_landmask_water(num_entries))
178 allocate(source_output_flag(num_entries))
179 do i=1,num_entries
180 call list_init(source_res_path(i))
181 call list_init(source_interp_option(i))
182 call list_init(source_landmask_land(i))
183 call list_init(source_landmask_water(i))
184 end do
186 allocate(is_wordsize(num_entries))
187 allocate(is_endian(num_entries))
188 allocate(is_fieldtype(num_entries))
189 allocate(is_dest_fieldtype(num_entries))
190 allocate(is_proj(num_entries))
191 allocate(is_priority(num_entries))
192 allocate(is_dx(num_entries))
193 allocate(is_dy(num_entries))
194 allocate(is_known_x(num_entries))
195 allocate(is_known_y(num_entries))
196 allocate(is_known_lat(num_entries))
197 allocate(is_known_lon(num_entries))
198 allocate(is_truelat1(num_entries))
199 allocate(is_truelat2(num_entries))
200 allocate(is_stdlon(num_entries))
201 allocate(is_fieldname(num_entries))
202 allocate(is_path(num_entries))
203 allocate(is_tile_x(num_entries))
204 allocate(is_tile_y(num_entries))
205 allocate(is_tile_z(num_entries))
206 allocate(is_tile_z_start(num_entries))
207 allocate(is_tile_z_end(num_entries))
208 allocate(is_category_min(num_entries))
209 allocate(is_category_max(num_entries))
210 allocate(is_tile_bdr(num_entries))
211 allocate(is_masked(num_entries))
212 allocate(is_halt_missing(num_entries))
213 allocate(is_output_stagger(num_entries))
214 allocate(is_row_order(num_entries))
215 allocate(is_dominant_category(num_entries))
216 allocate(is_dominant_only(num_entries))
217 allocate(is_dfdx(num_entries))
218 allocate(is_dfdy(num_entries))
219 allocate(is_scale_factor(num_entries))
220 allocate(is_z_dim_name(num_entries))
221 allocate(is_units(num_entries))
222 allocate(is_descr(num_entries))
223 allocate(is_smooth_option(num_entries))
224 allocate(is_smooth_passes(num_entries))
225 allocate(is_signed(num_entries))
226 allocate(is_missing_value(num_entries))
227 allocate(is_fill_missing(num_entries))
228 allocate(is_subgrid(num_entries))
229 allocate(is_output_flag(num_entries))
230 allocate(is_optional(num_entries))
231 allocate(is_not_found(num_entries))
233 source_wordsize=0
234 source_endian=0
235 source_fieldtype=0
236 source_dest_fieldtype=0
237 source_proj=0
238 source_priority=0
239 source_dx=0
240 source_dy=0
241 source_known_x=0
242 source_known_y=0
243 source_known_lat=0
244 source_known_lon=0
245 source_truelat1=0
246 source_truelat2=0
247 source_stdlon=0
248 source_fieldname=' '
249 source_path=' '
250 source_interp_string=' '
251 source_tile_x=0
252 source_tile_y=0
253 source_tile_z=0
254 source_tile_z_start=0
255 source_tile_z_end=0
256 source_filename_digits=5
257 source_category_min=0
258 source_category_max=0
259 source_tile_bdr=0
260 source_masked=0
261 source_output_stagger=0
262 source_row_order=0
263 source_dominant_category=' '
264 source_dominant_only=' '
265 source_dfdx=' '
266 source_dfdy=' '
267 source_scale_factor=0
268 source_z_dim_name=' '
269 source_units=' '
270 source_descr=' '
271 source_res=' '
272 source_smooth_option=0
273 source_smooth_passes=0
274 source_missing_value=0
275 source_fill_missing=0
276 source_output_flag=' '
278 is_wordsize=.false.
279 is_endian=.false.
280 is_fieldtype=.false.
281 is_dest_fieldtype=.false.
282 is_proj=.false.
283 is_priority=.false.
284 is_dx=.false.
285 is_dy=.false.
286 is_known_x=.false.
287 is_known_y=.false.
288 is_known_lat=.false.
289 is_known_lon=.false.
290 is_truelat1=.false.
291 is_truelat2=.false.
292 is_stdlon=.false.
293 is_fieldname=.false.
294 is_path=.false.
295 is_tile_x=.false.
296 is_tile_y=.false.
297 is_tile_z=.false.
298 is_tile_z_start=.false.
299 is_tile_z_end=.false.
300 is_category_min=.false.
301 is_category_max=.false.
302 is_tile_bdr=.false.
303 is_masked=.false.
304 is_halt_missing=.false.
305 is_output_stagger=.false.
306 is_row_order=.false.
307 is_dominant_category=.false.
308 is_dominant_only=.false.
309 is_dfdx=.false.
310 is_dfdy=.false.
311 is_scale_factor=.false.
312 is_z_dim_name=.false.
313 is_units=.false.
314 is_descr=.false.
315 is_smooth_option=.false.
316 is_smooth_passes=.false.
317 is_signed=.false.
318 is_missing_value=.false.
319 is_fill_missing=.false.
320 is_subgrid=.false.
321 is_output_flag=.false.
322 is_optional=.false.
323 is_not_found=.false.
325 ! This is the default value of source_mminlu
326 ! If this default is changed then you must also modify the variable
327 ! default_mminlu in get_source_params
328 write(source_mminlu,'(a4)') 'USGS'
329 source_iswater = 16
330 source_islake = -1
331 source_isice = 24
332 source_isurban = 1
333 source_isoilwater = 14
335 !
336 ! Actually read and save the specifications
337 !
338 nparams = 0
339 i = 1
340 30 buffer = ' '
341 read(funit,'(a)',end=40,err=1001) buffer
342 call despace(buffer)
344 ! Is this line a comment?
345 if (buffer(1:1) == '#') then
346 ! Do nothing.
348 ! Are we beginning a new field specification?
349 else if (index(buffer,'=====') /= 0) then !{
350 if (nparams > 0) i = i + 1
351 nparams = 0
352 if (i <= num_entries) then
353 !BUG: Are these initializations needed now that we've added initializations for
354 ! all options after their initial allocation above?
355 is_path(i) = .false.
356 is_masked(i) = .false.
357 is_halt_missing(i) = .false.
358 is_output_stagger(i) = .false.
359 is_dominant_category(i) = .false.
360 is_dominant_only(i) = .false.
361 is_dfdx(i) = .false.
362 is_dfdy(i) = .false.
363 is_dest_fieldtype(i) = .false.
364 is_priority(i) = .false.
365 is_z_dim_name(i) = .false.
366 is_smooth_option(i) = .false.
367 is_smooth_passes(i) = .false.
368 is_fill_missing(i) = .false.
369 is_subgrid(i) = .false.
370 is_output_flag(i) = .false.
371 is_optional(i) = .false.
372 end if
374 else
375 ! Check whether the current line is a comment
376 if (buffer(1:1) /= '#') then
377 have_specification = .true.
378 else
379 have_specification = .false.
380 end if
382 ! If only part of the line is a comment, just turn the comment into spaces
383 eos = index(buffer,'#')
384 if (eos /= 0) buffer(eos:BUFSIZE) = ' '
386 do while (have_specification) !{
388 ! If this line has no semicolon, it may contain a single specification,
389 ! so we set have_specification = .false. to prevent the line from being
390 ! processed again and "pretend" that the last character was a semicolon
391 eos = index(buffer,';')
392 if (eos == 0) then
393 have_specification = .false.
394 eos = BUFSIZE
395 end if
397 idx = index(buffer(1:eos-1),'=')
399 if (idx /= 0) then !{
400 nparams = nparams + 1
402 if (index('name',trim(buffer(1:idx-1))) /= 0) then
403 ispace = idx+1
404 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
405 ispace = ispace + 1
406 end do
407 is_fieldname(i) = .true.
408 source_fieldname(i) = ' '
409 source_fieldname(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
411 else if (index('priority',trim(buffer(1:idx-1))) /= 0) then
412 is_priority(i) = .true.
413 read(buffer(idx+1:eos-1),'(i10)') source_priority(i)
415 else if (index('dest_type',trim(buffer(1:idx-1))) /= 0) then
416 if (index('continuous',trim(buffer(idx+1:eos-1))) /= 0) then
417 is_dest_fieldtype(i) = .true.
418 source_dest_fieldtype(i) = CONTINUOUS
419 else if (index('categorical',trim(buffer(idx+1:eos-1))) /= 0) then
420 is_dest_fieldtype(i) = .true.
421 source_dest_fieldtype(i) = CATEGORICAL
422 end if
424 else if (index('interp_option',trim(buffer(1:idx-1))) /= 0) then
425 ispace = idx+1
426 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
427 ispace = ispace + 1
428 end do
429 interp_string = ' '
430 interp_string(1:ispace-idx-1) = buffer(idx+1:ispace-1)
431 ispace = index(interp_string,':')
432 if (ispace /= 0) then
433 write(res_string,'(a)') interp_string(1:ispace-1)
434 else
435 res_string = 'default'
436 end if
437 write(interp_string,'(a)') trim(interp_string(ispace+1:128))
438 if (list_search(source_interp_option(i), ckey=res_string, cvalue=interp_string)) then
439 call mprintf(.true., WARN, &
440 'In GEOGRID.TBL entry %i, multiple interpolation methods are '// &
441 'given for resolution %s. %s will be used.', &
442 i1=i, s1=trim(res_string), s2=trim(interp_string))
443 else
444 call list_insert(source_interp_option(i), ckey=res_string, cvalue=interp_string)
445 end if
447 else if (index('smooth_option',trim(buffer(1:idx-1))) /= 0) then
448 if ((index('1-2-1',trim(buffer(idx+1:eos-1))) /= 0) .and. &
449 (len_trim(buffer(idx+1:eos-1)) == len('1-2-1'))) then
450 is_smooth_option(i) = .true.
451 source_smooth_option(i) = ONETWOONE
452 else if ((index('smth-desmth',trim(buffer(idx+1:eos-1))) /= 0) .and. &
453 (len_trim(buffer(idx+1:eos-1)) == len('smth-desmth'))) then
454 is_smooth_option(i) = .true.
455 source_smooth_option(i) = SMTHDESMTH
456 else if ((index('smth-desmth_special',trim(buffer(idx+1:eos-1))) /= 0) .and. &
457 (len_trim(buffer(idx+1:eos-1)) == len('smth-desmth_special'))) then
458 is_smooth_option(i) = .true.
459 source_smooth_option(i) = SMTHDESMTH_SPECIAL
460 end if
462 else if (index('smooth_passes',trim(buffer(1:idx-1))) /= 0) then
463 is_smooth_passes(i) = .true.
464 read(buffer(idx+1:eos-1),'(i10)') source_smooth_passes(i)
466 else if (index('rel_path',trim(buffer(1:idx-1))) /= 0) then
467 ispace = idx+1
468 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
469 ispace = ispace + 1
470 end do
471 path_string = ' '
472 path_string(1:ispace-idx-1) = buffer(idx+1:ispace-1)
473 if (path_string(ispace-idx-1:ispace-idx-1) /= '/') &
474 path_string(ispace-idx:ispace-idx) = '/'
475 if (path_string(1:1) == '/') then
476 path_string(1:127) = path_string(2:128)
477 path_string(128:128) = ' '
478 end if
479 ispace = index(path_string,':')
480 if (ispace /= 0) then
481 write(res_string,'(a)') path_string(1:ispace-1)
482 else
483 res_string = 'default'
484 end if
485 write(path_string,'(a)') trim(geog_data_path)//trim(path_string(ispace+1:128))
486 if (list_search(source_res_path(i), ckey=res_string, cvalue=path_string)) then
487 call mprintf(.true., WARN, &
488 'In GEOGRID.TBL entry %i, multiple paths are given for '// &
489 'resolution %s. %s will be used.', &
490 i1=i, s1=trim(res_string), s2=trim(path_string))
491 else
492 call list_insert(source_res_path(i), ckey=res_string, cvalue=path_string)
493 end if
495 else if (index('abs_path',trim(buffer(1:idx-1))) /= 0) then
496 ispace = idx+1
497 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
498 ispace = ispace + 1
499 end do
500 path_string = ' '
501 path_string(1:ispace-idx-1) = buffer(idx+1:ispace-1)
502 if (path_string(ispace-idx-1:ispace-idx-1) /= '/') &
503 path_string(ispace-idx:ispace-idx) = '/'
504 ispace = index(path_string,':')
505 if (ispace /= 0) then
506 write(res_string,'(a)') path_string(1:ispace-1)
507 else
508 res_string = 'default'
509 end if
510 write(path_string,'(a)') trim(path_string(ispace+1:128))
511 if (list_search(source_res_path(i), ckey=res_string, cvalue=path_string)) then
512 call mprintf(.true., WARN, &
513 'In GEOGRID.TBL entry %i, multiple paths are given for '// &
514 'resolution %s. %s will be used.', &
515 i1=i, s1=trim(res_string), s2=trim(path_string))
516 else
517 call list_insert(source_res_path(i), ckey=res_string, cvalue=path_string)
518 end if
520 else if (index('output_stagger',trim(buffer(1:idx-1))) /= 0) then
521 if (index('M',trim(buffer(idx+1:eos-1))) /= 0) then
522 is_output_stagger(i) = .true.
523 source_output_stagger(i) = M
524 else if (index('U',trim(buffer(idx+1:eos-1))) /= 0) then
525 is_output_stagger(i) = .true.
526 source_output_stagger(i) = U
527 else if (index('V',trim(buffer(idx+1:eos-1))) /= 0) then
528 is_output_stagger(i) = .true.
529 source_output_stagger(i) = V
530 else if (index('HH',trim(buffer(idx+1:eos-1))) /= 0) then
531 is_output_stagger(i) = .true.
532 source_output_stagger(i) = HH
533 else if (index('VV',trim(buffer(idx+1:eos-1))) /= 0) then
534 is_output_stagger(i) = .true.
535 source_output_stagger(i) = VV
536 end if
538 else if ((index('landmask_water',trim(buffer(1:idx-1))) /= 0) .and. &
539 (len_trim(buffer(1:idx-1)) == 14)) then
540 ispace = idx+1
541 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
542 ispace = ispace + 1
543 end do
544 landmask_string = ' '
545 landmask_string(1:ispace-idx-1) = buffer(idx+1:ispace-1)
546 ispace = index(landmask_string,':')
547 if (ispace /= 0) then
548 write(res_string,'(a)') landmask_string(1:ispace-1)
549 else
550 res_string = 'default'
551 end if
552 write(landmask_string,'(a)') trim(landmask_string(ispace+1:128))
553 if (list_search(source_landmask_water(i), ckey=res_string, cvalue=landmask_string)) then
554 call mprintf(.true., WARN, &
555 'In GEOGRID.TBL entry %i, multiple landmask category specifications are given for '// &
556 'resolution %s. %s will be used.', &
557 i1=i, s1=trim(res_string), s2=trim(landmask_string))
558 else
559 call list_insert(source_landmask_water(i), ckey=res_string, cvalue=landmask_string)
560 end if
562 else if ((index('landmask_land',trim(buffer(1:idx-1))) /= 0) .and. &
563 (len_trim(buffer(1:idx-1)) == 13)) then
564 ispace = idx+1
565 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
566 ispace = ispace + 1
567 end do
568 landmask_string = ' '
569 landmask_string(1:ispace-idx-1) = buffer(idx+1:ispace-1)
570 ispace = index(landmask_string,':')
571 if (ispace /= 0) then
572 write(res_string,'(a)') landmask_string(1:ispace-1)
573 else
574 res_string = 'default'
575 end if
576 write(landmask_string,'(a)') trim(landmask_string(ispace+1:128))
577 if (list_search(source_landmask_land(i), ckey=res_string, cvalue=landmask_string)) then
578 call mprintf(.true., WARN, &
579 'In GEOGRID.TBL entry %i, multiple landmask category specifications are given for '// &
580 'resolution %s. %s will be used.', &
581 i1=i, s1=trim(res_string), s2=trim(landmask_string))
582 else
583 call list_insert(source_landmask_land(i), ckey=res_string, cvalue=landmask_string)
584 end if
586 else if ((index('masked',trim(buffer(1:idx-1))) /= 0) .and. &
587 (len_trim(buffer(1:idx-1)) == 6)) then
588 if (index('water',trim(buffer(idx+1:eos-1))) /= 0) then
589 is_masked(i) = .true.
590 source_masked(i) = 0.
591 else if (index('land',trim(buffer(idx+1:eos-1))) /= 0) then
592 is_masked(i) = .true.
593 source_masked(i) = 1.
594 end if
596 else if (index('fill_missing',trim(buffer(1:idx-1))) /= 0) then
597 is_fill_missing(i) = .true.
598 read(buffer(idx+1:eos-1),*) source_fill_missing(i)
600 else if (index('halt_on_missing',trim(buffer(1:idx-1))) /= 0) then
601 if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then
602 is_halt_missing(i) = .true.
603 else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then
604 is_halt_missing(i) = .false.
605 end if
607 else if (index('dominant_category',trim(buffer(1:idx-1))) /= 0) then
608 ispace = idx+1
609 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
610 ispace = ispace + 1
611 end do
612 is_dominant_category(i) = .true.
613 source_dominant_category(i) = ' '
614 source_dominant_category(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
616 else if (index('dominant_only',trim(buffer(1:idx-1))) /= 0) then
617 ispace = idx+1
618 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
619 ispace = ispace + 1
620 end do
621 is_dominant_only(i) = .true.
622 source_dominant_only(i) = ' '
623 source_dominant_only(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
625 else if (index('df_dx',trim(buffer(1:idx-1))) /= 0) then
626 ispace = idx+1
627 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
628 ispace = ispace + 1
629 end do
630 is_dfdx(i) = .true.
631 source_dfdx(i) = ' '
632 source_dfdx(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
634 else if (index('df_dy',trim(buffer(1:idx-1))) /= 0) then
635 ispace = idx+1
636 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
637 ispace = ispace + 1
638 end do
639 is_dfdy(i) = .true.
640 source_dfdy(i) = ' '
641 source_dfdy(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
643 else if (index('z_dim_name',trim(buffer(1:idx-1))) /= 0) then
644 ispace = idx+1
645 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
646 ispace = ispace + 1
647 end do
648 is_z_dim_name(i) = .true.
649 source_z_dim_name(i) = ' '
650 source_z_dim_name(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
652 else if (index('subgrid',trim(buffer(1:idx-1))) /= 0) then
653 if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then
654 is_subgrid(i) = .true.
655 else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then
656 is_subgrid(i) = .false.
657 end if
659 else if (index('flag_in_output',trim(buffer(1:idx-1))) /= 0) then
660 ispace = idx+1
661 do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
662 ispace = ispace + 1
663 end do
664 is_output_flag(i) = .true.
665 source_output_flag(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
667 else if (index('optional',trim(buffer(1:idx-1))) /= 0) then
668 if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then
669 is_optional(i) = .true.
670 else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then
671 is_subgrid(i) = .false.
672 end if
674 else
675 call mprintf(.true., WARN, 'In GEOGRID.TBL, unrecognized option %s in '// &
676 'entry %i.',i1=idx, s1=buffer(i:idx-1))
678 end if
680 end if !} index(buffer(1:eos-1),'=') /= 0
682 buffer = buffer(eos+1:BUFSIZE)
683 end do ! while eos /= 0 }
685 end if !} index(buffer, '=====') /= 0
686 go to 30
688 40 close(funit)
690 ! Check the user specifications for gross errors
691 if ( .not. check_data_specification() ) then
692 call datalist_destroy()
693 call mprintf(.true.,ERROR,'Errors were found in either index files or GEOGRID.TBL.')
694 end if
696 call hash_init(bad_files)
698 return
700 1000 call mprintf(.true.,ERROR,'Could not open GEOGRID.TBL')
702 1001 call mprintf(.true.,ERROR,'Encountered error while reading GEOGRID.TBL')
704 end subroutine get_datalist
707 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
708 ! Name: get_source_params
709 !
710 ! Purpose: For each field, this routine reads in the metadata in the index file
711 ! for the first available resolution of data specified by res_string. Also
712 ! based on res_string, this routine sets the interpolation sequence for the
713 ! field. This routine should be called prior to processing a field for each
714 ! domain.
715 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
716 subroutine get_source_params(res_string)
718 use stringutil
720 implicit none
722 ! Parameters
723 integer, parameter :: BUFSIZE = 256
725 ! Arguments
726 character (len=128), intent(in) :: res_string
728 ! Local variables
729 integer :: idx, i, is, ie, ispace, eos, iquoted, funit, iostatus
730 character (len=128) :: temp_data, temp_interp
731 character (len=256) :: test_fname
732 character (len=BUFSIZE) :: buffer
733 logical :: have_specification, is_used
734 logical :: landusef_already_found
735 character (len=128) :: cur_mminlu, previous_mminlu
736 character (len=128), parameter :: default_mminlu = 'USGS'
737 logical :: mminlu_found_in_this_entry
738 landusef_already_found = .FALSE.
739 previous_mminlu = 'NOT_YET_SET'
741 ! For each entry in the GEOGRID.TBL file
742 ENTRY_LOOP: do idx=1,num_entries
743 mminlu_found_in_this_entry = .FALSE.
745 ! Initialize metadata
746 is_wordsize(idx) = .false.
747 is_endian(idx) = .false.
748 is_row_order(idx) = .false.
749 is_fieldtype(idx) = .false.
750 is_proj(idx) = .false.
751 is_dx(idx) = .false.
752 is_dy(idx) = .false.
753 is_known_x(idx) = .false.
754 is_known_y(idx) = .false.
755 is_known_lat(idx) = .false.
756 is_known_lon(idx) = .false.
757 is_truelat1(idx) = .false.
758 is_truelat2(idx) = .false.
759 is_stdlon(idx) = .false.
760 is_tile_x(idx) = .false.
761 is_tile_y(idx) = .false.
762 is_tile_z(idx) = .false.
763 is_tile_z_start(idx) = .false.
764 is_tile_z_end(idx) = .false.
765 is_category_min(idx) = .false.
766 is_category_max(idx) = .false.
767 is_tile_bdr(idx) = .false.
768 is_fieldname(idx) = .false.
769 is_scale_factor(idx) = .false.
770 is_units(idx) = .false.
771 is_descr(idx) = .false.
772 is_signed(idx) = .false.
773 is_missing_value(idx) = .false.
774 is_not_found(idx) = .false.
777 ! Set the interpolator sequence for the field to be the first value in res_string that matches
778 ! the resolution keyword for an interp_sequence specification
779 is = 1
780 ie = index(res_string(is:128),'+') - 1
781 if (ie <= 0) ie = 128
782 temp_interp = res_string(is:ie)
783 do while (.not. list_search(source_interp_option(idx), ckey=temp_interp, cvalue=source_interp_string(idx)) &
784 .and. is <= 128)
785 call mprintf(.true., INFORM, 'For %s, couldn''t find interpolator sequence for '// &
786 'resolution %s.', &
787 s1=trim(source_fieldname(idx)), s2=trim(temp_interp))
788 is = ie+2
789 ie = is + index(res_string(is:128),'+') - 2
790 if (ie - is <= 0) ie = 128
791 temp_interp = res_string(is:ie)
792 end do
794 if (is > 128) then
795 temp_interp = 'default'
796 if (list_search(source_interp_option(idx), ckey=temp_interp, cvalue=source_interp_string(idx))) then
797 call mprintf(.true., INFORM, 'Using default interpolator sequence for %s.', &
798 s1=trim(source_fieldname(idx)))
799 else
800 if (is_optional(idx)) then
801 is_not_found(idx) = .true.
802 call mprintf(.true., INFORM, 'Could not find interpolator sequence for requested resolution '// &
803 'for this entry of %s in GEOGRID.TBL and no default interpolator was specified.',&
804 s1=trim(source_fieldname(idx)))
805 call mprintf(.true., INFORM, 'This entry in GEOGRID.TBL of %s is optional and will not be '// &
806 'processed. However, there may be other entries for %s in GEOGRID.TBL and ' // &
807 'thus this field may yet be processed.', s1=trim(source_fieldname(idx)), &
808 s2=trim(source_fieldname(idx)))
809 cycle ENTRY_LOOP
810 else
811 call mprintf(.true., ERROR, 'Could not find interpolator sequence for requested resolution for %s.'// &
812 ' The sources specified in namelist.wps is not listed in GEOGRID.TBL.', &
813 s1=trim(source_fieldname(idx)))
814 end if
815 end if
816 else
817 call mprintf(.true., INFORM, 'Using %s interpolator sequence for %s.', &
818 s1=temp_interp, s2=trim(source_fieldname(idx)))
819 end if
821 ! Set the data source for the field to be the first value in res_string that matches
822 ! the resolution keyword for an abs_path or rel_path specification
823 is = 1
824 ie = index(res_string(is:128),'+') - 1
825 if (ie <= 0) ie = 128
826 temp_data = res_string(is:ie)
827 do while (.not. list_search(source_res_path(idx), ckey=temp_data, cvalue=source_path(idx)) &
828 .and. is <= 128)
829 call mprintf(.true., INFORM, 'For %s, couldn''t find %s data source.', &
830 s1=trim(source_fieldname(idx)), s2=trim(temp_data))
831 is = ie+2
832 ie = is + index(res_string(is:128),'+') - 2
833 if (ie - is <= 0) ie = 128
834 temp_data = res_string(is:ie)
835 end do
837 if (is > 128) then
838 temp_data = 'default'
839 if (list_search(source_res_path(idx), ckey=temp_data, cvalue=source_path(idx))) then
840 call mprintf(.true., INFORM, 'Using default data source for %s.', &
841 s1=trim(source_fieldname(idx)))
842 else
843 call mprintf(.true., ERROR, 'Could not find data resolution for requested resolution for %s. '// &
844 'The source specified in namelist.wps is not listed in GEOGRID.TBL.', &
845 s1=trim(source_fieldname(idx)))
846 end if
847 else
848 call mprintf(.true., INFORM, 'Using %s data source for %s.', &
849 s1=temp_data, s2=trim(source_fieldname(idx)))
850 end if
851 source_res(idx) = temp_data
853 call mprintf(trim(temp_data) /= trim(temp_interp),WARN,'For %s, using %s data source with %s interpolation sequence.', &
854 s1=source_fieldname(idx), s2=temp_data, s3=temp_interp)
856 write(test_fname, '(a)') trim(source_path(idx))//'index'
858 !
859 ! Open the index file for the data source for this field, and read in metadata specs
860 !
861 do funit=10,100
862 inquire(unit=funit, opened=is_used)
863 if (.not. is_used) exit
864 end do
865 open(funit,file=trim(test_fname),form='formatted',status='old',iostat=iostatus)
866 if (iostatus /= 0) then
867 if (is_optional(idx)) then
868 is_not_found(idx) = .true.
869 call mprintf(.true.,INFORM,'Could not read ''index'' file %s for field %s', s1=trim(test_fname), &
870 s2=trim(source_fieldname(idx)))
871 call mprintf(.true.,INFORM,'This field is optional and will not be processed.')
872 else
873 call mprintf(.true.,ERROR,'Could not open %s', s1=trim(test_fname))
874 end if
876 cycle ENTRY_LOOP
878 end if
880 30 buffer = ' '
881 read(funit,'(a)',end=40, err=1001) buffer
882 call despace(buffer)
884 ! Is this line a comment?
885 if (buffer(1:1) == '#') then
886 ! Do nothing.
888 else
889 have_specification = .true.
891 ! If only part of the line is a comment, just turn the comment into spaces
892 eos = index(buffer,'#')
893 if (eos /= 0) buffer(eos:BUFSIZE) = ' '
895 do while (have_specification) !{
897 ! If this line has no semicolon, it may contain a single specification,
898 ! so we set have_specification = .false. to prevent the line from being
899 ! processed again and pretend that the last character was a semicolon
900 eos = index(buffer,';')
901 if (eos == 0) then
902 have_specification = .false.
903 eos = BUFSIZE
904 end if
906 i = index(buffer(1:eos-1),'=')
908 if (i /= 0) then !{
910 if (index('projection',trim(buffer(1:i-1))) /= 0) then
911 if (index('lambert',trim(buffer(i+1:eos-1))) /= 0) then
912 is_proj(idx) = .true.
913 source_proj(idx) = PROJ_LC
914 else if (index('polar_wgs84',trim(buffer(i+1:eos-1))) /= 0 .and. &
915 len_trim('polar_wgs84') == len_trim(buffer(i+1:eos-1))) then
916 is_proj(idx) = .true.
917 source_proj(idx) = PROJ_PS_WGS84
918 else if (index('albers_nad83',trim(buffer(i+1:eos-1))) /= 0 .and. &
919 len_trim('albers_nad83') == len_trim(buffer(i+1:eos-1))) then
920 is_proj(idx) = .true.
921 source_proj(idx) = PROJ_ALBERS_NAD83
922 else if (index('polar',trim(buffer(i+1:eos-1))) /= 0 .and. &
923 len_trim('polar') == len_trim(buffer(i+1:eos-1))) then
924 is_proj(idx) = .true.
925 source_proj(idx) = PROJ_PS
926 else if (index('mercator',trim(buffer(i+1:eos-1))) /= 0) then
927 is_proj(idx) = .true.
928 source_proj(idx) = PROJ_MERC
929 else if (index('regular_ll',trim(buffer(i+1:eos-1))) /= 0) then
930 is_proj(idx) = .true.
931 source_proj(idx) = PROJ_LATLON
932 end if
934 else if (index('type',trim(buffer(1:i-1))) /= 0) then
935 if (index('continuous',trim(buffer(i+1:eos-1))) /= 0) then
936 is_fieldtype(idx) = .true.
937 source_fieldtype(idx) = CONTINUOUS
938 else if (index('categorical',trim(buffer(i+1:eos-1))) /= 0) then
939 is_fieldtype(idx) = .true.
940 source_fieldtype(idx) = CATEGORICAL
941 end if
943 else if (index('signed',trim(buffer(1:i-1))) /= 0) then
944 if (index('yes',trim(buffer(i+1:eos-1))) /= 0) then
945 is_signed(idx) = .true.
946 else if (index('no',trim(buffer(i+1:eos-1))) /= 0) then
947 is_signed(idx) = .false.
948 end if
950 else if (index('units',trim(buffer(1:i-1))) /= 0) then
951 ispace = i+1
952 iquoted = 0
953 do while (((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) .or. (iquoted == 1))
954 if (buffer(ispace:ispace) == '"' .or. buffer(ispace:ispace) == '''') iquoted = mod(iquoted+1,2)
955 ispace = ispace + 1
956 end do
957 is_units(idx) = .true.
958 source_units(idx) = ' '
959 if (buffer(i+1:i+1) == '"' .or. buffer(i+1:i+1) == '''') i = i + 1
960 if (buffer(ispace-1:ispace-1) == '"' .or. buffer(ispace-1:ispace-1) == '''') ispace = ispace - 1
961 source_units(idx)(1:ispace-i) = buffer(i+1:ispace-1)
963 else if (index('description',trim(buffer(1:i-1))) /= 0) then
964 ispace = i+1
965 iquoted = 0
966 do while (((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) .or. (iquoted == 1))
967 if (buffer(ispace:ispace) == '"' .or. buffer(ispace:ispace) == '''') iquoted = mod(iquoted+1,2)
968 ispace = ispace + 1
969 end do
970 is_descr(idx) = .true.
971 source_descr(idx) = ' '
972 if (buffer(i+1:i+1) == '"' .or. buffer(i+1:i+1) == '''') i = i + 1
973 if (buffer(ispace-1:ispace-1) == '"' .or. buffer(ispace-1:ispace-1) == '''') ispace = ispace - 1
974 source_descr(idx)(1:ispace-i) = buffer(i+1:ispace-1)
976 else if (index('mminlu',trim(buffer(1:i-1))) /= 0) then
977 ispace = i+1
978 iquoted = 0
979 do while (((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) .or. (iquoted == 1))
980 if (buffer(ispace:ispace) == '"' .or. buffer(ispace:ispace) == '''') iquoted = mod(iquoted+1,2)
981 ispace = ispace + 1
982 end do
983 if (buffer(i+1:i+1) == '"' .or. buffer(i+1:i+1) == '''') i = i + 1
984 if (buffer(ispace-1:ispace-1) == '"' .or. buffer(ispace-1:ispace-1) == '''') ispace = ispace - 1
985 source_mminlu(1:ispace-i) = buffer(i+1:ispace-1)
986 mminlu_found_in_this_entry = .TRUE.
988 else if (index('iswater',trim(buffer(1:i-1))) /= 0) then
989 read(buffer(i+1:eos-1),*) source_iswater
991 else if (index('islake',trim(buffer(1:i-1))) /= 0) then
992 read(buffer(i+1:eos-1),*) source_islake
994 else if (index('isice',trim(buffer(1:i-1))) /= 0) then
995 read(buffer(i+1:eos-1),*) source_isice
997 else if (index('isurban',trim(buffer(1:i-1))) /= 0) then
998 read(buffer(i+1:eos-1),*) source_isurban
1000 else if (index('isoilwater',trim(buffer(1:i-1))) /= 0) then
1001 read(buffer(i+1:eos-1),*) source_isoilwater
1003 else if (index('dx',trim(buffer(1:i-1))) /= 0) then
1004 is_dx(idx) = .true.
1005 read(buffer(i+1:eos-1),*) source_dx(idx)
1007 else if (index('dy',trim(buffer(1:i-1))) /= 0) then
1008 is_dy(idx) = .true.
1009 read(buffer(i+1:eos-1),*) source_dy(idx)
1011 else if (index('known_x',trim(buffer(1:i-1))) /= 0) then
1012 is_known_x(idx) = .true.
1013 read(buffer(i+1:eos-1),*) source_known_x(idx)
1015 else if (index('known_y',trim(buffer(1:i-1))) /= 0) then
1016 is_known_y(idx) = .true.
1017 read(buffer(i+1:eos-1),*) source_known_y(idx)
1019 else if (index('known_lat',trim(buffer(1:i-1))) /= 0) then
1020 is_known_lat(idx) = .true.
1021 read(buffer(i+1:eos-1),*) source_known_lat(idx)
1023 else if (index('known_lon',trim(buffer(1:i-1))) /= 0) then
1024 is_known_lon(idx) = .true.
1025 read(buffer(i+1:eos-1),*) source_known_lon(idx)
1027 else if (index('stdlon',trim(buffer(1:i-1))) /= 0) then
1028 is_stdlon(idx) = .true.
1029 read(buffer(i+1:eos-1),*) source_stdlon(idx)
1031 else if (index('truelat1',trim(buffer(1:i-1))) /= 0) then
1032 is_truelat1(idx) = .true.
1033 read(buffer(i+1:eos-1),*) source_truelat1(idx)
1035 else if (index('truelat2',trim(buffer(1:i-1))) /= 0) then
1036 is_truelat2(idx) = .true.
1037 read(buffer(i+1:eos-1),*) source_truelat2(idx)
1039 else if (index('wordsize',trim(buffer(1:i-1))) /= 0) then
1040 is_wordsize(idx) = .true.
1041 read(buffer(i+1:eos-1),'(i10)') source_wordsize(idx)
1043 else if (index('endian',trim(buffer(1:i-1))) /= 0) then
1044 if (index('big',trim(buffer(i+1:eos-1))) /= 0) then
1045 is_endian(idx) = .true.
1046 source_endian(idx) = BIG_ENDIAN
1047 else if (index('little',trim(buffer(i+1:eos-1))) /= 0) then
1048 is_endian(idx) = .true.
1049 source_endian(idx) = LITTLE_ENDIAN
1050 else
1051 call mprintf(.true.,WARN,'Invalid value for keyword ''endian'' '// &
1052 'specified in index file. BIG_ENDIAN will be used.')
1053 end if
1055 else if (index('row_order',trim(buffer(1:i-1))) /= 0) then
1056 if (index('bottom_top',trim(buffer(i+1:eos-1))) /= 0) then
1057 is_row_order(idx) = .true.
1058 source_row_order(idx) = BOTTOM_TOP
1059 else if (index('top_bottom',trim(buffer(i+1:eos-1))) /= 0) then
1060 is_row_order(idx) = .true.
1061 source_row_order(idx) = TOP_BOTTOM
1062 end if
1064 else if (index('tile_x',trim(buffer(1:i-1))) /= 0) then
1065 is_tile_x(idx) = .true.
1066 read(buffer(i+1:eos-1),'(i10)') source_tile_x(idx)
1068 else if (index('tile_y',trim(buffer(1:i-1))) /= 0) then
1069 is_tile_y(idx) = .true.
1070 read(buffer(i+1:eos-1),'(i10)') source_tile_y(idx)
1072 else if (index('tile_z',trim(buffer(1:i-1))) /= 0) then
1073 is_tile_z(idx) = .true.
1074 read(buffer(i+1:eos-1),'(i10)') source_tile_z(idx)
1076 else if (index('tile_z_start',trim(buffer(1:i-1))) /= 0) then
1077 is_tile_z_start(idx) = .true.
1078 read(buffer(i+1:eos-1),'(i10)') source_tile_z_start(idx)
1080 else if (index('tile_z_end',trim(buffer(1:i-1))) /= 0) then
1081 is_tile_z_end(idx) = .true.
1082 read(buffer(i+1:eos-1),'(i10)') source_tile_z_end(idx)
1084 else if (index('filename_digits',trim(buffer(1:i-1))) /= 0) then
1085 read(buffer(i+1:eos-1),'(i10)') source_filename_digits(idx)
1087 else if (index('category_min',trim(buffer(1:i-1))) /= 0) then
1088 is_category_min(idx) = .true.
1089 read(buffer(i+1:eos-1),'(i10)') source_category_min(idx)
1091 else if (index('category_max',trim(buffer(1:i-1))) /= 0) then
1092 is_category_max(idx) = .true.
1093 read(buffer(i+1:eos-1),'(i10)') source_category_max(idx)
1095 else if (index('tile_bdr',trim(buffer(1:i-1))) /= 0) then
1096 is_tile_bdr(idx) = .true.
1097 read(buffer(i+1:eos-1),'(i10)') source_tile_bdr(idx)
1099 else if (index('missing_value',trim(buffer(1:i-1))) /= 0) then
1100 is_missing_value(idx) = .true.
1101 read(buffer(i+1:eos-1),*) source_missing_value(idx)
1103 else if (index('scale_factor',trim(buffer(1:i-1))) /= 0) then
1104 is_scale_factor(idx) = .true.
1105 read(buffer(i+1:eos-1),*) source_scale_factor(idx)
1107 else
1108 call mprintf(.true., WARN, 'In %s, unrecognized option %s in entry %i.', &
1109 s1=trim(test_fname), s2=buffer(i:i-1), i1=i)
1111 end if
1113 end if !} index(buffer(1:eos-1),'=') /= 0
1115 buffer = buffer(eos+1:BUFSIZE)
1116 end do ! while eos /= 0 }
1118 end if !} index(buffer, '=====') /= 0
1120 go to 30
1122 40 close(funit)
1124 !Make sure we do not use two sources of land use data that use different
1125 !categories (e.g., USGS categories for some and NLCD2006 for others)
1126 if( trim(source_fieldname(idx)) .eq. 'LANDUSEF' ) then
1127 !If mminlu was defined for the current LANDUSEF entry then store that as the
1128 !current value, otherwise use the default value
1129 if( mminlu_found_in_this_entry ) then
1130 cur_mminlu = source_mminlu
1131 else
1132 cur_mminlu = default_mminlu
1133 end if
1134 !If a previous entry in GEOGRID.TBL already read in LANDUSEF
1135 if ( landusef_already_found ) then
1136 !Check mminlu string found for previous LANDUSEF entry to see if it matches the current entry
1137 if ( previous_mminlu .ne. cur_mminlu ) then
1138 if( mminlu_found_in_this_entry ) then !Current entry DID have an MMINLU setting
1139 !Previous LANDUSEF entry used default mminlu (either explicitly specified mminlu that is the
1140 !default or did not specify anything and defaulted to this value)
1141 if ( previous_mminlu .ne. default_mminlu ) then
1142 call mprintf(.true., ERROR, 'MMINLU values differ among input fields. Based on reading '// &
1143 '%s using entry %i from GEOGRID.TBL mminlu = %s but a previous GEOGRID.TBL ' // &
1144 'entry resulted in mminlu being set to to %s', &
1145 s1=trim(source_fieldname(idx)),i1=idx,s2=trim(cur_mminlu), &
1146 s3=trim(previous_mminlu))
1147 !Previous LANDUSEF entry did NOT use default mminlu
1148 else
1149 call mprintf(.true., ERROR, 'MMINLU values differ among input fields. Based on reading '// &
1150 '%s using entry %i from GEOGRID.TBL mminlu = %s but a previous GEOGRID.TBL '// &
1151 'entry resulted in mminlu being set to (or defaulting to) %s.', &
1152 s1=trim(source_fieldname(idx)),i1=idx, &
1153 s2=trim(cur_mminlu), s3=trim(previous_mminlu))
1154 end if !If previous LANDUSEF entry used default MMINLU
1155 !Current entry did not have an MMINLU setting
1156 else
1157 call mprintf(.true., ERROR, 'MMINLU values differ among input fields. Reading %s using ' // &
1158 'entry %i from GEOGRID.TBL did not set mminlu, and thus the default value ' // &
1159 'of %s is assumed. However, mminlu was previously set to %s', &
1160 s1=trim(source_fieldname(idx)),i1=idx,s2=trim(cur_mminlu), &
1161 s3=trim(previous_mminlu))
1162 end if !If the current entry explicitly set MMINLU
1163 end if !If MMINLU associated with previous LANDUSEF entry matches current LANDUSEF entry
1164 end if !If previous GEOGRID.TBL entry already read in LANDUSEF
1166 landusef_already_found = .TRUE.
1167 previous_mminlu = cur_mminlu
1168 end if
1170 end do ENTRY_LOOP
1172 return
1174 1001 call mprintf(.true.,ERROR,'Encountered error while reading %s', s1=trim(test_fname))
1176 end subroutine get_source_params
1179 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1180 ! Name: datalist_destroy()
1181 !
1182 ! Purpose: This routine deallocates any memory that was allocated by the
1183 ! get_datalist() subroutine.
1184 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1185 subroutine datalist_destroy()
1187 implicit none
1189 ! Local variables
1190 integer :: i
1192 if (associated(source_wordsize)) then
1193 deallocate(source_wordsize)
1194 deallocate(source_endian)
1195 deallocate(source_fieldtype)
1196 deallocate(source_dest_fieldtype)
1197 deallocate(source_proj)
1198 deallocate(source_priority)
1199 deallocate(source_dx)
1200 deallocate(source_dy)
1201 deallocate(source_known_x)
1202 deallocate(source_known_y)
1203 deallocate(source_known_lat)
1204 deallocate(source_known_lon)
1205 deallocate(source_truelat1)
1206 deallocate(source_truelat2)
1207 deallocate(source_stdlon)
1208 deallocate(source_fieldname)
1209 deallocate(source_path)
1210 deallocate(source_interp_string)
1211 deallocate(source_tile_x)
1212 deallocate(source_tile_y)
1213 deallocate(source_tile_z)
1214 deallocate(source_tile_z_start)
1215 deallocate(source_tile_z_end)
1216 deallocate(source_filename_digits)
1217 deallocate(source_tile_bdr)
1218 deallocate(source_category_min)
1219 deallocate(source_category_max)
1220 deallocate(source_masked)
1221 deallocate(source_output_stagger)
1222 deallocate(source_row_order)
1223 deallocate(source_dominant_category)
1224 deallocate(source_dominant_only)
1225 deallocate(source_dfdx)
1226 deallocate(source_dfdy)
1227 deallocate(source_scale_factor)
1228 deallocate(source_z_dim_name)
1229 deallocate(source_smooth_option)
1230 deallocate(source_smooth_passes)
1231 deallocate(source_units)
1232 deallocate(source_descr)
1233 deallocate(source_res)
1234 deallocate(source_missing_value)
1235 deallocate(source_fill_missing)
1236 do i=1,num_entries
1237 call list_destroy(source_res_path(i))
1238 call list_destroy(source_interp_option(i))
1239 call list_destroy(source_landmask_land(i))
1240 call list_destroy(source_landmask_water(i))
1241 end do
1242 deallocate(source_res_path)
1243 deallocate(source_interp_option)
1244 deallocate(source_landmask_land)
1245 deallocate(source_landmask_water)
1246 deallocate(source_output_flag)
1248 deallocate(is_wordsize)
1249 deallocate(is_endian)
1250 deallocate(is_fieldtype)
1251 deallocate(is_dest_fieldtype)
1252 deallocate(is_proj)
1253 deallocate(is_priority)
1254 deallocate(is_dx)
1255 deallocate(is_dy)
1256 deallocate(is_known_x)
1257 deallocate(is_known_y)
1258 deallocate(is_known_lat)
1259 deallocate(is_known_lon)
1260 deallocate(is_truelat1)
1261 deallocate(is_truelat2)
1262 deallocate(is_stdlon)
1263 deallocate(is_fieldname)
1264 deallocate(is_path)
1265 deallocate(is_tile_x)
1266 deallocate(is_tile_y)
1267 deallocate(is_tile_z)
1268 deallocate(is_tile_z_start)
1269 deallocate(is_tile_z_end)
1270 deallocate(is_tile_bdr)
1271 deallocate(is_category_min)
1272 deallocate(is_category_max)
1273 deallocate(is_masked)
1274 deallocate(is_halt_missing)
1275 deallocate(is_output_stagger)
1276 deallocate(is_row_order)
1277 deallocate(is_dominant_category)
1278 deallocate(is_dominant_only)
1279 deallocate(is_dfdx)
1280 deallocate(is_dfdy)
1281 deallocate(is_scale_factor)
1282 deallocate(is_z_dim_name)
1283 deallocate(is_smooth_option)
1284 deallocate(is_smooth_passes)
1285 deallocate(is_signed)
1286 deallocate(is_units)
1287 deallocate(is_descr)
1288 deallocate(is_missing_value)
1289 deallocate(is_fill_missing)
1290 deallocate(is_subgrid)
1291 deallocate(is_output_flag)
1292 deallocate(is_optional)
1293 deallocate(is_not_found)
1294 end if
1296 call hash_destroy(bad_files)
1298 end subroutine datalist_destroy
1301 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1302 ! Name: reset_next_field
1303 !
1304 ! Purpose: To reset the pointer to the next field in the list of fields
1305 ! specified by the user.
1306 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1307 subroutine reset_next_field()
1309 implicit none
1311 next_field = 1
1313 end subroutine reset_next_field
1316 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1317 ! Name: get_next_fieldname
1318 !
1319 ! Purpose: Calling this routine results in field_name being set to the name of
1320 ! the field currently pointed to. If istatus /= 0 upon return, an error
1321 ! occurred, and the value of field_name is undefined.
1322 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1323 subroutine get_next_fieldname(field_name, istatus)
1325 implicit none
1327 ! Arguments
1328 integer, intent(out) :: istatus
1329 character (len=128), intent(out) :: field_name
1331 istatus = 1
1333 if (next_field <= num_entries) then
1335 field_name = source_fieldname(next_field)
1336 next_field = next_field + 1
1337 istatus = 0
1339 end if
1341 end subroutine get_next_fieldname
1344 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1345 ! Name: get_next_output_fieldname
1346 !
1347 ! Purpose:
1348 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1349 recursive subroutine get_next_output_fieldname(nest_num, field_name, ndims, &
1350 min_cat, max_cat, istagger, memorder, &
1351 dimnames, units, description, sr_x, sr_y, &
1352 is_subgrid_var, derived_from, istatus)
1354 use gridinfo_module
1356 implicit none
1358 #include "wrf_io_flags.h"
1360 ! Arguments
1361 integer, intent(in) :: nest_num
1362 integer, intent(out) :: istatus, ndims, istagger, min_cat, max_cat
1363 integer, intent(out) :: sr_x, sr_y
1364 logical, intent(out) :: is_subgrid_var
1365 character (len=128), intent(out) :: memorder, field_name, units, description, derived_from
1366 character (len=128), dimension(3), intent(out) :: dimnames
1368 ! Local variables
1369 integer :: temp_fieldtype
1370 integer, dimension(MAX_LANDMASK_CATEGORIES) :: landmask
1371 logical :: is_water_mask, is_dom_only
1372 character (len=128) :: domcat_name, dfdx_name, dfdy_name
1373 character (len=256) :: temphash
1375 istatus = 1
1377 if (output_field_state == RETURN_LANDMASK) then
1378 call hash_init(duplicate_fnames)
1379 call get_landmask_field(geog_data_res(nest_num), field_name, is_water_mask, landmask, istatus)
1380 derived_from = ''
1381 last_output_fieldname(1:128) = field_name(1:128)
1382 if (istatus == 0) then
1383 temphash(129:256) = ' '
1384 temphash(1:128) = field_name(1:128)
1385 call hash_insert(duplicate_fnames, temphash)
1386 call get_domcategory_name(field_name, domcat_name, is_dom_only, istatus)
1387 ! We will only save the dominant category
1388 if (is_dom_only .and. (istatus == 0)) then
1389 output_field_state = RETURN_DOMCAT_LM
1390 call get_next_output_fieldname(nest_num, field_name, ndims, &
1391 min_cat, max_cat, istagger, &
1392 memorder, dimnames, units, description, &
1393 sr_x, sr_y, is_subgrid_var, derived_from, istatus)
1394 return
1395 else
1396 ndims = 2
1397 min_cat = 1
1398 max_cat = 1
1399 temp_fieldtype = iget_fieldtype(field_name, istatus)
1400 if (istatus == 0) then
1401 if (temp_fieldtype == CONTINUOUS) then
1402 call get_max_levels(field_name, min_cat, max_cat, istatus)
1403 else if (temp_fieldtype == CATEGORICAL) then
1404 call get_max_categories(field_name, min_cat, max_cat, istatus)
1405 end if
1406 if (max_cat - min_cat > 0) ndims = 3
1407 end if
1408 call get_output_stagger(field_name, istagger, istatus)
1409 if (istagger == M) then
1410 dimnames(1) = 'west_east'
1411 dimnames(2) = 'south_north'
1412 else if (istagger == U) then
1413 dimnames(1) = 'west_east_stag'
1414 dimnames(2) = 'south_north'
1415 else if (istagger == V) then
1416 dimnames(1) = 'west_east'
1417 dimnames(2) = 'south_north_stag'
1418 else if (istagger == HH) then
1419 dimnames(1) = 'west_east'
1420 dimnames(2) = 'south_north'
1421 else if (istagger == VV) then
1422 dimnames(1) = 'west_east'
1423 dimnames(2) = 'south_north'
1424 end if
1425 if (ndims == 2) then
1426 memorder = 'XY '
1427 dimnames(3) = ' '
1428 else if (ndims == 3) then
1429 memorder = 'XYZ'
1430 call get_z_dim_name(field_name, dimnames(3), istatus)
1431 istatus = 0
1432 else
1433 memorder = ' '
1434 dimnames(3) = ' '
1435 end if
1436 call get_subgrid_dim_name(nest_num, field_name, dimnames(1:2), sr_x, sr_y, is_subgrid_var, istatus)
1437 call get_source_units(field_name, 1, units, istatus)
1438 if (istatus /= 0) units = '-'
1439 call get_source_descr(field_name, 1, description, istatus)
1440 if (istatus /= 0) description = '-'
1441 istatus = 0
1442 output_field_state = RETURN_DOMCAT_LM
1443 end if
1444 else
1445 output_field_state = RETURN_FIELDNAME
1446 call get_next_output_fieldname(nest_num, field_name, ndims, &
1447 min_cat, max_cat, istagger, &
1448 memorder, dimnames, units, description, &
1449 sr_x, sr_y, is_subgrid_var, derived_from, istatus)
1450 return
1451 end if
1453 else if (output_field_state == RETURN_FIELDNAME) then
1454 call get_next_fieldname(field_name, istatus)
1455 derived_from = ''
1456 last_output_fieldname(1:128) = field_name(1:128)
1457 temphash(129:256) = ' '
1458 temphash(1:128) = field_name(1:128)
1459 if (istatus == 0 .and. (.not. hash_search(duplicate_fnames, temphash))) then
1460 call hash_insert(duplicate_fnames, temphash)
1461 call get_domcategory_name(field_name, domcat_name, is_dom_only, istatus)
1462 ! We will only save the dominant category
1463 if (is_dom_only .and. (istatus == 0)) then
1464 output_field_state = RETURN_DOMCAT
1465 call get_next_output_fieldname(nest_num, field_name, ndims, &
1466 min_cat, max_cat, istagger, &
1467 memorder, dimnames, units, description, &
1468 sr_x, sr_y, is_subgrid_var, derived_from, istatus)
1469 return
1471 ! Return the fractional field
1472 else
1473 ndims = 2
1474 min_cat = 1
1475 max_cat = 1
1476 temp_fieldtype = iget_fieldtype(field_name, istatus)
1477 if (istatus == 0) then
1478 if (temp_fieldtype == CONTINUOUS) then
1479 call get_max_levels(field_name, min_cat, max_cat, istatus)
1480 else if (temp_fieldtype == CATEGORICAL) then
1481 call get_max_categories(field_name, min_cat, max_cat, istatus)
1482 end if
1483 if (max_cat - min_cat > 0) ndims = 3
1484 end if
1485 call get_output_stagger(field_name, istagger, istatus)
1486 if (istagger == M) then
1487 dimnames(1) = 'west_east'
1488 dimnames(2) = 'south_north'
1489 else if (istagger == U) then
1490 dimnames(1) = 'west_east_stag'
1491 dimnames(2) = 'south_north'
1492 else if (istagger == V) then
1493 dimnames(1) = 'west_east'
1494 dimnames(2) = 'south_north_stag'
1495 else if (istagger == HH) then
1496 dimnames(1) = 'west_east'
1497 dimnames(2) = 'south_north'
1498 else if (istagger == VV) then
1499 dimnames(1) = 'west_east'
1500 dimnames(2) = 'south_north'
1501 end if
1502 if (ndims == 2) then
1503 memorder = 'XY '
1504 dimnames(3) = ' '
1505 else if (ndims == 3) then
1506 memorder = 'XYZ'
1507 call get_z_dim_name(field_name, dimnames(3), istatus)
1508 istatus = 0
1509 else
1510 memorder = ' '
1511 dimnames(3) = ' '
1512 end if
1513 call get_subgrid_dim_name(nest_num, field_name, dimnames(1:2), sr_x, sr_y, is_subgrid_var, istatus)
1514 call get_source_units(field_name, 1, units, istatus)
1515 if (istatus /= 0) units = '-'
1516 call get_source_descr(field_name, 1, description, istatus)
1517 if (istatus /= 0) description = '-'
1518 istatus = 0
1519 output_field_state = RETURN_DOMCAT
1520 end if
1521 else if (istatus /= 0) then
1522 output_field_state = RETURN_LANDMASK
1523 call hash_destroy(duplicate_fnames)
1524 return
1525 else if (hash_search(duplicate_fnames, temphash)) then
1526 call get_next_output_fieldname(nest_num, field_name, ndims, &
1527 min_cat, max_cat, istagger, &
1528 memorder, dimnames, units, description, &
1529 sr_x, sr_y, is_subgrid_var, derived_from, istatus)
1530 return
1531 end if
1533 else if (output_field_state == RETURN_DOMCAT .or. &
1534 output_field_state == RETURN_DOMCAT_LM ) then
1535 derived_from = last_output_fieldname
1536 if (output_field_state == RETURN_DOMCAT) then
1537 next_field = next_field - 1
1538 call get_next_fieldname(field_name, istatus)
1539 else
1540 call get_landmask_field(geog_data_res(nest_num), field_name, is_water_mask, landmask, istatus)
1541 end if
1542 if (istatus == 0) then
1543 call get_domcategory_name(field_name, domcat_name, is_dom_only, istatus)
1544 if (istatus == 0) then
1545 ndims = 2
1546 min_cat = 1
1547 max_cat = 1
1548 call get_output_stagger(field_name, istagger, istatus)
1549 if (istagger == M) then
1550 dimnames(1) = 'west_east'
1551 dimnames(2) = 'south_north'
1552 else if (istagger == U) then
1553 dimnames(1) = 'west_east_stag'
1554 dimnames(2) = 'south_north'
1555 else if (istagger == V) then
1556 dimnames(1) = 'west_east'
1557 dimnames(2) = 'south_north_stag'
1558 else if (istagger == HH) then
1559 dimnames(1) = 'west_east'
1560 dimnames(2) = 'south_north'
1561 else if (istagger == VV) then
1562 dimnames(1) = 'west_east'
1563 dimnames(2) = 'south_north'
1564 end if
1565 dimnames(3) = ' '
1566 memorder = 'XY '
1568 call get_subgrid_dim_name(nest_num, field_name, dimnames(1:2), sr_x, sr_y, is_subgrid_var, istatus)
1569 field_name = domcat_name
1570 units = 'category'
1571 description = 'Dominant category'
1572 if (output_field_state == RETURN_DOMCAT) then
1573 output_field_state = RETURN_DFDX
1574 else
1575 output_field_state = RETURN_DFDX_LM
1576 end if
1577 else
1578 if (output_field_state == RETURN_DOMCAT) then
1579 output_field_state = RETURN_DFDX
1580 else
1581 output_field_state = RETURN_DFDX_LM
1582 end if
1583 call get_next_output_fieldname(nest_num, field_name, ndims, &
1584 min_cat, max_cat, istagger, &
1585 memorder, dimnames, units, description, &
1586 sr_x, sr_y, is_subgrid_var, derived_from, istatus)
1587 return
1588 end if
1589 else
1590 call mprintf(.true., ERROR, 'get_next_output_fieldname(): In state DOMCAT, '// &
1591 'but no field name is found.')
1592 end if
1594 else if (output_field_state == RETURN_DFDX .or. &
1595 output_field_state == RETURN_DFDX_LM) then
1596 derived_from = last_output_fieldname
1597 if (output_field_state == RETURN_DFDX) then
1598 next_field = next_field - 1
1599 call get_next_fieldname(field_name, istatus)
1600 else
1601 call get_landmask_field(geog_data_res(nest_num), field_name, is_water_mask, landmask, istatus)
1602 end if
1603 if (istatus == 0) then
1604 call get_dfdx_name(field_name, dfdx_name, istatus)
1605 if (istatus == 0) then
1606 ndims = 2
1607 min_cat = 1
1608 max_cat = 1
1609 temp_fieldtype = iget_fieldtype(field_name, istatus)
1610 if (istatus == 0) then
1611 if (temp_fieldtype == CONTINUOUS) then
1612 call get_max_levels(field_name, min_cat, max_cat, istatus)
1613 else if (temp_fieldtype == CATEGORICAL) then
1614 call get_max_categories(field_name, min_cat, max_cat, istatus)
1615 end if
1616 if (max_cat - min_cat > 0) ndims = 3
1617 end if
1618 call get_output_stagger(field_name, istagger, istatus)
1619 if (istagger == M) then
1620 dimnames(1) = 'west_east'
1621 dimnames(2) = 'south_north'
1622 else if (istagger == U) then
1623 dimnames(1) = 'west_east_stag'
1624 dimnames(2) = 'south_north'
1625 else if (istagger == V) then
1626 dimnames(1) = 'west_east'
1627 dimnames(2) = 'south_north_stag'
1628 else if (istagger == HH) then
1629 dimnames(1) = 'west_east'
1630 dimnames(2) = 'south_north'
1631 else if (istagger == VV) then
1632 dimnames(1) = 'west_east'
1633 dimnames(2) = 'south_north'
1634 end if
1635 if (ndims == 2) then
1636 memorder = 'XY '
1637 dimnames(3) = ' '
1638 else if (ndims == 3) then
1639 memorder = 'XYZ'
1640 call get_z_dim_name(field_name, dimnames(3), istatus)
1641 istatus = 0
1642 else
1643 memorder = ' '
1644 dimnames(3) = ' '
1645 end if
1646 !---------- B. Kosovic 2016-10-28 ---- Changes begin
1647 ! The following two lines of code are in the wrong place resulting in
1648 ! incorrect size of the dfdx array on the nested domain(s)
1649 ! field_name = dfdx_name
1650 ! units = '-'
1652 call get_subgrid_dim_name(nest_num, field_name, dimnames(1:2), sr_x, sr_y, is_subgrid_var, istatus)
1653 ! Correct location of the two lines of code is below (see also dfdy)
1654 field_name = dfdx_name
1655 units = '-'
1656 !---------- B. Kosovic 2016-10-28 ----- End of changes
1657 description = 'df/dx'
1658 if (output_field_state == RETURN_DFDX) then
1659 output_field_state = RETURN_DFDY
1660 else
1661 output_field_state = RETURN_DFDY_LM
1662 end if
1663 else
1664 if (output_field_state == RETURN_DFDX) then
1665 output_field_state = RETURN_DFDY
1666 else
1667 output_field_state = RETURN_DFDY_LM
1668 end if
1669 call get_next_output_fieldname(nest_num, field_name, ndims, &
1670 min_cat, max_cat, istagger, &
1671 memorder, dimnames, units, description, &
1672 sr_x, sr_y, is_subgrid_var, derived_from, istatus)
1673 return
1674 end if
1675 else
1676 call mprintf(.true., ERROR, 'get_next_output_fieldname(): In state DFDX, '// &
1677 'but no field name is found.')
1678 end if
1680 else if (output_field_state == RETURN_DFDY .or. &
1681 output_field_state == RETURN_DFDY_LM) then
1682 derived_from = last_output_fieldname
1683 if (output_field_state == RETURN_DFDY) then
1684 next_field = next_field - 1
1685 call get_next_fieldname(field_name, istatus)
1686 else
1687 call get_landmask_field(geog_data_res(nest_num), field_name, is_water_mask, landmask, istatus)
1688 end if
1689 if (istatus == 0) then
1690 call get_dfdy_name(field_name, dfdy_name, istatus)
1691 if (istatus == 0) then
1692 ndims = 2
1693 min_cat = 1
1694 max_cat = 1
1695 temp_fieldtype = iget_fieldtype(field_name, istatus)
1696 if (istatus == 0) then
1697 if (temp_fieldtype == CONTINUOUS) then
1698 call get_max_levels(field_name, min_cat, max_cat, istatus)
1699 else if (temp_fieldtype == CATEGORICAL) then
1700 call get_max_categories(field_name, min_cat, max_cat, istatus)
1701 end if
1702 if (max_cat - min_cat > 0) ndims = 3
1703 end if
1704 call get_output_stagger(field_name, istagger, istatus)
1705 if (istagger == M) then
1706 dimnames(1) = 'west_east'
1707 dimnames(2) = 'south_north'
1708 else if (istagger == U) then
1709 dimnames(1) = 'west_east_stag'
1710 dimnames(2) = 'south_north'
1711 else if (istagger == V) then
1712 dimnames(1) = 'west_east'
1713 dimnames(2) = 'south_north_stag'
1714 else if (istagger == HH) then
1715 dimnames(1) = 'west_east'
1716 dimnames(2) = 'south_north'
1717 else if (istagger == VV) then
1718 dimnames(1) = 'west_east'
1719 dimnames(2) = 'south_north'
1720 end if
1721 if (ndims == 2) then
1722 memorder = 'XY '
1723 dimnames(3) = ' '
1724 else if (ndims == 3) then
1725 memorder = 'XYZ'
1726 call get_z_dim_name(field_name, dimnames(3), istatus)
1727 istatus = 0
1728 else
1729 memorder = ' '
1730 dimnames(3) = ' '
1731 end if
1733 call get_subgrid_dim_name(nest_num, field_name, dimnames(1:2), sr_x, sr_y, is_subgrid_var, istatus)
1734 field_name = dfdy_name
1735 units = '-'
1736 description = 'df/dy'
1737 output_field_state = RETURN_FIELDNAME
1738 else
1739 output_field_state = RETURN_FIELDNAME
1740 call get_next_output_fieldname(nest_num, field_name, ndims, &
1741 min_cat, max_cat, istagger, &
1742 memorder, dimnames, units, description, &
1743 sr_x, sr_y, is_subgrid_var, derived_from, istatus)
1744 return
1745 end if
1746 else
1747 call mprintf(.true., ERROR, 'get_next_output_fieldname(): In state DFDY, but no '// &
1748 'field name is found.')
1749 end if
1751 end if
1753 end subroutine get_next_output_fieldname
1756 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1757 ! Name: get_landmask_field
1758 !
1759 ! Purpose: To return the name of the field from which the landmask is to be
1760 ! computed. If no error occurs, is_water_mask is .true. if the landmask
1761 ! value specifies the value of water, and .false. if the landmask value
1762 ! specifies the value of land.
1763 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1764 subroutine get_landmask_field(res_string, landmask_name, is_water_mask, landmask, istatus)
1766 implicit none
1768 ! Arguments
1769 character (len=128), intent(in) :: res_string
1770 integer, dimension(:), intent(out) :: landmask
1771 integer, intent(out) :: istatus
1772 logical, intent(out) :: is_water_mask
1773 character (len=128), intent(out) :: landmask_name
1775 ! Local variables
1776 integer :: j
1777 integer :: ilen
1778 integer :: idx
1779 integer :: is, ie, sos, eos, comma
1780 character (len=128) :: temp_res, mask_cat_string
1782 istatus = 1
1784 do idx=1,num_entries
1786 if (list_length(source_landmask_land(idx)) > 0) then
1787 is = 1
1788 ie = index(res_string(is:128),'+') - 1
1789 if (ie <= 0) ie = 128
1790 temp_res = res_string(is:ie)
1791 do while (.not. list_search(source_landmask_land(idx), ckey=temp_res, cvalue=mask_cat_string) &
1792 .and. is <= 128)
1793 is = ie+2
1794 ie = is + index(res_string(is:128),'+') - 2
1795 if (ie - is <= 0) ie = 128
1796 temp_res = res_string(is:ie)
1797 end do
1799 if (is > 128) then
1800 temp_res = 'default'
1801 if (list_search(source_landmask_land(idx), ckey=temp_res, cvalue=mask_cat_string)) then
1802 is_water_mask = .false.
1803 landmask_name = source_fieldname(idx)
1804 istatus = 0
1805 end if
1806 else
1807 is_water_mask = .false.
1808 landmask_name = source_fieldname(idx)
1809 istatus = 0
1810 end if
1812 end if
1814 ! Note: The following cannot be an else-if, since different resolutions of data may
1815 ! specify, alternately, a land or a water mask, and in general we need to search
1816 ! both lists
1818 if (list_length(source_landmask_water(idx)) > 0) then
1819 is = 1
1820 ie = index(res_string(is:128),'+') - 1
1821 if (ie <= 0) ie = 128
1822 temp_res = res_string(is:ie)
1823 do while (.not. list_search(source_landmask_water(idx), ckey=temp_res, cvalue=mask_cat_string) &
1824 .and. is <= 128)
1825 is = ie+2
1826 ie = is + index(res_string(is:128),'+') - 2
1827 if (ie - is <= 0) ie = 128
1828 temp_res = res_string(is:ie)
1829 end do
1831 if (is > 128) then
1832 temp_res = 'default'
1833 if (list_search(source_landmask_water(idx), ckey=temp_res, cvalue=mask_cat_string)) then
1834 is_water_mask = .true.
1835 landmask_name = source_fieldname(idx)
1836 istatus = 0
1837 end if
1838 else
1839 is_water_mask = .true.
1840 landmask_name = source_fieldname(idx)
1841 istatus = 0
1842 end if
1843 end if
1845 if (istatus == 0) then
1846 j = 1
1847 sos = 0
1848 eos = 128
1849 comma = index(mask_cat_string(sos+1:eos-1),',')
1850 do while (comma > 0 .and. j < MAX_LANDMASK_CATEGORIES)
1851 read(mask_cat_string(sos+1:sos+comma-1),'(i10)') landmask(j)
1852 sos = sos + comma
1853 comma = index(mask_cat_string(sos+1:eos-1),',')
1854 j = j + 1
1855 end do
1856 read(mask_cat_string(sos+1:eos-1),'(i10)') landmask(j)
1857 j = j + 1
1858 if (j <= MAX_LANDMASK_CATEGORIES) then ! Terminate list with a flag value
1859 landmask(j) = INVALID
1860 end if
1861 exit
1862 end if
1864 end do
1866 end subroutine get_landmask_field
1869 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1870 ! Name: get_missing_value
1871 !
1872 ! Pupose: Return the value used in the source data to indicate missing data.
1873 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1874 subroutine get_missing_value(fieldnm, ilevel, rmissing, istatus)
1876 implicit none
1878 ! Arguments
1879 integer, intent(in) :: ilevel
1880 integer, intent(out) :: istatus
1881 real, intent(out) :: rmissing
1882 character (len=128), intent(in) :: fieldnm
1884 ! Local variables
1885 integer :: idx
1887 istatus = 1
1889 do idx=1,num_entries
1890 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
1891 (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) .and. &
1892 (source_priority(idx) == ilevel)) then
1894 if (is_missing_value(idx)) then
1895 rmissing = source_missing_value(idx)
1896 istatus = 0
1897 exit
1898 end if
1900 end if
1901 end do
1903 end subroutine get_missing_value
1906 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1907 ! Name: get_source_units
1908 !
1909 ! Pupose: Return a string giving the units of the specified source data.
1910 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1911 subroutine get_source_units(fieldnm, ilevel, cunits, istatus)
1913 implicit none
1915 ! Arguments
1916 integer, intent(in) :: ilevel
1917 integer, intent(out) :: istatus
1918 character (len=128), intent(in) :: fieldnm
1919 character (len=128), intent(out) :: cunits
1921 ! Local variables
1922 integer :: idx
1924 istatus = 1
1926 do idx=1,num_entries
1927 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
1928 (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) .and. &
1929 (source_priority(idx) == ilevel)) then
1931 if (is_units(idx)) then
1932 cunits = source_units(idx)
1933 istatus = 0
1934 exit
1935 end if
1937 end if
1938 end do
1940 end subroutine get_source_units
1943 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1944 ! Name: get_source_descr
1945 !
1946 ! Pupose: Return a string giving a description of the specified source data.
1947 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1948 subroutine get_source_descr(fieldnm, ilevel, descr, istatus)
1950 implicit none
1952 ! Arguments
1953 integer, intent(in) :: ilevel
1954 integer, intent(out) :: istatus
1955 character (len=128), intent(in) :: fieldnm
1956 character (len=128), intent(out) :: descr
1958 ! Local variables
1959 integer :: idx
1961 istatus = 1
1963 do idx=1,num_entries
1964 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
1965 (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) .and. &
1966 (source_priority(idx) == ilevel)) then
1968 if (is_units(idx)) then
1969 descr = source_descr(idx)
1970 istatus = 0
1971 exit
1972 end if
1974 end if
1975 end do
1977 end subroutine get_source_descr
1980 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1981 ! Name: get_missing_fill_value
1982 !
1983 ! Pupose: Return the value to fill missing points with.
1984 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1985 subroutine get_missing_fill_value(fieldnm, rmissing, istatus)
1987 implicit none
1989 ! Arguments
1990 integer, intent(out) :: istatus
1991 real, intent(out) :: rmissing
1992 character (len=128), intent(in) :: fieldnm
1994 ! Local variables
1995 integer :: idx
1997 istatus = 1
1999 do idx=1,num_entries
2000 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2001 (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) ) then
2003 if (is_fill_missing(idx)) then
2004 rmissing = source_fill_missing(idx)
2005 istatus = 0
2006 exit
2007 end if
2009 end if
2010 end do
2012 end subroutine get_missing_fill_value
2015 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2016 ! Name: get_halt_on_missing
2017 !
2018 ! Pupose: Returns 1 if the program should halt upon encountering a missing
2019 ! value in the final output field, and 0 otherwise.
2020 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2021 subroutine get_halt_on_missing(fieldnm, halt, istatus)
2023 implicit none
2025 ! Arguments
2026 integer, intent(out) :: istatus
2027 logical, intent(out) :: halt
2028 character (len=128), intent(in) :: fieldnm
2030 ! Local variables
2031 integer :: idx
2033 istatus = 0
2034 halt = .false.
2036 do idx=1,num_entries
2037 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2038 (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) ) then
2040 if (is_halt_missing(idx)) halt = .true.
2042 end if
2043 end do
2045 end subroutine get_halt_on_missing
2048 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2049 ! Name: get_masked_value
2050 !
2051 ! Pupose: If the field is to be masked by the landmask, returns 0 if the field
2052 ! is masked over water and 1 if the field is masked over land. If no mask is
2053 ! to be applied, -1 is returned.
2054 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2055 subroutine get_masked_value(fieldnm, ilevel, masked, istatus)
2057 implicit none
2059 ! Arguments
2060 integer, intent(in) :: ilevel
2061 integer, intent(out) :: istatus
2062 real, intent(out) :: masked
2063 character (len=128), intent(in) :: fieldnm
2065 ! Local variables
2066 integer :: idx
2068 istatus = 0
2069 masked = -1.
2071 do idx=1,num_entries
2072 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2073 (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) .and. &
2074 (source_priority(idx) == ilevel)) then
2076 if (is_masked(idx)) then
2077 masked = source_masked(idx)
2078 exit
2079 end if
2081 end if
2082 end do
2084 end subroutine get_masked_value
2087 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2088 ! Name: get_max_levels
2089 !
2090 ! Purpose: Returns the number of levels for the field given by fieldnm.
2091 ! The number of levels will generally be specified for continuous fields,
2092 ! whereas min/max category will generally be specified for categorical ones.
2093 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2094 subroutine get_max_levels(fieldnm, min_level, max_level, istatus)
2096 implicit none
2098 ! Arguments
2099 integer, intent(out) :: min_level, max_level, istatus
2100 character (len=128), intent(in) :: fieldnm
2102 ! Local variables
2103 integer :: idx
2104 logical :: have_found_field
2106 have_found_field = .false.
2107 istatus = 1
2109 do idx=1,num_entries
2110 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2111 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2113 if (is_dest_fieldtype(idx) .and. (source_dest_fieldtype(idx) /= CONTINUOUS)) then
2114 call mprintf(.true., WARN, 'In GEOGRID.TBL, destination field type for %s is '// &
2115 'not continuous and min/max levels specified.', s1=trim(fieldnm))
2116 end if
2117 if (.not. have_found_field) then
2118 if (is_tile_z_start(idx) .and. is_tile_z_end(idx)) then
2119 have_found_field = .true.
2120 istatus = 0
2121 min_level = source_tile_z_start(idx)
2122 max_level = source_tile_z_end(idx)
2123 else if (is_tile_z(idx)) then
2124 have_found_field = .true.
2125 istatus = 0
2126 min_level = 1
2127 max_level = source_tile_z(idx)
2128 end if
2130 if (.not. (is_tile_z_start(idx) .and. is_tile_z_end(idx))) then
2131 if (is_tile_z_start(idx) .or. is_tile_z_end(idx)) then
2132 call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of tile_z_start '// &
2133 'and tile_z_end specified for entry %i.',i1=idx)
2134 end if
2135 end if
2136 else
2137 if (is_tile_z_start(idx) .and. is_tile_z_end(idx)) then
2138 if (source_tile_z_start(idx) < min_level) min_level = source_tile_z_start(idx)
2139 if (source_tile_z_end(idx) > max_level) max_level = source_tile_z_end(idx)
2140 else if (is_tile_z(idx)) then
2141 if (min_level > 1) min_level = 1
2142 if (source_tile_z(idx) > max_level) max_level = source_tile_z(idx)
2143 end if
2145 if (.not. (is_tile_z_start(idx) .and. is_tile_z_end(idx))) then
2146 if (is_tile_z_start(idx) .or. is_tile_z_end(idx)) then
2147 call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of tile_z_start '// &
2148 'and tile_z_end specified for entry %i.',i1=idx)
2149 end if
2150 end if
2151 end if
2153 end if
2154 end do
2156 end subroutine get_max_levels
2159 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2160 ! Name: get_source_levels
2161 !
2162 ! Purpose: Return the min and max z-index for the source data for fieldname
2163 ! at a specified priority level (compared with the min/max level over
2164 ! all priority levels, as given by get_max_levels).
2165 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2166 subroutine get_source_levels(fieldnm, ilevel, min_level, max_level, istatus)
2168 implicit none
2170 ! Arguments
2171 integer, intent(in) :: ilevel
2172 integer, intent(out) :: min_level, max_level, istatus
2173 character (len=128), intent(in) :: fieldnm
2175 ! Local variables
2176 integer :: idx
2178 istatus = 1
2180 do idx=1,num_entries
2181 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2182 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2183 if (ilevel == source_priority(idx)) then
2185 if (is_tile_z_start(idx) .and. is_tile_z_end(idx)) then
2186 istatus = 0
2187 min_level = source_tile_z_start(idx)
2188 max_level = source_tile_z_end(idx)
2189 else if (is_tile_z(idx)) then
2190 istatus = 0
2191 min_level = 1
2192 max_level = source_tile_z(idx)
2193 end if
2195 if (.not. (is_tile_z_start(idx) .and. is_tile_z_end(idx))) then
2196 if (is_tile_z_start(idx) .or. is_tile_z_end(idx)) then
2197 call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of tile_z_start '// &
2198 'and tile_z_end specified for entry %i.',i1=idx)
2199 end if
2200 end if
2202 end if
2203 end if
2204 end do
2206 end subroutine get_source_levels
2209 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2210 ! Name: get_max_categories
2211 !
2212 ! Purpose: Returns the minimum category and the maximum category for the field
2213 ! given by fieldnm.
2214 ! Min/max category will generally be specified for categorical fields,
2215 ! whereas the number of levels will generally be specified for continuous
2216 ! fields.
2217 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2218 subroutine get_max_categories(fieldnm, min_category, max_category, istatus)
2220 implicit none
2222 ! Arguments
2223 integer, intent(out) :: min_category, max_category, istatus
2224 character (len=128), intent(in) :: fieldnm
2226 ! Local variables
2227 integer :: idx
2228 logical :: have_found_field
2230 have_found_field = .false.
2231 istatus = 1
2233 do idx=1,num_entries
2234 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2235 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2237 if (is_dest_fieldtype(idx) .and. (source_dest_fieldtype(idx) /= CATEGORICAL)) then
2238 call mprintf(.true., WARN, &
2239 'In GEOGRID.TBL, cannot get min/max categories for continuous '// &
2240 'field %s at entry %i. Perhaps the user has requested to '// &
2241 'perform a strange operation on the field.', s1=trim(fieldnm), i1=idx)
2242 end if
2243 if (.not. have_found_field) then
2244 if (is_category_min(idx) .and. is_category_max(idx)) then
2245 have_found_field = .true.
2246 istatus = 0
2247 min_category = source_category_min(idx)
2248 max_category = source_category_max(idx)
2249 else if (is_category_min(idx) .or. is_category_max(idx)) then
2250 call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of min_category and '// &
2251 'max_category specified for entry %i.',i1=idx)
2252 end if
2253 else
2254 if (is_category_min(idx) .and. is_category_max(idx)) then
2255 if (source_category_min(idx) < min_category) min_category = source_category_min(idx)
2256 if (source_category_max(idx) > max_category) max_category = source_category_max(idx)
2257 else if (is_category_min(idx) .or. is_category_max(idx)) then
2258 call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of min_category and '// &
2259 'max_category specified for entry %i.',i1=idx)
2260 end if
2261 end if
2263 end if
2264 end do
2266 end subroutine get_max_categories
2269 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2270 ! Name: get_source_categories
2271 !
2272 ! Purpose: Return the min and max category for the source data for fieldname
2273 ! at a specified priority level (compared with the min/max category over
2274 ! all priority levels, as given by get_max_categories).
2275 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2276 subroutine get_source_categories(fieldnm, ilevel, min_category, max_category, istatus)
2278 implicit none
2280 ! Arguments
2281 integer, intent(in) :: ilevel
2282 integer, intent(out) :: min_category, max_category, istatus
2283 character (len=128), intent(in) :: fieldnm
2285 ! Local variables
2286 integer :: idx
2288 istatus = 1
2290 do idx=1,num_entries
2291 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2292 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2293 if (ilevel == source_priority(idx)) then
2295 if (is_category_min(idx) .and. is_category_max(idx)) then
2296 istatus = 0
2297 min_category = source_category_min(idx)
2298 max_category = source_category_max(idx)
2299 else if (is_category_min(idx) .or. is_category_max(idx)) then
2300 call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of min_category '// &
2301 'and max_category specified for entry %i.',i1=idx)
2302 end if
2304 end if
2305 end if
2306 end do
2308 end subroutine get_source_categories
2311 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2312 ! Name: get_domcategory_name
2313 !
2314 ! Purpose:
2315 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2316 subroutine get_domcategory_name(fieldnm, domcat_name, ldominant_only, istatus)
2318 implicit none
2320 ! Arguments
2321 integer, intent(out) :: istatus
2322 logical, intent(out) :: ldominant_only
2323 character (len=128), intent(in) :: fieldnm
2324 character (len=128), intent(out) :: domcat_name
2326 ! Local variables
2327 integer :: idx
2329 istatus = 1
2330 ldominant_only = .false.
2332 do idx=1,num_entries
2333 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2334 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2336 if (is_dominant_category(idx)) then
2337 domcat_name = source_dominant_category(idx)
2338 istatus = 0
2339 if (is_dominant_only(idx)) then
2340 call mprintf(.true., WARN, 'In GEOGRID.TBL, both dominant_category and '// &
2341 'dominant_only are specified in entry %i. Using specification '// &
2342 'for dominant_category.',i1=idx)
2343 is_dominant_only(idx) = .false.
2344 end if
2345 exit
2347 else if (is_dominant_only(idx)) then
2348 domcat_name = source_dominant_only(idx)
2349 ldominant_only = .true.
2350 istatus = 0
2351 exit
2352 end if
2354 end if
2355 end do
2357 end subroutine get_domcategory_name
2360 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2361 ! Name: get_dfdx_name
2362 !
2363 ! Purpose:
2364 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2365 subroutine get_dfdx_name(fieldnm, dfdx_name, istatus)
2367 implicit none
2369 ! Arguments
2370 integer, intent(out) :: istatus
2371 character (len=128), intent(in) :: fieldnm
2372 character (len=128), intent(out) :: dfdx_name
2374 ! Local variables
2375 integer :: idx
2377 istatus = 1
2379 do idx=1,num_entries
2380 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2381 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2383 if (is_dfdx(idx)) then
2384 dfdx_name = source_dfdx(idx)
2385 istatus = 0
2386 exit
2387 end if
2389 end if
2390 end do
2392 end subroutine get_dfdx_name
2395 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2396 ! Name: get_dfdy_name
2397 !
2398 ! Purpose:
2399 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2400 subroutine get_dfdy_name(fieldnm, dfdy_name, istatus)
2402 implicit none
2404 ! Arguments
2405 integer, intent(out) :: istatus
2406 character (len=128), intent(in) :: fieldnm
2407 character (len=128), intent(out) :: dfdy_name
2409 ! Local variables
2410 integer :: idx
2412 istatus = 1
2414 do idx=1,num_entries
2415 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2416 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2418 if (is_dfdy(idx)) then
2419 dfdy_name = source_dfdy(idx)
2420 istatus = 0
2421 exit
2422 end if
2424 end if
2425 end do
2427 end subroutine get_dfdy_name
2430 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2431 ! Name: get_z_dim_name
2432 !
2433 ! Purpose:
2434 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2435 subroutine get_z_dim_name(fieldnm, z_dim, istatus)
2437 implicit none
2439 ! Arguments
2440 integer, intent(out) :: istatus
2441 character (len=128), intent(in) :: fieldnm
2442 character (len=128), intent(out) :: z_dim
2444 ! Local variables
2445 integer :: idx
2447 istatus = 1
2449 do idx=1,num_entries
2450 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2451 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2452 if (is_z_dim_name(idx)) then
2453 z_dim = source_z_dim_name(idx)
2454 istatus = 0
2455 exit
2456 end if
2457 end if
2458 end do
2460 end subroutine get_z_dim_name
2463 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2464 ! Name: get_field_scale_factor
2465 !
2466 ! Purpose:
2467 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2468 subroutine get_field_scale_factor(fieldnm, ilevel, scale_factor, istatus)
2470 implicit none
2472 ! Arguments
2473 integer, intent(in) :: ilevel
2474 integer, intent(out) :: istatus
2475 real, intent(out) :: scale_factor
2476 character (len=128), intent(in) :: fieldnm
2478 ! Local variables
2479 integer :: idx
2481 istatus = 1
2483 do idx=1,num_entries
2484 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2485 (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) .and. &
2486 (ilevel == source_priority(idx))) then
2488 if (is_scale_factor(idx)) then
2489 scale_factor = source_scale_factor(idx)
2490 istatus = 0
2491 end if
2493 end if
2494 end do
2496 end subroutine get_field_scale_factor
2499 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2500 ! Name: get_output_stagger
2501 !
2502 ! Pupose:
2503 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2504 subroutine get_output_stagger(fieldnm, istagger, istatus)
2506 use gridinfo_module
2508 implicit none
2510 ! Arguments
2511 integer, intent(out) :: istatus, istagger
2512 character (len=128), intent(in) :: fieldnm
2514 ! Local variables
2515 integer :: idx
2517 istatus = 1
2518 do idx=1,num_entries
2519 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2520 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2522 if (is_output_stagger(idx)) then
2523 istatus = 0
2524 istagger = source_output_stagger(idx)
2525 exit
2526 else
2527 if (gridtype == 'C') then
2528 istatus = 0
2529 istagger = M
2530 exit
2531 else if (gridtype == 'E') then
2532 istatus = 0
2533 istagger = HH
2534 exit
2535 end if
2536 end if
2538 end if
2539 end do
2541 end subroutine get_output_stagger
2544 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2545 ! Name: get_subgrid_dim_name
2546 !
2547 ! Pupose:
2548 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2549 subroutine get_subgrid_dim_name(nest_num, field_name, dimnames, &
2550 sub_x, sub_y, is_subgrid_var, istatus)
2552 use gridinfo_module
2554 implicit none
2555 integer, intent(in) :: nest_num
2556 integer, intent(out) :: sub_x, sub_y, istatus
2557 logical, intent(out) :: is_subgrid_var
2558 character(len=128), intent(in) :: field_name
2559 character(len=128), dimension(2), intent(inout) :: dimnames
2560 integer :: idx, nlen
2562 sub_x = 1
2563 sub_y = 1
2564 is_subgrid_var = .false.
2566 istatus = 0
2567 do idx=1,num_entries
2568 if ((index(source_fieldname(idx),trim(field_name)) /= 0) .and. &
2569 (len_trim(source_fieldname(idx)) == len_trim(field_name))) then
2570 if (is_subgrid(idx)) then
2571 istatus = 0
2572 if (is_output_stagger(idx)) then
2573 call mprintf(.true.,ERROR,'Cannot use subgrids on variables with staggered grids')
2574 end if
2575 dimnames(1) = trim(dimnames(1))//"_subgrid"
2576 dimnames(2) = trim(dimnames(2))//"_subgrid"
2577 sub_x = subgrid_ratio_x(nest_num)
2578 sub_y = subgrid_ratio_y(nest_num)
2579 is_subgrid_var = .true.
2580 end if
2581 end if
2582 end do
2584 end subroutine get_subgrid_dim_name
2587 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2588 ! Name: get_output_flag
2589 !
2590 ! Purpose:
2591 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2592 subroutine get_output_flag(fieldnm, output_flag, istatus)
2594 implicit none
2596 ! Arguments
2597 integer, intent(out) :: istatus
2598 character (len=*), intent(in) :: fieldnm
2599 character (len=128), intent(out) :: output_flag
2601 ! Local variables
2602 integer :: idx
2604 istatus = 1
2606 do idx=1,num_entries
2607 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2608 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2610 if (is_output_flag(idx)) then
2611 output_flag = source_output_flag(idx)
2612 istatus = 0
2613 exit
2614 end if
2616 end if
2617 end do
2619 end subroutine get_output_flag
2622 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2623 ! Name: get_interp_option
2624 !
2625 ! Pupose:
2626 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2627 subroutine get_interp_option(fieldnm, ilevel, interp_opt, istatus)
2629 implicit none
2631 ! Arguments
2632 integer, intent(in) :: ilevel
2633 integer, intent(out) :: istatus
2634 character (len=128), intent(in) :: fieldnm
2635 character (len=128), intent(out) :: interp_opt
2637 ! Local variables
2638 integer :: idx
2640 istatus = 1
2641 do idx=1,num_entries
2642 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2643 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2644 if (ilevel == source_priority(idx)) then
2646 interp_opt = source_interp_string(idx)
2647 istatus = 0
2648 exit
2650 end if
2651 end if
2652 end do
2654 end subroutine get_interp_option
2657 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2658 ! Name: get_gcel_threshold
2659 !
2660 ! Pupose:
2661 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2662 subroutine get_gcell_threshold(interp_opt, threshold, istatus)
2664 implicit none
2666 ! Arguments
2667 integer, intent(out) :: istatus
2668 real, intent(out) :: threshold
2669 character (len=128), intent(in) :: interp_opt
2671 ! Local variables
2672 integer :: i, p1, p2
2674 istatus = 1
2675 threshold = 1.0
2677 i = index(interp_opt,'average_gcell')
2678 if (i /= 0) then
2679 ! Move the "average_gcell" option to the beginning
2680 ! if (i /= 1) then
2681 ! p1 =
2682 ! end if
2684 ! Check for a threshold
2685 p1 = index(interp_opt(i:128),'(')
2686 p2 = index(interp_opt(i:128),')')
2687 if (p1 /= 0 .and. p2 /= 0) then
2688 read(interp_opt(p1+1:p2-1),*,err=1000) threshold
2689 else
2690 call mprintf(.true., WARN, 'Problem with specified threshold '// &
2691 'for average_gcell interp option. Setting threshold to 0.0.')
2692 threshold = 0.0
2693 end if
2694 end if
2695 istatus = 0
2697 return
2699 1000 call mprintf(.true., ERROR, 'Threshold option to average_gcell interpolator '// &
2700 'must be a real number, enclosed in parentheses immediately '// &
2701 'after keyword "average_gcell"')
2703 end subroutine get_gcell_threshold
2706 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2707 ! Name: get_smooth_option
2708 !
2709 ! Pupose:
2710 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2711 subroutine get_smooth_option(fieldnm, smooth_opt, smooth_passes, istatus)
2713 implicit none
2715 ! Arguments
2716 integer, intent(out) :: istatus, smooth_opt, smooth_passes
2717 character (len=128), intent(in) :: fieldnm
2719 ! Local variables
2720 integer :: idx
2722 istatus = 1
2724 do idx=1,num_entries
2725 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2726 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2728 if (is_smooth_option(idx)) then
2729 istatus = 0
2730 smooth_opt = source_smooth_option(idx)
2732 if (is_smooth_passes(idx)) then
2733 smooth_passes = source_smooth_passes(idx)
2734 else
2735 smooth_passes = 1
2736 end if
2738 exit
2739 end if
2741 end if
2742 end do
2744 end subroutine get_smooth_option
2747 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2748 ! Name: iget_fieldtype
2749 !
2750 ! Purpose:
2751 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2752 function iget_fieldtype(fieldnm, istatus)
2754 implicit none
2756 ! Arguments
2757 integer, intent(out) :: istatus
2758 character (len=128), intent(in) :: fieldnm
2760 ! Local variables
2761 integer :: idx
2763 ! Return value
2764 integer :: iget_fieldtype
2766 istatus = 1
2768 do idx=1,num_entries
2769 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2770 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2772 if (is_dest_fieldtype(idx)) then
2773 iget_fieldtype = source_dest_fieldtype(idx)
2774 istatus = 0
2775 exit
2776 end if
2778 end if
2779 end do
2781 end function iget_fieldtype
2784 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2785 ! Name: iget_source_fieldtype
2786 !
2787 ! Purpose: Given a resolution, in degrees, and the name of a field, this
2788 ! function returns the type (categorical, continuous, etc.) of the source
2789 ! data that will be used. This may, in general, depend on the field name
2790 ! and the resolution; for example, near 30 second resolution, land use data
2791 ! may come from a categorical field, whereas for lower resolutions, it may
2792 ! come from arrays of land use fractions for each category.
2793 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2794 function iget_source_fieldtype(fieldnm, ilevel, istatus)
2796 implicit none
2798 ! Arguments
2799 integer, intent(in) :: ilevel
2800 integer, intent(out) :: istatus
2801 character (len=128), intent(in) :: fieldnm
2803 ! Return value
2804 integer :: iget_source_fieldtype
2806 ! Local variables
2807 integer :: idx
2809 ! Find information about the source tiles for the specified fieldname
2810 istatus = 1
2811 do idx=1,num_entries
2812 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2813 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2814 if (ilevel == source_priority(idx)) then
2815 istatus = 0
2816 iget_source_fieldtype = source_fieldtype(idx)
2817 exit
2818 end if
2819 end if
2820 end do
2822 end function iget_source_fieldtype
2825 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2826 ! Name: get_data_tile
2827 !
2828 ! Purpose:
2829 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2830 subroutine get_data_tile(xlat, xlon, ilevel, field_name, &
2831 file_name, array, start_x_dim, end_x_dim, start_y_dim, &
2832 end_y_dim, start_z_dim, end_z_dim, npts_bdr, &
2833 istatus)
2835 implicit none
2837 ! Arguments
2838 integer, intent(in) :: ilevel
2839 integer, intent(out) :: istatus
2840 integer, intent(out) :: start_x_dim, end_x_dim, &
2841 start_y_dim, end_y_dim, &
2842 start_z_dim, end_z_dim, &
2843 npts_bdr
2844 real, intent(in) :: xlat, xlon ! Location that tile should contain
2845 real, pointer, dimension(:,:,:) :: array ! The array to be allocated by this routine
2846 character (len=128), intent(in) :: field_name
2847 character (len=256), intent(out) :: file_name
2849 ! Local variables
2850 integer :: j, k
2851 integer :: local_wordsize, local_endian, sign_convention, irow_order, strlen
2852 integer :: xdim,ydim,zdim
2853 real :: scalefac
2854 real, allocatable, dimension(:) :: temprow
2856 call get_tile_fname(file_name, xlat, xlon, ilevel, field_name, istatus)
2858 if (index(file_name, 'OUTSIDE') /= 0) then
2859 istatus = 1
2860 return
2861 else if (hash_search(bad_files, file_name)) then
2862 istatus = 1
2863 return
2864 end if
2866 call get_tile_dimensions(xlat, xlon, start_x_dim, end_x_dim, start_y_dim, end_y_dim, &
2867 start_z_dim, end_z_dim, npts_bdr, local_wordsize, local_endian, &
2868 sign_convention, ilevel, field_name, istatus)
2870 xdim = (end_x_dim-start_x_dim+1)
2871 ydim = (end_y_dim-start_y_dim+1)
2872 zdim = (end_z_dim-start_z_dim+1)
2874 if (associated(array)) deallocate(array)
2875 allocate(array(xdim,ydim,zdim))
2877 call get_row_order(field_name, ilevel, irow_order, istatus)
2878 if (istatus /= 0) irow_order = BOTTOM_TOP
2880 call s_len(file_name,strlen)
2882 scalefac = 1.0
2884 call read_geogrid(file_name, strlen, array, xdim, ydim, zdim, &
2885 sign_convention, local_endian, scalefac, local_wordsize, istatus)
2887 if (irow_order == TOP_BOTTOM) then
2888 allocate(temprow(xdim))
2889 do k=1,zdim
2890 do j=1,ydim
2891 if (ydim-j+1 <= j) exit
2892 temprow(1:xdim) = array(1:xdim,j,k)
2893 array(1:xdim,j,k) = array(1:xdim,ydim-j+1,k)
2894 array(1:xdim,ydim-j+1,k) = temprow(1:xdim)
2895 end do
2896 end do
2897 deallocate(temprow)
2898 end if
2900 if (istatus /= 0) then
2901 start_x_dim = INVALID
2902 start_y_dim = INVALID
2903 end_x_dim = INVALID
2904 end_y_dim = INVALID
2906 call hash_insert(bad_files, file_name)
2907 end if
2909 end subroutine get_data_tile
2912 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2913 ! Name: get_row_order
2914 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2915 subroutine get_row_order(fieldnm, ilevel, irow_order, istatus)
2917 implicit none
2919 ! Arguments
2920 integer, intent(in) :: ilevel
2921 character (len=128), intent(in) :: fieldnm
2922 integer, intent(out) :: irow_order, istatus
2924 ! Local variables
2925 integer :: idx
2927 istatus = 1
2928 do idx=1,num_entries
2929 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2930 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2931 if (ilevel == source_priority(idx)) then
2932 if (is_row_order(idx)) then
2933 irow_order = source_row_order(idx)
2934 istatus = 0
2935 exit
2936 end if
2937 end if
2938 end if
2939 end do
2941 end subroutine get_row_order
2944 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2945 ! Name: get_tile_dimensions
2946 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2947 subroutine get_tile_dimensions(xlat, xlon, start_x_dim, end_x_dim, start_y_dim, end_y_dim, &
2948 start_z_dim, end_z_dim, npts_bdr, bytes_per_datum, endianness, &
2949 sign_convention, ilevel, fieldnm, istatus)
2951 use llxy_module
2953 implicit none
2955 ! Arguments
2956 integer, intent(in) :: ilevel
2957 integer, intent(out) :: start_x_dim, end_x_dim, &
2958 start_y_dim, end_y_dim, &
2959 start_z_dim, end_z_dim, &
2960 npts_bdr, &
2961 bytes_per_datum, endianness, &
2962 sign_convention, istatus
2963 real, intent(in) :: xlat, xlon
2964 character (len=128), intent(in) :: fieldnm
2966 ! Local variables
2967 integer :: idx, current_domain
2968 real :: rx, ry
2970 istatus = 1
2971 do idx=1,num_entries
2972 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
2973 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
2974 if (ilevel == source_priority(idx)) then
2975 istatus = 0
2976 exit
2977 end if
2978 end if
2979 end do
2981 if (istatus /= 0) then
2982 start_x_dim = 1
2983 start_y_dim = 1
2984 start_z_dim = 1
2985 end_x_dim = 1
2986 end_y_dim = 1
2987 end_z_dim = 1
2988 bytes_per_datum = 0
2989 return
2990 end if
2992 current_domain = iget_selected_domain()
2993 call select_domain(SOURCE_PROJ)
2994 call lltoxy(xlat, xlon, rx, ry, M)
2995 call select_domain(current_domain)
2997 start_x_dim = source_tile_x(idx) * nint(real(floor((rx-0.5) / real(source_tile_x(idx))))) + 1
2998 end_x_dim = start_x_dim + source_tile_x(idx) - 1
3000 start_y_dim = source_tile_y(idx) * nint(real(floor((ry-0.5) / real(source_tile_y(idx))))) + 1
3001 end_y_dim = start_y_dim + source_tile_y(idx) - 1
3003 if (is_tile_z_start(idx) .and. is_tile_z_end(idx)) then
3004 start_z_dim = source_tile_z_start(idx)
3005 end_z_dim = source_tile_z_end(idx)
3006 else if (is_tile_z(idx)) then
3007 start_z_dim = 1
3008 end_z_dim = source_tile_z(idx)
3009 end if
3011 if (.not. (is_tile_z_start(idx) .and. is_tile_z_end(idx))) then
3012 if (is_tile_z_start(idx) .or. is_tile_z_end(idx)) then
3013 call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of tile_z_start and '// &
3014 'tile_z_end specified for entry %i.',i1=idx)
3015 end if
3016 end if
3018 if (is_tile_bdr(idx)) then
3019 npts_bdr = source_tile_bdr(idx)
3020 else
3021 npts_bdr = 0
3022 end if
3024 start_x_dim = start_x_dim - npts_bdr
3025 end_x_dim = end_x_dim + npts_bdr
3026 start_y_dim = start_y_dim - npts_bdr
3027 end_y_dim = end_y_dim + npts_bdr
3029 if (is_wordsize(idx)) then
3030 bytes_per_datum = source_wordsize(idx)
3031 else
3032 bytes_per_datum = 1
3033 call mprintf(.true.,ERROR,'In GEOGRID.TBL, no wordsize specified for data in entry %i.',i1=idx)
3034 end if
3036 if (is_endian(idx)) then
3037 endianness = source_endian(idx)
3038 else
3039 endianness = BIG_ENDIAN
3040 end if
3042 if (is_signed(idx)) then
3043 sign_convention = 1
3044 else
3045 sign_convention = 0
3046 end if
3048 end subroutine get_tile_dimensions
3051 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3052 ! Name: get_tile_fname
3053 !
3054 ! Purpose:
3055 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3056 subroutine get_tile_fname(test_fname, xlat, xlon, ilevel, fieldname, istatus)
3058 use llxy_module
3059 use gridinfo_module
3061 implicit none
3063 ! Arguments
3064 integer, intent(in) :: ilevel
3065 integer, intent(out) :: istatus
3066 real, intent(in) :: xlat, xlon
3067 character (len=*), intent(in) :: fieldname
3068 character (len=256), intent(out) :: test_fname
3070 ! Local variables
3071 integer :: current_domain, idx
3072 real :: rx, ry
3074 istatus = 1
3075 write(test_fname, '(a)') 'TILE.OUTSIDE.DOMAIN'
3077 do idx=1,num_entries
3078 if ((index(source_fieldname(idx),trim(fieldname)) /= 0) .and. &
3079 (len_trim(source_fieldname(idx)) == len_trim(fieldname))) then
3080 if (ilevel == source_priority(idx)) then
3081 istatus = 0
3082 exit
3083 end if
3084 end if
3085 end do
3087 if (istatus /= 0) return
3089 current_domain = iget_selected_domain()
3090 call select_domain(SOURCE_PROJ)
3091 call lltoxy(xlat, xlon, rx, ry, M)
3092 call select_domain(current_domain)
3094 ! rx = real(source_tile_x(idx)) * real(floor((rx-0.5*source_dx(idx))/ real(source_tile_x(idx)))) + 1.0
3095 ! ry = real(source_tile_y(idx)) * real(floor((ry-0.5*source_dy(idx))/ real(source_tile_y(idx)))) + 1.0
3096 rx = real(source_tile_x(idx)) * real(floor((rx-0.5) / real(source_tile_x(idx)))) + 1.0
3097 ry = real(source_tile_y(idx)) * real(floor((ry-0.5) / real(source_tile_y(idx)))) + 1.0
3099 if (rx > 0. .and. ry > 0.) then
3100 select case(source_filename_digits(idx))
3101 case (5)
3102 write(test_fname, '(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(source_path(idx)), &
3103 nint(rx),'-',nint(rx)+source_tile_x(idx)-1,'.',nint(ry),'-',nint(ry)+source_tile_y(idx)-1
3104 case (6)
3105 write(test_fname, '(a,i6.6,a1,i6.6,a1,i6.6,a1,i6.6)') trim(source_path(idx)), &
3106 nint(rx),'-',nint(rx)+source_tile_x(idx)-1,'.',nint(ry),'-',nint(ry)+source_tile_y(idx)-1
3107 case default
3108 call mprintf(.true., ERROR, 'In GEOGRID.TBL, for index file of data at '// &
3109 'entry %i, filename_digits must be either 5 or 6.', i1=idx)
3110 istatus = 1
3111 return
3112 end select
3113 end if
3115 end subroutine get_tile_fname
3118 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3119 ! Name: get_source_resolution
3120 !
3121 ! Purpose:
3122 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3123 subroutine get_source_resolution(fieldnm, ilevel, src_dx, src_dy, istatus)
3125 implicit none
3127 ! Arguments
3128 integer, intent(in) :: ilevel
3129 integer, intent(out) :: istatus
3130 real, intent(out) :: src_dx, src_dy
3131 character (len=*), intent(in) :: fieldnm
3133 ! Local variables
3134 integer :: idx
3136 istatus = 1
3137 do idx=1,num_entries
3138 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
3139 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
3140 if (ilevel == source_priority(idx)) then
3141 if (is_dx(idx) .and. is_dy(idx)) then
3142 src_dx = source_dx(idx)
3143 src_dy = source_dy(idx)
3144 if (source_proj(idx) /= PROJ_LATLON) then
3145 src_dx = src_dx / 111000.
3146 src_dy = src_dy / 111000.
3147 end if
3148 istatus = 0
3149 exit
3150 end if
3151 end if
3152 end if
3153 end do
3155 end subroutine get_source_resolution
3158 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3159 ! Name: check_priority_level
3160 !
3161 ! Purpose: Determines whether there exists the specified priority level for
3162 ! the specified field.
3163 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3164 subroutine check_priority_level(fieldnm, ilevel, istatus)
3166 implicit none
3168 ! Arguments
3169 character (len=*), intent(in) :: fieldnm
3170 integer, intent(in) :: ilevel
3171 integer, intent(out) :: istatus
3173 ! Local variables
3174 integer :: idx
3176 istatus = 1
3177 do idx=1,num_entries
3178 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
3179 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
3180 if (ilevel == source_priority(idx)) then
3181 istatus = 0
3182 end if
3183 end if
3184 end do
3186 end subroutine check_priority_level
3189 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3190 ! Name: get_data_projection
3191 !
3192 ! Purpose: To acquire the parameters necessary in defining the grid on which
3193 ! the user-specified data for field 'fieldnm' are given.
3194 !
3195 ! NOTES: If the routine successfully acquires values for all necessary
3196 ! parameters, istatus is set to 0. In case of an error,
3197 ! OR IF THE USER HAS NOT SPECIFIED A TILE OF DATA FOR FIELDNM,
3198 ! istatus is set to 1.
3199 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3200 subroutine get_data_projection(fieldnm, iproj, stand_lon, truelat1, truelat2, &
3201 dxkm, dykm, known_x, known_y, known_lat, known_lon, ilevel, istatus)
3203 implicit none
3205 ! Arguments
3206 integer, intent(in) :: ilevel
3207 integer, intent(out) :: iproj, istatus
3208 real, intent(out) :: stand_lon, truelat1, truelat2, dxkm, dykm, &
3209 known_x, known_y, known_lat, known_lon
3210 character (len=*), intent(in) :: fieldnm
3212 ! Local variables
3213 integer :: idx
3215 istatus = 1
3216 do idx=1,num_entries
3217 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
3218 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
3219 if (ilevel == source_priority(idx)) then
3220 istatus = 0
3221 if (is_proj(idx)) then
3222 iproj = source_proj(idx)
3223 else
3224 iproj = 1
3225 call mprintf(.true., ERROR, &
3226 'In GEOGRID.TBL, no specification for projection in entry %i.',i1=idx)
3227 end if
3228 if (is_known_x(idx)) then
3229 known_x = source_known_x(idx)
3230 else
3231 known_x = 1.
3232 call mprintf(.true., ERROR, &
3233 'In GEOGRID.TBL, no specification for known_x in entry %i.',i1=idx)
3234 end if
3235 if (is_known_y(idx)) then
3236 known_y = source_known_y(idx)
3237 else
3238 known_y = 1.
3239 call mprintf(.true., ERROR, &
3240 'In GEOGRID.TBL, no specification for known_y in entry %i.',i1=idx)
3241 end if
3242 if (is_known_lat(idx)) then
3243 known_lat = source_known_lat(idx)
3244 else
3245 known_lat = 1.
3246 call mprintf(.true., ERROR, &
3247 'In GEOGRID.TBL, no specification for known_lat in entry %i.',i1=idx)
3248 end if
3249 if (is_known_lon(idx)) then
3250 known_lon = source_known_lon(idx)
3251 else
3252 known_lon = 1.
3253 call mprintf(.true., ERROR, &
3254 'In GEOGRID.TBL, no specification for known_lon in entry %i.',i1=idx)
3255 end if
3256 if (is_truelat1(idx)) then
3257 truelat1 = source_truelat1(idx)
3258 else if (is_proj(idx) .and. source_proj(idx) /= PROJ_LATLON) then
3259 truelat1 = 1.
3260 call mprintf(.true., WARN, &
3261 'In GEOGRID.TBL, no specification for truelat1 in entry %i.',i1=idx)
3262 end if
3263 if (is_truelat2(idx)) then
3264 truelat2 = source_truelat2(idx)
3265 else if (is_proj(idx) .and. source_proj(idx) /= PROJ_LATLON) then
3266 truelat2 = 1.
3267 call mprintf(.true., WARN, &
3268 'In GEOGRID.TBL, no specification for truelat2 in entry %i.',i1=idx)
3269 end if
3270 if (is_stdlon(idx)) then
3271 stand_lon = source_stdlon(idx)
3272 else if (is_proj(idx) .and. source_proj(idx) /= PROJ_LATLON) then
3273 stand_lon = 1.
3274 call mprintf(.true., WARN, &
3275 'In GEOGRID.TBL, no specification for stdlon in entry %i.',i1=idx)
3276 end if
3277 if (is_dx(idx)) then
3278 dxkm = source_dx(idx)
3279 else
3280 dxkm = 1.
3281 call mprintf(.true., ERROR, &
3282 'In GEOGRID.TBL, no specification for dx in entry %i.',i1=idx)
3283 end if
3284 if (is_dy(idx)) then
3285 dykm = source_dy(idx)
3286 else
3287 dykm = 1.
3288 call mprintf(.true., ERROR, &
3289 'In GEOGRID.TBL, no specification for dy in entry %i.',i1=idx)
3290 end if
3291 exit
3292 end if
3293 end if
3294 end do
3296 end subroutine get_data_projection
3299 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3300 ! Name: get_source_opt_status
3301 !
3302 ! Purpose: Determines whether a field is optional and can be skipped
3303 !
3304 ! If ilevel is specified as 0, the return value, istatus, will be 0 if
3305 ! any priority level is available for the field, and 1 otherwise. Otherwise,
3306 ! istatus will be set to 0 only if the specified priority level for
3307 ! the field is available.
3308 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3309 subroutine get_source_opt_status(fieldnm, ilevel, istatus)
3311 implicit none
3313 ! Arguments
3314 character (len=*), intent(in) :: fieldnm
3315 integer, intent(in) :: ilevel
3316 integer, intent(out) :: istatus
3318 ! Local variables
3319 integer :: idx
3322 ! Any priority level is available
3323 if (ilevel == 0) then
3324 istatus = 1
3325 do idx=1,num_entries
3326 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
3327 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
3328 if (.not. is_not_found(idx)) then
3329 istatus = 0
3330 exit
3331 end if
3332 end if
3333 end do
3335 ! Only the specified level is to be checked
3336 else
3337 istatus = 0
3338 do idx=1,num_entries
3339 if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. &
3340 (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then
3341 if (ilevel == source_priority(idx)) then
3342 if (is_not_found(idx)) then
3343 istatus = 1
3344 exit
3345 end if
3346 end if
3347 end if
3348 end do
3349 end if
3351 end subroutine get_source_opt_status
3354 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3355 ! Name: check_data_specification
3356 !
3357 ! Purpose: To check for obvious errors in the user source data specifications.
3358 ! Returns .true. if specification passes all checks, and .false. otherwise.
3359 ! For failing checks, diagnostic messages are printed.
3360 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3361 function check_data_specification( )
3363 implicit none
3365 ! Return value
3366 logical :: check_data_specification
3368 ! Local variables
3369 integer :: i, j, istatus
3370 integer, pointer, dimension(:) :: priorities
3371 real :: rmissing
3372 logical :: begin_priority, halt
3373 character (len=128) :: cur_name
3375 check_data_specification = .false.
3377 ! Check that each specification has a name, priority level, and path
3378 do i=1,num_entries
3379 if (.not. is_fieldname(i)) then
3380 call mprintf(.true., ERROR, &
3381 'In GEOGRID.TBL, specification %i does not have a name.',i1=i)
3382 end if
3383 if (.not. is_priority(i)) then
3384 call mprintf(.true., ERROR, &
3385 'In GEOGRID.TBL, specification %i does not have a priority.',i1=i)
3386 end if
3387 if (list_length(source_res_path(i)) == 0) then
3388 call mprintf(.true., ERROR, &
3389 'In GEOGRID.TBL, no path (relative or absolute) is specified '// &
3390 'for entry %i.',i1=i)
3391 end if
3392 end do
3394 ! The fill_missing and halt_on_missing options are mutually exclusive
3395 do i=1,num_entries
3396 call get_halt_on_missing(source_fieldname(i), halt, istatus)
3397 call get_missing_fill_value(source_fieldname(i), rmissing, istatus)
3398 if (halt .and. (istatus == 0)) then
3399 call mprintf(.true., ERROR, 'In GEOGRID.TBL, the halt_on_missing and fill_missing '// &
3400 'options are mutually exclusive, but both are given for field %s', &
3401 s1=trim(source_fieldname(i)))
3402 end if
3403 end do
3405 ! Check that the field from which landmask is calculated is not output on a staggering
3406 do i=1,num_entries
3407 if (list_length(source_landmask_land(i)) > 0 .or. list_length(source_landmask_water(i)) > 0) then
3408 if (is_output_stagger(i)) then
3409 if (source_output_stagger(i) /= M) then
3410 call mprintf(.true., ERROR, 'In GEOGRID.TBL, landmask cannot be derived from '// &
3411 'a field that is computed on a staggered grid at entry %i.',i1=i)
3412 end if
3413 end if
3414 end if
3415 end do
3417 ! Also check that any field that is to be masked by the landmask is not output on a staggering
3418 do i=1,num_entries
3419 if (is_masked(i) .and. is_output_stagger(i)) then
3420 if (source_output_stagger(i) /= M) then
3421 call mprintf(.true., ERROR, 'In GEOGRID.TBL, landmask cannot be used with '// &
3422 'a field that is computed on a staggered grid at entry %i.',i1=i)
3423 end if
3424 end if
3425 end do
3427 allocate(priorities(num_entries))
3429 ! Now check that priorities for each source are unique and in the interval [1,n], n <= num_entries
3430 do i=1,num_entries
3431 priorities = 0
3432 cur_name = source_fieldname(i)
3433 do j=1,num_entries
3434 if (source_fieldname(j) == cur_name) then
3436 if (source_priority(j) > num_entries .or. source_priority(j) < 1) then
3437 call mprintf(.true., ERROR, 'In GEOGRID.TBL, priorities for %s do not '// &
3438 'form a sequence 1,2,...,n.', s1=trim(cur_name))
3440 else
3441 if (priorities(source_priority(j)) == 1) then
3442 call mprintf(.true., ERROR, 'In GEOGRID.TBL, more than one entry for %s '// &
3443 'has priority %i.', s1=trim(cur_name), i1=source_priority(j))
3445 else
3446 priorities(source_priority(j)) = 1
3447 end if
3448 end if
3450 end if
3451 end do
3453 begin_priority = .false.
3454 do j=num_entries,1,-1
3455 if (.not.begin_priority .and. priorities(j) == 1) then
3456 begin_priority = .true.
3457 else if (begin_priority .and. priorities(j) == 0) then
3458 call mprintf(.true., ERROR, 'In GEOGRID.TBL, no entry for %s has '// &
3459 'priority %i, but an entry has priority %i.', &
3460 s1=trim(cur_name), i1=j, i2=j+1)
3461 end if
3462 end do
3463 end do
3465 deallocate(priorities)
3467 ! Units must match for all priority levels of a field
3468 do i=1,num_entries
3469 if (source_priority(i) == 1) then
3470 do j=1,num_entries
3471 if ((source_fieldname(i) == source_fieldname(j)) .and. &
3472 (source_units(i) /= source_units(j))) then
3473 call mprintf(.true., ERROR, 'In GEOGRID.TBL, units for %s at entry %i '// &
3474 'do not match units at entry %i (%s)', &
3475 s1=trim(source_fieldname(i)), i1=j, i2=i, s2=trim(source_units(i)))
3476 end if
3477 end do
3478 end if
3479 end do
3481 ! Make sure that user has not asked to calculate landmask from a continuous field
3482 do i=1,num_entries
3483 if (is_dest_fieldtype(i)) then
3484 if (source_dest_fieldtype(i) == CONTINUOUS) then
3485 if (list_length(source_landmask_water(i)) > 0 .or. list_length(source_landmask_land(i)) > 0) then
3486 call mprintf(.true., ERROR, 'In GEOGRID.TBL, landmask cannot be '// &
3487 'calculated from a continuous destination field at entry %i.',i1=i)
3488 end if
3489 end if
3490 end if
3491 end do
3493 ! If either min_category or max_category is specified, then both must be specified
3494 do i=1,num_entries
3495 if (is_category_min(i) .or. is_category_max(i)) then
3496 if (.not. is_category_min(i)) then
3497 call mprintf(.true., ERROR, 'In GEOGRID.TBL, for index file of data at '// &
3498 'entry %i, category_max is specified, but category_min is '// &
3499 'not. Both must be specified.',i1=i)
3500 else if (.not. is_category_max(i)) then
3501 call mprintf(.true., ERROR, 'In GEOGRID.TBL, for index file of data at '// &
3502 'entry %i, category_min is specified, but category_max is '// &
3503 'not. Both must be specified.',i1=i)
3504 end if
3505 end if
3506 end do
3508 ! For continuous data, (category_max - category_min + 1) should equal tile_z
3509 do i=1,num_entries
3510 if (is_fieldtype(i)) then
3511 if (source_fieldtype(i) == CONTINUOUS) then
3512 if (is_category_max(i) .and. is_category_min(i) .and. is_tile_z(i)) then
3513 if (source_tile_z(i) /= (source_category_max(i) - source_category_min(i) + 1)) then
3514 call mprintf(.true., ERROR, 'In GEOGRID.TBL, tile_z must equal '// &
3515 '(category_max - category_min + 1) at entry %i.',i1=i)
3516 end if
3517 else if (is_category_max(i) .and. is_category_min(i) .and. &
3518 is_tile_z_start(i) .and. is_tile_z_end(i)) then
3519 if (source_tile_z_end(i) /= source_category_max(i) .or. &
3520 source_tile_z_start(i) /= source_category_min(i)) then
3521 call mprintf(.true., ERROR, 'In GEOGRID.TBL, tile_z_end must equal '// &
3522 'category_max, and tile_z_start must equal category_min '// &
3523 'at entry %i.',i1=i)
3524 end if
3525 end if
3526 end if
3527 end if
3528 end do
3530 ! Make sure that user has not named a dominant category or computed slope field
3531 ! the same as a fractional field
3532 do i=1,num_entries
3533 if (source_dominant_category(i) == source_fieldname(i)) then
3534 call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant category cannot have '// &
3535 'the same name as the field at entry %i.',i1=i)
3536 end if
3538 do j=1,num_entries
3539 if (.not. is_dominant_only(i)) then
3540 if (is_dfdx(j)) then
3541 if (source_dfdx(j) == source_fieldname(i)) then
3542 call mprintf(.true., ERROR, 'In GEOGRID.TBL, field name at entry %i '// &
3543 'cannot have the same name as the slope field df_dx at entry %i.', &
3544 i1=i, i2=j)
3545 end if
3546 end if
3547 if (is_dfdy(j)) then
3548 if (source_dfdy(j) == source_fieldname(i)) then
3549 call mprintf(.true., ERROR, 'In GEOGRID.TBL, field name at entry %i '// &
3550 'cannot have the same name as the slope field df_dy at entry %i.', &
3551 i1=i, i2=j)
3552 end if
3553 end if
3554 if (is_dfdx(j) .and. is_dominant_category(i)) then
3555 if (source_dfdx(j) == source_dominant_category(i)) then
3556 call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant field name at '// &
3557 'entry %i cannot have the same name as the slope field df_dx '// &
3558 'at entry %i.',i1=i, i2=j)
3559 end if
3560 end if
3561 if (is_dfdy(j) .and. is_dominant_category(i)) then
3562 if (source_dfdy(j) == source_dominant_category(i)) then
3563 call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant field name at '// &
3564 'entry %i cannot have the same name as the slope field '// &
3565 'df_dy at entry %i.',i1=i, i2=j)
3566 end if
3567 end if
3568 else
3569 if (is_dfdx(j)) then
3570 if (source_dfdx(j) == source_dominant_only(i)) then
3571 call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant field name at '// &
3572 'entry %i cannot have the same name as the slope field '// &
3573 'df_dx at entry %i.',i1=i, i2=j)
3574 end if
3575 end if
3576 if (is_dfdy(j)) then
3577 if (source_dfdy(j) == source_dominant_only(i)) then
3578 call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant field name at '// &
3579 'entry %i cannot have the same name as the slope field '// &
3580 'df_dy at entry %i.',i1=i, i2=j)
3581 end if
3582 end if
3583 end if
3584 if (i /= j) then
3585 if (is_dfdx(i)) then
3586 if (is_dfdx(j)) then
3587 if (source_dfdx(j) == source_dfdx(i)) then
3588 call mprintf(.true., ERROR, 'In GEOGRID.TBL, slope field df_dx at '// &
3589 'entry %i cannot have the same name as the slope '// &
3590 'field df_dx at entry %i.',i1=i, i2=j)
3591 end if
3592 end if
3593 if (is_dfdy(j)) then
3594 if (source_dfdy(j) == source_dfdx(i)) then
3595 call mprintf(.true., ERROR, 'In GEOGRID.TBL, slope field df_dx at '// &
3596 'entry %i cannot have the same name as the slope field '// &
3597 'df_dy at entry %i.',i1=i, i2=j)
3598 end if
3599 end if
3600 end if
3601 if (is_dfdy(i)) then
3602 if (is_dfdx(j)) then
3603 if (source_dfdx(j) == source_dfdy(i)) then
3604 call mprintf(.true., ERROR, 'In GEOGRID.TBL, slope field df_dy at '// &
3605 'entry %i cannot have the same name as the slope field '// &
3606 'df_dx at entry %i.',i1=i, i2=j)
3607 end if
3608 end if
3609 if (is_dfdy(j)) then
3610 if (source_dfdy(j) == source_dfdy(i)) then
3611 call mprintf(.true., ERROR, 'In GEOGRID.TBL, slope field df_dy at '// &
3612 'entry %i cannot have the same name as the slope field '// &
3613 'df_dy at entry %i.',i1=i, i2=j)
3614 end if
3615 end if
3616 end if
3617 if (is_dominant_category(i)) then
3618 if (source_dominant_category(i) == source_fieldname(j)) then ! Possible exception
3619 if (.not. (is_dominant_only(j) .and. (source_dominant_category(i) /= source_dominant_only(j)))) then
3620 call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant category at '// &
3621 'entry %i cannot have the same name as the field at '// &
3622 'entry %i.',i1=i, i2=j)
3623 end if
3624 else if (is_dominant_category(j) .and. &
3625 (source_dominant_category(i) == source_dominant_category(j))) then
3626 call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant category at entry '// &
3627 '%i cannot have the same name as dominant category at '// &
3628 'entry %i.',i1=i, i2=j)
3629 else if (is_dominant_only(j) .and. &
3630 (source_dominant_category(i) == source_dominant_only(j))) then
3631 call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant category at '// &
3632 'entry %i cannot have the same name as dominant_only '// &
3633 'category at entry %i.',i1=i, i2=j)
3634 end if
3635 else if (is_dominant_only(i)) then
3636 if (source_dominant_only(i) == source_fieldname(j)) then ! Possible exception
3637 if (.not. (is_dominant_only(j) .and. (source_dominant_only(i) /= source_dominant_only(j)))) then
3638 call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant_only category '// &
3639 'at entry %i cannot have the same name as the field at '// &
3640 'entry %i.',i1=i, i2=j)
3641 end if
3642 else if (is_dominant_category(j) .and. &
3643 (source_dominant_only(i) == source_dominant_category(j))) then
3644 call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant_only category '// &
3645 'at entry %i cannot have the same name as dominant '// &
3646 'category at entry %i.',i1=i, i2=j)
3647 else if (is_dominant_only(j) .and. &
3648 (source_dominant_only(i) == source_dominant_only(j))) then
3649 call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant_only category '// &
3650 'at entry %i cannot have the same name as dominant_only '// &
3651 'category at entry %i.',i1=i, i2=j)
3652 end if
3653 end if
3654 end if
3655 end do
3656 end do
3658 check_data_specification = .true.
3660 end function check_data_specification
3663 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3664 ! Name: s_len
3665 !
3666 ! Purpose: This routine receives a fortran string, and returns the number of
3667 ! characters in the string before the first "space" is encountered. It
3668 ! considers ascii characters 33 to 126 to be valid characters, and ascii
3669 ! 0 to 32, and 127 to be "space" characters.
3670 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3671 subroutine s_len(string, s_length)
3673 implicit none
3675 ! Arguments
3676 character (len=*), intent(in) :: string
3677 integer, intent(out) :: s_length
3679 ! Local variables
3680 integer :: i, len_str, aval
3681 logical :: space
3683 space = .false.
3684 i = 1
3685 len_str = len(string)
3686 s_length = len_str
3687 do while ((i .le. len_str) .and. (.not. space))
3688 aval = ichar(string(i:i))
3689 if ((aval .lt. 33) .or. (aval .gt. 126)) then
3690 s_length = i - 1
3691 space = .true.
3692 endif
3693 i = i + 1
3694 enddo
3696 end subroutine s_len
3699 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3700 ! Name: display_optional_field_msgs
3701 !
3702 ! Purpose: This routine prints out information regarding any optional fields
3703 ! in the GEOGRID.TBL file that were not found at run-time and were
3704 ! skipped.
3705 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3706 subroutine display_optional_field_msgs()
3708 implicit none
3710 integer :: idx
3711 logical :: do_prints
3714 do_prints = .false.
3716 do idx=1,num_entries
3717 if (is_optional(idx) .and. is_not_found(idx)) then
3718 do_prints = .true.
3719 exit
3720 end if
3721 end do
3723 if (do_prints) then
3724 call mprintf(.true., STDOUT, ' ')
3725 call mprintf(.true., STDOUT, ' Optional fields not processed by geogrid:')
3726 call mprintf(.true., LOGFILE, 'Optional fields not processed by geogrid:')
3728 do idx=1,num_entries
3729 if (is_optional(idx) .and. is_not_found(idx)) then
3730 call mprintf(.true., STDOUT, ' %s (priority=%i, resolution=''%s'', path=''%s'')', s1=source_fieldname(idx), &
3731 i1=source_priority(idx), s2=source_res(idx), s3=source_path(idx))
3732 call mprintf(.true., LOGFILE, ' %s (priority=%i, resolution=''%s'', path=''%s'')', s1=source_fieldname(idx), &
3733 i1=source_priority(idx), s2=source_res(idx), s3=source_path(idx))
3734 end if
3735 end do
3737 call mprintf(.true., STDOUT, ' ')
3738 end if
3740 end subroutine display_optional_field_msgs
3742 end module source_data_module