92 character (len=255),
parameter:: subcategory=
"vol7d_dballe_class"
105 integer :: handle,handle_staz
106 integer :: handle_err
109 integer ,
pointer :: data_id(:,:,:,:,:)
110 logical :: file=.false.
115 INTEGER,
PARAMETER,
PRIVATE :: nftype = 2
116 CHARACTER(len=16),
PARAMETER,
PRIVATE :: &
117 pathlist(2,nftype) = reshape((/ &
118 '/usr/share ',
'/usr/local/share', &
119 '/etc ',
'/usr/local/etc ' /), &
123 CHARACTER(len=20),
PRIVATE :: dballe_name=
'wreport', dballe_name_env=
'DBA_TABLES'
128 MODULE PROCEDURE vol7d_dballe_init
133 MODULE PROCEDURE vol7d_dballe_delete
138 MODULE PROCEDURE vol7d_dballe_importvsns, vol7d_dballe_importvvns, &
139 vol7d_dballe_importvsnv, vol7d_dballe_importvvnv
144 MODULE PROCEDURE vol7d_dballe_export
152 TYPE(vol7d_ana
) :: ana
153 TYPE(datetime
) :: time
154 TYPE(vol7d_level
) :: level
155 TYPE(vol7d_timerange
) :: timerange
156 TYPE(vol7d_network
) :: network
158 CHARACTER(len=10) :: btable
161 REAL(kind=fp_d) :: datod
163 INTEGER(kind=int_b) :: datob
164 CHARACTER(len=vol7d_cdatalen) :: datoc
174 type(vol7d_var
),
allocatable,
private :: blocal(:)
178 vol7d_dballe_import_dballevar
184 SUBROUTINE vol7d_dballe_init(this,dsn,user,password,write,wipe,repinfo,&
185 filename,
format,file,categoryappend,time_definition,idbhandle)
189 character(len=*),
INTENT(in),
OPTIONAL :: dsn
190 character(len=*),
INTENT(in),
OPTIONAL :: user
191 character(len=*),
INTENT(in),
OPTIONAL :: password
192 logical,
INTENT(in),
OPTIONAL :: write
193 logical,
INTENT(in),
OPTIONAL :: wipe
194 character(len=*),
INTENT(in),
OPTIONAL :: repinfo
195 character(len=*),
intent(inout),
optional :: filename
196 character(len=*),
intent(in),
optional :: format
197 logical,
INTENT(in),
OPTIONAL :: file
198 character(len=*),
INTENT(in),
OPTIONAL :: categoryappend
199 integer,
INTENT(in),
OPTIONAL :: time_definition
200 integer,
INTENT(in),
OPTIONAL :: idbhandle
202 character(len=1):: mode
204 character(len=50) :: quidsn,quiuser,quipassword
205 character(len=255) :: quirepinfo
206 logical :: quiwrite,quiwipe,quifile
208 character(len=512) :: a_name
209 character(len=254) :: arg,lfilename,lformat
218 this%handle_err=imiss
219 this%handle_staz=imiss
221 if (present(categoryappend))
then
222 call l4f_launcher(a_name,a_name_append=trim(subcategory)//
"."//trim(categoryappend))
224 call l4f_launcher(a_name,a_name_append=trim(subcategory))
226 this%category=l4f_category_get(a_name)
228 nullify(this%data_id)
231 CALL
init(this%vol7d,time_definition=time_definition)
234 ier=idba_error_set_callback(0,v7d_dballe_error_handler, &
235 this%category,this%handle_err)
238 if (present(write))
then
244 if (present(wipe))
then
246 if (present(repinfo))
then
252 if (present(file))
then
262 if (present(format))
then
267 lfilename=trim(arg)//
"."//trim(lformat)
268 if (
index(arg,
'/',back=.true.) > 0) lfilename=lfilename(
index(arg,
'/',back=.true.)+1 : )
270 if (present(filename))
then
271 if (filename /=
"")
then
276 inquire(file=lfilename,exist=exist)
280 if (quiwipe.or..not.exist)
then
284 call
l4f_category_log(this%category,l4f_info,
"file exists; appending data to file: "//trim(lfilename))
288 call
l4f_category_log(this%category,l4f_error,
"file does not exist; cannot open file for read: "//trim(lfilename))
289 CALL raise_fatal_error()
296 ier=idba_messaggi(this%handle,lfilename,mode,lformat)
300 ier=idba_presentati(this%idbhandle,dsn=
"mem:",user=
"",password=
"")
301 ier=idba_preparati(this%idbhandle,this%handle,
"write",
"write",
"write")
302 ier=idba_preparati(this%idbhandle,this%handle_staz,
"write",
"write",
"write")
303 ier = idba_messages_open_input(this%handle, lfilename, mode, lformat, simplified=.true.)
304 ier=idba_messages_read_next(this%handle, read_next)
306 ier=idba_messages_read_next(this%handle, read_next)
312 ier=idba_messaggi(this%handle,lfilename,mode,lformat)
319 call
l4f_category_log(this%category,l4f_debug,
"handle from idba_messaggi: "//
t2c(this%handle))
320 call
l4f_category_log(this%category,l4f_debug,
"filename: "//trim(lfilename))
328 if (.not.
c_e(optio_i(idbhandle)))
then
333 IF (present(dsn))
THEN
334 IF (
c_e(dsn)) quidsn = dsn
336 IF (present(user))
THEN
337 IF (
c_e(user)) quiuser = user
339 IF (present(password))
THEN
340 IF (
c_e(password)) quipassword = password
344 ier=idba_presentati(this%idbhandle,quidsn,quiuser,quipassword)
346 this%idbhandle=optio_i(idbhandle)
350 ier=idba_preparati(this%idbhandle,this%handle,
"write",
"write",
"write")
351 ier=idba_preparati(this%idbhandle,this%handle_staz,
"write",
"write",
"write")
353 ier=idba_preparati(this%idbhandle,this%handle,
"read",
"read",
"read")
354 ier=idba_preparati(this%idbhandle,this%handle_staz,
"read",
"read",
"read")
357 if (quiwipe)ier=idba_scopa(this%handle,quirepinfo)
363 END SUBROUTINE vol7d_dballe_init
371 SUBROUTINE vol7d_dballe_importvsns(this, var, network, coordmin, coordmax, timei, timef,level,timerange, set_network,&
372 attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,ana)
374 CHARACTER(len=*),
INTENT(in) :: var
377 type(geo_coord),
INTENT(inout),
optional :: coordmin,coordmax
379 TYPE(vol7d_ana
),
INTENT(inout),
optional :: ana
381 TYPE(datetime
),
INTENT(in),
optional :: timei, timef
382 TYPE(vol7d_network
),
INTENT(in),
optional :: network
386 type(vol7d_network),
INTENT(in),
OPTIONAL ::set_network
387 TYPE(vol7d_level
),
INTENT(in),
optional :: level
388 type(vol7d_timerange),
INTENT(in),
optional :: timerange
390 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: attr(:)
392 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: anavar(:)
394 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: anaattr(:)
401 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: varkind(:)
408 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: attrkind(:)
415 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: anavarkind(:)
422 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: anaattrkind(:)
423 logical,
intent(in),
optional :: anaonly
425 CALL
import(this, (/var/), network, coordmin, coordmax, timei, timef,level,timerange, set_network,&
426 attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,ana)
428 END SUBROUTINE vol7d_dballe_importvsns
434 SUBROUTINE vol7d_dballe_importvsnv(this, var, network, coordmin, coordmax, timei, timef,level,timerange, set_network,&
435 attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,ana)
437 CHARACTER(len=*),
INTENT(in) :: var
438 TYPE(geo_coord
),
INTENT(inout),
optional :: coordmin,coordmax
439 TYPE(vol7d_ana
),
INTENT(inout),
optional :: ana
440 TYPE(datetime
),
INTENT(in),
optional :: timei, timef
441 TYPE(vol7d_network
),
INTENT(in) :: network(:)
442 TYPE(vol7d_network
),
INTENT(in),
OPTIONAL :: set_network
443 TYPE(vol7d_level
),
INTENT(in),
optional :: level
444 TYPE(vol7d_timerange
),
INTENT(in),
optional :: timerange
445 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: attr(:),anavar(:),anaattr(:)
446 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: varkind(:),attrkind(:),anavarkind(:),anaattrkind(:)
447 logical,
intent(in),
optional :: anaonly
452 if (
size(network) == 0)
then
454 CALL
import(this, (/var/), coordmin=coordmin, coordmax=coordmax, timei=timei, timef=timef, level=level,&
455 timerange=timerange,set_network=set_network, attr=attr,anavar=anavar,anaattr=anaattr,&
456 varkind=varkind,attrkind=attrkind,anavarkind=anavarkind,anaattrkind=anaattrkind,anaonly=anaonly,ana=ana)
460 DO i = 1,
SIZE(network)
461 CALL
import(this, (/var/), network(i), coordmin, coordmax, timei, timef, level,timerange,set_network,&
462 attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,ana)
468 END SUBROUTINE vol7d_dballe_importvsnv
474 SUBROUTINE vol7d_dballe_importvvnv(this, var, network, coordmin,coordmax, timei, timef, level,timerange,set_network,&
475 attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,ana)
477 CHARACTER(len=*),
INTENT(in) :: var(:)
478 TYPE(geo_coord
),
INTENT(inout),
optional :: coordmin,coordmax
479 TYPE(vol7d_ana
),
INTENT(inout),
optional :: ana
480 TYPE(datetime
),
INTENT(in),
optional :: timei, timef
481 TYPE(vol7d_network
),
INTENT(in) :: network(:)
482 TYPE(vol7d_network
),
INTENT(in),
OPTIONAL :: set_network
483 TYPE(vol7d_level
),
INTENT(in),
optional :: level
484 TYPE(vol7d_timerange
),
INTENT(in),
optional :: timerange
485 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: attr(:),anavar(:),anaattr(:)
486 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: varkind(:),attrkind(:),anavarkind(:),anaattrkind(:)
487 logical,
intent(in),
optional :: anaonly
491 if (
size(network) == 0 )
then
492 CALL
import(this,var, coordmin=coordmin, coordmax=coordmax, timei=timei, timef=timef, level=level,&
493 timerange=timerange,set_network=set_network, attr=attr,anavar=anavar,anaattr=anaattr,&
494 varkind=varkind,attrkind=attrkind,anavarkind=anavarkind,anaattrkind=anaattrkind,anaonly=anaonly,ana=ana)
496 DO i = 1,
SIZE(network)
497 CALL
import(this, var, network(i), coordmin, coordmax, timei, timef, level,timerange,set_network,&
498 attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,ana)
502 END SUBROUTINE vol7d_dballe_importvvnv
508 SUBROUTINE vol7d_dballe_importvvns(this, var, network, coordmin, coordmax, timei, timef,level,timerange, set_network,&
509 attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,ana)
512 CHARACTER(len=*),
INTENT(in),
optional :: var(:)
513 TYPE(geo_coord
),
INTENT(inout),
optional :: coordmin,coordmax
514 TYPE(vol7d_ana
),
INTENT(inout),
optional :: ana
515 TYPE(datetime
),
INTENT(in),
OPTIONAL :: timei, timef
516 TYPE(vol7d_network
),
INTENT(in),
OPTIONAL :: network,set_network
517 TYPE(vol7d_level
),
INTENT(in),
optional :: level
518 TYPE(vol7d_timerange
),
INTENT(in),
optional :: timerange
519 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: attr(:),anavar(:),anaattr(:)
520 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: varkind(:),attrkind(:),anavarkind(:),anaattrkind(:)
521 logical,
intent(in),
optional :: anaonly
525 call vol7d_dballe_importvvns_file(this, var, network, coordmin, coordmax, timei, timef,level,timerange, set_network,&
526 attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,ana)
534 call vol7d_dballe_importvvns_dba(this, var, network, coordmin, coordmax, timei, timef,level,timerange, set_network,&
535 attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,ana)
539 end SUBROUTINE vol7d_dballe_importvvns
546 SUBROUTINE vol7d_dballe_importvvns_dba(this, var, network, coordmin, coordmax, timei, timef,level,timerange, set_network,&
547 attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,ana)
550 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: var(:)
551 TYPE(geo_coord
),
INTENT(inout),
optional :: coordmin,coordmax
552 TYPE(vol7d_ana
),
INTENT(inout),
optional :: ana
553 TYPE(datetime
),
INTENT(in),
OPTIONAL :: timei, timef
554 TYPE(vol7d_network
),
INTENT(in),
OPTIONAL :: network,set_network
555 TYPE(vol7d_level
),
INTENT(in),
optional :: level
556 TYPE(vol7d_timerange
),
INTENT(in),
optional :: timerange
557 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: attr(:),anavar(:),anaattr(:)
558 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: varkind(:),attrkind(:),anavarkind(:),anaattrkind(:)
559 logical,
intent(in),
optional :: anaonly
561 TYPE(vol7d_network
) :: lnetwork
562 TYPE(vol7d_level
) :: llevel
563 TYPE(vol7d_timerange
) :: ltimerange
565 INTEGER,
PARAMETER :: maxvarlist=100
570 CHARACTER(len=maxvarlist*7) :: varlist
571 CHARACTER(len=maxvarlist*8) :: starvarlist
572 CHARACTER(len=6) :: btable
573 CHARACTER(len=7) ::starbtable
575 LOGICAL :: ldegnet, lattr, lanaattr
576 integer :: year,month,day,hour,minute,sec,msec
577 integer :: rlevel1, rl1,rlevel2, rl2
578 integer :: rtimerange, p1, p2
579 character(len=network_name_len) :: rep_memo
580 integer :: indana,indtime,indlevel,indtimerange,inddativar,indnetwork
583 integer :: nana,ntime,ntimerange,nlevel,nnetwork
584 TYPE(vol7d_var
) :: var_tmp
586 INTEGER :: i,ii, iii,n,n_ana,nn,nvarattr,istat,indattr
587 integer :: nvar ,inddatiattr,inddativarattr
588 integer :: nanavar ,indanavar,indanaattr,indanavarattr,nanavarattr
590 INTEGER(kind=int_l) :: ilat,ilon
591 CHARACTER(len=vol7d_ana_lenident) :: ident
592 CHARACTER(len=10),
allocatable :: lvar(:), lanavar(:)
595 integer :: ndativarr, ndativari, ndativarb, ndativard, ndativarc
596 integer :: ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc
597 integer :: ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc
599 integer :: nanavarr, nanavari, nanavarb, nanavard, nanavarc
600 integer :: nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc
601 integer :: nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
603 integer :: ir,ib,id,ic,ier
613 TYPE(vol7d) :: vol7dtmp
615 type(record
),
ALLOCATABLE :: buffer(:),bufferana(:)
623 IF (present(set_network))
THEN
624 if (
c_e(set_network))
then
633 IF (present(attr))
THEN
634 if (any(
c_e(attr)).and.
size(attr) > 0)
then
652 IF (present(anaattr))
THEN
653 if (
size(anaattr) > 0)
then
662 IF (present(var))
THEN
663 allocate(lvar(
size(var)))
669 IF (present(anavar))
THEN
670 allocate(lanavar(
size(anavar)))
676 if (present(network))
then
682 if (present(level))
then
688 if (present(timerange))
then
691 call
init(ltimerange)
695 ier=idba_unsetall(this%handle)
701 if(
c_e(lnetwork))ier=idba_set(this%handle,
"rep_memo",lnetwork%name)
704 CALL
l4f_category_log(this%category,l4f_debug,
'query rep_memo:'//
t2c(lnetwork%name,miss=
"missing"))
707 if(ldegnet)ier=idba_set(this%handle,
"query",
"best")
712 if (present(coordmin))
then
714 CALL
getval(coordmin, ilat=ilat,ilon=ilon)
717 CALL
l4f_category_log(this%category,l4f_debug,
'query coordmin:'//
t2c(ilon,miss=
"missing")//
"/"//
t2c(ilat,miss=
"missing"))
719 ier=idba_set(this%handle,
"lonmin",ilon)
720 ier=idba_set(this%handle,
"latmin",ilat)
723 if (present(coordmax))
then
725 CALL
getval(coordmax, ilat=ilat,ilon=ilon)
727 CALL
l4f_category_log(this%category,l4f_debug,
'query coordmax:'//
t2c(ilon,miss=
"missing")//
"/"//
t2c(ilat,miss=
"missing"))
729 ier=idba_set(this%handle,
"lonmax",ilon)
730 ier=idba_set(this%handle,
"latmax",ilat)
733 if (present(ana))
then
734 CALL
getval(ana%coord, ilat=ilat,ilon=ilon)
736 CALL
l4f_category_log(this%category,l4f_debug,
'query coord:'//
t2c(ilon,miss=
"missing")//
"/"//
t2c(ilat,miss=
"missing"))
737 CALL
l4f_category_log(this%category,l4f_debug,
'query ident:'//
t2c(ana%ident,miss=
"missing"))
739 ier=idba_set(this%handle,
"lon",ilon)
740 ier=idba_set(this%handle,
"lat",ilat)
741 if (
c_e(ana%ident))
then
742 ier=idba_set(this%handle,
"ident",ana%ident)
744 ier=idba_set(this%handle,
"mobile",1)
746 ier=idba_set(this%handle,
"mobile",0)
750 if (present(timei))
then
755 CALL
getval(timei, year=year, month=month, day=day, hour=hour, minute=minute,msec=msec)
756 sec=nint(float(msec)/1000.)
757 ier=idba_setdatemin(this%handle,year,month,day,hour,minute,sec)
762 if (present(timef))
then
767 CALL
getval(timef, year=year, month=month, day=day, hour=hour, minute=minute,msec=msec)
768 sec=nint(float(msec)/1000.)
769 ier=idba_setdatemax(this%handle,year,month,day,hour,minute,sec)
778 if (any(
c_e(lvar)) .and. .not. optio_log(anaonly))
then
781 IF (
SIZE(lvar) > maxvarlist)
THEN
782 CALL
l4f_category_log(this%category,l4f_error,
"too many variables requested: "//
t2c(
SIZE(lvar)))
783 call raise_fatal_error()
790 IF (nvar > 1) varlist(len_trim(varlist)+1:) =
','
791 varlist(len_trim(varlist)+1:) = trim(lvar(i))
796 CALL
l4f_category_log(this%category,l4f_debug,
'query varlist:'//
t2c(
SIZE(lvar))//
":"//varlist)
798 if (varlist /=
'' ) ier=idba_set(this%handle,
"varlist",varlist )
802 if (
c_e(ltimerange))
then
806 ier=idba_settimerange(this%handle, timerange%timerange, timerange%p1, timerange%p2)
813 ier=idba_setlevel(this%handle, level%level1, level%l1,level%level2, level%l2)
816 ier=idba_voglioquesto(this%handle,n)
822 if (optio_log(anaonly)) n=0
825 allocate(buffer(n),stat=istat)
828 //trim(
to_char(n))//
' buffer elements')
829 CALL raise_fatal_error()
836 ier=idba_dammelo(this%handle,btable)
838 ier=idba_enqdate(this%handle,year,month,day,hour,minute,sec)
839 IF (.NOT.
c_e(sec)) sec = 0
840 ier=idba_enqlevel(this%handle, rlevel1, rl1, rlevel2,rl2)
841 ier=idba_enqtimerange(this%handle, rtimerange, p1, p2)
842 ier=idba_enq(this%handle,
"rep_memo",rep_memo)
849 buffer(i)%dator=dba_mvr
850 buffer(i)%datoi=dba_mvi
851 buffer(i)%datob=dba_mvb
852 buffer(i)%datod=dba_mvd
853 buffer(i)%datoc=dba_mvc
855 if (any(
c_e(lvar)).and. present(varkind))
then
856 ii= index_c(lvar, btable)
859 if(varkind(ii) ==
"r") ier=idba_enq(this%handle,btable,buffer(i)%dator)
860 if(varkind(ii) ==
"i") ier=idba_enq(this%handle,btable,buffer(i)%datoi)
861 if(varkind(ii) ==
"b") ier=idba_enq(this%handle,btable,buffer(i)%datob)
862 if(varkind(ii) ==
"d") ier=idba_enq(this%handle,btable,buffer(i)%datod)
863 if(varkind(ii) ==
"c") ier=idba_enq(this%handle,btable,buffer(i)%datoc)
866 ier=idba_enq(this%handle,btable,buffer(i)%datoc)
871 ier=idba_enq(this%handle,
"context_id",buffer(i)%data_id)
874 ier=idba_enq(this%handle,
"lat", ilat)
875 ier=idba_enq(this%handle,
"lon", ilon)
876 ier=idba_enq(this%handle,
"ident",ident)
888 call
init(buffer(i)%ana,ilat=ilat,ilon=ilon,ident=ident)
889 call
init(buffer(i)%time, year=year, month=month, day=day, hour=hour, minute=minute,msec=sec*1000)
890 call
init(buffer(i)%level, rlevel1,rl1,rlevel2,rl2)
891 call
init(buffer(i)%timerange, rtimerange, p1, p2)
892 call
init(buffer(i)%network, rep_memo)
893 buffer(i)%btable = btable
896 if (this%vol7d%time_definition == 0) buffer(i)%time = buffer(i)%time - &
897 timedelta_new(sec=buffer(i)%timerange%p1)
905 ier=idba_unsetall(this%handle_staz)
910 if(
c_e(lnetwork))ier=idba_set(this%handle_staz,
"rep_memo",lnetwork%name)
911 if(ldegnet)ier=idba_set(this%handle_staz,
"query",
"best")
913 if (present(coordmin))
then
915 CALL
getval(coordmin, ilat=ilat,ilon=ilon)
916 ier=idba_set(this%handle_staz,
"lonmin",ilon)
917 ier=idba_set(this%handle_staz,
"latmin",ilat)
920 if (present(coordmax))
then
922 CALL
getval(coordmax, ilat=ilat,ilon=ilon)
923 ier=idba_set(this%handle_staz,
"lonmax",ilon)
924 ier=idba_set(this%handle_staz,
"latmax",ilat)
927 if (present(ana))
then
928 CALL
getval(ana%coord, ilat=ilat,ilon=ilon)
929 ier=idba_set(this%handle_staz,
"lon",ilon)
930 ier=idba_set(this%handle_staz,
"lat",ilat)
931 if (
c_e(ana%ident))
then
932 ier=idba_set(this%handle_staz,
"ident",ana%ident)
934 ier=idba_set(this%handle_staz,
"mobile",1)
936 ier=idba_set(this%handle_staz,
"mobile",0)
942 if (
size (lanavar) > 0 )
then
945 DO i = 1,
SIZE(lanavar)
946 nanavar = nanavar + 1
947 IF (nanavar > 1) varlist(len_trim(varlist)+1:) =
','
948 varlist(len_trim(varlist)+1:) = trim(lanavar(i))
956 ier=idba_setcontextana(this%handle_staz)
957 ier=idba_voglioquesto(this%handle_staz,n_ana)
961 allocate(bufferana(n_ana),stat=istat)
964 //trim(
to_char(n_ana))//
' bufferana elements')
965 CALL raise_fatal_error()
971 call
init(bufferana(i)%ana)
972 call
init(bufferana(i)%network)
974 bufferana(i)%dator=dba_mvr
975 bufferana(i)%datoi=dba_mvi
976 bufferana(i)%datob=dba_mvb
977 bufferana(i)%datod=dba_mvd
978 bufferana(i)%datoc=dba_mvc
979 bufferana(i)%btable = dba_mvc
981 ier=idba_dammelo(this%handle_staz,btable)
984 ier=idba_enqdate(this%handle_staz,year,month,day,hour,minute,sec)
985 IF (.NOT.
c_e(sec)) sec = 0
986 ier=idba_enqlevel(this%handle_staz, rlevel1, rl1, rlevel2,rl2)
987 ier=idba_enqtimerange(this%handle_staz, rtimerange, p1, p2)
988 ier=idba_enq(this%handle_staz,
"rep_memo",rep_memo)
997 ier=idba_enq(this%handle_staz,
"context_id",bufferana(i)%data_id)
1000 ier=idba_enq(this%handle_staz,
"lat", ilat)
1001 ier=idba_enq(this%handle_staz,
"lon", ilon)
1002 ier=idba_enq(this%handle_staz,
"ident",ident)
1007 call
init(bufferana(i)%ana,ilat=ilat,ilon=ilon,ident=ident)
1008 call
init(bufferana(i)%network, rep_memo)
1011 if (btable ==
"B05001" .or. btable ==
"B06001" .or. btable ==
"B01011" .or. btable ==
"B01194" ) cycle
1013 if (
size(lanavar) > 0 .and. present(anavarkind))
then
1014 ii= index_c(lanavar, btable)
1017 if(anavarkind(ii) ==
"r") ier=idba_enq(this%handle_staz,btable,bufferana(i)%dator)
1018 if(anavarkind(ii) ==
"i") ier=idba_enq(this%handle_staz,btable,bufferana(i)%datoi)
1019 if(anavarkind(ii) ==
"b") ier=idba_enq(this%handle_staz,btable,bufferana(i)%datob)
1020 if(anavarkind(ii) ==
"d") ier=idba_enq(this%handle_staz,btable,bufferana(i)%datod)
1021 if(anavarkind(ii) ==
"c") ier=idba_enq(this%handle_staz,btable,bufferana(i)%datoc)
1024 ier=idba_enq(this%handle_staz,btable,bufferana(i)%datoc)
1028 call
init(bufferana(i)%time, year=year, month=month, day=day, hour=hour, minute=minute,msec=sec*1000)
1029 call
init(bufferana(i)%level, rlevel1,rl1,rlevel2,rl2)
1030 call
init(bufferana(i)%timerange, rtimerange, p1, p2)
1031 bufferana(i)%btable = btable
1037 if (.not. any(
c_e(lvar)))
then
1038 nvar = count_distinct(buffer%btable, back=.true.)
1041 if (optio_log(anaonly))
then
1042 nana = count_distinct(bufferana%ana, back=.true.)
1044 nana = count_distinct(buffer%ana, back=.true.)
1050 if (optio_log(anaonly))
then
1051 nnetwork = count_distinct(bufferana%network, back=.true.)
1053 nnetwork = count_distinct(buffer%network, back=.true.)
1058 ntime = count_distinct(buffer%time, back=.true.)
1059 ntimerange = count_distinct(buffer%timerange, back=.true.)
1060 nlevel = count_distinct(buffer%level, back=.true.)
1063 if (present(varkind))
then
1064 ndativarr= count(varkind ==
"r")
1065 ndativari= count(varkind ==
"i")
1066 ndativarb= count(varkind ==
"b")
1067 ndativard= count(varkind ==
"d")
1068 ndativarc= count(varkind ==
"c")
1083 if (present(attrkind))
then
1084 ndatiattrr= count(attrkind ==
"r")
1085 ndatiattri= count(attrkind ==
"i")
1086 ndatiattrb= count(attrkind ==
"b")
1087 ndatiattrd= count(attrkind ==
"d")
1088 ndatiattrc= count(attrkind ==
"c")
1095 ndatiattrc=
size(attr)
1112 if (ndatiattrr > 0 ) ndativarattrr=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1113 if (ndatiattri > 0 ) ndativarattri=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1114 if (ndatiattrb > 0 ) ndativarattrb=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1115 if (ndatiattrd > 0 ) ndativarattrd=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1116 if (ndatiattrc > 0 ) ndativarattrc=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1121 if (
size(lanavar) == 0 )
then
1122 nanavar = count_distinct(bufferana%btable, back=.true.,mask=(bufferana%btable /= dba_mvc))
1125 if (present(anavarkind))
then
1126 nanavarr= count(anavarkind ==
"r")
1127 nanavari= count(anavarkind ==
"i")
1128 nanavarb= count(anavarkind ==
"b")
1129 nanavard= count(anavarkind ==
"d")
1130 nanavarc= count(anavarkind ==
"c")
1145 if (present(anaattrkind))
then
1146 nanaattrr= count(anaattrkind ==
"r")
1147 nanaattri= count(anaattrkind ==
"i")
1148 nanaattrb= count(anaattrkind ==
"b")
1149 nanaattrd= count(anaattrkind ==
"d")
1150 nanaattrc= count(anaattrkind ==
"c")
1157 nanaattrc=
size(anaattr)
1174 if (nanaattrr > 0 ) nanavarattrr=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1175 if (nanaattri > 0 ) nanavarattri=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1176 if (nanaattrb > 0 ) nanavarattrb=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1177 if (nanaattrd > 0 ) nanavarattrd=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1178 if (nanaattrc > 0 ) nanavarattrc=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1183 CALL
init(vol7dtmp,time_definition=this%vol7d%time_definition)
1187 call vol7d_alloc(vol7dtmp, &
1188 nana=nana, ntime=ntime, ntimerange=ntimerange, &
1189 nlevel=nlevel, nnetwork=nnetwork, &
1190 ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb, ndativard=ndativard, ndativarc=ndativarc,&
1191 ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb, ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
1192 ndativarattrr=ndativarattrr, &
1193 ndativarattri=ndativarattri, &
1194 ndativarattrb=ndativarattrb, &
1195 ndativarattrd=ndativarattrd, &
1196 ndativarattrc=ndativarattrc,&
1197 nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, nanavard=nanavard, nanavarc=nanavarc,&
1198 nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb, nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
1199 nanavarattrr=nanavarattrr, &
1200 nanavarattri=nanavarattri, &
1201 nanavarattrb=nanavarattrb, &
1202 nanavarattrd=nanavarattrd, &
1203 nanavarattrc=nanavarattrc)
1215 if (optio_log(anaonly))
then
1216 vol7dtmp%ana=pack_distinct(bufferana%ana, nana, back=.true.)
1218 vol7dtmp%ana=pack_distinct(buffer%ana, nana, back=.true.)
1221 vol7dtmp%time=pack_distinct(buffer%time, ntime, back=.true.)
1222 call
sort(vol7dtmp%time)
1224 vol7dtmp%timerange=pack_distinct(buffer%timerange, ntimerange, back=.true.)
1225 call
sort(vol7dtmp%timerange)
1227 vol7dtmp%level=pack_distinct(buffer%level, nlevel, back=.true.)
1228 call
sort(vol7dtmp%level)
1231 vol7dtmp%network(1)=set_network
1233 if (optio_log(anaonly))
then
1234 vol7dtmp%network=pack_distinct(bufferana%network, nnetwork, back=.true.)
1236 vol7dtmp%network=pack_distinct(buffer%network, nnetwork, back=.true.)
1242 if (any(
c_e(lvar)).and. present(varkind))
then
1250 do i=1,
size(varkind)
1251 if (varkind(i) ==
"r")
then
1253 call
init(vol7dtmp%dativar%r(ir), btable=var(i))
1255 if (varkind(i) ==
"i")
then
1257 call
init(vol7dtmp%dativar%i(ii), btable=var(i))
1259 if (varkind(i) ==
"b")
then
1261 call
init(vol7dtmp%dativar%b(ib), btable=var(i))
1263 if (varkind(i) ==
"d")
then
1265 call
init(vol7dtmp%dativar%d(id), btable=var(i))
1267 if (varkind(i) ==
"c")
then
1269 call
init(vol7dtmp%dativar%c(ic), btable=var(i))
1272 else if (any(
c_e(lvar)))
then
1274 call
init(vol7dtmp%dativar%c(i), btable=var(i))
1279 call
init(vol7dtmp%dativar%c(i))
1282 if (ndativarc > 0)
then
1283 call pack_distinct_c(buffer%btable, vol7dtmp%dativar%c%btable, back=.true.,mask=(buffer%btable /= dba_mvc))
1290 if ( present(attrkind).and. present(attr).and. any(
c_e(lvar)))
then
1300 if ( ndativarattrr > 0 )
then
1302 call
init(vol7dtmp%dativarattr%r(ir), btable=lvar(i))
1305 if ( ndativarattri > 0 )
then
1307 call
init(vol7dtmp%dativarattr%i(ii), btable=lvar(i))
1310 if ( ndativarattrb > 0 )
then
1312 call
init(vol7dtmp%dativarattr%b(ib), btable=lvar(i))
1315 if ( ndativarattrd > 0 )
then
1317 call
init(vol7dtmp%dativarattr%d(id), btable=lvar(i))
1320 if ( ndativarattrc > 0 )
then
1322 call
init(vol7dtmp%dativarattr%c(ic), btable=lvar(i))
1327 else if (present(attr).and. any(
c_e(lvar)))
then
1330 if ( ndativarattrc > 0 )call
init(vol7dtmp%dativarattr%c(i), btable=lvar(i))
1333 else if (
associated(vol7dtmp%dativarattr%c).and.
associated(vol7dtmp%dativar%c))
then
1335 vol7dtmp%dativarattr%c=vol7dtmp%dativar%c
1340 if (present(attrkind).and. lattr)
then
1348 do i=1,
size(attrkind)
1350 if (attrkind(i) ==
"r")
then
1352 call
init(vol7dtmp%datiattr%r(ir), btable=attr(i))
1354 if (attrkind(i) ==
"i")
then
1356 call
init(vol7dtmp%datiattr%i(ii), btable=attr(i))
1358 if (attrkind(i) ==
"b")
then
1360 call
init(vol7dtmp%datiattr%b(ib), btable=attr(i))
1362 if (attrkind(i) ==
"d")
then
1364 call
init(vol7dtmp%datiattr%d(id), btable=attr(i))
1366 if (attrkind(i) ==
"c")
then
1368 call
init(vol7dtmp%datiattr%c(ic), btable=attr(i))
1371 else if (present(attr))
then
1374 call
init(vol7dtmp%datiattr%c(i), btable=attr(i))
1381 if (
size(lanavar) > 0 .and. present(anavarkind))
then
1389 do i=1,
size(anavarkind)
1390 if (anavarkind(i) ==
"r")
then
1392 call
init(vol7dtmp%anavar%r(ir), btable=anavar(i))
1394 if (anavarkind(i) ==
"i")
then
1396 call
init(vol7dtmp%anavar%i(ii), btable=anavar(i))
1398 if (anavarkind(i) ==
"b")
then
1400 call
init(vol7dtmp%anavar%b(ib), btable=anavar(i))
1402 if (anavarkind(i) ==
"d")
then
1404 call
init(vol7dtmp%anavar%d(id), btable=anavar(i))
1406 if (anavarkind(i) ==
"c")
then
1408 call
init(vol7dtmp%anavar%c(ic), btable=anavar(i))
1411 else if (
size(lanavar) > 0 )
then
1414 call
init(vol7dtmp%anavar%c(i), btable=anavar(i))
1420 call
init(vol7dtmp%anavar%c(i))
1422 if (nanavarc > 0)
then
1423 call pack_distinct_c(bufferana%btable, vol7dtmp%anavar%c%btable, back=.true.,mask=(bufferana%btable /= dba_mvc))
1429 if ( present(anaattrkind) .and. present(anaattr) .and.
size(anavar) > 0 )
then
1439 if ( nanavarattrr > 0 )
then
1441 call
init(vol7dtmp%anavarattr%r(ir), btable=anavar(i))
1444 if ( nanavarattri > 0 )
then
1446 call
init(vol7dtmp%anavarattr%i(ii), btable=anavar(i))
1449 if ( nanavarattrb > 0 )
then
1451 call
init(vol7dtmp%anavarattr%b(ib), btable=anavar(i))
1454 if ( nanavarattrd > 0 )
then
1456 call
init(vol7dtmp%anavarattr%d(id), btable=anavar(i))
1459 if ( nanavarattrc > 0 )
then
1461 call
init(vol7dtmp%anavarattr%c(ic), btable=anavar(i))
1466 else if (present(anaattr) .and.
size(anavar) > 0 )
then
1469 if ( nanavarattrc > 0 )call
init(vol7dtmp%anavarattr%c(i), btable=anavar(i))
1472 else if (
associated(vol7dtmp%anavarattr%c) .and.
associated(vol7dtmp%anavar%c))
then
1474 vol7dtmp%anavarattr%c=vol7dtmp%anavar%c
1479 if (present(anaattrkind).and. present(anaattr))
then
1487 do i=1,
size(anaattrkind)
1489 if (anaattrkind(i) ==
"r")
then
1491 call
init(vol7dtmp%anaattr%r(ir), btable=anaattr(i))
1493 if (anaattrkind(i) ==
"i")
then
1495 call
init(vol7dtmp%anaattr%i(ii), btable=anaattr(i))
1497 if (anaattrkind(i) ==
"b")
then
1499 call
init(vol7dtmp%anaattr%b(ib), btable=anaattr(i))
1501 if (anaattrkind(i) ==
"d")
then
1503 call
init(vol7dtmp%anaattr%d(id), btable=anaattr(i))
1505 if (anaattrkind(i) ==
"c")
then
1507 call
init(vol7dtmp%anaattr%c(ic), btable=anaattr(i))
1510 else if (present(anaattr))
then
1512 do i=1,
size(anaattr)
1513 call
init(vol7dtmp%anaattr%c(i), btable=anaattr(i))
1526 call vol7d_alloc_vol(vol7dtmp)
1530 allocate (this%data_id( nana, ntime, nlevel, ntimerange, nnetwork),stat=istat)
1533 //trim(
to_char(nana*ntime*nlevel*ntimerange*nnetwork))//
' data_id elements')
1534 CALL raise_fatal_error()
1538 this%data_id=dba_mvi
1542 nullify(this%data_id)
1559 IF (
SIZE(attr) > maxvarlist)
THEN
1560 CALL
l4f_category_log(this%category,l4f_error,
"too many attributes requested: "//
t2c(
SIZE(attr)))
1561 call raise_fatal_error()
1567 DO ii = 1,
SIZE(attr)
1568 nvarattr = nvarattr + 1
1569 IF (nvarattr > 1) starvarlist(len_trim(starvarlist)+1:) =
','
1570 starvarlist(len_trim(starvarlist)+1:) = trim(attr(ii))
1578 indana = firsttrue(buffer(i)%ana == vol7dtmp%ana)
1579 indtime = firsttrue(buffer(i)%time == vol7dtmp%time)
1580 indtimerange = firsttrue(buffer(i)%timerange == vol7dtmp%timerange)
1581 indlevel = firsttrue(buffer(i)%level == vol7dtmp%level)
1585 indnetwork = firsttrue(buffer(i)%network == vol7dtmp%network)
1589 if(
c_e(buffer(i)%dator))
then
1590 inddativar = firsttrue(buffer(i)%btable == vol7dtmp%dativar%r%btable)
1591 vol7dtmp%voldatir( &
1592 indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
1596 if(
c_e(buffer(i)%datoi))
then
1597 inddativar = firsttrue(buffer(i)%btable == vol7dtmp%dativar%i%btable)
1598 vol7dtmp%voldatii( &
1599 indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
1603 if(
c_e(buffer(i)%datob))
then
1604 inddativar = firsttrue(buffer(i)%btable == vol7dtmp%dativar%b%btable)
1605 vol7dtmp%voldatib( &
1606 indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
1610 if(
c_e(buffer(i)%datod))
then
1611 inddativar = firsttrue(buffer(i)%btable == vol7dtmp%dativar%d%btable)
1612 vol7dtmp%voldatid( &
1613 indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
1617 if(
c_e(buffer(i)%datoc))
then
1618 inddativar = firsttrue(buffer(i)%btable == vol7dtmp%dativar%c%btable)
1619 vol7dtmp%voldatic( &
1620 indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
1631 this%data_id(indana,indtime,indlevel,indtimerange,indnetwork)=buffer(i)%data_id
1633 ier=idba_unsetall(this%handle)
1637 ier=idba_set(this%handle,
"*context_id",buffer(i)%data_id)
1638 ier=idba_set(this%handle,
"*var_related",buffer(i)%btable)
1640 ier=idba_set(this%handle,
"*varlist",starvarlist )
1641 ier=idba_voglioancora(this%handle,nn)
1645 ier=idba_ancora(this%handle,starbtable)
1647 indattr = firsttrue(attr == starbtable)
1648 IF (indattr<1) cycle
1650 call
init(var_tmp, btable=starbtable)
1652 if (present(attrkind))
then
1653 iii=( firsttrue(attr == starbtable))
1658 if(attrkind(iii) ==
"r")
then
1659 inddativarattr = firsttrue(buffer(i)%btable == vol7dtmp%dativarattr%r%btable)
1660 inddatiattr = firsttrue(var_tmp == vol7dtmp%datiattr%r)
1661 ier=idba_enq(this%handle,starbtable,&
1662 vol7dtmp%voldatiattrr(indana,indtime,indlevel,indtimerange,&
1663 inddativarattr,indnetwork,inddatiattr))
1665 if(attrkind(iii) ==
"i")
then
1666 inddativarattr = firsttrue(buffer(i)%btable == vol7dtmp%dativarattr%i%btable)
1667 inddatiattr = firsttrue(var_tmp == vol7dtmp%datiattr%i)
1668 ier=idba_enq(this%handle,starbtable,&
1669 vol7dtmp%voldatiattri(indana,indtime,indlevel,indtimerange,&
1670 inddativarattr,indnetwork,inddatiattr))
1672 if(attrkind(iii) ==
"b")
then
1673 inddativarattr = firsttrue(buffer(i)%btable == vol7dtmp%dativarattr%b%btable)
1674 inddatiattr = firsttrue(var_tmp == vol7dtmp%datiattr%b)
1677 ier=idba_enq(this%handle,starbtable,&
1678 vol7dtmp%voldatiattrb(indana,indtime,indlevel,indtimerange,&
1679 inddativarattr,indnetwork,inddatiattr))
1681 if(attrkind(iii) ==
"d")
then
1682 inddativarattr = firsttrue(buffer(i)%btable == vol7dtmp%dativarattr%d%btable)
1683 inddatiattr = firsttrue(var_tmp == vol7dtmp%datiattr%d)
1684 ier=idba_enq(this%handle,starbtable,&
1685 vol7dtmp%voldatiattrd(indana,indtime,indlevel,indtimerange,&
1686 inddativarattr,indnetwork,inddatiattr))
1688 if(attrkind(iii) ==
"c")
then
1689 inddativarattr = firsttrue(buffer(i)%btable == vol7dtmp%dativarattr%c%btable)
1690 inddatiattr = firsttrue(var_tmp == vol7dtmp%datiattr%c)
1691 ier=idba_enq(this%handle,starbtable,&
1692 vol7dtmp%voldatiattrc(indana,indtime,indlevel,indtimerange,&
1693 inddativarattr,indnetwork,inddatiattr))
1698 inddativarattr = firsttrue(buffer(i)%btable == vol7dtmp%dativarattr%c%btable)
1699 inddatiattr = firsttrue(var_tmp == vol7dtmp%datiattr%c)
1700 ier=idba_enq(this%handle,starbtable,&
1701 vol7dtmp%voldatiattrc(indana,indtime,indlevel,indtimerange,&
1702 inddativarattr,indnetwork,inddatiattr))
1722 DO ii = 1,
SIZE(anaattr)
1723 nanavarattr = nanavarattr + 1
1724 IF (nanavarattr > 1) starvarlist(len_trim(starvarlist)+1:) =
','
1725 starvarlist(len_trim(starvarlist)+1:) = trim(anaattr(ii))
1733 indana = firsttrue(bufferana(i)%ana == vol7dtmp%ana)
1738 indnetwork = firsttrue(bufferana(i)%network == vol7dtmp%network)
1741 if (indana < 1 .or. indnetwork < 1 )cycle
1745 if(
c_e(bufferana(i)%dator))
then
1746 indanavar = firsttrue(bufferana(i)%btable == vol7dtmp%anavar%r%btable)
1747 vol7dtmp%volanar( indana,indanavar,indnetwork ) = bufferana(i)%dator
1749 if(
c_e(bufferana(i)%datoi))
then
1750 indanavar = firsttrue(bufferana(i)%btable == vol7dtmp%anavar%i%btable)
1751 vol7dtmp%volanai( indana,indanavar,indnetwork ) = bufferana(i)%datoi
1753 if(
c_e(bufferana(i)%datob))
then
1754 indanavar = firsttrue(bufferana(i)%btable == vol7dtmp%anavar%b%btable)
1755 vol7dtmp%volanab( indana,indanavar,indnetwork ) = bufferana(i)%datob
1757 if(
c_e(bufferana(i)%datod))
then
1758 indanavar = firsttrue(bufferana(i)%btable == vol7dtmp%anavar%d%btable)
1759 vol7dtmp%volanad( indana,indanavar,indnetwork ) = bufferana(i)%datod
1761 if(
c_e(bufferana(i)%datoc))
then
1762 indanavar = firsttrue(bufferana(i)%btable == vol7dtmp%anavar%c%btable)
1763 vol7dtmp%volanac( indana,indanavar,indnetwork ) = bufferana(i)%datoc
1772 ier=idba_unsetall(this%handle_staz)
1773 ier=idba_set(this%handle_staz,
"*context_id",bufferana(i)%data_id)
1774 ier=idba_set(this%handle_staz,
"*var_related",bufferana(i)%btable)
1777 ier=idba_set(this%handle_staz,
"*varlist",starvarlist )
1778 ier=idba_voglioancora(this%handle_staz,nn)
1782 ier=idba_ancora(this%handle_staz,starbtable)
1784 indattr = firsttrue(anaattr == starbtable)
1785 IF (indattr<1) cycle
1788 call
init(var_tmp, btable=starbtable)
1791 if (present(anaattrkind))
then
1792 iii=( firsttrue(anaattr == starbtable))
1796 if(anaattrkind(iii) ==
"r")
then
1797 indanavarattr = firsttrue(bufferana(i)%btable == vol7dtmp%anavarattr%r%btable)
1798 indanaattr = firsttrue(var_tmp == vol7dtmp%anaattr%r)
1799 ier=idba_enq(this%handle_staz,starbtable,&
1800 vol7dtmp%volanaattrr(indana,indanavarattr,indnetwork,indanaattr))
1802 if(anaattrkind(iii) ==
"i")
then
1803 indanavarattr = firsttrue(bufferana(i)%btable == vol7dtmp%anavarattr%i%btable)
1804 indanaattr = firsttrue(var_tmp == vol7dtmp%anaattr%i)
1805 ier=idba_enq(this%handle_staz,starbtable,&
1806 vol7dtmp%volanaattri(indana,indanavarattr,indnetwork,indanaattr))
1808 if(anaattrkind(iii) ==
"b")
then
1809 indanavarattr = firsttrue(bufferana(i)%btable == vol7dtmp%anavarattr%b%btable)
1810 indanaattr = firsttrue(var_tmp == vol7dtmp%anaattr%b)
1811 ier=idba_enq(this%handle_staz,starbtable,&
1812 vol7dtmp%volanaattrb(indana,indanavarattr,indnetwork,indanaattr))
1814 if(anaattrkind(iii) ==
"d")
then
1815 indanavarattr = firsttrue(bufferana(i)%btable == vol7dtmp%anavarattr%d%btable)
1816 indanaattr = firsttrue(var_tmp == vol7dtmp%anaattr%d)
1817 ier=idba_enq(this%handle_staz,starbtable,&
1818 vol7dtmp%volanaattrd(indana,indanavarattr,indnetwork,indanaattr))
1820 if(anaattrkind(iii) ==
"c")
then
1821 indanavarattr = firsttrue(bufferana(i)%btable == vol7dtmp%anavarattr%c%btable)
1822 indanaattr = firsttrue(var_tmp == vol7dtmp%anaattr%c)
1823 ier=idba_enq(this%handle_staz,starbtable,&
1824 vol7dtmp%volanaattrc(indana,indanavarattr,indnetwork,indanaattr))
1829 indanavarattr = firsttrue(bufferana(i)%btable == vol7dtmp%anavarattr%c%btable)
1830 indanaattr = firsttrue(var_tmp == vol7dtmp%anaattr%c)
1831 ier=idba_enq(this%handle,starbtable,&
1832 vol7dtmp%volanaattrc(indana,indanavarattr,indnetwork,indanaattr))
1843 deallocate (bufferana)
1846 CALL vol7d_merge(this%vol7d, vol7dtmp,
sort=.true.)
1850 call vol7d_set_attr_ind(this%vol7d)
1852 call vol7d_dballe_set_var_du(this%vol7d)
1866 deallocate(lvar,lanavar)
1869 END SUBROUTINE vol7d_dballe_importvvns_dba
1880 SUBROUTINE vol7d_dballe_export(this, network, coordmin, coordmax,&
1881 timei, timef,level,timerange,var,attr,anavar,anaattr,attr_only,template,ana)
1884 character(len=network_name_len),
INTENT(in),
optional :: network
1887 type(geo_coord),
INTENT(in),
optional :: coordmin,coordmax
1888 TYPE(vol7d_ana
),
INTENT(inout),
optional :: ana
1890 type(datetime),
INTENT(in),
optional :: timei, timef
1891 TYPE(vol7d_level
),
INTENT(in),
optional :: level
1892 type(vol7d_timerange),
INTENT(in),
optional :: timerange
1895 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: var(:),attr(:),anavar(:),anaattr(:)
1899 logical,
intent(in),
optional :: attr_only
1902 character(len=*),
intent(in),
optional :: template
1943 logical,
allocatable :: lnetwork(:),llevel(:),ltimerange(:)
1944 integer,
allocatable :: ana_id(:,:)
1945 logical :: write,writeattr,lattr_only, generic_frag
1946 character(len=80) :: ltemplate
1951 integer :: year,month,day,hour,minute,sec,msec
1952 integer :: nstaz,ntime,ntimerange,nlevel,nnetwork
1955 INTEGER :: i,ii,iii,iiii,iiiii,iiiiii,a,ind,inddatiattr,indanaattr,ier
1957 INTEGER(kind=int_l) :: ilat,ilon
1961 integer :: ndativarr,ndatiattrr
1962 integer :: ndativari,ndatiattri
1963 integer :: ndativarb,ndatiattrb
1964 integer :: ndativard,ndatiattrd
1965 integer :: ndativarc,ndatiattrc
1967 integer :: nanavarr,nanaattrr
1968 integer :: nanavari,nanaattri
1969 integer :: nanavarb,nanaattrb
1970 integer :: nanavard,nanaattrd
1971 integer :: nanavarc,nanaattrc
1973 logical,
allocatable :: lvarr(:),lattrr(:)
1974 logical,
allocatable :: lvari(:),lattri(:)
1975 logical,
allocatable :: lvarb(:),lattrb(:)
1976 logical,
allocatable :: lvard(:),lattrd(:)
1977 logical,
allocatable :: lvarc(:),lattrc(:)
1979 logical,
allocatable :: lanavarr(:),lanaattrr(:)
1980 logical,
allocatable :: lanavari(:),lanaattri(:)
1981 logical,
allocatable :: lanavarb(:),lanaattrb(:)
1982 logical,
allocatable :: lanavard(:),lanaattrd(:)
1983 logical,
allocatable :: lanavarc(:),lanaattrc(:)
2008 call vol7d_alloc_vol(this%vol7d)
2009 nstaz=
size(this%vol7d%ana(:))
2011 ntimerange=
size(this%vol7d%timerange(:))
2012 allocate (ltimerange(ntimerange))
2015 if (present(timerange))
then
2016 where (timerange == this%vol7d%timerange(:))
2017 ltimerange(:)=.true.
2023 nlevel=
size(this%vol7d%level(:))
2024 allocate (llevel(nlevel))
2027 if (present(level))
then
2028 where (level == this%vol7d%level(:))
2035 if (present(attr_only))
then
2036 lattr_only=attr_only
2041 if ( .not.
associated(this%data_id))
then
2046 nnetwork=
size(this%vol7d%network(:))
2047 ntime=
size(this%vol7d%time(:))
2049 allocate (lnetwork(nnetwork))
2051 allocate (ana_id(nstaz,nnetwork))
2055 if (present(network))
then
2056 where (network == this%vol7d%network(:)%name)
2063 ltemplate=optio_c(template,len(ltemplate))
2064 if (template ==
"generic-frag")
then
2069 generic_frag=.false.
2076 #undef VOL7D_POLY_TYPES_V
2077 #define VOL7D_POLY_TYPES_V r
2081 #include "vol7d_dballe_class_nana.F90"
2082 #undef VOL7D_POLY_TYPES_V
2083 #define VOL7D_POLY_TYPES_V i
2087 #include "vol7d_dballe_class_nana.F90"
2088 #undef VOL7D_POLY_TYPES_V
2089 #define VOL7D_POLY_TYPES_V b
2093 #include "vol7d_dballe_class_nana.F90"
2094 #undef VOL7D_POLY_TYPES_V
2095 #define VOL7D_POLY_TYPES_V d
2099 #include "vol7d_dballe_class_nana.F90"
2100 #undef VOL7D_POLY_TYPES_V
2101 #define VOL7D_POLY_TYPES_V c
2105 #include "vol7d_dballe_class_nana.F90"
2106 #undef VOL7D_POLY_TYPES_V
2111 #undef VOL7D_POLY_TYPES_V
2112 #define VOL7D_POLY_TYPES_V r
2116 #include "vol7d_dballe_class_ndati.F90"
2117 #undef VOL7D_POLY_TYPES_V
2118 #define VOL7D_POLY_TYPES_V i
2122 #include "vol7d_dballe_class_ndati.F90"
2123 #undef VOL7D_POLY_TYPES_V
2124 #define VOL7D_POLY_TYPES_V b
2128 #include "vol7d_dballe_class_ndati.F90"
2129 #undef VOL7D_POLY_TYPES_V
2130 #define VOL7D_POLY_TYPES_V d
2134 #include "vol7d_dballe_class_ndati.F90"
2135 #undef VOL7D_POLY_TYPES_V
2136 #define VOL7D_POLY_TYPES_V c
2140 #include "vol7d_dballe_class_ndati.F90"
2141 #undef VOL7D_POLY_TYPES_V
2148 do iiiiii=1, nnetwork
2149 if (.not.lnetwork(iiiiii))cycle
2152 if (this%file .and. .not. generic_frag .and. ntime > 0 ) cycle
2156 if (present(coordmin).and.present(coordmax))
then
2157 if (.not.
inside(this%vol7d%ana(i)%coord,coordmin,coordmax)) cycle
2160 CALL
getval(this%vol7d%ana(i)%coord, ilat=ilat,ilon=ilon)
2161 ier=idba_unsetall(this%handle)
2165 ier=idba_setcontextana(this%handle)
2167 ier=idba_set(this%handle,
"lat",ilat)
2168 ier=idba_set(this%handle,
"lon",ilon)
2170 if (present(ana))
then
2171 if (
c_e(ana%ident) .and. ana%ident /= this%vol7d%ana(i)%ident ) cycle
2172 if (
c_e(ana%coord) .and. ana%coord /= this%vol7d%ana(i)%coord ) cycle
2182 if (
c_e(this%vol7d%ana(i)%ident))
then
2184 call
l4f_category_log(this%category,l4f_debug,
"I have found a mobile station! ident: "//&
2185 this%vol7d%ana(i)%ident)
2187 ier=idba_set(this%handle,
"ident",this%vol7d%ana(i)%ident)
2188 ier=idba_set(this%handle,
"mobile",1)
2190 ier=idba_set(this%handle,
"mobile",0)
2193 ier=idba_set(this%handle,
"rep_memo",this%vol7d%network(iiiiii)%name)
2197 #undef VOL7D_POLY_TYPES_V
2198 #define VOL7D_POLY_TYPES_V r
2200 #include "vol7d_dballe_class_ana.F90"
2201 #undef VOL7D_POLY_TYPES_V
2202 #define VOL7D_POLY_TYPES_V i
2204 #include "vol7d_dballe_class_ana.F90"
2205 #undef VOL7D_POLY_TYPES_V
2206 #define VOL7D_POLY_TYPES_V b
2208 #include "vol7d_dballe_class_ana.F90"
2209 #undef VOL7D_POLY_TYPES_V
2210 #define VOL7D_POLY_TYPES_V d
2212 #include "vol7d_dballe_class_ana.F90"
2213 #undef VOL7D_POLY_TYPES_V
2214 #define VOL7D_POLY_TYPES_V c
2216 #include "vol7d_dballe_class_ana.F90"
2217 #undef VOL7D_POLY_TYPES_V
2221 if (
write .or. generic_frag)
then
2223 if (
c_e(ltemplate))
then
2224 ier=idba_set(this%handle,
"query",
"message "//trim(ltemplate))
2226 ier=idba_set(this%handle,
"query",
"message")
2230 call
l4f_category_log(this%category,l4f_debug,
"eseguo una main prendilo di anagrafica")
2232 ier=idba_prendilo(this%handle)
2239 call
l4f_category_log(this%category,l4f_debug,
"eseguo una main prendilo di anagrafica")
2241 ier=idba_prendilo(this%handle)
2242 ier=idba_enq(this%handle,
"*ana_id",ana_id(i,iiiiii))
2247 if (
c_e(this%vol7d%anavar%r(ii)%btable))ier=idba_unset(this%handle,this%vol7d%anavar%r(ii)%btable )
2249 call
l4f_category_log(this%category,l4f_debug,
"unset ana: "//this%vol7d%anavar%r(ii)%btable)
2253 if (
c_e(this%vol7d%anavar%i(ii)%btable))ier=idba_unset(this%handle,this%vol7d%anavar%i(ii)%btable )
2255 call
l4f_category_log(this%category,l4f_debug,
"unset ana: "//this%vol7d%anavar%i(ii)%btable)
2259 if (
c_e(this%vol7d%anavar%b(ii)%btable))ier=idba_unset(this%handle,this%vol7d%anavar%b(ii)%btable )
2261 call
l4f_category_log(this%category,l4f_debug,
"unset ana: "//this%vol7d%anavar%b(ii)%btable)
2265 if (
c_e(this%vol7d%anavar%d(ii)%btable))ier=idba_unset(this%handle,this%vol7d%anavar%d(ii)%btable )
2267 call
l4f_category_log(this%category,l4f_debug,
"unset ana: "//this%vol7d%anavar%d(ii)%btable)
2271 if (
c_e(this%vol7d%anavar%c(ii)%btable))ier=idba_unset(this%handle,this%vol7d%anavar%c(ii)%btable )
2273 call
l4f_category_log(this%category,l4f_debug,
"unset ana: "//this%vol7d%anavar%c(ii)%btable)
2285 do iiiiii=1, nnetwork
2286 if (.not.lnetwork(iiiiii))cycle
2290 if ( (.not. this%file) .and. (.not.
c_e(ana_id(i,iiiiii))) ) cycle
2291 if (present(coordmin).and.present(coordmax))
then
2292 if (.not.
inside(this%vol7d%ana(i)%coord,coordmin,coordmax)) cycle
2296 if (present(timei) )
then
2297 if ( this%vol7d%time(ii) < timei ) cycle
2299 if (present(timef) )
then
2300 if ( this%vol7d%time(ii) > timef ) cycle
2304 ier=idba_unsetall(this%handle)
2309 ier=idba_set(this%handle,
"rep_memo",this%vol7d%network(iiiiii)%name)
2311 CALL
l4f_category_log(this%category,l4f_debug,
'set rep_memo:'//this%vol7d%network(iiiiii)%name)
2316 call
getval(this%vol7d%ana(i)%coord, ilat=ilat,ilon=ilon)
2317 ier=idba_set(this%handle,
"lat",ilat)
2318 ier=idba_set(this%handle,
"lon",ilon)
2323 if (present(ana))
then
2324 if (
c_e(ana%ident) .and. ana%ident /= this%vol7d%ana(i)%ident ) cycle
2325 if (
c_e(ana%coord) .and. ana%coord /= this%vol7d%ana(i)%coord ) cycle
2328 if (
c_e(this%vol7d%ana(i)%ident))
then
2329 ier=idba_set(this%handle,
"ident",this%vol7d%ana(i)%ident)
2330 ier=idba_set(this%handle,
"mobile",1)
2332 call
l4f_category_log(this%category,l4f_debug,
"there is a mobile station! identity: "&
2333 //this%vol7d%ana(i)%ident)
2336 ier=idba_set(this%handle,
"mobile",0)
2341 if (.not. generic_frag)
then
2346 ier=idba_setcontextana(this%handle)
2350 #undef VOL7D_POLY_TYPES_V
2351 #define VOL7D_POLY_TYPES_V r
2353 #include "vol7d_dballe_class_ana.F90"
2354 #undef VOL7D_POLY_TYPES_V
2355 #define VOL7D_POLY_TYPES_V i
2357 #include "vol7d_dballe_class_ana.F90"
2358 #undef VOL7D_POLY_TYPES_V
2359 #define VOL7D_POLY_TYPES_V b
2361 #include "vol7d_dballe_class_ana.F90"
2362 #undef VOL7D_POLY_TYPES_V
2363 #define VOL7D_POLY_TYPES_V d
2365 #include "vol7d_dballe_class_ana.F90"
2366 #undef VOL7D_POLY_TYPES_V
2367 #define VOL7D_POLY_TYPES_V c
2369 #include "vol7d_dballe_class_ana.F90"
2370 #undef VOL7D_POLY_TYPES_V
2375 call
l4f_category_log(this%category,l4f_debug,
"eseguo una main prendilo di anagrafica")
2377 ier=idba_prendilo(this%handle)
2386 ier=idba_set(this%handle,
"ana_id",ana_id(i,iiiiii))
2389 CALL
getval(this%vol7d%time(ii), year=year, month=month, day=day, hour=hour, minute=minute,msec=msec)
2390 sec=nint(float(msec)/1000.)
2395 ier=idba_setdate(this%handle,year,month,day,hour,minute,sec)
2398 if (.not.llevel(iii))cycle
2400 do iiii=1,ntimerange
2401 if (.not.ltimerange(iiii))cycle
2403 if (.not. lattr_only)
then
2406 ier=idba_setlevel(this%handle, this%vol7d%level(iii)%level1, this%vol7d%level(iii)%l1,&
2407 this%vol7d%level(iii)%level2, this%vol7d%level(iii)%l2)
2416 ier=idba_settimerange(this%handle, this%vol7d%timerange(iiii)%timerange, &
2417 this%vol7d%timerange(iiii)%p1, this%vol7d%timerange(iiii)%p2)
2435 #undef VOL7D_POLY_TYPES_V
2436 #define VOL7D_POLY_TYPES_V r
2440 #include "vol7d_dballe_class_dati.F90"
2441 #undef VOL7D_POLY_TYPES_V
2442 #define VOL7D_POLY_TYPES_V i
2446 #include "vol7d_dballe_class_dati.F90"
2447 #undef VOL7D_POLY_TYPES_V
2448 #define VOL7D_POLY_TYPES_V b
2452 #include "vol7d_dballe_class_dati.F90"
2453 #undef VOL7D_POLY_TYPES_V
2454 #define VOL7D_POLY_TYPES_V d
2458 #include "vol7d_dballe_class_dati.F90"
2459 #undef VOL7D_POLY_TYPES_V
2460 #define VOL7D_POLY_TYPES_V c
2464 #include "vol7d_dballe_class_dati.F90"
2465 #undef VOL7D_POLY_TYPES_V
2483 call
l4f_category_log(this%category,l4f_debug,
"eseguo una main prendilo sui dati")
2485 ier=idba_prendilo(this%handle)
2492 if (this%file .and. .not. generic_frag)
then
2495 if (
c_e(this%vol7d%anavar%r(a)%btable))ier=idba_unset(this%handle,this%vol7d%anavar%r(a)%btable )
2497 call
l4f_category_log(this%category,l4f_debug,
"unset ana: "//this%vol7d%anavar%r(a)%btable)
2501 if (
c_e(this%vol7d%anavar%i(a)%btable))ier=idba_unset(this%handle,this%vol7d%anavar%i(a)%btable )
2503 call
l4f_category_log(this%category,l4f_debug,
"unset ana: "//this%vol7d%anavar%i(a)%btable)
2507 if (
c_e(this%vol7d%anavar%b(a)%btable))ier=idba_unset(this%handle,this%vol7d%anavar%b(a)%btable )
2509 call
l4f_category_log(this%category,l4f_debug,
"unset ana: "//this%vol7d%anavar%b(a)%btable)
2513 if (
c_e(this%vol7d%anavar%d(a)%btable))ier=idba_unset(this%handle,this%vol7d%anavar%d(a)%btable )
2515 call
l4f_category_log(this%category,l4f_debug,
"unset ana: "//this%vol7d%anavar%d(a)%btable)
2519 if (
c_e(this%vol7d%anavar%c(a)%btable))ier=idba_unset(this%handle,this%vol7d%anavar%c(a)%btable )
2521 call
l4f_category_log(this%category,l4f_debug,
"unset ana: "//this%vol7d%anavar%c(a)%btable)
2529 do iiiii=1,ndativarr
2530 if(
c_e(this%vol7d%dativar%r(iiiii)%btable))ier=idba_unset(this%handle,this%vol7d%dativar%r(iiiii)%btable )
2532 call
l4f_category_log(this%category,l4f_debug,
"unset dati: "//this%vol7d%dativar%r(iiiii)%btable)
2535 do iiiii=1,ndativari
2536 if(
c_e(this%vol7d%dativar%i(iiiii)%btable))ier=idba_unset(this%handle,this%vol7d%dativar%i(iiiii)%btable )
2538 call
l4f_category_log(this%category,l4f_debug,
"unset dati: "//this%vol7d%dativar%i(iiiii)%btable)
2541 do iiiii=1,ndativarb
2542 if(
c_e(this%vol7d%dativar%b(iiiii)%btable))ier=idba_unset(this%handle,this%vol7d%dativar%b(iiiii)%btable )
2544 call
l4f_category_log(this%category,l4f_debug,
"unset dati: "//this%vol7d%dativar%b(iiiii)%btable)
2547 do iiiii=1,ndativard
2548 if(
c_e(this%vol7d%dativar%d(iiiii)%btable))ier=idba_unset(this%handle,this%vol7d%dativar%d(iiiii)%btable )
2550 call
l4f_category_log(this%category,l4f_debug,
"unset dati: "//this%vol7d%dativar%d(iiiii)%btable)
2553 do iiiii=1,ndativarc
2554 if(
c_e(this%vol7d%dativar%c(iiiii)%btable))ier=idba_unset(this%handle,this%vol7d%dativar%c(iiiii)%btable )
2556 call
l4f_category_log(this%category,l4f_debug,
"unset dati: "//this%vol7d%dativar%c(iiiii)%btable)
2565 if (
c_e(ltemplate))
then
2566 ier=idba_set(this%handle,
"query",
"message "//trim(ltemplate))
2568 ier=idba_set(this%handle,
"query",
"message")
2574 call
l4f_category_log(this%category,l4f_debug,
"eseguo una main prendilo sui dati")
2576 ier=idba_prendilo(this%handle)
2583 END SUBROUTINE vol7d_dballe_export
2588 SUBROUTINE vol7d_dballe_delete(this, preserveidbhandle)
2590 logical,
intent(in),
optional :: preserveidbhandle
2595 ier=idba_fatto(this%handle)
2599 ier=idba_fatto(this%handle)
2600 ier=idba_fatto(this%handle_staz)
2601 if (.not. optio_log(preserveidbhandle)) ier=idba_arrivederci(this%idbhandle)
2605 ier=idba_error_remove_callback(this%handle_err)
2610 this%idbhandle=imiss
2612 this%handle_err=imiss
2613 this%handle_staz=imiss
2615 if (
associated(this%data_id))
then
2616 deallocate (this%data_id)
2617 nullify(this%data_id)
2622 call l4f_category_delete(this%category)
2625 END SUBROUTINE vol7d_dballe_delete
2629 subroutine vol7d_dballe_import_dballevar(this)
2631 type(vol7d_var
),
pointer :: this(:)
2634 IF (
associated(this))
return
2635 IF (
allocated(blocal))
then
2636 ALLOCATE(this(
size(blocal)))
2641 un = open_dballe_file(
'dballe.txt', filetype_data)
2644 call l4f_log(l4f_error,
"error open_dballe_file: dballe.txt")
2645 CALL raise_error(
"error open_dballe_file: dballe.txt")
2660 readline:
do i = 1 ,n
2661 READ(un,
'(1x,A6,1x,a65,a24,i4)')blocal(i)%btable,blocal(i)%description,blocal(i)%unit,&
2662 blocal(i)%scalefactor
2663 blocal(i)%btable(:1)=
"B"
2670 CALL l4f_log(l4f_info,
'Found '//trim(
to_char(i-1))//
' variables in dballe master table')
2677 END SUBROUTINE vol7d_dballe_import_dballevar
2684 subroutine vol7d_dballe_set_var_du(this)
2688 type(vol7d_var
),
pointer :: dballevar(:)
2691 call vol7d_dballe_import_dballevar(dballevar)
2693 #undef VOL7D_POLY_NAME
2694 #define VOL7D_POLY_NAME dativar
2697 #undef VOL7D_POLY_TYPES_V
2698 #define VOL7D_POLY_TYPES_V r
2699 #include "vol7d_dballe_class_var_du.F90"
2700 #undef VOL7D_POLY_TYPES_V
2701 #define VOL7D_POLY_TYPES_V i
2702 #include "vol7d_dballe_class_var_du.F90"
2703 #undef VOL7D_POLY_TYPES_V
2704 #define VOL7D_POLY_TYPES_V b
2705 #include "vol7d_dballe_class_var_du.F90"
2706 #undef VOL7D_POLY_TYPES_V
2707 #define VOL7D_POLY_TYPES_V d
2708 #include "vol7d_dballe_class_var_du.F90"
2709 #undef VOL7D_POLY_TYPES_V
2710 #define VOL7D_POLY_TYPES_V c
2711 #include "vol7d_dballe_class_var_du.F90"
2712 #undef VOL7D_POLY_TYPES_V
2714 #undef VOL7D_POLY_NAME
2715 #define VOL7D_POLY_NAME anavar
2718 #undef VOL7D_POLY_TYPES_V
2719 #define VOL7D_POLY_TYPES_V r
2720 #include "vol7d_dballe_class_var_du.F90"
2721 #undef VOL7D_POLY_TYPES_V
2722 #define VOL7D_POLY_TYPES_V i
2723 #include "vol7d_dballe_class_var_du.F90"
2724 #undef VOL7D_POLY_TYPES_V
2725 #define VOL7D_POLY_TYPES_V b
2726 #include "vol7d_dballe_class_var_du.F90"
2727 #undef VOL7D_POLY_TYPES_V
2728 #define VOL7D_POLY_TYPES_V d
2729 #include "vol7d_dballe_class_var_du.F90"
2730 #undef VOL7D_POLY_TYPES_V
2731 #define VOL7D_POLY_TYPES_V c
2732 #include "vol7d_dballe_class_var_du.F90"
2733 #undef VOL7D_POLY_TYPES_V
2736 #undef VOL7D_POLY_NAME
2737 #define VOL7D_POLY_NAME datiattr
2740 #undef VOL7D_POLY_TYPES_V
2741 #define VOL7D_POLY_TYPES_V r
2742 #include "vol7d_dballe_class_var_du.F90"
2743 #undef VOL7D_POLY_TYPES_V
2744 #define VOL7D_POLY_TYPES_V i
2745 #include "vol7d_dballe_class_var_du.F90"
2746 #undef VOL7D_POLY_TYPES_V
2747 #define VOL7D_POLY_TYPES_V b
2748 #include "vol7d_dballe_class_var_du.F90"
2749 #undef VOL7D_POLY_TYPES_V
2750 #define VOL7D_POLY_TYPES_V d
2751 #include "vol7d_dballe_class_var_du.F90"
2752 #undef VOL7D_POLY_TYPES_V
2753 #define VOL7D_POLY_TYPES_V c
2754 #include "vol7d_dballe_class_var_du.F90"
2755 #undef VOL7D_POLY_TYPES_V
2758 #undef VOL7D_POLY_NAME
2759 #define VOL7D_POLY_NAME anaattr
2762 #undef VOL7D_POLY_TYPES_V
2763 #define VOL7D_POLY_TYPES_V r
2764 #include "vol7d_dballe_class_var_du.F90"
2765 #undef VOL7D_POLY_TYPES_V
2766 #define VOL7D_POLY_TYPES_V i
2767 #include "vol7d_dballe_class_var_du.F90"
2768 #undef VOL7D_POLY_TYPES_V
2769 #define VOL7D_POLY_TYPES_V b
2770 #include "vol7d_dballe_class_var_du.F90"
2771 #undef VOL7D_POLY_TYPES_V
2772 #define VOL7D_POLY_TYPES_V d
2773 #include "vol7d_dballe_class_var_du.F90"
2774 #undef VOL7D_POLY_TYPES_V
2775 #define VOL7D_POLY_TYPES_V c
2776 #include "vol7d_dballe_class_var_du.F90"
2777 #undef VOL7D_POLY_TYPES_V
2780 deallocate(dballevar)
2784 end subroutine vol7d_dballe_set_var_du
2788 FUNCTION get_dballe_filepath(filename, filetype) RESULT(path)
2789 CHARACTER(len=*),
INTENT(in) :: filename
2790 INTEGER,
INTENT(in) :: filetype
2793 CHARACTER(len=512) :: path
2796 IF (dballe_name ==
' ')
THEN
2797 CALL getarg(0, dballe_name)
2801 IF (filetype < 1 .OR. filetype > nftype)
THEN
2803 CALL l4f_log(l4f_error,
'dballe file type '//trim(
to_char(filetype))// &
2810 CALL getenv(trim(dballe_name_env), path)
2811 IF (path /=
' ')
THEN
2813 path=trim(path)//
'/'//filename
2814 INQUIRE(file=path, exist=exist)
2816 CALL l4f_log(l4f_info,
'dballe file '//trim(path)//
' found')
2821 DO j = 1,
SIZE(pathlist,1)
2822 IF (pathlist(j,filetype) ==
' ')
EXIT
2823 path=trim(pathlist(j,filetype))//
'/'//trim(dballe_name)//
'/'//filename
2824 INQUIRE(file=path, exist=exist)
2826 CALL l4f_log(l4f_info,
'dballe file '//trim(path)//
' found')
2830 CALL l4f_log(l4f_error,
'dballe file '//trim(filename)//
' not found')
2834 END FUNCTION get_dballe_filepath
2837 FUNCTION open_dballe_file(filename, filetype) RESULT(unit)
2838 CHARACTER(len=*),
INTENT(in) :: filename
2839 INTEGER,
INTENT(in) :: filetype
2842 CHARACTER(len=512) :: path
2845 path=get_dballe_filepath(filename, filetype)
2846 IF (path ==
'')
RETURN
2849 IF (unit == -1)
RETURN
2851 OPEN(unit, file=path, status=
'old', iostat = i)
2853 CALL l4f_log(l4f_info,
'dballe file '//trim(path)//
' opened')
2857 CALL l4f_log(l4f_error,
'dballe file '//trim(filename)//
' not found')
2861 END FUNCTION open_dballe_file
2865 FUNCTION v7d_dballe_error_handler(category)
2866 INTEGER :: category, code, l4f_level
2867 INTEGER :: v7d_dballe_error_handler
2869 CHARACTER(len=1000) :: message, buf
2871 code = idba_error_code()
2874 if (code == 13 )
then
2880 call idba_error_message(message)
2883 call idba_error_context(buf)
2887 call idba_error_details(buf)
2892 if (l4f_level == l4f_error ) CALL raise_fatal_error(
"dballe: "//message)
2894 v7d_dballe_error_handler = 0
2897 END FUNCTION v7d_dballe_error_handler
2906 #ifndef F2003_EXTENDED_FEATURES
2910 SUBROUTINE vol7d_dballe_importvvns_file(this, var, network, coordmin, coordmax, timei, timef,level,timerange, set_network,&
2911 attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,ana)
2914 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: var(:)
2915 TYPE(geo_coord
),
INTENT(inout),
optional :: coordmin,coordmax
2916 TYPE(vol7d_ana
),
INTENT(inout),
optional :: ana
2917 TYPE(datetime
),
INTENT(in),
OPTIONAL :: timei, timef
2918 TYPE(vol7d_network
),
INTENT(in),
OPTIONAL :: network,set_network
2919 TYPE(vol7d_level
),
INTENT(in),
optional :: level
2920 TYPE(vol7d_timerange
),
INTENT(in),
optional :: timerange
2921 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: attr(:),anavar(:),anaattr(:)
2922 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: varkind(:),attrkind(:),anavarkind(:),anaattrkind(:)
2923 logical,
intent(in),
optional :: anaonly
2928 CHARACTER(len=6) :: btable
2930 LOGICAL :: ldegnet, lanaonly
2931 integer :: year,month,day,hour,minute,sec
2932 integer :: rlevel1, rl1,rlevel2, rl2
2933 integer :: rtimerange, p1, p2
2934 character(len=network_name_len) ::rep_memo
2935 integer :: indana,indtime,indlevel,indtimerange,inddativar,indnetwork
2938 integer :: nana,ntime,ntimerange,nlevel,nnetwork
2939 TYPE(vol7d_network
),
ALLOCATABLE :: networktmp(:)
2941 INTEGER :: i,ii, n, na, nd
2942 integer :: nvar, nanavar ,indanavar
2944 INTEGER(kind=int_l) :: ilat,ilon,latmin,latmax,lonmin,lonmax,ilata,ilona
2945 CHARACTER(len=vol7d_ana_lenident) :: ident
2948 integer :: ndativarr, ndativari, ndativarb, ndativard, ndativarc
2949 integer :: ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc
2950 integer :: ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc
2952 integer :: nanavarr, nanavari, nanavarb, nanavard, nanavarc
2953 integer :: nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc
2954 integer :: nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
2956 integer :: ir,ib,id,ic,ier
2958 TYPE(datetime
) :: timee
2959 TYPE(vol7d_level
) :: levele
2960 TYPE(vol7d_timerange
) :: timerangee
2962 TYPE(vol7d_network
) :: lnetwork
2963 TYPE(vol7d_level
) :: llevel
2964 TYPE(vol7d_timerange
) :: ltimerange
2975 TYPE(vol7d) :: vol7dtmp
2977 type(record
),
pointer :: buffer(:),bufferana(:)
2981 call
optio(anaonly,lanaonly)
2984 IF (present(set_network))
THEN
2985 if (
c_e(set_network))
then
2988 "set_network is not fully implemented in BUFR/CREX import: priority will be ignored")
2996 if (present(attr))
then
2997 if (
size(attr) > 0 )
then
3006 if ( lattr .or. present(anaattr) .or. present(attrkind) .or. present(anaattrkind))
then
3007 call
l4f_category_log(this%category,l4f_error,
"attributes not managed in BUFR/CREX import: try --disable-qc when is possible")
3012 if (present(network))
then
3018 if (present(level))
then
3024 if (present(timerange))
then
3025 ltimerange=timerange
3027 call
init(ltimerange)
3031 ier=idba_unsetall(this%handle)
3040 call mem_acquire( buffer,nd,1000,this%category )
3041 call mem_acquire( bufferana,na,100,this%category )
3043 ier=idba_setcontextana(this%handle)
3046 ier=idba_voglioquesto(this%handle,n)
3048 call
l4f_category_log(this%category,l4f_error,
"voglioquesto return error status")
3055 if (.not.
c_e(n))
exit
3064 ier=idba_dammelo(this%handle,btable)
3066 ier=idba_enqdate(this%handle,year,month,day,hour,minute,sec)
3067 IF (.NOT.
c_e(sec)) sec = 0
3068 ier=idba_enqlevel(this%handle, rlevel1, rl1, rlevel2,rl2)
3069 ier=idba_enqtimerange(this%handle, rtimerange, p1, p2)
3070 ier=idba_enq(this%handle,
"rep_memo",rep_memo)
3078 ier=idba_enq(this%handle,
"lat", ilat)
3079 ier=idba_enq(this%handle,
"lon", ilon)
3080 ier=idba_enq(this%handle,
"ident",ident)
3089 if(
c_e(lnetwork))
then
3090 if (rep_memo /= lnetwork%name) cycle
3103 if (present(coordmin))
then
3105 if (
c_e(coordmin))
then
3106 CALL
getval(coordmin, ilat=latmin,ilon=lonmin)
3107 if (lonmin > ilon) cycle
3108 if (latmin > ilat) cycle
3112 if (present(coordmax))
then
3114 if (
c_e(coordmax))
then
3115 CALL
getval(coordmax, ilat=latmax,ilon=lonmax)
3116 if (lonmax < ilon) cycle
3117 if (latmax < ilat) cycle
3122 if (present(ana))
then
3123 if (
c_e(ana%coord))
then
3124 CALL
getval(ana%coord, ilat=ilata,ilon=ilona)
3125 if (ilona /= ilon) cycle
3126 if (ilata /= ilat) cycle
3128 if (
c_e(ana%ident))
then
3129 if (ana%ident /= ident) cycle
3133 call
init(timee, year=year, month=month, day=day, hour=hour, minute=minute,msec=sec*1000)
3135 if (present(timei))
then
3136 if (
c_e(timei) .and. timee < timei) cycle
3139 if (present(timef))
then
3140 if (
c_e(timef) .and. timee > timef) cycle
3143 if (
c_e(ltimerange))
then
3144 call
init(timerangee, timerange%timerange, timerange%p1, timerange%p2)
3145 if (timerangee /= ltimerange) cycle
3148 if (
c_e(llevel))
then
3149 call
init(levele, rlevel1, rl1,rlevel2, rl2)
3150 if (levele /= llevel) cycle
3153 if (rlevel1 /= 257)
then
3156 if (present(var))
then
3158 if (any(
c_e(var)) .and. (all(btable /= var))) cycle
3168 call mem_acquire( buffer,nd,0,this%category )
3170 buffer(nd)%dator=dba_mvr
3171 buffer(nd)%datoi=dba_mvi
3172 buffer(nd)%datob=dba_mvb
3173 buffer(nd)%datod=dba_mvd
3174 buffer(nd)%datoc=dba_mvc
3176 if (present(var).and. present(varkind))
then
3177 ii=( firsttrue(var == btable))
3180 if(varkind(ii) ==
"r") ier=idba_enq(this%handle,btable,buffer(nd)%dator)
3181 if(varkind(ii) ==
"i") ier=idba_enq(this%handle,btable,buffer(nd)%datoi)
3182 if(varkind(ii) ==
"b") ier=idba_enq(this%handle,btable,buffer(nd)%datob)
3183 if(varkind(ii) ==
"d") ier=idba_enq(this%handle,btable,buffer(nd)%datod)
3184 if(varkind(ii) ==
"c") ier=idba_enq(this%handle,btable,buffer(nd)%datoc)
3187 ier=idba_enq(this%handle,btable,buffer(nd)%datoc)
3196 call
init(buffer(nd)%ana,ilat=ilat,ilon=ilon,ident=ident)
3197 call
init(buffer(nd)%time, year=year, month=month, day=day, hour=hour, minute=minute,msec=sec*1000)
3198 call
init(buffer(nd)%level, rlevel1,rl1,rlevel2,rl2)
3199 call
init(buffer(nd)%timerange, rtimerange, p1, p2)
3200 call
init(buffer(nd)%network, rep_memo)
3201 buffer(nd)%btable = btable
3204 IF (this%vol7d%time_definition == 0) buffer(nd)%time = buffer(nd)%time - &
3205 timedelta_new(sec=buffer(nd)%timerange%p1)
3209 if (
index(bufferana%ana,buffer(nd)%ana) <= 0)
then
3211 call mem_acquire( bufferana,na,0,this%category )
3213 call
init(bufferana(na)%ana,ilat=ilat,ilon=ilon,ident=ident)
3214 call
init(bufferana(na)%time, year=year, month=month, day=day, hour=hour, minute=minute,msec=sec*1000)
3215 call
init(bufferana(na)%level, rlevel1,rl1,rlevel2,rl2)
3216 call
init(bufferana(na)%timerange, rtimerange, p1, p2)
3217 call
init(bufferana(na)%network, rep_memo)
3219 bufferana(na)%dator=dba_mvr
3220 bufferana(na)%datoi=dba_mvi
3221 bufferana(na)%datob=dba_mvb
3222 bufferana(na)%datod=dba_mvd
3223 bufferana(na)%datoc=dba_mvc
3224 bufferana(na)%btable = dba_mvc
3238 if (btable ==
"B04001" .or. btable ==
"B04002" .or. btable ==
"B04003") cycle
3240 if (btable ==
"B04004" .or. btable ==
"B04005" .or. btable ==
"B04006") cycle
3242 if (btable ==
"B01193" .or. btable ==
"B01194") cycle
3245 if (present(anavar))
then
3246 if (any(
c_e(anavar)) .and. (all(btable /= anavar))) btable=dba_mvc
3250 if (.not. lanaonly)
then
3252 if (btable ==
"B05001" .or. btable ==
"B06001" .or. btable ==
"B01011" .or. btable ==
"B01194") btable=dba_mvc
3259 call mem_acquire( bufferana,na,0,this%category )
3261 bufferana(na)%dator=dba_mvr
3262 bufferana(na)%datoi=dba_mvi
3263 bufferana(na)%datob=dba_mvb
3264 bufferana(na)%datod=dba_mvd
3265 bufferana(na)%datoc=dba_mvc
3266 bufferana(na)%btable = dba_mvc
3269 if (
c_e(btable))
then
3271 if (present(anavar).and. present(anavarkind))
then
3272 ii=( firsttrue(anavar == btable))
3275 if(anavarkind(ii) ==
"r") ier=idba_enq(this%handle,btable,bufferana(na)%dator)
3276 if(anavarkind(ii) ==
"i") ier=idba_enq(this%handle,btable,bufferana(na)%datoi)
3277 if(anavarkind(ii) ==
"b") ier=idba_enq(this%handle,btable,bufferana(na)%datob)
3278 if(anavarkind(ii) ==
"d") ier=idba_enq(this%handle,btable,bufferana(na)%datod)
3279 if(anavarkind(ii) ==
"c") ier=idba_enq(this%handle,btable,bufferana(na)%datoc)
3282 ier=idba_enq(this%handle,btable,bufferana(na)%datoc)
3291 call
init(bufferana(na)%ana,ilat=ilat,ilon=ilon,ident=ident)
3292 call
init(bufferana(na)%time, year=year, month=month, day=day, hour=hour, minute=minute,msec=sec*1000)
3293 call
init(bufferana(na)%level, rlevel1,rl1,rlevel2,rl2)
3294 call
init(bufferana(na)%timerange, rtimerange, p1, p2)
3295 call
init(bufferana(na)%network, rep_memo)
3296 bufferana(na)%btable = btable
3304 if (.not. present(var))
then
3305 nvar = count_distinct(buffer(:nd)%btable, back=.true.)
3307 if ( all(.not.
c_e(var)))
then
3308 nvar = count_distinct(buffer(:nd)%btable, back=.true.)
3310 nvar=count(
c_e(var))
3314 nana = count_distinct(bufferana(:na)%ana, back=.true.)
3316 ntime = count_distinct(buffer(:nd)%time, back=.true.)
3317 ntimerange = count_distinct(buffer(:nd)%timerange, back=.true.)
3318 nlevel = count_distinct(buffer(:nd)%level, back=.true.)
3322 ALLOCATE(networktmp(na+nd))
3323 networktmp(1:nd) = buffer(1:nd)%network
3324 networktmp(nd+1:na+nd) = bufferana(1:na)%network
3325 nnetwork = count_distinct(networktmp, back=.true.)
3329 if (present(varkind))
then
3330 ndativarr= count(varkind ==
"r")
3331 ndativari= count(varkind ==
"i")
3332 ndativarb= count(varkind ==
"b")
3333 ndativard= count(varkind ==
"d")
3334 ndativarc= count(varkind ==
"c")
3361 if (.not. present(anavar))
then
3362 nanavar = count_distinct(bufferana(:na)%btable, back=.true.,mask=(bufferana(:na)%btable /= dba_mvc))
3364 if (all(.not.
c_e(anavar)))
then
3365 nanavar = count_distinct(bufferana(:na)%btable, back=.true.,mask=(bufferana(:na)%btable /= dba_mvc))
3367 nanavar = count(
c_e(anavar))
3371 if (present(anavarkind))
then
3372 nanavarr= count(anavarkind ==
"r")
3373 nanavari= count(anavarkind ==
"i")
3374 nanavarb= count(anavarkind ==
"b")
3375 nanavard= count(anavarkind ==
"d")
3376 nanavarc= count(anavarkind ==
"c")
3403 CALL
init(vol7dtmp,time_definition=this%vol7d%time_definition)
3409 CALL vol7d_alloc(vol7dtmp, nana=nana, nnetwork=nnetwork)
3410 call vol7d_alloc_vol(vol7dtmp)
3411 vol7dtmp%ana=pack_distinct(bufferana(:na)%ana, nana, back=.true.)
3415 deallocate (bufferana)
3418 vol7dtmp%network(1)=set_network
3420 vol7dtmp%network=pack_distinct(networktmp, nnetwork, back=.true.)
3421 DEALLOCATE(networktmp)
3425 CALL vol7d_merge(this%vol7d, vol7dtmp)
3432 call vol7d_alloc(vol7dtmp, &
3433 nana=nana, ntime=ntime, ntimerange=ntimerange, &
3434 nlevel=nlevel, nnetwork=nnetwork, &
3435 ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb, ndativard=ndativard, ndativarc=ndativarc,&
3436 ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb, ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
3437 ndativarattrr=ndativarattrr, &
3438 ndativarattri=ndativarattri, &
3439 ndativarattrb=ndativarattrb, &
3440 ndativarattrd=ndativarattrd, &
3441 ndativarattrc=ndativarattrc,&
3442 nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, nanavard=nanavard, nanavarc=nanavarc,&
3443 nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb, nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
3444 nanavarattrr=nanavarattrr, &
3445 nanavarattri=nanavarattri, &
3446 nanavarattrb=nanavarattrb, &
3447 nanavarattrd=nanavarattrd, &
3448 nanavarattrc=nanavarattrc)
3450 vol7dtmp%ana=pack_distinct(bufferana(:na)%ana, nana, back=.true.)
3452 vol7dtmp%time=pack_distinct(buffer(:nd)%time, ntime, back=.true.)
3453 call
sort(vol7dtmp%time)
3454 vol7dtmp%timerange=pack_distinct(buffer(:nd)%timerange, ntimerange, back=.true.)
3455 call
sort(vol7dtmp%timerange)
3456 vol7dtmp%level=pack_distinct(buffer(:nd)%level, nlevel, back=.true.)
3457 call
sort(vol7dtmp%level)
3460 vol7dtmp%network(1)=set_network
3462 vol7dtmp%network=pack_distinct(networktmp, nnetwork, back=.true.)
3463 DEALLOCATE(networktmp)
3468 if (present(var).and. present(varkind))
then
3476 do i=1,
size(varkind)
3477 if (varkind(i) ==
"r")
then
3479 call
init(vol7dtmp%dativar%r(ir), btable=var(i))
3481 if (varkind(i) ==
"i")
then
3483 call
init(vol7dtmp%dativar%i(ii), btable=var(i))
3485 if (varkind(i) ==
"b")
then
3487 call
init(vol7dtmp%dativar%b(ib), btable=var(i))
3489 if (varkind(i) ==
"d")
then
3491 call
init(vol7dtmp%dativar%d(id), btable=var(i))
3493 if (varkind(i) ==
"c")
then
3495 call
init(vol7dtmp%dativar%c(ic), btable=var(i))
3498 else if (present(var))
then
3499 if (any(
c_e(var)))
then
3501 call
init(vol7dtmp%dativar%c(i), btable=var(i))
3507 call
init(vol7dtmp%dativar%c(i))
3509 if (ndativarc > 0)
then
3510 call pack_distinct_c(buffer(:nd)%btable,vol7dtmp%dativar%c%btable, back=.true.)
3516 call
init(vol7dtmp%dativar%c(i))
3518 if (ndativarc > 0)
then
3519 call pack_distinct_c(buffer(:nd)%btable,vol7dtmp%dativar%c%btable, back=.true.)
3526 if (present(anavar).and. present(anavarkind))
then
3534 do i=1,
size(anavarkind)
3535 if (anavarkind(i) ==
"r")
then
3537 call
init(vol7dtmp%anavar%r(ir), btable=anavar(i))
3539 if (anavarkind(i) ==
"i")
then
3541 call
init(vol7dtmp%anavar%i(ii), btable=anavar(i))
3543 if (anavarkind(i) ==
"b")
then
3545 call
init(vol7dtmp%anavar%b(ib), btable=anavar(i))
3547 if (anavarkind(i) ==
"d")
then
3549 call
init(vol7dtmp%anavar%d(id), btable=anavar(i))
3551 if (anavarkind(i) ==
"c")
then
3553 call
init(vol7dtmp%anavar%c(ic), btable=anavar(i))
3556 else if (present(anavar))
then
3558 IF (any(
c_e(anavar)))
THEN
3560 CALL
init(vol7dtmp%anavar%c(i), btable=anavar(i))
3565 call
init(vol7dtmp%anavar%c(i))
3568 if (nanavarc > 0)
then
3569 call pack_distinct_c(bufferana(:na)%btable,vol7dtmp%anavar%c%btable, back=.true.,&
3570 mask=(bufferana(:na)%btable /= dba_mvc))
3578 call
init(vol7dtmp%anavar%c(i))
3581 if (nanavarc > 0)
then
3582 call pack_distinct_c(bufferana(:na)%btable,vol7dtmp%anavar%c%btable, back=.true.,&
3583 mask=(bufferana(:na)%btable /= dba_mvc))
3589 call vol7d_alloc_vol(vol7dtmp)
3593 indana = firsttrue(buffer(i)%ana == vol7dtmp%ana)
3594 indtime = firsttrue(buffer(i)%time == vol7dtmp%time)
3595 indtimerange = firsttrue(buffer(i)%timerange == vol7dtmp%timerange)
3596 indlevel = firsttrue(buffer(i)%level == vol7dtmp%level)
3600 indnetwork = firsttrue(buffer(i)%network == vol7dtmp%network)
3604 if(
c_e(buffer(i)%dator))
then
3605 inddativar = firsttrue(buffer(i)%btable == vol7dtmp%dativar%r%btable)
3606 vol7dtmp%voldatir( &
3607 indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
3611 if(
c_e(buffer(i)%datoi))
then
3612 inddativar = firsttrue(buffer(i)%btable == vol7dtmp%dativar%i%btable)
3613 vol7dtmp%voldatii( &
3614 indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
3618 if(
c_e(buffer(i)%datob))
then
3619 inddativar = firsttrue(buffer(i)%btable == vol7dtmp%dativar%b%btable)
3620 vol7dtmp%voldatib( &
3621 indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
3625 if(
c_e(buffer(i)%datod))
then
3626 inddativar = firsttrue(buffer(i)%btable == vol7dtmp%dativar%d%btable)
3627 vol7dtmp%voldatid( &
3628 indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
3632 if(
c_e(buffer(i)%datoc))
then
3633 inddativar = firsttrue(buffer(i)%btable == vol7dtmp%dativar%c%btable)
3634 vol7dtmp%voldatic( &
3635 indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
3646 indana = firsttrue(bufferana(i)%ana == vol7dtmp%ana)
3651 indnetwork = firsttrue(bufferana(i)%network == vol7dtmp%network)
3654 if (indana < 1 .or. indnetwork < 1 )cycle
3658 if(
c_e(bufferana(i)%dator))
then
3659 indanavar = firsttrue(bufferana(i)%btable == vol7dtmp%anavar%r%btable)
3660 vol7dtmp%volanar( indana,indanavar,indnetwork ) = bufferana(i)%dator
3662 if(
c_e(bufferana(i)%datoi))
then
3663 indanavar = firsttrue(bufferana(i)%btable == vol7dtmp%anavar%i%btable)
3664 vol7dtmp%volanai( indana,indanavar,indnetwork ) = bufferana(i)%datoi
3666 if(
c_e(bufferana(i)%datob))
then
3667 indanavar = firsttrue(bufferana(i)%btable == vol7dtmp%anavar%b%btable)
3668 vol7dtmp%volanab( indana,indanavar,indnetwork ) = bufferana(i)%datob
3670 if(
c_e(bufferana(i)%datod))
then
3671 indanavar = firsttrue(bufferana(i)%btable == vol7dtmp%anavar%d%btable)
3672 vol7dtmp%volanad( indana,indanavar,indnetwork ) = bufferana(i)%datod
3674 if (nanavarc > 0)
then
3675 if(
c_e(bufferana(i)%datoc))
then
3676 indanavar = firsttrue(bufferana(i)%btable == vol7dtmp%anavar%c%btable)
3677 vol7dtmp%volanac( indana,indanavar,indnetwork ) = bufferana(i)%datoc
3690 deallocate (bufferana)
3693 CALL vol7d_merge(this%vol7d, vol7dtmp,
sort=.true.)
3697 call vol7d_set_attr_ind(this%vol7d)
3699 call vol7d_dballe_set_var_du(this%vol7d)
3714 END SUBROUTINE vol7d_dballe_importvvns_file
3718 subroutine mem_acquire( buffer,n,npool,category )
3720 INTEGER :: n,mem,npool,category,istat
3721 type(record
),
pointer :: buffer(:)
3722 type(record
),
pointer :: buffertmp(:)
3727 allocate (buffer(npool))
3738 ALLOCATE (buffertmp(max(mem*2,n)),stat=istat)
3739 IF (istat /= 0)
THEN
3741 //trim(
to_char(mem*2))//
' buffer elements')
3742 CALL raise_fatal_error()
3745 buffertmp(:mem)=buffer(:)
3753 end subroutine mem_acquire
Functions that return a trimmed CHARACTER representation of the input variable.
Classes for handling georeferenced sparse points in geographical corodinates.
Generic subroutine for checking OPTIONAL parameters.
Classe per la gestione di un volume completo di dati osservati.
Oggetto per import ed export da DB-All.e.
Restituiscono il valore dell'oggetto in forma di stringa stampabile.
Determine whether a point lies inside a polygon or a rectangle.
Restituiscono il valore dell'oggetto nella forma desiderata.
Definisce un oggetto contenente i volumi anagrafica e dati e tutti i descrittori delle loro dimension...
classe per import ed export di volumi da e in DB-All.e
classe per la gestione del logging
Utilities for CHARACTER variables.
Emit log message for a category with specific priority.
This module defines usefull general purpose function and subroutine.