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