libsim Versione 7.2.1
dballe_class.F03
1! Copyright (C) 2013 ARPA-SIM <urpsim@smr.arpa.emr.it>
2! authors:
3! Paolo Patruno <ppatruno@arpa.emr.it>
4! Davide Cesari <dcesari@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
19#include "config.h"
20
43MODULE dballe_class
44
56use vol7d_class, only: vol7d_cdatalen
57use dballef
58IMPLICIT NONE
59
60private
61
62character (len=255),parameter:: subcategory="dballe_class"
63
65type,public :: dbaconnection
66 integer :: dbhandle=imiss
67 integer :: handle_err=imiss
68 integer :: category=0
69 contains
70# ifdef F2003_FULL_FEATURES
71 final :: dbaconnection_delete
72# else
73 procedure :: delete => dbaconnection_delete
74# endif
75end type dbaconnection
76
78interface dbaconnection
79 procedure dbaconnection_init
80end interface
81
83type,public :: dbasession
84 integer :: sehandle=imiss
85 logical :: file=.false.
86 character(len=40) :: template='generic'
87 character(len=255) :: filename=cmiss
88 character(len=40) :: mode=cmiss
89 character(len=40) :: format=cmiss
90 logical :: simplified=.true.
91 logical :: memdb=.false.
92 logical :: loadfile=.false.
93 type(dbaconnection) :: memconnection
94 integer :: category=0
95 integer :: count=imiss
96 contains
97# ifdef F2003_FULL_FEATURES
98 final :: dbasession_delete
99# else
100 procedure :: delete => dbasession_delete
101# endif
102 procedure :: unsetall => dbasession_unsetall
103 procedure :: remove_all => dbasession_remove_all
104 procedure :: set => dbasession_set
105 procedure :: setcontextana => dbasession_setcontextana
106 procedure :: dimenticami => dbasession_dimenticami
119 procedure :: prendilo => dbasession_prendilo
120 procedure :: var_related => dbasession_var_related
121 procedure :: critica => dbasession_critica
122 procedure :: scusa => dbasession_scusa
123 procedure :: messages_open_input => dbasession_messages_open_input
124 procedure :: messages_open_output => dbasession_messages_open_output
125 procedure :: messages_read_next => dbasession_messages_read_next
126 procedure :: messages_write_next => dbasession_messages_write_next
127 procedure :: close_message => dbasession_close_message
128 procedure :: unsetb => dbasession_unsetb
129 procedure :: filerewind => dbasession_filerewind
130 procedure :: ingest_ana => dbasession_ingest_ana
131 procedure :: ingest_anav => dbasession_ingest_anav
132 procedure :: ingest_anal => dbasession_ingest_anal
133 procedure :: ingest_metaanddata => dbasession_ingest_metaanddata
134 procedure :: ingest_metaanddatal => dbasession_ingest_metaanddatal
135 procedure :: ingest_metaanddatav => dbasession_ingest_metaanddatav
136 procedure :: ingest_metaanddatai => dbasession_ingest_metaanddatai
137 procedure :: ingest_metaanddataiv => dbasession_ingest_metaanddataiv
138 procedure :: ingest_metaanddatail => dbasession_ingest_metaanddatail
139 procedure :: ingest_metaanddatab => dbasession_ingest_metaanddatab
140 procedure :: ingest_metaanddatabv => dbasession_ingest_metaanddatabv
141 procedure :: ingest_metaanddatabl => dbasession_ingest_metaanddatabl
142 procedure :: ingest_metaanddatad => dbasession_ingest_metaanddatad
143 procedure :: ingest_metaanddatadv => dbasession_ingest_metaanddatadv
144 procedure :: ingest_metaanddatadl => dbasession_ingest_metaanddatadl
145 procedure :: ingest_metaanddatar => dbasession_ingest_metaanddatar
146 procedure :: ingest_metaanddatarv => dbasession_ingest_metaanddatarv
147 procedure :: ingest_metaanddatarl => dbasession_ingest_metaanddatarl
148 procedure :: ingest_metaanddatac => dbasession_ingest_metaanddatac
149 procedure :: ingest_metaanddatacv => dbasession_ingest_metaanddatacv
150 procedure :: ingest_metaanddatacl => dbasession_ingest_metaanddatacl
151 procedure :: dissolve_metadata => dbasession_dissolve_metadata
152 procedure :: dissolveattr => dbasession_dissolveattr_metadata
153 generic :: dissolve => dissolve_metadata ,dimenticami
154 generic :: ingesta => ingest_ana, ingest_anav,ingest_anal
155 generic :: ingest => ingest_metaanddata,ingest_metaanddatav,ingest_metaanddatal,&
156 !ingest_metaanddatai,ingest_metaanddatab,ingest_metaanddatad,ingest_metaanddatar,ingest_metaanddatac,& !ambiguos
157 ingest_metaanddataiv,ingest_metaanddatabv,ingest_metaanddatadv,ingest_metaanddatarv,ingest_metaanddatacv,&
158 ingest_metaanddatail,ingest_metaanddatarl,ingest_metaanddatadl,ingest_metaanddatabl,ingest_metaanddatacl
162end type dbasession
163
165interface dbasession
166 procedure dbasession_init
167end interface
168
170type,public,extends(vol7d_level) :: dbalevel
171 contains
172
173# ifdef F2003_FULL_FEATURES
174! final :: dbalevel_delete
175# else
176! procedure :: delete => dbalevel_delete !< todo
177# endif
178 procedure :: display => dbalevel_display
179 procedure :: dbaset => dbalevel_set
180 procedure :: dbaenq => dbalevel_enq
181 procedure,nopass :: dbacontextana => dbalevel_contextana
183end type dbalevel
184
186interface dbalevel
187 procedure dbalevel_init
188end interface
189
191type,public,extends(vol7d_timerange) :: dbatimerange
192 contains
193# ifdef F2003_FULL_FEATURES
194! final :: dbatimerange_delete
195# else
196! procedure :: delete => dbatimerange_delete
197# endif
198 procedure :: display => dbatimerange_display
199 procedure :: dbaset => dbatimerange_set
200 procedure :: dbaenq => dbatimerange_enq
201 procedure,nopass :: dbacontextana => dbatimerange_contextana
203end type dbatimerange
204
206interface dbatimerange
207 procedure dbatimerange_init
208end interface
209
211type,public,extends(geo_coord) :: dbacoord
212
213!!$ REAL(kind=fp_geo) :: lon !< longitudine
214!!$ REAL(kind=fp_geo) :: lat !< latitudine
215!!$ INTEGER(kind=int_l) :: ilon !< integer longitude (nint(lon*1.d5)
216!!$ INTEGER(kind=int_l) :: ilat !< integer latitude (nint(lat*1.d5)
217
218 contains
219# ifdef F2003_FULL_FEATURES
220! final :: dbacoord_delete
221# else
222! procedure :: delete => dbacoord_delete
223# endif
224 procedure :: display => dbacoord_display
225
226end type dbacoord
227
229interface dbacoord
230 procedure dbacoord_init
231end interface
232
234type,public,extends(vol7d_ana) :: dbaana
235
236 contains
237# ifdef F2003_FULL_FEATURES
238! final :: dbaana_delete
239# else
240! procedure :: delete => dbaana_delete
241# endif
242 procedure :: display => dbaana_display
243 procedure :: dbaset => dbaana_set
244 procedure :: dbaenq => dbaana_enq
245 procedure :: extrude => dbaana_extrude
246end type dbaana
247
249interface dbaana
250 procedure dbaana_init
251end interface
252
254type, public, extends(list) :: dbaanalist
255 contains
256 procedure :: current => currentdbaana
257 procedure :: display => displaydbaana
258end type dbaanalist
259
261type,public,extends(vol7d_network) :: dbanetwork
262
263 !Every type of report has an associated priority that controls which
264 !data are first returned when there is more than one in the same
265 !physical space. It can be changed by editing
266 !/etc/dballe/repinfo.csv
267 integer :: priority
268
269 contains
270# ifdef F2003_FULL_FEATURES
271! final :: dbanetwork_delete
272# else
273! procedure :: delete => dbanetwork_delete
274# endif
275 procedure :: display => dbanetwork_display
276 procedure :: dbaset => dbanetwork_set
277 procedure :: dbaenq => dbanetwork_enq
282interface dbanetwork
283 procedure dbanetwork_init
284end interface
285
286
288type,public,extends(datetime) :: dbadatetime
289
290 contains
291# ifdef F2003_FULL_FEATURES
292! final :: dbanetwork_delete
293# else
294! procedure :: delete => dbanetwork_delete
295# endif
296 procedure :: display => dbadatetime_display
297 procedure :: dbaset => dbadatetime_set
298 procedure :: dbaenq => dbadatetime_enq
299 procedure,nopass :: dbacontextana => dbadatetime_contextana
300end type dbadatetime
301
303interface dbadatetime
304 procedure dbadatetime_init
305end interface
306
309type,public,abstract :: dbadata
310 character(len=9) :: btable
311contains
312 procedure(dbadata_set),deferred :: dbaset
313 procedure :: dbadata_geti
314 procedure :: dbadata_getr
315 procedure :: dbadata_getd
316 procedure :: dbadata_getb
317 procedure :: dbadata_getc
318 generic :: get => dbadata_geti,dbadata_getr,dbadata_getd,dbadata_getb,dbadata_getc
319 procedure :: dbadata_c_e_i
320 procedure :: dbadata_c_e_r
321 procedure :: dbadata_c_e_d
322 procedure :: dbadata_c_e_b
323 procedure :: dbadata_c_e_c
324 procedure :: c_e => dbadata_c_e
325 procedure(dbadata_display),deferred :: display
326 procedure :: equal => dbadata_equal
327 generic :: operator (==) => equal
328end type dbadata
331abstract interface
332subroutine dbadata_set(data,session)
333import
334class(dbadata), intent(in) :: data
335type(dbasession), intent(in) :: session
336end subroutine dbadata_set
339subroutine dbadata_display(data)
340import
341class(dbadata), intent(in) :: data
342end subroutine dbadata_display
344end interface
345
347type,public, extends(dbadata) :: dbadatai
348 integer :: value
349contains
350 procedure :: dbadata_geti => dbadatai_geti
351 procedure :: dbaset => dbadatai_set
352 procedure :: display => dbadatai_display
353end type dbadatai
354
356interface dbadatai
357 procedure :: dbadatai_init
358end interface dbadatai
359
361type,public, extends(dbadata) :: dbadatar
362 real :: value
363contains
364 procedure :: dbadata_getr => dbadatar_getr
365 procedure :: dbaset => dbadatar_set
366 procedure :: display => dbadatar_display
367end type dbadatar
370interface dbadatar
371 procedure :: dbadatar_init
372end interface dbadatar
373
374
376type,public, extends(dbadata) :: dbadatad
377 doubleprecision :: value
378contains
379 procedure :: dbadata_getd => dbadatad_getd
380 procedure :: dbaset => dbadatad_set
381 procedure :: display => dbadatad_display
382end type dbadatad
383
385interface dbadatad
386 procedure :: dbadatad_init
387end interface dbadatad
391type,public, extends(dbadata) :: dbadatab
392 integer(kind=int_b) :: value
393contains
394 procedure :: dbadata_getb => dbadatab_getb
395 procedure :: dbaset => dbadatab_set
396 procedure :: display => dbadatab_display
397end type dbadatab
398
400interface dbadatab
401 procedure :: dbadatab_init
402end interface dbadatab
403
404
406type,public, extends(dbadata) :: dbadatac
407! character(:) :: value
408! character(255) :: value
409character(vol7d_cdatalen) :: value
410
411contains
412 procedure :: dbadata_getc => dbadatac_getc
413 procedure :: dbaset => dbadatac_set
414 procedure :: display => dbadatac_display
415end type dbadatac
416
418interface dbadatac
419 procedure :: dbadatac_init
420end interface dbadatac
421
423type,public :: dbametadata
424 type(dbalevel) :: level
425 type(dbatimerange) :: timerange
426 type(dbaana) :: ana
427 type(dbanetwork) :: network
428 type(dbadatetime) :: datetime
429 contains
430# ifdef F2003_FULL_FEATURES
431! final :: dbametadata_delete
432# else
433! procedure :: delete => dbametadata_delete
434# endif
435 procedure :: dbaset => dbametadata_set
436 procedure :: dbaenq => dbametadata_enq
437 procedure :: dbacontextana => dbametadata_contextana
438 procedure :: display => dbametadata_display
439 procedure :: equal => dbametadata_equal
440 generic :: operator (==) => equal
441end type dbametadata
444interface dbametadata
445 procedure dbametadata_init
446end interface
447
449type, public :: dbadc
450 class(dbadata),allocatable :: dat
451 contains
452 procedure :: display => dbadc_display
453 procedure :: dbaset => dbadc_set
454 procedure :: extrude => dbadc_extrude
455end type dbadc
456
457
459type, public :: dbadcv
460 type(dbadc),allocatable :: dcv(:)
461 contains
462 procedure :: display => dbadcv_display
463 procedure :: dbaset => dbadcv_set
464 procedure :: extrude => dbadcv_extrude
465 procedure :: equal => dbadcv_equal_dbadata
466 generic :: operator (==) => equal
467end type dbadcv
468
470type, public ,extends(dbadc):: dbadataattr
471 type(dbadcv) :: attrv
472 contains
473 procedure :: display => dbadataattr_display
474 procedure :: extrude => dbadataattr_extrude
475end type dbadataattr
478type, public :: dbadataattrv
479 class(dbadataattr),allocatable :: dataattr(:)
480 contains
481 procedure :: display => dbadataattrv_display
482 procedure :: extrude => dbadataattrv_extrude
483end type dbadataattrv
486type, public :: dbametaanddata
487 type(dbametadata) :: metadata
488 type(dbadataattrv) ::dataattrv
489 contains
490 procedure :: display => dbametaanddata_display
491 procedure :: extrude => dbametaanddata_extrude
492end type dbametaanddata
493
495type, public :: dbametaanddatav
496 type(dbametadata) :: metadata
497 type(dbadcv) ::datav
498 contains
499 procedure :: display => dbametaanddatav_display
500 procedure :: extrude => dbametaanddatav_extrude
504type, public, extends(list) :: dbametaanddatalist
505 contains
506 procedure :: current => currentdbametaanddata
507 procedure :: display => displaydbametaanddata
508 procedure :: extrude => dbametaanddatal_extrude
512type, public,extends(dbadatai) :: dbametaanddatai
513 type(dbametadata) :: metadata
514 contains
515 procedure :: display => dbametaanddatai_display
516 procedure :: extrude => dbametaanddatai_extrude
517end type dbametaanddatai
518
520type, public, extends(list) :: dbametaanddatailist
521 contains
522 procedure :: current => currentdbametaanddatai
523 procedure :: display => displaydbametaanddatai
524 procedure :: toarray => toarray_dbametaanddatai
525end type dbametaanddatailist
526
528type, public,extends(dbadatab) :: dbametaanddatab
529 type(dbametadata) :: metadata
530 contains
531 procedure :: display => dbametaanddatab_display
532 procedure :: extrude => dbametaanddatab_extrude
533end type dbametaanddatab
534
536type, public, extends(list) :: dbametaanddatablist
537 contains
538 procedure :: current => currentdbametaanddatab
539 procedure :: display => displaydbametaanddatab
540 procedure :: toarray => toarray_dbametaanddatab
541end type dbametaanddatablist
542
544type, public,extends(dbadatad) :: dbametaanddatad
545 type(dbametadata) :: metadata
546 contains
547 procedure :: display => dbametaanddatad_display
548 procedure :: extrude => dbametaanddatad_extrude
550
552type, public, extends(list) :: dbametaanddatadlist
553 contains
554 procedure :: current => currentdbametaanddatad
555 procedure :: display => displaydbametaanddatad
556 procedure :: toarray => toarray_dbametaanddatad
557end type dbametaanddatadlist
558
560type, public,extends(dbadatar) :: dbametaanddatar
561 type(dbametadata) :: metadata
562 contains
563 procedure :: display => dbametaanddatar_display
564 procedure :: extrude => dbametaanddatar_extrude
565end type dbametaanddatar
566
568type, public, extends(list) :: dbametaanddatarlist
569 contains
570 procedure :: current => currentdbametaanddatar
571 procedure :: display => displaydbametaanddatar
572 procedure :: toarray => toarray_dbametaanddatar
573end type dbametaanddatarlist
574
576type, public,extends(dbadatac) :: dbametaanddatac
577 type(dbametadata) :: metadata
578 contains
579 procedure :: display => dbametaanddatac_display
580 procedure :: extrude => dbametaanddatac_extrude
581end type dbametaanddatac
584type, public, extends(list) :: dbametaanddataclist
585 contains
586 procedure :: current => currentdbametaanddatac
587 procedure :: display => displaydbametaanddatac
588 procedure :: toarray => toarray_dbametaanddatac
589end type dbametaanddataclist
590
592type, public :: dbafilter
593 type(dbaana) :: ana
594 character(len=6) :: var
595 type(dbadatetime) :: datetime
596 type(dbalevel) :: level
597 type(dbatimerange) :: timerange
598 type(dbanetwork) :: network
599
600 type(dbacoord) :: coordmin,coordmax
601 type(dbadatetime) :: datetimemin,datetimemax
602 integer :: limit
603 character(len=255) :: ana_filter, data_filter, attr_filter, varlist, starvarlist, anavarlist, anastarvarlist
604 character(len=40) :: query
605 integer :: priority,priomin,priomax
606 logical :: contextana
607 logical :: anaonly
608 logical :: dataonly
609 type(dbadcv) :: vars,starvars
610 type(dbadcv) :: anavars,anastarvars
611 contains
612 procedure :: display => dbafilter_display
613 procedure :: dbaset => dbafilter_set
614 procedure :: equalmetadata => dbafilter_equal_dbametadata
617 generic :: operator (==) => equalmetadata
618end type dbafilter
619
621interface dbafilter
622 procedure dbafilter_init
623end interface
625contains
628subroutine displaydbametaanddata(this)
629class(dbametaanddatalist),intent(inout) :: this
630type(dbametaanddata) :: element
631
632call this%rewind()
633do while(this%element())
634 print *,"index:",this%currentindex()," value:"
635 element=this%current()
636 call element%display()
637 call this%next()
638end do
639end subroutine displaydbametaanddata
642type(dbametaanddata) function currentdbametaanddata(this)
643class(dbametaanddatalist),intent(inout) :: this
644class(*), pointer :: v
645
646v => this%currentpoli()
647select type(v)
648type is (dbametaanddata)
649 currentdbametaanddata = v
650end select
651end function currentdbametaanddata
652
653
655elemental logical function dbadata_equal(this,that)
656
657class(dbadata), intent(in) :: this
658class(dbadata), intent(in) :: that
659
660if ( this%btable == that%btable ) then
661 dbadata_equal = .true.
662else
663 dbadata_equal = .false.
664end if
665
666end function dbadata_equal
667
668
670subroutine dbadata_geti(data,value)
671class(dbadata), intent(in) :: data
672integer, intent(out) :: value
673value=imiss
675select type(data)
676type is (dbadatai)
677 value = data%value
678end select
680end subroutine dbadata_geti
681
682
684logical function dbadata_c_e_i(data)
685class(dbadata), intent(in) :: data
686
687dbadata_c_e_i=.false.
689select type(data)
690type is (dbadatai)
691 dbadata_c_e_i = c_e(data%value)
692end select
693
694end function dbadata_c_e_i
697subroutine dbadata_getr(data,value)
698class(dbadata), intent(in) :: data
699real, intent(out) :: value
700value=rmiss
701
702select type(data)
703type is (dbadatar)
704 value = data%value
705end select
706
707end subroutine dbadata_getr
710logical function dbadata_c_e_r(data)
711class(dbadata), intent(in) :: data
713dbadata_c_e_r=.false.
714
715select type(data)
716type is (dbadatar)
717 dbadata_c_e_r = c_e(data%value)
718end select
720end function dbadata_c_e_r
721
723subroutine dbadata_getd(data,value)
724class(dbadata), intent(in) :: data
725doubleprecision, intent(out) :: value
726value=dmiss
728select type(data)
729type is (dbadatad)
730 value = data%value
731end select
733end subroutine dbadata_getd
734
736logical function dbadata_c_e_d(data)
737class(dbadata), intent(in) :: data
738
739dbadata_c_e_d=.false.
741select type(data)
742type is (dbadatad)
743 dbadata_c_e_d = c_e(data%value)
744end select
745
746end function dbadata_c_e_d
747
750subroutine dbadata_getb(data,value)
751class(dbadata), intent(in) :: data
752INTEGER(kind=int_b), intent(out) :: value
753value=bmiss
754
755select type(data)
756type is (dbadatab)
757 value = data%value
758end select
760end subroutine dbadata_getb
761
763logical function dbadata_c_e_b(data)
764class(dbadata), intent(in) :: data
765
766dbadata_c_e_b=.false.
768select type(data)
769type is (dbadatab)
770 dbadata_c_e_b = c_e(data%value)
771end select
773end function dbadata_c_e_b
776subroutine dbadata_getc(data,value)
777class(dbadata), intent(in) :: data
778character(len=*), intent(out) :: value
779value=cmiss
781select type(data)
782type is (dbadatac)
783 value = data%value
784end select
785
786end subroutine dbadata_getc
787
788
790logical function dbadata_c_e_c(data)
791class(dbadata), intent(in) :: data
792
793dbadata_c_e_c=.false.
794
795select type(data)
796type is (dbadatac)
797 dbadata_c_e_c = c_e(data%value)
798end select
799
800end function dbadata_c_e_c
802
804logical function dbadata_c_e(data)
805class(dbadata), intent(in) :: data
806
807dbadata_c_e=data%dbadata_c_e_i() .or. data%dbadata_c_e_r() .or. data%dbadata_c_e_d() &
808 .or. data%dbadata_c_e_b() .or. data%dbadata_c_e_c()
809
810end function dbadata_c_e
811
812
814subroutine dbalevel_display(level)
815class(dbalevel), intent(in) :: level
816call display (level%vol7d_level)
817end subroutine dbalevel_display
818
821type(dbalevel) function dbalevel_init(level1, l1, level2, l2)
822
823INTEGER,INTENT(IN),OPTIONAL :: level1
824INTEGER,INTENT(IN),OPTIONAL :: l1
825INTEGER,INTENT(IN),OPTIONAL :: level2
826INTEGER,INTENT(IN),OPTIONAL :: l2
827
828call init (dbalevel_init%vol7d_level,level1, l1, level2, l2)
829end function dbalevel_init
832subroutine dbalevel_set(level,session)
833class(dbalevel), intent(in) :: level
834type(dbasession), intent(in) :: session
835integer :: ier
836
837!if (c_e(session%sehandle)) then
838ier = idba_setlevel(session%sehandle,&
839 level%level1, level%l1, level%level2, level%l2)
840
841!todo this is a work around
842if (.not. c_e(level%vol7d_level)) then
843 call session%setcontextana
844end if
845
846end subroutine dbalevel_set
847
849subroutine dbalevel_enq(level,session)
850class(dbalevel), intent(out) :: level
851type(dbasession), intent(in) :: session
852integer :: ier
853
854ier = idba_enqlevel(session%sehandle,&
855 level%level1, level%l1, level%level2, level%l2)
856
857end subroutine dbalevel_enq
860type(dbalevel) function dbalevel_contextana()
861
862dbalevel_contextana=dbalevel()
863
864end function dbalevel_contextana
865
866
868subroutine dbaana_display(ana)
869class(dbaana), intent(in) :: ana
870call display (ana%vol7d_ana)
871end subroutine dbaana_display
873
876type(dbacoord) function dbacoord_init(lon, lat, ilon, ilat)
877REAL(kind=fp_geo),INTENT(in),OPTIONAL :: lon
878REAL(kind=fp_geo),INTENT(in),OPTIONAL :: lat
879INTEGER(kind=int_l),INTENT(in),OPTIONAL :: ilon
880INTEGER(kind=int_l),INTENT(in),OPTIONAL :: ilat
881
882CALL init(dbacoord_init%geo_coord, lon=lon, lat=lat , ilon=ilon, ilat=ilat)
883
884end function dbacoord_init
887subroutine dbacoord_display(coord)
888class(dbacoord), intent(in) :: coord
889call display (coord%geo_coord)
890end subroutine dbacoord_display
891
894type(dbaana) function dbaana_init(coord,ident,lon, lat, ilon, ilat)
895CHARACTER(len=*),INTENT(in),OPTIONAL :: ident
896TYPE(dbacoord),INTENT(IN),optional :: coord
897REAL(kind=fp_geo),INTENT(in),OPTIONAL :: lon
898REAL(kind=fp_geo),INTENT(in),OPTIONAL :: lat
899INTEGER(kind=int_l),INTENT(in),OPTIONAL :: ilon
900INTEGER(kind=int_l),INTENT(in),OPTIONAL :: ilat
901
902if (present(coord))then
903 CALL init(dbaana_init%vol7d_ana, ilon=getilon(coord%geo_coord), ilat=getilat(coord%geo_coord), ident=ident)
904else
905 CALL init(dbaana_init%vol7d_ana, lon=lon, lat=lat, ilon=ilon, ilat=ilat, ident=ident)
906end if
907
908end function dbaana_init
909
911subroutine dbaana_set(ana,session)
912class(dbaana), intent(in) :: ana
913type(dbasession), intent(in) :: session
914integer :: ier
915
916!if (c_e(session%sehandle)) then
917ier = idba_set(session%sehandle,"lat",getilat(ana%vol7d_ana%coord))
918ier = idba_set(session%sehandle,"lon",getilon(ana%vol7d_ana%coord))
919if (c_e(ana%vol7d_ana%ident)) then
920 ier = idba_set(session%sehandle,"ident",ana%vol7d_ana%ident)
921 ier = idba_set(session%sehandle,"mobile",1)
922else
923 ier = idba_set(session%sehandle,"ident",cmiss)
924 ier = idba_set(session%sehandle,"mobile",imiss)
925end if
926
927end subroutine dbaana_set
928
930subroutine dbaana_enq(ana,session)
931class(dbaana), intent(out) :: ana
932type(dbasession), intent(in) :: session
933integer :: ier,ilat,ilon
934
935!if (c_e(session%sehandle)) then
936ier = idba_enq(session%sehandle,"lat",ilat)
937ier = idba_enq(session%sehandle,"lon",ilon)
939call init(ana%vol7d_ana%coord,ilon=ilon,ilat=ilat)
940ier = idba_enq(session%sehandle,"ident",ana%vol7d_ana%ident)
941
942end subroutine dbaana_enq
943
944
946subroutine dbaana_extrude(ana,session)
947class(dbaana), intent(in) :: ana
948type(dbasession), intent(in) :: session
949
950call session%unsetall()
951!write ana
952call session%set(ana=ana)
953call session%prendilo()
954
955!to close message on file
956call session%close_message()
957
958end subroutine dbaana_extrude
959
960
962subroutine displaydbaana(this)
963class(dbaanalist),intent(inout) :: this
964type(dbaana) :: element
965
966call this%rewind()
967do while(this%element())
968 print *,"index:",this%currentindex()," value:"
969 element=this%current()
970 call element%display()
971 call this%next()
972end do
973end subroutine displaydbaana
974
976type(dbaana) function currentdbaana(this)
977class(dbaanalist) :: this
978class(*), pointer :: v
979
980v => this%currentpoli()
981select type(v)
982type is (dbaana)
983 currentdbaana = v
984end select
985end function currentdbaana
986
987
989subroutine dbadc_set(dc,session)
990class(dbadc), intent(in) :: dc
991type(dbasession), intent(in) :: session
993call dc%dat%dbaset(session)
994
995end subroutine dbadc_set
996
998subroutine dbadc_display(dc)
999class(dbadc), intent(in) :: dc
1000
1001call dc%dat%display()
1003end subroutine dbadc_display
1004
1006subroutine dbadcv_set(dcv,session)
1007class(dbadcv), intent(in) :: dcv
1008type(dbasession), intent(in) :: session
1009integer :: i
1010
1011do i=1, size(dcv%dcv)
1012 call dcv%dcv(i)%dbaset(session)
1013enddo
1014
1015end subroutine dbadcv_set
1016
1017
1018
1020subroutine dbadcv_extrude(dcv,session,noattr,filter,template)
1021class(dbadcv), intent(in) :: dcv
1022type(dbasession), intent(in) :: session
1023logical, intent(in),optional :: noattr
1024type(dbafilter),intent(in),optional :: filter
1025character(len=*),intent(in),optional :: template
1026integer :: i
1027
1028do i=1, size(dcv%dcv)
1029 call dcv%dcv(i)%extrude(session,noattr,filter,template=template)
1030enddo
1031
1032end subroutine dbadcv_extrude
1033
1035subroutine dbadc_extrude(data,session,noattr,filter,attronly,template)
1036class(dbadc), intent(in) :: data
1037type(dbasession), intent(in) :: session
1038logical, intent(in),optional :: noattr
1039type(dbafilter),intent(in),optional :: filter
1040logical, intent(in),optional :: attronly
1041character(len=*),intent(in),optional :: template
1042
1043call data%extrude(session,noattr,filter,attronly,template)
1044
1045end subroutine dbadc_extrude
1046
1047
1049subroutine dbadcv_display(dcv)
1050class(dbadcv), intent(in) :: dcv
1051integer :: i
1052
1053if (allocated(dcv%dcv)) then
1054 do i=1, size(dcv%dcv)
1055 call dcv%dcv(i)%display()
1056 end do
1057end if
1058end subroutine dbadcv_display
1059
1060!!$subroutine dbadat_extrude(dat,session)
1061!!$class(dbadat), intent(in) :: dat
1062!!$type(dbasession), intent(in) :: session
1063!!$
1064!!$!write data in dsn
1065!!$call dat%dbaset(session)
1066!!$call session%prendilo()
1067!!$
1068!!$end subroutine dbadat_extrude
1069!!$
1070!!$subroutine dbadatav_extrude(datav,session)
1071!!$class(dbadatav), intent(in) :: datav
1072!!$type(dbasession), intent(in) :: session
1073!!$integer :: i
1074!!$!write data in dsn
1075!!$do i =1,size(datav%dat)
1076!!$ call datav%dat(i)%dbaset(session)
1077!!$end do
1078!!$call session%prendilo()
1079!!$
1080!!$end subroutine dbadatav_extrude
1081
1084subroutine dbasession_unsetb(session)
1085class(dbasession), intent(in) :: session
1086integer :: ier
1087
1088!if (session%file)then
1089ier=idba_unsetb(session%sehandle)
1090!end if
1091end subroutine dbasession_unsetb
1092
1094subroutine dbasession_close_message(session,template)
1095class(dbasession), intent(in) :: session
1096character(len=*),intent(in),optional :: template
1097integer :: ier
1098character(len=40) :: ltemplate
1100
1101ltemplate=session%template
1102if (present(template)) ltemplate=template
1103
1104!!$print*,"--------------- dbasession ---------------------------------"
1105!!$print *,'file',session%file
1106!!$print *,'filename',trim(session%filename)
1107!!$print *,'mode',session%mode
1108!!$print *,'format',session%format
1109!!$print *,'simplified',session%simplified
1110!!$print *,'memdb',session%memdb
1111!!$print *,'loadfile',session%loadfile
1112!!$print *,'template',ltemplate
1113!!$print*,"------------------------------------------------"
1114
1115if (session%file)then
1116
1117 if (session%memdb) then
1119 return
1120 !call session%messages_write_next(template=ltemplate)
1121
1122 else
1123
1124 if (c_e(ltemplate)) then
1125 ier=idba_set(session%sehandle,"query","message "//trim(ltemplate))
1126 else
1127 ier=idba_set(session%sehandle,"query","message")
1128 end if
1129
1130 call session%unsetb()
1131 call session%prendilo()
1132
1133 end if
1134end if
1135end subroutine dbasession_close_message
1136
1137
1139subroutine dbasession_messages_open_input(session,filename,mode,format,simplified)
1140class(dbasession), intent(in) :: session
1141character (len=*), intent(in) :: filename
1142character (len=*), intent(in),optional :: mode
1143character (len=*), intent(in),optional :: format
1144logical, intent(in),optional :: simplified
1145
1146integer :: ier
1147character (len=40) :: lmode, lformat
1148logical :: lsimplified
1149
1150lmode="r"
1151if (present(mode)) lmode=mode
1152
1153lformat="BUFR"
1154if (present(format)) lformat=format
1155
1156lsimplified=.true.
1157if (present(simplified)) lsimplified=simplified
1158
1159ier = idba_messages_open_input(session%sehandle, filename, lmode, lformat, lsimplified)
1160
1161end subroutine dbasession_messages_open_input
1162
1163
1165subroutine dbasession_messages_open_output(session,filename,mode,format)
1166class(dbasession), intent(in) :: session
1167character (len=*), intent(in) :: filename
1168character (len=*), intent(in),optional :: mode
1169character (len=*), intent(in),optional :: format
1170
1171integer :: ier
1172character (len=40) :: lmode, lformat
1173
1174lmode="w"
1175if (present(mode)) lmode=mode
1176
1177lformat="BUFR"
1178if (present(format)) lformat=format
1179
1180ier = idba_messages_open_output(session%sehandle, filename, lmode, lformat)
1181
1182end subroutine dbasession_messages_open_output
1183
1184
1186logical function dbasession_messages_read_next(session)
1187class(dbasession), intent(in) :: session
1188
1189integer :: ier
1190
1191ier = idba_messages_read_next(session%sehandle, dbasession_messages_read_next)
1192
1193end function dbasession_messages_read_next
1196subroutine dbasession_messages_write_next(session,template)
1197class(dbasession), intent(in) :: session
1198character(len=*), optional :: template
1199character(len=40) :: ltemplate
1200
1201integer :: ier
1202
1203!TODO how to set autodetect?
1204!ltemplate="generic" !! "wmo" = wmo - WMO style templates (autodetect) ?
1205
1206ltemplate=session%template
1207if (present(template)) ltemplate=template
1209ier = idba_messages_write_next(session%sehandle,ltemplate)
1210
1211end subroutine dbasession_messages_write_next
1212
1213
1215subroutine dbasession_dissolve_metadata(session,metadata)
1216class(dbasession), intent(in) :: session
1217type(dbametadata), intent(in) :: metadata(:)
1218
1219integer :: i
1220
1221do i =1, size (metadata)
1222
1223 call metadata(i)%dbaset(session)
1224 call session%dissolve()
1225
1226end do
1227
1228end subroutine dbasession_dissolve_metadata
1229
1230
1231
1233subroutine dbasession_dissolveattr_metadata(session,metadata)
1234class(dbasession), intent(in) :: session
1235type(dbametadata), intent(in),optional :: metadata(:)
1236
1237character(len=9) :: btable
1238integer :: i,ii,count,ier
1239
1240if (present (metadata)) then
1241 do i =1, size (metadata)
1242
1243 ! here if metadata have some field missig they will be set to missing so it will be unset in dballe (I hope)
1244 call metadata(i)%dbaset(session)
1245 ier = idba_voglioquesto(session%sehandle, count)
1246
1247 if (.not. c_e(count)) cycle
1248 do ii =1,count
1249 ier = idba_dammelo(session%sehandle, btable)
1250 !call session%var_related(btable) !not needed after dammelo
1251 call session%scusa()
1252 end do
1253
1254 end do
1255else
1256
1257 ier = idba_voglioquesto(session%sehandle, count)
1258
1259 if (c_e(count)) then
1260 do i =1,count
1261 ier = idba_dammelo(session%sehandle, btable)
1262 !call session%var_related(btable) !not needed after dammelo
1263 call session%scusa()
1264 end do
1265 end if
1266end if
1267end subroutine dbasession_dissolveattr_metadata
1268
1269
1271subroutine dbadataattr_extrude(data,session,noattr,filter,attronly,template)
1272class(dbadataattr), intent(in) :: data
1273type(dbasession), intent(in) :: session
1274logical, intent(in),optional :: noattr
1275type(dbafilter),intent(in),optional :: filter
1276logical, intent(in),optional :: attronly
1277character(len=*),intent(in),optional :: template
1278integer :: i,ierr,count,code
1279logical :: critica
1280character(len=9) :: btable
1281
1283if (session%file .and. optio_log(attronly))then
1284 call l4f_category_log(session%category,l4f_error,"attronly writing on file not supported")
1285 CALL raise_fatal_error()
1286end if
1287
1288if (present(filter))then
1289 if (filter%contextana) then
1290 if (.not. filter%anavars == data%dbadc%dat) return
1291 else
1292 if (.not. filter%vars == data%dbadc%dat) return
1293 end if
1294endif
1295
1296!write data in dsn
1297
1298!print *,"extrude dati:"
1299!call data%dbadc%display()
1300
1301! missing on file do nothing
1302if (.not. data%dbadc%dat%c_e() .and. session%file) return
1303
1304call data%dbadc%dbaset(session)
1305
1306code = idba_error_code() !! 13 for Value is outside the range
1307
1308if (optio_log(attronly).or. .not. data%dbadc%dat%c_e() .or. code ==13 ) then
1309
1310 !! those hare required?
1311 ierr = idba_set(session%sehandle,"var",data%dbadc%dat%btable)
1312 !!
1313
1314 ierr = idba_voglioquesto(session%sehandle, count)
1315
1316 ! with missing data to extrude and missing data in DB we have nothing to delete
1317 ! with attronly and missing data in DB we have nothing to do
1318 ierr=idba_unsetb(session%sehandle)
1319 if (count ==0) return
1320
1321 if (c_e(count)) then
1322 if (optio_log(attronly))then
1323 ierr=idba_dammelo(session%sehandle, btable)
1324 !ierr=idba_enqi(session%sehandle, "context_id", id)
1325 else
1326 !remove data from db if data is missing
1327 ierr=idba_dimenticami(session%sehandle)
1328 endif
1329 endif
1330else
1331 call session%prendilo()
1332 ierr=idba_unsetb(session%sehandle)
1333end if
1334
1335if (optio_log(noattr)) return
1336
1337!write attributes in dsn
1338if (allocated(data%attrv%dcv)) then
1339 if (size(data%attrv%dcv) > 0 )then
1340 critica = .false.
1341 do i = 1, size(data%attrv%dcv)
1342 if (present(filter))then
1343 if (filter%contextana) then
1344 if (.not. filter%anastarvars == data%attrv%dcv(i)%dat) cycle
1345 else
1346 if (.not. filter%starvars == data%attrv%dcv(i)%dat) cycle
1347 end if
1348 endif
1349
1350 if (data%attrv%dcv(i)%dat%c_e()) then
1351 !print *,"extrude attributi:"
1352 !call data%attrv%dcv(i)%dat%display()
1353 call data%attrv%dcv(i)%dat%dbaset(session)
1354 critica=.true.
1355 else if(optio_log(attronly)) then
1356 !ierr=idba_seti(session%sehandle, "*context_id", id)
1357 !call session%var_related(data%dbadc%dat%btable) ! If I have made a prendilo I do not need this
1358 !call data%attrv%dcv(i)%dat%dbaset(session)
1359 ierr = idba_set(session%sehandle,"*var",data%attrv%dcv(i)%dat%btable)
1360 !print *,"scusa attributi:"
1361 !call data%attrv%dcv(i)%dat%display()
1362 call session%scusa()
1363 endif
1364 end do
1365 if (critica) then
1366 !ierr=idba_seti(session%sehandle, "*context_id", id)
1367 !call session%var_related(data%dbadc%dat%btable) ! If I have made a prendilo I do not need this
1368 call session%critica()
1369 end if
1370
1371 end if
1372end if
1373
1375!to close message on file
1376!call session%close_message()
1377
1378end subroutine dbadataattr_extrude
1379
1381subroutine dbadataattr_display(dc)
1382class(dbadataattr), intent(in) :: dc
1383
1384print*,"Data:"
1385call dc%dbadc%display()
1386print*,"Attributes:"
1387call dc%attrv%display()
1388
1389end subroutine dbadataattr_display
1390
1391
1393subroutine dbadataattrv_extrude(dataattr,session,noattr,filter,attronly,template)
1394class(dbadataattrv), intent(in) :: dataattr
1395type(dbasession), intent(in) :: session
1396logical, intent(in),optional :: noattr
1397type(dbafilter),intent(in),optional :: filter
1398logical, intent(in),optional :: attronly
1399character(len=*),intent(in),optional :: template
1400
1401integer :: i
1402
1403if(.not. allocated(dataattr%dataattr)) return
1404do i=1, size(dataattr%dataattr)
1405 call dataattr%dataattr(i)%extrude(session,noattr,filter,attronly,template)
1406enddo
1407
1408!to close message on file
1409!call session%prendilo()
1410!call session%close_message()
1411
1412end subroutine dbadataattrv_extrude
1413
1415subroutine dbadataattrv_display(dataattr)
1416class(dbadataattrv), intent(in) :: dataattr
1417integer :: i
1418
1419do i=1, size(dataattr%dataattr)
1420 call dataattr%dataattr(i)%display()
1421end do
1422
1423end subroutine dbadataattrv_display
1424
1426subroutine dbadatai_geti(data,value)
1427class(dbadatai), intent(in) :: data
1428integer, intent(out) :: value
1429value=data%value
1430end subroutine dbadatai_geti
1431
1433subroutine dbadatar_getr(data,value)
1434class(dbadatar), intent(in) :: data
1435real, intent(out) :: value
1436value=data%value
1437end subroutine dbadatar_getr
1438
1440subroutine dbadatad_getd(data,value)
1441class(dbadatad), intent(in) :: data
1442doubleprecision, intent(out) :: value
1443value=data%value
1444end subroutine dbadatad_getd
1445
1447subroutine dbadatab_getb(data,value)
1448class(dbadatab), intent(in) :: data
1449integer(kind=int_b), intent(out) :: value
1450value=data%value
1451end subroutine dbadatab_getb
1452
1454subroutine dbadatac_getc(data,value)
1455class(dbadatac), intent(in) :: data
1456character(len=*), intent(out) :: value
1457value=data%value
1458end subroutine dbadatac_getc
1460
1463type(dbadatai) elemental function dbadatai_init(btable,value)
1464
1465character(len=*),INTENT(IN),OPTIONAL :: btable
1466INTEGER,INTENT(IN),OPTIONAL :: value
1467
1468if (present(btable)) then
1469 dbadatai_init%btable=btable
1470else
1471 dbadatai_init%btable=cmiss
1472end if
1473
1474if (present(value)) then
1475 dbadatai_init%value=value
1476else
1477 dbadatai_init%value=imiss
1478end if
1479
1480end function dbadatai_init
1481
1484type(dbadatar) elemental function dbadatar_init(btable,value)
1485
1486character(len=*),INTENT(IN),OPTIONAL :: btable
1487real,INTENT(IN),OPTIONAL :: value
1488
1489if (present(btable)) then
1490 dbadatar_init%btable=btable
1491else
1492 dbadatar_init%btable=cmiss
1493end if
1494
1495if (present(value)) then
1496 dbadatar_init%value=value
1497else
1498 dbadatar_init%value=rmiss
1499end if
1500
1501end function dbadatar_init
1502
1505type(dbadatad) elemental function dbadatad_init(btable,value)
1506
1507character(len=*),INTENT(IN),OPTIONAL :: btable
1508double precision,INTENT(IN),OPTIONAL :: value
1509
1510if (present(btable)) then
1511 dbadatad_init%btable=btable
1512else
1513 dbadatad_init%btable=cmiss
1514end if
1515
1516if (present(value)) then
1517 dbadatad_init%value=value
1518else
1519 dbadatad_init%value=dmiss
1520end if
1521
1522end function dbadatad_init
1523
1524
1527type(dbadatab) elemental function dbadatab_init(btable,value)
1528
1529character(len=*),INTENT(IN),OPTIONAL :: btable
1530INTEGER(kind=int_b) ,INTENT(IN),OPTIONAL :: value
1531
1532if (present(btable)) then
1533 dbadatab_init%btable=btable
1534else
1535 dbadatab_init%btable=cmiss
1536end if
1537
1538if (present(value)) then
1539 dbadatab_init%value=value
1540else
1541 dbadatab_init%value=bmiss
1542end if
1543
1544end function dbadatab_init
1545
1548type(dbadatac) elemental function dbadatac_init(btable,value)
1549
1550character(len=*),INTENT(IN),OPTIONAL :: btable
1551character(len=*),INTENT(IN),OPTIONAL :: value
1552
1553if (present(btable)) then
1554 dbadatac_init%btable=btable
1555else
1556 dbadatac_init%btable=cmiss
1557end if
1558
1559if (present(value)) then
1560 dbadatac_init%value=value
1561else
1562 dbadatac_init%value=cmiss
1563end if
1564
1565end function dbadatac_init
1566
1567
1569subroutine dbadatai_set(data,session)
1570class(dbadatai), intent(in) :: data
1571type(dbasession), intent(in) :: session
1572integer :: ier
1573if (.not. c_e(data%btable)) return
1574ier = idba_set(session%sehandle,data%btable,data%value)
1575end subroutine dbadatai_set
1576
1578subroutine dbadatai_display(data)
1579class(dbadatai), intent(in) :: data
1580print *,"Btable: ", t2c(data%btable,miss="Missing")," Value: ", t2c(data%value,miss="Missing value")
1581end subroutine dbadatai_display
1582
1584subroutine dbadatar_set(data,session)
1585class(dbadatar), intent(in) :: data
1586type(dbasession), intent(in) :: session
1587integer :: ier
1588if (.not. c_e(data%btable)) return
1589ier = idba_set(session%sehandle,data%btable,data%value)
1590end subroutine dbadatar_set
1591
1593subroutine dbadatar_display(data)
1594class(dbadatar), intent(in) :: data
1595print *,"Btable: ", t2c(data%btable,miss="Missing")," Value: ", t2c(data%value,miss="Missing value")
1596end subroutine dbadatar_display
1597
1598
1600subroutine dbadatad_set(data,session)
1601class(dbadatad), intent(in) :: data
1602type(dbasession), intent(in) :: session
1603integer :: ier
1604if (.not. c_e(data%btable)) return
1605ier = idba_set(session%sehandle,data%btable,data%value)
1606end subroutine dbadatad_set
1607
1609subroutine dbadatad_display(data)
1610class(dbadatad), intent(in) :: data
1611print *,"Btable: ", t2c(data%btable,miss="Missing")," Value: ", t2c(data%value,miss="Missing value")
1612end subroutine dbadatad_display
1613
1615subroutine dbadatab_set(data,session)
1616class(dbadatab), intent(in) :: data
1617type(dbasession), intent(in) :: session
1618integer :: ier
1619if (.not. c_e(data%btable)) return
1620ier = idba_set(session%sehandle,data%btable,data%value)
1621end subroutine dbadatab_set
1622
1624subroutine dbadatab_display(data)
1625class(dbadatab), intent(in) :: data
1626print *,"Btable: ", t2c(data%btable,miss="Missing")," Value: ", t2c(data%value,miss="Missing value")
1627end subroutine dbadatab_display
1630subroutine dbadatac_set(data,session)
1631class(dbadatac), intent(in) :: data
1632type(dbasession), intent(in) :: session
1633integer :: ier
1634if (.not. c_e(data%btable)) return
1635ier = idba_set(session%sehandle,data%btable,data%value)
1636end subroutine dbadatac_set
1637
1639subroutine dbadatac_display(data)
1640class(dbadatac), intent(in) :: data
1641print *,"Btable: ", t2c(data%btable,miss="Missing")," Value: ", t2c(data%value,miss="Missing value")
1642end subroutine dbadatac_display
1643
1644
1645!!$function dbalevel_spiega(level,handle)
1646!!$class(dbalevel), intent(in) :: level
1647!!$integer, intent(in) :: handle
1648!!$character (len=255) :: dbalevel_spiega
1649!!$integer :: ier
1650!!$
1651!!$ier = idba_spiegal(handle,level%level1,level%l1,level%level2,level%l2,dbalevel_spiega)
1652!!$if (ier /= 0) dbalevel_spiega = cmiss
1653!!$
1654!!$end function dbalevel_spiega
1655
1656
1658subroutine dbatimerange_display(timerange)
1659class(dbatimerange), intent(in) :: timerange
1660call display (timerange%vol7d_timerange)
1661end subroutine dbatimerange_display
1662
1664subroutine dbatimerange_set(timerange,session)
1665class(dbatimerange), intent(in) :: timerange
1666type(dbasession), intent(in) :: session
1667integer :: ier
1668
1669ier = idba_settimerange(session%sehandle,&
1670 timerange%timerange, timerange%p1, timerange%p2)
1671
1672!todo this is a work around
1673if (.not. c_e(timerange%vol7d_timerange)) then
1674 call session%setcontextana
1675end if
1676
1677end subroutine dbatimerange_set
1678
1680subroutine dbatimerange_enq(timerange,session)
1681class(dbatimerange), intent(out) :: timerange
1682type(dbasession), intent(in) :: session
1683integer :: ier
1684
1685ier = idba_enqtimerange(session%sehandle,&
1686 timerange%timerange, timerange%p1, timerange%p2)
1687
1688end subroutine dbatimerange_enq
1689
1692type(dbatimerange) function dbatimerange_init(timerange, p1, p2)
1693INTEGER,INTENT(IN),OPTIONAL :: timerange
1694INTEGER,INTENT(IN),OPTIONAL :: p1
1695INTEGER,INTENT(IN),OPTIONAL :: p2
1696
1697call init (dbatimerange_init%vol7d_timerange,timerange, p1, p2)
1698end function dbatimerange_init
1699
1701type(dbatimerange) function dbatimerange_contextana()
1702
1703dbatimerange_contextana=dbatimerange()
1704
1705end function dbatimerange_contextana
1706
1707
1709subroutine dbanetwork_display(network)
1710class(dbanetwork), intent(in) :: network
1711call display (network%vol7d_network)
1712print *,"Priority=",network%priority
1713end subroutine dbanetwork_display
1714
1716subroutine dbanetwork_set(network,session)
1717class(dbanetwork), intent(in) :: network
1718type(dbasession), intent(in) :: session
1719integer :: ier
1720
1721ier = idba_set(session%sehandle,"rep_memo", network%name)
1722
1723end subroutine dbanetwork_set
1724
1726subroutine dbanetwork_enq(network,session)
1727class(dbanetwork), intent(out) :: network
1728type(dbasession), intent(in) :: session
1729integer :: ier
1730
1731ier = idba_enq(session%sehandle,"rep_memo", network%name)
1732ier = idba_enq(session%sehandle,"priority", network%priority)
1733
1734end subroutine dbanetwork_enq
1735
1738type(dbanetwork) function dbanetwork_init(name)
1739CHARACTER(len=*),INTENT(in),OPTIONAL :: name
1740
1741call init (dbanetwork_init%vol7d_network,name)
1742dbanetwork_init%priority=imiss
1743end function dbanetwork_init
1744
1745
1747subroutine dbadatetime_display(datetime)
1748class(dbadatetime), intent(in) :: datetime
1749call display (datetime%datetime)
1750end subroutine dbadatetime_display
1751
1753subroutine dbadatetime_set(datetime,session)
1754class(dbadatetime), intent(in) :: datetime
1755type(dbasession), intent(in) :: session
1756integer :: ier,year,month,day,hour,minute,sec,msec
1758CALL getval(datetime%datetime, year=year, month=month, day=day, hour=hour, minute=minute,msec=msec)
1759
1760if (c_e(msec)) then
1761 sec=nint(float(msec)/1000.)
1762else
1763 sec=imiss
1764end if
1765
1766ier = idba_setdate(session%sehandle,year,month,day,hour,minute,sec)
1767
1768!todo this is a work around
1769if (.not. c_e(datetime%datetime)) then
1770 call session%setcontextana
1771end if
1773end subroutine dbadatetime_set
1774
1776subroutine dbadatetime_enq(datetime,session)
1777class(dbadatetime), intent(out) :: datetime
1778type(dbasession), intent(in) :: session
1779
1780integer :: ier,year,month,day,hour,minute,sec,msec
1782ier = idba_enqdate(session%sehandle,year,month,day,hour,minute,sec)
1783
1784if (c_e(sec)) then
1785 msec=sec*1000
1786else
1787 msec=imiss
1788end if
1789
1790!! TODO
1791!! this is a workaround ! year == 1000 should never exist
1792if (year==1000) then
1793 datetime%datetime=datetime_new()
1794else
1795 CALL init(datetime%datetime, year=year, month=month, day=day, hour=hour, minute=minute,msec=msec)
1796end if
1798end subroutine dbadatetime_enq
1799
1802type(dbadatetime) function dbadatetime_init(dt)
1803type(datetime),INTENT(in),OPTIONAL :: dt
1804
1805if (present(dt)) then
1806 dbadatetime_init%datetime=dt
1807else
1808 dbadatetime_init%datetime=datetime_new()
1809end if
1810
1811end function dbadatetime_init
1814type(dbadatetime) function dbadatetime_contextana()
1815
1816dbadatetime_contextana%datetime=datetime_new()
1817
1818end function dbadatetime_contextana
1819
1820
1823type(dbametadata) function dbametadata_init(level,timerange,ana,network,datetime)
1824
1825type(dbalevel), intent(in), optional :: level
1826type(dbatimerange), intent(in), optional :: timerange
1827type(dbaana), intent(in), optional :: ana
1828type(dbanetwork), intent(in), optional :: network
1829type(dbadatetime), intent(in), optional :: datetime
1830
1831if (present(level)) then
1832 dbametadata_init%level=level
1833else
1834 dbametadata_init%level=dbalevel()
1835end if
1836
1837if (present(timerange)) then
1838 dbametadata_init%timerange=timerange
1839else
1840 dbametadata_init%timerange=dbatimerange()
1841end if
1842
1843if (present(ana)) then
1844 dbametadata_init%ana=ana
1845else
1846 dbametadata_init%ana=dbaana()
1847end if
1848
1849if (present(network)) then
1850 dbametadata_init%network=network
1851else
1852 dbametadata_init%network=dbanetwork()
1853end if
1854
1855if (present(datetime)) then
1856 dbametadata_init%datetime=datetime
1857else
1858 dbametadata_init%datetime=dbadatetime()
1859end if
1860
1861end function dbametadata_init
1862
1864subroutine dbametadata_display(metadata)
1865class(dbametadata), intent(in) :: metadata
1866call metadata%level%display()
1867call metadata%timerange%display()
1868call metadata%ana%display()
1869call metadata%network%display()
1870call metadata%datetime%display()
1871
1872end subroutine dbametadata_display
1873
1875subroutine dbametadata_set(metadata,session)
1876class(dbametadata), intent(in) :: metadata
1877type(dbasession), intent(in) :: session
1878
1879!print *,"extrude metadata:"
1880!call metadata%display()
1881
1882call metadata%ana%dbaset(session)
1883call metadata%network%dbaset(session)
1884
1885if (c_e(metadata%datetime%datetime) .or. &
1886 c_e(metadata%level%vol7d_level) .or. &
1887 c_e(metadata%timerange%vol7d_timerange)) then
1888
1889 call metadata%datetime%dbaset(session)
1890 call metadata%level%dbaset(session)
1891 call metadata%timerange%dbaset(session)
1892
1893else
1894 call session%setcontextana()
1895end if
1896
1897end subroutine dbametadata_set
1898
1900subroutine dbametadata_enq(metadata,session)
1901class(dbametadata), intent(out) :: metadata
1902type(dbasession), intent(in) :: session
1903
1904call metadata%ana%dbaenq(session)
1905call metadata%network%dbaenq(session)
1906call metadata%datetime%dbaenq(session)
1907call metadata%level%dbaenq(session)
1908call metadata%timerange%dbaenq(session)
1909
1910end subroutine dbametadata_enq
1911
1912
1914logical function dbafilter_equal_dbametadata(this,that)
1915
1916class(dbafilter), intent(in) :: this
1917class(dbametadata), intent(in) :: that
1918
1919dbafilter_equal_dbametadata = .false.
1920
1921!! TODO utilizzare dataonly ? direi di no
1922
1923if (this%contextana .and. c_e(that%timerange%vol7d_timerange)) return
1924if (this%contextana .and. c_e(that%datetime%datetime)) return
1925if (this%contextana .and. c_e(that%level%vol7d_level)) return
1927if (c_e(this%level%vol7d_level) .and. .not. this%level%vol7d_level == that%level%vol7d_level ) return
1928if (c_e(this%timerange%vol7d_timerange) .and. .not. this%timerange%vol7d_timerange == that%timerange%vol7d_timerange ) return
1929if (c_e(this%datetime%datetime) .and. .not. this%datetime%datetime == that%datetime%datetime ) return
1930if (c_e(this%network%vol7d_network) .and. .not. this%network%vol7d_network == that%network%vol7d_network ) return
1931if (c_e(this%ana%vol7d_ana) .and. .not. this%ana%vol7d_ana == that%ana%vol7d_ana ) return
1932
1933if ( c_e(this%datetimemin%datetime) .and. c_e(that%datetime%datetime) .and. &
1934 this%datetimemin%datetime > that%datetime%datetime ) return
1935if ( c_e(this%datetimemax%datetime) .and. c_e(that%datetime%datetime) .and. &
1936 this%datetimemax%datetime < that%datetime%datetime ) return
1937
1938if (c_e(this%coordmin%geo_coord)) then
1939 if (geo_coord_ll(that%ana%vol7d_ana%coord, this%coordmin%geo_coord)) return
1940end if
1942if (c_e(this%coordmax%geo_coord)) then
1943 if (geo_coord_ur(that%ana%vol7d_ana%coord, this%coordmax%geo_coord)) return
1944end if
1945
1946dbafilter_equal_dbametadata = .true.
1947
1948end function dbafilter_equal_dbametadata
1949
1950
1951!!$!> equal operator for dbafilter and dbadata
1952!!$! todo qui vuene utilizzata vars ma potrebbe essere attrs: bisogna distinguere
1953!!$elemental logical function dbafilter_equal_dbadata(this,that)
1954!!$
1955!!$class(dbafilter), intent(in) :: this !< first element
1956!!$class(dbadata), intent(in) :: that !< second element
1957!!$
1958!!$integer :: i
1959!!$
1960!!$!non compila:
1961!!$!dbafilter_equal_dbadata = any(this%vars%dcv(:)%dat == that)
1962!!$
1963!!$if (allocated(this%vars%dcv)) then
1964!!$ do i=1, size(this%vars%dcv(:))
1965!!$ dbafilter_equal_dbadata = this%vars%dcv(i)%dat == that
1966!!$ if (dbafilter_equal_dbadata) continue
1967!!$ end do
1968!!$else
1969!!$ dbafilter_equal_dbadata=.false.
1970!!$end if
1971!!$
1972!!$end function dbafilter_equal_dbadata
1973
1974
1977elemental logical function dbadcv_equal_dbadata(this,that)
1978
1979class(dbadcv), intent(in) :: this
1980class(dbadata), intent(in) :: that
1981
1982integer :: i
1983
1984!non compila:
1985!dbafilter_equal_dbadata = any(this%vars%dcv(:)%dat == that)
1986
1987if (allocated(this%dcv)) then
1988 dbadcv_equal_dbadata=.false.
1989 do i=1, size(this%dcv)
1990 dbadcv_equal_dbadata = this%dcv(i)%dat == that
1991 if (dbadcv_equal_dbadata) exit
1992 end do
1993else
1994 dbadcv_equal_dbadata=.true.
1995end if
1996
1997end function dbadcv_equal_dbadata
1998
1999
2001elemental logical function dbametadata_equal(this,that)
2003class(dbametadata), intent(in) :: this
2004class(dbametadata), intent(in) :: that
2005
2006if ( &
2007 this%level%vol7d_level == that%level%vol7d_level .and. &
2008 this%timerange%vol7d_timerange == that%timerange%vol7d_timerange .and. &
2009 this%datetime%datetime == that%datetime%datetime .and. &
2010 this%network%vol7d_network == that%network%vol7d_network .and. &
2011 this%ana%vol7d_ana == that%ana%vol7d_ana &
2012 ) then
2013 dbametadata_equal = .true.
2014else
2015 dbametadata_equal = .false.
2016end if
2017
2018end function dbametadata_equal
2019
2020
2024type(dbafilter) function dbafilter_init(filter,ana,var,datetime,level,timerange,network,&
2025 datetimemin,datetimemax,coordmin,coordmax,limit,&
2026 ana_filter, data_filter, attr_filter, varlist, starvarlist, anavarlist, anastarvarlist ,&
2027 priority, priomin, priomax, contextana,&
2028 vars, starvars, anavars, anastarvars, query,anaonly,dataonly)
2029
2030type(dbafilter),intent(in),optional :: filter
2031type(dbaana),intent(in),optional :: ana
2032character(len=*),intent(in),optional :: var
2033type(dbadatetime),intent(in),optional :: datetime
2034type(dbalevel),intent(in),optional :: level
2035type(dbatimerange),intent(in),optional :: timerange
2036type(dbanetwork),intent(in),optional :: network
2037type(dbacoord),intent(in),optional :: coordmin
2038type(dbacoord),intent(in),optional :: coordmax
2039type(dbadatetime),intent(in),optional :: datetimemin
2040type(dbadatetime),intent(in),optional :: datetimemax
2041integer,intent(in),optional :: limit
2042character(len=*),intent(in),optional :: ana_filter
2043character(len=*),intent(in),optional :: data_filter
2044character(len=*),intent(in),optional :: attr_filter
2045character(len=*),intent(in),optional :: varlist
2046character(len=*),intent(in),optional :: starvarlist
2047character(len=*),intent(in),optional :: anavarlist
2048character(len=*),intent(in),optional :: anastarvarlist
2049integer,intent(in),optional :: priority
2050integer,intent(in),optional :: priomin
2051integer,intent(in),optional :: priomax
2052logical,intent(in),optional :: contextana
2053class(dbadcv),intent(in),optional :: vars ! vector of vars wanted on output
2054class(dbadcv),intent(in),optional :: starvars ! vector of vars for attribute wanted on output
2055class(dbadcv),intent(in),optional :: anavars ! vector of ana vars wanted on output
2056class(dbadcv),intent(in),optional :: anastarvars ! vector of vars for attribute of ana wanted on output
2057character(len=*),intent(in),optional :: query
2058logical,intent(in),optional :: anaonly
2059logical,intent(in),optional :: dataonly
2060
2061integer :: i
2062logical :: nopreserve
2064nopreserve=.true.
2065if (present(filter)) then
2066 dbafilter_init=filter
2067
2068!!$ if (allocated(filter%vars%dcv)) then
2069!!$ if (allocated(dbafilter_init%vars%dcv)) deallocate(dbafilter_init%vars%dcv)
2070!!$ allocate(dbafilter_init%vars%dcv(size(filter%vars%dcv)))
2071!!$ do i =1,size(filter%vars%dcv)
2072!!$ allocate(dbafilter_init%vars%dcv(i)%dat,source=filter%vars%dcv(i)%dat)
2073!!$ end do
2074!!$ end if
2075!!$
2076!!$ if (allocated(filter%starvars%dcv)) then
2077!!$ if (allocated(dbafilter_init%starvars%dcv)) deallocate(dbafilter_init%starvars%dcv)
2078!!$ allocate(dbafilter_init%starvars%dcv(size(filter%starvars%dcv)))
2079!!$ do i =1,size(filter%starvars%dcv)
2080!!$ allocate(dbafilter_init%starvars%dcv(i)%dat,source=filter%starvars%dcv(i)%dat)
2081!!$ end do
2082!!$ end if
2083!!$
2084!!$ if (allocated(filter%anavars%dcv)) then
2085!!$ if (allocated(dbafilter_init%anavars%dcv)) deallocate(dbafilter_init%anavars%dcv)
2086!!$ allocate(dbafilter_init%anavars%dcv(size(filter%anavars%dcv)))
2087!!$ do i =1,size(filter%anavars%dcv)
2088!!$ call filter%anavars%dcv(i)%dat%display()
2089!!$ allocate(dbafilter_init%anavars%dcv(i)%dat,source=filter%anavars%dcv(i)%dat)
2090!!$ end do
2091!!$ end if
2092!!$
2093!!$ if (allocated(filter%anastarvars%dcv)) then
2094!!$ if (allocated(dbafilter_init%anastarvars%dcv)) deallocate(dbafilter_init%anastarvars%dcv)
2095!!$ allocate(dbafilter_init%anastarvars%dcv(size(filter%anastarvars%dcv)))
2096!!$ do i =1,size(filter%anastarvars%dcv)
2097!!$ allocate(dbafilter_init%anastarvars%dcv(i)%dat,source=filter%anastarvars%dcv(i)%dat)
2098!!$ end do
2099!!$ end if
2100
2101 nopreserve=.false.
2102end if
2103
2104if (present(ana)) then
2105 dbafilter_init%ana=ana
2106else if (nopreserve) then
2107 dbafilter_init%ana=dbaana()
2108end if
2109
2110if (present(var)) then
2111 dbafilter_init%var=var
2112else if (nopreserve) then
2113 dbafilter_init%var=cmiss
2114end if
2115
2116if (present(datetime)) then
2117 dbafilter_init%datetime=datetime
2118else if (nopreserve) then
2119 dbafilter_init%datetime=dbadatetime()
2120end if
2121
2122if (present(level)) then
2123 dbafilter_init%level=level
2124else if (nopreserve) then
2125 dbafilter_init%level=dbalevel()
2126end if
2127
2128if (present(timerange)) then
2129 dbafilter_init%timerange=timerange
2130else if (nopreserve) then
2131 dbafilter_init%timerange=dbatimerange()
2132end if
2133
2134if (present(network)) then
2135 dbafilter_init%network=network
2136else if (nopreserve) then
2137 dbafilter_init%network=dbanetwork()
2138end if
2139
2140if (present(datetimemin)) then
2141 dbafilter_init%datetimemin=datetimemin
2142else if (nopreserve) then
2143 dbafilter_init%datetimemin=dbadatetime()
2144end if
2145
2146if (present(datetimemax)) then
2147 dbafilter_init%datetimemax=datetimemax
2148else if (nopreserve) then
2149 dbafilter_init%datetimemax=dbadatetime()
2150end if
2151
2152if (present(coordmin)) then
2153 dbafilter_init%coordmin=coordmin
2154else if (nopreserve) then
2155 dbafilter_init%coordmin=dbacoord()
2156end if
2157
2158if (present(coordmax)) then
2159 dbafilter_init%coordmax=coordmax
2160else if (nopreserve) then
2161 dbafilter_init%coordmax=dbacoord()
2162end if
2163
2164if (present(limit)) then
2165 dbafilter_init%limit=limit
2166else if (nopreserve) then
2167 dbafilter_init%limit=imiss
2168end if
2169
2170if (present(ana_filter)) then
2171 dbafilter_init%ana_filter=ana_filter
2172else if (nopreserve) then
2173 dbafilter_init%ana_filter=cmiss
2174end if
2175
2176if (present(data_filter)) then
2177 dbafilter_init%data_filter=data_filter
2178else if (nopreserve) then
2179 dbafilter_init%data_filter=cmiss
2180end if
2181
2182if (present(attr_filter)) then
2183 dbafilter_init%attr_filter=attr_filter
2184else if (nopreserve) then
2185 dbafilter_init%attr_filter=cmiss
2186end if
2187
2188if (present(varlist)) then
2189 dbafilter_init%varlist=varlist
2190else if (nopreserve) then
2191 dbafilter_init%varlist=cmiss
2192end if
2193
2194if (present(starvarlist)) then
2195 dbafilter_init%starvarlist=starvarlist
2196else if (nopreserve) then
2197 dbafilter_init%starvarlist=cmiss
2198end if
2199
2200if (present(anavarlist)) then
2201 dbafilter_init%anavarlist=anavarlist
2202else if (nopreserve) then
2203 dbafilter_init%anavarlist=cmiss
2204end if
2205
2206if (present(anastarvarlist)) then
2207 dbafilter_init%anastarvarlist=anastarvarlist
2208else if (nopreserve) then
2209 dbafilter_init%anastarvarlist=cmiss
2210end if
2211
2212if (present(vars)) then
2213 if (allocated(vars%dcv)) then
2214 allocate(dbafilter_init%vars%dcv(size(vars%dcv)))
2215 do i =1,size(vars%dcv)
2216 allocate(dbafilter_init%vars%dcv(i)%dat,source=vars%dcv(i)%dat)
2217 end do
2218
2219 dbafilter_init%varlist=""
2220 do i=1,size(vars%dcv)
2221 dbafilter_init%varlist=trim(dbafilter_init%varlist)//vars%dcv(i)%dat%btable
2222 if (i /= size(vars%dcv)) dbafilter_init%varlist=trim(dbafilter_init%varlist)//","
2223 end do
2224 endif
2225end if
2226
2227if (present(starvars)) then
2228 if (allocated(starvars%dcv)) then
2229 allocate(dbafilter_init%starvars%dcv(size(starvars%dcv)))
2230 do i =1,size(starvars%dcv)
2231 allocate(dbafilter_init%starvars%dcv(i)%dat,source=starvars%dcv(i)%dat)
2232 end do
2233
2234 dbafilter_init%starvarlist=""
2235 do i=1,size(starvars%dcv)
2236 dbafilter_init%starvarlist=trim(dbafilter_init%starvarlist)//starvars%dcv(i)%dat%btable
2237 if (i /= size(starvars%dcv)) dbafilter_init%starvarlist=trim(dbafilter_init%starvarlist)//","
2238 end do
2239 end if
2240end if
2241
2242
2243if (present(anavars)) then
2244 if (allocated(anavars%dcv)) then
2245 allocate(dbafilter_init%anavars%dcv(size(anavars%dcv)))
2246 do i =1,size(anavars%dcv)
2247 allocate(dbafilter_init%anavars%dcv(i)%dat,source=anavars%dcv(i)%dat)
2248 end do
2249
2250 dbafilter_init%anavarlist=""
2251 do i=1,size(anavars%dcv)
2252 dbafilter_init%anavarlist=trim(dbafilter_init%anavarlist)//anavars%dcv(i)%dat%btable
2253 if (i /= size(anavars%dcv)) dbafilter_init%anavarlist=trim(dbafilter_init%anavarlist)//","
2254 end do
2255 endif
2256end if
2257
2258if (present(anastarvars)) then
2259 if (allocated(anastarvars%dcv)) then
2260 allocate(dbafilter_init%anastarvars%dcv(size(anastarvars%dcv)))
2261 do i =1,size(anastarvars%dcv)
2262 allocate(dbafilter_init%anastarvars%dcv(i)%dat,source=anastarvars%dcv(i)%dat)
2263 end do
2264
2265 dbafilter_init%anastarvarlist=""
2266 do i=1,size(anastarvars%dcv)
2267 dbafilter_init%anastarvarlist=trim(dbafilter_init%anastarvarlist)//anastarvars%dcv(i)%dat%btable
2268 if (i /= size(anastarvars%dcv)) dbafilter_init%anastarvarlist=trim(dbafilter_init%anastarvarlist)//","
2269 end do
2270 end if
2271end if
2272
2273if (present(priority)) then
2274 dbafilter_init%priority=priority
2275else if (nopreserve) then
2276 dbafilter_init%priority=imiss
2277end if
2278
2279if (present(priomin)) then
2280 dbafilter_init%priomin=priomax
2281else if (nopreserve) then
2282 dbafilter_init%priomin=imiss
2283end if
2284
2285if (present(priomax)) then
2286 dbafilter_init%priomax=priomax
2287else if (nopreserve) then
2288 dbafilter_init%priomax=imiss
2289end if
2290
2291if (present(contextana)) then
2292 dbafilter_init%contextana=contextana
2293else if (nopreserve) then
2294 dbafilter_init%contextana=.false.
2295end if
2296
2297if (present(anaonly)) then
2298 dbafilter_init%anaonly=anaonly
2299else if (nopreserve) then
2300 dbafilter_init%anaonly=.false.
2301end if
2302if (present(dataonly)) then
2303 dbafilter_init%dataonly=dataonly
2304else if (nopreserve) then
2305 dbafilter_init%dataonly=.false.
2306end if
2307
2308if (present(query)) then
2309 dbafilter_init%query=query
2310else if (nopreserve) then
2311 dbafilter_init%query=cmiss
2312end if
2313
2314end function dbafilter_init
2315
2317subroutine dbafilter_display(filter)
2318class(dbafilter), intent(in) :: filter
2319
2320print *,"------------------ filter ---------------"
2321call filter%ana%display()
2322call filter%datetime%display()
2323call filter%level%display()
2324call filter%timerange%display()
2325call filter%network%display()
2326print *, " >>>> minimum:"
2327call filter%datetimemin%display()
2328call filter%coordmin%display()
2329print *, " >>>> maximum:"
2330call filter%datetimemax%display()
2331call filter%coordmax%display()
2332print *, " >>>> vars:"
2333call filter%vars%display()
2334print *, " >>>> starvars:"
2335call filter%starvars%display()
2336print *, " >>>> anavars:"
2337call filter%anavars%display()
2338print *, " >>>> anastarvars:"
2339call filter%anastarvars%display()
2340print *,"var=",filter%var
2341print *,"limit=",filter%limit
2342print *,"ana_filter=",trim(filter%ana_filter)
2343print *,"data_filter=",trim(filter%data_filter)
2344print *,"attr_filter=",trim(filter%attr_filter)
2345print *,"varlist=",trim(filter%varlist)
2346print *,"*varlist=",trim(filter%starvarlist)
2347print *,"anavarlist=",trim(filter%anavarlist)
2348print *,"ana*varlist=",trim(filter%anastarvarlist)
2349print *,"priority=",filter%priority
2350print *,"priomin=",filter%priomin
2351print *,"priomax=",filter%priomax
2352print *,"contextana=",filter%contextana
2353print *,"anaonly=",filter%anaonly
2354print *,"dataonly=",filter%dataonly
2355print *,"query=",trim(filter%query)
2356
2357print *,"-----------------------------------------"
2358
2359end subroutine dbafilter_display
2360
2362subroutine dbafilter_set(filter,session)
2363class(dbafilter), intent(in) :: filter
2364type(dbasession), intent(in) :: session
2365
2366integer :: ier,year,month,day,hour,minute,sec,msec
2367
2368call session%unsetall()
2369
2370call filter%ana%dbaset(session)
2371call filter%network%dbaset(session)
2372ier = idba_set(session%sehandle,"var",filter%var)
2373
2374ier = idba_set(session%sehandle,"limit",filter%limit)
2375ier = idba_set(session%sehandle,"priority",filter%priority)
2376ier = idba_set(session%sehandle,"priomin",filter%priomin)
2377ier = idba_set(session%sehandle,"priomax",filter%priomax)
2378
2379ier = idba_set(session%sehandle,"latmin",getilat(filter%coordmin%geo_coord))
2380ier = idba_set(session%sehandle,"lonmin",getilon(filter%coordmin%geo_coord))
2381ier = idba_set(session%sehandle,"latmax",getilat(filter%coordmax%geo_coord))
2382ier = idba_set(session%sehandle,"lonmax",getilon(filter%coordmax%geo_coord))
2383
2384ier = idba_set(session%sehandle,"ana_filter",filter%ana_filter)
2385ier = idba_set(session%sehandle,"data_filter",filter%data_filter)
2386ier = idba_set(session%sehandle,"attr_filter",filter%attr_filter)
2387
2388ier = idba_set(session%sehandle,"query",filter%query)
2389
2390if (filter%contextana) then
2391
2392 call session%setcontextana()
2393
2394 ier = idba_set(session%sehandle,"varlist",filter%anavarlist)
2395 ier = idba_set(session%sehandle,"*varlist",filter%anastarvarlist)
2396
2397else
2398
2399 if (c_e(filter%datetime%datetime)) call filter%datetime%dbaset(session)
2400 if (c_e(filter%level%vol7d_level)) call filter%level%dbaset(session)
2401 if (c_e(filter%timerange%vol7d_timerange)) call filter%timerange%dbaset(session)
2402
2403 CALL getval(filter%datetimemin%datetime, year=year, month=month, day=day, hour=hour, minute=minute,msec=msec)
2404 if (c_e(msec)) then
2405 sec=nint(float(msec)/1000.)
2406 else
2407 sec=imiss
2408 end if
2409
2410 ier = idba_set(session%sehandle,"yearmin",year)
2411 ier = idba_set(session%sehandle,"monthmin",month)
2412 ier = idba_set(session%sehandle,"daymin",day)
2413 ier = idba_set(session%sehandle,"hourmin",hour)
2414 ier = idba_set(session%sehandle,"minumin",minute)
2415 ier = idba_set(session%sehandle,"secmin",sec)
2416
2417 CALL getval(filter%datetimemax%datetime, year=year, month=month, day=day, hour=hour, minute=minute,msec=msec)
2418
2419 if (c_e(msec)) then
2420 sec=nint(float(msec)/1000.)
2421 else
2422 sec=imiss
2423 end if
2424
2425 ier = idba_set(session%sehandle,"yearmax",year)
2426 ier = idba_set(session%sehandle,"monthmax",month)
2427 ier = idba_set(session%sehandle,"daymax",day)
2428 ier = idba_set(session%sehandle,"hourmax",hour)
2429 ier = idba_set(session%sehandle,"minumax",minute)
2430 ier = idba_set(session%sehandle,"secmax",sec)
2431
2432
2433 ier = idba_set(session%sehandle,"varlist",filter%varlist)
2434 ier = idba_set(session%sehandle,"*varlist",filter%starvarlist)
2435end if
2436
2437end subroutine dbafilter_set
2438
2439
2441type(dbametadata) function dbametadata_contextana(metadata)
2442class(dbametadata), intent(in) :: metadata
2443
2444type (dbadatetime) :: datetime
2445type (dbalevel) :: level
2446type (dbatimerange) :: timerange
2447
2448select type(metadata)
2449type is(dbametadata)
2450 dbametadata_contextana=metadata
2451end select
2452
2453dbametadata_contextana%datetime=datetime%dbacontextana()
2454dbametadata_contextana%level=level%dbacontextana()
2455dbametadata_contextana%timerange=timerange%dbacontextana()
2456
2457end function dbametadata_contextana
2458
2459
2461subroutine dbametaanddata_display(metaanddata)
2462class(dbametaanddata), intent(in) :: metaanddata
2463
2464call metaanddata%metadata%display()
2465call metaanddata%dataattrv%display()
2466
2467end subroutine dbametaanddata_display
2468
2470subroutine dbametaanddata_extrude(metaanddata,session,noattr,filter,attronly,template)
2471class(dbametaanddata), intent(in) :: metaanddata
2472type(dbasession), intent(in) :: session
2473logical, intent(in),optional :: noattr
2474type(dbafilter),intent(in),optional :: filter
2475logical, intent(in),optional :: attronly
2476character(len=*),intent(in),optional :: template
2477
2478type(dbafilter) :: myfilter
2479
2480!print *,"------------------"
2481!call metaanddata%display()
2482!print *,"contextana false"
2483
2484myfilter=dbafilter(filter=filter,contextana=.false.)
2485call extrude(metaanddata,session,noattr,myfilter,attronly,template)
2486
2487!print *,"contextana true"
2488myfilter=dbafilter(filter=filter,contextana=.true.)
2489call extrude(metaanddata,session,noattr,myfilter,attronly,template)
2490
2491contains
2492
2493subroutine extrude(metaanddata,session,noattr,filter,attronly,template)
2494class(dbametaanddata), intent(in) :: metaanddata
2495type(dbasession), intent(in) :: session
2496logical, intent(in),optional :: noattr
2497type(dbafilter),intent(in) :: filter
2498logical, intent(in),optional :: attronly
2499character(len=*),intent(in),optional :: template
2500
2501if (.not. filter == metaanddata%metadata) return
2502
2503call session%unsetall()
2504!write metadata
2505call session%set(metadata=metaanddata%metadata)
2506
2507!write data and attribute
2508!call session%extrude(metaanddata%dataattrv,noattr,filter)
2509call metaanddata%dataattrv%extrude(session,noattr,filter,attronly)
2510
2511!to close message on file
2512call session%close_message(template)
2513
2514end subroutine extrude
2515end subroutine dbametaanddata_extrude
2516
2517
2519subroutine dbametaanddatav_display(metaanddatav)
2520class(dbametaanddatav), intent(in) :: metaanddatav
2521
2522call metaanddatav%metadata%display()
2523call metaanddatav%datav%display()
2524
2525end subroutine dbametaanddatav_display
2526
2528subroutine dbametaanddatav_extrude(metaanddatav,session,noattr,filter,template)
2529class(dbametaanddatav), intent(in) :: metaanddatav
2530type(dbasession), intent(in) :: session
2531logical, intent(in),optional :: noattr
2532type(dbafilter),intent(in),optional :: filter
2533character(len=*),intent(in),optional :: template
2534
2535type(dbafilter) :: myfilter
2536
2537myfilter=dbafilter(filter=filter,contextana=.false.)
2538call extrude(metaanddatav,session,noattr,myfilter,template)
2539
2540myfilter=dbafilter(filter=filter,contextana=.true.)
2541call extrude(metaanddatav,session,noattr,myfilter,template)
2542
2543contains
2544
2545subroutine extrude(metaanddatav,session,noattr,filter,template)
2546class(dbametaanddatav), intent(in) :: metaanddatav
2547type(dbasession), intent(in) :: session
2548logical, intent(in),optional :: noattr
2549type(dbafilter),intent(in) :: filter
2550character(len=*),intent(in),optional :: template
2551
2552if (.not. filter == metaanddatav%metadata)return
2553!write metadata
2554call session%set(metadata=metaanddatav%metadata)
2555
2556!write ana data and attribute
2557!!$call session%set(datav=metaanddatav%datav)
2558call metaanddatav%datav%extrude(session,noattr,filter,template)
2559
2560print*,"dbaana_metaanddatav"
2561!to close message on file
2562call session%close_message(template)
2563
2564end subroutine extrude
2565end subroutine dbametaanddatav_extrude
2566
2567
2569subroutine dbametaanddatal_extrude(metaanddatal,session,noattr,filter,attronly,template)
2570class(dbametaanddatalist), intent(inout) :: metaanddatal
2571class(dbasession), intent(in) :: session
2572logical, intent(in),optional :: noattr
2573type(dbafilter),intent(in),optional :: filter
2574type(dbametaanddata) :: metaanddata
2575logical, intent(in),optional :: attronly
2576character(len=*),intent(in),optional :: template
2577
2578call metaanddatal%rewind()
2579do while(metaanddatal%element())
2580 !call session%extrude(metaanddatal%current(),noattr,filter)
2581 metaanddata=metaanddatal%current()
2582 call metaanddata%extrude(session,noattr,filter,attronly,template)
2583 call metaanddatal%next()
2584end do
2585
2586end subroutine dbametaanddatal_extrude
2587
2588
2590subroutine displaydbametaanddatai(this)
2591class(dbametaanddatailist),intent(inout) :: this
2592type(dbametaanddatai) :: element
2593
2594call this%rewind()
2595do while(this%element())
2596 print *,"index:",this%currentindex()," value:"
2597 element=this%current()
2598 call element%display()
2599 call this%next()
2600end do
2601end subroutine displaydbametaanddatai
2602
2604type(dbametaanddatai) function currentdbametaanddatai(this)
2605class(dbametaanddatailist) :: this
2606class(*), pointer :: v
2607
2608v => this%currentpoli()
2609select type(v)
2610type is (dbametaanddatai)
2611 currentdbametaanddatai = v
2612end select
2613end function currentdbametaanddatai
2614
2615
2617subroutine dbasession_ingest_metaanddatail(session,metaanddatal,filter)
2618class(dbasession), intent(inout) :: session
2619type(dbametaanddatailist), intent(inout) :: metaanddatal
2620type(dbafilter),intent(in),optional :: filter
2621
2622type(dbametaanddatai) :: element
2623
2624
2625if (session%memdb .and. .not. session%loadfile)then
2626
2627 do while (session%messages_read_next())
2628 call session%set(filter=filter)
2629 call session%ingest_metaanddatai()
2630 call session%ingest_metaanddatai(element)
2631 call metaanddatal%append(element)
2632 call session%remove_all()
2633 end do
2634
2635else
2636
2637 call session%set(filter=filter)
2638 call session%ingest_metaanddatai()
2639 do while (c_e(session%count) .and. session%count >0)
2640 call session%ingest_metaanddatai(element)
2641 call metaanddatal%append(element)
2642 if (session%file) call session%ingest()
2643 end do
2644
2645end if
2646
2647end subroutine dbasession_ingest_metaanddatail
2648
2650function toarray_dbametaanddatai(this)
2651type(dbametaanddatai),allocatable :: toarray_dbametaanddatai(:)
2652class(dbametaanddatailist) :: this
2653
2654integer :: i
2655
2656allocate (toarray_dbametaanddatai(this%countelements()))
2657
2658call this%rewind()
2659i=0
2660do while(this%element())
2661 i=i+1
2662 toarray_dbametaanddatai(i) =this%current()
2663 call this%next()
2664end do
2665end function toarray_dbametaanddatai
2666
2667
2669subroutine displaydbametaanddatar(this)
2670class(dbametaanddatarlist),intent(inout) :: this
2671type(dbametaanddatar) :: element
2672
2673call this%rewind()
2674do while(this%element())
2675 print *,"index:",this%currentindex()," value:"
2676 element=this%current()
2677 call element%display()
2678 call this%next()
2679end do
2680end subroutine displaydbametaanddatar
2681
2683type(dbametaanddatar) function currentdbametaanddatar(this)
2684class(dbametaanddatarlist) :: this
2685class(*), pointer :: v
2686
2687v => this%currentpoli()
2688select type(v)
2689type is (dbametaanddatar)
2690 currentdbametaanddatar = v
2691end select
2692end function currentdbametaanddatar
2693
2694
2696subroutine dbasession_ingest_metaanddatarl(session,metaanddatal,filter)
2697class(dbasession), intent(inout) :: session
2698type(dbametaanddatarlist), intent(inout) :: metaanddatal
2699type(dbafilter),intent(in),optional :: filter
2700
2701type(dbametaanddatar) :: element
2702
2703if (session%memdb .and. .not. session%loadfile)then
2704
2705 do while (session%messages_read_next())
2706 call session%set(filter=filter)
2707 call session%ingest_metaanddatar()
2708 call session%ingest_metaanddatar(element)
2709 call metaanddatal%append(element)
2710 call session%remove_all()
2711 end do
2712
2713else
2714
2715 call session%set(filter=filter)
2716 call session%ingest_metaanddatar()
2717 do while (c_e(session%count) .and. session%count >0)
2718 call session%ingest_metaanddatar(element)
2719 call metaanddatal%append(element)
2720 if (session%file) call session%ingest()
2721 end do
2722
2723end if
2724
2725
2726end subroutine dbasession_ingest_metaanddatarl
2727
2728
2730function toarray_dbametaanddatar(this)
2731type(dbametaanddatar),allocatable :: toarray_dbametaanddatar(:)
2732class(dbametaanddatarlist) :: this
2733
2734integer :: i
2735i=this%countelements()
2736!print *, "allocate:",i
2737allocate (toarray_dbametaanddatar(this%countelements()))
2738
2739call this%rewind()
2740i=0
2741do while(this%element())
2742 i=i+1
2743 toarray_dbametaanddatar(i) =this%current()
2744 call this%next()
2745end do
2746end function toarray_dbametaanddatar
2747
2748
2750subroutine displaydbametaanddatad(this)
2751class(dbametaanddatadlist),intent(inout) :: this
2752type(dbametaanddatad) :: element
2753
2754call this%rewind()
2755do while(this%element())
2756 print *,"index:",this%currentindex()," value:"
2757 element=this%current()
2758 call element%display()
2759 call this%next()
2760end do
2761end subroutine displaydbametaanddatad
2762
2764type(dbametaanddatad) function currentdbametaanddatad(this)
2765class(dbametaanddatadlist) :: this
2766class(*), pointer :: v
2767
2768v => this%currentpoli()
2769select type(v)
2770type is (dbametaanddatad)
2771 currentdbametaanddatad = v
2772end select
2773end function currentdbametaanddatad
2774
2776subroutine dbasession_ingest_metaanddatadl(session,metaanddatal,filter)
2777class(dbasession), intent(inout) :: session
2778type(dbametaanddatadlist), intent(inout) :: metaanddatal
2779type(dbafilter),intent(in),optional :: filter
2780
2781type(dbametaanddatad) :: element
2782
2783if (session%memdb .and. .not. session%loadfile)then
2784
2785 do while (session%messages_read_next())
2786 call session%set(filter=filter)
2787 call session%ingest_metaanddatad()
2788 call session%ingest_metaanddatad(element)
2789 call metaanddatal%append(element)
2790 call session%remove_all()
2791 end do
2793else
2794
2795 call session%set(filter=filter)
2796 call session%ingest_metaanddatad()
2797 do while (c_e(session%count) .and. session%count >0)
2798 call session%ingest_metaanddatad(element)
2799 call metaanddatal%append(element)
2800 if (session%file) call session%ingest()
2801 end do
2802
2803end if
2804
2805end subroutine dbasession_ingest_metaanddatadl
2806
2807
2809function toarray_dbametaanddatad(this)
2810type(dbametaanddatad),allocatable :: toarray_dbametaanddatad(:)
2811class(dbametaanddatadlist) :: this
2812
2813integer :: i
2814
2815allocate (toarray_dbametaanddatad(this%countelements()))
2816
2817call this%rewind()
2818i=0
2819do while(this%element())
2820 i=i+1
2821 toarray_dbametaanddatad(i) =this%current()
2822 call this%next()
2823end do
2824end function toarray_dbametaanddatad
2825
2826
2828subroutine displaydbametaanddatab(this)
2829class(dbametaanddatablist),intent(inout) :: this
2830type(dbametaanddatab) :: element
2831
2832call this%rewind()
2833do while(this%element())
2834 print *,"index:",this%currentindex()," value:"
2835 element=this%current()
2836 call element%display()
2837 call this%next()
2838end do
2839end subroutine displaydbametaanddatab
2840
2842type(dbametaanddatab) function currentdbametaanddatab(this)
2843class(dbametaanddatablist) :: this
2844class(*), pointer :: v
2845
2846v => this%currentpoli()
2847select type(v)
2848type is (dbametaanddatab)
2849 currentdbametaanddatab = v
2850end select
2851end function currentdbametaanddatab
2852
2853
2855subroutine dbasession_ingest_metaanddatabl(session,metaanddatal,filter)
2856class(dbasession), intent(inout) :: session
2857type(dbametaanddatablist), intent(inout) :: metaanddatal
2858type(dbafilter),intent(in),optional :: filter
2859
2860type(dbametaanddatab) :: element
2861
2862if (session%memdb .and. .not. session%loadfile)then
2863
2864 do while (session%messages_read_next())
2865 call session%set(filter=filter)
2866 call session%ingest_metaanddatab()
2867 call session%ingest_metaanddatab(element)
2868 call metaanddatal%append(element)
2869 call session%remove_all()
2870 end do
2872else
2873
2874 call session%set(filter=filter)
2875 call session%ingest_metaanddatab()
2876 do while (c_e(session%count) .and. session%count >0)
2877 call session%ingest_metaanddatab(element)
2878 call metaanddatal%append(element)
2879 if (session%file) call session%ingest()
2880 end do
2881
2882end if
2883
2884end subroutine dbasession_ingest_metaanddatabl
2885
2886
2888function toarray_dbametaanddatab(this)
2889type(dbametaanddatab),allocatable :: toarray_dbametaanddatab(:)
2890class(dbametaanddatablist) :: this
2891
2892integer :: i
2893
2894allocate (toarray_dbametaanddatab(this%countelements()))
2895
2896call this%rewind()
2897i=0
2898do while(this%element())
2899 i=i+1
2900 toarray_dbametaanddatab(i) =this%current()
2901 call this%next()
2902end do
2903end function toarray_dbametaanddatab
2904
2905
2907subroutine displaydbametaanddatac(this)
2908class(dbametaanddataclist),intent(inout) :: this
2909type(dbametaanddatac) :: element
2910
2911call this%rewind()
2912do while(this%element())
2913 print *,"index:",this%currentindex()," value:"
2914 element=this%current()
2915 call element%display()
2916 call this%next()
2917end do
2918end subroutine displaydbametaanddatac
2919
2921type(dbametaanddatac) function currentdbametaanddatac(this)
2922class(dbametaanddataclist) :: this
2923class(*), pointer :: v
2924
2925v => this%currentpoli()
2926select type(v)
2927type is (dbametaanddatac)
2928 currentdbametaanddatac = v
2929end select
2930end function currentdbametaanddatac
2931
2932
2934subroutine dbasession_ingest_metaanddatacl(session,metaanddatal,filter)
2935class(dbasession), intent(inout) :: session
2936type(dbametaanddataclist), intent(inout) :: metaanddatal
2937type(dbafilter),intent(in),optional :: filter
2939type(dbametaanddatac) :: element
2940
2941if (session%memdb .and. .not. session%loadfile)then
2942
2943 do while (session%messages_read_next())
2944 call session%set(filter=filter)
2945 call session%ingest_metaanddatac()
2946 call session%ingest_metaanddatac(element)
2947 call metaanddatal%append(element)
2948 call session%remove_all()
2949 end do
2950
2951else
2953 call session%set(filter=filter)
2954 call session%ingest_metaanddatac()
2955 do while (c_e(session%count) .and. session%count >0)
2956 call session%ingest_metaanddatac(element)
2957 call metaanddatal%append(element)
2958 if (session%file) call session%ingest()
2959 end do
2960
2961end if
2962
2963end subroutine dbasession_ingest_metaanddatacl
2965
2967function toarray_dbametaanddatac(this)
2968type(dbametaanddatac),allocatable :: toarray_dbametaanddatac(:)
2969class(dbametaanddataclist) :: this
2970
2971integer :: i
2972
2973allocate (toarray_dbametaanddatac(this%countelements()))
2974
2975call this%rewind()
2976i=0
2977do while(this%element())
2978 i=i+1
2979 toarray_dbametaanddatac(i) =this%current()
2980 call this%next()
2981end do
2982end function toarray_dbametaanddatac
2983
2984
2986subroutine dbametaanddatai_display(data)
2987class(dbametaanddatai), intent(in) :: data
2988
2989call data%metadata%display()
2990call data%dbadatai%display()
2991
2992end subroutine dbametaanddatai_display
2993
2995subroutine dbametaanddatab_display(data)
2996class(dbametaanddatab), intent(in) :: data
2998call data%metadata%display()
2999call data%dbadatab%display()
3000
3001end subroutine dbametaanddatab_display
3002
3004subroutine dbametaanddatad_display(data)
3005class(dbametaanddatad), intent(in) :: data
3006
3007call data%metadata%display()
3008call data%dbadatad%display()
3009
3010end subroutine dbametaanddatad_display
3011
3013subroutine dbametaanddatar_display(data)
3014class(dbametaanddatar), intent(in) :: data
3015
3016call data%metadata%display()
3017call data%dbadatar%display()
3018
3019end subroutine dbametaanddatar_display
3020
3021
3023subroutine dbametaanddatac_display(data)
3024class(dbametaanddatac), intent(in) :: data
3025
3026call data%metadata%display()
3027call data%dbadatac%display()
3028
3029end subroutine dbametaanddatac_display
3031
3033subroutine dbametaanddatai_extrude(metaanddatai,session)
3034class(dbametaanddatai), intent(in) :: metaanddatai
3035type(dbasession), intent(in) :: session
3036
3037call session%unsetall()
3038!write metadata
3039call session%set(metadata=metaanddatai%metadata)
3040!write ana data and attribute
3041call session%set(data=metaanddatai%dbadatai)
3042
3043if (metaanddatai%dbadatai%c_e()) then
3044 call session%prendilo()
3045else
3046 call session%dimenticami()
3047endif
3048
3049end subroutine dbametaanddatai_extrude
3050
3052subroutine dbametaanddatab_extrude(metaanddatab,session)
3053class(dbametaanddatab), intent(in) :: metaanddatab
3054type(dbasession), intent(in) :: session
3055
3056call session%unsetall()
3057!write metadata
3058call session%set(metadata=metaanddatab%metadata)
3059!write ana data and attribute
3060call session%set(data=metaanddatab%dbadatab)
3061
3062if (metaanddatab%dbadatab%c_e()) then
3063 call session%prendilo()
3064else
3065 call session%dimenticami()
3066endif
3067
3068end subroutine dbametaanddatab_extrude
3069
3071subroutine dbametaanddatad_extrude(metaanddatad,session)
3072class(dbametaanddatad), intent(in) :: metaanddatad
3073type(dbasession), intent(in) :: session
3074
3075call session%unsetall()
3076!write metadata
3077call session%set(metadata=metaanddatad%metadata)
3078!write ana data and attribute
3079call session%set(data=metaanddatad%dbadatad)
3080
3081if (metaanddatad%dbadatad%c_e()) then
3082 call session%prendilo()
3083else
3084 call session%dimenticami()
3085endif
3086
3087end subroutine dbametaanddatad_extrude
3088
3090subroutine dbametaanddatar_extrude(metaanddatar,session)
3091class(dbametaanddatar), intent(in) :: metaanddatar
3092type(dbasession), intent(in) :: session
3093
3094call session%unsetall()
3095!write metadata
3096call session%set(metadata=metaanddatar%metadata)
3097!write ana data and attribute
3098call session%set(data=metaanddatar%dbadatar)
3099
3100if (metaanddatar%dbadatar%c_e()) then
3101 call session%prendilo()
3102else
3103 call session%dimenticami()
3104endif
3105
3106end subroutine dbametaanddatar_extrude
3107
3109subroutine dbametaanddatac_extrude(metaanddatac,session)
3110class(dbametaanddatac), intent(in) :: metaanddatac
3111type(dbasession), intent(in) :: session
3112
3113call session%unsetall()
3114!write metadata
3115call session%set(metadata=metaanddatac%metadata)
3116!write ana data and attribute
3117call session%set(data=metaanddatac%dbadatac)
3118
3119if (metaanddatac%dbadatac%c_e()) then
3120 call session%prendilo()
3121else
3122 call session%dimenticami()
3123endif
3124
3125end subroutine dbametaanddatac_extrude
3126
3128subroutine dbasession_ingest_ana(session,ana)
3129class(dbasession), intent(inout) :: session
3130type(dbaana), intent(out),optional :: ana
3131
3132integer :: ier
3133
3134if (.not. present(ana)) then
3135 ier = idba_quantesono(session%sehandle, session%count)
3136 !print *,"numero ana",session%count
3137else
3138 ier = idba_elencamele(session%sehandle)
3139 call ana%dbaenq(session)
3140 session%count=session%count-1
3141end if
3142
3143end subroutine dbasession_ingest_ana
3144
3145
3147subroutine dbasession_ingest_anav(session,anav)
3148class(dbasession), intent(inout) :: session
3149type(dbaana), intent(out),allocatable :: anav(:)
3150integer :: i
3151
3152call session%ingest_ana()
3153
3154if (c_e(session%count)) then
3155 allocate(anav(session%count))
3156 i=0
3157 do while (session%count >0)
3158 i=i+1
3159 call session%ingest_ana(anav(i))
3160 end do
3161else
3162 allocate(anav(0))
3163end if
3164
3165end subroutine dbasession_ingest_anav
3166
3167
3169subroutine dbasession_ingest_anal(session,anal)
3170class(dbasession), intent(inout) :: session
3171type(dbaanalist), intent(out) :: anal
3172type(dbaana) :: element
3173
3174call session%ingest_ana()
3175do while (c_e(session%count) .and. session%count >0)
3176 call session%ingest_ana(element)
3177 call anal%append(element)
3178 call session%ingest_ana()
3179end do
3180end subroutine dbasession_ingest_anal
3181
3182
3184subroutine dbasession_ingest_metaanddata(session,metaanddata,noattr,filter)
3185class(dbasession), intent(inout) :: session
3186type(dbametaanddata), intent(inout),optional :: metaanddata
3187logical,intent(in),optional :: noattr
3188type(dbafilter),intent(in),optional :: filter
3189
3190type(dbametadata) :: metadata
3191integer :: ier,acount,i,j,k
3192character(len=9) :: btable
3193character(255) :: value
3194logical :: lvars,lstarvars
3195type(dbadcv) :: vars,starvars
3196
3197
3198 ! if you do not pass metaanddata we presume to have to initialize the query
3199if (.not. present(metaanddata)) then
3200 ier = idba_voglioquesto(session%sehandle, session%count)
3202 ! preroll one read because after I have to read one more to check metadata
3203 if (c_e(session%count) .and. session%count > 0) then
3204 ier = idba_dammelo(session%sehandle, btable)
3205 end if
3206
3207else
3208
3209 ! you pass metaanddata so we continue with the query
3210
3211 if (allocated(metaanddata%dataattrv%dataattr)) then
3212 deallocate (metaanddata%dataattrv%dataattr)
3213 end if
3214
3215 lvars=.false.
3216 lstarvars=.false.
3217 if (present(filter)) then
3218
3219 if (filter%contextana) then
3220
3221 !todo try to use this: vars=filter%anavars
3222 if (allocated(filter%anavars%dcv)) then
3223 lvars=.true.
3224 allocate(vars%dcv(size(filter%anavars%dcv)))
3225 do i =1,size(filter%anavars%dcv)
3226 allocate(vars%dcv(i)%dat,source=filter%anavars%dcv(i)%dat)
3227 end do
3228 end if
3229
3230 if (allocated(filter%anastarvars%dcv)) then
3231 lstarvars=.true.
3232 allocate(starvars%dcv(size(filter%anastarvars%dcv)))
3233 do i =1,size(filter%anastarvars%dcv)
3234 allocate(starvars%dcv(i)%dat,source=filter%anastarvars%dcv(i)%dat)
3235 end do
3236 end if
3237
3238 else
3239
3240 if (allocated(filter%vars%dcv)) then
3241 lvars=.true.
3242 allocate(vars%dcv(size(filter%vars%dcv)))
3243 do i =1,size(filter%vars%dcv)
3244 allocate(vars%dcv(i)%dat,source=filter%vars%dcv(i)%dat)
3245 end do
3246 end if
3247
3248 if (allocated(filter%starvars%dcv)) then
3249 lstarvars=.true.
3250 allocate(starvars%dcv(size(filter%starvars%dcv)))
3251 do i =1,size(filter%starvars%dcv)
3252 allocate(starvars%dcv(i)%dat,source=filter%starvars%dcv(i)%dat)
3253 end do
3254 end if
3255
3256 end if
3257
3258 end if
3260 if (lvars) then
3261
3262 ! create an empty vector for data
3263 allocate (metaanddata%dataattrv%dataattr(size(vars%dcv)))
3264 do i = 1, size(vars%dcv)
3265 allocate (metaanddata%dataattrv%dataattr(i)%dat,source=vars%dcv(i)%dat)
3266 end do
3267
3268 ! load metadata
3269 call metaanddata%metadata%dbaenq(session)
3270 ! load curret metadata
3271 call metadata%dbaenq(session)
3272
3273 ! if current metadata is equal to metadata
3274 do while ( metaanddata%metadata == metadata )
3275 ier = idba_enq(session%sehandle,"var",btable)
3276 do i=1,size(metaanddata%dataattrv%dataattr)
3277 if (metaanddata%dataattrv%dataattr(i)%dat%btable == btable) then
3279 select type ( dat => metaanddata%dataattrv%dataattr(i)%dat )
3280 type is (dbadatai)
3281 ier = idba_enq(session%sehandle, btable,dat%value)
3282 type is (dbadatar)
3283 ier = idba_enq(session%sehandle, btable,dat%value)
3284 type is (dbadatad)
3285 ier = idba_enq(session%sehandle, btable,dat%value)
3286 type is (dbadatab)
3287 ier = idba_enq(session%sehandle, btable,dat%value)
3288 type is (dbadatac)
3289 ier = idba_enq(session%sehandle, btable,dat%value)
3290 end select
3291
3292 if (optio_log(noattr))then
3293 ! initialize to (0) the attribute vector
3294 allocate (metaanddata%dataattrv%dataattr(i)%attrv%dcv(0))
3295
3296 else
3298 if (lstarvars) then
3299
3300 allocate (metaanddata%dataattrv%dataattr(i)%attrv%dcv(size(starvars%dcv)))
3301 do j = 1, size(starvars%dcv)
3302 allocate (metaanddata%dataattrv%dataattr(i)%attrv%dcv(j)%dat,source=starvars%dcv(j)%dat)
3303 end do
3304
3305 if (c_e(session%count) .and. session%count > 0) then
3306
3307 ier = idba_voglioancora(session%sehandle, acount)
3308 do k =1,acount
3309 ier = idba_ancora(session%sehandle, btable)
3310 ier = idba_enq(session%sehandle, btable,value)
3311
3312 do j=1,size(metaanddata%dataattrv%dataattr(i)%attrv%dcv)
3313
3314 if (metaanddata%dataattrv%dataattr(i)%attrv%dcv(j)%dat%btable == btable) then
3315
3316 select type ( dat => metaanddata%dataattrv%dataattr(i)%attrv%dcv(j)%dat )
3317 type is (dbadatai)
3318 ier = idba_enq(session%sehandle, btable,dat%value)
3319 type is (dbadatar)
3320 ier = idba_enq(session%sehandle, btable,dat%value)
3321 type is (dbadatad)
3322 ier = idba_enq(session%sehandle, btable,dat%value)
3323 type is (dbadatab)
3324 ier = idba_enq(session%sehandle, btable,dat%value)
3325 type is (dbadatac)
3326 ier = idba_enq(session%sehandle, btable,dat%value)
3327 end select
3328
3329 end if
3330 end do
3331 end do
3332 end if
3333 else
3334 if (c_e(session%count) .and. session%count > 0) then
3335 ier = idba_voglioancora(session%sehandle, acount)
3336
3337 allocate (metaanddata%dataattrv%dataattr(i)%attrv%dcv(acount))
3338 do j =1,acount
3339 ier = idba_ancora(session%sehandle, btable)
3340 ier = idba_enq(session%sehandle, btable,value)
3341 allocate (metaanddata%dataattrv%dataattr(i)%attrv%dcv(j)%dat,source=dbadatac(btable,value))
3342 end do
3343 else
3344 allocate (metaanddata%dataattrv%dataattr(i)%attrv%dcv(0))
3345 end if
3346 end if
3347 end if
3348 end if
3349 end do
3350
3351 if (c_e(session%count)) session%count=session%count-1
3352
3353 if (c_e(session%count) .and. session%count > 0 ) then
3354 ier = idba_dammelo(session%sehandle, btable)
3355 call metadata%dbaenq(session)
3356 else
3357 metadata=dbametadata()
3358 end if
3359 end do
3360 else
3361
3362 allocate (metaanddata%dataattrv%dataattr(1))
3363 ier = idba_enq(session%sehandle,"var",btable)
3364 ier = idba_enq(session%sehandle, btable,value)
3365 allocate (metaanddata%dataattrv%dataattr(1)%dat,source=dbadatac(btable,value))
3366 call metaanddata%metadata%dbaenq(session)
3367
3368
3369 if (optio_log(noattr))then
3370
3371 allocate (metaanddata%dataattrv%dataattr(1)%attrv%dcv(0))
3373 else
3374
3375 if (lstarvars) then
3376
3377 allocate (metaanddata%dataattrv%dataattr(1)%attrv%dcv(size(starvars%dcv)))
3378 do j = 1, size(starvars%dcv)
3379 allocate (metaanddata%dataattrv%dataattr(1)%attrv%dcv(j)%dat,source=starvars%dcv(j)%dat)
3380 end do
3381
3382 if (c_e(session%count) .and. session%count > 0) then
3383
3384 ier = idba_voglioancora(session%sehandle, acount)
3385 do k =1,acount
3386 ier = idba_ancora(session%sehandle, btable)
3387 ier = idba_enq(session%sehandle, btable,value)
3388
3389 do j=1,size(metaanddata%dataattrv%dataattr(1)%attrv%dcv)
3390
3391 if (metaanddata%dataattrv%dataattr(1)%attrv%dcv(j)%dat%btable == btable) then
3392
3393 select type ( dat => metaanddata%dataattrv%dataattr(1)%attrv%dcv(j)%dat )
3394 type is (dbadatai)
3395 ier = idba_enq(session%sehandle, btable,dat%value)
3396 type is (dbadatar)
3397 ier = idba_enq(session%sehandle, btable,dat%value)
3398 type is (dbadatad)
3399 ier = idba_enq(session%sehandle, btable,dat%value)
3400 type is (dbadatab)
3401 ier = idba_enq(session%sehandle, btable,dat%value)
3402 type is (dbadatac)
3403 ier = idba_enq(session%sehandle, btable,dat%value)
3404 end select
3405
3406 end if
3407 end do
3408 end do
3409 end if
3410 else
3411 if (c_e(session%count) .and. session%count > 0) then
3412 ier = idba_voglioancora(session%sehandle, acount)
3413
3414 allocate (metaanddata%dataattrv%dataattr(1)%attrv%dcv(acount))
3415 do j =1,acount
3416 ier = idba_ancora(session%sehandle, btable)
3417 ier = idba_enq(session%sehandle, btable,value)
3418 allocate (metaanddata%dataattrv%dataattr(1)%attrv%dcv(j)%dat,source=dbadatac(btable,value))
3419 end do
3420 else
3421 allocate (metaanddata%dataattrv%dataattr(1)%attrv%dcv(0))
3422 end if
3423 end if
3424 end if
3425
3426 if (c_e(session%count)) then
3427 session%count=session%count-1
3428
3429 if (session%count > 0 ) then
3430 ier = idba_dammelo(session%sehandle, btable)
3431 end if
3432 end if
3433 end if
3434!!$ SOLVED by https://github.com/ARPA-SIMC/dballe/issues/73
3435!!$ !reading from file get some variable not in filter so we can have some attrv%dcv not allocated
3436 do i=1,size(metaanddata%dataattrv%dataattr)
3437 if (.not.allocated(metaanddata%dataattrv%dataattr(i)%attrv%dcv)) then
3438 allocate (metaanddata%dataattrv%dataattr(i)%attrv%dcv(0))
3439 endif
3440 end do
3441
3442end if
3443
3444end subroutine dbasession_ingest_metaanddata
3445
3446
3448subroutine dbasession_ingest_metaanddatav(session,metaanddatav,noattr,filter)
3449class(dbasession), intent(inout) :: session
3450type(dbametaanddata), intent(inout),allocatable :: metaanddatav(:)
3451logical, intent(in),optional :: noattr
3452type(dbafilter),intent(in),optional :: filter
3453
3454type(dbametaanddata),allocatable :: metaanddatavbuf(:)
3455integer :: i
3456
3457!todo aggiungere anche altrove dove passato filter
3458if (present(filter)) then
3459 call filter%dbaset(session)
3460else
3461 call session%unsetall()
3462endif
3463
3464call session%ingest()
3465!print*," count: ",session%count
3466
3467if (c_e(session%count)) then
3468 ! allocate to max dimension
3469 allocate(metaanddatavbuf(session%count))
3470 i=0
3471 do while (session%count >0)
3472 i=i+1
3473 call session%ingest(metaanddatavbuf(i),noattr=noattr,filter=filter)
3474 end do
3475
3476! compact data to real dimension
3477 IF (SIZE(metaanddatavbuf) == i) THEN
3478! space/time optimization in common case of no filter
3479 CALL move_alloc(metaanddatavbuf, metaanddatav)
3480 ELSE
3481! allocate (metaanddatav(i))
3482 metaanddatav=metaanddatavbuf(:i)
3483 DEALLOCATE(metaanddatavbuf)
3484 ENDIF
3485
3486else
3487 if (allocated(metaanddatav)) deallocate(metaanddatav)
3488 allocate(metaanddatav(0))
3489end if
3490
3491
3492end subroutine dbasession_ingest_metaanddatav
3493
3494
3496subroutine dbasession_ingest_metaanddatal(session,metaanddatal,noattr,filter)
3497class(dbasession), intent(inout) :: session
3498type(dbametaanddatalist), intent(out) :: metaanddatal
3499logical, intent(in),optional :: noattr
3500type(dbafilter),intent(in),optional :: filter
3501
3502type(dbametaanddata),allocatable :: metaanddatavbuf(:)
3503integer :: i
3504
3505if (session%memdb .and. .not. session%loadfile)then
3506
3507 do while (session%messages_read_next())
3508 call session%set(filter=filter)
3509 call session%ingest()
3510 call session%ingest(metaanddatavbuf,noattr=noattr,filter=filter)
3511 do i=1,size(metaanddatavbuf)
3512 call metaanddatal%append(metaanddatavbuf(i))
3513 end do
3514
3515 call session%remove_all()
3516 deallocate (metaanddatavbuf)
3517 end do
3518
3519else
3520
3521 call session%ingest()
3522
3523 do while (c_e(session%count) .and. session%count >0)
3524 call session%ingest(metaanddatavbuf,noattr=noattr,filter=filter)
3525 do i=1,size(metaanddatavbuf)
3526 if (present(filter)) then
3527 ! exclude contextana data from file
3528 if (filter%contextana) then
3529 if (datetime_new() /= metaanddatavbuf(i)%metadata%datetime%datetime) cycle
3530 end if
3531 end if
3532 call metaanddatal%append(metaanddatavbuf(i))
3533 end do
3534 if (session%file) call session%ingest()
3535 deallocate (metaanddatavbuf)
3536 end do
3537end if
3538
3539end subroutine dbasession_ingest_metaanddatal
3540
3542subroutine dbasession_ingest_metaanddatai(session,metaanddata)
3543class(dbasession), intent(inout) :: session
3544type(dbametaanddatai), intent(inout),optional :: metaanddata
3545
3546integer :: ier
3547character(len=9) :: btable
3548integer :: value
3549
3550if (.not. present(metaanddata)) then
3551 ier = idba_voglioquesto(session%sehandle, session%count)
3552else
3553 ier = idba_dammelo(session%sehandle, btable)
3554 ier = idba_enq(session%sehandle, btable,value)
3555 metaanddata%dbadatai=dbadatai(btable,value)
3556 call metaanddata%metadata%dbaenq(session)
3557 session%count=session%count-1
3558end if
3559end subroutine dbasession_ingest_metaanddatai
3560
3561
3563subroutine dbasession_ingest_metaanddataiv(session,metaanddatav)
3564class(dbasession), intent(inout) :: session
3565type(dbametaanddatai), intent(inout),allocatable :: metaanddatav(:)
3566
3567integer :: i
3568
3569call session%ingest_metaanddatai()
3570if (c_e(session%count)) then
3571 allocate(metaanddatav(session%count))
3572 i=0
3573 do while (session%count >0)
3574 i=i+1
3575 call session%ingest_metaanddatai(metaanddatav(i))
3576 end do
3577else
3578 allocate(metaanddatav(0))
3579end if
3580
3581end subroutine dbasession_ingest_metaanddataiv
3582
3583
3585subroutine dbasession_ingest_metaanddatab(session,metaanddata)
3586class(dbasession), intent(inout) :: session
3587type(dbametaanddatab), intent(inout),optional :: metaanddata
3588
3589integer :: ier
3590character(len=9) :: btable
3591integer(kind=int_b) :: value
3592
3593if (.not. present(metaanddata)) then
3594 ier = idba_voglioquesto(session%sehandle, session%count)
3595else
3596 ier = idba_dammelo(session%sehandle, btable)
3597 ier = idba_enq(session%sehandle, btable,value)
3598 metaanddata%dbadatab=dbadatab(btable,value)
3599 call metaanddata%metadata%dbaenq(session)
3600 session%count=session%count-1
3601end if
3602end subroutine dbasession_ingest_metaanddatab
3603
3604
3606subroutine dbasession_ingest_metaanddatabv(session,metaanddatav)
3607class(dbasession), intent(inout) :: session
3608type(dbametaanddatab), intent(inout),allocatable :: metaanddatav(:)
3609
3610integer :: i
3611
3612call session%ingest_metaanddatab()
3613if (c_e(session%count)) then
3614 allocate(metaanddatav(session%count))
3615 i=0
3616 do while (session%count >0)
3617 i=i+1
3618 call session%ingest_metaanddatab(metaanddatav(i))
3619 end do
3620else
3621 allocate(metaanddatav(0))
3622end if
3623
3624end subroutine dbasession_ingest_metaanddatabv
3625
3626
3628subroutine dbasession_ingest_metaanddatad(session,metaanddata)
3629class(dbasession), intent(inout) :: session
3630type(dbametaanddatad), intent(inout),optional :: metaanddata
3631
3632integer :: ier
3633character(len=9) :: btable
3634doubleprecision :: value
3635
3636if (.not. present(metaanddata)) then
3637 ier = idba_voglioquesto(session%sehandle, session%count)
3638else
3639 ier = idba_dammelo(session%sehandle, btable)
3640 ier = idba_enq(session%sehandle, btable,value)
3641 metaanddata%dbadatad=dbadatad(btable,value)
3642 call metaanddata%metadata%dbaenq(session)
3643 session%count=session%count-1
3644end if
3645end subroutine dbasession_ingest_metaanddatad
3646
3647
3649subroutine dbasession_ingest_metaanddatadv(session,metaanddatav)
3650class(dbasession), intent(inout) :: session
3651type(dbametaanddatad), intent(inout),allocatable :: metaanddatav(:)
3652
3653integer :: i
3654
3655call session%ingest_metaanddatad()
3656if (c_e(session%count)) then
3657 allocate(metaanddatav(session%count))
3658 i=0
3659 do while (session%count >0)
3660 i=i+1
3661 call session%ingest_metaanddatad(metaanddatav(i))
3662 end do
3663else
3664 allocate(metaanddatav(0))
3665end if
3666end subroutine dbasession_ingest_metaanddatadv
3667
3668
3670subroutine dbasession_ingest_metaanddatar(session,metaanddata)
3671class(dbasession), intent(inout) :: session
3672type(dbametaanddatar), intent(inout),optional :: metaanddata
3673
3674integer :: ier
3675character(len=9) :: btable
3676real :: value
3677
3678if (.not. present(metaanddata)) then
3679 ier = idba_voglioquesto(session%sehandle, session%count)
3680else
3681 ier = idba_dammelo(session%sehandle, btable)
3682 ier = idba_enq(session%sehandle, btable,value)
3683 metaanddata%dbadatar=dbadatar(btable,value)
3684 call metaanddata%metadata%dbaenq(session)
3685 session%count=session%count-1
3686end if
3687end subroutine dbasession_ingest_metaanddatar
3688
3689
3691subroutine dbasession_ingest_metaanddatarv(session,metaanddatav)
3692class(dbasession), intent(inout) :: session
3693type(dbametaanddatar), intent(inout),allocatable :: metaanddatav(:)
3694
3695integer :: i
3696
3697call session%ingest_metaanddatar()
3698if (c_e(session%count)) then
3699 allocate(metaanddatav(session%count))
3700 i=0
3701 do while (session%count >0)
3702 i=i+1
3703 call session%ingest_metaanddatar(metaanddatav(i))
3704 end do
3705else
3706 allocate(metaanddatav(0))
3707end if
3708end subroutine dbasession_ingest_metaanddatarv
3709
3710
3711
3713subroutine dbasession_ingest_metaanddatac(session,metaanddata)
3714class(dbasession), intent(inout) :: session
3715type(dbametaanddatac), intent(inout),optional :: metaanddata
3716
3717integer :: ier
3718character(len=9) :: btable
3719character(len=255) :: value
3720
3721if (.not. present(metaanddata)) then
3722 ier = idba_voglioquesto(session%sehandle, session%count)
3723else
3724 ier = idba_dammelo(session%sehandle, btable)
3725 ier = idba_enq(session%sehandle, btable,value)
3726 metaanddata%dbadatac=dbadatac(btable,value)
3727 call metaanddata%metadata%dbaenq(session)
3728 session%count=session%count-1
3729end if
3730end subroutine dbasession_ingest_metaanddatac
3731
3732
3734subroutine dbasession_ingest_metaanddatacv(session,metaanddatav)
3735class(dbasession), intent(inout) :: session
3736type(dbametaanddatac), intent(inout),allocatable :: metaanddatav(:)
3737
3738integer :: i
3739
3740call session%ingest_metaanddatac()
3741if (c_e(session%count)) then
3742 allocate(metaanddatav(session%count))
3743 i=0
3744 do while (session%count >0)
3745 i=i+1
3746 call session%ingest_metaanddatac(metaanddatav(i))
3747 end do
3748else
3749 allocate(metaanddatav(session%count))
3750end if
3751end subroutine dbasession_ingest_metaanddatacv
3752
3755type(dbaconnection) function dbaconnection_init(dsn, user, password,categoryappend,idbhandle)
3756character (len=*), intent(in), optional :: dsn
3757character (len=*), intent(in), optional :: user
3758character (len=*), intent(in), optional :: password
3759character(len=*),INTENT(in),OPTIONAL :: categoryappend
3760integer,INTENT(in),OPTIONAL :: idbhandle
3761
3762integer :: ier
3763character(len=512) :: a_name,quidsn
3764
3765if (present(categoryappend))then
3766 call l4f_launcher(a_name,a_name_append=trim(subcategory)//"."//trim(categoryappend))
3767else
3768 call l4f_launcher(a_name,a_name_append=trim(subcategory))
3769endif
3770dbaconnection_init%category=l4f_category_get(a_name)
3771
3772! impostiamo la gestione dell'errore
3773ier=idba_error_set_callback(0,c_funloc(dballe_error_handler), &
3774 dbaconnection_init%category,dbaconnection_init%handle_err)
3775if (.not. c_e(optio_i(idbhandle))) then
3776
3777 quidsn = "test"
3778 IF (PRESENT(dsn)) THEN
3779 IF (c_e(dsn)) quidsn = dsn
3780 ENDIF
3781
3782 ier=idba_presentati(dbaconnection_init%dbhandle,quidsn)
3783else
3784 dbaconnection_init%dbhandle=optio_i(idbhandle)
3785end if
3786
3787end function dbaconnection_init
3788
3790subroutine dbaconnection_delete(handle)
3791#ifdef F2003_FULL_FEATURES
3792type (dbaconnection), intent(inout) :: handle
3793#else
3794class(dbaconnection), intent(inout) :: handle
3795#endif
3796
3797integer :: ier
3798
3799if (c_e(handle%dbhandle)) then
3800 ier = idba_arrivederci(handle%dbhandle)
3801 ier = idba_error_remove_callback(handle%handle_err)
3802end if
3803
3804end subroutine dbaconnection_delete
3805
3808recursive type(dbasession) function dbasession_init(connection,anaflag, dataflag, attrflag,&
3809 filename,mode,format,template,write,wipe,repinfo,simplified,memdb,loadfile,categoryappend)
3810type(dbaconnection),intent(in),optional :: connection
3811character (len=*), intent(in), optional :: anaflag
3812character (len=*), intent(in), optional :: dataflag
3813character (len=*), intent(in), optional :: attrflag
3814character (len=*), intent(in), optional :: filename
3815character (len=*), intent(in), optional :: mode
3816character (len=*), intent(in), optional :: template
3817logical,INTENT(in),OPTIONAL :: write
3818logical,INTENT(in),OPTIONAL :: wipe
3819character(len=*), INTENT(in),OPTIONAL :: repinfo
3820character(len=*),intent(in),optional :: format
3821logical,intent(in),optional :: simplified
3822logical,intent(in),optional :: memdb
3823logical,intent(in),optional :: loadfile
3824character(len=*),INTENT(in),OPTIONAL :: categoryappend
3825
3826integer :: ier
3827character (len=5) :: lanaflag,ldataflag,lattrflag
3828character (len=1) :: lmode
3829logical :: lwrite,lwipe
3830character(len=255) :: lrepinfo
3831character(len=40) :: lformat
3832logical :: exist,lsimplified,read_next,lfile,lmemdb,lloadfile
3833character(len=512) :: a_name
3834character(len=40) :: ltemplate
3835
3836! those are assigned by the default constructor?
3837!!$dbasession_init%sehandle=imiss
3838!!$dbasession_init%file=.false.
3839!!$dbasession_init%template=cmiss
3840!!$dbasession_init%count=imiss
3841
3842if (present(categoryappend))then
3843 call l4f_launcher(a_name,a_name_append=trim(subcategory)//"."//trim(categoryappend))
3844else
3845 call l4f_launcher(a_name,a_name_append=trim(subcategory))
3846endif
3847dbasession_init%category=l4f_category_get(a_name)
3848
3849
3850lwrite=.false.
3851if (present(write))then
3852 lwrite=write
3853endif
3854
3855lwipe=.false.
3856lrepinfo=""
3857if (present(wipe))then
3858 lwipe=wipe
3859 if (present(repinfo))then
3860 lrepinfo=repinfo
3861 endif
3862endif
3863
3864lmemdb=.false.
3865lloadfile=.false.
3866lfile=.false.
3867
3868if (present(template))then
3869 ltemplate=template
3870else
3871 ltemplate=cmiss
3872endif
3873
3874lsimplified=.true.
3875if (present(simplified))then
3876 lsimplified=simplified
3877end if
3878
3879lformat="BUFR"
3880if (present(format))then
3881 lformat=format
3882end if
3883
3884lmode="r"
3885
3886if (present(filename)) then
3887
3888 lfile=.true.
3889
3890 IF (filename == '') THEN
3891! if stdio do not check existence, stdin always exist, stdout never exist
3892 exist = .NOT.lwrite
3893 ELSE
3894 INQUIRE(file=filename,exist=exist)
3895 ENDIF
3896
3897 if (lwrite)then
3898 if (lwipe.or..not.exist) then
3899 lmode="w"
3900 else
3901 lmode="a"
3902 call l4f_category_log(dbasession_init%category,l4f_info,"file exists; appending data to file")
3903 end if
3904 else
3905 if (.not.exist) then
3906 call l4f_category_log(dbasession_init%category,l4f_error,"file does not exist; cannot open file for read")
3907 CALL raise_fatal_error()
3908 end if
3909 end if
3910
3911 if (present(mode)) lmode = mode
3912
3913 if (.not.present(memdb))then
3914 dbasession_init%memdb=.true. ! default with filename
3915 end if
3916
3917 if (.not.present(loadfile))then
3918 dbasession_init%loadfile=.true. ! default with filename
3919 end if
3920
3921end if
3923if (present(memdb))then
3924 lmemdb=memdb
3925end if
3926
3927if (present(loadfile))then
3928 lloadfile=loadfile
3929end if
3930
3931
3932call optio(anaflag,lanaflag)
3933if (.not. c_e(lanaflag))then
3934 if (lwrite) then
3935 lanaflag = "write"
3936 else
3937 lanaflag = "read"
3938 end if
3939end if
3940
3941call optio(dataflag,ldataflag)
3942if (.not. c_e(ldataflag)) then
3943 if (lwrite) then
3944 ldataflag = "write"
3945 else
3946 ldataflag = "read"
3947 end if
3948end if
3949
3950call optio(attrflag,lattrflag)
3951if (.not. c_e(lattrflag))then
3952 if (lwrite) then
3953 lattrflag = "write"
3954 else
3955 lattrflag = "read"
3956 end if
3957end if
3958
3959
3960!!$print*,"---------------- call session_init --------------------------------"
3961!!$print *,"session_init,lformat,ltemplate,lmemdb,lfile,lloadfile,lanaflag,ldataflag,lattrflag"
3962!!$print *,"session_init",lformat,ltemplate,lmemdb,lfile,lloadfile,lanaflag,ldataflag,lattrflag
3963!!$print*,"------------------------------------------------"
3964
3965if (lfile) then
3966
3967 if (present(anaflag).or.present(dataflag).or.present( attrflag)) then
3968 call l4f_category_log(dbasession_init%category,l4f_error,"option anaflag, dataflag, attrflag defined with filename access")
3969 CALL raise_error()
3970 end if
3971
3972else
3973
3974 if(.not. present(connection)) then
3975 call l4f_category_log(dbasession_init%category,l4f_error,"connection not present accessing DBA")
3976 CALL raise_error()
3977 end if
3979 if (present(mode).or.present(format).or.present(template).or.present(simplified)) then
3980 call l4f_category_log(dbasession_init%category,l4f_error,&
3981 "option mode or format or template or simplified defined without filename")
3982 CALL raise_error()
3983 end if
3984
3985end if
3986
3987
3988! check filename for recursive call
3989if (present(filename))then
3990 if (lmemdb)then
3991 if (.not. present(connection)) then
3992 ! connect to dsn type DBA
3993 dbasession_init%memconnection=dbaconnection(dsn="mem:")
3994 !call self with memconnection without filename
3995 dbasession_init=dbasession(dbasession_init%memconnection,&
3996 write=.true.,wipe=lwrite,repinfo=lrepinfo,&
3997 memdb=lmemdb,loadfile=lloadfile) ! without categoryappend
3998
3999 else
4000 dbasession_init%memconnection=connection
4001 !call self with memconnection without filename
4002 dbasession_init=dbasession(dbasession_init%memconnection,&
4003 write=.true.,wipe=lwrite,repinfo=lrepinfo,&
4004 memdb=lmemdb,loadfile=lloadfile) ! without categoryappend
4005
4006 end if
4007
4008 if (lmode == "r") then
4009 call dbasession_init%messages_open_input(filename=filename,mode=lmode,&
4010 format=lformat,simplified=lsimplified)
4011
4012 if (lloadfile)then
4013 read_next = dbasession_init%messages_read_next()
4014 do while (read_next)
4015 read_next = dbasession_init%messages_read_next()
4016 end do
4017 end if
4018 else
4019
4020 call dbasession_init%messages_open_output(filename=filename,&
4021 mode=lmode,format=lformat)
4022
4023 end if
4024
4025 else
4026
4027 ier = idba_messaggi(dbasession_init%sehandle,filename, lmode, lformat)
4028
4029 end if
4030
4031else
4032
4033 ier = idba_preparati(connection%dbhandle,dbasession_init%sehandle, lanaflag, ldataflag, lattrflag)
4034 if (lwipe)ier=idba_scopa(dbasession_init%sehandle,lrepinfo)
4035
4036end if
4037
4038dbasession_init%file=lfile
4039if (dbasession_init%file) dbasession_init%filename=filename
4040dbasession_init%mode=lmode
4041dbasession_init%format=lformat
4042dbasession_init%simplified=lsimplified
4043dbasession_init%memdb=lmemdb
4044dbasession_init%loadfile=lloadfile
4045dbasession_init%template=ltemplate
4046
4047!!$print*,"--------------- at end ---------------------------------"
4048!!$print *,'file',dbasession_init%file
4049!!$print *,'filename',trim(dbasession_init%filename)
4050!!$print *,'mode',dbasession_init%mode
4051!!$print *,'format',dbasession_init%format
4052!!$print *,'simplified',dbasession_init%simplified
4053!!$print *,'memdb',dbasession_init%memdb
4054!!$print *,'loadfile',dbasession_init%loadfile
4055!!$print *,'template',dbasession_init%template
4056!!$print*,"------------------------------------------------"
4057
4058end function dbasession_init
4059
4060
4062subroutine dbasession_unsetall(session)
4063class(dbasession), intent(in) :: session
4064integer :: ier
4065
4066if (c_e(session%sehandle)) then
4067 ier = idba_unsetall(session%sehandle)
4068end if
4069
4070end subroutine dbasession_unsetall
4071
4072
4074subroutine dbasession_remove_all(session)
4075class(dbasession), intent(in) :: session
4076integer :: ier
4077
4078if (c_e(session%sehandle)) then
4079 ier = idba_remove_all(session%sehandle)
4080end if
4081
4082end subroutine dbasession_remove_all
4083
4084
4086subroutine dbasession_prendilo(session)
4087class(dbasession), intent(in) :: session
4088integer :: ier
4089
4090if (c_e(session%sehandle)) then
4091 ier = idba_prendilo(session%sehandle)
4092end if
4093
4094end subroutine dbasession_prendilo
4095
4097subroutine dbasession_var_related(session,btable)
4098class(dbasession), intent(in) :: session
4099character(len=*),INTENT(IN) :: btable
4100integer :: ier
4101
4102if (c_e(session%sehandle)) then
4103 ier = idba_set(session%sehandle,"*var_related",btable)
4104end if
4105
4106end subroutine dbasession_var_related
4107
4109subroutine dbasession_setcontextana(session)
4110class(dbasession), intent(in) :: session
4111integer :: ier
4112
4113if (c_e(session%sehandle)) then
4114 ier = idba_setcontextana(session%sehandle)
4115end if
4116
4117end subroutine dbasession_setcontextana
4118
4120subroutine dbasession_dimenticami(session)
4121class(dbasession), intent(in) :: session
4122integer :: ier
4123
4124if (c_e(session%sehandle)) then
4125 ier = idba_dimenticami(session%sehandle)
4126end if
4127
4128end subroutine dbasession_dimenticami
4129
4131subroutine dbasession_critica(session)
4132class(dbasession), intent(in) :: session
4133integer :: ier
4134
4135if (c_e(session%sehandle)) then
4136 ier = idba_critica(session%sehandle)
4137end if
4138
4139end subroutine dbasession_critica
4140
4142subroutine dbasession_scusa(session)
4143class(dbasession), intent(in) :: session
4144integer :: ier
4145
4146if (c_e(session%sehandle)) then
4147 ier = idba_scusa(session%sehandle)
4148end if
4149
4150end subroutine dbasession_scusa
4151
4153subroutine dbasession_set(session,metadata,datav,data,datetime,ana,network,level,timerange,filter)
4154class(dbasession), intent(in) :: session
4155type (dbametadata),optional :: metadata
4156class(dbadcv),optional :: datav
4157class(dbadata),optional :: data
4158type (dbadatetime),optional :: datetime
4159type (dbaana),optional :: ana
4160type (dbanetwork),optional :: network
4161type (dbalevel),optional :: level
4162type (dbatimerange),optional :: timerange
4163type (dbafilter),optional :: filter
4164
4165if (present(metadata)) then
4166 call metadata%dbaset(session)
4167endif
4168
4169if (present(datetime)) then
4170 call datetime%dbaset(session)
4171endif
4172
4173if (present(ana)) then
4174 call ana%dbaset(session)
4175endif
4176
4177if (present(network)) then
4178 call network%dbaset(session)
4179endif
4180
4181if (present(level)) then
4182 call level%dbaset(session)
4183endif
4184
4185if (present(timerange)) then
4186 call timerange%dbaset(session)
4187endif
4188
4189if (present(datav)) then
4190 call datav%dbaset(session)
4191end if
4192
4193if (present(data)) then
4194 call data%dbaset(session)
4195end if
4196
4197if (present(filter)) then
4198 call filter%dbaset(session)
4199end if
4200
4201end subroutine dbasession_set
4202
4203
4204!!! Those are for reverse order call session%extrude(object)
4205
4206!!$!> put data on DSN
4207!!$subroutine dbasession_extrude_ana(session,ana)
4208!!$class(dbasession), intent(in) :: session
4209!!$class(dbaana) :: ana !< ana
4210!!$call ana%extrude(session)
4211!!$end subroutine dbasession_extrude_ana
4212!!$
4213!!$!> put data on DSN
4214!!$subroutine dbasession_extrude_dataattr(session,dataattr)
4215!!$class(dbasession), intent(in) :: session
4216!!$class(dbadataattr) :: dataattr !< dataattr
4217!!$call dataattr%extrude(session)
4218!!$end subroutine dbasession_extrude_dataattr
4219!!$
4220!!$!> put data on DSN
4221!!$subroutine dbasession_extrude_dataattrv(session,dataattrv,noattr,filter)
4222!!$class(dbasession), intent(in) :: session
4223!!$class(dbadataattrv) :: dataattrv !< array datatattr
4224!!$logical, intent(in),optional :: noattr !< set to .true. to get data only (no attribute)
4225!!$type(dbafilter),intent(in),optional :: filter !< use this to filter wanted data
4226!!$
4227!!$call dataattrv%extrude(session,noattr,filter)
4228!!$end subroutine dbasession_extrude_dataattrv
4229!!$
4230!!$!> put data on DSN
4231!!$subroutine dbasession_extrude_metaanddata(session,metaanddata,noattr,filter)
4232!!$class(dbasession), intent(in) :: session
4233!!$class(dbametaanddata) :: metaanddata !< metaanddata
4234!!$logical, intent(in),optional :: noattr !< set to .true. to get data only (no attribute)
4235!!$type(dbafilter),intent(in),optional :: filter !< use this to filter wanted data
4236!!$
4237!!$call metaanddata%extrude(session,noattr,filter)
4238!!$end subroutine dbasession_extrude_metaanddata
4239!!$
4240!!$!> put data on DSN
4241!!$subroutine dbasession_extrude_metaanddatai(session,metaanddatai)
4242!!$class(dbasession), intent(in) :: session
4243!!$class(dbametaanddatai) :: metaanddatai !< metaanddatai
4244!!$call metaanddatai%extrude(session)
4245!!$end subroutine dbasession_extrude_metaanddatai
4246!!$
4247!!$!> put data on DSN
4248!!$subroutine dbasession_extrude_metaanddatab(session,metaanddatab)
4249!!$class(dbasession), intent(in) :: session
4250!!$class(dbametaanddatab) :: metaanddatab !< metaanddatab
4251!!$call metaanddatab%extrude(session)
4252!!$end subroutine dbasession_extrude_metaanddatab
4253!!$
4254!!$!> put data on DSN
4255!!$subroutine dbasession_extrude_metaanddatad(session,metaanddatad)
4256!!$class(dbasession), intent(in) :: session
4257!!$class(dbametaanddatad) :: metaanddatad !< metaanddatad
4258!!$call metaanddatad%extrude(session)
4259!!$end subroutine dbasession_extrude_metaanddatad
4260!!$
4261!!$!> put data on DSN
4262!!$subroutine dbasession_extrude_metaanddatac(session,metaanddatac)
4263!!$class(dbasession), intent(in) :: session
4264!!$class(dbametaanddatac) :: metaanddatac !< metaanddatac
4265!!$call metaanddatac%extrude(session)
4266!!$end subroutine dbasession_extrude_metaanddatac
4267!!$
4268!!$!> put data on DSN
4269!!$subroutine dbasession_extrude_metaanddatar(session,metaanddatar)
4270!!$class(dbasession), intent(in) :: session
4271!!$class(dbametaanddatar) :: metaanddatar !< metaanddatar
4272!!$call metaanddatar%extrude(session)
4273!!$end subroutine dbasession_extrude_metaanddatar
4275!!$!> put data on DSN
4276!!$subroutine dbasession_extrude_metaanddatav(session, metaanddatav,noattr,filter)
4277!!$class(dbasession), intent(in) :: session
4278!!$class(dbametaanddatav) :: metaanddatav !< array metaanddata
4279!!$logical, intent(in),optional :: noattr !< set to .true. to get data only (no attribute)
4280!!$type(dbafilter),intent(in),optional :: filter !< use this to filter wanted data
4281!!$
4282!!$call metaanddatav%extrude(session,noattr,filter)
4283!!$end subroutine dbasession_extrude_metaanddatav
4284!!$
4285!!$subroutine dbasession_extrude_metaanddatal(session, metaanddatal,noattr,filter)
4286!!$class(dbasession), intent(in) :: session
4287!!$class (dbametaanddatalist) :: metaanddatal !< metaanddata list
4288!!$logical, intent(in),optional :: noattr !< set to .true. to get data only (no attribute)
4289!!$type(dbafilter),intent(in),optional :: filter !< use this to filter wanted data
4290!!$
4291!!$call metaanddatal%extrude(session,noattr,filter)
4292!!$end subroutine dbasession_extrude_metaanddatal
4293!!$
4294!!$!> put data on DSN
4295!!$subroutine dbasession_extrude(session,ana,dataattr,dataattrv,metaanddata,&
4296!!$ metaanddatai,metaanddatab,metaanddatad,metaanddatac,metaanddatar,&
4297!!$ metaanddatav ,metaanddatal,noattr,filter)
4298!!$class(dbasession), intent(in) :: session
4299!!$class(dbaana),optional :: ana !< ana
4300!!$class(dbadataattr),optional :: dataattr !< dataattr
4301!!$class(dbadataattrv),optional :: dataattrv !< array datatattr
4302!!$class(dbametaanddata),optional :: metaanddata !< metaanddata
4303!!$class(dbametaanddatai),optional :: metaanddatai !< metaanddatai
4304!!$class(dbametaanddatab),optional :: metaanddatab !< metaanddatab
4305!!$class(dbametaanddatad),optional :: metaanddatad !< metaanddatad
4306!!$class(dbametaanddatac),optional :: metaanddatac !< metaanddatac
4307!!$class(dbametaanddatar),optional :: metaanddatar !< metaanddatar
4308!!$class(dbametaanddatav),optional :: metaanddatav !< array metaanddata
4309!!$class(dbametaanddatalist),optional :: metaanddatal !< metaanddata list
4310!!$logical, intent(in),optional :: noattr !< set to .true. to get data only (no attribute)
4311!!$type(dbafilter),intent(in),optional :: filter !< use this to filter wanted data
4312!!$
4313!!$if (present(ana)) then
4314!!$ call ana%extrude(session)
4315!!$end if
4316!!$
4317!!$if (present(dataattr)) then
4318!!$ call dataattr%extrude(session)
4319!!$end if
4320!!$
4321!!$if (present(dataattrv)) then
4322!!$ call dataattrv%extrude(session,noattr,filter)
4323!!$end if
4324!!$
4325!!$if (present(metaanddata)) then
4326!!$ call metaanddata%extrude(session)
4327!!$end if
4328!!$
4329!!$if (present(metaanddatai)) then
4330!!$ call metaanddatai%extrude(session)
4331!!$end if
4332!!$
4333!!$if (present(metaanddatab)) then
4334!!$ call metaanddatab%extrude(session)
4335!!$end if
4336!!$
4337!!$if (present(metaanddatad)) then
4338!!$ call metaanddatad%extrude(session)
4339!!$end if
4340!!$
4341!!$if (present(metaanddatac)) then
4342!!$ call metaanddatac%extrude(session)
4343!!$end if
4344!!$
4345!!$if (present(metaanddatar)) then
4346!!$ call metaanddatar%extrude(session)
4347!!$end if
4348!!$
4349!!$if (present(metaanddatav)) then
4350!!$ call metaanddatav%extrude(session,noattr,filter)
4351!!$end if
4352!!$
4353!!$if (present(metaanddatal)) then
4354!!$ call metaanddatal%extrude(session,noattr,filter)
4355!!$end if
4356!!$
4357!!$end subroutine dbasession_extrude
4358
4359# ifndef F2003_FULL_FEATURES
4360
4361subroutine dbasession_delete(session)
4362class(dbasession), intent(inout) :: session
4363integer :: ier
4364type(dbasession) :: defsession
4365
4366if (c_e(session%sehandle)) then
4367 ier = idba_fatto(session%sehandle)
4368end if
4369
4370call session%memconnection%delete()
4371
4372select type (session)
4373type is (dbasession)
4374 session = defsession
4375end select
4376
4377!!$session%sehandle=imiss
4378!!$session%file=.false.
4379!!$session%template=cmiss
4380!!$session%filename=cmiss
4381!!$session%mode=cmiss
4382!!$session%format=cmiss
4383!!$session%simplified=.true.
4384!!$session%memdb=.false.
4385!!$session%category=imiss
4386!!$session%count=imiss
4387
4388end subroutine dbasession_delete
4389
4390#else
4391
4393subroutine dbasession_delete(session)
4394type (dbasession), intent(inout) :: session
4395integer :: ier
4396
4397if (c_e(session%sehandle)) then
4398 ier = idba_fatto(session%sehandle)
4399end if
4400
4401!!$session%sehandle=imiss
4402!!$session%file=.false.
4403!!$session%template=cmiss
4404!!$session%filename=cmiss
4405!!$session%mode=cmiss
4406!!$session%format=cmiss
4407!!$session%simplified=.true.
4408!!$session%memdb=.false.
4409!!$session%category=imiss
4410!!$session%count=imiss
4411
4412end subroutine dbasession_delete
4413
4414#endif
4415
4416
4417
4419subroutine dbasession_filerewind(session)
4420class(dbasession), intent(inout) :: session
4421integer :: ier
4422
4423if (c_e(session%sehandle).and. session%file) then
4424 ier = idba_fatto(session%sehandle)
4425 ier = idba_messaggi(session%sehandle,session%filename,session%mode,session%format)
4426
4427!!$! example: here we call constructor after a cast to reassign self (can you pass self attributes to constructor?)
4428!!$ select type(session)
4429!!$ type is (dbasession)
4430!!$ session=dbasession(filename=session%filename,mode=session%mode,format=session%format)
4431!!$ end select
4432
4433end if
4434
4435end subroutine dbasession_filerewind
4436
4437
4438FUNCTION dballe_error_handler(category)
4439INTEGER :: category, code, l4f_level
4440INTEGER :: dballe_error_handler
4441
4442CHARACTER(len=1000) :: message, buf
4443
4444code = idba_error_code()
4445
4446! check if "Value outside acceptable domain"
4447if (code == 13 ) then
4448 l4f_level=l4f_warn
4449else
4450 l4f_level=l4f_error
4451end if
4452
4453call idba_error_message(message)
4454call l4f_category_log(category,l4f_level,trim(message))
4455
4456call idba_error_context(buf)
4457
4458call l4f_category_log(category,l4f_level,trim(buf))
4459
4460call idba_error_details(buf)
4461call l4f_category_log(category,l4f_info,trim(buf))
4462
4463
4464! if "Value outside acceptable domain" do not raise error
4465if (l4f_level == l4f_error ) CALL raise_fatal_error("dballe: "//message)
4466
4467dballe_error_handler = 0
4468return
4469
4470END FUNCTION dballe_error_handler
4471
4472end MODULE dballe_class
4473
Distruttori per le 2 classi.
print a summary of object contents
set parameters in dballe API
Classi per la gestione delle coordinate temporali.
class for import and export data from e to DB-All.e.
Gestione degli errori.
Classes for handling georeferenced sparse points in geographical corodinates.
abstract class to use lists in fortran 2003.
classe per la gestione del logging
Definitions of constants and functions for working with missing values.
Module for quickly interpreting the OPTIONAL parameters passed to a subprogram.
Classe per la gestione dell'anagrafica di stazioni meteo e affini.
Classe per la gestione di un volume completo di dati osservati.
Classe per la gestione dei livelli verticali in osservazioni meteo e affini.
Classe per la gestione delle reti di stazioni per osservazioni meteo e affini.
Classe per la gestione degli intervalli temporali di osservazioni meteo e affini.
Class for expressing an absolute time value.
double linked list of ana
manage connection handle to a DSN
fortran 2003 interface to geo_coord
base (abstract) type for data
extend one data container with a vector of data container (one data plus attributes)
vector of dbadataattr (more data plus attributes)
byte version for dbadata
character version for dbadata
doubleprecision version for dbadata
integer version for dbadata
real version for dbadata
container for dbadata (used for promiscuous vector of data)
vector of container of dbadata
filter to apply before ingest data
one metadata with more data plus attributes
metadata and byte data
metadata and byte data double linked list
metadata and character data
metadata and character data double linked list
metadata and doubleprecision data
metadata and diubleprecision data double linked list
metadata and integer data
metadata and integer data double linked list
double linked list of dbametaanddata
metadata and real data
metadata and real data double linked list
one metadata plus vector of container of dbadata
summ of all metadata pieces
manage session handle
Derived type defining an isolated georeferenced point on Earth in polar geographical coordinates.
Abstract implementation of doubly-linked list.
Definisce l'anagrafica di una stazione.
Definisce il livello verticale di un'osservazione.
Definisce la rete a cui appartiene una stazione.
Definisce l'intervallo temporale di un'osservazione meteo.

Generated with Doxygen.