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