libsim  Versione6.3.0
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 
137 type(vol7d_level) :: almost_equal_levels(3)=(/&
138  vol7d_level( 1,imiss,imiss,imiss),&
139  vol7d_level(103,imiss,imiss,imiss),&
140  vol7d_level(106,imiss,imiss,imiss)/)
141 
142 TYPE level_var
143  INTEGER :: level
144  CHARACTER(len=10) :: btable
145 END TYPE level_var
146 
147 ! Conversion table from GRIB2 vertical level codes to corresponding
148 ! BUFR B table variables, no unit conversion provided since there is
149 ! no need up to now
150 TYPE(level_var),PARAMETER :: level_var_converter(6) = (/ &
151  level_var(20, 'B12101'), & ! isothermal (K)
152  level_var(100, 'B10004'), & ! isobaric (Pa)
153  level_var(102, 'B10007'), & ! height over sea level (m)
154  level_var(103, 'B10007'), & ! height over surface (m) (special treatment needed!)
155  level_var(107, 'B12192'), & ! isentropical (K)
156  level_var(108, 'B10004') /) ! pressure difference from surface (Pa) (special treatment needed!)
157 
158 PRIVATE level_var, level_var_converter
159 
160 CONTAINS
161 
167 FUNCTION vol7d_level_new(level1, l1, level2, l2) RESULT(this)
168 INTEGER,INTENT(IN),OPTIONAL :: level1
169 INTEGER,INTENT(IN),OPTIONAL :: l1
170 INTEGER,INTENT(IN),OPTIONAL :: level2
171 INTEGER,INTENT(IN),OPTIONAL :: l2
172 
173 TYPE(vol7d_level) :: this
174 
175 CALL init(this, level1, l1, level2, l2)
176 
177 END FUNCTION vol7d_level_new
178 
179 
183 SUBROUTINE vol7d_level_init(this, level1, l1, level2, l2)
184 TYPE(vol7d_level),INTENT(INOUT) :: this
185 INTEGER,INTENT(IN),OPTIONAL :: level1
186 INTEGER,INTENT(IN),OPTIONAL :: l1
187 INTEGER,INTENT(IN),OPTIONAL :: level2
188 INTEGER,INTENT(IN),OPTIONAL :: l2
189 
190 this%level1 = imiss
191 this%l1 = imiss
192 this%level2 = imiss
193 this%l2 = imiss
194 
195 IF (present(level1)) THEN
196  this%level1 = level1
197 ELSE
198  RETURN
199 END IF
200 
201 IF (present(l1)) this%l1 = l1
202 
203 IF (present(level2)) THEN
204  this%level2 = level2
205 ELSE
206  RETURN
207 END IF
208 
209 IF (present(l2)) this%l2 = l2
210 
211 END SUBROUTINE vol7d_level_init
212 
213 
215 SUBROUTINE vol7d_level_delete(this)
216 TYPE(vol7d_level),INTENT(INOUT) :: this
217 
218 this%level1 = imiss
219 this%l1 = imiss
220 this%level2 = imiss
221 this%l2 = imiss
222 
223 END SUBROUTINE vol7d_level_delete
224 
225 
226 SUBROUTINE display_level(this)
227 TYPE(vol7d_level),INTENT(in) :: this
228 
229 print*,trim(to_char(this))
231 END SUBROUTINE display_level
234 FUNCTION to_char_level(this)
235 #ifdef HAVE_DBALLE
236 #ifdef HAVE_DBALLEF_MOD
237 USE dballef
238 #else
239 include 'dballeff.h'
240 #endif
241 #endif
242 TYPE(vol7d_level),INTENT(in) :: this
243 CHARACTER(len=255) :: to_char_level
244 
245 #ifdef HAVE_DBALLE
246 INTEGER :: handle, ier
247 
248 handle = 0
249 ier = idba_messaggi(handle,"/dev/null", "w", "BUFR")
250 ier = idba_spiegal(handle,this%level1,this%l1,this%level2,this%l2,to_char_level)
251 ier = idba_fatto(handle)
252 
253 to_char_level="LEVEL: "//to_char_level
254 
255 #else
256 
257 to_char_level="LEVEL: "//&
258  " typelev1:"//trim(to_char(this%level1))//" L1:"//trim(to_char(this%l1))//&
259  " typelev2:"//trim(to_char(this%level2))//" L2:"//trim(to_char(this%l2))
260 
261 #endif
263 END FUNCTION to_char_level
264 
265 
266 ELEMENTAL FUNCTION vol7d_level_eq(this, that) RESULT(res)
267 TYPE(vol7d_level),INTENT(IN) :: this, that
268 LOGICAL :: res
269 
270 res = &
271  this%level1 == that%level1 .AND. &
272  this%level2 == that%level2 .AND. &
273  this%l1 == that%l1 .AND. this%l2 == that%l2
274 
275 END FUNCTION vol7d_level_eq
276 
277 
278 ELEMENTAL FUNCTION vol7d_level_ne(this, that) RESULT(res)
279 TYPE(vol7d_level),INTENT(IN) :: this, that
280 LOGICAL :: res
281 
282 res = .NOT.(this == that)
283 
284 END FUNCTION vol7d_level_ne
285 
286 
287 ELEMENTAL FUNCTION vol7d_level_almost_eq(this, that) RESULT(res)
288 TYPE(vol7d_level),INTENT(IN) :: this, that
289 LOGICAL :: res
290 
291 IF ( .not. c_e(this%level1) .or. .not. c_e(that%level1) .or. this%level1 == that%level1 .AND. &
292  .not. c_e(this%level2) .or. .not. c_e(that%level2) .or. this%level2 == that%level2 .AND. &
293  .not. c_e(this%l1) .or. .not. c_e(that%l1) .or. this%l1 == that%l1 .AND. &
294  .not. c_e(this%l2) .or. .not. c_e(that%l2) .or. this%l2 == that%l2) THEN
295  res = .true.
296 ELSE
297  res = .false.
298 ENDIF
299 
300 END FUNCTION vol7d_level_almost_eq
301 
302 
303 ELEMENTAL FUNCTION vol7d_level_gt(this, that) RESULT(res)
304 TYPE(vol7d_level),INTENT(IN) :: this, that
305 LOGICAL :: res
306 
307 IF (&
308  this%level1 > that%level1 .OR. &
309  (this%level1 == that%level1 .AND. this%l1 > that%l1) .OR. &
310  (this%level1 == that%level1 .AND. this%l1 == that%l1 .AND. &
311  (&
312  this%level2 > that%level2 .OR. &
313  (this%level2 == that%level2 .AND. this%l2 > that%l2) &
314  ))) THEN
315  res = .true.
316 ELSE
317  res = .false.
318 ENDIF
319 
320 END FUNCTION vol7d_level_gt
321 
322 
323 ELEMENTAL FUNCTION vol7d_level_lt(this, that) RESULT(res)
324 TYPE(vol7d_level),INTENT(IN) :: this, that
325 LOGICAL :: res
326 
327 IF (&
328  this%level1 < that%level1 .OR. &
329  (this%level1 == that%level1 .AND. this%l1 < that%l1) .OR. &
330  (this%level1 == that%level1 .AND. this%l1 == that%l1 .AND. &
331  (&
332  this%level2 < that%level2 .OR. &
333  (this%level2 == that%level2 .AND. this%l2 < that%l2) &
334  ))) THEN
335  res = .true.
336 ELSE
337  res = .false.
338 ENDIF
339 
340 END FUNCTION vol7d_level_lt
341 
342 
343 ELEMENTAL FUNCTION vol7d_level_ge(this, that) RESULT(res)
344 TYPE(vol7d_level),INTENT(IN) :: this, that
345 LOGICAL :: res
346 
347 IF (this == that) THEN
348  res = .true.
349 ELSE IF (this > that) THEN
350  res = .true.
351 ELSE
352  res = .false.
353 ENDIF
354 
355 END FUNCTION vol7d_level_ge
356 
358 ELEMENTAL FUNCTION vol7d_level_le(this, that) RESULT(res)
359 TYPE(vol7d_level),INTENT(IN) :: this, that
360 LOGICAL :: res
361 
362 IF (this == that) THEN
363  res = .true.
364 ELSE IF (this < that) THEN
365  res = .true.
366 ELSE
367  res = .false.
368 ENDIF
370 END FUNCTION vol7d_level_le
371 
372 
373 ELEMENTAL FUNCTION vol7d_level_c_e(this) RESULT(c_e)
374 TYPE(vol7d_level),INTENT(IN) :: this
375 LOGICAL :: c_e
376 c_e = this /= vol7d_level_miss
377 END FUNCTION vol7d_level_c_e
378 
379 
380 #include "array_utilities_inc.F90"
381 
383 FUNCTION vol7d_level_to_var(level) RESULT(btable)
384 TYPE(vol7d_level),INTENT(in) :: level
385 CHARACTER(len=10) :: btable
386 
387 INTEGER :: i
388 
389 DO i = 1, SIZE(level_var_converter)
390  IF (level_var_converter(i)%level == level%level1) THEN
391  btable = level_var_converter(i)%btable
392  RETURN
393  ENDIF
394 ENDDO
395 
396 btable = cmiss
397 
398 END FUNCTION vol7d_level_to_var
399 
400 
401 END MODULE vol7d_level_class
Costruttore per la classe vol7d_level.
Distruttore per la classe vol7d_level.
Definitions of constants and functions for working with missing values.
Represent level object in a pretty string.
Classe per la gestione dei livelli verticali in osservazioni meteo e affini.
Utilities for CHARACTER variables.
Definition of constants to be used for declaring variables of a desired type.
Definition: kinds.F90:251

Generated with Doxygen.