libsim Versione 7.1.11
|
◆ dbasession_delete()
clear a dballe session Definizione alla linea 4555 del file dballe_class.F03. 4556! Copyright (C) 2013 ARPA-SIM <urpsim@smr.arpa.emr.it>
4557! authors:
4558! Paolo Patruno <ppatruno@arpa.emr.it>
4559! Davide Cesari <dcesari@arpa.emr.it>
4560
4561! This program is free software; you can redistribute it and/or
4562! modify it under the terms of the GNU General Public License as
4563! published by the Free Software Foundation; either version 2 of
4564! the License, or (at your option) any later version.
4565
4566! This program is distributed in the hope that it will be useful,
4567! but WITHOUT ANY WARRANTY; without even the implied warranty of
4568! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
4569! GNU General Public License for more details.
4570
4571! You should have received a copy of the GNU General Public License
4572! along with this program. If not, see <http://www.gnu.org/licenses/>.
4573
4574#include "config.h"
4575
4599
4612use dballef
4613IMPLICIT NONE
4614
4615private
4616
4617character (len=255),parameter:: subcategory="dballe_class"
4618
4621 integer :: dbhandle=imiss
4622 integer :: handle_err=imiss
4623 integer :: category=0
4624 contains
4625# ifdef F2003_FULL_FEATURES
4626 final :: dbaconnection_delete
4627# else
4628 procedure :: delete => dbaconnection_delete
4629# endif
4631
4634 procedure dbaconnection_init
4635end interface
4636
4639 integer :: sehandle=imiss
4640 logical :: file=.false.
4641 character(len=40) :: template='generic'
4642 character(len=255) :: filename=cmiss
4643 character(len=40) :: mode=cmiss
4644 character(len=40) :: format=cmiss
4645 logical :: simplified=.true.
4646 logical :: memdb=.false.
4647 logical :: loadfile=.false.
4648 type(dbaconnection) :: memconnection
4649 integer :: category=0
4650 integer :: count=imiss
4651 contains
4652# ifdef F2003_FULL_FEATURES
4653 final :: dbasession_delete
4654# else
4655 procedure :: delete => dbasession_delete
4656# endif
4657 procedure :: unsetall => dbasession_unsetall
4658 procedure :: remove_all => dbasession_remove_all
4659 procedure :: set => dbasession_set
4660 procedure :: setcontextana => dbasession_setcontextana
4661 procedure :: dimenticami => dbasession_dimenticami
4674 procedure :: prendilo => dbasession_prendilo
4675 procedure :: var_related => dbasession_var_related
4676 procedure :: critica => dbasession_critica
4677 procedure :: scusa => dbasession_scusa
4678 procedure :: messages_open_input => dbasession_messages_open_input
4679 procedure :: messages_open_output => dbasession_messages_open_output
4680 procedure :: messages_read_next => dbasession_messages_read_next
4681 procedure :: messages_write_next => dbasession_messages_write_next
4682 procedure :: close_message => dbasession_close_message
4683 procedure :: unsetb => dbasession_unsetb
4684 procedure :: filerewind => dbasession_filerewind
4685 procedure :: ingest_ana => dbasession_ingest_ana
4686 procedure :: ingest_anav => dbasession_ingest_anav
4687 procedure :: ingest_anal => dbasession_ingest_anal
4688 procedure :: ingest_metaanddata => dbasession_ingest_metaanddata
4689 procedure :: ingest_metaanddatal => dbasession_ingest_metaanddatal
4690 procedure :: ingest_metaanddatav => dbasession_ingest_metaanddatav
4691 procedure :: ingest_metaanddatai => dbasession_ingest_metaanddatai
4692 procedure :: ingest_metaanddataiv => dbasession_ingest_metaanddataiv
4693 procedure :: ingest_metaanddatail => dbasession_ingest_metaanddatail
4694 procedure :: ingest_metaanddatab => dbasession_ingest_metaanddatab
4695 procedure :: ingest_metaanddatabv => dbasession_ingest_metaanddatabv
4696 procedure :: ingest_metaanddatabl => dbasession_ingest_metaanddatabl
4697 procedure :: ingest_metaanddatad => dbasession_ingest_metaanddatad
4698 procedure :: ingest_metaanddatadv => dbasession_ingest_metaanddatadv
4699 procedure :: ingest_metaanddatadl => dbasession_ingest_metaanddatadl
4700 procedure :: ingest_metaanddatar => dbasession_ingest_metaanddatar
4701 procedure :: ingest_metaanddatarv => dbasession_ingest_metaanddatarv
4702 procedure :: ingest_metaanddatarl => dbasession_ingest_metaanddatarl
4703 procedure :: ingest_metaanddatac => dbasession_ingest_metaanddatac
4704 procedure :: ingest_metaanddatacv => dbasession_ingest_metaanddatacv
4705 procedure :: ingest_metaanddatacl => dbasession_ingest_metaanddatacl
4706 procedure :: dissolve_metadata => dbasession_dissolve_metadata
4707 procedure :: dissolveattr => dbasession_dissolveattr_metadata
4708 generic :: dissolve => dissolve_metadata ,dimenticami
4709 generic :: ingesta => ingest_ana, ingest_anav,ingest_anal
4710 generic :: ingest => ingest_metaanddata,ingest_metaanddatav,ingest_metaanddatal,&
4711 !ingest_metaanddatai,ingest_metaanddatab,ingest_metaanddatad,ingest_metaanddatar,ingest_metaanddatac,& !ambiguos
4712 ingest_metaanddataiv,ingest_metaanddatabv,ingest_metaanddatadv,ingest_metaanddatarv,ingest_metaanddatacv,&
4713 ingest_metaanddatail,ingest_metaanddatarl,ingest_metaanddatadl,ingest_metaanddatabl,ingest_metaanddatacl
4718
4721 procedure dbasession_init
4722end interface
4723
4726 contains
4727
4728# ifdef F2003_FULL_FEATURES
4729! final :: dbalevel_delete
4730# else
4731! procedure :: delete => dbalevel_delete !< todo
4732# endif
4733 procedure :: display => dbalevel_display
4734 procedure :: dbaset => dbalevel_set
4735 procedure :: dbaenq => dbalevel_enq
4736 procedure,nopass :: dbacontextana => dbalevel_contextana
4739
4742 procedure dbalevel_init
4743end interface
4744
4747 contains
4748# ifdef F2003_FULL_FEATURES
4749! final :: dbatimerange_delete
4750# else
4751! procedure :: delete => dbatimerange_delete
4752# endif
4753 procedure :: display => dbatimerange_display
4754 procedure :: dbaset => dbatimerange_set
4755 procedure :: dbaenq => dbatimerange_enq
4756 procedure,nopass :: dbacontextana => dbatimerange_contextana
4759
4762 procedure dbatimerange_init
4763end interface
4764
4767
4768!!$ REAL(kind=fp_geo) :: lon !< longitudine
4769!!$ REAL(kind=fp_geo) :: lat !< latitudine
4770!!$ INTEGER(kind=int_l) :: ilon !< integer longitude (nint(lon*1.d5)
4771!!$ INTEGER(kind=int_l) :: ilat !< integer latitude (nint(lat*1.d5)
4772
4773 contains
4774# ifdef F2003_FULL_FEATURES
4775! final :: dbacoord_delete
4776# else
4777! procedure :: delete => dbacoord_delete
4778# endif
4779 procedure :: display => dbacoord_display
4780
4782
4785 procedure dbacoord_init
4786end interface
4787
4790
4791 contains
4792# ifdef F2003_FULL_FEATURES
4793! final :: dbaana_delete
4794# else
4795! procedure :: delete => dbaana_delete
4796# endif
4797 procedure :: display => dbaana_display
4798 procedure :: dbaset => dbaana_set
4799 procedure :: dbaenq => dbaana_enq
4800 procedure :: extrude => dbaana_extrude
4802
4805 procedure dbaana_init
4806end interface
4807
4810 contains
4811 procedure :: current => currentdbaana
4812 procedure :: display => displaydbaana
4814
4817
4818 !Every type of report has an associated priority that controls which
4819 !data are first returned when there is more than one in the same
4820 !physical space. It can be changed by editing
4821 !/etc/dballe/repinfo.csv
4822 integer :: priority
4823
4824 contains
4825# ifdef F2003_FULL_FEATURES
4826! final :: dbanetwork_delete
4827# else
4828! procedure :: delete => dbanetwork_delete
4829# endif
4830 procedure :: display => dbanetwork_display
4831 procedure :: dbaset => dbanetwork_set
4832 procedure :: dbaenq => dbanetwork_enq
4833
4835
4838 procedure dbanetwork_init
4839end interface
4840
4841
4844
4845 contains
4846# ifdef F2003_FULL_FEATURES
4847! final :: dbanetwork_delete
4848# else
4849! procedure :: delete => dbanetwork_delete
4850# endif
4851 procedure :: display => dbadatetime_display
4852 procedure :: dbaset => dbadatetime_set
4853 procedure :: dbaenq => dbadatetime_enq
4854 procedure,nopass :: dbacontextana => dbadatetime_contextana
4856
4859 procedure dbadatetime_init
4860end interface
4861
4862
4865 character(len=9) :: btable
4866contains
4867 procedure(dbadata_set),deferred :: dbaset
4868 procedure :: dbadata_geti
4869 procedure :: dbadata_getr
4870 procedure :: dbadata_getd
4871 procedure :: dbadata_getb
4872 procedure :: dbadata_getc
4873 generic :: get => dbadata_geti,dbadata_getr,dbadata_getd,dbadata_getb,dbadata_getc
4874 procedure :: dbadata_c_e_i
4875 procedure :: dbadata_c_e_r
4876 procedure :: dbadata_c_e_d
4877 procedure :: dbadata_c_e_b
4878 procedure :: dbadata_c_e_c
4879 procedure :: c_e => dbadata_c_e
4880 procedure(dbadata_display),deferred :: display
4881 procedure :: equal => dbadata_equal
4882 generic :: operator (==) => equal
4884
4886abstract interface
4888import
4889class(dbadata), intent(in) :: data
4890type(dbasession), intent(in) :: session
4892
4895import
4896class(dbadata), intent(in) :: data
4898
4899end interface
4900
4903 integer :: value
4904contains
4905 procedure :: dbadata_geti => dbadatai_geti
4906 procedure :: dbaset => dbadatai_set
4907 procedure :: display => dbadatai_display
4909
4912 procedure :: dbadatai_init
4914
4917 real :: value
4918contains
4919 procedure :: dbadata_getr => dbadatar_getr
4920 procedure :: dbaset => dbadatar_set
4921 procedure :: display => dbadatar_display
4923
4926 procedure :: dbadatar_init
4928
4929
4932 doubleprecision :: value
4933contains
4934 procedure :: dbadata_getd => dbadatad_getd
4935 procedure :: dbaset => dbadatad_set
4936 procedure :: display => dbadatad_display
4938
4941 procedure :: dbadatad_init
4943
4944
4947 integer(kind=int_b) :: value
4948contains
4949 procedure :: dbadata_getb => dbadatab_getb
4950 procedure :: dbaset => dbadatab_set
4951 procedure :: display => dbadatab_display
4953
4956 procedure :: dbadatab_init
4958
4959
4962! character(:) :: value
4963! character(255) :: value
4964character(vol7d_cdatalen) :: value
4965
4966contains
4967 procedure :: dbadata_getc => dbadatac_getc
4968 procedure :: dbaset => dbadatac_set
4969 procedure :: display => dbadatac_display
4971
4974 procedure :: dbadatac_init
4976
4979 type(dbalevel) :: level
4980 type(dbatimerange) :: timerange
4981 type(dbaana) :: ana
4982 type(dbanetwork) :: network
4983 type(dbadatetime) :: datetime
4984 contains
4985# ifdef F2003_FULL_FEATURES
4986! final :: dbametadata_delete
4987# else
4988! procedure :: delete => dbametadata_delete
4989# endif
4990 procedure :: dbaset => dbametadata_set
4991 procedure :: dbaenq => dbametadata_enq
4992 procedure :: dbacontextana => dbametadata_contextana
4993 procedure :: display => dbametadata_display
4994 procedure :: equal => dbametadata_equal
4995 generic :: operator (==) => equal
4997
5000 procedure dbametadata_init
5001end interface
5002
5005 class(dbadata),allocatable :: dat
5006 contains
5007 procedure :: display => dbadc_display
5008 procedure :: dbaset => dbadc_set
5009 procedure :: extrude => dbadc_extrude
5011
5012
5015 type(dbadc),allocatable :: dcv(:)
5016 contains
5017 procedure :: display => dbadcv_display
5018 procedure :: dbaset => dbadcv_set
5019 procedure :: extrude => dbadcv_extrude
5020 procedure :: equal => dbadcv_equal_dbadata
5021 generic :: operator (==) => equal
5023
5026 type(dbadcv) :: attrv
5027 contains
5028 procedure :: display => dbadataattr_display
5029 procedure :: extrude => dbadataattr_extrude
5031
5034 class(dbadataattr),allocatable :: dataattr(:)
5035 contains
5036 procedure :: display => dbadataattrv_display
5037 procedure :: extrude => dbadataattrv_extrude
5039
5042 type(dbametadata) :: metadata
5043 type(dbadataattrv) ::dataattrv
5044 contains
5045 procedure :: display => dbametaanddata_display
5046 procedure :: extrude => dbametaanddata_extrude
5048
5051 type(dbametadata) :: metadata
5052 type(dbadcv) ::datav
5053 contains
5054 procedure :: display => dbametaanddatav_display
5055 procedure :: extrude => dbametaanddatav_extrude
5057
5060 contains
5061 procedure :: current => currentdbametaanddata
5062 procedure :: display => displaydbametaanddata
5063 procedure :: extrude => dbametaanddatal_extrude
5065
5068 type(dbametadata) :: metadata
5069 contains
5070 procedure :: display => dbametaanddatai_display
5071 procedure :: extrude => dbametaanddatai_extrude
5073
5076 contains
5077 procedure :: current => currentdbametaanddatai
5078 procedure :: display => displaydbametaanddatai
5079 procedure :: toarray => toarray_dbametaanddatai
5081
5084 type(dbametadata) :: metadata
5085 contains
5086 procedure :: display => dbametaanddatab_display
5087 procedure :: extrude => dbametaanddatab_extrude
5089
5092 contains
5093 procedure :: current => currentdbametaanddatab
5094 procedure :: display => displaydbametaanddatab
5095 procedure :: toarray => toarray_dbametaanddatab
5097
5100 type(dbametadata) :: metadata
5101 contains
5102 procedure :: display => dbametaanddatad_display
5103 procedure :: extrude => dbametaanddatad_extrude
5105
5108 contains
5109 procedure :: current => currentdbametaanddatad
5110 procedure :: display => displaydbametaanddatad
5111 procedure :: toarray => toarray_dbametaanddatad
5113
5116 type(dbametadata) :: metadata
5117 contains
5118 procedure :: display => dbametaanddatar_display
5119 procedure :: extrude => dbametaanddatar_extrude
5121
5124 contains
5125 procedure :: current => currentdbametaanddatar
5126 procedure :: display => displaydbametaanddatar
5127 procedure :: toarray => toarray_dbametaanddatar
5129
5132 type(dbametadata) :: metadata
5133 contains
5134 procedure :: display => dbametaanddatac_display
5135 procedure :: extrude => dbametaanddatac_extrude
5137
5140 contains
5141 procedure :: current => currentdbametaanddatac
5142 procedure :: display => displaydbametaanddatac
5143 procedure :: toarray => toarray_dbametaanddatac
5145
5148 type(dbaana) :: ana
5149 character(len=6) :: var
5150 type(dbadatetime) :: datetime
5151 type(dbalevel) :: level
5152 type(dbatimerange) :: timerange
5153 type(dbanetwork) :: network
5154
5155 type(dbacoord) :: coordmin,coordmax
5156 type(dbadatetime) :: datetimemin,datetimemax
5157 integer :: limit
5158 character(len=255) :: ana_filter, data_filter, attr_filter, varlist, starvarlist, anavarlist, anastarvarlist
5159 character(len=40) :: query
5160 integer :: priority,priomin,priomax
5161 logical :: contextana
5162 logical :: anaonly
5163 logical :: dataonly
5164 type(dbadcv) :: vars,starvars
5165 type(dbadcv) :: anavars,anastarvars
5166 contains
5167 procedure :: display => dbafilter_display
5168 procedure :: dbaset => dbafilter_set
5169 procedure :: equalmetadata => dbafilter_equal_dbametadata
5172 generic :: operator (==) => equalmetadata
5174
5177 procedure dbafilter_init
5178end interface
5179
5180contains
5181
5183subroutine displaydbametaanddata(this)
5184class(dbametaanddataList),intent(inout) :: this
5185type(dbametaanddata) :: element
5186
5187call this%rewind()
5188do while(this%element())
5189 print *,"index:",this%currentindex()," value:"
5190 element=this%current()
5191 call element%display()
5192 call this%next()
5193end do
5194end subroutine displaydbametaanddata
5195
5197type(dbametaanddata) function currentdbametaanddata(this)
5198class(dbametaanddataList),intent(inout) :: this
5199class(*), pointer :: v
5200
5201v => this%currentpoli()
5202select type(v)
5204 currentdbametaanddata = v
5205end select
5206end function currentdbametaanddata
5207
5208
5210elemental logical function dbadata_equal(this,that)
5211
5212class(dbadata), intent(in) :: this
5213class(dbadata), intent(in) :: that
5214
5215if ( this%btable == that%btable ) then
5216 dbadata_equal = .true.
5217else
5218 dbadata_equal = .false.
5219end if
5220
5221end function dbadata_equal
5222
5223
5225subroutine dbadata_geti(data,value)
5226class(dbadata), intent(in) :: data
5227integer, intent(out) :: value
5228value=imiss
5229
5230select type(data)
5232 value = data%value
5233end select
5234
5235end subroutine dbadata_geti
5236
5237
5239logical function dbadata_c_e_i(data)
5240class(dbadata), intent(in) :: data
5241
5242dbadata_c_e_i=.false.
5243
5244select type(data)
5246 dbadata_c_e_i = c_e(data%value)
5247end select
5248
5249end function dbadata_c_e_i
5250
5252subroutine dbadata_getr(data,value)
5253class(dbadata), intent(in) :: data
5254real, intent(out) :: value
5255value=rmiss
5256
5257select type(data)
5259 value = data%value
5260end select
5261
5262end subroutine dbadata_getr
5263
5265logical function dbadata_c_e_r(data)
5266class(dbadata), intent(in) :: data
5267
5268dbadata_c_e_r=.false.
5269
5270select type(data)
5272 dbadata_c_e_r = c_e(data%value)
5273end select
5274
5275end function dbadata_c_e_r
5276
5278subroutine dbadata_getd(data,value)
5279class(dbadata), intent(in) :: data
5280doubleprecision, intent(out) :: value
5281value=dmiss
5282
5283select type(data)
5285 value = data%value
5286end select
5287
5288end subroutine dbadata_getd
5289
5291logical function dbadata_c_e_d(data)
5292class(dbadata), intent(in) :: data
5293
5294dbadata_c_e_d=.false.
5295
5296select type(data)
5298 dbadata_c_e_d = c_e(data%value)
5299end select
5300
5301end function dbadata_c_e_d
5302
5303
5305subroutine dbadata_getb(data,value)
5306class(dbadata), intent(in) :: data
5307INTEGER(kind=int_b), intent(out) :: value
5308value=bmiss
5309
5310select type(data)
5312 value = data%value
5313end select
5314
5315end subroutine dbadata_getb
5316
5318logical function dbadata_c_e_b(data)
5319class(dbadata), intent(in) :: data
5320
5321dbadata_c_e_b=.false.
5322
5323select type(data)
5325 dbadata_c_e_b = c_e(data%value)
5326end select
5327
5328end function dbadata_c_e_b
5329
5331subroutine dbadata_getc(data,value)
5332class(dbadata), intent(in) :: data
5333character(len=*), intent(out) :: value
5334value=cmiss
5335
5336select type(data)
5338 value = data%value
5339end select
5340
5341end subroutine dbadata_getc
5342
5343
5345logical function dbadata_c_e_c(data)
5346class(dbadata), intent(in) :: data
5347
5348dbadata_c_e_c=.false.
5349
5350select type(data)
5352 dbadata_c_e_c = c_e(data%value)
5353end select
5354
5355end function dbadata_c_e_c
5356
5357
5359logical function dbadata_c_e(data)
5360class(dbadata), intent(in) :: data
5361
5362dbadata_c_e=data%dbadata_c_e_i() .or. data%dbadata_c_e_r() .or. data%dbadata_c_e_d() &
5363 .or. data%dbadata_c_e_b() .or. data%dbadata_c_e_c()
5364
5365end function dbadata_c_e
5366
5367
5369subroutine dbalevel_display(level)
5370class(dbalevel), intent(in) :: level
5371call display (level%vol7d_level)
5372end subroutine dbalevel_display
5373
5376type(dbalevel) function dbalevel_init(level1, l1, level2, l2)
5377
5378INTEGER,INTENT(IN),OPTIONAL :: level1
5379INTEGER,INTENT(IN),OPTIONAL :: l1
5380INTEGER,INTENT(IN),OPTIONAL :: level2
5381INTEGER,INTENT(IN),OPTIONAL :: l2
5382
5383call init (dbalevel_init%vol7d_level,level1, l1, level2, l2)
5384end function dbalevel_init
5385
5387subroutine dbalevel_set(level,session)
5388class(dbalevel), intent(in) :: level
5389type(dbasession), intent(in) :: session
5390integer :: ier
5391
5392!if (c_e(session%sehandle)) then
5393ier = idba_setlevel(session%sehandle,&
5394 level%level1, level%l1, level%level2, level%l2)
5395
5396!todo this is a work around
5397if (.not. c_e(level%vol7d_level)) then
5398 call session%setcontextana
5399end if
5400
5401end subroutine dbalevel_set
5402
5404subroutine dbalevel_enq(level,session)
5405class(dbalevel), intent(out) :: level
5406type(dbasession), intent(in) :: session
5407integer :: ier
5408
5409ier = idba_enqlevel(session%sehandle,&
5410 level%level1, level%l1, level%level2, level%l2)
5411
5412end subroutine dbalevel_enq
5413
5415type(dbalevel) function dbalevel_contextana()
5416
5417dbalevel_contextana=dbalevel()
5418
5419end function dbalevel_contextana
5420
5421
5423subroutine dbaana_display(ana)
5424class(dbaana), intent(in) :: ana
5425call display (ana%vol7d_ana)
5426end subroutine dbaana_display
5427
5428
5431type(dbacoord) function dbacoord_init(lon, lat, ilon, ilat)
5432REAL(kind=fp_geo),INTENT(in),OPTIONAL :: lon
5433REAL(kind=fp_geo),INTENT(in),OPTIONAL :: lat
5434INTEGER(kind=int_l),INTENT(in),OPTIONAL :: ilon
5435INTEGER(kind=int_l),INTENT(in),OPTIONAL :: ilat
5436
5437CALL init(dbacoord_init%geo_coord, lon=lon, lat=lat , ilon=ilon, ilat=ilat)
5438
5439end function dbacoord_init
5440
5442subroutine dbacoord_display(coord)
5443class(dbacoord), intent(in) :: coord
5444call display (coord%geo_coord)
5445end subroutine dbacoord_display
5446
5449type(dbaana) function dbaana_init(coord,ident,lon, lat, ilon, ilat)
5450CHARACTER(len=*),INTENT(in),OPTIONAL :: ident
5451TYPE(dbacoord),INTENT(IN),optional :: coord
5452REAL(kind=fp_geo),INTENT(in),OPTIONAL :: lon
5453REAL(kind=fp_geo),INTENT(in),OPTIONAL :: lat
5454INTEGER(kind=int_l),INTENT(in),OPTIONAL :: ilon
5455INTEGER(kind=int_l),INTENT(in),OPTIONAL :: ilat
5456
5457if (present(coord))then
5458 CALL init(dbaana_init%vol7d_ana, ilon=getilon(coord%geo_coord), ilat=getilat(coord%geo_coord), ident=ident)
5459else
5460 CALL init(dbaana_init%vol7d_ana, lon=lon, lat=lat, ilon=ilon, ilat=ilat, ident=ident)
5461end if
5462
5463end function dbaana_init
5464
5466subroutine dbaana_set(ana,session)
5467class(dbaana), intent(in) :: ana
5468type(dbasession), intent(in) :: session
5469integer :: ier
5470
5471!if (c_e(session%sehandle)) then
5472ier = idba_set(session%sehandle,"lat",getilat(ana%vol7d_ana%coord))
5473ier = idba_set(session%sehandle,"lon",getilon(ana%vol7d_ana%coord))
5474if (c_e(ana%vol7d_ana%ident)) then
5475 ier = idba_set(session%sehandle,"ident",ana%vol7d_ana%ident)
5476 ier = idba_set(session%sehandle,"mobile",1)
5477else
5478 ier = idba_set(session%sehandle,"ident",cmiss)
5479 ier = idba_set(session%sehandle,"mobile",imiss)
5480end if
5481
5482end subroutine dbaana_set
5483
5485subroutine dbaana_enq(ana,session)
5486class(dbaana), intent(out) :: ana
5487type(dbasession), intent(in) :: session
5488integer :: ier,ilat,ilon
5489
5490!if (c_e(session%sehandle)) then
5491ier = idba_enq(session%sehandle,"lat",ilat)
5492ier = idba_enq(session%sehandle,"lon",ilon)
5493
5494call init(ana%vol7d_ana%coord,ilon=ilon,ilat=ilat)
5495ier = idba_enq(session%sehandle,"ident",ana%vol7d_ana%ident)
5496
5497end subroutine dbaana_enq
5498
5499
5501subroutine dbaana_extrude(ana,session)
5502class(dbaana), intent(in) :: ana
5503type(dbasession), intent(in) :: session
5504
5505call session%unsetall()
5506!write ana
5507call session%set(ana=ana)
5508call session%prendilo()
5509
5510!to close message on file
5511call session%close_message()
5512
5513end subroutine dbaana_extrude
5514
5515
5517subroutine displaydbaana(this)
5518class(dbaanaList),intent(inout) :: this
5519type(dbaana) :: element
5520
5521call this%rewind()
5522do while(this%element())
5523 print *,"index:",this%currentindex()," value:"
5524 element=this%current()
5525 call element%display()
5526 call this%next()
5527end do
5528end subroutine displaydbaana
5529
5531type(dbaana) function currentdbaana(this)
5532class(dbaanaList) :: this
5533class(*), pointer :: v
5534
5535v => this%currentpoli()
5536select type(v)
5538 currentdbaana = v
5539end select
5540end function currentdbaana
5541
5542
5544subroutine dbadc_set(dc,session)
5545class(dbadc), intent(in) :: dc
5546type(dbasession), intent(in) :: session
5547
5548call dc%dat%dbaset(session)
5549
5550end subroutine dbadc_set
5551
5553subroutine dbadc_display(dc)
5554class(dbadc), intent(in) :: dc
5555
5556call dc%dat%display()
5557
5558end subroutine dbadc_display
5559
5561subroutine dbadcv_set(dcv,session)
5562class(dbadcv), intent(in) :: dcv
5563type(dbasession), intent(in) :: session
5564integer :: i
5565
5566do i=1, size(dcv%dcv)
5567 call dcv%dcv(i)%dbaset(session)
5568enddo
5569
5570end subroutine dbadcv_set
5571
5572
5573
5575subroutine dbadcv_extrude(dcv,session,noattr,filter,template)
5576class(dbadcv), intent(in) :: dcv
5577type(dbasession), intent(in) :: session
5578logical, intent(in),optional :: noattr
5579type(dbafilter),intent(in),optional :: filter
5580character(len=*),intent(in),optional :: template
5581integer :: i
5582
5583do i=1, size(dcv%dcv)
5584 call dcv%dcv(i)%extrude(session,noattr,filter,template=template)
5585enddo
5586
5587end subroutine dbadcv_extrude
5588
5590subroutine dbadc_extrude(data,session,noattr,filter,attronly,template)
5591class(dbadc), intent(in) :: data
5592type(dbasession), intent(in) :: session
5593logical, intent(in),optional :: noattr
5594type(dbafilter),intent(in),optional :: filter
5595logical, intent(in),optional :: attronly
5596character(len=*),intent(in),optional :: template
5597
5598call data%extrude(session,noattr,filter,attronly,template)
5599
5600end subroutine dbadc_extrude
5601
5602
5604subroutine dbadcv_display(dcv)
5605class(dbadcv), intent(in) :: dcv
5606integer :: i
5607
5608if (allocated(dcv%dcv)) then
5609 do i=1, size(dcv%dcv)
5610 call dcv%dcv(i)%display()
5611 end do
5612end if
5613end subroutine dbadcv_display
5614
5615!!$subroutine dbadat_extrude(dat,session)
5616!!$class(dbadat), intent(in) :: dat
5617!!$type(dbasession), intent(in) :: session
5618!!$
5619!!$!write data in dsn
5620!!$call dat%dbaset(session)
5621!!$call session%prendilo()
5622!!$
5623!!$end subroutine dbadat_extrude
5624!!$
5625!!$subroutine dbadatav_extrude(datav,session)
5626!!$class(dbadatav), intent(in) :: datav
5627!!$type(dbasession), intent(in) :: session
5628!!$integer :: i
5629!!$!write data in dsn
5630!!$do i =1,size(datav%dat)
5631!!$ call datav%dat(i)%dbaset(session)
5632!!$end do
5633!!$call session%prendilo()
5634!!$
5635!!$end subroutine dbadatav_extrude
5636
5637
5639subroutine dbasession_unsetb(session)
5640class(dbasession), intent(in) :: session
5641integer :: ier
5642
5643!if (session%file)then
5644ier=idba_unsetb(session%sehandle)
5645!end if
5646end subroutine dbasession_unsetb
5647
5649subroutine dbasession_close_message(session,template)
5650class(dbasession), intent(in) :: session
5651character(len=*),intent(in),optional :: template
5652integer :: ier
5653character(len=40) :: ltemplate
5654
5655
5656ltemplate=session%template
5657if (present(template)) ltemplate=template
5658
5659!!$print*,"--------------- dbasession ---------------------------------"
5660!!$print *,'file',session%file
5661!!$print *,'filename',trim(session%filename)
5662!!$print *,'mode',session%mode
5663!!$print *,'format',session%format
5664!!$print *,'simplified',session%simplified
5665!!$print *,'memdb',session%memdb
5666!!$print *,'loadfile',session%loadfile
5667!!$print *,'template',ltemplate
5668!!$print*,"------------------------------------------------"
5669
5670if (session%file)then
5671
5672 if (session%memdb) then
5673
5674 return
5675 !call session%messages_write_next(template=ltemplate)
5676
5677 else
5678
5679 if (c_e(ltemplate)) then
5680 ier=idba_set(session%sehandle,"query","message "//trim(ltemplate))
5681 else
5682 ier=idba_set(session%sehandle,"query","message")
5683 end if
5684
5685 call session%unsetb()
5686 call session%prendilo()
5687
5688 end if
5689end if
5690end subroutine dbasession_close_message
5691
5692
5694subroutine dbasession_messages_open_input(session,filename,mode,format,simplified)
5695class(dbasession), intent(in) :: session
5696character (len=*), intent(in) :: filename
5697character (len=*), intent(in),optional :: mode
5698character (len=*), intent(in),optional :: format
5699logical, intent(in),optional :: simplified
5700
5701integer :: ier
5702character (len=40) :: lmode, lformat
5703logical :: lsimplified
5704
5705lmode="r"
5706if (present(mode)) lmode=mode
5707
5708lformat="BUFR"
5709if (present(format)) lformat=format
5710
5711lsimplified=.true.
5712if (present(simplified)) lsimplified=simplified
5713
5714ier = idba_messages_open_input(session%sehandle, filename, lmode, lformat, lsimplified)
5715
5716end subroutine dbasession_messages_open_input
5717
5718
5720subroutine dbasession_messages_open_output(session,filename,mode,format)
5721class(dbasession), intent(in) :: session
5722character (len=*), intent(in) :: filename
5723character (len=*), intent(in),optional :: mode
5724character (len=*), intent(in),optional :: format
5725
5726integer :: ier
5727character (len=40) :: lmode, lformat
5728
5729lmode="w"
5730if (present(mode)) lmode=mode
5731
5732lformat="BUFR"
5733if (present(format)) lformat=format
5734
5735ier = idba_messages_open_output(session%sehandle, filename, lmode, lformat)
5736
5737end subroutine dbasession_messages_open_output
5738
5739
5741logical function dbasession_messages_read_next(session)
5742class(dbasession), intent(in) :: session
5743
5744integer :: ier
5745
5746ier = idba_messages_read_next(session%sehandle, dbasession_messages_read_next)
5747
5748end function dbasession_messages_read_next
5749
5751subroutine dbasession_messages_write_next(session,template)
5752class(dbasession), intent(in) :: session
5753character(len=*), optional :: template
5754character(len=40) :: ltemplate
5755
5756integer :: ier
5757
5758!TODO how to set autodetect?
5759!ltemplate="generic" !! "wmo" = wmo - WMO style templates (autodetect) ?
5760
5761ltemplate=session%template
5762if (present(template)) ltemplate=template
5763
5764ier = idba_messages_write_next(session%sehandle,ltemplate)
5765
5766end subroutine dbasession_messages_write_next
5767
5768
5770subroutine dbasession_dissolve_metadata(session,metadata)
5771class(dbasession), intent(in) :: session
5772type(dbametadata), intent(in) :: metadata(:)
5773
5774integer :: i
5775
5776do i =1, size (metadata)
5777
5778 call metadata(i)%dbaset(session)
5779 call session%dissolve()
5780
5781end do
5782
5783end subroutine dbasession_dissolve_metadata
5784
5785
5786
5788subroutine dbasession_dissolveattr_metadata(session,metadata)
5789class(dbasession), intent(in) :: session
5790type(dbametadata), intent(in),optional :: metadata(:)
5791
5792character(len=9) :: btable
5793integer :: i,ii,count,ier
5794
5795if (present (metadata)) then
5796 do i =1, size (metadata)
5797
5798 ! here if metadata have some field missig they will be set to missing so it will be unset in dballe (I hope)
5799 call metadata(i)%dbaset(session)
5800 ier = idba_voglioquesto(session%sehandle, count)
5801
5802 if (.not. c_e(count)) cycle
5803 do ii =1,count
5804 ier = idba_dammelo(session%sehandle, btable)
5805 !call session%var_related(btable) !not needed after dammelo
5806 call session%scusa()
5807 end do
5808
5809 end do
5810else
5811
5812 ier = idba_voglioquesto(session%sehandle, count)
5813
5814 if (c_e(count)) then
5815 do i =1,count
5816 ier = idba_dammelo(session%sehandle, btable)
5817 !call session%var_related(btable) !not needed after dammelo
5818 call session%scusa()
5819 end do
5820 end if
5821end if
5822end subroutine dbasession_dissolveattr_metadata
5823
5824
5826subroutine dbadataattr_extrude(data,session,noattr,filter,attronly,template)
5827class(dbadataattr), intent(in) :: data
5828type(dbasession), intent(in) :: session
5829logical, intent(in),optional :: noattr
5830type(dbafilter),intent(in),optional :: filter
5831logical, intent(in),optional :: attronly
5832character(len=*),intent(in),optional :: template
5833integer :: i,ierr,count,code
5834logical :: critica
5835character(len=9) :: btable
5836
5837
5838if (session%file .and. optio_log(attronly))then
5839 call l4f_category_log(session%category,l4f_error,"attronly writing on file not supported")
5840 CALL raise_fatal_error()
5841end if
5842
5843if (present(filter))then
5844 if (filter%contextana) then
5845 if (.not. filter%anavars == data%dbadc%dat) return
5846 else
5847 if (.not. filter%vars == data%dbadc%dat) return
5848 end if
5849endif
5850
5851!write data in dsn
5852
5853!print *,"extrude dati:"
5854!call data%dbadc%display()
5855
5856! missing on file do nothing
5857if (.not. data%dbadc%dat%c_e() .and. session%file) return
5858
5859call data%dbadc%dbaset(session)
5860
5861code = idba_error_code() !! 13 for Value is outside the range
5862
5863if (optio_log(attronly).or. .not. data%dbadc%dat%c_e() .or. code ==13 ) then
5864
5865 !! those hare required?
5866 ierr = idba_set(session%sehandle,"var",data%dbadc%dat%btable)
5867 !!
5868
5869 ierr = idba_voglioquesto(session%sehandle, count)
5870
5871 ! with missing data to extrude and missing data in DB we have nothing to delete
5872 ! with attronly and missing data in DB we have nothing to do
5873 ierr=idba_unsetb(session%sehandle)
5874 if (count ==0) return
5875
5876 if (c_e(count)) then
5877 if (optio_log(attronly))then
5878 ierr=idba_dammelo(session%sehandle, btable)
5879 !ierr=idba_enqi(session%sehandle, "context_id", id)
5880 else
5881 !remove data from db if data is missing
5882 ierr=idba_dimenticami(session%sehandle)
5883 endif
5884 endif
5885else
5886 call session%prendilo()
5887 ierr=idba_unsetb(session%sehandle)
5888end if
5889
5890if (optio_log(noattr)) return
5891
5892!write attributes in dsn
5893if (allocated(data%attrv%dcv)) then
5894 if (size(data%attrv%dcv) > 0 )then
5895 critica = .false.
5896 do i = 1, size(data%attrv%dcv)
5897 if (present(filter))then
5898 if (filter%contextana) then
5899 if (.not. filter%anastarvars == data%attrv%dcv(i)%dat) cycle
5900 else
5901 if (.not. filter%starvars == data%attrv%dcv(i)%dat) cycle
5902 end if
5903 endif
5904
5905 if (data%attrv%dcv(i)%dat%c_e()) then
5906 !print *,"extrude attributi:"
5907 !call data%attrv%dcv(i)%dat%display()
5908 call data%attrv%dcv(i)%dat%dbaset(session)
5909 critica=.true.
5910 else if(optio_log(attronly)) then
5911 !ierr=idba_seti(session%sehandle, "*context_id", id)
5912 !call session%var_related(data%dbadc%dat%btable) ! If I have made a prendilo I do not need this
5913 !call data%attrv%dcv(i)%dat%dbaset(session)
5914 ierr = idba_set(session%sehandle,"*var",data%attrv%dcv(i)%dat%btable)
5915 !print *,"scusa attributi:"
5916 !call data%attrv%dcv(i)%dat%display()
5917 call session%scusa()
5918 endif
5919 end do
5920 if (critica) then
5921 !ierr=idba_seti(session%sehandle, "*context_id", id)
5922 !call session%var_related(data%dbadc%dat%btable) ! If I have made a prendilo I do not need this
5923 call session%critica()
5924 end if
5925
5926 end if
5927end if
5928
5929
5930!to close message on file
5931!call session%close_message()
5932
5933end subroutine dbadataattr_extrude
5934
5936subroutine dbadataattr_display(dc)
5937class(dbadataattr), intent(in) :: dc
5938
5939print*,"Data:"
5940call dc%dbadc%display()
5941print*,"Attributes:"
5942call dc%attrv%display()
5943
5944end subroutine dbadataattr_display
5945
5946
5948subroutine dbadataattrv_extrude(dataattr,session,noattr,filter,attronly,template)
5949class(dbadataattrv), intent(in) :: dataattr
5950type(dbasession), intent(in) :: session
5951logical, intent(in),optional :: noattr
5952type(dbafilter),intent(in),optional :: filter
5953logical, intent(in),optional :: attronly
5954character(len=*),intent(in),optional :: template
5955
5956integer :: i
5957
5958if(.not. allocated(dataattr%dataattr)) return
5959do i=1, size(dataattr%dataattr)
5960 call dataattr%dataattr(i)%extrude(session,noattr,filter,attronly,template)
5961enddo
5962
5963!to close message on file
5964!call session%prendilo()
5965!call session%close_message()
5966
5967end subroutine dbadataattrv_extrude
5968
5970subroutine dbadataattrv_display(dataattr)
5971class(dbadataattrv), intent(in) :: dataattr
5972integer :: i
5973
5974do i=1, size(dataattr%dataattr)
5975 call dataattr%dataattr(i)%display()
5976end do
5977
5978end subroutine dbadataattrv_display
5979
5981subroutine dbadatai_geti(data,value)
5982class(dbadatai), intent(in) :: data
5983integer, intent(out) :: value
5984value=data%value
5985end subroutine dbadatai_geti
5986
5988subroutine dbadatar_getr(data,value)
5989class(dbadatar), intent(in) :: data
5990real, intent(out) :: value
5991value=data%value
5992end subroutine dbadatar_getr
5993
5995subroutine dbadatad_getd(data,value)
5996class(dbadatad), intent(in) :: data
5997doubleprecision, intent(out) :: value
5998value=data%value
5999end subroutine dbadatad_getd
6000
6002subroutine dbadatab_getb(data,value)
6003class(dbadatab), intent(in) :: data
6004integer(kind=int_b), intent(out) :: value
6005value=data%value
6006end subroutine dbadatab_getb
6007
6009subroutine dbadatac_getc(data,value)
6010class(dbadatac), intent(in) :: data
6011character(len=*), intent(out) :: value
6012value=data%value
6013end subroutine dbadatac_getc
6014
6015
6018type(dbadatai) elemental function dbadatai_init(btable,value)
6019
6020character(len=*),INTENT(IN),OPTIONAL :: btable
6021INTEGER,INTENT(IN),OPTIONAL :: value
6022
6023if (present(btable)) then
6024 dbadatai_init%btable=btable
6025else
6026 dbadatai_init%btable=cmiss
6027end if
6028
6029if (present(value)) then
6030 dbadatai_init%value=value
6031else
6032 dbadatai_init%value=imiss
6033end if
6034
6035end function dbadatai_init
6036
6039type(dbadatar) elemental function dbadatar_init(btable,value)
6040
6041character(len=*),INTENT(IN),OPTIONAL :: btable
6042real,INTENT(IN),OPTIONAL :: value
6043
6044if (present(btable)) then
6045 dbadatar_init%btable=btable
6046else
6047 dbadatar_init%btable=cmiss
6048end if
6049
6050if (present(value)) then
6051 dbadatar_init%value=value
6052else
6053 dbadatar_init%value=rmiss
6054end if
6055
6056end function dbadatar_init
6057
6060type(dbadatad) elemental function dbadatad_init(btable,value)
6061
6062character(len=*),INTENT(IN),OPTIONAL :: btable
6063double precision,INTENT(IN),OPTIONAL :: value
6064
6065if (present(btable)) then
6066 dbadatad_init%btable=btable
6067else
6068 dbadatad_init%btable=cmiss
6069end if
6070
6071if (present(value)) then
6072 dbadatad_init%value=value
6073else
6074 dbadatad_init%value=dmiss
6075end if
6076
6077end function dbadatad_init
6078
6079
6082type(dbadatab) elemental function dbadatab_init(btable,value)
6083
6084character(len=*),INTENT(IN),OPTIONAL :: btable
6085INTEGER(kind=int_b) ,INTENT(IN),OPTIONAL :: value
6086
6087if (present(btable)) then
6088 dbadatab_init%btable=btable
6089else
6090 dbadatab_init%btable=cmiss
6091end if
6092
6093if (present(value)) then
6094 dbadatab_init%value=value
6095else
6096 dbadatab_init%value=bmiss
6097end if
6098
6099end function dbadatab_init
6100
6103type(dbadatac) elemental function dbadatac_init(btable,value)
6104
6105character(len=*),INTENT(IN),OPTIONAL :: btable
6106character(len=*),INTENT(IN),OPTIONAL :: value
6107
6108if (present(btable)) then
6109 dbadatac_init%btable=btable
6110else
6111 dbadatac_init%btable=cmiss
6112end if
6113
6114if (present(value)) then
6115 dbadatac_init%value=value
6116else
6117 dbadatac_init%value=cmiss
6118end if
6119
6120end function dbadatac_init
6121
6122
6124subroutine dbadatai_set(data,session)
6125class(dbadatai), intent(in) :: data
6126type(dbasession), intent(in) :: session
6127integer :: ier
6128if (.not. c_e(data%btable)) return
6129ier = idba_set(session%sehandle,data%btable,data%value)
6130end subroutine dbadatai_set
6131
6133subroutine dbadatai_display(data)
6134class(dbadatai), intent(in) :: data
6135print *,"Btable: ", t2c(data%btable,miss="Missing")," Value: ", t2c(data%value,miss="Missing value")
6136end subroutine dbadatai_display
6137
6139subroutine dbadatar_set(data,session)
6140class(dbadatar), intent(in) :: data
6141type(dbasession), intent(in) :: session
6142integer :: ier
6143if (.not. c_e(data%btable)) return
6144ier = idba_set(session%sehandle,data%btable,data%value)
6145end subroutine dbadatar_set
6146
6148subroutine dbadatar_display(data)
6149class(dbadatar), intent(in) :: data
6150print *,"Btable: ", t2c(data%btable,miss="Missing")," Value: ", t2c(data%value,miss="Missing value")
6151end subroutine dbadatar_display
6152
6153
6155subroutine dbadatad_set(data,session)
6156class(dbadatad), intent(in) :: data
6157type(dbasession), intent(in) :: session
6158integer :: ier
6159if (.not. c_e(data%btable)) return
6160ier = idba_set(session%sehandle,data%btable,data%value)
6161end subroutine dbadatad_set
6162
6164subroutine dbadatad_display(data)
6165class(dbadatad), intent(in) :: data
6166print *,"Btable: ", t2c(data%btable,miss="Missing")," Value: ", t2c(data%value,miss="Missing value")
6167end subroutine dbadatad_display
6168
6170subroutine dbadatab_set(data,session)
6171class(dbadatab), intent(in) :: data
6172type(dbasession), intent(in) :: session
6173integer :: ier
6174if (.not. c_e(data%btable)) return
6175ier = idba_set(session%sehandle,data%btable,data%value)
6176end subroutine dbadatab_set
6177
6179subroutine dbadatab_display(data)
6180class(dbadatab), intent(in) :: data
6181print *,"Btable: ", t2c(data%btable,miss="Missing")," Value: ", t2c(data%value,miss="Missing value")
6182end subroutine dbadatab_display
6183
6185subroutine dbadatac_set(data,session)
6186class(dbadatac), intent(in) :: data
6187type(dbasession), intent(in) :: session
6188integer :: ier
6189if (.not. c_e(data%btable)) return
6190ier = idba_set(session%sehandle,data%btable,data%value)
6191end subroutine dbadatac_set
6192
6194subroutine dbadatac_display(data)
6195class(dbadatac), intent(in) :: data
6196print *,"Btable: ", t2c(data%btable,miss="Missing")," Value: ", t2c(data%value,miss="Missing value")
6197end subroutine dbadatac_display
6198
6199
6200!!$function dbalevel_spiega(level,handle)
6201!!$class(dbalevel), intent(in) :: level
6202!!$integer, intent(in) :: handle
6203!!$character (len=255) :: dbalevel_spiega
6204!!$integer :: ier
6205!!$
6206!!$ier = idba_spiegal(handle,level%level1,level%l1,level%level2,level%l2,dbalevel_spiega)
6207!!$if (ier /= 0) dbalevel_spiega = cmiss
6208!!$
6209!!$end function dbalevel_spiega
6210
6211
6213subroutine dbatimerange_display(timerange)
6214class(dbatimerange), intent(in) :: timerange
6215call display (timerange%vol7d_timerange)
6216end subroutine dbatimerange_display
6217
6219subroutine dbatimerange_set(timerange,session)
6220class(dbatimerange), intent(in) :: timerange
6221type(dbasession), intent(in) :: session
6222integer :: ier
6223
6224ier = idba_settimerange(session%sehandle,&
6225 timerange%timerange, timerange%p1, timerange%p2)
6226
6227!todo this is a work around
6228if (.not. c_e(timerange%vol7d_timerange)) then
6229 call session%setcontextana
6230end if
6231
6232end subroutine dbatimerange_set
6233
6235subroutine dbatimerange_enq(timerange,session)
6236class(dbatimerange), intent(out) :: timerange
6237type(dbasession), intent(in) :: session
6238integer :: ier
6239
6240ier = idba_enqtimerange(session%sehandle,&
6241 timerange%timerange, timerange%p1, timerange%p2)
6242
6243end subroutine dbatimerange_enq
6244
6247type(dbatimerange) function dbatimerange_init(timerange, p1, p2)
6248INTEGER,INTENT(IN),OPTIONAL :: timerange
6249INTEGER,INTENT(IN),OPTIONAL :: p1
6250INTEGER,INTENT(IN),OPTIONAL :: p2
6251
6252call init (dbatimerange_init%vol7d_timerange,timerange, p1, p2)
6253end function dbatimerange_init
6254
6256type(dbatimerange) function dbatimerange_contextana()
6257
6258dbatimerange_contextana=dbatimerange()
6259
6260end function dbatimerange_contextana
6261
6262
6264subroutine dbanetwork_display(network)
6265class(dbanetwork), intent(in) :: network
6266call display (network%vol7d_network)
6267print *,"Priority=",network%priority
6268end subroutine dbanetwork_display
6269
6271subroutine dbanetwork_set(network,session)
6272class(dbanetwork), intent(in) :: network
6273type(dbasession), intent(in) :: session
6274integer :: ier
6275
6276ier = idba_set(session%sehandle,"rep_memo", network%name)
6277
6278end subroutine dbanetwork_set
6279
6281subroutine dbanetwork_enq(network,session)
6282class(dbanetwork), intent(out) :: network
6283type(dbasession), intent(in) :: session
6284integer :: ier
6285
6286ier = idba_enq(session%sehandle,"rep_memo", network%name)
6287ier = idba_enq(session%sehandle,"priority", network%priority)
6288
6289end subroutine dbanetwork_enq
6290
6293type(dbanetwork) function dbanetwork_init(name)
6294CHARACTER(len=*),INTENT(in),OPTIONAL :: name
6295
6296call init (dbanetwork_init%vol7d_network,name)
6297dbanetwork_init%priority=imiss
6298end function dbanetwork_init
6299
6300
6302subroutine dbadatetime_display(datetime)
6303class(dbadatetime), intent(in) :: datetime
6304call display (datetime%datetime)
6305end subroutine dbadatetime_display
6306
6308subroutine dbadatetime_set(datetime,session)
6309class(dbadatetime), intent(in) :: datetime
6310type(dbasession), intent(in) :: session
6311integer :: ier,year,month,day,hour,minute,sec,msec
6312
6313CALL getval(datetime%datetime, year=year, month=month, day=day, hour=hour, minute=minute,msec=msec)
6314
6315if (c_e(msec)) then
6316 sec=nint(float(msec)/1000.)
6317else
6318 sec=imiss
6319end if
6320
6321ier = idba_setdate(session%sehandle,year,month,day,hour,minute,sec)
6322
6323!todo this is a work around
6324if (.not. c_e(datetime%datetime)) then
6325 call session%setcontextana
6326end if
6327
6328end subroutine dbadatetime_set
6329
6331subroutine dbadatetime_enq(datetime,session)
6332class(dbadatetime), intent(out) :: datetime
6333type(dbasession), intent(in) :: session
6334
6335integer :: ier,year,month,day,hour,minute,sec,msec
6336
6337ier = idba_enqdate(session%sehandle,year,month,day,hour,minute,sec)
6338
6339if (c_e(sec)) then
6340 msec=sec*1000
6341else
6342 msec=imiss
6343end if
6344
6345!! TODO
6346!! this is a workaround ! year == 1000 should never exist
6347if (year==1000) then
6348 datetime%datetime=datetime_new()
6349else
6350 CALL init(datetime%datetime, year=year, month=month, day=day, hour=hour, minute=minute,msec=msec)
6351end if
6352
6353end subroutine dbadatetime_enq
6354
6357type(dbadatetime) function dbadatetime_init(dt)
6358type(datetime),INTENT(in),OPTIONAL :: dt
6359
6360if (present(dt)) then
6361 dbadatetime_init%datetime=dt
6362else
6363 dbadatetime_init%datetime=datetime_new()
6364end if
6365
6366end function dbadatetime_init
6367
6369type(dbadatetime) function dbadatetime_contextana()
6370
6371dbadatetime_contextana%datetime=datetime_new()
6372
6373end function dbadatetime_contextana
6374
6375
6378type(dbametadata) function dbametadata_init(level,timerange,ana,network,datetime)
6379
6380type(dbalevel), intent(in), optional :: level
6381type(dbatimerange), intent(in), optional :: timerange
6382type(dbaana), intent(in), optional :: ana
6383type(dbanetwork), intent(in), optional :: network
6384type(dbadatetime), intent(in), optional :: datetime
6385
6386if (present(level)) then
6387 dbametadata_init%level=level
6388else
6389 dbametadata_init%level=dbalevel()
6390end if
6391
6392if (present(timerange)) then
6393 dbametadata_init%timerange=timerange
6394else
6395 dbametadata_init%timerange=dbatimerange()
6396end if
6397
6398if (present(ana)) then
6399 dbametadata_init%ana=ana
6400else
6401 dbametadata_init%ana=dbaana()
6402end if
6403
6404if (present(network)) then
6405 dbametadata_init%network=network
6406else
6407 dbametadata_init%network=dbanetwork()
6408end if
6409
6410if (present(datetime)) then
6411 dbametadata_init%datetime=datetime
6412else
6413 dbametadata_init%datetime=dbadatetime()
6414end if
6415
6416end function dbametadata_init
6417
6419subroutine dbametadata_display(metadata)
6420class(dbametadata), intent(in) :: metadata
6421call metadata%level%display()
6422call metadata%timerange%display()
6423call metadata%ana%display()
6424call metadata%network%display()
6425call metadata%datetime%display()
6426
6427end subroutine dbametadata_display
6428
6430subroutine dbametadata_set(metadata,session)
6431class(dbametadata), intent(in) :: metadata
6432type(dbasession), intent(in) :: session
6433
6434!print *,"extrude metadata:"
6435!call metadata%display()
6436
6437call metadata%ana%dbaset(session)
6438call metadata%network%dbaset(session)
6439
6440if (c_e(metadata%datetime%datetime) .or. &
6441 c_e(metadata%level%vol7d_level) .or. &
6442 c_e(metadata%timerange%vol7d_timerange)) then
6443
6444 call metadata%datetime%dbaset(session)
6445 call metadata%level%dbaset(session)
6446 call metadata%timerange%dbaset(session)
6447
6448else
6449 call session%setcontextana()
6450end if
6451
6452end subroutine dbametadata_set
6453
6455subroutine dbametadata_enq(metadata,session)
6456class(dbametadata), intent(out) :: metadata
6457type(dbasession), intent(in) :: session
6458
6459call metadata%ana%dbaenq(session)
6460call metadata%network%dbaenq(session)
6461call metadata%datetime%dbaenq(session)
6462call metadata%level%dbaenq(session)
6463call metadata%timerange%dbaenq(session)
6464
6465end subroutine dbametadata_enq
6466
6467
6469logical function dbafilter_equal_dbametadata(this,that)
6470
6471class(dbafilter), intent(in) :: this
6472class(dbametadata), intent(in) :: that
6473
6474dbafilter_equal_dbametadata = .false.
6475
6476!! TODO utilizzare dataonly ? direi di no
6477
6478if (this%contextana .and. c_e(that%timerange%vol7d_timerange)) return
6479if (this%contextana .and. c_e(that%datetime%datetime)) return
6480if (this%contextana .and. c_e(that%level%vol7d_level)) return
6481
6482if (c_e(this%level%vol7d_level) .and. .not. this%level%vol7d_level == that%level%vol7d_level ) return
6483if (c_e(this%timerange%vol7d_timerange) .and. .not. this%timerange%vol7d_timerange == that%timerange%vol7d_timerange ) return
6484if (c_e(this%datetime%datetime) .and. .not. this%datetime%datetime == that%datetime%datetime ) return
6485if (c_e(this%network%vol7d_network) .and. .not. this%network%vol7d_network == that%network%vol7d_network ) return
6486if (c_e(this%ana%vol7d_ana) .and. .not. this%ana%vol7d_ana == that%ana%vol7d_ana ) return
6487
6488if ( c_e(this%datetimemin%datetime) .and. c_e(that%datetime%datetime) .and. &
6489 this%datetimemin%datetime > that%datetime%datetime ) return
6490if ( c_e(this%datetimemax%datetime) .and. c_e(that%datetime%datetime) .and. &
6491 this%datetimemax%datetime < that%datetime%datetime ) return
6492
6493if (c_e(this%coordmin%geo_coord)) then
6494 if (geo_coord_ll(that%ana%vol7d_ana%coord, this%coordmin%geo_coord)) return
6495end if
6496
6497if (c_e(this%coordmax%geo_coord)) then
6498 if (geo_coord_ur(that%ana%vol7d_ana%coord, this%coordmax%geo_coord)) return
6499end if
6500
6501dbafilter_equal_dbametadata = .true.
6502
6503end function dbafilter_equal_dbametadata
6504
6505
6506!!$!> equal operator for dbafilter and dbadata
6507!!$! todo qui vuene utilizzata vars ma potrebbe essere attrs: bisogna distinguere
6508!!$elemental logical function dbafilter_equal_dbadata(this,that)
6509!!$
6510!!$class(dbafilter), intent(in) :: this !< first element
6511!!$class(dbadata), intent(in) :: that !< second element
6512!!$
6513!!$integer :: i
6514!!$
6515!!$!non compila:
6516!!$!dbafilter_equal_dbadata = any(this%vars%dcv(:)%dat == that)
6517!!$
6518!!$if (allocated(this%vars%dcv)) then
6519!!$ do i=1, size(this%vars%dcv(:))
6520!!$ dbafilter_equal_dbadata = this%vars%dcv(i)%dat == that
6521!!$ if (dbafilter_equal_dbadata) continue
6522!!$ end do
6523!!$else
6524!!$ dbafilter_equal_dbadata=.false.
6525!!$end if
6526!!$
6527!!$end function dbafilter_equal_dbadata
6528
6529
6532elemental logical function dbadcv_equal_dbadata(this,that)
6533
6534class(dbadcv), intent(in) :: this
6535class(dbadata), intent(in) :: that
6536
6537integer :: i
6538
6539!non compila:
6540!dbafilter_equal_dbadata = any(this%vars%dcv(:)%dat == that)
6541
6542if (allocated(this%dcv)) then
6543 dbadcv_equal_dbadata=.false.
6544 do i=1, size(this%dcv)
6545 dbadcv_equal_dbadata = this%dcv(i)%dat == that
6546 if (dbadcv_equal_dbadata) exit
6547 end do
6548else
6549 dbadcv_equal_dbadata=.true.
6550end if
6551
6552end function dbadcv_equal_dbadata
6553
6554
6556elemental logical function dbametadata_equal(this,that)
6557
6558class(dbametadata), intent(in) :: this
6559class(dbametadata), intent(in) :: that
6560
6561if ( &
6562 this%level%vol7d_level == that%level%vol7d_level .and. &
6563 this%timerange%vol7d_timerange == that%timerange%vol7d_timerange .and. &
6564 this%datetime%datetime == that%datetime%datetime .and. &
6565 this%network%vol7d_network == that%network%vol7d_network .and. &
6566 this%ana%vol7d_ana == that%ana%vol7d_ana &
6567 ) then
6568 dbametadata_equal = .true.
6569else
6570 dbametadata_equal = .false.
6571end if
6572
6573end function dbametadata_equal
6574
6575
6579type(dbafilter) function dbafilter_init(filter,ana,var,datetime,level,timerange,network,&
6580 datetimemin,datetimemax,coordmin,coordmax,limit,&
6581 ana_filter, data_filter, attr_filter, varlist, starvarlist, anavarlist, anastarvarlist ,&
6582 priority, priomin, priomax, contextana,&
6583 vars, starvars, anavars, anastarvars, query,anaonly,dataonly)
6584
6585type(dbafilter),intent(in),optional :: filter
6586type(dbaana),intent(in),optional :: ana
6587character(len=*),intent(in),optional :: var
6588type(dbadatetime),intent(in),optional :: datetime
6589type(dbalevel),intent(in),optional :: level
6590type(dbatimerange),intent(in),optional :: timerange
6591type(dbanetwork),intent(in),optional :: network
6592type(dbacoord),intent(in),optional :: coordmin
6593type(dbacoord),intent(in),optional :: coordmax
6594type(dbadatetime),intent(in),optional :: datetimemin
6595type(dbadatetime),intent(in),optional :: datetimemax
6596integer,intent(in),optional :: limit
6597character(len=*),intent(in),optional :: ana_filter
6598character(len=*),intent(in),optional :: data_filter
6599character(len=*),intent(in),optional :: attr_filter
6600character(len=*),intent(in),optional :: varlist
6601character(len=*),intent(in),optional :: starvarlist
6602character(len=*),intent(in),optional :: anavarlist
6603character(len=*),intent(in),optional :: anastarvarlist
6604integer,intent(in),optional :: priority
6605integer,intent(in),optional :: priomin
6606integer,intent(in),optional :: priomax
6607logical,intent(in),optional :: contextana
6608class(dbadcv),intent(in),optional :: vars ! vector of vars wanted on output
6609class(dbadcv),intent(in),optional :: starvars ! vector of vars for attribute wanted on output
6610class(dbadcv),intent(in),optional :: anavars ! vector of ana vars wanted on output
6611class(dbadcv),intent(in),optional :: anastarvars ! vector of vars for attribute of ana wanted on output
6612character(len=*),intent(in),optional :: query
6613logical,intent(in),optional :: anaonly
6614logical,intent(in),optional :: dataonly
6615
6616integer :: i
6617logical :: nopreserve
6618
6619nopreserve=.true.
6620if (present(filter)) then
6621 dbafilter_init=filter
6622
6623!!$ if (allocated(filter%vars%dcv)) then
6624!!$ if (allocated(dbafilter_init%vars%dcv)) deallocate(dbafilter_init%vars%dcv)
6625!!$ allocate(dbafilter_init%vars%dcv(size(filter%vars%dcv)))
6626!!$ do i =1,size(filter%vars%dcv)
6627!!$ allocate(dbafilter_init%vars%dcv(i)%dat,source=filter%vars%dcv(i)%dat)
6628!!$ end do
6629!!$ end if
6630!!$
6631!!$ if (allocated(filter%starvars%dcv)) then
6632!!$ if (allocated(dbafilter_init%starvars%dcv)) deallocate(dbafilter_init%starvars%dcv)
6633!!$ allocate(dbafilter_init%starvars%dcv(size(filter%starvars%dcv)))
6634!!$ do i =1,size(filter%starvars%dcv)
6635!!$ allocate(dbafilter_init%starvars%dcv(i)%dat,source=filter%starvars%dcv(i)%dat)
6636!!$ end do
6637!!$ end if
6638!!$
6639!!$ if (allocated(filter%anavars%dcv)) then
6640!!$ if (allocated(dbafilter_init%anavars%dcv)) deallocate(dbafilter_init%anavars%dcv)
6641!!$ allocate(dbafilter_init%anavars%dcv(size(filter%anavars%dcv)))
6642!!$ do i =1,size(filter%anavars%dcv)
6643!!$ call filter%anavars%dcv(i)%dat%display()
6644!!$ allocate(dbafilter_init%anavars%dcv(i)%dat,source=filter%anavars%dcv(i)%dat)
6645!!$ end do
6646!!$ end if
6647!!$
6648!!$ if (allocated(filter%anastarvars%dcv)) then
6649!!$ if (allocated(dbafilter_init%anastarvars%dcv)) deallocate(dbafilter_init%anastarvars%dcv)
6650!!$ allocate(dbafilter_init%anastarvars%dcv(size(filter%anastarvars%dcv)))
6651!!$ do i =1,size(filter%anastarvars%dcv)
6652!!$ allocate(dbafilter_init%anastarvars%dcv(i)%dat,source=filter%anastarvars%dcv(i)%dat)
6653!!$ end do
6654!!$ end if
6655
6656 nopreserve=.false.
6657end if
6658
6659if (present(ana)) then
6660 dbafilter_init%ana=ana
6661else if (nopreserve) then
6662 dbafilter_init%ana=dbaana()
6663end if
6664
6665if (present(var)) then
6666 dbafilter_init%var=var
6667else if (nopreserve) then
6668 dbafilter_init%var=cmiss
6669end if
6670
6671if (present(datetime)) then
6672 dbafilter_init%datetime=datetime
6673else if (nopreserve) then
6674 dbafilter_init%datetime=dbadatetime()
6675end if
6676
6677if (present(level)) then
6678 dbafilter_init%level=level
6679else if (nopreserve) then
6680 dbafilter_init%level=dbalevel()
6681end if
6682
6683if (present(timerange)) then
6684 dbafilter_init%timerange=timerange
6685else if (nopreserve) then
6686 dbafilter_init%timerange=dbatimerange()
6687end if
6688
6689if (present(network)) then
6690 dbafilter_init%network=network
6691else if (nopreserve) then
6692 dbafilter_init%network=dbanetwork()
6693end if
6694
6695if (present(datetimemin)) then
6696 dbafilter_init%datetimemin=datetimemin
6697else if (nopreserve) then
6698 dbafilter_init%datetimemin=dbadatetime()
6699end if
6700
6701if (present(datetimemax)) then
6702 dbafilter_init%datetimemax=datetimemax
6703else if (nopreserve) then
6704 dbafilter_init%datetimemax=dbadatetime()
6705end if
6706
6707if (present(coordmin)) then
6708 dbafilter_init%coordmin=coordmin
6709else if (nopreserve) then
6710 dbafilter_init%coordmin=dbacoord()
6711end if
6712
6713if (present(coordmax)) then
6714 dbafilter_init%coordmax=coordmax
6715else if (nopreserve) then
6716 dbafilter_init%coordmax=dbacoord()
6717end if
6718
6719if (present(limit)) then
6720 dbafilter_init%limit=limit
6721else if (nopreserve) then
6722 dbafilter_init%limit=imiss
6723end if
6724
6725if (present(ana_filter)) then
6726 dbafilter_init%ana_filter=ana_filter
6727else if (nopreserve) then
6728 dbafilter_init%ana_filter=cmiss
6729end if
6730
6731if (present(data_filter)) then
6732 dbafilter_init%data_filter=data_filter
6733else if (nopreserve) then
6734 dbafilter_init%data_filter=cmiss
6735end if
6736
6737if (present(attr_filter)) then
6738 dbafilter_init%attr_filter=attr_filter
6739else if (nopreserve) then
6740 dbafilter_init%attr_filter=cmiss
6741end if
6742
6743if (present(varlist)) then
6744 dbafilter_init%varlist=varlist
6745else if (nopreserve) then
6746 dbafilter_init%varlist=cmiss
6747end if
6748
6749if (present(starvarlist)) then
6750 dbafilter_init%starvarlist=starvarlist
6751else if (nopreserve) then
6752 dbafilter_init%starvarlist=cmiss
6753end if
6754
6755if (present(anavarlist)) then
6756 dbafilter_init%anavarlist=anavarlist
6757else if (nopreserve) then
6758 dbafilter_init%anavarlist=cmiss
6759end if
6760
6761if (present(anastarvarlist)) then
6762 dbafilter_init%anastarvarlist=anastarvarlist
6763else if (nopreserve) then
6764 dbafilter_init%anastarvarlist=cmiss
6765end if
6766
6767if (present(vars)) then
6768 if (allocated(vars%dcv)) then
6769 allocate(dbafilter_init%vars%dcv(size(vars%dcv)))
6770 do i =1,size(vars%dcv)
6771 allocate(dbafilter_init%vars%dcv(i)%dat,source=vars%dcv(i)%dat)
6772 end do
6773
6774 dbafilter_init%varlist=""
6775 do i=1,size(vars%dcv)
6776 dbafilter_init%varlist=trim(dbafilter_init%varlist)//vars%dcv(i)%dat%btable
6777 if (i /= size(vars%dcv)) dbafilter_init%varlist=trim(dbafilter_init%varlist)//","
6778 end do
6779 endif
6780end if
6781
6782if (present(starvars)) then
6783 if (allocated(starvars%dcv)) then
6784 allocate(dbafilter_init%starvars%dcv(size(starvars%dcv)))
6785 do i =1,size(starvars%dcv)
6786 allocate(dbafilter_init%starvars%dcv(i)%dat,source=starvars%dcv(i)%dat)
6787 end do
6788
6789 dbafilter_init%starvarlist=""
6790 do i=1,size(starvars%dcv)
6791 dbafilter_init%starvarlist=trim(dbafilter_init%starvarlist)//starvars%dcv(i)%dat%btable
6792 if (i /= size(starvars%dcv)) dbafilter_init%starvarlist=trim(dbafilter_init%starvarlist)//","
6793 end do
6794 end if
6795end if
6796
6797
6798if (present(anavars)) then
6799 if (allocated(anavars%dcv)) then
6800 allocate(dbafilter_init%anavars%dcv(size(anavars%dcv)))
6801 do i =1,size(anavars%dcv)
6802 allocate(dbafilter_init%anavars%dcv(i)%dat,source=anavars%dcv(i)%dat)
6803 end do
6804
6805 dbafilter_init%anavarlist=""
6806 do i=1,size(anavars%dcv)
6807 dbafilter_init%anavarlist=trim(dbafilter_init%anavarlist)//anavars%dcv(i)%dat%btable
6808 if (i /= size(anavars%dcv)) dbafilter_init%anavarlist=trim(dbafilter_init%anavarlist)//","
6809 end do
6810 endif
6811end if
6812
6813if (present(anastarvars)) then
6814 if (allocated(anastarvars%dcv)) then
6815 allocate(dbafilter_init%anastarvars%dcv(size(anastarvars%dcv)))
6816 do i =1,size(anastarvars%dcv)
6817 allocate(dbafilter_init%anastarvars%dcv(i)%dat,source=anastarvars%dcv(i)%dat)
6818 end do
6819
6820 dbafilter_init%anastarvarlist=""
6821 do i=1,size(anastarvars%dcv)
6822 dbafilter_init%anastarvarlist=trim(dbafilter_init%anastarvarlist)//anastarvars%dcv(i)%dat%btable
6823 if (i /= size(anastarvars%dcv)) dbafilter_init%anastarvarlist=trim(dbafilter_init%anastarvarlist)//","
6824 end do
6825 end if
6826end if
6827
6828if (present(priority)) then
6829 dbafilter_init%priority=priority
6830else if (nopreserve) then
6831 dbafilter_init%priority=imiss
6832end if
6833
6834if (present(priomin)) then
6835 dbafilter_init%priomin=priomax
6836else if (nopreserve) then
6837 dbafilter_init%priomin=imiss
6838end if
6839
6840if (present(priomax)) then
6841 dbafilter_init%priomax=priomax
6842else if (nopreserve) then
6843 dbafilter_init%priomax=imiss
6844end if
6845
6846if (present(contextana)) then
6847 dbafilter_init%contextana=contextana
6848else if (nopreserve) then
6849 dbafilter_init%contextana=.false.
6850end if
6851
6852if (present(anaonly)) then
6853 dbafilter_init%anaonly=anaonly
6854else if (nopreserve) then
6855 dbafilter_init%anaonly=.false.
6856end if
6857if (present(dataonly)) then
6858 dbafilter_init%dataonly=dataonly
6859else if (nopreserve) then
6860 dbafilter_init%dataonly=.false.
6861end if
6862
6863if (present(query)) then
6864 dbafilter_init%query=query
6865else if (nopreserve) then
6866 dbafilter_init%query=cmiss
6867end if
6868
6869end function dbafilter_init
6870
6872subroutine dbafilter_display(filter)
6873class(dbafilter), intent(in) :: filter
6874
6875print *,"------------------ filter ---------------"
6876call filter%ana%display()
6877call filter%datetime%display()
6878call filter%level%display()
6879call filter%timerange%display()
6880call filter%network%display()
6881print *, " >>>> minimum:"
6882call filter%datetimemin%display()
6883call filter%coordmin%display()
6884print *, " >>>> maximum:"
6885call filter%datetimemax%display()
6886call filter%coordmax%display()
6887print *, " >>>> vars:"
6888call filter%vars%display()
6889print *, " >>>> starvars:"
6890call filter%starvars%display()
6891print *, " >>>> anavars:"
6892call filter%anavars%display()
6893print *, " >>>> anastarvars:"
6894call filter%anastarvars%display()
6895print *,"var=",filter%var
6896print *,"limit=",filter%limit
6897print *,"ana_filter=",trim(filter%ana_filter)
6898print *,"data_filter=",trim(filter%data_filter)
6899print *,"attr_filter=",trim(filter%attr_filter)
6900print *,"varlist=",trim(filter%varlist)
6901print *,"*varlist=",trim(filter%starvarlist)
6902print *,"anavarlist=",trim(filter%anavarlist)
6903print *,"ana*varlist=",trim(filter%anastarvarlist)
6904print *,"priority=",filter%priority
6905print *,"priomin=",filter%priomin
6906print *,"priomax=",filter%priomax
6907print *,"contextana=",filter%contextana
6908print *,"anaonly=",filter%anaonly
6909print *,"dataonly=",filter%dataonly
6910print *,"query=",trim(filter%query)
6911
6912print *,"-----------------------------------------"
6913
6914end subroutine dbafilter_display
6915
6917subroutine dbafilter_set(filter,session)
6918class(dbafilter), intent(in) :: filter
6919type(dbasession), intent(in) :: session
6920
6921integer :: ier,year,month,day,hour,minute,sec,msec
6922
6923call session%unsetall()
6924
6925call filter%ana%dbaset(session)
6926call filter%network%dbaset(session)
6927ier = idba_set(session%sehandle,"var",filter%var)
6928
6929ier = idba_set(session%sehandle,"limit",filter%limit)
6930ier = idba_set(session%sehandle,"priority",filter%priority)
6931ier = idba_set(session%sehandle,"priomin",filter%priomin)
6932ier = idba_set(session%sehandle,"priomax",filter%priomax)
6933
6934ier = idba_set(session%sehandle,"latmin",getilat(filter%coordmin%geo_coord))
6935ier = idba_set(session%sehandle,"lonmin",getilon(filter%coordmin%geo_coord))
6936ier = idba_set(session%sehandle,"latmax",getilat(filter%coordmax%geo_coord))
6937ier = idba_set(session%sehandle,"lonmax",getilon(filter%coordmax%geo_coord))
6938
6939ier = idba_set(session%sehandle,"ana_filter",filter%ana_filter)
6940ier = idba_set(session%sehandle,"data_filter",filter%data_filter)
6941ier = idba_set(session%sehandle,"attr_filter",filter%attr_filter)
6942
6943ier = idba_set(session%sehandle,"query",filter%query)
6944
6945if (filter%contextana) then
6946
6947 call session%setcontextana()
6948
6949 ier = idba_set(session%sehandle,"varlist",filter%anavarlist)
6950 ier = idba_set(session%sehandle,"*varlist",filter%anastarvarlist)
6951
6952else
6953
6954 if (c_e(filter%datetime%datetime)) call filter%datetime%dbaset(session)
6955 if (c_e(filter%level%vol7d_level)) call filter%level%dbaset(session)
6956 if (c_e(filter%timerange%vol7d_timerange)) call filter%timerange%dbaset(session)
6957
6958 CALL getval(filter%datetimemin%datetime, year=year, month=month, day=day, hour=hour, minute=minute,msec=msec)
6959 if (c_e(msec)) then
6960 sec=nint(float(msec)/1000.)
6961 else
6962 sec=imiss
6963 end if
6964
6965 ier = idba_set(session%sehandle,"yearmin",year)
6966 ier = idba_set(session%sehandle,"monthmin",month)
6967 ier = idba_set(session%sehandle,"daymin",day)
6968 ier = idba_set(session%sehandle,"hourmin",hour)
6969 ier = idba_set(session%sehandle,"minumin",minute)
6970 ier = idba_set(session%sehandle,"secmin",sec)
6971
6972 CALL getval(filter%datetimemax%datetime, year=year, month=month, day=day, hour=hour, minute=minute,msec=msec)
6973
6974 if (c_e(msec)) then
6975 sec=nint(float(msec)/1000.)
6976 else
6977 sec=imiss
6978 end if
6979
6980 ier = idba_set(session%sehandle,"yearmax",year)
6981 ier = idba_set(session%sehandle,"monthmax",month)
6982 ier = idba_set(session%sehandle,"daymax",day)
6983 ier = idba_set(session%sehandle,"hourmax",hour)
6984 ier = idba_set(session%sehandle,"minumax",minute)
6985 ier = idba_set(session%sehandle,"secmax",sec)
6986
6987
6988 ier = idba_set(session%sehandle,"varlist",filter%varlist)
6989 ier = idba_set(session%sehandle,"*varlist",filter%starvarlist)
6990end if
6991
6992end subroutine dbafilter_set
6993
6994
6996type(dbametadata) function dbametadata_contextana(metadata)
6997class(dbametadata), intent(in) :: metadata
6998
6999type (dbadatetime) :: datetime
7000type (dbalevel) :: level
7001type (dbatimerange) :: timerange
7002
7003select type(metadata)
7005 dbametadata_contextana=metadata
7006end select
7007
7008dbametadata_contextana%datetime=datetime%dbacontextana()
7009dbametadata_contextana%level=level%dbacontextana()
7010dbametadata_contextana%timerange=timerange%dbacontextana()
7011
7012end function dbametadata_contextana
7013
7014
7016subroutine dbametaanddata_display(metaanddata)
7017class(dbametaanddata), intent(in) :: metaanddata
7018
7019call metaanddata%metadata%display()
7020call metaanddata%dataattrv%display()
7021
7022end subroutine dbametaanddata_display
7023
7025subroutine dbametaanddata_extrude(metaanddata,session,noattr,filter,attronly,template)
7026class(dbametaanddata), intent(in) :: metaanddata
7027type(dbasession), intent(in) :: session
7028logical, intent(in),optional :: noattr
7029type(dbafilter),intent(in),optional :: filter
7030logical, intent(in),optional :: attronly
7031character(len=*),intent(in),optional :: template
7032
7033type(dbafilter) :: myfilter
7034
7035!print *,"------------------"
7036!call metaanddata%display()
7037!print *,"contextana false"
7038
7039myfilter=dbafilter(filter=filter,contextana=.false.)
7040call extrude(metaanddata,session,noattr,myfilter,attronly,template)
7041
7042!print *,"contextana true"
7043myfilter=dbafilter(filter=filter,contextana=.true.)
7044call extrude(metaanddata,session,noattr,myfilter,attronly,template)
7045
7046contains
7047
7048subroutine extrude(metaanddata,session,noattr,filter,attronly,template)
7049class(dbametaanddata), intent(in) :: metaanddata
7050type(dbasession), intent(in) :: session
7051logical, intent(in),optional :: noattr
7052type(dbafilter),intent(in) :: filter
7053logical, intent(in),optional :: attronly
7054character(len=*),intent(in),optional :: template
7055
7056if (.not. filter == metaanddata%metadata) return
7057
7058call session%unsetall()
7059!write metadata
7060call session%set(metadata=metaanddata%metadata)
7061
7062!write data and attribute
7063!call session%extrude(metaanddata%dataattrv,noattr,filter)
7064call metaanddata%dataattrv%extrude(session,noattr,filter,attronly)
7065
7066!to close message on file
7067call session%close_message(template)
7068
7069end subroutine extrude
7070end subroutine dbametaanddata_extrude
7071
7072
7074subroutine dbametaanddatav_display(metaanddatav)
7075class(dbametaanddatav), intent(in) :: metaanddatav
7076
7077call metaanddatav%metadata%display()
7078call metaanddatav%datav%display()
7079
7080end subroutine dbametaanddatav_display
7081
7083subroutine dbametaanddatav_extrude(metaanddatav,session,noattr,filter,template)
7084class(dbametaanddatav), intent(in) :: metaanddatav
7085type(dbasession), intent(in) :: session
7086logical, intent(in),optional :: noattr
7087type(dbafilter),intent(in),optional :: filter
7088character(len=*),intent(in),optional :: template
7089
7090type(dbafilter) :: myfilter
7091
7092myfilter=dbafilter(filter=filter,contextana=.false.)
7093call extrude(metaanddatav,session,noattr,myfilter,template)
7094
7095myfilter=dbafilter(filter=filter,contextana=.true.)
7096call extrude(metaanddatav,session,noattr,myfilter,template)
7097
7098contains
7099
7100subroutine extrude(metaanddatav,session,noattr,filter,template)
7101class(dbametaanddatav), intent(in) :: metaanddatav
7102type(dbasession), intent(in) :: session
7103logical, intent(in),optional :: noattr
7104type(dbafilter),intent(in) :: filter
7105character(len=*),intent(in),optional :: template
7106
7107if (.not. filter == metaanddatav%metadata)return
7108!write metadata
7109call session%set(metadata=metaanddatav%metadata)
7110
7111!write ana data and attribute
7112!!$call session%set(datav=metaanddatav%datav)
7113call metaanddatav%datav%extrude(session,noattr,filter,template)
7114
7115print*,"dbaana_metaanddatav"
7116!to close message on file
7117call session%close_message(template)
7118
7119end subroutine extrude
7120end subroutine dbametaanddatav_extrude
7121
7122
7124subroutine dbametaanddatal_extrude(metaanddatal,session,noattr,filter,attronly,template)
7125class(dbametaanddatalist), intent(inout) :: metaanddatal
7126class(dbasession), intent(in) :: session
7127logical, intent(in),optional :: noattr
7128type(dbafilter),intent(in),optional :: filter
7129type(dbametaanddata) :: metaanddata
7130logical, intent(in),optional :: attronly
7131character(len=*),intent(in),optional :: template
7132
7133call metaanddatal%rewind()
7134do while(metaanddatal%element())
7135 !call session%extrude(metaanddatal%current(),noattr,filter)
7136 metaanddata=metaanddatal%current()
7137 call metaanddata%extrude(session,noattr,filter,attronly,template)
7138 call metaanddatal%next()
7139end do
7140
7141end subroutine dbametaanddatal_extrude
7142
7143
7145subroutine displaydbametaanddatai(this)
7146class(dbametaanddataiList),intent(inout) :: this
7147type(dbametaanddatai) :: element
7148
7149call this%rewind()
7150do while(this%element())
7151 print *,"index:",this%currentindex()," value:"
7152 element=this%current()
7153 call element%display()
7154 call this%next()
7155end do
7156end subroutine displaydbametaanddatai
7157
7159type(dbametaanddatai) function currentdbametaanddatai(this)
7160class(dbametaanddataiList) :: this
7161class(*), pointer :: v
7162
7163v => this%currentpoli()
7164select type(v)
7166 currentdbametaanddatai = v
7167end select
7168end function currentdbametaanddatai
7169
7170
7172subroutine dbasession_ingest_metaanddatail(session,metaanddatal,filter)
7173class(dbasession), intent(inout) :: session
7174type(dbametaanddatailist), intent(inout) :: metaanddatal
7175type(dbafilter),intent(in),optional :: filter
7176
7177type(dbametaanddatai) :: element
7178
7179
7180if (session%memdb .and. .not. session%loadfile)then
7181
7182 do while (session%messages_read_next())
7183 call session%set(filter=filter)
7184 call session%ingest_metaanddatai()
7185 call session%ingest_metaanddatai(element)
7186 call metaanddatal%append(element)
7187 call session%remove_all()
7188 end do
7189
7190else
7191
7192 call session%set(filter=filter)
7193 call session%ingest_metaanddatai()
7194 do while (c_e(session%count) .and. session%count >0)
7195 call session%ingest_metaanddatai(element)
7196 call metaanddatal%append(element)
7197 if (session%file) call session%ingest()
7198 end do
7199
7200end if
7201
7202end subroutine dbasession_ingest_metaanddatail
7203
7205function toarray_dbametaanddatai(this)
7206type(dbametaanddatai),allocatable :: toarray_dbametaanddatai(:)
7207class(dbametaanddataiList) :: this
7208
7209integer :: i
7210
7211allocate (toarray_dbametaanddatai(this%countelements()))
7212
7213call this%rewind()
7214i=0
7215do while(this%element())
7216 i=i+1
7217 toarray_dbametaanddatai(i) =this%current()
7218 call this%next()
7219end do
7220end function toarray_dbametaanddatai
7221
7222
7224subroutine displaydbametaanddatar(this)
7225class(dbametaanddatarList),intent(inout) :: this
7226type(dbametaanddatar) :: element
7227
7228call this%rewind()
7229do while(this%element())
7230 print *,"index:",this%currentindex()," value:"
7231 element=this%current()
7232 call element%display()
7233 call this%next()
7234end do
7235end subroutine displaydbametaanddatar
7236
7238type(dbametaanddatar) function currentdbametaanddatar(this)
7239class(dbametaanddatarList) :: this
7240class(*), pointer :: v
7241
7242v => this%currentpoli()
7243select type(v)
7245 currentdbametaanddatar = v
7246end select
7247end function currentdbametaanddatar
7248
7249
7251subroutine dbasession_ingest_metaanddatarl(session,metaanddatal,filter)
7252class(dbasession), intent(inout) :: session
7253type(dbametaanddatarlist), intent(inout) :: metaanddatal
7254type(dbafilter),intent(in),optional :: filter
7255
7256type(dbametaanddatar) :: element
7257
7258if (session%memdb .and. .not. session%loadfile)then
7259
7260 do while (session%messages_read_next())
7261 call session%set(filter=filter)
7262 call session%ingest_metaanddatar()
7263 call session%ingest_metaanddatar(element)
7264 call metaanddatal%append(element)
7265 call session%remove_all()
7266 end do
7267
7268else
7269
7270 call session%set(filter=filter)
7271 call session%ingest_metaanddatar()
7272 do while (c_e(session%count) .and. session%count >0)
7273 call session%ingest_metaanddatar(element)
7274 call metaanddatal%append(element)
7275 if (session%file) call session%ingest()
7276 end do
7277
7278end if
7279
7280
7281end subroutine dbasession_ingest_metaanddatarl
7282
7283
7285function toarray_dbametaanddatar(this)
7286type(dbametaanddatar),allocatable :: toarray_dbametaanddatar(:)
7287class(dbametaanddatarList) :: this
7288
7289integer :: i
7290i=this%countelements()
7291!print *, "allocate:",i
7292allocate (toarray_dbametaanddatar(this%countelements()))
7293
7294call this%rewind()
7295i=0
7296do while(this%element())
7297 i=i+1
7298 toarray_dbametaanddatar(i) =this%current()
7299 call this%next()
7300end do
7301end function toarray_dbametaanddatar
7302
7303
7305subroutine displaydbametaanddatad(this)
7306class(dbametaanddatadList),intent(inout) :: this
7307type(dbametaanddatad) :: element
7308
7309call this%rewind()
7310do while(this%element())
7311 print *,"index:",this%currentindex()," value:"
7312 element=this%current()
7313 call element%display()
7314 call this%next()
7315end do
7316end subroutine displaydbametaanddatad
7317
7319type(dbametaanddatad) function currentdbametaanddatad(this)
7320class(dbametaanddatadList) :: this
7321class(*), pointer :: v
7322
7323v => this%currentpoli()
7324select type(v)
7326 currentdbametaanddatad = v
7327end select
7328end function currentdbametaanddatad
7329
7331subroutine dbasession_ingest_metaanddatadl(session,metaanddatal,filter)
7332class(dbasession), intent(inout) :: session
7333type(dbametaanddatadlist), intent(inout) :: metaanddatal
7334type(dbafilter),intent(in),optional :: filter
7335
7336type(dbametaanddatad) :: element
7337
7338if (session%memdb .and. .not. session%loadfile)then
7339
7340 do while (session%messages_read_next())
7341 call session%set(filter=filter)
7342 call session%ingest_metaanddatad()
7343 call session%ingest_metaanddatad(element)
7344 call metaanddatal%append(element)
7345 call session%remove_all()
7346 end do
7347
7348else
7349
7350 call session%set(filter=filter)
7351 call session%ingest_metaanddatad()
7352 do while (c_e(session%count) .and. session%count >0)
7353 call session%ingest_metaanddatad(element)
7354 call metaanddatal%append(element)
7355 if (session%file) call session%ingest()
7356 end do
7357
7358end if
7359
7360end subroutine dbasession_ingest_metaanddatadl
7361
7362
7364function toarray_dbametaanddatad(this)
7365type(dbametaanddatad),allocatable :: toarray_dbametaanddatad(:)
7366class(dbametaanddatadList) :: this
7367
7368integer :: i
7369
7370allocate (toarray_dbametaanddatad(this%countelements()))
7371
7372call this%rewind()
7373i=0
7374do while(this%element())
7375 i=i+1
7376 toarray_dbametaanddatad(i) =this%current()
7377 call this%next()
7378end do
7379end function toarray_dbametaanddatad
7380
7381
7383subroutine displaydbametaanddatab(this)
7384class(dbametaanddatabList),intent(inout) :: this
7385type(dbametaanddatab) :: element
7386
7387call this%rewind()
7388do while(this%element())
7389 print *,"index:",this%currentindex()," value:"
7390 element=this%current()
7391 call element%display()
7392 call this%next()
7393end do
7394end subroutine displaydbametaanddatab
7395
7397type(dbametaanddatab) function currentdbametaanddatab(this)
7398class(dbametaanddatabList) :: this
7399class(*), pointer :: v
7400
7401v => this%currentpoli()
7402select type(v)
7404 currentdbametaanddatab = v
7405end select
7406end function currentdbametaanddatab
7407
7408
7410subroutine dbasession_ingest_metaanddatabl(session,metaanddatal,filter)
7411class(dbasession), intent(inout) :: session
7412type(dbametaanddatablist), intent(inout) :: metaanddatal
7413type(dbafilter),intent(in),optional :: filter
7414
7415type(dbametaanddatab) :: element
7416
7417if (session%memdb .and. .not. session%loadfile)then
7418
7419 do while (session%messages_read_next())
7420 call session%set(filter=filter)
7421 call session%ingest_metaanddatab()
7422 call session%ingest_metaanddatab(element)
7423 call metaanddatal%append(element)
7424 call session%remove_all()
7425 end do
7426
7427else
7428
7429 call session%set(filter=filter)
7430 call session%ingest_metaanddatab()
7431 do while (c_e(session%count) .and. session%count >0)
7432 call session%ingest_metaanddatab(element)
7433 call metaanddatal%append(element)
7434 if (session%file) call session%ingest()
7435 end do
7436
7437end if
7438
7439end subroutine dbasession_ingest_metaanddatabl
7440
7441
7443function toarray_dbametaanddatab(this)
7444type(dbametaanddatab),allocatable :: toarray_dbametaanddatab(:)
7445class(dbametaanddatabList) :: this
7446
7447integer :: i
7448
7449allocate (toarray_dbametaanddatab(this%countelements()))
7450
7451call this%rewind()
7452i=0
7453do while(this%element())
7454 i=i+1
7455 toarray_dbametaanddatab(i) =this%current()
7456 call this%next()
7457end do
7458end function toarray_dbametaanddatab
7459
7460
7462subroutine displaydbametaanddatac(this)
7463class(dbametaanddatacList),intent(inout) :: this
7464type(dbametaanddatac) :: element
7465
7466call this%rewind()
7467do while(this%element())
7468 print *,"index:",this%currentindex()," value:"
7469 element=this%current()
7470 call element%display()
7471 call this%next()
7472end do
7473end subroutine displaydbametaanddatac
7474
7476type(dbametaanddatac) function currentdbametaanddatac(this)
7477class(dbametaanddatacList) :: this
7478class(*), pointer :: v
7479
7480v => this%currentpoli()
7481select type(v)
7483 currentdbametaanddatac = v
7484end select
7485end function currentdbametaanddatac
7486
7487
7489subroutine dbasession_ingest_metaanddatacl(session,metaanddatal,filter)
7490class(dbasession), intent(inout) :: session
7491type(dbametaanddataclist), intent(inout) :: metaanddatal
7492type(dbafilter),intent(in),optional :: filter
7493
7494type(dbametaanddatac) :: element
7495
7496if (session%memdb .and. .not. session%loadfile)then
7497
7498 do while (session%messages_read_next())
7499 call session%set(filter=filter)
7500 call session%ingest_metaanddatac()
7501 call session%ingest_metaanddatac(element)
7502 call metaanddatal%append(element)
7503 call session%remove_all()
7504 end do
7505
7506else
7507
7508 call session%set(filter=filter)
7509 call session%ingest_metaanddatac()
7510 do while (c_e(session%count) .and. session%count >0)
7511 call session%ingest_metaanddatac(element)
7512 call metaanddatal%append(element)
7513 if (session%file) call session%ingest()
7514 end do
7515
7516end if
7517
7518end subroutine dbasession_ingest_metaanddatacl
7519
7520
7522function toarray_dbametaanddatac(this)
7523type(dbametaanddatac),allocatable :: toarray_dbametaanddatac(:)
7524class(dbametaanddatacList) :: this
7525
7526integer :: i
7527
7528allocate (toarray_dbametaanddatac(this%countelements()))
7529
7530call this%rewind()
7531i=0
7532do while(this%element())
7533 i=i+1
7534 toarray_dbametaanddatac(i) =this%current()
7535 call this%next()
7536end do
7537end function toarray_dbametaanddatac
7538
7539
7541subroutine dbametaanddatai_display(data)
7542class(dbametaanddatai), intent(in) :: data
7543
7544call data%metadata%display()
7545call data%dbadatai%display()
7546
7547end subroutine dbametaanddatai_display
7548
7550subroutine dbametaanddatab_display(data)
7551class(dbametaanddatab), intent(in) :: data
7552
7553call data%metadata%display()
7554call data%dbadatab%display()
7555
7556end subroutine dbametaanddatab_display
7557
7559subroutine dbametaanddatad_display(data)
7560class(dbametaanddatad), intent(in) :: data
7561
7562call data%metadata%display()
7563call data%dbadatad%display()
7564
7565end subroutine dbametaanddatad_display
7566
7568subroutine dbametaanddatar_display(data)
7569class(dbametaanddatar), intent(in) :: data
7570
7571call data%metadata%display()
7572call data%dbadatar%display()
7573
7574end subroutine dbametaanddatar_display
7575
7576
7578subroutine dbametaanddatac_display(data)
7579class(dbametaanddatac), intent(in) :: data
7580
7581call data%metadata%display()
7582call data%dbadatac%display()
7583
7584end subroutine dbametaanddatac_display
7585
7586
7588subroutine dbametaanddatai_extrude(metaanddatai,session)
7589class(dbametaanddatai), intent(in) :: metaanddatai
7590type(dbasession), intent(in) :: session
7591
7592call session%unsetall()
7593!write metadata
7594call session%set(metadata=metaanddatai%metadata)
7595!write ana data and attribute
7596call session%set(data=metaanddatai%dbadatai)
7597
7598if (metaanddatai%dbadatai%c_e()) then
7599 call session%prendilo()
7600else
7601 call session%dimenticami()
7602endif
7603
7604end subroutine dbametaanddatai_extrude
7605
7607subroutine dbametaanddatab_extrude(metaanddatab,session)
7608class(dbametaanddatab), intent(in) :: metaanddatab
7609type(dbasession), intent(in) :: session
7610
7611call session%unsetall()
7612!write metadata
7613call session%set(metadata=metaanddatab%metadata)
7614!write ana data and attribute
7615call session%set(data=metaanddatab%dbadatab)
7616
7617if (metaanddatab%dbadatab%c_e()) then
7618 call session%prendilo()
7619else
7620 call session%dimenticami()
7621endif
7622
7623end subroutine dbametaanddatab_extrude
7624
7626subroutine dbametaanddatad_extrude(metaanddatad,session)
7627class(dbametaanddatad), intent(in) :: metaanddatad
7628type(dbasession), intent(in) :: session
7629
7630call session%unsetall()
7631!write metadata
7632call session%set(metadata=metaanddatad%metadata)
7633!write ana data and attribute
7634call session%set(data=metaanddatad%dbadatad)
7635
7636if (metaanddatad%dbadatad%c_e()) then
7637 call session%prendilo()
7638else
7639 call session%dimenticami()
7640endif
7641
7642end subroutine dbametaanddatad_extrude
7643
7645subroutine dbametaanddatar_extrude(metaanddatar,session)
7646class(dbametaanddatar), intent(in) :: metaanddatar
7647type(dbasession), intent(in) :: session
7648
7649call session%unsetall()
7650!write metadata
7651call session%set(metadata=metaanddatar%metadata)
7652!write ana data and attribute
7653call session%set(data=metaanddatar%dbadatar)
7654
7655if (metaanddatar%dbadatar%c_e()) then
7656 call session%prendilo()
7657else
7658 call session%dimenticami()
7659endif
7660
7661end subroutine dbametaanddatar_extrude
7662
7664subroutine dbametaanddatac_extrude(metaanddatac,session)
7665class(dbametaanddatac), intent(in) :: metaanddatac
7666type(dbasession), intent(in) :: session
7667
7668call session%unsetall()
7669!write metadata
7670call session%set(metadata=metaanddatac%metadata)
7671!write ana data and attribute
7672call session%set(data=metaanddatac%dbadatac)
7673
7674if (metaanddatac%dbadatac%c_e()) then
7675 call session%prendilo()
7676else
7677 call session%dimenticami()
7678endif
7679
7680end subroutine dbametaanddatac_extrude
7681
7683subroutine dbasession_ingest_ana(session,ana)
7684class(dbasession), intent(inout) :: session
7685type(dbaana), intent(out),optional :: ana
7686
7687integer :: ier
7688
7689if (.not. present(ana)) then
7690 ier = idba_quantesono(session%sehandle, session%count)
7691 !print *,"numero ana",session%count
7692else
7693 ier = idba_elencamele(session%sehandle)
7694 call ana%dbaenq(session)
7695 session%count=session%count-1
7696end if
7697
7698end subroutine dbasession_ingest_ana
7699
7700
7702subroutine dbasession_ingest_anav(session,anav)
7703class(dbasession), intent(inout) :: session
7704type(dbaana), intent(out),allocatable :: anav(:)
7705integer :: i
7706
7707call session%ingest_ana()
7708
7709if (c_e(session%count)) then
7710 allocate(anav(session%count))
7711 i=0
7712 do while (session%count >0)
7713 i=i+1
7714 call session%ingest_ana(anav(i))
7715 end do
7716else
7717 allocate(anav(0))
7718end if
7719
7720end subroutine dbasession_ingest_anav
7721
7722
7724subroutine dbasession_ingest_anal(session,anal)
7725class(dbasession), intent(inout) :: session
7726type(dbaanalist), intent(out) :: anal
7727type(dbaana) :: element
7728
7729call session%ingest_ana()
7730do while (c_e(session%count) .and. session%count >0)
7731 call session%ingest_ana(element)
7732 call anal%append(element)
7733 call session%ingest_ana()
7734end do
7735end subroutine dbasession_ingest_anal
7736
7737
7739subroutine dbasession_ingest_metaanddata(session,metaanddata,noattr,filter)
7740class(dbasession), intent(inout) :: session
7741type(dbametaanddata), intent(inout),optional :: metaanddata
7742logical,intent(in),optional :: noattr
7743type(dbafilter),intent(in),optional :: filter
7744
7745type(dbametadata) :: metadata
7746integer :: ier,acount,i,j,k
7747character(len=9) :: btable
7748character(255) :: value
7749logical :: lvars,lstarvars
7750type(dbadcv) :: vars,starvars
7751
7752
7753 ! if you do not pass metaanddata we presume to have to initialize the query
7754if (.not. present(metaanddata)) then
7755 ier = idba_voglioquesto(session%sehandle, session%count)
7756
7757 ! preroll one read because after I have to read one more to check metadata
7758 if (c_e(session%count) .and. session%count > 0) then
7759 ier = idba_dammelo(session%sehandle, btable)
7760 end if
7761
7762else
7763
7764 ! you pass metaanddata so we continue with the query
7765
7766 if (allocated(metaanddata%dataattrv%dataattr)) then
7767 deallocate (metaanddata%dataattrv%dataattr)
7768 end if
7769
7770 lvars=.false.
7771 lstarvars=.false.
7772 if (present(filter)) then
7773
7774 if (filter%contextana) then
7775
7776 !todo try to use this: vars=filter%anavars
7777 if (allocated(filter%anavars%dcv)) then
7778 lvars=.true.
7779 allocate(vars%dcv(size(filter%anavars%dcv)))
7780 do i =1,size(filter%anavars%dcv)
7781 allocate(vars%dcv(i)%dat,source=filter%anavars%dcv(i)%dat)
7782 end do
7783 end if
7784
7785 if (allocated(filter%anastarvars%dcv)) then
7786 lstarvars=.true.
7787 allocate(starvars%dcv(size(filter%anastarvars%dcv)))
7788 do i =1,size(filter%anastarvars%dcv)
7789 allocate(starvars%dcv(i)%dat,source=filter%anastarvars%dcv(i)%dat)
7790 end do
7791 end if
7792
7793 else
7794
7795 if (allocated(filter%vars%dcv)) then
7796 lvars=.true.
7797 allocate(vars%dcv(size(filter%vars%dcv)))
7798 do i =1,size(filter%vars%dcv)
7799 allocate(vars%dcv(i)%dat,source=filter%vars%dcv(i)%dat)
7800 end do
7801 end if
7802
7803 if (allocated(filter%starvars%dcv)) then
7804 lstarvars=.true.
7805 allocate(starvars%dcv(size(filter%starvars%dcv)))
7806 do i =1,size(filter%starvars%dcv)
7807 allocate(starvars%dcv(i)%dat,source=filter%starvars%dcv(i)%dat)
7808 end do
7809 end if
7810
7811 end if
7812
7813 end if
7814
7815 if (lvars) then
7816
7817 ! create an empty vector for data
7818 allocate (metaanddata%dataattrv%dataattr(size(vars%dcv)))
7819 do i = 1, size(vars%dcv)
7820 allocate (metaanddata%dataattrv%dataattr(i)%dat,source=vars%dcv(i)%dat)
7821 end do
7822
7823 ! load metadata
7824 call metaanddata%metadata%dbaenq(session)
7825 ! load curret metadata
7826 call metadata%dbaenq(session)
7827
7828 ! if current metadata is equal to metadata
7829 do while ( metaanddata%metadata == metadata )
7830 ier = idba_enq(session%sehandle,"var",btable)
7831 do i=1,size(metaanddata%dataattrv%dataattr)
7832 if (metaanddata%dataattrv%dataattr(i)%dat%btable == btable) then
7833
7834 select type ( dat => metaanddata%dataattrv%dataattr(i)%dat )
7836 ier = idba_enq(session%sehandle, btable,dat%value)
7838 ier = idba_enq(session%sehandle, btable,dat%value)
7840 ier = idba_enq(session%sehandle, btable,dat%value)
7842 ier = idba_enq(session%sehandle, btable,dat%value)
7844 ier = idba_enq(session%sehandle, btable,dat%value)
7845 end select
7846
7847 if (optio_log(noattr))then
7848 ! initialize to (0) the attribute vector
7849 allocate (metaanddata%dataattrv%dataattr(i)%attrv%dcv(0))
7850
7851 else
7852
7853 if (lstarvars) then
7854
7855 allocate (metaanddata%dataattrv%dataattr(i)%attrv%dcv(size(starvars%dcv)))
7856 do j = 1, size(starvars%dcv)
7857 allocate (metaanddata%dataattrv%dataattr(i)%attrv%dcv(j)%dat,source=starvars%dcv(j)%dat)
7858 end do
7859
7860 if (c_e(session%count) .and. session%count > 0) then
7861
7862 ier = idba_voglioancora(session%sehandle, acount)
7863 do k =1,acount
7864 ier = idba_ancora(session%sehandle, btable)
7865 ier = idba_enq(session%sehandle, btable,value)
7866
7867 do j=1,size(metaanddata%dataattrv%dataattr(i)%attrv%dcv)
7868
7869 if (metaanddata%dataattrv%dataattr(i)%attrv%dcv(j)%dat%btable == btable) then
7870
7871 select type ( dat => metaanddata%dataattrv%dataattr(i)%attrv%dcv(j)%dat )
7873 ier = idba_enq(session%sehandle, btable,dat%value)
7875 ier = idba_enq(session%sehandle, btable,dat%value)
7877 ier = idba_enq(session%sehandle, btable,dat%value)
7879 ier = idba_enq(session%sehandle, btable,dat%value)
7881 ier = idba_enq(session%sehandle, btable,dat%value)
7882 end select
7883
7884 end if
7885 end do
7886 end do
7887 end if
7888 else
7889 if (c_e(session%count) .and. session%count > 0) then
7890 ier = idba_voglioancora(session%sehandle, acount)
7891
7892 allocate (metaanddata%dataattrv%dataattr(i)%attrv%dcv(acount))
7893 do j =1,acount
7894 ier = idba_ancora(session%sehandle, btable)
7895 ier = idba_enq(session%sehandle, btable,value)
7897 end do
7898 else
7899 allocate (metaanddata%dataattrv%dataattr(i)%attrv%dcv(0))
7900 end if
7901 end if
7902 end if
7903 end if
7904 end do
7905
7906 if (c_e(session%count)) session%count=session%count-1
7907
7908 if (c_e(session%count) .and. session%count > 0 ) then
7909 ier = idba_dammelo(session%sehandle, btable)
7910 call metadata%dbaenq(session)
7911 else
7912 metadata=dbametadata()
7913 end if
7914 end do
7915 else
7916
7917 allocate (metaanddata%dataattrv%dataattr(1))
7918 ier = idba_enq(session%sehandle,"var",btable)
7919 ier = idba_enq(session%sehandle, btable,value)
7921 call metaanddata%metadata%dbaenq(session)
7922
7923
7924 if (optio_log(noattr))then
7925
7926 allocate (metaanddata%dataattrv%dataattr(1)%attrv%dcv(0))
7927
7928 else
7929
7930 if (lstarvars) then
7931
7932 allocate (metaanddata%dataattrv%dataattr(1)%attrv%dcv(size(starvars%dcv)))
7933 do j = 1, size(starvars%dcv)
7934 allocate (metaanddata%dataattrv%dataattr(1)%attrv%dcv(j)%dat,source=starvars%dcv(j)%dat)
7935 end do
7936
7937 if (c_e(session%count) .and. session%count > 0) then
7938
7939 ier = idba_voglioancora(session%sehandle, acount)
7940 do k =1,acount
7941 ier = idba_ancora(session%sehandle, btable)
7942 ier = idba_enq(session%sehandle, btable,value)
7943
7944 do j=1,size(metaanddata%dataattrv%dataattr(1)%attrv%dcv)
7945
7946 if (metaanddata%dataattrv%dataattr(1)%attrv%dcv(j)%dat%btable == btable) then
7947
7948 select type ( dat => metaanddata%dataattrv%dataattr(1)%attrv%dcv(j)%dat )
7950 ier = idba_enq(session%sehandle, btable,dat%value)
7952 ier = idba_enq(session%sehandle, btable,dat%value)
7954 ier = idba_enq(session%sehandle, btable,dat%value)
7956 ier = idba_enq(session%sehandle, btable,dat%value)
7958 ier = idba_enq(session%sehandle, btable,dat%value)
7959 end select
7960
7961 end if
7962 end do
7963 end do
7964 end if
7965 else
7966 if (c_e(session%count) .and. session%count > 0) then
7967 ier = idba_voglioancora(session%sehandle, acount)
7968
7969 allocate (metaanddata%dataattrv%dataattr(1)%attrv%dcv(acount))
7970 do j =1,acount
7971 ier = idba_ancora(session%sehandle, btable)
7972 ier = idba_enq(session%sehandle, btable,value)
7974 end do
7975 else
7976 allocate (metaanddata%dataattrv%dataattr(1)%attrv%dcv(0))
7977 end if
7978 end if
7979 end if
7980
7981 if (c_e(session%count)) then
7982 session%count=session%count-1
7983
7984 if (session%count > 0 ) then
7985 ier = idba_dammelo(session%sehandle, btable)
7986 end if
7987 end if
7988 end if
7989!!$ SOLVED by https://github.com/ARPA-SIMC/dballe/issues/73
7990!!$ !reading from file get some variable not in filter so we can have some attrv%dcv not allocated
7991 do i=1,size(metaanddata%dataattrv%dataattr)
7992 if (.not.allocated(metaanddata%dataattrv%dataattr(i)%attrv%dcv)) then
7993 allocate (metaanddata%dataattrv%dataattr(i)%attrv%dcv(0))
7994 endif
7995 end do
7996
7997end if
7998
7999end subroutine dbasession_ingest_metaanddata
8000
8001
8003subroutine dbasession_ingest_metaanddatav(session,metaanddatav,noattr,filter)
8004class(dbasession), intent(inout) :: session
8005type(dbametaanddata), intent(inout),allocatable :: metaanddatav(:)
8006logical, intent(in),optional :: noattr
8007type(dbafilter),intent(in),optional :: filter
8008
8009type(dbametaanddata),allocatable :: metaanddatavbuf(:)
8010integer :: i
8011
8012!todo aggiungere anche altrove dove passato filter
8013if (present(filter)) then
8014 call filter%dbaset(session)
8015else
8016 call session%unsetall()
8017endif
8018
8019call session%ingest()
8020!print*," count: ",session%count
8021
8022if (c_e(session%count)) then
8023 ! allocate to max dimension
8024 allocate(metaanddatavbuf(session%count))
8025 i=0
8026 do while (session%count >0)
8027 i=i+1
8028 call session%ingest(metaanddatavbuf(i),noattr=noattr,filter=filter)
8029 end do
8030
8031! compact data to real dimension
8032 IF (SIZE(metaanddatavbuf) == i) THEN
8033! space/time optimization in common case of no filter
8034 CALL move_alloc(metaanddatavbuf, metaanddatav)
8035 ELSE
8036! allocate (metaanddatav(i))
8037 metaanddatav=metaanddatavbuf(:i)
8038 DEALLOCATE(metaanddatavbuf)
8039 ENDIF
8040
8041else
8042 if (allocated(metaanddatav)) deallocate(metaanddatav)
8043 allocate(metaanddatav(0))
8044end if
8045
8046
8047end subroutine dbasession_ingest_metaanddatav
8048
8049
8051subroutine dbasession_ingest_metaanddatal(session,metaanddatal,noattr,filter)
8052class(dbasession), intent(inout) :: session
8053type(dbametaanddatalist), intent(out) :: metaanddatal
8054logical, intent(in),optional :: noattr
8055type(dbafilter),intent(in),optional :: filter
8056
8057type(dbametaanddata),allocatable :: metaanddatavbuf(:)
8058integer :: i
8059
8060if (session%memdb .and. .not. session%loadfile)then
8061
8062 do while (session%messages_read_next())
8063 call session%set(filter=filter)
8064 call session%ingest()
8065 call session%ingest(metaanddatavbuf,noattr=noattr,filter=filter)
8066 do i=1,size(metaanddatavbuf)
8067 call metaanddatal%append(metaanddatavbuf(i))
8068 end do
8069
8070 call session%remove_all()
8071 deallocate (metaanddatavbuf)
8072 end do
8073
8074else
8075
8076 call session%ingest()
8077
8078 do while (c_e(session%count) .and. session%count >0)
8079 call session%ingest(metaanddatavbuf,noattr=noattr,filter=filter)
8080 do i=1,size(metaanddatavbuf)
8081 if (present(filter)) then
8082 ! exclude contextana data from file
8083 if (filter%contextana) then
8084 if (datetime_new() /= metaanddatavbuf(i)%metadata%datetime%datetime) cycle
8085 end if
8086 end if
8087 call metaanddatal%append(metaanddatavbuf(i))
8088 end do
8089 if (session%file) call session%ingest()
8090 deallocate (metaanddatavbuf)
8091 end do
8092end if
8093
8094end subroutine dbasession_ingest_metaanddatal
8095
8097subroutine dbasession_ingest_metaanddatai(session,metaanddata)
8098class(dbasession), intent(inout) :: session
8099type(dbametaanddatai), intent(inout),optional :: metaanddata
8100
8101integer :: ier
8102character(len=9) :: btable
8103integer :: value
8104
8105if (.not. present(metaanddata)) then
8106 ier = idba_voglioquesto(session%sehandle, session%count)
8107else
8108 ier = idba_dammelo(session%sehandle, btable)
8109 ier = idba_enq(session%sehandle, btable,value)
8111 call metaanddata%metadata%dbaenq(session)
8112 session%count=session%count-1
8113end if
8114end subroutine dbasession_ingest_metaanddatai
8115
8116
8118subroutine dbasession_ingest_metaanddataiv(session,metaanddatav)
8119class(dbasession), intent(inout) :: session
8120type(dbametaanddatai), intent(inout),allocatable :: metaanddatav(:)
8121
8122integer :: i
8123
8124call session%ingest_metaanddatai()
8125if (c_e(session%count)) then
8126 allocate(metaanddatav(session%count))
8127 i=0
8128 do while (session%count >0)
8129 i=i+1
8130 call session%ingest_metaanddatai(metaanddatav(i))
8131 end do
8132else
8133 allocate(metaanddatav(0))
8134end if
8135
8136end subroutine dbasession_ingest_metaanddataiv
8137
8138
8140subroutine dbasession_ingest_metaanddatab(session,metaanddata)
8141class(dbasession), intent(inout) :: session
8142type(dbametaanddatab), intent(inout),optional :: metaanddata
8143
8144integer :: ier
8145character(len=9) :: btable
8146integer(kind=int_b) :: value
8147
8148if (.not. present(metaanddata)) then
8149 ier = idba_voglioquesto(session%sehandle, session%count)
8150else
8151 ier = idba_dammelo(session%sehandle, btable)
8152 ier = idba_enq(session%sehandle, btable,value)
8154 call metaanddata%metadata%dbaenq(session)
8155 session%count=session%count-1
8156end if
8157end subroutine dbasession_ingest_metaanddatab
8158
8159
8161subroutine dbasession_ingest_metaanddatabv(session,metaanddatav)
8162class(dbasession), intent(inout) :: session
8163type(dbametaanddatab), intent(inout),allocatable :: metaanddatav(:)
8164
8165integer :: i
8166
8167call session%ingest_metaanddatab()
8168if (c_e(session%count)) then
8169 allocate(metaanddatav(session%count))
8170 i=0
8171 do while (session%count >0)
8172 i=i+1
8173 call session%ingest_metaanddatab(metaanddatav(i))
8174 end do
8175else
8176 allocate(metaanddatav(0))
8177end if
8178
8179end subroutine dbasession_ingest_metaanddatabv
8180
8181
8183subroutine dbasession_ingest_metaanddatad(session,metaanddata)
8184class(dbasession), intent(inout) :: session
8185type(dbametaanddatad), intent(inout),optional :: metaanddata
8186
8187integer :: ier
8188character(len=9) :: btable
8189doubleprecision :: value
8190
8191if (.not. present(metaanddata)) then
8192 ier = idba_voglioquesto(session%sehandle, session%count)
8193else
8194 ier = idba_dammelo(session%sehandle, btable)
8195 ier = idba_enq(session%sehandle, btable,value)
8197 call metaanddata%metadata%dbaenq(session)
8198 session%count=session%count-1
8199end if
8200end subroutine dbasession_ingest_metaanddatad
8201
8202
8204subroutine dbasession_ingest_metaanddatadv(session,metaanddatav)
8205class(dbasession), intent(inout) :: session
8206type(dbametaanddatad), intent(inout),allocatable :: metaanddatav(:)
8207
8208integer :: i
8209
8210call session%ingest_metaanddatad()
8211if (c_e(session%count)) then
8212 allocate(metaanddatav(session%count))
8213 i=0
8214 do while (session%count >0)
8215 i=i+1
8216 call session%ingest_metaanddatad(metaanddatav(i))
8217 end do
8218else
8219 allocate(metaanddatav(0))
8220end if
8221end subroutine dbasession_ingest_metaanddatadv
8222
8223
8225subroutine dbasession_ingest_metaanddatar(session,metaanddata)
8226class(dbasession), intent(inout) :: session
8227type(dbametaanddatar), intent(inout),optional :: metaanddata
8228
8229integer :: ier
8230character(len=9) :: btable
8231real :: value
8232
8233if (.not. present(metaanddata)) then
8234 ier = idba_voglioquesto(session%sehandle, session%count)
8235else
8236 ier = idba_dammelo(session%sehandle, btable)
8237 ier = idba_enq(session%sehandle, btable,value)
8239 call metaanddata%metadata%dbaenq(session)
8240 session%count=session%count-1
8241end if
8242end subroutine dbasession_ingest_metaanddatar
8243
8244
8246subroutine dbasession_ingest_metaanddatarv(session,metaanddatav)
8247class(dbasession), intent(inout) :: session
8248type(dbametaanddatar), intent(inout),allocatable :: metaanddatav(:)
8249
8250integer :: i
8251
8252call session%ingest_metaanddatar()
8253if (c_e(session%count)) then
8254 allocate(metaanddatav(session%count))
8255 i=0
8256 do while (session%count >0)
8257 i=i+1
8258 call session%ingest_metaanddatar(metaanddatav(i))
8259 end do
8260else
8261 allocate(metaanddatav(0))
8262end if
8263end subroutine dbasession_ingest_metaanddatarv
8264
8265
8266
8268subroutine dbasession_ingest_metaanddatac(session,metaanddata)
8269class(dbasession), intent(inout) :: session
8270type(dbametaanddatac), intent(inout),optional :: metaanddata
8271
8272integer :: ier
8273character(len=9) :: btable
8274character(len=255) :: value
8275
8276if (.not. present(metaanddata)) then
8277 ier = idba_voglioquesto(session%sehandle, session%count)
8278else
8279 ier = idba_dammelo(session%sehandle, btable)
8280 ier = idba_enq(session%sehandle, btable,value)
8282 call metaanddata%metadata%dbaenq(session)
8283 session%count=session%count-1
8284end if
8285end subroutine dbasession_ingest_metaanddatac
8286
8287
8289subroutine dbasession_ingest_metaanddatacv(session,metaanddatav)
8290class(dbasession), intent(inout) :: session
8291type(dbametaanddatac), intent(inout),allocatable :: metaanddatav(:)
8292
8293integer :: i
8294
8295call session%ingest_metaanddatac()
8296if (c_e(session%count)) then
8297 allocate(metaanddatav(session%count))
8298 i=0
8299 do while (session%count >0)
8300 i=i+1
8301 call session%ingest_metaanddatac(metaanddatav(i))
8302 end do
8303else
8304 allocate(metaanddatav(session%count))
8305end if
8306end subroutine dbasession_ingest_metaanddatacv
8307
8310type(dbaconnection) function dbaconnection_init(dsn, user, password,categoryappend,idbhandle)
8311character (len=*), intent(in), optional :: dsn
8312character (len=*), intent(in), optional :: user
8313character (len=*), intent(in), optional :: password
8314character(len=*),INTENT(in),OPTIONAL :: categoryappend
8315integer,INTENT(in),OPTIONAL :: idbhandle
8316
8317integer :: ier
8318character(len=512) :: a_name,quidsn
8319
8320if (present(categoryappend))then
8321 call l4f_launcher(a_name,a_name_append=trim(subcategory)//"."//trim(categoryappend))
8322else
8323 call l4f_launcher(a_name,a_name_append=trim(subcategory))
8324endif
8325dbaconnection_init%category=l4f_category_get(a_name)
8326
8327! impostiamo la gestione dell'errore
8328ier=idba_error_set_callback(0,c_funloc(dballe_error_handler), &
8329 dbaconnection_init%category,dbaconnection_init%handle_err)
8330if (.not. c_e(optio_i(idbhandle))) then
8331
8332 quidsn = "test"
8333 IF (PRESENT(dsn)) THEN
8334 IF (c_e(dsn)) quidsn = dsn
8335 ENDIF
8336
8337 ier=idba_presentati(dbaconnection_init%dbhandle,quidsn)
8338else
8339 dbaconnection_init%dbhandle=optio_i(idbhandle)
8340end if
8341
8342end function dbaconnection_init
8343
8345subroutine dbaconnection_delete(handle)
8346#ifdef F2003_FULL_FEATURES
8347type (dbaconnection), intent(inout) :: handle
8348#else
8350#endif
8351
8352integer :: ier
8353
8354if (c_e(handle%dbhandle)) then
8355 ier = idba_arrivederci(handle%dbhandle)
8356 ier = idba_error_remove_callback(handle%handle_err)
8357end if
8358
8359end subroutine dbaconnection_delete
8360
8363recursive type(dbasession) function dbasession_init(connection,anaflag, dataflag, attrflag,&
8364 filename,mode,format,template,write,wipe,repinfo,simplified,memdb,loadfile,categoryappend)
8365type(dbaconnection),intent(in),optional :: connection
8366character (len=*), intent(in), optional :: anaflag
8367character (len=*), intent(in), optional :: dataflag
8368character (len=*), intent(in), optional :: attrflag
8369character (len=*), intent(in), optional :: filename
8370character (len=*), intent(in), optional :: mode
8371character (len=*), intent(in), optional :: template
8372logical,INTENT(in),OPTIONAL :: write
8373logical,INTENT(in),OPTIONAL :: wipe
8374character(len=*), INTENT(in),OPTIONAL :: repinfo
8375character(len=*),intent(in),optional :: format
8376logical,intent(in),optional :: simplified
8377logical,intent(in),optional :: memdb
8378logical,intent(in),optional :: loadfile
8379character(len=*),INTENT(in),OPTIONAL :: categoryappend
8380
8381integer :: ier
8382character (len=5) :: lanaflag,ldataflag,lattrflag
8383character (len=1) :: lmode
8384logical :: lwrite,lwipe
8385character(len=255) :: lrepinfo
8386character(len=40) :: lformat
8387logical :: exist,lsimplified,read_next,lfile,lmemdb,lloadfile
8388character(len=512) :: a_name
8389character(len=40) :: ltemplate
8390
8391! those are assigned by the default constructor?
8392!!$dbasession_init%sehandle=imiss
8393!!$dbasession_init%file=.false.
8394!!$dbasession_init%template=cmiss
8395!!$dbasession_init%count=imiss
8396
8397if (present(categoryappend))then
8398 call l4f_launcher(a_name,a_name_append=trim(subcategory)//"."//trim(categoryappend))
8399else
8400 call l4f_launcher(a_name,a_name_append=trim(subcategory))
8401endif
8402dbasession_init%category=l4f_category_get(a_name)
8403
8404
8405lwrite=.false.
8406if (present(write))then
8407 lwrite=write
8408endif
8409
8410lwipe=.false.
8411lrepinfo=""
8412if (present(wipe))then
8413 lwipe=wipe
8414 if (present(repinfo))then
8415 lrepinfo=repinfo
8416 endif
8417endif
8418
8419lmemdb=.false.
8420lloadfile=.false.
8421lfile=.false.
8422
8423if (present(template))then
8424 ltemplate=template
8425else
8426 ltemplate=cmiss
8427endif
8428
8429lsimplified=.true.
8430if (present(simplified))then
8431 lsimplified=simplified
8432end if
8433
8434lformat="BUFR"
8435if (present(format))then
8436 lformat=format
8437end if
8438
8439lmode="r"
8440
8441if (present(filename)) then
8442
8443 lfile=.true.
8444
8445 IF (filename == '') THEN
8446! if stdio do not check existence, stdin always exist, stdout never exist
8447 exist = .NOT.lwrite
8448 ELSE
8449 INQUIRE(file=filename,exist=exist)
8450 ENDIF
8451
8452 if (lwrite)then
8453 if (lwipe.or..not.exist) then
8454 lmode="w"
8455 else
8456 lmode="a"
8457 call l4f_category_log(dbasession_init%category,l4f_info,"file exists; appending data to file")
8458 end if
8459 else
8460 if (.not.exist) then
8461 call l4f_category_log(dbasession_init%category,l4f_error,"file does not exist; cannot open file for read")
8462 CALL raise_fatal_error()
8463 end if
8464 end if
8465
8466 if (present(mode)) lmode = mode
8467
8468 if (.not.present(memdb))then
8469 dbasession_init%memdb=.true. ! default with filename
8470 end if
8471
8472 if (.not.present(loadfile))then
8473 dbasession_init%loadfile=.true. ! default with filename
8474 end if
8475
8476end if
8477
8478if (present(memdb))then
8479 lmemdb=memdb
8480end if
8481
8482if (present(loadfile))then
8483 lloadfile=loadfile
8484end if
8485
8486
8487call optio(anaflag,lanaflag)
8488if (.not. c_e(lanaflag))then
8489 if (lwrite) then
8490 lanaflag = "write"
8491 else
8492 lanaflag = "read"
8493 end if
8494end if
8495
8496call optio(dataflag,ldataflag)
8497if (.not. c_e(ldataflag)) then
8498 if (lwrite) then
8499 ldataflag = "write"
8500 else
8501 ldataflag = "read"
8502 end if
8503end if
8504
8505call optio(attrflag,lattrflag)
8506if (.not. c_e(lattrflag))then
8507 if (lwrite) then
8508 lattrflag = "write"
8509 else
8510 lattrflag = "read"
8511 end if
8512end if
8513
8514
8515!!$print*,"---------------- call session_init --------------------------------"
8516!!$print *,"session_init,lformat,ltemplate,lmemdb,lfile,lloadfile,lanaflag,ldataflag,lattrflag"
8517!!$print *,"session_init",lformat,ltemplate,lmemdb,lfile,lloadfile,lanaflag,ldataflag,lattrflag
8518!!$print*,"------------------------------------------------"
8519
8520if (lfile) then
8521
8522 if (present(anaflag).or.present(dataflag).or.present( attrflag)) then
8523 call l4f_category_log(dbasession_init%category,l4f_error,"option anaflag, dataflag, attrflag defined with filename access")
8524 CALL raise_error()
8525 end if
8526
8527else
8528
8529 if(.not. present(connection)) then
8530 call l4f_category_log(dbasession_init%category,l4f_error,"connection not present accessing DBA")
8531 CALL raise_error()
8532 end if
8533
8534 if (present(mode).or.present(format).or.present(template).or.present(simplified)) then
8535 call l4f_category_log(dbasession_init%category,l4f_error,&
8536 "option mode or format or template or simplified defined without filename")
8537 CALL raise_error()
8538 end if
8539
8540end if
8541
8542
8543! check filename for recursive call
8544if (present(filename))then
8545 if (lmemdb)then
8546 if (.not. present(connection)) then
8547 ! connect to dsn type DBA
8549 !call self with memconnection without filename
8550 dbasession_init=dbasession(dbasession_init%memconnection,&
8551 write=.true.,wipe=lwrite,repinfo=lrepinfo,&
8552 memdb=lmemdb,loadfile=lloadfile) ! without categoryappend
8553
8554 else
8555 dbasession_init%memconnection=connection
8556 !call self with memconnection without filename
8557 dbasession_init=dbasession(dbasession_init%memconnection,&
8558 write=.true.,wipe=lwrite,repinfo=lrepinfo,&
8559 memdb=lmemdb,loadfile=lloadfile) ! without categoryappend
8560
8561 end if
8562
8563 if (lmode == "r") then
8564 call dbasession_init%messages_open_input(filename=filename,mode=lmode,&
8565 format=lformat,simplified=lsimplified)
8566
8567 if (lloadfile)then
8568 read_next = dbasession_init%messages_read_next()
8569 do while (read_next)
8570 read_next = dbasession_init%messages_read_next()
8571 end do
8572 end if
8573 else
8574
8575 call dbasession_init%messages_open_output(filename=filename,&
8576 mode=lmode,format=lformat)
8577
8578 end if
8579
8580 else
8581
8582 ier = idba_messaggi(dbasession_init%sehandle,filename, lmode, lformat)
8583
8584 end if
8585
8586else
8587
8588 ier = idba_preparati(connection%dbhandle,dbasession_init%sehandle, lanaflag, ldataflag, lattrflag)
8589 if (lwipe)ier=idba_scopa(dbasession_init%sehandle,lrepinfo)
8590
8591end if
8592
8593dbasession_init%file=lfile
8594if (dbasession_init%file) dbasession_init%filename=filename
8595dbasession_init%mode=lmode
8596dbasession_init%format=lformat
8597dbasession_init%simplified=lsimplified
8598dbasession_init%memdb=lmemdb
8599dbasession_init%loadfile=lloadfile
8600dbasession_init%template=ltemplate
8601
8602!!$print*,"--------------- at end ---------------------------------"
8603!!$print *,'file',dbasession_init%file
8604!!$print *,'filename',trim(dbasession_init%filename)
8605!!$print *,'mode',dbasession_init%mode
8606!!$print *,'format',dbasession_init%format
8607!!$print *,'simplified',dbasession_init%simplified
8608!!$print *,'memdb',dbasession_init%memdb
8609!!$print *,'loadfile',dbasession_init%loadfile
8610!!$print *,'template',dbasession_init%template
8611!!$print*,"------------------------------------------------"
8612
8613end function dbasession_init
8614
8615
8617subroutine dbasession_unsetall(session)
8619integer :: ier
8620
8621if (c_e(session%sehandle)) then
8622 ier = idba_unsetall(session%sehandle)
8623end if
8624
8625end subroutine dbasession_unsetall
8626
8627
8629subroutine dbasession_remove_all(session)
8631integer :: ier
8632
8633if (c_e(session%sehandle)) then
8634 ier = idba_remove_all(session%sehandle)
8635end if
8636
8637end subroutine dbasession_remove_all
8638
8639
8641subroutine dbasession_prendilo(session)
8643integer :: ier
8644
8645if (c_e(session%sehandle)) then
8646 ier = idba_prendilo(session%sehandle)
8647end if
8648
8649end subroutine dbasession_prendilo
8650
8652subroutine dbasession_var_related(session,btable)
8654character(len=*),INTENT(IN) :: btable
8655integer :: ier
8656
8657if (c_e(session%sehandle)) then
8658 ier = idba_set(session%sehandle,"*var_related",btable)
8659end if
8660
8661end subroutine dbasession_var_related
8662
8664subroutine dbasession_setcontextana(session)
8666integer :: ier
8667
8668if (c_e(session%sehandle)) then
8669 ier = idba_setcontextana(session%sehandle)
8670end if
8671
8672end subroutine dbasession_setcontextana
8673
8675subroutine dbasession_dimenticami(session)
8677integer :: ier
8678
8679if (c_e(session%sehandle)) then
8680 ier = idba_dimenticami(session%sehandle)
8681end if
8682
8683end subroutine dbasession_dimenticami
8684
8686subroutine dbasession_critica(session)
8688integer :: ier
8689
8690if (c_e(session%sehandle)) then
8691 ier = idba_critica(session%sehandle)
8692end if
8693
8694end subroutine dbasession_critica
8695
8697subroutine dbasession_scusa(session)
8699integer :: ier
8700
8701if (c_e(session%sehandle)) then
8702 ier = idba_scusa(session%sehandle)
8703end if
8704
8705end subroutine dbasession_scusa
8706
8708subroutine dbasession_set(session,metadata,datav,data,datetime,ana,network,level,timerange,filter)
8710type (dbametadata),optional :: metadata
8711class(dbadcv),optional :: datav
8712class(dbadata),optional :: data
8713type (dbadatetime),optional :: datetime
8714type (dbaana),optional :: ana
8715type (dbanetwork),optional :: network
8716type (dbalevel),optional :: level
8717type (dbatimerange),optional :: timerange
8718type (dbafilter),optional :: filter
8719
8720if (present(metadata)) then
8721 call metadata%dbaset(session)
8722endif
8723
8724if (present(datetime)) then
8725 call datetime%dbaset(session)
8726endif
8727
8728if (present(ana)) then
8729 call ana%dbaset(session)
8730endif
8731
8732if (present(network)) then
8733 call network%dbaset(session)
8734endif
8735
8736if (present(level)) then
8737 call level%dbaset(session)
8738endif
8739
8740if (present(timerange)) then
8741 call timerange%dbaset(session)
8742endif
8743
8744if (present(datav)) then
8745 call datav%dbaset(session)
8746end if
8747
8748if (present(data)) then
8749 call data%dbaset(session)
8750end if
8751
8752if (present(filter)) then
8753 call filter%dbaset(session)
8754end if
8755
8756end subroutine dbasession_set
8757
8758
8759!!! Those are for reverse order call session%extrude(object)
8760
8761!!$!> put data on DSN
8762!!$subroutine dbasession_extrude_ana(session,ana)
8763!!$class(dbasession), intent(in) :: session
8764!!$class(dbaana) :: ana !< ana
8765!!$call ana%extrude(session)
8766!!$end subroutine dbasession_extrude_ana
8767!!$
8768!!$!> put data on DSN
8769!!$subroutine dbasession_extrude_dataattr(session,dataattr)
8770!!$class(dbasession), intent(in) :: session
8771!!$class(dbadataattr) :: dataattr !< dataattr
8772!!$call dataattr%extrude(session)
8773!!$end subroutine dbasession_extrude_dataattr
8774!!$
8775!!$!> put data on DSN
8776!!$subroutine dbasession_extrude_dataattrv(session,dataattrv,noattr,filter)
8777!!$class(dbasession), intent(in) :: session
8778!!$class(dbadataattrv) :: dataattrv !< array datatattr
8779!!$logical, intent(in),optional :: noattr !< set to .true. to get data only (no attribute)
8780!!$type(dbafilter),intent(in),optional :: filter !< use this to filter wanted data
8781!!$
8782!!$call dataattrv%extrude(session,noattr,filter)
8783!!$end subroutine dbasession_extrude_dataattrv
8784!!$
8785!!$!> put data on DSN
8786!!$subroutine dbasession_extrude_metaanddata(session,metaanddata,noattr,filter)
8787!!$class(dbasession), intent(in) :: session
8788!!$class(dbametaanddata) :: metaanddata !< metaanddata
8789!!$logical, intent(in),optional :: noattr !< set to .true. to get data only (no attribute)
8790!!$type(dbafilter),intent(in),optional :: filter !< use this to filter wanted data
8791!!$
8792!!$call metaanddata%extrude(session,noattr,filter)
8793!!$end subroutine dbasession_extrude_metaanddata
8794!!$
8795!!$!> put data on DSN
8796!!$subroutine dbasession_extrude_metaanddatai(session,metaanddatai)
8797!!$class(dbasession), intent(in) :: session
8798!!$class(dbametaanddatai) :: metaanddatai !< metaanddatai
8799!!$call metaanddatai%extrude(session)
8800!!$end subroutine dbasession_extrude_metaanddatai
8801!!$
8802!!$!> put data on DSN
8803!!$subroutine dbasession_extrude_metaanddatab(session,metaanddatab)
8804!!$class(dbasession), intent(in) :: session
8805!!$class(dbametaanddatab) :: metaanddatab !< metaanddatab
8806!!$call metaanddatab%extrude(session)
8807!!$end subroutine dbasession_extrude_metaanddatab
8808!!$
8809!!$!> put data on DSN
8810!!$subroutine dbasession_extrude_metaanddatad(session,metaanddatad)
8811!!$class(dbasession), intent(in) :: session
8812!!$class(dbametaanddatad) :: metaanddatad !< metaanddatad
8813!!$call metaanddatad%extrude(session)
8814!!$end subroutine dbasession_extrude_metaanddatad
8815!!$
8816!!$!> put data on DSN
8817!!$subroutine dbasession_extrude_metaanddatac(session,metaanddatac)
8818!!$class(dbasession), intent(in) :: session
8819!!$class(dbametaanddatac) :: metaanddatac !< metaanddatac
8820!!$call metaanddatac%extrude(session)
8821!!$end subroutine dbasession_extrude_metaanddatac
8822!!$
8823!!$!> put data on DSN
8824!!$subroutine dbasession_extrude_metaanddatar(session,metaanddatar)
8825!!$class(dbasession), intent(in) :: session
8826!!$class(dbametaanddatar) :: metaanddatar !< metaanddatar
8827!!$call metaanddatar%extrude(session)
8828!!$end subroutine dbasession_extrude_metaanddatar
8829!!$
8830!!$!> put data on DSN
8831!!$subroutine dbasession_extrude_metaanddatav(session, metaanddatav,noattr,filter)
8832!!$class(dbasession), intent(in) :: session
8833!!$class(dbametaanddatav) :: metaanddatav !< array metaanddata
8834!!$logical, intent(in),optional :: noattr !< set to .true. to get data only (no attribute)
8835!!$type(dbafilter),intent(in),optional :: filter !< use this to filter wanted data
8836!!$
8837!!$call metaanddatav%extrude(session,noattr,filter)
8838!!$end subroutine dbasession_extrude_metaanddatav
8839!!$
8840!!$subroutine dbasession_extrude_metaanddatal(session, metaanddatal,noattr,filter)
8841!!$class(dbasession), intent(in) :: session
8842!!$class (dbametaanddatalist) :: metaanddatal !< metaanddata list
8843!!$logical, intent(in),optional :: noattr !< set to .true. to get data only (no attribute)
8844!!$type(dbafilter),intent(in),optional :: filter !< use this to filter wanted data
8845!!$
8846!!$call metaanddatal%extrude(session,noattr,filter)
8847!!$end subroutine dbasession_extrude_metaanddatal
8848!!$
8849!!$!> put data on DSN
8850!!$subroutine dbasession_extrude(session,ana,dataattr,dataattrv,metaanddata,&
8851!!$ metaanddatai,metaanddatab,metaanddatad,metaanddatac,metaanddatar,&
8852!!$ metaanddatav ,metaanddatal,noattr,filter)
8853!!$class(dbasession), intent(in) :: session
8854!!$class(dbaana),optional :: ana !< ana
8855!!$class(dbadataattr),optional :: dataattr !< dataattr
8856!!$class(dbadataattrv),optional :: dataattrv !< array datatattr
8857!!$class(dbametaanddata),optional :: metaanddata !< metaanddata
8858!!$class(dbametaanddatai),optional :: metaanddatai !< metaanddatai
8859!!$class(dbametaanddatab),optional :: metaanddatab !< metaanddatab
8860!!$class(dbametaanddatad),optional :: metaanddatad !< metaanddatad
8861!!$class(dbametaanddatac),optional :: metaanddatac !< metaanddatac
8862!!$class(dbametaanddatar),optional :: metaanddatar !< metaanddatar
8863!!$class(dbametaanddatav),optional :: metaanddatav !< array metaanddata
8864!!$class(dbametaanddatalist),optional :: metaanddatal !< metaanddata list
8865!!$logical, intent(in),optional :: noattr !< set to .true. to get data only (no attribute)
8866!!$type(dbafilter),intent(in),optional :: filter !< use this to filter wanted data
8867!!$
8868!!$if (present(ana)) then
8869!!$ call ana%extrude(session)
8870!!$end if
8871!!$
8872!!$if (present(dataattr)) then
8873!!$ call dataattr%extrude(session)
8874!!$end if
8875!!$
8876!!$if (present(dataattrv)) then
8877!!$ call dataattrv%extrude(session,noattr,filter)
8878!!$end if
8879!!$
8880!!$if (present(metaanddata)) then
8881!!$ call metaanddata%extrude(session)
8882!!$end if
8883!!$
8884!!$if (present(metaanddatai)) then
8885!!$ call metaanddatai%extrude(session)
8886!!$end if
8887!!$
8888!!$if (present(metaanddatab)) then
8889!!$ call metaanddatab%extrude(session)
8890!!$end if
8891!!$
8892!!$if (present(metaanddatad)) then
8893!!$ call metaanddatad%extrude(session)
8894!!$end if
8895!!$
8896!!$if (present(metaanddatac)) then
8897!!$ call metaanddatac%extrude(session)
8898!!$end if
8899!!$
8900!!$if (present(metaanddatar)) then
8901!!$ call metaanddatar%extrude(session)
8902!!$end if
8903!!$
8904!!$if (present(metaanddatav)) then
8905!!$ call metaanddatav%extrude(session,noattr,filter)
8906!!$end if
8907!!$
8908!!$if (present(metaanddatal)) then
8909!!$ call metaanddatal%extrude(session,noattr,filter)
8910!!$end if
8911!!$
8912!!$end subroutine dbasession_extrude
8913
8914# ifndef F2003_FULL_FEATURES
8915
8916subroutine dbasession_delete(session)
8918integer :: ier
8919type(dbasession) :: defsession
8920
8921if (c_e(session%sehandle)) then
8922 ier = idba_fatto(session%sehandle)
8923end if
8924
8925call session%memconnection%delete()
8926
8927select type (session)
8929 session = defsession
8930end select
8931
8932!!$session%sehandle=imiss
8933!!$session%file=.false.
8934!!$session%template=cmiss
8935!!$session%filename=cmiss
8936!!$session%mode=cmiss
8937!!$session%format=cmiss
8938!!$session%simplified=.true.
8939!!$session%memdb=.false.
8940!!$session%category=imiss
8941!!$session%count=imiss
8942
8943end subroutine dbasession_delete
8944
8945#else
8946
8948subroutine dbasession_delete(session)
8949type (dbasession), intent(inout) :: session
8950integer :: ier
8951
8952if (c_e(session%sehandle)) then
8953 ier = idba_fatto(session%sehandle)
8954end if
8955
8956!!$session%sehandle=imiss
8957!!$session%file=.false.
8958!!$session%template=cmiss
8959!!$session%filename=cmiss
8960!!$session%mode=cmiss
8961!!$session%format=cmiss
8962!!$session%simplified=.true.
8963!!$session%memdb=.false.
8964!!$session%category=imiss
8965!!$session%count=imiss
8966
8967end subroutine dbasession_delete
8968
8969#endif
8970
8971
8972
8974subroutine dbasession_filerewind(session)
8976integer :: ier
8977
8978if (c_e(session%sehandle).and. session%file) then
8979 ier = idba_fatto(session%sehandle)
8980 ier = idba_messaggi(session%sehandle,session%filename,session%mode,session%format)
8981
8982!!$! example: here we call constructor after a cast to reassign self (can you pass self attributes to constructor?)
8983!!$ select type(session)
8984!!$ type is (dbasession)
8985!!$ session=dbasession(filename=session%filename,mode=session%mode,format=session%format)
8986!!$ end select
8987
8988end if
8989
8990end subroutine dbasession_filerewind
8991
8992
8993FUNCTION dballe_error_handler(category)
8994INTEGER :: category, code, l4f_level
8995INTEGER :: dballe_error_handler
8996
8997CHARACTER(len=1000) :: message, buf
8998
8999code = idba_error_code()
9000
9001! check if "Value outside acceptable domain"
9002if (code == 13 ) then
9003 l4f_level=l4f_warn
9004else
9005 l4f_level=l4f_error
9006end if
9007
9008call idba_error_message(message)
9009call l4f_category_log(category,l4f_level,trim(message))
9010
9011call idba_error_context(buf)
9012
9013call l4f_category_log(category,l4f_level,trim(buf))
9014
9015call idba_error_details(buf)
9016call l4f_category_log(category,l4f_info,trim(buf))
9017
9018
9019! if "Value outside acceptable domain" do not raise error
9020if (l4f_level == l4f_error ) CALL raise_fatal_error("dballe: "//message)
9021
9022dballe_error_handler = 0
9023return
9024
9025END FUNCTION dballe_error_handler
9026
9028
Classes for handling georeferenced sparse points in geographical corodinates. Definition: geo_coord_class.F90:222 Definitions of constants and functions for working with missing values. Definition: missing_values.f90:50 Module for quickly interpreting the OPTIONAL parameters passed to a subprogram. Definition: optional_values.f90:28 Classe per la gestione dell'anagrafica di stazioni meteo e affini. Definition: vol7d_ana_class.F90:218 Classe per la gestione di un volume completo di dati osservati. Definition: vol7d_class.F90:279 Classe per la gestione dei livelli verticali in osservazioni meteo e affini. Definition: vol7d_level_class.F90:219 Classe per la gestione delle reti di stazioni per osservazioni meteo e affini. Definition: vol7d_network_class.F90:220 Classe per la gestione degli intervalli temporali di osservazioni meteo e affini. Definition: vol7d_timerange_class.F90:221 Class for expressing an absolute time value. Definition: datetime_class.F90:239 extend one data container with a vector of data container (one data plus attributes) Definition: dballe_class.F03:664 vector of dbadataattr (more data plus attributes) Definition: dballe_class.F03:672 container for dbadata (used for promiscuous vector of data) Definition: dballe_class.F03:643 one metadata with more data plus attributes Definition: dballe_class.F03:680 metadata and byte data double linked list Definition: dballe_class.F03:730 metadata and character data double linked list Definition: dballe_class.F03:778 metadata and diubleprecision data double linked list Definition: dballe_class.F03:746 metadata and integer data double linked list Definition: dballe_class.F03:714 double linked list of dbametaanddata Definition: dballe_class.F03:698 metadata and real data double linked list Definition: dballe_class.F03:762 one metadata plus vector of container of dbadata Definition: dballe_class.F03:689 Derived type defining an isolated georeferenced point on Earth in polar geographical coordinates. Definition: geo_coord_class.F90:249 Definisce l'anagrafica di una stazione. Definition: vol7d_ana_class.F90:231 Definisce il livello verticale di un'osservazione. Definition: vol7d_level_class.F90:229 Definisce la rete a cui appartiene una stazione. Definition: vol7d_network_class.F90:232 Definisce l'intervallo temporale di un'osservazione meteo. Definition: vol7d_timerange_class.F90:231 |