dba2v7d vol7d_dballe_delete vol7d_dballe_export vol7d_dballe_export_old vol7d_dballe_import vol7d_dballe_import_old vol7d_dballe_importvvnv vol7d_dballe_init vol7d_dballe_set_var_du

vol7d_dballe_export() subroutine vol7d_dballe_export ( type(vol7d_dballe), intent(inout) this, type(dbafilter), intent(in) filter, character(len=*), intent(in), optional template, logical, intent(in), optional attr_only ) private Parametri [in,out] this oggetto contenente il volume e altre info per l'accesso al DSN [in] filter filter o use [in] template specificando category.subcategory.localcategory oppure un alias ("synop", "metar","temp","generic") forza l'exportazione ad uno specifico template BUFR/CREX" the special value "generic-frag is used to generate bufr on file where ana data is reported only once at beginning and data in other bufr after [in] attr_only set to .true. to export attr only (no data) Definizione alla linea 2778 del file vol7d_dballe_class.F03. ! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it> ! authors: ! Davide Cesari <dcesari@arpa.emr.it> ! Paolo Patruno <ppatruno@arpa.emr.it> ! This program is free software; you can redistribute it and/or ! modify it under the terms of the GNU General Public License as ! published by the Free Software Foundation; either version 2 of ! the License, or (at your option) any later version. ! This program is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! You should have received a copy of the GNU General Public License ! along with this program. If not, see <http://www.gnu.org/licenses/>. #include "config.h" !> \brief classe per import ed export di volumi da e in DB-All.e !! !!Questo modulo definisce gli oggetti e i metodi per gestire !!l'importazione e l'esportazione di volumi dal database per dati sparsi !!DB-All.e !! !!Il tutto funziona intorno all'oggetto vol7d_dballe che aggiunge ad un !!oggetto vol7d ulteriori informazioni. !! !!Con la chiamata init vengono definiti i parametri di accesso alla DSN !!(database) di DB-All.e. oppure da file bufr/crex !! !!Con import è possibile acquisire nel prorio programma i dati presenti !!nel DSN o su file; l'allocazione di memoria è automatica. Import è in grado di !!importare dati senza nessuna ulteriore specificazione: vengono !!acquisite tutte le stazioni senza limiti di tempo o di spazio, per !!tutti i dati, compresi quelli di anagrafica; solo gli attributi !!vengono tralasciati se non specificati. Se non specificato i dati sono !!in forma character che permette di essere conservativi su tutti i tipi !!di dato archiviabile in DB-all.e. Aumentando i parametri !!all'intefaccia import è possibile specificare sottoinsiemi temporali e !!spaziali, elenchi di variabili e attributi. E' possibile anche !!specificare il tipo per ogni variabile o attributo richiesto. E' !!fornito un set di routine per avere la possibilità di estrarre un !!vettore di variabili e un vettore di reti. E' possibile anche specificare !!una singola stazione. vol7d_dballe%%data_id !!contiene un vettore di servizio con gli id interni del database che !!indirizzano direttamente i dati. Una particolare opzione permette di !!attivare l'opzione query di tipo best in DB-All.e per avere in una !!unica rete i dati migliori presenti nel DB. !! !!Con export si riscrivono i dati nel DSN di DB-All.e potendo attivare !!una serie di filtri. !! !!Con delete si elimina definitvamente l'oggetto vol7d_dballe. !! !!Mantenendo lo stesso oggetto nella sequenza init, import, export, !!delete si sovrascrive lo stesso DSN di DB-All.e. Il vettore !!vol7d_dballe%%data_id in export permette di sovrascrivere solo gli !!attributi; eventualmente possono essere sovrascritti i soli attributi !!relativi agli elementi data_id non mancanti. !! !! E' da notare che se si attiva l'opzione "anaonly" solo ma tutte le stazioni e !! i dati di anagrafica vengono importati secondo i parametri di query selezionati. !! Se l'opzione "anaonly" è disattivata solo le stazioni con i dati richiesti presenti !! saranno caricati nella sezione anagrafica !! !!Utilizzando due differenti oggetti uno per import e uno per export è !!possibile tramite l'associazione del puntatore in essi contenuto !!relativo al volume vol7d ricopiare contenuti in altri DSN senza !!sprechi di memoria. !! !!Programma esempio !!\include esempio_v7ddballe.f90 !! !!\ingroup vol7d MODULE vol7d_dballe_class USE dballe_class USE char_utilities USE vol7d_class USE array_utilities use log4fortran USE geo_coord_class !use list_mix use list_character use list_linkchar use vol7d_serialize_dballe_class IMPLICIT NONE character (len=255),parameter:: subcategory="vol7d_dballe_class" !>\brief Oggetto per import ed export da DB-All.e !! !!L'oggetto è costituito da un oggetto vol7d attorniato dalle !!informazioni necessarie per l'accesso al DSN di DB-All.e !! e da una matrice necessaria per l'ottimizzazione della scrittura dei !!degli attributi dei dati in export TYPE vol7d_dballe TYPE(vol7d) :: vol7d !< volume vol7d type(dbaconnection) :: idbhandle !< handle della connessioni al DSN DB-All.e type(dbasession) :: handle !< handle della sessione connessa al DSN DB-All.e !> memorizza gli id interni al database DB-All.e per !!ottimizzare le riscritture degli attributi ai dati integer ,pointer :: data_id(:,:,:,:,:) integer :: time_definition type(l4f_handle) :: category !< log4fortran logical :: file !< END TYPE vol7d_dballe INTEGER, PARAMETER, PRIVATE :: nftype = 2 CHARACTER(len=16), PARAMETER, PRIVATE :: & pathlist(2,nftype) = reshape((/ & '/usr/share ', '/usr/local/share', & '/etc ', '/usr/local/etc ' /), & (/2,nftype/)) type(vol7d_var),allocatable,private :: blocal(:) ! cache of dballe.txt CHARACTER(len=20),PRIVATE :: dballe_name='wreport', dballe_name_env='DBA_TABLES' !>\brief inizializza INTERFACE init MODULE PROCEDURE vol7d_dballe_init END INTERFACE init !>\brief cancella INTERFACE delete MODULE PROCEDURE vol7d_dballe_delete END INTERFACE delete !>\brief importa INTERFACE import MODULE PROCEDURE vol7d_dballe_importvvnv,vol7d_dballe_import, vol7d_dballe_import_old, dba2v7d END INTERFACE import !>\brief exporta INTERFACE export MODULE PROCEDURE vol7d_dballe_export_old,vol7d_dballe_export, v7d2dba END INTERFACE export PRIVATE PUBLIC vol7d_dballe, init, delete, import, export, vol7d_dballe_import_dballevar, vol7d_dballe_set_var_du CONTAINS !>\brief inizializza l'oggetto SUBROUTINE vol7d_dballe_init(this,dsn,user,password,write,wipe,repinfo,& filename,format,file,categoryappend,time_definition,idbhandle,template) TYPE(vol7d_dballe),INTENT(out) :: this !< l'oggetto da inizializzare character(len=*), INTENT(in),OPTIONAL :: dsn !< per l'accesso al DSN ( default="test" ) character(len=*), INTENT(in),OPTIONAL :: user !< per l'accesso al DSN ( default="test" ) character(len=*), INTENT(in),OPTIONAL :: password !< per l'accesso al DSN ( default="" ) logical,INTENT(in),OPTIONAL :: write !< abilita la scrittura sul DSN/file ( default=.false. ) logical,INTENT(in),OPTIONAL :: wipe !< svuota il DSN/file e/o lo prepara per una scrittura ( default=.false. ) character(len=*), INTENT(in),OPTIONAL :: repinfo !< eventuale file repinfo.csv usato con wipe ( default="" ) character(len=*),intent(inout),optional :: filename !< nome dell'eventuale file da utilizzare in alternativa a dsn when file is true; se passato ="" ritorna un valore di deafult elaborato character(len=*),intent(in),optional :: format !< the file format when file is true. It can be "BUFR", "CREX" or "JSON" (default="BUFR") logical,INTENT(in),OPTIONAL :: file !< switch to use file or data base ( default=.false ) character(len=*),INTENT(in),OPTIONAL :: categoryappend !< appennde questo suffisso al namespace category di log4fortran integer,INTENT(in),OPTIONAL :: time_definition !< 0=time is reference time ; 1=time is validity time (default=1) integer,INTENT(in),OPTIONAL :: idbhandle !< dsn connection; if present it will be used !> specificando category.subcategory.localcategory oppure un alias ("synop", "metar","temp","generic") forza l'exportazione ad uno specifico template BUFR/CREX" !! the special value "generic-frag is used to generate bufr on file where ana data is reported only once at beginning and data in other bufr after character(len=*),intent(in),optional :: template !< default template to use exporting to file; can be overwritten by export logical :: quiwrite,loadfile character(len=512) :: a_name character(len=254) :: arg,lfilename,lformat quiwrite=.false. if (present(write))then quiwrite=write endif if (present(categoryappend))then call l4f_launcher(a_name,a_name_append=trim(subcategory)//"."//trim(categoryappend)) else call l4f_launcher(a_name,a_name_append=trim(subcategory)) endif this%category=l4f_category_get_handle(a_name) #ifdef DEBUG CALL l4f_category_log(this%category,l4f_debug,'vol7d_dballe_init start') #endif nullify(this%data_id) if (optio_log(file)) then this%file=.true. lformat="BUFR" if (present(format))then lformat=format end if CALL getarg(0,arg) lfilename=trim(arg)//"."//trim(lformat) if (index(arg,'/',back=.true.) > 0) lfilename=lfilename(index(arg,'/',back=.true.)+1 : ) if (present(filename))then if (c_e(filename))then lfilename=filename end if end if if(quiwrite)then ! this for write in memdb and write file on export loadfile=.false. else loadfile=.true. end if this%handle=dbasession(wipe=wipe,write=quiwrite,repinfo=repinfo, & filename=lfilename,format=lformat,template=template, & memdb=.true.,loadfile=loadfile) else this%file=.false. this%idbhandle=dbaconnection(dsn,user,password,idbhandle=idbhandle) this%handle=dbasession(this%idbhandle,wipe=wipe,write=quiwrite,repinfo=repinfo) endif ! this init has been added here for cleaningness, this%vol7d gets ! reinitialised afterwards in dba2v7d and this%vol7d%time_definition is ! overwritten by this%time_definition, this duplication is required in ! order to pass time_definition down to dba2v7d CALL init(this%vol7d, time_definition) this%time_definition = optio_i(time_definition) #ifdef DEBUG CALL l4f_category_log(this%category,l4f_debug,'vol7d_dballe_init end') #endif END SUBROUTINE vol7d_dballe_init !>\brief Identica a vol7d_dballe_importvsns con var e network vettore. !! !!import da DB-all.e SUBROUTINE vol7d_dballe_importvvnv(this, var, network, coordmin,coordmax, timei, timef, level,timerange,set_network,& attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,dataonly,ana) TYPE(vol7d_dballe),INTENT(inout) :: this !< oggetto vol7d_dballe CHARACTER(len=*),INTENT(in) :: var(:) TYPE(geo_coord),INTENT(inout),optional :: coordmin,coordmax TYPE(vol7d_ana),INTENT(inout),optional :: ana TYPE(datetime),INTENT(in),optional :: timei, timef TYPE(vol7d_network),INTENT(in) :: network(:) TYPE(vol7d_network),INTENT(in),OPTIONAL :: set_network TYPE(vol7d_level),INTENT(in),optional :: level TYPE(vol7d_timerange),INTENT(in),optional :: timerange CHARACTER(len=*),INTENT(in),OPTIONAL :: attr(:),anavar(:),anaattr(:) CHARACTER(len=*),INTENT(in),OPTIONAL :: varkind(:),attrkind(:),anavarkind(:),anaattrkind(:) logical,intent(in),optional :: anaonly LOGICAL,INTENT(in),OPTIONAL :: dataonly TYPE(vol7d_dballe) :: v7ddbatmp INTEGER :: i IF (SIZE(network) == 0 )THEN CALL import(this, var, coordmin=coordmin, coordmax=coordmax, timei=timei, & timef=timef, level=level, timerange=timerange, set_network=set_network, & attr=attr, anavar=anavar, anaattr=anaattr, varkind=varkind, attrkind=attrkind, & anavarkind=anavarkind, anaattrkind=anaattrkind, anaonly=anaonly, & dataonly=dataonly, ana=ana) ELSE CALL init(this%vol7d) v7ddbatmp = this ! shallow copy DO i = 1, SIZE(network) CALL import(v7ddbatmp, var, network(i), coordmin, coordmax, timei, timef, & level,timerange, set_network, attr,anavar,anaattr, varkind, attrkind, & anavarkind, anaattrkind, anaonly, dataonly, ana) CALL vol7d_merge(this%vol7d, v7ddbatmp%vol7d, sort=.true.) ENDDO ENDIF END SUBROUTINE vol7d_dballe_importvvnv !>import da DB-all.e SUBROUTINE vol7d_dballe_import_old(this, var, network, coordmin, coordmax, timei, timef,level,timerange, set_network,& attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,dataonly,ana) TYPE(vol7d_dballe),INTENT(inout) :: this !< oggetto vol7d_dballe CHARACTER(len=*),INTENT(in),OPTIONAL :: var(:) TYPE(geo_coord),INTENT(inout),optional :: coordmin,coordmax TYPE(vol7d_ana),INTENT(inout),optional :: ana TYPE(datetime),INTENT(in),OPTIONAL :: timei, timef TYPE(vol7d_network),INTENT(in),OPTIONAL :: network,set_network TYPE(vol7d_level),INTENT(in),optional :: level TYPE(vol7d_timerange),INTENT(in),optional :: timerange CHARACTER(len=*),INTENT(in),OPTIONAL :: attr(:),anavar(:),anaattr(:) CHARACTER(len=*),INTENT(in),OPTIONAL :: varkind(:),attrkind(:),anavarkind(:),anaattrkind(:) logical,intent(in),optional :: anaonly logical,intent(in),optional :: dataonly INTEGER,PARAMETER :: maxvarlist=100 !TYPE(vol7d) :: v7d ! da non fare (con gfortran?)!!!!! !CHARACTER(len=SIZE(var)*7) :: varlist !CHARACTER(len=SIZE(attr)*8) :: starvarlist LOGICAL :: ldegnet INTEGER :: i integer :: nvar integer :: nanavar !CHARACTER(len=10),allocatable :: lvar(:), lanavar(:) type(dbadcv) :: vars,starvars,anavars,anastarvars type(dbafilter) :: filter type(dbacoord) :: mydbacoordmin, mydbacoordmax type(dbaana) :: mydbaana type(dbadatetime) :: mydatetimemin, mydatetimemax type(dbatimerange) :: mydbatimerange type(dbalevel) :: mydbalevel type(dbanetwork) :: mydbanetwork integer :: nanaattr,nattr character(len=40) :: query #ifdef DEBUG CALL l4f_category_log(this%category,l4f_debug,'inizio') #endif IF (PRESENT(set_network)) THEN if (c_e(set_network)) then ldegnet = .true. else ldegnet = .false. end if ELSE ldegnet = .false. ENDIF if(ldegnet) then query = "best" else query=cmiss end if ! uncommenti this if you want compatibility API with old import !!$ if (allocated(starvars%dcv)) then !!$ ldataonly=.false. !!$ else !!$ ldataonly=.true. !!$ end if !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ------------- prepare filter options !! !! translate import option for dballe2003 api !! if (present(var)) then nvar=count(c_e(var)) if (nvar > 0) then allocate (vars%dcv(nvar)) do i=1,size(var) if (c_e(var(i)))then if (present(varkind))then select case (varkind(i)) case("r") allocate (vars%dcv(i)%dat,source=dbadatar(var(i))) case("i") allocate (vars%dcv(i)%dat,source=dbadatai(var(i))) case("b") allocate (vars%dcv(i)%dat,source=dbadatab(var(i))) case("d") allocate (vars%dcv(i)%dat,source=dbadatad(var(i))) case("c") allocate (vars%dcv(i)%dat,source=dbadatac(var(i))) case default call l4f_category_log(this%category,l4f_error,"var and varkind mismach") CALL raise_fatal_error() end select else allocate (vars%dcv(i)%dat,source=dbadatac(var(i))) !char is default end if end if end do end if end if if (present(anavar)) then nanavar=count(c_e(anavar)) if (nanavar > 0) then allocate (anavars%dcv(nanavar)) do i=1,size(anavar) if (c_e(anavar(i)))then if (present(anavarkind))then select case (anavarkind(i)) case("r") allocate (anavars%dcv(i)%dat,source=dbadatar(anavar(i))) case("i") allocate (anavars%dcv(i)%dat,source=dbadatai(anavar(i))) case("b") allocate (anavars%dcv(i)%dat,source=dbadatab(anavar(i))) case("d") allocate (anavars%dcv(i)%dat,source=dbadatad(anavar(i))) case("c") allocate (anavars%dcv(i)%dat,source=dbadatac(anavar(i))) case default call l4f_category_log(this%category,l4f_error,"anavar and anavarkind mismach") CALL raise_fatal_error() end select else allocate (anavars%dcv(i)%dat,source=dbadatac(anavar(i))) !char is default end if end if end do end if end if if (present(attr)) then nattr=size(attr) if (nattr == 0) then allocate (starvars%dcv(nattr)) else nattr=count(c_e(attr)) if (nattr > 0) then allocate (starvars%dcv(nattr)) do i=1,size(attr) if (c_e(attr(i)))then if (present(attrkind))then select case (attrkind(i)) case("r") allocate (starvars%dcv(i)%dat,source=dbadatar(attr(i))) case("i") allocate (starvars%dcv(i)%dat,source=dbadatai(attr(i))) case("b") allocate (starvars%dcv(i)%dat,source=dbadatab(attr(i))) case("d") allocate (starvars%dcv(i)%dat,source=dbadatad(attr(i))) case("c") allocate (starvars%dcv(i)%dat,source=dbadatac(attr(i))) case default call l4f_category_log(this%category,l4f_error,"attr and attrkind mismach") CALL raise_fatal_error() end select else allocate (starvars%dcv(i)%dat,source=dbadatac(attr(i))) !char is default end if end if end do end if endif end if if (present(anaattr)) then nanaattr=size(anaattr) if (nanaattr == 0) then allocate (anastarvars%dcv(nanaattr)) else nanaattr=count(c_e(anaattr)) if (nanaattr > 0) then allocate (anastarvars%dcv(nanaattr)) do i=1,size(anaattr) if (c_e(anaattr(i)))then if (present(anaattrkind))then select case (anaattrkind(i)) case("r") allocate (anastarvars%dcv(i)%dat,source=dbadatar(anaattr(i))) case("i") allocate (anastarvars%dcv(i)%dat,source=dbadatai(anaattr(i))) case("b") allocate (anastarvars%dcv(i)%dat,source=dbadatab(anaattr(i))) case("d") allocate (anastarvars%dcv(i)%dat,source=dbadatad(anaattr(i))) case("c") allocate (anastarvars%dcv(i)%dat,source=dbadatac(anaattr(i))) case default call l4f_category_log(this%category,l4f_error,"attr and attrkind mismach") CALL raise_fatal_error() end select else allocate (anastarvars%dcv(i)%dat,source=dbadatac(anaattr(i))) !char is default end if end if end do end if end if end if ! like a cast mydbacoordmin=dbacoord() if (present(coordmin)) mydbacoordmin%geo_coord=coordmin mydbacoordmax=dbacoord() if (present(coordmax)) mydbacoordmax%geo_coord=coordmax mydbaana=dbaana() if (present(ana)) mydbaana%vol7d_ana=ana mydatetimemin=dbadatetime() if (present(timei)) mydatetimemin%datetime=timei mydatetimemax=dbadatetime() if (present(timef)) mydatetimemax%datetime=timef mydbatimerange=dbatimerange() if (present(timerange)) mydbatimerange%vol7d_timerange=timerange mydbalevel=dbalevel() if (present(level)) mydbalevel%vol7d_level=level mydbanetwork=dbanetwork() if (present(network)) mydbanetwork%vol7d_network=network !! !! here we have options ready for filter !! filter=dbafilter(coordmin=mydbacoordmin,coordmax=mydbacoordmax,ana=mydbaana, & datetimemin=mydatetimemin,datetimemax=mydatetimemax, & timerange=mydbatimerange,level=mydbalevel,network=mydbanetwork,query=query,& vars=vars,starvars=starvars,anavars=anavars,anastarvars=anastarvars,& dataonly=dataonly,anaonly=anaonly) !!$ print *, "filter:" !!$ call filter%display() call import(this,filter,set_network) END SUBROUTINE vol7d_dballe_import_old !>import da DB-all.e subroutine vol7d_dballe_import(this,filter,set_network) TYPE(vol7d_dballe),INTENT(inout) :: this !< oggetto vol7d_dballe type(dbafilter),INTENT(in) :: filter TYPE(vol7d_network),INTENT(in),OPTIONAL :: set_network TYPE(vol7d) :: vol7dtmp type(dbametaanddata),allocatable :: metaanddatav(:) type(dbafilter) :: myfilter CALL l4f_category_log(this%category,l4f_debug,'start import vol7d_dballe') if ( .not. filter%dataonly) then ! ----------------> constant station data myfilter=dbafilter(filter=filter,contextana=.true.,query=cmiss) ! ! set filter ! call this%handle%set(filter=myfilter) ! estrude the data CALL l4f_category_log(this%category,l4f_debug,'start import vol7d_dballe ingest for constant station data') ! call this%handle%ingest(filter=myfilter) call this%handle%ingest(metaanddatav,filter=myfilter) CALL l4f_category_log(this%category,l4f_debug,'end import vol7d_dballe ingest') CALL l4f_category_log(this%category,l4f_debug,'start import vol7d_dballe dba2v7d') call dba2v7d(this%vol7d, metaanddatav,this%time_definition,set_network) CALL l4f_category_log(this%category,l4f_debug,'end import vol7d_dballe dba2v7d') deallocate (metaanddatav) else ! empty volume call init(this%vol7d) call vol7d_alloc(this%vol7d) call vol7d_alloc_vol(this%vol7d) end if ! ----------------> constant station data end if ( .not. filter%anaonly) then ! ----------------> working on data myfilter=dbafilter(filter=filter,contextana=.false.) ! ! set filter ! call this%handle%set(filter=myfilter) ! estrude the data CALL l4f_category_log(this%category,l4f_debug,'start import vol7d_dballe ingest for station data') ! call this%handle%ingest(filter=myfilter) call this%handle%ingest(metaanddatav,filter=myfilter) CALL l4f_category_log(this%category,l4f_debug,'end import vol7d_dballe ingest') CALL l4f_category_log(this%category,l4f_debug,'start import vol7d_dballe dba2v7d') call dba2v7d(vol7dtmp,metaanddatav,this%time_definition,set_network) CALL l4f_category_log(this%category,l4f_debug,'end import vol7d_dballe dba2v7d') deallocate (metaanddatav) CALL vol7d_merge(this%vol7d, vol7dtmp, sort=.true.) ! Smart merge !!$else !!$ ! should we sort separately in case no merge is done? !!$ CALL vol7d_smart_sort(this%vol7d, lsort_time=.TRUE., lsort_timerange=.TRUE., lsort_level=.TRUE.) end if call vol7d_dballe_set_var_du(this%vol7d) #ifdef NONE !!$if (lattr) then !!$ !!$ allocate (this%data_id( nana, ntime, nlevel, ntimerange, nnetwork),stat=istat) !!$ if (istat/= 0) THEN !!$ CALL l4f_category_log(this%category,L4F_ERROR,'cannot allocate ' & !!$ //TRIM(to_char(nana*ntime*nlevel*ntimerange*nnetwork))//' data_id elements') !!$ CALL raise_fatal_error() !!$ !!$ ENDIF !!$ !!$ this%data_id=DBA_MVI !!$ !!$else nullify(this%data_id) !!$end if !memorizzo data_id #ifdef DEBUG !CALL l4f_category_log(this%category,L4F_DEBUG,"data_id: "//trim(to_char(buffer(i)%data_id))) #endif this%data_id(indana,indtime,indlevel,indtimerange,indnetwork)=buffer(i)%data_id ier=idba_set(this%handle,"*context_id",buffer(i)%data_id) ier=idba_set(this%handle,"*var_related",buffer(i)%btable) !per ogni dato ora lavoro sugli attributi ier=idba_set(this%handle, "*varlist",starvarlist ) ier=idba_voglioancora(this%handle,nn) !print*,buffer(i)%btable," numero attributi",nn #endif CALL l4f_category_log(this%category,l4f_debug,'end import vol7d_dballe') end subroutine vol7d_dballe_import !>\brief Cancella l'oggetto SUBROUTINE vol7d_dballe_delete(this, preserveidbhandle) TYPE(vol7d_dballe) :: this !< oggetto da cancellare logical,intent(in), optional :: preserveidbhandle !< do not close connection to dsn # ifndef F2003_FULL_FEATURES call this%handle%delete() if (.not. optio_log(preserveidbhandle)) call this%idbhandle%delete() # endif !!$if (associated(this%data_id)) then !!$ deallocate (this%data_id) !!$ nullify(this%data_id) !!$end if CALL delete(this%vol7d) !chiudo il logger call l4f_category_delete(this%category) !ier=l4f_fini() END SUBROUTINE vol7d_dballe_delete !>\brief import dba objects in vol7d !subroutine dba2v7d(this,metaanddatav,vars,starvars,anavars,anastarvars,time_definition, set_network) subroutine dba2v7d(this,metaanddatav,time_definition, set_network) type(dbametaanddata),intent(inout) :: metaanddatav(:) ! change value in datetime reguard timedefinition TYPE(vol7d),INTENT(inout) :: this integer,INTENT(in),OPTIONAL :: time_definition !< 0=time is reference time ; 1=time is validity time (default=1) TYPE(vol7d_network),INTENT(in),OPTIONAL :: set_network type(dbadcv) :: vars type(dbadcv) :: starvars type(dbadcv) :: anavars type(dbadcv) :: anastarvars LOGICAL :: ldegnet integer :: indana,indtime,indlevel,indtimerange,inddativar,indnetwork,indattrvar integer :: nana,ntime,ntimerange,nlevel,nnetwork INTEGER :: i, j, k, n integer :: inddativarattr integer :: nanavar, indanavar,indanavarattr,nanavarattr integer :: ndativarr, ndativari, ndativarb, ndativard, ndativarc integer :: ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc integer :: ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc integer :: nanavarr, nanavari, nanavarb, nanavard, nanavarc integer :: nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc integer :: nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc integer :: ndativar,ndativarattr type(characterlist) :: dativarl,dativarattrl,anavarl,anavarattrl character(len=listcharmaxlen),allocatable :: dativara(:),dativarattra(:),anavara(:),anavarattra(:) logical :: status integer :: ltime_definition type(datetime),allocatable :: tmptime(:) type(vol7d_network),allocatable :: tmpnetwork(:) type(vol7d_level),allocatable :: tmplevel(:) type(vol7d_timerange),allocatable :: tmptimerange(:) type(vol7d_ana),allocatable :: tmpana(:) ltime_definition=optio_i(time_definition) if (.not. c_e(ltime_definition)) ltime_definition = 1 ! take in account time_definition if (ltime_definition == 0) then do i =1,size(metaanddatav) metaanddatav(i)%metadata%datetime%datetime = & metaanddatav(i)%metadata%datetime%datetime - & timedelta_new(sec=metaanddatav(i)%metadata%timerange%vol7d_timerange%p1) end do end if if (ltime_definition == 2) then do i =1,size(metaanddatav) metaanddatav(i)%metadata%timerange%vol7d_timerange%p1 = 0 end do end if IF (PRESENT(set_network)) THEN if (c_e(set_network)) then ldegnet = .true. else ldegnet = .false. end if ELSE ldegnet = .false. ENDIF !!-------------------------------------------------------------------------- !! find vars, starvars, anavars, anastarvars !! ! create lists of all ! data do i =1, size(metaanddatav) do j=1, size(metaanddatav(i)%dataattrv%dataattr) if (c_e(metaanddatav(i)%metadata%datetime%datetime)) then !print *,"dativarl: ", metaanddatav(i)%dataattrv%dataattr(j)%dat%btable call dativarl%append(metaanddatav(i)%dataattrv%dataattr(j)%dat%btable) else !print *,"anavarl: ", metaanddatav(i)%dataattrv%dataattr(j)%dat%btable call anavarl%append(metaanddatav(i)%dataattrv%dataattr(j)%dat%btable) end if end do end do !count and put in vector of unuique key ndativar = count_distinct(toarray_charl(dativarl) , back=.true.) allocate(dativara(ndativar)) call pack_distinct_c (toarray_charl(dativarl) , dativara , back=.true.) status = dativarl%delete() allocate (vars%dcv(ndativar)) nanavar = count_distinct(toarray_charl(anavarl) , back=.true.) allocate(anavara(nanavar)) call pack_distinct_c (toarray_charl(anavarl) , anavara , back=.true.) status = anavarl%delete() allocate (anavars%dcv(nanavar)) an: do n=1,ndativar do i =1, size(metaanddatav) do j=1, size(metaanddatav(i)%dataattrv%dataattr) if (c_e(metaanddatav(i)%metadata%datetime%datetime)) then if (metaanddatav(i)%dataattrv%dataattr(j)%dat%btable == dativara(n)) then allocate(vars%dcv(n)%dat,source=metaanddatav(i)%dataattrv%dataattr(j)%dat) cycle an end if end if end do end do end do an bn: do n=1,nanavar do i =1, size(metaanddatav) do j=1, size(metaanddatav(i)%dataattrv%dataattr) if (.not. c_e(metaanddatav(i)%metadata%datetime%datetime)) then if (metaanddatav(i)%dataattrv%dataattr(j)%dat%btable == anavara(n)) then allocate(anavars%dcv(n)%dat,source=metaanddatav(i)%dataattrv%dataattr(j)%dat) cycle bn end if end if end do end do end do bn ! attributes do i =1, size(metaanddatav) do j=1, size(metaanddatav(i)%dataattrv%dataattr) do k=1, size(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv) if (c_e(metaanddatav(i)%metadata%datetime%datetime)) then !print *,"dativarattrl: ", metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat%btable call dativarattrl%append(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat%btable) else !print *,"anavarattrl: ", metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat%btable call anavarattrl%append(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat%btable) end if end do end do end do ndativarattr = count_distinct(toarray_charl(dativarattrl), back=.true.) allocate(dativarattra(ndativarattr)) call pack_distinct_c (toarray_charl(dativarattrl), dativarattra, back=.true.) status = dativarattrl%delete() allocate(starvars%dcv(ndativarattr)) nanavarattr = count_distinct(toarray_charl(anavarattrl) , back=.true.) allocate(anavarattra(nanavarattr)) call pack_distinct_c (toarray_charl(anavarattrl) , anavarattra , back=.true.) status = anavarattrl%delete() allocate(anastarvars%dcv(nanavarattr)) cn: do n=1,ndativarattr do i =1, size(metaanddatav) do j=1, size(metaanddatav(i)%dataattrv%dataattr) do k=1, size(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv) if (c_e(metaanddatav(i)%metadata%datetime%datetime)) then if (metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat%btable == dativarattra(n))then allocate(starvars%dcv(n)%dat,source=metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat) cycle cn end if end if end do end do end do end do cn dn: do n=1,nanavarattr do i =1, size(metaanddatav) do j=1, size(metaanddatav(i)%dataattrv%dataattr) do k=1, size(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv) if (.not. c_e(metaanddatav(i)%metadata%datetime%datetime)) then if (metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat%btable == anavarattra(n))then allocate(anastarvars%dcv(n)%dat,source=metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat) cycle dn end if end if end do end do end do end do dn !!-------------------------------------------------------------------------- !! !! count all unique metadata !! if(ldegnet) then nnetwork=1 else !nnetwork = count_distinct(metaanddatav(:)%metadata%network%vol7d_network, back=.TRUE.) allocate (tmpnetwork(size(metaanddatav(:))),& source=metaanddatav(:)%metadata%network%vol7d_network) call sort(tmpnetwork) nnetwork = count_distinct_sorted(tmpnetwork) end if !ntime = count_distinct(metaanddatav(:)%metadata%datetime%datetime, & ! mask=c_e(metaanddatav(:)%metadata%datetime%datetime),back=.TRUE.) allocate (tmptime(size(metaanddatav(:))),& source=metaanddatav(:)%metadata%datetime%datetime) call sort(tmptime) ntime = count_distinct_sorted(tmptime,mask=c_e(tmptime)) !ntimerange = count_distinct(metaanddatav(:)%metadata%timerange%vol7d_timerange, & ! mask=c_e(metaanddatav(:)%metadata%timerange%vol7d_timerange), back=.TRUE.) allocate (tmptimerange(size(metaanddatav(:))),& source=metaanddatav(:)%metadata%timerange%vol7d_timerange) call sort(tmptimerange) ntimerange = count_distinct_sorted(tmptimerange,mask=c_e(tmptimerange)) !nlevel = count_distinct(metaanddatav(:)%metadata%level%vol7d_level, & ! mask=c_e(metaanddatav(:)%metadata%level%vol7d_level),back=.TRUE.) allocate (tmplevel(size(metaanddatav(:))),& source=metaanddatav(:)%metadata%level%vol7d_level) call sort(tmplevel) nlevel = count_distinct_sorted(tmplevel,mask=c_e(tmplevel)) !nana = count_distinct(metaanddatav(:)%metadata%ana%vol7d_ana, back=.TRUE.) allocate (tmpana(size(metaanddatav(:))),& source=metaanddatav(:)%metadata%ana%vol7d_ana) call sort(tmpana) nana = count_distinct_sorted(tmpana) !!$if(ldegnet) then !!$ nnetwork=1 !!$else !!$ nnetwork = size(metaanddatav(:)%metadata%network%vol7d_network) !!$end if !!$ntime = size(metaanddatav(:)%metadata%datetime%datetime) !!$ntimerange = size(metaanddatav(:)%metadata%timerange%vol7d_timerange) !!$nlevel = size(metaanddatav(:)%metadata%level%vol7d_level) !!$nana = size(metaanddatav(:)%metadata%ana%vol7d_ana) ! var ndativarr = 0 ndativari = 0 ndativarb = 0 ndativard = 0 ndativarc = 0 do i =1 ,size(vars%dcv) associate(dato => vars%dcv(i)%dat) select type (dato) type is (dbadatar) ndativarr = ndativarr + 1 type is (dbadatai) ndativari = ndativari + 1 type is (dbadatab) ndativarb = ndativarb + 1 type is (dbadatad) ndativard = ndativard + 1 type is (dbadatac) ndativarc = ndativarc + 1 end select end associate end do !attr ndatiattrr = 0 ndatiattri = 0 ndatiattrb = 0 ndatiattrd = 0 ndatiattrc = 0 do i =1 ,size(starvars%dcv) associate(dato => starvars%dcv(i)%dat) select type (dato) type is (dbadatar) ndatiattrr = ndatiattrr + 1 type is (dbadatai) ndatiattri = ndatiattri + 1 type is (dbadatab) ndatiattrb = ndatiattrb + 1 type is (dbadatad) ndatiattrd = ndatiattrd + 1 type is (dbadatac) ndatiattrc = ndatiattrc + 1 end select end associate end do ! ana var nanavarr = 0 nanavari = 0 nanavarb = 0 nanavard = 0 nanavarc = 0 do i =1 ,size(anavars%dcv) associate(dato => anavars%dcv(i)%dat) select type (dato) type is (dbadatar) nanavarr = nanavarr + 1 type is (dbadatai) nanavari = nanavari + 1 type is (dbadatab) nanavarb = nanavarb + 1 type is (dbadatad) nanavard = nanavard + 1 type is (dbadatac) nanavarc = nanavarc + 1 end select end associate end do ! ana attr nanaattrr = 0 nanaattri = 0 nanaattrb = 0 nanaattrd = 0 nanaattrc = 0 do i =1 ,size(anastarvars%dcv) associate(dato => anastarvars%dcv(i)%dat) select type (dato) type is (dbadatar) nanaattrr = nanaattrr + 1 type is (dbadatai) nanaattri = nanaattri + 1 type is (dbadatab) nanaattrb = nanaattrb + 1 type is (dbadatad) nanaattrd = nanaattrd + 1 type is (dbadatac) nanaattrc = nanaattrc + 1 end select end associate end do !refine ndativarattrr=0 ndativarattri=0 ndativarattrb=0 ndativarattrd=0 ndativarattrc=0 if (ndatiattrr > 0 ) ndativarattrr=ndativarr+ndativari+ndativarb+ndativard+ndativarc if (ndatiattri > 0 ) ndativarattri=ndativarr+ndativari+ndativarb+ndativard+ndativarc if (ndatiattrb > 0 ) ndativarattrb=ndativarr+ndativari+ndativarb+ndativard+ndativarc if (ndatiattrd > 0 ) ndativarattrd=ndativarr+ndativari+ndativarb+ndativard+ndativarc if (ndatiattrc > 0 ) ndativarattrc=ndativarr+ndativari+ndativarb+ndativard+ndativarc nanavarattrr=0 nanavarattri=0 nanavarattrb=0 nanavarattrd=0 nanavarattrc=0 if (nanaattrr > 0 ) nanavarattrr=nanavarr+nanavari+nanavarb+nanavard+nanavarc if (nanaattri > 0 ) nanavarattri=nanavarr+nanavari+nanavarb+nanavard+nanavarc if (nanaattrb > 0 ) nanavarattrb=nanavarr+nanavari+nanavarb+nanavard+nanavarc if (nanaattrd > 0 ) nanavarattrd=nanavarr+nanavari+nanavarb+nanavard+nanavarc if (nanaattrc > 0 ) nanavarattrc=nanavarr+nanavari+nanavarb+nanavard+nanavarc CALL init(this,time_definition=ltime_definition) !!$print *, "nana=",nana, "ntime=",ntime, "ntimerange=",ntimerange, & !!$ "nlevel=",nlevel, "nnetwork=",nnetwork, & !!$ "ndativarr=",ndativarr, "ndativari=",ndativari, & !!$ "ndativarb=",ndativarb, "ndativard=",ndativard, "ndativarc=",ndativarc,& !!$ "ndatiattrr=",ndatiattrr, "ndatiattri=",ndatiattri, "ndatiattrb=",ndatiattrb,& !!$ "ndatiattrd=",ndatiattrd, "ndatiattrc=",ndatiattrc,& !!$ "ndativarattrr=",ndativarattrr, "ndativarattri=",ndativarattri, "ndativarattrb=",ndativarattrb,& !!$ "ndativarattrd=",ndativarattrd, "ndativarattrc=",ndativarattrc !!$ !!$print *,"nanaattrr,nanaattri,nanaattrb,nanaattrd,nanaattrc" !!$print *,nanaattrr,nanaattri,nanaattrb,nanaattrd,nanaattrc call vol7d_alloc (this, & nana=nana, ntime=ntime, ntimerange=ntimerange, & nlevel=nlevel, nnetwork=nnetwork, & ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb, ndativard=ndativard, ndativarc=ndativarc,& ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb, ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,& ndativarattrr=ndativarattrr, & ndativarattri=ndativarattri, & ndativarattrb=ndativarattrb, & ndativarattrd=ndativarattrd, & ndativarattrc=ndativarattrc,& nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, nanavard=nanavard, nanavarc=nanavarc,& nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb, nanaattrd=nanaattrd, nanaattrc=nanaattrc,& nanavarattrr=nanavarattrr, & nanavarattri=nanavarattri, & nanavarattrb=nanavarattrb, & nanavarattrd=nanavarattrd, & nanavarattrc=nanavarattrc) ! fill metadata removing contextana metadata !nana=count_and_pack_distinct(metaanddatav(:)%metadata%ana%vol7d_ana,this%ana, back=.TRUE.) !this%ana=pack_distinct(metaanddatav(:)%metadata%ana%vol7d_ana, nana, back=.TRUE.) this%ana=pack_distinct_sorted(tmpana, nana) deallocate(tmpana) !call sort(this%ana) !ntime=count_and_pack_distinct(metaanddatav(:)%metadata%datetime%datetime,this%time, & ! mask=c_e(metaanddatav(:)%metadata%datetime%datetime), back=.TRUE.) !this%time=pack_distinct(metaanddatav(:)%metadata%datetime%datetime, ntime, & ! mask=c_e(metaanddatav(:)%metadata%datetime%datetime),back=.TRUE.) this%time=pack_distinct_sorted(tmptime, ntime,mask=c_e(tmptime)) deallocate(tmptime) !call sort(this%time) !ntimerange=count_and_pack_distinct(metaanddatav(:)%metadata%timerange%vol7d_timerange,this%timerange, & ! mask=c_e(metaanddatav(:)%metadata%timerange%vol7d_timerange), back=.TRUE.) !this%timerange=pack_distinct(metaanddatav(:)%metadata%timerange%vol7d_timerange, ntimerange, & ! mask=c_e(metaanddatav(:)%metadata%timerange%vol7d_timerange), back=.TRUE.) this%timerange=pack_distinct_sorted(tmptimerange, ntimerange,mask=c_e(tmptimerange)) deallocate(tmptimerange) !call sort(this%timerange) !nlevel=count_and_pack_distinct(metaanddatav(:)%metadata%level%vol7d_level,this%level, & ! mask=c_e(metaanddatav(:)%metadata%level%vol7d_level), back=.TRUE.) !this%level=pack_distinct(metaanddatav(:)%metadata%level%vol7d_level, nlevel, & ! mask=c_e(metaanddatav(:)%metadata%level%vol7d_level), back=.TRUE.) this%level=pack_distinct_sorted(tmplevel, nlevel,mask=c_e(tmplevel)) deallocate(tmplevel) !call sort(this%level) if(ldegnet)then nnetwork=1 ALLOCATE(this%network(1)) this%network(1)=set_network else !nnetwork=count_and_pack_distinct(metaanddatav(:)%metadata%network%vol7d_network,this%network, back=.TRUE.) !this%network=pack_distinct(metaanddatav(:)%metadata%network%vol7d_network, nnetwork, back=.TRUE.) this%network=pack_distinct_sorted(tmpnetwork, nnetwork) deallocate(tmpnetwork) end if !call sort(this%network) ! var ndativarr = 0 ndativari = 0 ndativarb = 0 ndativard = 0 ndativarc = 0 do i =1 ,size(vars%dcv) associate(dato => vars%dcv(i)%dat) select type (dato) type is (dbadatar) ndativarr = ndativarr + 1 call init (this%dativar%r(ndativarr), btable=dato%btable) type is (dbadatai) ndativari = ndativari + 1 call init (this%dativar%i(ndativari), btable=dato%btable) type is (dbadatab) ndativarb = ndativarb + 1 call init (this%dativar%b(ndativarb), btable=dato%btable) type is (dbadatad) ndativard = ndativard + 1 call init (this%dativar%d(ndativard), btable=dato%btable) type is (dbadatac) ndativarc = ndativarc + 1 call init (this%dativar%c(ndativarc), btable=dato%btable) end select end associate end do !attr ndatiattrr = 0 ndatiattri = 0 ndatiattrb = 0 ndatiattrd = 0 ndatiattrc = 0 do i =1 ,size(starvars%dcv) associate(dato => starvars%dcv(i)%dat) select type (dato) type is (dbadatar) ndatiattrr = ndatiattrr + 1 call init (this%datiattr%r(ndatiattrr), btable=dato%btable) type is (dbadatai) ndatiattri = ndatiattri + 1 call init (this%datiattr%i(ndatiattri), btable=dato%btable) type is (dbadatab) ndatiattrb = ndatiattrb + 1 call init (this%datiattr%b(ndatiattrb), btable=dato%btable) type is (dbadatad) ndatiattrd = ndatiattrd + 1 call init (this%datiattr%d(ndatiattrd), btable=dato%btable) type is (dbadatac) ndatiattrc = ndatiattrc + 1 call init (this%datiattr%c(ndatiattrc), btable=dato%btable) end select end associate end do ! ana var nanavarr = 0 nanavari = 0 nanavarb = 0 nanavard = 0 nanavarc = 0 do i =1 ,size(anavars%dcv) associate(dato => anavars%dcv(i)%dat) select type (dato) type is (dbadatar) nanavarr = nanavarr + 1 call init (this%anavar%r(nanavarr), btable=dato%btable) type is (dbadatai) nanavari = nanavari + 1 call init (this%anavar%i(nanavari), btable=dato%btable) type is (dbadatab) nanavarb = nanavarb + 1 call init (this%anavar%b(nanavarb), btable=dato%btable) type is (dbadatad) nanavard = nanavard + 1 call init (this%anavar%d(nanavard), btable=dato%btable) type is (dbadatac) nanavarc = nanavarc + 1 call init (this%anavar%c(nanavarc), btable=dato%btable) end select end associate end do ! ana attr nanaattrr = 0 nanaattri = 0 nanaattrb = 0 nanaattrd = 0 nanaattrc = 0 do i =1 ,size(anastarvars%dcv) associate(dato => anastarvars%dcv(i)%dat) select type (dato) type is (dbadatar) nanaattrr = nanaattrr + 1 call init (this%anaattr%r(nanaattrr), btable=dato%btable) type is (dbadatai) nanaattri = nanaattri + 1 call init (this%anaattr%i(nanaattri), btable=dato%btable) type is (dbadatab) nanaattrb = nanaattrb + 1 call init (this%anaattr%b(nanaattrb), btable=dato%btable) type is (dbadatad) nanaattrd = nanaattrd + 1 call init (this%anaattr%d(nanaattrd), btable=dato%btable) type is (dbadatac) nanaattrc = nanaattrc + 1 call init (this%anaattr%c(nanaattrc), btable=dato%btable) end select end associate end do ! here we colcolate the link from attributes and vars do i =1, size(vars%dcv) associate(dato => vars%dcv(i)%dat) if ( ndativarattri > 0 ) call init(this%dativarattr%i(i),btable=dato%btable) if ( ndativarattrr > 0 ) call init(this%dativarattr%r(i),btable=dato%btable) if ( ndativarattrd > 0 ) call init(this%dativarattr%d(i),btable=dato%btable) if ( ndativarattrb > 0 ) call init(this%dativarattr%b(i),btable=dato%btable) if ( ndativarattrc > 0 ) call init(this%dativarattr%c(i),btable=dato%btable) end associate end do do i =1, size(anavars%dcv) associate(dato => anavars%dcv(i)%dat) if ( nanavarattri > 0 ) call init(this%anavarattr%i(i),btable=dato%btable) if ( nanavarattrr > 0 ) call init(this%anavarattr%r(i),btable=dato%btable) if ( nanavarattrd > 0 ) call init(this%anavarattr%d(i),btable=dato%btable) if ( nanavarattrb > 0 ) call init(this%anavarattr%b(i),btable=dato%btable) if ( nanavarattrc > 0 ) call init(this%anavarattr%c(i),btable=dato%btable) end associate end do ! set index in dativaratt* call vol7d_set_attr_ind(this) call vol7d_alloc_vol (this) ! Ora qui bisogna metterci dentro idati indana = 0 indtime = 0 indnetwork = 0 indtime = 0 indtimerange = 0 indlevel = 0 do i =1, size(metaanddatav) indana = index_sorted(this%ana, metaanddatav(i)%metadata%ana%vol7d_ana) if (ldegnet)then indnetwork=1 else indnetwork = index_sorted(this%network, metaanddatav(i)%metadata%network%vol7d_network) endif if (c_e(metaanddatav(i)%metadata%datetime%datetime) .and. & c_e(metaanddatav(i)%metadata%timerange%vol7d_timerange) .and. & c_e(metaanddatav(i)%metadata%level%vol7d_level) ) then ! dati indtime = index_sorted(this%time, metaanddatav(i)%metadata%datetime%datetime) indtimerange = index_sorted(this%timerange, metaanddatav(i)%metadata%timerange%vol7d_timerange) indlevel = index_sorted(this%level, metaanddatav(i)%metadata%level%vol7d_level) do j=1, size(metaanddatav(i)%dataattrv%dataattr) associate(dato => metaanddatav(i)%dataattrv%dataattr(j)%dat) select type (dato) type is (dbadatai) inddativar = firsttrue(dato%btable == this%dativar%i%btable) this%voldatii( & indana,indtime,indlevel,indtimerange,inddativar,indnetwork & ) = dato%value type is (dbadatar) inddativar = firsttrue(dato%btable == this%dativar%r%btable) this%voldatir( & indana,indtime,indlevel,indtimerange,inddativar,indnetwork & ) = dato%value type is (dbadatad) inddativar = firsttrue(dato%btable == this%dativar%d%btable) this%voldatid( & indana,indtime,indlevel,indtimerange,inddativar,indnetwork & ) = dato%value type is (dbadatab) inddativar = firsttrue(dato%btable == this%dativar%b%btable) this%voldatib( & indana,indtime,indlevel,indtimerange,inddativar,indnetwork & ) = dato%value type is (dbadatac) inddativar = firsttrue(dato%btable == this%dativar%c%btable) this%voldatic( & indana,indtime,indlevel,indtimerange,inddativar,indnetwork & ) = dato%value end select ! dati attributes do k=1, size(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv) associate(attr => metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat) select type (attr) type is (dbadatai) inddativarattr = firsttrue(dato%btable == this%dativarattr%i%btable) indattrvar = firsttrue(attr%btable == this%datiattr%i%btable) this%voldatiattri( & indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar & ) = attr%value type is (dbadatar) inddativarattr = firsttrue(dato%btable == this%dativarattr%r%btable) indattrvar = firsttrue(attr%btable == this%datiattr%r%btable) this%voldatiattrr( & indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar & ) = attr%value type is (dbadatad) inddativarattr = firsttrue(dato%btable == this%dativarattr%d%btable) indattrvar = firsttrue(attr%btable == this%datiattr%d%btable) this%voldatiattrd( & indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar & ) = attr%value type is (dbadatab) inddativarattr = firsttrue(dato%btable == this%dativarattr%b%btable) indattrvar = firsttrue(attr%btable == this%datiattr%b%btable) this%voldatiattrb( & indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar & ) = attr%value type is (dbadatac) inddativarattr = firsttrue(dato%btable == this%dativarattr%c%btable) indattrvar = firsttrue(attr%btable == this%datiattr%c%btable) this%voldatiattrc( & indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar & ) = attr%value end select end associate end do end associate end do else ! ana do j=1, size(metaanddatav(i)%dataattrv%dataattr) associate(dato => metaanddatav(i)%dataattrv%dataattr(j)%dat) select type (dato) type is (dbadatai) indanavar = firsttrue(dato%btable == this%anavar%i%btable) this%volanai( & indana,indanavar,indnetwork & ) = dato%value type is (dbadatar) indanavar = firsttrue(dato%btable == this%anavar%r%btable) this%volanar( & indana,indanavar,indnetwork & ) = dato%value type is (dbadatad) indanavar = firsttrue(dato%btable == this%anavar%d%btable) this%volanad( & indana,indanavar,indnetwork & ) = dato%value type is (dbadatab) indanavar = firsttrue(dato%btable == this%anavar%b%btable) this%volanab( & indana,indanavar,indnetwork & ) = dato%value type is (dbadatac) indanavar = firsttrue(dato%btable == this%anavar%c%btable) this%volanac( & indana,indanavar,indnetwork & ) = dato%value end select ! ana attributes do k=1, size(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv) associate(attr => metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat) select type (attr) type is (dbadatai) indanavarattr = firsttrue(dato%btable == this%anavarattr%i%btable) indattrvar = firsttrue(attr%btable == this%anaattr%i%btable) this%volanaattri( & indana,indanavarattr,indnetwork,indattrvar & ) = attr%value type is (dbadatar) indanavarattr = firsttrue(dato%btable == this%anavarattr%r%btable) indattrvar = firsttrue(attr%btable == this%anaattr%r%btable) this%volanaattrr( & indana,indanavarattr,indnetwork,indattrvar & ) = attr%value type is (dbadatad) indanavarattr = firsttrue(dato%btable == this%anavarattr%d%btable) indattrvar = firsttrue(attr%btable == this%anaattr%d%btable) this%volanaattrd( & indana,indanavarattr,indnetwork,indattrvar & ) = attr%value type is (dbadatab) indanavarattr = firsttrue(dato%btable == this%anavarattr%b%btable) indattrvar = firsttrue(attr%btable == this%anaattr%b%btable) this%volanaattrb( & indana,indanavarattr,indnetwork,indattrvar & ) = attr%value type is (dbadatac) indanavarattr = firsttrue(dato%btable == this%anavarattr%c%btable) indattrvar = firsttrue(attr%btable == this%anaattr%c%btable) this%volanaattrc( & indana,indanavarattr,indnetwork,indattrvar & ) = attr%value end select end associate end do end associate end do end if end do contains !!$!> /brief Return an dbadcv from a mixlist with dbadata* type !!$function todcv_dbadat(this) !!$type(dbadcv) :: todcv_dbadat !< array !!$type(mixlist) :: this !!$ !!$integer :: i !!$ !!$allocate (todcv_dbadat%dcv(this%countelements())) !!$ !!$call this%rewind() !!$i=0 !!$do while(this%element()) !!$ i=i+1 !!$ !!$ associate (dato => this%current()) !!$ select type (dato) !!$ type is (dbadatar) !!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato) !!$ type is (dbadatai) !!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato) !!$ type is (dbadatab) !!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato) !!$ type is (dbadatad) !!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato) !!$ type is (dbadatac) !!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato) !!$ end select !!$ end associate !!$ !!$ call this%next() !!$end do !!$end function todcv_dbadat !!$! Definisce le funzioni count_distinct e pack_distinct !!$#define VOL7D_POLY_TYPE TYPE(dbadata) !!$#define VOL7D_POLY_TYPES _dbadata !!$#undef ENABLE_SORT !!$#include "array_utilities_inc.F90" !!$#undef VOL7D_POLY_TYPE !!$#undef VOL7D_POLY_TYPES end subroutine dba2v7d subroutine vol7d_dballe_import_dballevar(this) type(vol7d_var),pointer :: this(:) INTEGER :: i,un,n IF (associated(this)) return IF (allocated(blocal)) then ALLOCATE(this(size(blocal))) this=blocal return end if un = open_dballe_file('dballe.txt', filetype_data) IF (un < 0) then call l4f_log(l4f_error,"error open_dballe_file: dballe.txt") CALL raise_error("error open_dballe_file: dballe.txt") return end if n = 0 DO WHILE(.true.) READ(un,*,END=100) n = n + 1 ENDDO 100 CONTINUE IF (n > 0) THEN ALLOCATE(this(n)) ALLOCATE(blocal(n)) rewind(un) readline: do i = 1 ,n READ(un,'(1x,A6,1x,a65,a24,i4)')blocal(i)%btable,blocal(i)%description,blocal(i)%unit,& blocal(i)%scalefactor blocal(i)%btable(:1)="B" !print*,"B=",blocal(i)%btable !print*," D=",blocal(i)%description !PRINT*," U=",blocal(i)%unit !PRINT*," D=",blocal(i)%scalefactor ENDDO readline CALL l4f_log(l4f_info,'Found '//trim(to_char(i-1))//' variables in dballe master table') this=blocal ENDIF CLOSE(un) END SUBROUTINE vol7d_dballe_import_dballevar !> \brief Integra il vettore delle variabili in vol7d con le descrizioni e le unità di misura !!eventualmente mancanti. subroutine vol7d_dballe_set_var_du(this) TYPE(vol7d) :: this !< oggetto vol7d con le variabili da completare integer :: i,j type(vol7d_var),pointer :: dballevar(:) nullify(dballevar) call vol7d_dballe_import_dballevar(dballevar) #undef VOL7D_POLY_NAME #define VOL7D_POLY_NAME dativar #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V r #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V i #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V b #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V d #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V c #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #undef VOL7D_POLY_NAME #define VOL7D_POLY_NAME anavar #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V r #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V i #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V b #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V d #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V c #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #undef VOL7D_POLY_NAME #define VOL7D_POLY_NAME datiattr #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V r #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V i #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V b #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V d #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V c #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #undef VOL7D_POLY_NAME #define VOL7D_POLY_NAME anaattr #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V r #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V i #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V b #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V d #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V c #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V deallocate(dballevar) return end subroutine vol7d_dballe_set_var_du FUNCTION get_dballe_filepath(filename, filetype) RESULT(path) CHARACTER(len=*), INTENT(in) :: filename INTEGER, INTENT(in) :: filetype INTEGER :: j CHARACTER(len=512) :: path LOGICAL :: exist IF (dballe_name == ' ') THEN CALL getarg(0, dballe_name) ! dballe_name_env ENDIF IF (filetype < 1 .OR. filetype > nftype) THEN path = "" CALL l4f_log(l4f_error, 'dballe file type '//trim(to_char(filetype))// & ' not valid') CALL raise_error() RETURN ENDIF ! try with environment variable CALL getenv(trim(dballe_name_env), path) IF (path /= ' ') THEN path=trim(path)//'/'//filename INQUIRE(file=path, exist=exist) IF (exist) THEN CALL l4f_log(l4f_info, 'dballe file '//trim(path)//' found') RETURN ENDIF ENDIF ! try with pathlist DO j = 1, SIZE(pathlist,1) IF (pathlist(j,filetype) == ' ') EXIT path=trim(pathlist(j,filetype))//'/'//trim(dballe_name)//'/'//filename INQUIRE(file=path, exist=exist) IF (exist) THEN CALL l4f_log(l4f_info, 'dballe file '//trim(path)//' found') RETURN ENDIF ENDDO CALL l4f_log(l4f_error, 'dballe file '//trim(filename)//' not found') CALL raise_error() path = "" END FUNCTION get_dballe_filepath FUNCTION open_dballe_file(filename, filetype) RESULT(unit) CHARACTER(len=*), INTENT(in) :: filename INTEGER, INTENT(in) :: filetype INTEGER :: unit,i CHARACTER(len=512) :: path unit = -1 path=get_dballe_filepath(filename, filetype) IF (path == '') RETURN unit = getunit() IF (unit == -1) RETURN OPEN(unit, file=path, status='old', iostat = i) IF (i == 0) THEN CALL l4f_log(l4f_info, 'dballe file '//trim(path)//' opened') RETURN ENDIF CALL l4f_log(l4f_error, 'dballe file '//trim(filename)//' not found') CALL raise_error() unit = -1 END FUNCTION open_dballe_file !> \brief Exporta un volume dati a un DSN DB-all.e !! !! Riscrive i dati nel DSN di DB-All.e con la possibilità di attivare !! una serie di filtri. !!! TODO manage attr_only !!! attention template migrated in init !SUBROUTINE vol7d_dballe_export(this, network, coordmin, coordmax,& ! timei, timef,level,timerange,var,attr,anavar,anaattr,attr_only,ana,dataonly) SUBROUTINE vol7d_dballe_export_old(this, network, coordmin, coordmax,& timei, timef,level,timerange,var,attr,anavar,anaattr,ana,dataonly,anaonly,template,attr_only) TYPE(vol7d_dballe),INTENT(inout) :: this !< oggetto contenente il volume e altre info per l'accesso al DSN character(len=network_name_len),INTENT(in),optional :: network !< network da exportare !> coordinate minime e massime che definiscono il !! rettangolo di estrazione per l'esportazione TYPE(geo_coord),INTENT(in),optional :: coordmin,coordmax !>estremi temporali dei dati da esportare TYPE(datetime),INTENT(in),optional :: timei, timef TYPE(vol7d_level),INTENT(in),optional :: level !< livello selezionato per l'esportazione TYPE(vol7d_timerange),INTENT(in),optional :: timerange !< timerange selezionato per l'esportazione !> variabili da exportare secondo la tabella B locale o alias relative a dati, attributi, !! anagrafica e attributi dell'anagrafica CHARACTER(len=*),INTENT(in),OPTIONAL :: var(:),attr(:),anavar(:),anaattr(:) !!$!> permette di riscrivere su un DSN letto precedentemente, modificando solo gli attributi ai dati, !!$!! ottimizzando enormente le prestazioni: gli attributi riscritti saranno quelli con this%data_id definito !!$!! (solitamente ricopiato dall'oggetto letto) !!$logical,intent(in),optional :: attr_only TYPE(vol7d_ana),INTENT(inout),optional :: ana !< identificativo della stazione da exportare logical, intent(in),optional :: dataonly !< set to .true. to export data only logical, intent(in),optional :: anaonly !< set to .true. to export ana only !> specificando category.subcategory.localcategory oppure un alias ("synop", "metar","temp","generic") forza l'exportazione ad uno specifico template BUFR/CREX" !! the special value "generic-frag is used to generate bufr on file where ana data is reported only once at beginning and data in other bufr after character(len=*),intent(in),optional :: template logical, intent(in),optional :: attr_only !< set to .true. to export attr only (no data) type(dbadcv) :: vars,starvars,anavars,anastarvars type(dbafilter) :: filter type(dbacoord) :: mydbacoordmin, mydbacoordmax type(dbaana) :: mydbaana type(dbadatetime) :: mydatetimemin, mydatetimemax type(dbatimerange) :: mydbatimerange type(dbalevel) :: mydbalevel type(dbanetwork) :: mydbanetwork integer :: i LOGICAL :: lattr, lanaattr integer :: nanaattr,nattr,nanavar,nvar ! ------------- prepare filter options !! !! translate export option for dballe2003 api !! if (present(var)) then nvar=count(c_e(var)) if (nvar > 0) then allocate (vars%dcv(nvar)) do i=1,size(var) if (c_e(var(i)))then allocate (vars%dcv(i)%dat,source=dbadatac(var(i))) !char is default end if end do end if end if if (present(anavar)) then nanavar=count(c_e(anavar)) if (nanavar > 0) then allocate (anavars%dcv(nanavar)) do i=1,size(anavar) if (c_e(anavar(i)))then allocate (anavars%dcv(i)%dat,source=dbadatac(anavar(i))) !char is default end if end do end if end if lattr = .false. if (present(attr)) then nattr=count(c_e(attr)) if (nattr > 0) then lattr = .true. allocate (starvars%dcv(nattr)) do i=1,size(attr) if (c_e(attr(i)))then allocate (starvars%dcv(i)%dat,source=dbadatac(attr(i))) !char is default end if end do end if end if lanaattr = .false. if (present(anaattr)) then nanaattr=count(c_e(anaattr)) if (nanaattr > 0) then lanaattr = .true. allocate (anastarvars%dcv(nanaattr)) do i=1,size(anaattr) if (c_e(anaattr(i)))then allocate (anastarvars%dcv(i)%dat,source=dbadatac(anaattr(i))) !char is default end if end do end if end if ! like a cast mydbacoordmin=dbacoord() if (present(coordmin)) mydbacoordmin%geo_coord=coordmin mydbacoordmax=dbacoord() if (present(coordmax)) mydbacoordmax%geo_coord=coordmax mydbaana=dbaana() if (present(ana)) mydbaana%vol7d_ana=ana mydatetimemin=dbadatetime() if (present(timei)) mydatetimemin%datetime=timei mydatetimemax=dbadatetime() if (present(timef)) mydatetimemax%datetime=timef mydbatimerange=dbatimerange() if (present(timerange)) mydbatimerange%vol7d_timerange=timerange mydbalevel=dbalevel() if (present(level)) mydbalevel%vol7d_level=level mydbanetwork=dbanetwork() if (present(network)) call init(mydbanetwork%vol7d_network,name=network) !! !! here we have options ready for filter !! filter=dbafilter(coordmin=mydbacoordmin,coordmax=mydbacoordmax,ana=mydbaana, & datetimemin=mydatetimemin,datetimemax=mydatetimemax, & timerange=mydbatimerange,level=mydbalevel,network=mydbanetwork,& vars=vars,starvars=starvars,anavars=anavars,anastarvars=anastarvars,& dataonly=dataonly,anaonly=anaonly) !!$ print *, "filter:" !!$ call filter%display() call export (this, filter,template,attr_only) end SUBROUTINE vol7d_dballe_export_old subroutine vol7d_dballe_export (this, filter, template, attr_only) TYPE(vol7d_dballe),INTENT(inout) :: this !< oggetto contenente il volume e altre info per l'accesso al DSN type(dbafilter),intent(in) :: filter !< filter o use !> specificando category.subcategory.localcategory oppure un alias ("synop", "metar","temp","generic") forza l'exportazione ad uno specifico template BUFR/CREX" !! the special value "generic-frag is used to generate bufr on file where ana data is reported only once at beginning and data in other bufr after character(len=*),intent(in),optional :: template logical, intent(in),optional :: attr_only !< set to .true. to export attr only (no data) character(len=40) :: ltemplate type(dbametaanddatalist) :: metaanddatal logical :: stat metaanddatal=dbametaanddatalist() call v7d2dba(this%vol7d,metaanddatal) !call metaanddatal%display() !clean memdb if (this%file) call this%handle%remove_all() ! using filter here can limit memory use for memdb call metaanddatal%extrude(session=this%handle,filter=filter,attronly=attr_only,template=template) if (this%file) then !!!!! this if we have written in memdb and now we have to write the file !filter is already in extrude !this%handle%set(filter=filter) ! export to file !! TODO : revert template from init to export !!!!!!!!!!!!!!!!!!!!! !!call this%handle%messages_write_next(template) ! note that you can use unsetall hera because the filter was used in extrude call filter%dbaset(this%handle) ltemplate=this%handle%template if (present(template))then ltemplate=template end if call this%handle%messages_write_next(ltemplate) !clean memdb call this%handle%remove_all() end if stat = metaanddatal%delete() end subroutine vol7d_dballe_export subroutine v7d2dba(v7d,metaanddatal) TYPE(vol7d),INTENT(in) :: v7d !!!!!! dovrebbe essere intent(in) type(dbametaanddatalist),intent(inout) :: metaanddatal TYPE(vol7d_serialize_dballe) :: serialize serialize = vol7d_serialize_dballe_new() serialize%anaonly=.true. call serialize%vol7d_serialize_setup(v7d) call serialize%vol7d_serialize_export(metaanddatal) serialize = vol7d_serialize_dballe_new() serialize%dataonly=.true. call serialize%vol7d_serialize_setup(v7d) call serialize%vol7d_serialize_export(metaanddatal) end subroutine v7d2dba end MODULE vol7d_dballe_class !>\example esempio_v7ddballe.f90 !!/brief Programma esempio semplice per l'uso di vol7d con DB-All.e !! !>\example esempio_v7ddballe_multi.f90 !!/brief Programma esempio per l'uso di vol7d con DB-All.e !! !!Vengono estratte più reti !>\example esempio_v7ddballe_import_export.f90 !!\brief Esempio di utilizzo della classe vol7d_dballe_class !! !! Vengono estratti i dati e riscritti in un nuovo DSN