libsim  Versione7.2.1
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)
243 IF (PRESENT(discipline)) THEN
244  this%discipline = discipline
245 ELSE
246  this%discipline = 255
247 ENDIF
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, WMO tables are all equivalent
294  res = ((this%category == that%category) .OR. &
295  (this%category >= 1 .AND. this%category <=3 .AND. &
296  that%category >= 1 .AND. that%category <=3)) .AND. &
297  this%number == that%number
298 
299  IF ((this%category >= 128 .AND. this%category <= 254) .OR. &
300  (this%number >= 128 .AND. this%number <= 254)) THEN
301  res = res .AND. this%centre == that%centre ! local definition, centre matters
302  ENDIF
303 
304  ELSE ! grib2
305  res = this%category == that%category .AND. &
306  this%number == that%number
307 
308  IF ((this%discipline >= 192 .AND. this%discipline <= 254) .OR. &
309  (this%category >= 192 .AND. this%category <= 254) .OR. &
310  (this%number >= 192 .AND. this%number <= 254)) THEN
311  res = res .AND. this%centre == that%centre ! local definition, centre matters
312  ENDIF
313  ENDIF
315 ELSE ! different edition or different discipline
316  res = .false.
317 ENDIF
318 
319 END FUNCTION volgrid6d_var_eq
320 
321 
322 ELEMENTAL FUNCTION volgrid6d_var_ne(this, that) RESULT(res)
323 TYPE(volgrid6d_var),INTENT(IN) :: this, that
324 LOGICAL :: res
325 
326 res = .NOT.(this == that)
328 END FUNCTION volgrid6d_var_ne
329 
330 
331 #include "array_utilities_inc.F90"
332 
333 
335 SUBROUTINE display_volgrid6d_var(this)
336 TYPE(volgrid6d_var),INTENT(in) :: this
337 
338 print*,"GRIDVAR: ",this%centre,this%discipline,this%category,this%number
339 
340 END SUBROUTINE display_volgrid6d_var
341 
342 
355 SUBROUTINE vargrib2varbufr(vargrib, varbufr, c_func)
356 TYPE(volgrid6d_var),INTENT(in) :: vargrib(:)
357 TYPE(vol7d_var),INTENT(out) :: varbufr(:)
358 TYPE(conv_func),POINTER :: c_func(:)
359 
360 INTEGER :: i, n, stallo
361 
362 n = min(SIZE(varbufr), SIZE(vargrib))
363 ALLOCATE(c_func(n),stat=stallo)
364 IF (stallo /= 0) THEN
365  call l4f_log(l4f_fatal,"allocating memory")
366  call raise_fatal_error()
367 ENDIF
368 
369 DO i = 1, n
370  varbufr(i) = convert(vargrib(i), c_func(i))
371 ENDDO
372 
373 END SUBROUTINE vargrib2varbufr
374 
375 
386 FUNCTION vargrib2varbufr_convert(vargrib, c_func) RESULT(convert)
387 TYPE(volgrid6d_var),INTENT(in) :: vargrib
388 TYPE(conv_func),INTENT(out),OPTIONAL :: c_func
389 TYPE(vol7d_var) :: convert
390 
391 INTEGER :: i
392 
393 IF (.NOT. ALLOCATED(conv_fwd)) CALL vg6d_v7d_var_conv_setup()
395 DO i = 1, SIZE(conv_fwd)
396  IF (vargrib == conv_fwd(i)%vg6d_var) THEN
397  convert = conv_fwd(i)%v7d_var
398  IF (PRESENT(c_func)) c_func = conv_fwd(i)%c_func
399  RETURN
400  ENDIF
401 ENDDO
402 ! not found
403 convert = vol7d_var_miss
404 IF (PRESENT(c_func)) c_func = conv_func_miss
405 
406 ! set hint for backwards conversion
407 convert%gribhint(:) = (/vargrib%centre, vargrib%category, vargrib%number, &
408  vargrib%discipline/)
409 
410 CALL l4f_log(l4f_warn, 'vargrib2varbufr: variable '// &
411  trim(to_char(vargrib%centre))//':'//trim(to_char(vargrib%category))//':'// &
412  trim(to_char(vargrib%number))//':'//trim(to_char(vargrib%discipline))// &
413  ' not found in table')
414 
415 END FUNCTION vargrib2varbufr_convert
416 
417 
433 SUBROUTINE varbufr2vargrib(varbufr, vargrib, c_func, grid_id_template)
434 TYPE(vol7d_var),INTENT(in) :: varbufr(:)
435 TYPE(volgrid6d_var),INTENT(out) :: vargrib(:)
436 TYPE(conv_func),POINTER :: c_func(:)
437 TYPE(grid_id),INTENT(in),OPTIONAL :: grid_id_template
438 
439 INTEGER :: i, n, stallo
440 
441 n = min(SIZE(varbufr), SIZE(vargrib))
442 ALLOCATE(c_func(n),stat=stallo)
443 IF (stallo /= 0) THEN
444  CALL l4f_log(l4f_fatal,"allocating memory")
445  CALL raise_fatal_error()
446 ENDIF
447 
448 DO i = 1, n
449  vargrib(i) = convert(varbufr(i), c_func(i), grid_id_template)
450 ENDDO
451 
452 END SUBROUTINE varbufr2vargrib
453 
454 
468 FUNCTION varbufr2vargrib_convert(varbufr, c_func, grid_id_template) RESULT(convert)
469 TYPE(vol7d_var),INTENT(in) :: varbufr
470 TYPE(conv_func),INTENT(out),OPTIONAL :: c_func
471 TYPE(grid_id),INTENT(in),OPTIONAL :: grid_id_template
472 TYPE(volgrid6d_var) :: convert
473 
474 INTEGER :: i
475 #ifdef HAVE_LIBGRIBAPI
476 INTEGER :: gaid, editionnumber, category, centre
477 #endif
478 
479 IF (.NOT. ALLOCATED(conv_bwd)) CALL vg6d_v7d_var_conv_setup()
480 
481 #ifdef HAVE_LIBGRIBAPI
482 editionnumber=255; category=255; centre=255
483 #endif
484 IF (PRESENT(grid_id_template)) THEN
485 #ifdef HAVE_LIBGRIBAPI
486  gaid = grid_id_get_gaid(grid_id_template)
487  IF (c_e(gaid)) THEN
488  CALL grib_get(gaid, 'GRIBEditionNumber', editionnumber)
489  IF (editionnumber == 1) THEN
490  CALL grib_get(gaid,'gribTablesVersionNo',category)
491  ENDIF
492  CALL grib_get(gaid,'centre',centre)
493  ENDIF
494 #endif
495 ENDIF
496 
497 DO i = 1, SIZE(conv_bwd)
498  IF (varbufr == conv_bwd(i)%v7d_var) THEN
499 #ifdef HAVE_LIBGRIBAPI
500  IF (editionnumber /= 255) THEN ! further check required (gaid present)
501  IF (editionnumber == 1) THEN
502  IF (conv_bwd(i)%vg6d_var%discipline /= 255) cycle ! wrong edition
503  ELSE IF (editionnumber == 2) THEN
504  IF (conv_bwd(i)%vg6d_var%discipline == 255) cycle ! wrong edition
505  ENDIF
506  IF (conv_bwd(i)%vg6d_var%centre /= 255 .AND. &
507  conv_bwd(i)%vg6d_var%centre /= centre) cycle ! wrong centre
508  ENDIF
509 #endif
510  convert = conv_bwd(i)%vg6d_var
511  IF (PRESENT(c_func)) c_func = conv_bwd(i)%c_func
512  RETURN
513  ENDIF
514 ENDDO
515 ! not found
516 convert = volgrid6d_var_miss
517 IF (PRESENT(c_func)) c_func = conv_func_miss
518 
519 ! if hint available use it as a fallback
520 IF (any(varbufr%gribhint /= imiss)) THEN
521  convert%centre = varbufr%gribhint(1)
522  convert%category = varbufr%gribhint(2)
523  convert%number = varbufr%gribhint(3)
524  convert%discipline = varbufr%gribhint(4)
525 ENDIF
526 
527 CALL l4f_log(l4f_warn, 'varbufr2vargrib: variable '// &
528  trim(varbufr%btable)//" : "//trim(varbufr%description)//" : "//trim(varbufr%unit)// &
529  ' not found in table')
530 
531 END FUNCTION varbufr2vargrib_convert
532 
533 
541 SUBROUTINE volgrid6d_var_normalize(this, c_func, grid_id_template)
542 TYPE(volgrid6d_var),INTENT(inout) :: this
543 TYPE(conv_func),INTENT(out) :: c_func
544 TYPE(grid_id),INTENT(in) :: grid_id_template
545 
546 LOGICAL :: eqed, eqcentre
547 INTEGER :: gaid, editionnumber, centre
548 TYPE(volgrid6d_var) :: tmpgrib
549 TYPE(vol7d_var) :: tmpbufr
550 TYPE(conv_func) tmpc_func1, tmpc_func2
551 
552 eqed = .true.
553 eqcentre = .true.
554 c_func = conv_func_miss
555 
556 #ifdef HAVE_LIBGRIBAPI
557 gaid = grid_id_get_gaid(grid_id_template)
558 IF (c_e(gaid)) THEN
559  CALL grib_get(gaid, 'GRIBEditionNumber', editionnumber)
560  CALL grib_get(gaid, 'centre', centre)
561  eqed = editionnumber == 1 .EQV. this%discipline == 255
562  eqcentre = centre == this%centre
563 ENDIF
564 #endif
565 
566 IF (eqed .AND. eqcentre) RETURN ! nothing to do
567 
568 tmpbufr = convert(this, tmpc_func1)
569 tmpgrib = convert(tmpbufr, tmpc_func2, grid_id_template)
570 
571 IF (tmpgrib /= volgrid6d_var_miss) THEN
572 ! conversion back and forth successful, set also conversion function
573  this = tmpgrib
574  c_func = tmpc_func1 * tmpc_func2
575 ! set to missing in common case to avoid useless computation
576  IF (c_func == conv_func_identity) c_func = conv_func_miss
577 ELSE IF (.NOT.eqed) THEN
578 ! conversion back and forth unsuccessful and grib edition incompatible, set to miss
579  this = tmpgrib
580 ENDIF
581 
582 END SUBROUTINE volgrid6d_var_normalize
583 
584 
585 ! Private subroutine for reading forward and backward conversion tables
586 ! todo: better error handling
587 SUBROUTINE vg6d_v7d_var_conv_setup()
588 INTEGER :: un, i, n, stallo
589 
590 ! forward, grib to bufr
591 un = open_package_file('vargrib2bufr.csv', filetype_data)
592 n=0
593 DO WHILE(.true.)
594  READ(un,*,end=100)
595  n = n + 1
596 ENDDO
597 
598 100 CONTINUE
599 
600 rewind(un)
601 ALLOCATE(conv_fwd(n),stat=stallo)
602 IF (stallo /= 0) THEN
603  CALL l4f_log(l4f_fatal,"allocating memory")
604  CALL raise_fatal_error()
605 ENDIF
606 
607 conv_fwd(:) = vg6d_v7d_var_conv_miss
608 CALL import_var_conv(un, conv_fwd)
609 CLOSE(un)
610 
611 ! backward, bufr to grib
612 un = open_package_file('vargrib2bufr.csv', filetype_data)
613 ! use the same file for now
614 !un = open_package_file('varbufr2grib.csv', filetype_data)
615 n=0
616 DO WHILE(.true.)
617  READ(un,*,end=300)
618  n = n + 1
619 ENDDO
620 
621 300 CONTINUE
622 
623 rewind(un)
624 ALLOCATE(conv_bwd(n),stat=stallo)
625 IF (stallo /= 0) THEN
626  CALL l4f_log(l4f_fatal,"allocating memory")
627  CALL raise_fatal_error()
628 end if
629 
630 conv_bwd(:) = vg6d_v7d_var_conv_miss
631 CALL import_var_conv(un, conv_bwd)
632 DO i = 1, n
633  conv_bwd(i)%c_func%a = 1./conv_bwd(i)%c_func%a
634  conv_bwd(i)%c_func%b = - conv_bwd(i)%c_func%b
635 ENDDO
636 CLOSE(un)
637 
638 CONTAINS
639 
640 SUBROUTINE import_var_conv(un, conv_type)
641 INTEGER, INTENT(in) :: un
642 TYPE(vg6d_v7d_var_conv), INTENT(out) :: conv_type(:)
643 
644 INTEGER :: i
645 TYPE(csv_record) :: csv
646 CHARACTER(len=1024) :: line
647 CHARACTER(len=10) :: btable
648 INTEGER :: centre, category, number, discipline
649 
650 DO i = 1, SIZE(conv_type)
651  READ(un,'(A)',end=200)line
652  CALL init(csv, line)
653  CALL csv_record_getfield(csv, btable)
654  CALL csv_record_getfield(csv) ! skip fields for description and unit,
655  CALL csv_record_getfield(csv) ! they correspond to grib information, not bufr Btable
656  CALL init(conv_type(i)%v7d_var, btable=btable)
657 
658  CALL csv_record_getfield(csv, centre)
659  CALL csv_record_getfield(csv, category)
660  CALL csv_record_getfield(csv, number)
661  CALL csv_record_getfield(csv, discipline)
662  CALL init(conv_type(i)%vg6d_var, centre=centre, category=category, &
663  number=number, discipline=discipline) ! controllare l'ordine
664 
665  CALL csv_record_getfield(csv, conv_type(i)%c_func%a)
666  CALL csv_record_getfield(csv, conv_type(i)%c_func%b)
667  CALL delete(csv)
668 ENDDO
669 
670 200 CONTINUE
671 
672 END SUBROUTINE import_var_conv
673 
674 END SUBROUTINE vg6d_v7d_var_conv_setup
675 
676 
677 ELEMENTAL FUNCTION conv_func_eq(this, that) RESULT(res)
678 TYPE(conv_func),INTENT(IN) :: this, that
679 LOGICAL :: res
680 
681 res = this%a == that%a .AND. this%b == that%b
682 
683 END FUNCTION conv_func_eq
684 
685 
686 ELEMENTAL FUNCTION conv_func_ne(this, that) RESULT(res)
687 TYPE(conv_func),INTENT(IN) :: this, that
688 LOGICAL :: res
689 
690 res = .NOT.(this == that)
691 
692 END FUNCTION conv_func_ne
693 
694 
695 FUNCTION conv_func_mult(this, that) RESULT(mult)
696 TYPE(conv_func),INTENT(in) :: this
697 TYPE(conv_func),INTENT(in) :: that
698 
699 TYPE(conv_func) :: mult
700 
701 IF (this == conv_func_miss .OR. that == conv_func_miss) THEN
702  mult = conv_func_miss
703 ELSE
704  mult%a = this%a*that%a
705  mult%b = this%a*that%b+this%b
706 ENDIF
707 
708 END FUNCTION conv_func_mult
709 
717 ELEMENTAL SUBROUTINE conv_func_compute(this, values)
718 TYPE(conv_func),INTENT(in) :: this
719 REAL,INTENT(inout) :: values
720 
721 IF (this /= conv_func_miss) THEN
722  IF (c_e(values)) values = values*this%a + this%b
723 ELSE
724  values=rmiss
725 ENDIF
726 
727 END SUBROUTINE conv_func_compute
728 
729 
737 ELEMENTAL FUNCTION conv_func_convert(this, values) RESULT(convert)
738 TYPE(conv_func),intent(in) :: this
739 REAL,INTENT(in) :: values
740 REAL :: convert
741 
742 convert = values
743 CALL compute(this, convert)
744 
745 END FUNCTION conv_func_convert
746 
747 
761 SUBROUTINE volgrid6d_var_hor_comp_index(this, xind, yind)
762 TYPE(volgrid6d_var),INTENT(in) :: this(:)
763 INTEGER,POINTER :: xind(:), yind(:)
764 
765 TYPE(vol7d_var) :: varbufr(size(this))
766 TYPE(conv_func),POINTER :: c_func(:)
767 INTEGER :: i, nv, counts(size(vol7d_var_horcomp))
768 
769 NULLIFY(xind, yind)
770 counts(:) = 0
771 
772 CALL vargrib2varbufr(this, varbufr, c_func)
773 
774 DO i = 1, SIZE(vol7d_var_horcomp)
775  counts(i) = count(varbufr(:) == vol7d_var_horcomp(i))
776 ENDDO
777 
778 IF (any(counts(1::2) > 1)) THEN
779  CALL l4f_log(l4f_warn, '> 1 variable refer to x component of the same field, (un)rotation impossible')
780  DEALLOCATE(c_func)
781  RETURN
782 ENDIF
783 IF (any(counts(2::2) > 1)) THEN
784  CALL l4f_log(l4f_warn, '> 1 variable refer to y component of the same field, (un)rotation impossible')
785  DEALLOCATE(c_func)
786  RETURN
787 ENDIF
788 
789 ! check that variables are paired and count pairs
790 nv = 0
791 DO i = 1, SIZE(vol7d_var_horcomp), 2
792  IF (counts(i) == 0 .AND. counts(i+1) > 0) THEN
793  CALL l4f_log(l4f_warn, 'variable '//trim(vol7d_var_horcomp(i+1)%btable)// &
794  ' present but the corresponding x-component '// &
795  trim(vol7d_var_horcomp(i)%btable)//' is missing, (un)rotation impossible')
796  RETURN
797  ELSE IF (counts(i+1) == 0 .AND. counts(i) > 0) THEN
798  CALL l4f_log(l4f_warn, 'variable '//trim(vol7d_var_horcomp(i)%btable)// &
799  ' present but the corresponding y-component '// &
800  trim(vol7d_var_horcomp(i+1)%btable)//' is missing, (un)rotation impossible')
801  RETURN
802  ENDIF
803  IF (counts(i) == 1 .AND. counts(i+1) == 1) nv = nv + 1
804 ENDDO
805 
806 ! repeat the loop storing indices
807 ALLOCATE(xind(nv), yind(nv))
808 nv = 0
809 DO i = 1, SIZE(vol7d_var_horcomp), 2
810  IF (counts(i) == 1 .AND. counts(i+1) == 1) THEN
811  nv = nv + 1
812  xind(nv) = index(varbufr(:), vol7d_var_horcomp(i))
813  yind(nv) = index(varbufr(:), vol7d_var_horcomp(i+1))
814  ENDIF
815 ENDDO
816 DEALLOCATE(c_func)
817 
818 END SUBROUTINE volgrid6d_var_hor_comp_index
819 
820 
825 FUNCTION volgrid6d_var_is_hor_comp(this) RESULT(is_hor_comp)
826 TYPE(volgrid6d_var),INTENT(in) :: this
827 LOGICAL :: is_hor_comp
828 
829 TYPE(vol7d_var) :: varbufr
830 
831 varbufr = convert(this)
832 is_hor_comp = any(varbufr == vol7d_var_horcomp(:))
833 
834 END FUNCTION volgrid6d_var_is_hor_comp
835 
836 ! before unstaggering??
837 
838 !IF (.NOT. ALLOCATED(conv_fwd)) CALL vg6d_v7d_var_conv_setup()
839 !
840 !call init(varu,btable="B11003")
841 !call init(varv,btable="B11004")
842 !
843 ! test about presence of u and v in standard table
844 !if ( index(conv_fwd(:)%v7d_var,varu) == 0 .or. index(conv_fwd(:)%v7d_var,varv) == 0 )then
845 ! call l4f_category_log(this%category,L4F_FATAL, &
846 ! "variables B11003 and/or B11004 (wind components) not defined by vg6d_v7d_var_conv_setup")
847 ! CALL raise_error()
848 ! RETURN
849 !end if
850 !
851 !if (associated(this%var))then
852 ! nvar=size(this%var)
853 ! allocate(varbufr(nvar),stat=stallo)
854 ! if (stallo /=0)then
855 ! call l4f_log(L4F_FATAL,"allocating memory")
856 ! call raise_fatal_error("allocating memory")
857 ! end if
858 !
859 ! CALL vargrib2varbufr(this%var, varbufr)
860 !ELSE
861 ! CALL l4f_category_log(this%category, L4F_ERROR, &
862 ! "trying to destagger an incomplete volgrid6d object")
863 ! CALL raise_error()
864 ! RETURN
865 !end if
866 !
867 !nvaru=COUNT(varbufr==varu)
868 !nvarv=COUNT(varbufr==varv)
869 !
870 !if (nvaru > 1 )then
871 ! call l4f_category_log(this%category,L4F_WARN, &
872 ! ">1 variables refer to u wind component, destaggering will not be done ")
873 ! DEALLOCATE(varbufr)
874 ! RETURN
875 !endif
876 !
877 !if (nvarv > 1 )then
878 ! call l4f_category_log(this%category,L4F_WARN, &
879 ! ">1 variables refer to v wind component, destaggering will not be done ")
880 ! DEALLOCATE(varbufr)
881 ! RETURN
882 !endif
883 !
884 !if (nvaru == 0 .and. nvarv == 0) then
885 ! call l4f_category_log(this%category,L4F_WARN, &
886 ! "no u or v wind component found in volume, nothing to do")
887 ! DEALLOCATE(varbufr)
888 ! RETURN
889 !endif
890 !
891 !if (COUNT(varbufr/=varu .and. varbufr/=varv) > 0) then
892 ! call l4f_category_log(this%category,L4F_WARN, &
893 ! "there are variables different from u and v wind component in C grid")
894 !endif
895 
896 
897 END MODULE volgrid6d_var_class
Represent level object in a pretty string.
Definition of a physical variable in grib coding style.
This module defines an abstract interface to different drivers for access to files containing gridded...
Apply the conversion function this to values.
Display on the screen a brief content of object.
Utilities for managing files.
Methods for successively obtaining the fields of a csv_record object.
Classe per la gestione delle variabili osservate da stazioni meteo e affini.
Initialize a volgrid6d_var object with the optional arguments provided.
Destructor for the corresponding object, it assigns it to a missing value.
Index method.
Gestione degli errori.
Definitions of constants and functions for working with missing values.
Class for interpreting the records of a csv file.
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.
Apply the conversion function this to values.
Definition of constants to be used for declaring variables of a desired type.
Definition: kinds.F90:255

Generated with Doxygen.