libsim  Versione 7.1.6
volgrid6d_var_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 
31 USE kinds
33 USE err_handling
36 USE grid_id_class
37 
38 IMPLICIT NONE
39 
44 TYPE volgrid6d_var
45  integer :: centre
46  integer :: category
47  integer :: number
48  integer :: discipline
49  CHARACTER(len=65) :: description
50  CHARACTER(len=24) :: unit
51 END TYPE volgrid6d_var
52 
53 TYPE(volgrid6d_var),PARAMETER :: volgrid6d_var_miss= &
54  volgrid6d_var(imiss,imiss,imiss,imiss,cmiss,cmiss)
55 
56 TYPE(vol7d_var),PARAMETER :: vol7d_var_horstag(2) = (/ &
57  vol7d_var('B11003', '', '', 0, 0, 0, 0, 0, 0), &
58  vol7d_var('B11004', '', '', 0, 0, 0, 0, 0, 0) &
59  /)
60 
61 TYPE(vol7d_var),PARAMETER :: vol7d_var_horcomp(4) = (/ &! RESHAPE( (/ &
62  vol7d_var('B11003', '', '', 0, 0, 0, 0, 0, 0), &
63  vol7d_var('B11004', '', '', 0, 0, 0, 0, 0, 0), &
64  vol7d_var('B11200', '', '', 0, 0, 0, 0, 0, 0), &
65  vol7d_var('B11201', '', '', 0, 0, 0, 0, 0, 0) &
66 /)
67 !/), (/2,2/)) ! bug in gfortran
68 
77 TYPE conv_func
78  PRIVATE
79  REAL :: a, b
80 END TYPE conv_func
81 
82 TYPE(conv_func), PARAMETER :: conv_func_miss=conv_func(rmiss,rmiss)
83 TYPE(conv_func), PARAMETER :: conv_func_identity=conv_func(1.0,0.0)
84 
85 TYPE vg6d_v7d_var_conv
86  TYPE(volgrid6d_var) :: vg6d_var
87  TYPE(vol7d_var) :: v7d_var
88  TYPE(conv_func) :: c_func
89 ! aggiungere informazioni ad es. su rotazione del vento
90 END TYPE vg6d_v7d_var_conv
91 
92 TYPE(vg6d_v7d_var_conv), PARAMETER :: vg6d_v7d_var_conv_miss= &
93  vg6d_v7d_var_conv(volgrid6d_var_miss, vol7d_var_miss, conv_func_miss)
94 
95 TYPE(vg6d_v7d_var_conv), ALLOCATABLE :: conv_fwd(:), conv_bwd(:)
96 
110 INTERFACE init
111  MODULE PROCEDURE volgrid6d_var_init
112 END INTERFACE
113 
116 INTERFACE delete
117  MODULE PROCEDURE volgrid6d_var_delete
118 END INTERFACE
119 
120 INTERFACE c_e
121  MODULE PROCEDURE volgrid6d_var_c_e
122 END INTERFACE
123 
124 
129 INTERFACE OPERATOR (==)
130  MODULE PROCEDURE volgrid6d_var_eq, conv_func_eq
131 END INTERFACE
132 
137 INTERFACE OPERATOR (/=)
138  MODULE PROCEDURE volgrid6d_var_ne, conv_func_ne
139 END INTERFACE
140 
141 #define VOL7D_POLY_TYPE TYPE(volgrid6d_var)
142 #define VOL7D_POLY_TYPES _var6d
143 #include "array_utilities_pre.F90"
144 
146 INTERFACE display
147  MODULE PROCEDURE display_volgrid6d_var
148 END INTERFACE
149 
154 INTERFACE OPERATOR (*)
155  MODULE PROCEDURE conv_func_mult
156 END INTERFACE OPERATOR (*)
157 
160 INTERFACE compute
161  MODULE PROCEDURE conv_func_compute
162 END INTERFACE
163 
166 INTERFACE convert
167  MODULE PROCEDURE varbufr2vargrib_convert, vargrib2varbufr_convert, &
168  conv_func_convert
169 END INTERFACE
170 
171 PRIVATE
172 PUBLIC volgrid6d_var, volgrid6d_var_miss, volgrid6d_var_new, init, delete, &
173  c_e, volgrid6d_var_normalize, &
174  OPERATOR(==), OPERATOR(/=), OPERATOR(*), &
175  count_distinct, pack_distinct, count_and_pack_distinct, &
176  map_distinct, map_inv_distinct, &
177  index, display, &
178  vargrib2varbufr, varbufr2vargrib, &
179  conv_func, conv_func_miss, compute, convert, &
180  volgrid6d_var_hor_comp_index, volgrid6d_var_is_hor_comp
181 
182 
183 CONTAINS
184 
185 
186 ELEMENTAL FUNCTION volgrid6d_var_new(centre, category, number, &
187  discipline, description, unit) RESULT(this)
188 integer,INTENT(in),OPTIONAL :: centre
189 integer,INTENT(in),OPTIONAL :: category
190 integer,INTENT(in),OPTIONAL :: number
191 integer,INTENT(in),OPTIONAL :: discipline
192 CHARACTER(len=*),INTENT(in),OPTIONAL :: description
193 CHARACTER(len=*),INTENT(in),OPTIONAL :: unit
194 
195 TYPE(volgrid6d_var) :: this
196 
197 CALL init(this, centre, category, number, discipline, description, unit)
198 
199 END FUNCTION volgrid6d_var_new
200 
201 
202 ! documented in the interface
203 ELEMENTAL SUBROUTINE volgrid6d_var_init(this, centre, category, number, discipline,description,unit)
204 TYPE(volgrid6d_var),INTENT(INOUT) :: this ! object to be initialized
205 INTEGER,INTENT(in),OPTIONAL :: centre ! centre
206 INTEGER,INTENT(in),OPTIONAL :: category ! grib2: category / grib1: grib table version number
207 INTEGER,INTENT(in),OPTIONAL :: number ! parameter number
208 INTEGER,INTENT(in),OPTIONAL :: discipline ! grib2: discipline / grib1: 255
209 CHARACTER(len=*),INTENT(in),OPTIONAL :: description ! optional textual description of the variable
210 CHARACTER(len=*),INTENT(in),OPTIONAL :: unit ! optional textual description of the variable's unit
211 
212 IF (PRESENT(centre)) THEN
213  this%centre = centre
214 ELSE
215  this%centre = imiss
216  this%category = imiss
217  this%number = imiss
218  this%discipline = imiss
219  RETURN
220 ENDIF
221 
222 IF (PRESENT(category)) THEN
223  this%category = category
224 ELSE
225  this%category = imiss
226  this%number = imiss
227  this%discipline = imiss
228  RETURN
229 ENDIF
230 
231 
232 IF (PRESENT(number)) THEN
233  this%number = number
234 ELSE
235  this%number = imiss
236  this%discipline = imiss
237  RETURN
238 ENDIF
239 
240 ! se sono arrivato fino a qui ho impostato centre, category e number
241 !per il grib 1 manca discipline e imposto 255 (missing del grib2)
242 
243 IF (PRESENT(discipline)) THEN
244  this%discipline = discipline
245 ELSE
246  this%discipline = 255
247 ENDIF
248 
249 IF (PRESENT(description)) THEN
250  this%description = description
251 ELSE
252  this%description = cmiss
253 ENDIF
254 
255 IF (PRESENT(unit)) THEN
256  this%unit = unit
257 ELSE
258  this%unit = cmiss
259 ENDIF
260 
261 
262 
263 END SUBROUTINE volgrid6d_var_init
264 
265 
266 ! documented in the interface
267 SUBROUTINE volgrid6d_var_delete(this)
268 TYPE(volgrid6d_var),INTENT(INOUT) :: this
269 
270 this%centre = imiss
271 this%category = imiss
272 this%number = imiss
273 this%discipline = imiss
274 this%description = cmiss
275 this%unit = cmiss
276 
277 END SUBROUTINE volgrid6d_var_delete
278 
279 
280 ELEMENTAL FUNCTION volgrid6d_var_c_e(this) RESULT(c_e)
281 TYPE(volgrid6d_var),INTENT(IN) :: this
282 LOGICAL :: c_e
283 c_e = this /= volgrid6d_var_miss
284 END FUNCTION volgrid6d_var_c_e
285 
286 
287 ELEMENTAL FUNCTION volgrid6d_var_eq(this, that) RESULT(res)
288 TYPE(volgrid6d_var),INTENT(IN) :: this, that
289 LOGICAL :: res
290 
291 IF (this%discipline == that%discipline) THEN
292 
293  IF (this%discipline == 255) THEN ! grib1
294  res = this%category == that%category .AND. &
295  this%number == that%number
296 
297  IF ((this%category >= 128 .AND. this%category <= 254) .OR. &
298  (this%number >= 128 .AND. this%number <= 254)) THEN
299  res = res .AND. this%centre == that%centre ! local definition, centre matters
300  ENDIF
301 
302  ELSE ! grib2
303  res = this%category == that%category .AND. &
304  this%number == that%number
305 
306  IF ((this%discipline >= 192 .AND. this%discipline <= 254) .OR. &
307  (this%category >= 192 .AND. this%category <= 254) .OR. &
308  (this%number >= 192 .AND. this%number <= 254)) THEN
309  res = res .AND. this%centre == that%centre ! local definition, centre matters
310  ENDIF
311  ENDIF
312 
313 ELSE ! different edition or different discipline
314  res = .false.
315 ENDIF
316 
317 END FUNCTION volgrid6d_var_eq
318 
319 
320 ELEMENTAL FUNCTION volgrid6d_var_ne(this, that) RESULT(res)
321 TYPE(volgrid6d_var),INTENT(IN) :: this, that
322 LOGICAL :: res
323 
324 res = .NOT.(this == that)
325 
326 END FUNCTION volgrid6d_var_ne
327 
328 
329 #include "array_utilities_inc.F90"
330 
331 
333 SUBROUTINE display_volgrid6d_var(this)
334 TYPE(volgrid6d_var),INTENT(in) :: this
335 
336 print*,"GRIDVAR: ",this%centre,this%discipline,this%category,this%number
337 
338 END SUBROUTINE display_volgrid6d_var
339 
340 
353 SUBROUTINE vargrib2varbufr(vargrib, varbufr, c_func)
354 TYPE(volgrid6d_var),INTENT(in) :: vargrib(:)
355 TYPE(vol7d_var),INTENT(out) :: varbufr(:)
356 TYPE(conv_func),POINTER :: c_func(:)
357 
358 INTEGER :: i, n, stallo
359 
360 n = min(SIZE(varbufr), SIZE(vargrib))
361 ALLOCATE(c_func(n),stat=stallo)
362 IF (stallo /= 0) THEN
363  call l4f_log(l4f_fatal,"allocating memory")
364  call raise_fatal_error()
365 ENDIF
366 
367 DO i = 1, n
368  varbufr(i) = convert(vargrib(i), c_func(i))
369 ENDDO
370 
371 END SUBROUTINE vargrib2varbufr
372 
373 
384 FUNCTION vargrib2varbufr_convert(vargrib, c_func) RESULT(convert)
385 TYPE(volgrid6d_var),INTENT(in) :: vargrib
386 TYPE(conv_func),INTENT(out),OPTIONAL :: c_func
387 TYPE(vol7d_var) :: convert
388 
389 INTEGER :: i
390 
391 IF (.NOT. ALLOCATED(conv_fwd)) CALL vg6d_v7d_var_conv_setup()
392 
393 DO i = 1, SIZE(conv_fwd)
394  IF (vargrib == conv_fwd(i)%vg6d_var) THEN
395  convert = conv_fwd(i)%v7d_var
396  IF (PRESENT(c_func)) c_func = conv_fwd(i)%c_func
397  RETURN
398  ENDIF
399 ENDDO
400 ! not found
401 convert = vol7d_var_miss
402 IF (PRESENT(c_func)) c_func = conv_func_miss
403 
404 ! set hint for backwards conversion
405 convert%gribhint(:) = (/vargrib%centre, vargrib%category, vargrib%number, &
406  vargrib%discipline/)
407 
408 CALL l4f_log(l4f_warn, 'vargrib2varbufr: variable '// &
409  trim(to_char(vargrib%centre))//':'//trim(to_char(vargrib%category))//':'// &
410  trim(to_char(vargrib%number))//':'//trim(to_char(vargrib%discipline))// &
411  ' not found in table')
412 
413 END FUNCTION vargrib2varbufr_convert
414 
415 
431 SUBROUTINE varbufr2vargrib(varbufr, vargrib, c_func, grid_id_template)
432 TYPE(vol7d_var),INTENT(in) :: varbufr(:)
433 TYPE(volgrid6d_var),INTENT(out) :: vargrib(:)
434 TYPE(conv_func),POINTER :: c_func(:)
435 TYPE(grid_id),INTENT(in),OPTIONAL :: grid_id_template
436 
437 INTEGER :: i, n, stallo
438 
439 n = min(SIZE(varbufr), SIZE(vargrib))
440 ALLOCATE(c_func(n),stat=stallo)
441 IF (stallo /= 0) THEN
442  CALL l4f_log(l4f_fatal,"allocating memory")
443  CALL raise_fatal_error()
444 ENDIF
445 
446 DO i = 1, n
447  vargrib(i) = convert(varbufr(i), c_func(i), grid_id_template)
448 ENDDO
449 
450 END SUBROUTINE varbufr2vargrib
451 
452 
466 FUNCTION varbufr2vargrib_convert(varbufr, c_func, grid_id_template) RESULT(convert)
467 TYPE(vol7d_var),INTENT(in) :: varbufr
468 TYPE(conv_func),INTENT(out),OPTIONAL :: c_func
469 TYPE(grid_id),INTENT(in),OPTIONAL :: grid_id_template
470 TYPE(volgrid6d_var) :: convert
471 
472 INTEGER :: i
473 #ifdef HAVE_LIBGRIBAPI
474 INTEGER :: gaid, editionnumber, category, centre
475 #endif
476 
477 IF (.NOT. ALLOCATED(conv_bwd)) CALL vg6d_v7d_var_conv_setup()
478 
479 #ifdef HAVE_LIBGRIBAPI
480 editionnumber=255; category=255; centre=255
481 #endif
482 IF (PRESENT(grid_id_template)) THEN
483 #ifdef HAVE_LIBGRIBAPI
484  gaid = grid_id_get_gaid(grid_id_template)
485  IF (c_e(gaid)) THEN
486  CALL grib_get(gaid, 'GRIBEditionNumber', editionnumber)
487  IF (editionnumber == 1) THEN
488  CALL grib_get(gaid,'gribTablesVersionNo',category)
489  ENDIF
490  CALL grib_get(gaid,'centre',centre)
491  ENDIF
492 #endif
493 ENDIF
494 
495 DO i = 1, SIZE(conv_bwd)
496  IF (varbufr == conv_bwd(i)%v7d_var) THEN
497 #ifdef HAVE_LIBGRIBAPI
498  IF (editionnumber /= 255) THEN ! further check required (gaid present)
499  IF (editionnumber == 1) THEN
500  IF (conv_bwd(i)%vg6d_var%discipline /= 255) cycle ! wrong edition
501  ELSE IF (editionnumber == 2) THEN
502  IF (conv_bwd(i)%vg6d_var%discipline == 255) cycle ! wrong edition
503  ENDIF
504  IF (conv_bwd(i)%vg6d_var%centre /= 255 .AND. &
505  conv_bwd(i)%vg6d_var%centre /= centre) cycle ! wrong centre
506  ENDIF
507 #endif
508  convert = conv_bwd(i)%vg6d_var
509  IF (PRESENT(c_func)) c_func = conv_bwd(i)%c_func
510  RETURN
511  ENDIF
512 ENDDO
513 ! not found
514 convert = volgrid6d_var_miss
515 IF (PRESENT(c_func)) c_func = conv_func_miss
516 
517 ! if hint available use it as a fallback
518 IF (any(varbufr%gribhint /= imiss)) THEN
519  convert%centre = varbufr%gribhint(1)
520  convert%category = varbufr%gribhint(2)
521  convert%number = varbufr%gribhint(3)
522  convert%discipline = varbufr%gribhint(4)
523 ENDIF
524 
525 CALL l4f_log(l4f_warn, 'varbufr2vargrib: variable '// &
526  trim(varbufr%btable)//" : "//trim(varbufr%description)//" : "//trim(varbufr%unit)// &
527  ' not found in table')
528 
529 END FUNCTION varbufr2vargrib_convert
530 
531 
539 SUBROUTINE volgrid6d_var_normalize(this, c_func, grid_id_template)
540 TYPE(volgrid6d_var),INTENT(inout) :: this
541 TYPE(conv_func),INTENT(out) :: c_func
542 TYPE(grid_id),INTENT(in) :: grid_id_template
543 
544 LOGICAL :: eqed, eqcentre
545 INTEGER :: gaid, editionnumber, centre
546 TYPE(volgrid6d_var) :: tmpgrib
547 TYPE(vol7d_var) :: tmpbufr
548 TYPE(conv_func) tmpc_func1, tmpc_func2
549 
550 eqed = .true.
551 eqcentre = .true.
552 c_func = conv_func_miss
553 
554 #ifdef HAVE_LIBGRIBAPI
555 gaid = grid_id_get_gaid(grid_id_template)
556 IF (c_e(gaid)) THEN
557  CALL grib_get(gaid, 'GRIBEditionNumber', editionnumber)
558  CALL grib_get(gaid, 'centre', centre)
559  eqed = editionnumber == 1 .EQV. this%discipline == 255
560  eqcentre = centre == this%centre
561 ENDIF
562 #endif
563 
564 IF (eqed .AND. eqcentre) RETURN ! nothing to do
565 
566 tmpbufr = convert(this, tmpc_func1)
567 tmpgrib = convert(tmpbufr, tmpc_func2, grid_id_template)
568 
569 IF (tmpgrib /= volgrid6d_var_miss) THEN
570 ! conversion back and forth successful, set also conversion function
571  this = tmpgrib
572  c_func = tmpc_func1 * tmpc_func2
573 ! set to missing in common case to avoid useless computation
574  IF (c_func == conv_func_identity) c_func = conv_func_miss
575 ELSE IF (.NOT.eqed) THEN
576 ! conversion back and forth unsuccessful and grib edition incompatible, set to miss
577  this = tmpgrib
578 ENDIF
579 
580 END SUBROUTINE volgrid6d_var_normalize
581 
582 
583 ! Private subroutine for reading forward and backward conversion tables
584 ! todo: better error handling
585 SUBROUTINE vg6d_v7d_var_conv_setup()
586 INTEGER :: un, i, n, stallo
587 
588 ! forward, grib to bufr
589 un = open_package_file('vargrib2bufr.csv', filetype_data)
590 n=0
591 DO WHILE(.true.)
592  READ(un,*,END=100)
593  n = n + 1
594 ENDDO
595 
596 100 CONTINUE
597 
598 rewind(un)
599 ALLOCATE(conv_fwd(n),stat=stallo)
600 IF (stallo /= 0) THEN
601  CALL l4f_log(l4f_fatal,"allocating memory")
602  CALL raise_fatal_error()
603 ENDIF
604 
605 conv_fwd(:) = vg6d_v7d_var_conv_miss
606 CALL import_var_conv(un, conv_fwd)
607 CLOSE(un)
608 
609 ! backward, bufr to grib
610 un = open_package_file('vargrib2bufr.csv', filetype_data)
611 ! use the same file for now
612 !un = open_package_file('varbufr2grib.csv', filetype_data)
613 n=0
614 DO WHILE(.true.)
615  READ(un,*,END=300)
616  n = n + 1
617 ENDDO
618 
619 300 CONTINUE
620 
621 rewind(un)
622 ALLOCATE(conv_bwd(n),stat=stallo)
623 IF (stallo /= 0) THEN
624  CALL l4f_log(l4f_fatal,"allocating memory")
625  CALL raise_fatal_error()
626 end if
627 
628 conv_bwd(:) = vg6d_v7d_var_conv_miss
629 CALL import_var_conv(un, conv_bwd)
630 DO i = 1, n
631  conv_bwd(i)%c_func%a = 1./conv_bwd(i)%c_func%a
632  conv_bwd(i)%c_func%b = - conv_bwd(i)%c_func%b
633 ENDDO
634 CLOSE(un)
635 
636 CONTAINS
637 
638 SUBROUTINE import_var_conv(un, conv_type)
639 INTEGER, INTENT(in) :: un
640 TYPE(vg6d_v7d_var_conv), INTENT(out) :: conv_type(:)
641 
642 INTEGER :: i
643 TYPE(csv_record) :: csv
644 CHARACTER(len=1024) :: line
645 CHARACTER(len=10) :: btable
646 INTEGER :: centre, category, number, discipline
647 
648 DO i = 1, SIZE(conv_type)
649  READ(un,'(A)',END=200)line
650  CALL init(csv, line)
651  CALL csv_record_getfield(csv, btable)
652  CALL csv_record_getfield(csv) ! skip fields for description and unit,
653  CALL csv_record_getfield(csv) ! they correspond to grib information, not bufr Btable
654  CALL init(conv_type(i)%v7d_var, btable=btable)
655 
656  CALL csv_record_getfield(csv, centre)
657  CALL csv_record_getfield(csv, category)
658  CALL csv_record_getfield(csv, number)
659  CALL csv_record_getfield(csv, discipline)
660  CALL init(conv_type(i)%vg6d_var, centre=centre, category=category, &
661  number=number, discipline=discipline) ! controllare l'ordine
662 
663  CALL csv_record_getfield(csv, conv_type(i)%c_func%a)
664  CALL csv_record_getfield(csv, conv_type(i)%c_func%b)
665  CALL delete(csv)
666 ENDDO
667 
668 200 CONTINUE
669 
670 END SUBROUTINE import_var_conv
671 
672 END SUBROUTINE vg6d_v7d_var_conv_setup
673 
674 
675 ELEMENTAL FUNCTION conv_func_eq(this, that) RESULT(res)
676 TYPE(conv_func),INTENT(IN) :: this, that
677 LOGICAL :: res
678 
679 res = this%a == that%a .AND. this%b == that%b
680 
681 END FUNCTION conv_func_eq
682 
683 
684 ELEMENTAL FUNCTION conv_func_ne(this, that) RESULT(res)
685 TYPE(conv_func),INTENT(IN) :: this, that
686 LOGICAL :: res
687 
688 res = .NOT.(this == that)
689 
690 END FUNCTION conv_func_ne
691 
692 
693 FUNCTION conv_func_mult(this, that) RESULT(mult)
694 TYPE(conv_func),INTENT(in) :: this
695 TYPE(conv_func),INTENT(in) :: that
696 
697 TYPE(conv_func) :: mult
698 
699 IF (this == conv_func_miss .OR. that == conv_func_miss) THEN
700  mult = conv_func_miss
701 ELSE
702  mult%a = this%a*that%a
703  mult%b = this%a*that%b+this%b
704 ENDIF
705 
706 END FUNCTION conv_func_mult
707 
715 ELEMENTAL SUBROUTINE conv_func_compute(this, values)
716 TYPE(conv_func),INTENT(in) :: this
717 REAL,INTENT(inout) :: values
718 
719 IF (this /= conv_func_miss) THEN
720  IF (c_e(values)) values = values*this%a + this%b
721 ELSE
722  values=rmiss
723 ENDIF
724 
725 END SUBROUTINE conv_func_compute
726 
727 
735 ELEMENTAL FUNCTION conv_func_convert(this, values) RESULT(convert)
736 TYPE(conv_func),intent(in) :: this
737 REAL,INTENT(in) :: values
738 REAL :: convert
739 
740 convert = values
741 CALL compute(this, convert)
742 
743 END FUNCTION conv_func_convert
744 
745 
759 SUBROUTINE volgrid6d_var_hor_comp_index(this, xind, yind)
760 TYPE(volgrid6d_var),INTENT(in) :: this(:)
761 INTEGER,POINTER :: xind(:), yind(:)
762 
763 TYPE(vol7d_var) :: varbufr(size(this))
764 TYPE(conv_func),POINTER :: c_func(:)
765 INTEGER :: i, nv, counts(size(vol7d_var_horcomp))
766 
767 NULLIFY(xind, yind)
768 counts(:) = 0
769 
770 CALL vargrib2varbufr(this, varbufr, c_func)
771 
772 DO i = 1, SIZE(vol7d_var_horcomp)
773  counts(i) = count(varbufr(:) == vol7d_var_horcomp(i))
774 ENDDO
775 
776 IF (any(counts(1::2) > 1)) THEN
777  CALL l4f_log(l4f_warn, '> 1 variable refer to x component of the same field, (un)rotation impossible')
778  DEALLOCATE(c_func)
779  RETURN
780 ENDIF
781 IF (any(counts(2::2) > 1)) THEN
782  CALL l4f_log(l4f_warn, '> 1 variable refer to y component of the same field, (un)rotation impossible')
783  DEALLOCATE(c_func)
784  RETURN
785 ENDIF
786 
787 ! check that variables are paired and count pairs
788 nv = 0
789 DO i = 1, SIZE(vol7d_var_horcomp), 2
790  IF (counts(i) == 0 .AND. counts(i+1) > 0) THEN
791  CALL l4f_log(l4f_warn, 'variable '//trim(vol7d_var_horcomp(i+1)%btable)// &
792  ' present but the corresponding x-component '// &
793  trim(vol7d_var_horcomp(i)%btable)//' is missing, (un)rotation impossible')
794  RETURN
795  ELSE IF (counts(i+1) == 0 .AND. counts(i) > 0) THEN
796  CALL l4f_log(l4f_warn, 'variable '//trim(vol7d_var_horcomp(i)%btable)// &
797  ' present but the corresponding y-component '// &
798  trim(vol7d_var_horcomp(i+1)%btable)//' is missing, (un)rotation impossible')
799  RETURN
800  ENDIF
801  IF (counts(i) == 1 .AND. counts(i+1) == 1) nv = nv + 1
802 ENDDO
803 
804 ! repeat the loop storing indices
805 ALLOCATE(xind(nv), yind(nv))
806 nv = 0
807 DO i = 1, SIZE(vol7d_var_horcomp), 2
808  IF (counts(i) == 1 .AND. counts(i+1) == 1) THEN
809  nv = nv + 1
810  xind(nv) = index(varbufr(:), vol7d_var_horcomp(i))
811  yind(nv) = index(varbufr(:), vol7d_var_horcomp(i+1))
812  ENDIF
813 ENDDO
814 DEALLOCATE(c_func)
815 
816 END SUBROUTINE volgrid6d_var_hor_comp_index
817 
818 
823 FUNCTION volgrid6d_var_is_hor_comp(this) RESULT(is_hor_comp)
824 TYPE(volgrid6d_var),INTENT(in) :: this
825 LOGICAL :: is_hor_comp
826 
827 TYPE(vol7d_var) :: varbufr
828 
829 varbufr = convert(this)
830 is_hor_comp = any(varbufr == vol7d_var_horcomp(:))
831 
832 END FUNCTION volgrid6d_var_is_hor_comp
833 
834 ! before unstaggering??
835 
836 !IF (.NOT. ALLOCATED(conv_fwd)) CALL vg6d_v7d_var_conv_setup()
837 !
838 !call init(varu,btable="B11003")
839 !call init(varv,btable="B11004")
840 !
841 ! test about presence of u and v in standard table
842 !if ( index(conv_fwd(:)%v7d_var,varu) == 0 .or. index(conv_fwd(:)%v7d_var,varv) == 0 )then
843 ! call l4f_category_log(this%category,L4F_FATAL, &
844 ! "variables B11003 and/or B11004 (wind components) not defined by vg6d_v7d_var_conv_setup")
845 ! CALL raise_error()
846 ! RETURN
847 !end if
848 !
849 !if (associated(this%var))then
850 ! nvar=size(this%var)
851 ! allocate(varbufr(nvar),stat=stallo)
852 ! if (stallo /=0)then
853 ! call l4f_log(L4F_FATAL,"allocating memory")
854 ! call raise_fatal_error("allocating memory")
855 ! end if
856 !
857 ! CALL vargrib2varbufr(this%var, varbufr)
858 !ELSE
859 ! CALL l4f_category_log(this%category, L4F_ERROR, &
860 ! "trying to destagger an incomplete volgrid6d object")
861 ! CALL raise_error()
862 ! RETURN
863 !end if
864 !
865 !nvaru=COUNT(varbufr==varu)
866 !nvarv=COUNT(varbufr==varv)
867 !
868 !if (nvaru > 1 )then
869 ! call l4f_category_log(this%category,L4F_WARN, &
870 ! ">1 variables refer to u wind component, destaggering will not be done ")
871 ! DEALLOCATE(varbufr)
872 ! RETURN
873 !endif
874 !
875 !if (nvarv > 1 )then
876 ! call l4f_category_log(this%category,L4F_WARN, &
877 ! ">1 variables refer to v wind component, destaggering will not be done ")
878 ! DEALLOCATE(varbufr)
879 ! RETURN
880 !endif
881 !
882 !if (nvaru == 0 .and. nvarv == 0) then
883 ! call l4f_category_log(this%category,L4F_WARN, &
884 ! "no u or v wind component found in volume, nothing to do")
885 ! DEALLOCATE(varbufr)
886 ! RETURN
887 !endif
888 !
889 !if (COUNT(varbufr/=varu .and. varbufr/=varv) > 0) then
890 ! call l4f_category_log(this%category,L4F_WARN, &
891 ! "there are variables different from u and v wind component in C grid")
892 !endif
893 
894 
895 END MODULE volgrid6d_var_class
Index method.
Apply the conversion function this to values.
Apply the conversion function this to values.
Destructor for the corresponding object, it assigns it to a missing value.
Display on the screen a brief content of object.
Initialize a volgrid6d_var object with the optional arguments provided.
Gestione degli errori.
Utilities for managing files.
This module defines an abstract interface to different drivers for access to files containing gridded...
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 delle variabili osservate da stazioni meteo e affini.
Class for managing physical variables in a grib 1/2 fashion.
Definisce una variabile meteorologica osservata o un suo attributo.
Class defining a real conversion function between units.
Definition of a physical variable in grib coding style.

Generated with Doxygen.