libsim  Versione 7.1.7
vol7d_level_class.F90
1 ! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2 ! authors:
3 ! Davide Cesari <dcesari@arpa.emr.it>
4 ! Paolo Patruno <ppatruno@arpa.emr.it>
5 
6 ! This program is free software; you can redistribute it and/or
7 ! modify it under the terms of the GNU General Public License as
8 ! published by the Free Software Foundation; either version 2 of
9 ! the License, or (at your option) any later version.
10 
11 ! This program is distributed in the hope that it will be useful,
12 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ! GNU General Public License for more details.
15 
16 ! You should have received a copy of the GNU General Public License
17 ! along with this program. If not, see <http://www.gnu.org/licenses/>.
18 #include "config.h"
19 
25 MODULE vol7d_level_class
26 USE kinds
29 IMPLICIT NONE
30 
35 TYPE vol7d_level
36  INTEGER :: level1
37  INTEGER :: l1
38  INTEGER :: level2
39  INTEGER :: l2
40 END TYPE vol7d_level
41 
43 TYPE(vol7d_level),PARAMETER :: vol7d_level_miss=vol7d_level(imiss,imiss,imiss,imiss)
44 
48 INTERFACE init
49  MODULE PROCEDURE vol7d_level_init
50 END INTERFACE
51 
54 INTERFACE delete
55  MODULE PROCEDURE vol7d_level_delete
56 END INTERFACE
57 
61 INTERFACE OPERATOR (==)
62  MODULE PROCEDURE vol7d_level_eq
63 END INTERFACE
64 
68 INTERFACE OPERATOR (/=)
69  MODULE PROCEDURE vol7d_level_ne
70 END INTERFACE
71 
77 INTERFACE OPERATOR (>)
78  MODULE PROCEDURE vol7d_level_gt
79 END INTERFACE
80 
86 INTERFACE OPERATOR (<)
87  MODULE PROCEDURE vol7d_level_lt
88 END INTERFACE
89 
95 INTERFACE OPERATOR (>=)
96  MODULE PROCEDURE vol7d_level_ge
97 END INTERFACE
98 
104 INTERFACE OPERATOR (<=)
105  MODULE PROCEDURE vol7d_level_le
106 END INTERFACE
107 
111 INTERFACE OPERATOR (.almosteq.)
112  MODULE PROCEDURE vol7d_level_almost_eq
113 END INTERFACE
114 
115 
116 ! da documentare in inglese assieme al resto
118 INTERFACE c_e
119  MODULE PROCEDURE vol7d_level_c_e
120 END INTERFACE
121 
122 #define VOL7D_POLY_TYPE TYPE(vol7d_level)
123 #define VOL7D_POLY_TYPES _level
124 #define ENABLE_SORT
125 #include "array_utilities_pre.F90"
126 
128 INTERFACE display
129  MODULE PROCEDURE display_level
130 END INTERFACE
131 
133 INTERFACE to_char
134  MODULE PROCEDURE to_char_level
135 END INTERFACE
136 
138 INTERFACE vol7d_level_to_var
139  MODULE PROCEDURE vol7d_level_to_var_int, vol7d_level_to_var_lev
140 END INTERFACE vol7d_level_to_var
141 
144  MODULE PROCEDURE vol7d_level_to_var_factor_int, vol7d_level_to_var_factor_lev
145 END INTERFACE vol7d_level_to_var_factor
146 
148 INTERFACE vol7d_level_to_var_log10
149  MODULE PROCEDURE vol7d_level_to_var_log10_int, vol7d_level_to_var_log10_lev
150 END INTERFACE vol7d_level_to_var_log10
151 
152 type(vol7d_level) :: almost_equal_levels(3)=(/&
153  vol7d_level( 1,imiss,imiss,imiss),&
154  vol7d_level(103,imiss,imiss,imiss),&
155  vol7d_level(106,imiss,imiss,imiss)/)
156 
157 ! levels requiring conversion from internal to physical representation
158 INTEGER, PARAMETER :: &
159  height_level(6) = (/102,103,106,117,160,161/), & ! 10**-3
160  thermo_level(3) = (/20,107,235/), & ! 10**-1
161  sigma_level(2) = (/104,111/) ! 10**-4
162 
163 TYPE level_var
164  INTEGER :: level
165  CHARACTER(len=10) :: btable
166 END TYPE level_var
167 
168 ! Conversion table from GRIB2 vertical level codes to corresponding
169 ! BUFR B table variables
170 TYPE(level_var),PARAMETER :: level_var_converter(7) = (/ &
171  level_var(20, 'B12101'), & ! isothermal (K)
172  level_var(100, 'B10004'), & ! isobaric (Pa)
173  level_var(102, 'B10007'), & ! height over sea level (m)
174  level_var(103, 'B10007'), & ! height over surface (m) (special treatment needed!)
175  level_var(107, 'B12192'), & ! isentropical (K)
176  level_var(108, 'B10004'), & ! pressure difference from surface (Pa) (special treatment needed!)
177  level_var(161, 'B22195') /) ! depth below sea surface
178 
179 PRIVATE level_var, level_var_converter
180 
181 CONTAINS
182 
188 FUNCTION vol7d_level_new(level1, l1, level2, l2) RESULT(this)
189 INTEGER,INTENT(IN),OPTIONAL :: level1
190 INTEGER,INTENT(IN),OPTIONAL :: l1
191 INTEGER,INTENT(IN),OPTIONAL :: level2
192 INTEGER,INTENT(IN),OPTIONAL :: l2
193 
194 TYPE(vol7d_level) :: this
195 
196 CALL init(this, level1, l1, level2, l2)
197 
198 END FUNCTION vol7d_level_new
199 
200 
204 SUBROUTINE vol7d_level_init(this, level1, l1, level2, l2)
205 TYPE(vol7d_level),INTENT(INOUT) :: this
206 INTEGER,INTENT(IN),OPTIONAL :: level1
207 INTEGER,INTENT(IN),OPTIONAL :: l1
208 INTEGER,INTENT(IN),OPTIONAL :: level2
209 INTEGER,INTENT(IN),OPTIONAL :: l2
210 
211 this%level1 = imiss
212 this%l1 = imiss
213 this%level2 = imiss
214 this%l2 = imiss
215 
216 IF (PRESENT(level1)) THEN
217  this%level1 = level1
218 ELSE
219  RETURN
220 END IF
221 
222 IF (PRESENT(l1)) this%l1 = l1
223 
224 IF (PRESENT(level2)) THEN
225  this%level2 = level2
226 ELSE
227  RETURN
228 END IF
229 
230 IF (PRESENT(l2)) this%l2 = l2
231 
232 END SUBROUTINE vol7d_level_init
233 
234 
236 SUBROUTINE vol7d_level_delete(this)
237 TYPE(vol7d_level),INTENT(INOUT) :: this
238 
239 this%level1 = imiss
240 this%l1 = imiss
241 this%level2 = imiss
242 this%l2 = imiss
243 
244 END SUBROUTINE vol7d_level_delete
245 
246 
247 SUBROUTINE display_level(this)
248 TYPE(vol7d_level),INTENT(in) :: this
249 
250 print*,trim(to_char(this))
251 
252 END SUBROUTINE display_level
253 
254 
255 FUNCTION to_char_level(this)
256 #ifdef HAVE_DBALLE
257 USE dballef
258 #endif
259 TYPE(vol7d_level),INTENT(in) :: this
260 CHARACTER(len=255) :: to_char_level
261 
262 #ifdef HAVE_DBALLE
263 INTEGER :: handle, ier
264 
265 handle = 0
266 ier = idba_messaggi(handle,"/dev/null", "w", "BUFR")
267 ier = idba_spiegal(handle,this%level1,this%l1,this%level2,this%l2,to_char_level)
268 ier = idba_fatto(handle)
269 
270 to_char_level="LEVEL: "//to_char_level
271 
272 #else
273 
274 to_char_level="LEVEL: "//&
275  " typelev1:"//trim(to_char(this%level1))//" L1:"//trim(to_char(this%l1))//&
276  " typelev2:"//trim(to_char(this%level2))//" L2:"//trim(to_char(this%l2))
277 
278 #endif
279 
280 END FUNCTION to_char_level
281 
282 
283 ELEMENTAL FUNCTION vol7d_level_eq(this, that) RESULT(res)
284 TYPE(vol7d_level),INTENT(IN) :: this, that
285 LOGICAL :: res
286 
287 res = &
288  this%level1 == that%level1 .AND. &
289  this%level2 == that%level2 .AND. &
290  this%l1 == that%l1 .AND. this%l2 == that%l2
291 
292 END FUNCTION vol7d_level_eq
293 
294 
295 ELEMENTAL FUNCTION vol7d_level_ne(this, that) RESULT(res)
296 TYPE(vol7d_level),INTENT(IN) :: this, that
297 LOGICAL :: res
298 
299 res = .NOT.(this == that)
300 
301 END FUNCTION vol7d_level_ne
302 
303 
304 ELEMENTAL FUNCTION vol7d_level_almost_eq(this, that) RESULT(res)
305 TYPE(vol7d_level),INTENT(IN) :: this, that
306 LOGICAL :: res
307 
308 IF ( .not. c_e(this%level1) .or. .not. c_e(that%level1) .or. this%level1 == that%level1 .AND. &
309  .not. c_e(this%level2) .or. .not. c_e(that%level2) .or. this%level2 == that%level2 .AND. &
310  .not. c_e(this%l1) .or. .not. c_e(that%l1) .or. this%l1 == that%l1 .AND. &
311  .not. c_e(this%l2) .or. .not. c_e(that%l2) .or. this%l2 == that%l2) THEN
312  res = .true.
313 ELSE
314  res = .false.
315 ENDIF
316 
317 END FUNCTION vol7d_level_almost_eq
318 
319 
320 ELEMENTAL FUNCTION vol7d_level_gt(this, that) RESULT(res)
321 TYPE(vol7d_level),INTENT(IN) :: this, that
322 LOGICAL :: res
323 
324 IF (&
325  this%level1 > that%level1 .OR. &
326  (this%level1 == that%level1 .AND. this%l1 > that%l1) .OR. &
327  (this%level1 == that%level1 .AND. this%l1 == that%l1 .AND. &
328  (&
329  this%level2 > that%level2 .OR. &
330  (this%level2 == that%level2 .AND. this%l2 > that%l2) &
331  ))) THEN
332  res = .true.
333 ELSE
334  res = .false.
335 ENDIF
336 
337 END FUNCTION vol7d_level_gt
338 
339 
340 ELEMENTAL FUNCTION vol7d_level_lt(this, that) RESULT(res)
341 TYPE(vol7d_level),INTENT(IN) :: this, that
342 LOGICAL :: res
343 
344 IF (&
345  this%level1 < that%level1 .OR. &
346  (this%level1 == that%level1 .AND. this%l1 < that%l1) .OR. &
347  (this%level1 == that%level1 .AND. this%l1 == that%l1 .AND. &
348  (&
349  this%level2 < that%level2 .OR. &
350  (this%level2 == that%level2 .AND. this%l2 < that%l2) &
351  ))) THEN
352  res = .true.
353 ELSE
354  res = .false.
355 ENDIF
356 
357 END FUNCTION vol7d_level_lt
358 
359 
360 ELEMENTAL FUNCTION vol7d_level_ge(this, that) RESULT(res)
361 TYPE(vol7d_level),INTENT(IN) :: this, that
362 LOGICAL :: res
363 
364 IF (this == that) THEN
365  res = .true.
366 ELSE IF (this > that) THEN
367  res = .true.
368 ELSE
369  res = .false.
370 ENDIF
371 
372 END FUNCTION vol7d_level_ge
373 
374 
375 ELEMENTAL FUNCTION vol7d_level_le(this, that) RESULT(res)
376 TYPE(vol7d_level),INTENT(IN) :: this, that
377 LOGICAL :: res
378 
379 IF (this == that) THEN
380  res = .true.
381 ELSE IF (this < that) THEN
382  res = .true.
383 ELSE
384  res = .false.
385 ENDIF
386 
387 END FUNCTION vol7d_level_le
388 
389 
390 ELEMENTAL FUNCTION vol7d_level_c_e(this) RESULT(c_e)
391 TYPE(vol7d_level),INTENT(IN) :: this
392 LOGICAL :: c_e
393 c_e = this /= vol7d_level_miss
394 END FUNCTION vol7d_level_c_e
395 
396 
397 #include "array_utilities_inc.F90"
398 
399 
400 FUNCTION vol7d_level_to_var_lev(level) RESULT(btable)
401 TYPE(vol7d_level),INTENT(in) :: level
402 CHARACTER(len=10) :: btable
403 
404 btable = vol7d_level_to_var_int(level%level1)
405 
406 END FUNCTION vol7d_level_to_var_lev
407 
408 FUNCTION vol7d_level_to_var_int(level) RESULT(btable)
409 INTEGER,INTENT(in) :: level
410 CHARACTER(len=10) :: btable
411 
412 INTEGER :: i
413 
414 DO i = 1, SIZE(level_var_converter)
415  IF (level_var_converter(i)%level == level) THEN
416  btable = level_var_converter(i)%btable
417  RETURN
418  ENDIF
419 ENDDO
420 
421 btable = cmiss
422 
423 END FUNCTION vol7d_level_to_var_int
424 
425 
426 FUNCTION vol7d_level_to_var_factor_lev(level) RESULT(factor)
427 TYPE(vol7d_level),INTENT(in) :: level
428 REAL :: factor
429 
430 factor = vol7d_level_to_var_factor_int(level%level1)
431 
432 END FUNCTION vol7d_level_to_var_factor_lev
433 
434 FUNCTION vol7d_level_to_var_factor_int(level) RESULT(factor)
435 INTEGER,INTENT(in) :: level
436 REAL :: factor
437 
438 factor = 1.
439 IF (any(level == height_level)) THEN
440  factor = 1.e-3
441 ELSE IF (any(level == thermo_level)) THEN
442  factor = 1.e-1
443 ELSE IF (any(level == sigma_level)) THEN
444  factor = 1.e-4
445 ENDIF
446 
447 END FUNCTION vol7d_level_to_var_factor_int
448 
449 
450 FUNCTION vol7d_level_to_var_log10_lev(level) RESULT(log10)
451 TYPE(vol7d_level),INTENT(in) :: level
452 REAL :: log10
453 
454 log10 = vol7d_level_to_var_log10_int(level%level1)
455 
456 END FUNCTION vol7d_level_to_var_log10_lev
457 
458 FUNCTION vol7d_level_to_var_log10_int(level) RESULT(log10)
459 INTEGER,INTENT(in) :: level
460 REAL :: log10
461 
462 log10 = 0.
463 IF (any(level == height_level)) THEN
464  log10 = -3.
465 ELSE IF (any(level == thermo_level)) THEN
466  log10 = -1.
467 ELSE IF (any(level == sigma_level)) THEN
468  log10 = -4.
469 ENDIF
470 
471 END FUNCTION vol7d_level_to_var_log10_int
472 
473 END MODULE vol7d_level_class
Distruttore per la classe vol7d_level.
Costruttore per la classe vol7d_level.
Represent level object in a pretty string.
Return the conversion factor for multiplying the level value when converting to variable.
Return the scale value (base 10 log of conversion factor) for multiplying the level value when conver...
Convert a level type to a physical variable.
Utilities for CHARACTER variables.
Definition of constants to be used for declaring variables of a desired type.
Definition: kinds.F90:251
Definitions of constants and functions for working with missing values.
Classe per la gestione dei livelli verticali in osservazioni meteo e affini.
Definisce il livello verticale di un'osservazione.

Generated with Doxygen.