source: trunk/MESOSCALE/LMD_MM_MARS/SRC/WPS/metgrid/src/interp_option_module.f90

Last change on this file was 11, checked in by aslmd, 14 years ago

spiga@svn-planeto:ajoute le modele meso-echelle martien
File size: 29.0 KB
Line 
1module interp_option_module
2
3   use gridinfo_module
4   use list_module
5   use misc_definitions_module
6   use module_debug
7
8   integer, parameter :: BUFSIZE=128
9
10   integer :: num_entries
11   integer, pointer, dimension(:) :: output_stagger
12   real, pointer, dimension(:) :: masked, fill_missing, missing_value, &
13                    interp_mask_val, interp_land_mask_val, interp_water_mask_val
14   logical, pointer, dimension(:) :: output_this_field, is_u_field, is_v_field, is_derived_field, is_mandatory
15   character (len=128), pointer, dimension(:) :: fieldname, interp_method, v_interp_method, &
16                    interp_mask, interp_land_mask, interp_water_mask, &
17                    flag_in_output, output_name, from_input, z_dim_name, level_template
18   type (list), pointer, dimension(:) :: fill_lev_list
19   type (list) :: flag_in_output_list
20
21   contains
22
23   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
24   ! Name: read_interp_table
25   !
26   ! Purpose:
27   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
28   subroutine read_interp_table()
29
30      ! Local variables
31      integer :: i, p1, p2, idx, eos, ispace, funit, istatus, nparams
32      logical :: is_used, have_specification
33      character (len=128) :: lev_string, fill_string, flag_string, flag_val
34      character (len=BUFSIZE) :: buffer
35   
36      do funit=10,100
37         inquire(unit=funit, opened=is_used)
38         if (.not. is_used) exit
39      end do
40   
41      nparams = 0
42      num_entries = 0
43   
44      open(funit, file=trim(opt_metgrid_tbl_path)//'METGRID.TBL', form='formatted', status='old', err=1001)
45      istatus = 0
46      do while (istatus == 0)
47         read(funit, '(a)', iostat=istatus) buffer
48         if (istatus == 0) then
49            call despace(buffer)
50   
51            ! Is this line a comment?
52            if (buffer(1:1) == '#') then
53   
54            ! Are we beginning a new field specification?
55            else if (index(buffer,'=====') /= 0) then
56               if (nparams > 0) num_entries = num_entries + 1
57               nparams = 0
58   
59            else
60               eos = index(buffer,'#')
61               if (eos /= 0) buffer(eos:BUFSIZE) = ' '
62   
63               ! Does this line contain at least one parameter specification?
64               if (index(buffer,'=') /= 0) then
65                  nparams = nparams + 1
66               end if
67            end if
68   
69         end if
70      end do
71   
72      rewind(funit)
73   
74      ! Allocate one extra array element to act as the default
75! BUG: Maybe this will not be necessary if we move to a module with query routines for
76!  parsing the METGRID.TBL
77      num_entries = num_entries + 1
78   
79      allocate(fieldname(num_entries))
80      allocate(interp_method(num_entries))
81      allocate(v_interp_method(num_entries))
82      allocate(masked(num_entries))
83      allocate(fill_missing(num_entries))
84      allocate(missing_value(num_entries))
85      allocate(fill_lev_list(num_entries))
86      allocate(interp_mask(num_entries))
87      allocate(interp_land_mask(num_entries))
88      allocate(interp_water_mask(num_entries))
89      allocate(interp_mask_val(num_entries))
90      allocate(interp_land_mask_val(num_entries))
91      allocate(interp_water_mask_val(num_entries))
92      allocate(level_template(num_entries))
93      allocate(flag_in_output(num_entries))
94      allocate(output_name(num_entries))
95      allocate(from_input(num_entries))
96      allocate(z_dim_name(num_entries))
97      allocate(output_stagger(num_entries))
98      allocate(output_this_field(num_entries))
99      allocate(is_u_field(num_entries))
100      allocate(is_v_field(num_entries))
101      allocate(is_derived_field(num_entries))
102      allocate(is_mandatory(num_entries))
103   
104      !
105      ! Set default values
106      !
107      do i=1,num_entries
108         fieldname(i) = ' '
109         flag_in_output(i) = ' '
110         output_name(i) = ' '
111         from_input(i) = '*'
112         z_dim_name(i) = 'num_metgrid_levels'
113         interp_method(i) = 'nearest_neighbor'
114         v_interp_method(i) = 'linear_log_p'
115         masked(i) = NOT_MASKED
116         fill_missing(i) = NAN
117         missing_value(i) = NAN
118         call list_init(fill_lev_list(i))
119         interp_mask(i) = ' '
120         interp_land_mask(i) = ' '
121         interp_water_mask(i) = ' '
122         interp_mask_val(i) = NAN
123         interp_land_mask_val(i) = NAN
124         interp_water_mask_val(i) = NAN
125         level_template(i) = ' '
126         if (gridtype == 'C') then
127            output_stagger(i) = M
128         else if (gridtype == 'E') then
129            output_stagger(i) = HH
130         end if
131         output_this_field(i) = .true.
132         is_u_field(i) = .false.
133         is_v_field(i) = .false.
134         is_derived_field(i) = .false.
135         is_mandatory(i) = .false.
136      end do
137      call list_init(flag_in_output_list)
138   
139      i = 1
140      istatus = 0
141      nparams = 0
142   
143      do while (istatus == 0)
144         buffer = ' '
145         read(funit, '(a)', iostat=istatus) buffer
146         if (istatus == 0) then
147            call despace(buffer)
148   
149            ! Is this line a comment?
150            if (buffer(1:1) == '#') then
151               ! Do nothing.
152   
153            ! Are we beginning a new field specification?
154            else if (index(buffer,'=====') /= 0) then   !{
155               if (nparams > 0) i = i + 1
156               nparams = 0
157   
158            else
159               ! Check whether the current line is a comment
160               if (buffer(1:1) /= '#') then
161                 have_specification = .true.
162               else
163                 have_specification = .false.
164               end if
165         
166               ! If only part of the line is a comment, just turn the comment into spaces
167               eos = index(buffer,'#')
168               if (eos /= 0) buffer(eos:BUFSIZE) = ' '
169         
170               do while (have_specification)   !{
171         
172                  ! If this line has no semicolon, it may contain a single specification,
173                  !   so we set have_specification = .false. to prevent the line from being
174                  !   processed again and "pretend" that the last character was a semicolon
175                  eos = index(buffer,';')
176                  if (eos == 0) then
177                    have_specification = .false.
178                    eos = BUFSIZE
179                  end if
180         
181                  idx = index(buffer(1:eos-1),'=')
182         
183                  if (idx /= 0) then   !{
184                     nparams = nparams + 1
185           
186                     if (index('name',trim(buffer(1:idx-1))) /= 0 .and. &
187                         len_trim('name') == len_trim(buffer(1:idx-1))) then
188                        ispace = idx+1
189                        do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
190                           ispace = ispace + 1
191                        end do
192                        fieldname(i) = ' '
193                        fieldname(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
194
195                     else if (index('from_input',trim(buffer(1:idx-1))) /= 0 .and. &
196                         len_trim('from_input') == len_trim(buffer(1:idx-1))) then
197                        ispace = idx+1
198                        do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
199                           ispace = ispace + 1
200                        end do
201                        from_input(i) = ' '
202                        from_input(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
203
204                     else if (index('z_dim_name',trim(buffer(1:idx-1))) /= 0 .and. &
205                         len_trim('z_dim_name') == len_trim(buffer(1:idx-1))) then
206                        ispace = idx+1
207                        do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
208                           ispace = ispace + 1
209                        end do
210                        z_dim_name(i) = ' '
211                        z_dim_name(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
212
213                     else if (index('output_stagger',trim(buffer(1:idx-1))) /= 0 .and. &
214                         len_trim('output_stagger') == len_trim(buffer(1:idx-1))) then
215                        if (index('M',trim(buffer(idx+1:eos-1))) /= 0) then
216                           output_stagger(i) = M
217                        else if (index('U',trim(buffer(idx+1:eos-1))) /= 0) then
218                           output_stagger(i) = U
219                        else if (index('V',trim(buffer(idx+1:eos-1))) /= 0) then
220                           output_stagger(i) = V
221                        else if (index('HH',trim(buffer(idx+1:eos-1))) /= 0) then
222                           output_stagger(i) = HH
223                        else if (index('VV',trim(buffer(idx+1:eos-1))) /= 0) then
224                           output_stagger(i) = VV
225                        end if
226
227                     else if (index('output',trim(buffer(1:idx-1))) /= 0 .and. &
228                         len_trim('output') == len_trim(buffer(1:idx-1))) then
229                        if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then
230                           output_this_field(i) = .true.
231                        else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then
232                           output_this_field(i) = .false.
233                        end if
234
235                     else if (index('is_u_field',trim(buffer(1:idx-1))) /= 0 .and. &
236                         len_trim('is_u_field') == len_trim(buffer(1:idx-1))) then
237                        if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then
238                           is_u_field(i) = .true.
239                        else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then
240                           is_u_field(i) = .false.
241                        end if
242
243                     else if (index('is_v_field',trim(buffer(1:idx-1))) /= 0 .and. &
244                         len_trim('is_v_field') == len_trim(buffer(1:idx-1))) then
245                        if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then
246                           is_v_field(i) = .true.
247                        else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then
248                           is_v_field(i) = .false.
249                        end if
250       
251                     else if (index('derived',trim(buffer(1:idx-1))) /= 0 .and. &
252                         len_trim('derived') == len_trim(buffer(1:idx-1))) then
253                        if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then
254                           is_derived_field(i) = .true.
255                        else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then
256                           is_derived_field(i) = .false.
257                        end if
258       
259                     else if (index('mandatory',trim(buffer(1:idx-1))) /= 0 .and. &
260                         len_trim('mandatory') == len_trim(buffer(1:idx-1))) then
261                        if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then
262                           is_mandatory(i) = .true.
263                        else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then
264                           is_mandatory(i) = .false.
265                        end if
266       
267                     else if (index('interp_option',trim(buffer(1:idx-1))) /= 0 .and. &
268                         len_trim('interp_option') == len_trim(buffer(1:idx-1))) then
269                        ispace = idx+1
270                        do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
271                           ispace = ispace + 1
272                        end do
273                        interp_method(i) = ' '
274                        interp_method(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
275
276                     else if (index('vertical_interp_option',trim(buffer(1:idx-1))) /= 0 .and. &
277                         len_trim('vertical_interp_option') == len_trim(buffer(1:idx-1))) then
278                        ispace = idx+1
279                        do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
280                           ispace = ispace + 1
281                        end do
282                        v_interp_method(i) = ' '
283                        v_interp_method(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
284
285                     else if (index('level_template',trim(buffer(1:idx-1))) /= 0 .and. &
286                         len_trim('level_template') == len_trim(buffer(1:idx-1))) then
287                        ispace = idx+1
288                        do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
289                           ispace = ispace + 1
290                        end do
291                        level_template(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
292
293                     else if (index('interp_mask',trim(buffer(1:idx-1))) /= 0 .and. &
294                         len_trim('interp_mask') == len_trim(buffer(1:idx-1))) then
295                        ispace = idx+1
296                        do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
297                           ispace = ispace + 1
298                        end do
299                        p1 = index(buffer(idx+1:ispace-1),'(')
300                        p2 = index(buffer(idx+1:ispace-1),')')
301                        if (p1 == 0 .or. p2 == 0) then
302                           call mprintf(.true.,WARN, &
303                                        'Problem in specifying interp_mask flag. Setting masked flag to 0.')
304                           interp_mask(i) = ' '
305                           interp_mask(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
306                           interp_mask_val(i) = 0
307                        else
308                           interp_mask(i) = ' '
309                           interp_mask(i)(1:p1) = buffer(idx+1:idx+p1-1)
310                           read(buffer(idx+p1+1:idx+p2-1),*,err=1000) interp_mask_val(i)
311                        end if
312     
313                     else if (index('interp_land_mask',trim(buffer(1:idx-1))) /= 0 .and. &
314                         len_trim('interp_land_mask') == len_trim(buffer(1:idx-1))) then
315                        ispace = idx+1
316                        do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
317                           ispace = ispace + 1
318                        end do
319                        p1 = index(buffer(idx+1:ispace-1),'(')
320                        p2 = index(buffer(idx+1:ispace-1),')')
321                        if (p1 == 0 .or. p2 == 0) then
322                           call mprintf(.true.,WARN, &
323                                        'Problem in specifying interp_land_mask flag. Setting masked flag to 0.')
324                           interp_land_mask(i) = ' '
325                           interp_land_mask(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
326                           interp_land_mask_val(i) = 0
327                        else
328                           interp_land_mask(i) = ' '
329                           interp_land_mask(i)(1:p1) = buffer(idx+1:idx+p1-1)
330                           read(buffer(idx+p1+1:idx+p2-1),*,err=1000) interp_land_mask_val(i)
331                        end if
332     
333                     else if (index('interp_water_mask',trim(buffer(1:idx-1))) /= 0 .and. &
334                         len_trim('interp_water_mask') == len_trim(buffer(1:idx-1))) then
335                        ispace = idx+1
336                        do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
337                           ispace = ispace + 1
338                        end do
339                        p1 = index(buffer(idx+1:ispace-1),'(')
340                        p2 = index(buffer(idx+1:ispace-1),')')
341                        if (p1 == 0 .or. p2 == 0) then
342                           call mprintf(.true.,WARN, &
343                                        'Problem in specifying interp_water_mask flag. Setting masked flag to 0.')
344                           interp_water_mask(i) = ' '
345                           interp_water_mask(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
346                           interp_water_mask_val(i) = 0
347                        else
348                           interp_water_mask(i) = ' '
349                           interp_water_mask(i)(1:p1) = buffer(idx+1:idx+p1-1)
350                           read(buffer(idx+p1+1:idx+p2-1),*,err=1000) interp_water_mask_val(i)
351                        end if
352     
353                     else if (index('masked',trim(buffer(1:idx-1))) /= 0 .and. &
354                         len_trim('masked') == len_trim(buffer(1:idx-1))) then
355                        if (index('water',trim(buffer(idx+1:eos-1))) /= 0) then
356                           masked(i) = MASKED_WATER
357                        else if (index('land',trim(buffer(idx+1:eos-1))) /= 0) then
358                           masked(i) = MASKED_LAND
359                        else if (index('both',trim(buffer(idx+1:eos-1))) /= 0) then
360                           masked(i) = MASKED_BOTH
361                        end if
362           
363                     else if (index('flag_in_output',trim(buffer(1:idx-1))) /= 0 .and. &
364                         len_trim('flag_in_output') == len_trim(buffer(1:idx-1))) then
365                        flag_string = ' '
366                        flag_string(1:eos-idx-1) = buffer(idx+1:eos-1)
367                        if (list_search(flag_in_output_list, ckey=flag_string, cvalue=flag_val)) then
368                           call mprintf(.true.,WARN, 'In METGRID.TBL, %s is given as a flag more than once.', &
369                                        s1=flag_string)
370                        else
371                           flag_in_output(i)(1:eos-idx-1) = buffer(idx+1:eos-1)
372                           write(flag_val,'(i1)') 1
373                           call list_insert(flag_in_output_list, ckey=flag_string, cvalue=flag_val)
374                        end if
375
376                     else if (index('output_name',trim(buffer(1:idx-1))) /= 0 .and. &
377                         len_trim('output_name') == len_trim(buffer(1:idx-1))) then
378                        ispace = idx+1
379                        do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
380                           ispace = ispace + 1
381                        end do
382                        output_name(i) = ' '
383                        output_name(i)(1:ispace-idx) = buffer(idx+1:ispace-1)
384           
385                     else if (index('fill_missing',trim(buffer(1:idx-1))) /= 0 .and. &
386                         len_trim('fill_missing') == len_trim(buffer(1:idx-1))) then
387                        read(buffer(idx+1:eos-1),*) fill_missing(i)
388   
389                     else if (index('missing_value',trim(buffer(1:idx-1))) /= 0 .and. &
390                         len_trim('missing_value') == len_trim(buffer(1:idx-1))) then
391                        read(buffer(idx+1:eos-1),*) missing_value(i)
392   
393                     else if (index('fill_lev',trim(buffer(1:idx-1))) /= 0 .and. &
394                         len_trim('fill_lev') == len_trim(buffer(1:idx-1))) then
395                        ispace = idx+1
396                        do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' '))
397                           ispace = ispace + 1
398                        end do
399                        fill_string = ' '
400                        fill_string(1:ispace-idx-1) = buffer(idx+1:ispace-1)
401                        ispace = index(fill_string,':')
402                        if (ispace /= 0) then
403                           write(lev_string,'(a)') fill_string(1:ispace-1)
404                        else
405                           write(lev_string,'(a)') 'all'
406                        end if
407                        write(fill_string,'(a)') trim(fill_string(ispace+1:128))
408                        fill_string(128-ispace:128) = ' '
409                        call list_insert(fill_lev_list(i), ckey=lev_string, cvalue=fill_string)
410       
411                     else
412                        call mprintf(.true.,WARN, 'In METGRID.TBL, unrecognized option %s in entry %i.', s1=buffer(1:idx-1), i1=idx)
413                     end if
414         
415                  end if   !} index(buffer(1:eos-1),'=') /= 0
416
417! BUG: If buffer has non-whitespace characters but no =, then maybe a wrong specification?
418         
419                  buffer = buffer(eos+1:BUFSIZE)
420               end do   ! while eos /= 0 }
421       
422            end if   !} index(buffer, '=====') /= 0
423   
424         end if
425      end do
426
427      call check_table_specs()
428   
429      close(funit)
430   
431      return
432
433   1000 call mprintf(.true.,ERROR,'The mask value of the interp_mask specification must '// &
434                     'be a real value, enclosed in parentheses immediately after the field name.')
435   
436   1001 call mprintf(.true.,ERROR,'Could not open file METGRID.TBL')
437
438   end subroutine read_interp_table
439
440
441   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
442   ! Name: check_table_specs
443   !
444   ! Pupose: Perform basic consistency and sanity checks on the METGRID.TBL
445   !         entries supplied by the user.
446   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
447   subroutine check_table_specs()
448
449      implicit none
450
451      ! Local variables
452      integer :: i
453
454      do i=1,num_entries
455         
456         ! For C grid, U field must be on U staggering, and V field must be on
457         !   V staggering; for E grid, U and V must be on VV staggering.
458         if (gridtype == 'C') then
459            if (is_u_field(i) .and. output_stagger(i) /= U) then
460               call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, the wind U-component field '// &
461                            'must be interpolated to the U staggered grid points.',i1=i)
462            else if (is_v_field(i) .and. output_stagger(i) /= V) then
463               call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, the wind V-component field '// &
464                            'must be interpolated to the V staggered grid points.',i1=i)
465            end if
466
467            if (output_stagger(i) == VV) then
468               call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, VV is not a valid output staggering for ARW.',i1=i)
469            else if (output_stagger(i) == HH) then
470               call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, HH is not a valid output staggering for ARW.',i1=i)
471            end if
472
473            if (masked(i) /= NOT_MASKED .and. output_stagger(i) /= M) then
474               call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, staggered output field '// &
475                            'cannot use the ''masked'' option.',i1=i)
476            end if
477
478         else if (gridtype == 'E') then
479            if (is_u_field(i) .and. output_stagger(i) /= VV) then
480               call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, the wind U-component field '// &
481                            'must be interpolated to the V staggered grid points.',i1=i)
482            else if (is_v_field(i) .and. output_stagger(i) /= VV) then
483               call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, the wind V-component field '// &
484                            'must be interpolated to the V staggered grid points.',i1=i)
485            end if
486
487            if (output_stagger(i) == M) then
488               call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, M is not a valid output staggering for NMM.',i1=i)
489            else if (output_stagger(i) == U) then
490               call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, U is not a valid output staggering for NMM.',i1=i)
491            else if (output_stagger(i) == V) then
492               call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, V is not a valid output staggering for NMM.',i1=i)
493            end if
494
495            if (masked(i) /= NOT_MASKED .and. output_stagger(i) /= HH) then
496               call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, staggered output field '// &
497                            'cannot use the ''masked'' option.',i1=i)
498            end if
499         end if
500
501      end do
502
503   end subroutine check_table_specs
504
505
506   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
507   ! Name: get_z_dim_name
508   !
509   ! Pupose:
510   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
511   subroutine get_z_dim_name(fldname, zdim_name)
512 
513      implicit none
514 
515      ! Arguments
516      character (len=*), intent(in) :: fldname
517      character (len=32), intent(out) :: zdim_name
518
519      ! Local variables
520      integer :: i
521
522      zdim_name = z_dim_name(num_entries)(1:32)
523      do i=1,num_entries
524         if (trim(fldname) == trim(fieldname(i))) then
525            zdim_name = z_dim_name(i)(1:32)
526            exit
527         end if
528      end do
529
530   end subroutine get_z_dim_name
531
532
533   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
534   ! Name: get_gcell_threshold
535   !
536   ! Pupose:
537   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
538   subroutine get_gcell_threshold(interp_opt, threshold, istatus)
539
540      implicit none
541
542      ! Arguments
543      integer, intent(out) :: istatus
544      real, intent(out) :: threshold
545      character (len=128), intent(in) :: interp_opt
546
547      ! Local variables
548      integer :: i, p1, p2
549
550      istatus = 1
551      threshold = 1.0
552
553      i = index(interp_opt,'average_gcell')
554      if (i /= 0) then
555
556         ! Check for a threshold
557         p1 = index(interp_opt(i:128),'(')
558         p2 = index(interp_opt(i:128),')')
559         if (p1 /= 0 .and. p2 /= 0) then
560            read(interp_opt(p1+1:p2-1),*,err=1000) threshold
561         else
562            call mprintf(.true.,WARN, 'Problem in specifying threshold for average_gcell interp option. Setting threshold to 1.0')
563            threshold = 1.0
564         end if
565      end if
566      istatus = 0
567
568      return
569
5701000  call mprintf(.true.,ERROR, &
571                   'Threshold option to average_gcell interpolator must be a real number, '// &
572                   'enclosed in parentheses immediately after keyword "average_gcell"')
573
574   end subroutine get_gcell_threshold
575
576
577   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
578   ! Name: get_constant_fill_lev
579   !
580   ! Pupose:
581   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
582   subroutine get_constant_fill_lev(fill_opt, fill_const, istatus)
583
584      implicit none
585
586      ! Arguments
587      integer, intent(out) :: istatus
588      real, intent(out) :: fill_const
589      character (len=128), intent(in) :: fill_opt
590
591      ! Local variables
592      integer :: i, p1, p2
593
594      istatus = 1
595      fill_const = NAN
596
597      i = index(fill_opt,'const')
598      if (i /= 0) then
599
600         ! Check for a threshold
601         p1 = index(fill_opt(i:128),'(')
602         p2 = index(fill_opt(i:128),')')
603         if (p1 /= 0 .and. p2 /= 0) then
604            read(fill_opt(p1+1:p2-1),*,err=1000) fill_const
605         else
606            call mprintf(.true.,WARN, 'Problem in specifying fill_lev constant. Setting fill_const to %f', f1=NAN)
607            fill_const = NAN
608         end if
609         istatus = 0
610      end if
611
612      return
613
6141000  call mprintf(.true.,ERROR, &
615                   'Constant option to fill_lev must be a real number, enclosed in parentheses '// &
616                   'immediately after keyword "const"')
617
618   end subroutine get_constant_fill_lev
619
620
621   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
622   ! Name: get_fill_src_level
623   !
624   ! Purpose:
625   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
626   subroutine get_fill_src_level(fill_opt, fill_src, fill_src_level)
627
628      implicit none
629
630      ! Arguments
631      integer, intent(out) :: fill_src_level
632      character (len=128), intent(in) :: fill_opt
633      character (len=128), intent(out) :: fill_src
634
635      ! Local variables
636      integer :: p1, p2
637
638      ! Check for a level in parentheses
639      p1 = index(fill_opt,'(')
640      p2 = index(fill_opt,')')
641      if (p1 /= 0 .and. p2 /= 0) then
642         read(fill_opt(p1+1:p2-1),*,err=1000) fill_src_level
643         fill_src = ' '
644         write(fill_src,'(a)') fill_opt(1:p1-1)
645      else
646         fill_src_level = 1
647         fill_src = fill_opt
648      end if
649
650      return
651
6521000  call mprintf(.true.,ERROR, &
653                   'For fill_lev specification, level in source field must be an integer, '// &
654                   'enclosed in parentheses immediately after the fieldname')
655
656   end subroutine get_fill_src_level
657
658
659   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
660   ! Name: interp_option_destroy
661   !
662   ! Purpose:
663   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
664   subroutine interp_option_destroy()
665
666      implicit none
667
668      ! Local variables
669      integer :: i
670
671      deallocate(fieldname)
672      deallocate(from_input)
673      deallocate(z_dim_name)
674      deallocate(interp_method)
675      deallocate(v_interp_method)
676      deallocate(masked)
677      deallocate(fill_missing)
678      deallocate(missing_value)
679      do i=1,num_entries
680         call list_destroy(fill_lev_list(i))
681      end do
682      deallocate(fill_lev_list)
683      deallocate(interp_mask)
684      deallocate(interp_land_mask)
685      deallocate(interp_water_mask)
686      deallocate(interp_mask_val)
687      deallocate(interp_land_mask_val)
688      deallocate(interp_water_mask_val)
689      deallocate(level_template)
690      deallocate(flag_in_output)
691      deallocate(output_name)
692      deallocate(output_stagger)
693      deallocate(output_this_field)
694      deallocate(is_u_field)
695      deallocate(is_v_field)
696      deallocate(is_derived_field)
697      deallocate(is_mandatory)
698      call list_destroy(flag_in_output_list)
699
700   end subroutine interp_option_destroy
701
702end module interp_option_module
Note: See TracBrowser for help on using the repository browser.