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)
188 TYPE(vol7d_dballe),
INTENT(out) :: this
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)
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)
373 TYPE(vol7d_dballe),
INTENT(inout) :: this
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)
436 TYPE(vol7d_dballe),
INTENT(inout) :: this
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)
476 TYPE(vol7d_dballe),
INTENT(inout) :: this
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)
511 TYPE(vol7d_dballe),
INTENT(inout) :: this
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)
549 TYPE(vol7d_dballe),
INTENT(inout) :: this
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)
1883 TYPE(vol7d_dballe),
INTENT(inout) :: this
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)
2589 TYPE(vol7d_dballe) :: this
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)
2913 TYPE(vol7d_dballe),
INTENT(inout) :: this
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
Set of functions that return a trimmed CHARACTER representation of the input variable.
Oggetto per import ed export da DB-All.e.
Test for a missing volume.
Classes for handling georeferenced sparse points in geographical corodinates.
Determine whether a point lies inside a polygon or a rectangle.
Set of functions that return a CHARACTER representation of the input variable.
Classe per la gestione di un volume completo di dati osservati.
This module defines usefull general purpose function and subroutine.
classe per la gestione del logging
classe per import ed export di volumi da e in DB-All.e
Utilities for CHARACTER variables.
Methods for returning the value of object members.
Emit log message for a category with specific priority.