libsim Versione 7.2.1
vol7d_dballe_class.F03
1! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2! authors:
3! Davide Cesari <dcesari@arpa.emr.it>
4! Paolo Patruno <ppatruno@arpa.emr.it>
5
6! This program is free software; you can redistribute it and/or
7! modify it under the terms of the GNU General Public License as
8! published by the Free Software Foundation; either version 2 of
9! the License, or (at your option) any later version.
10
11! This program is distributed in the hope that it will be useful,
12! but WITHOUT ANY WARRANTY; without even the implied warranty of
13! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14! GNU General Public License for more details.
15
16! You should have received a copy of the GNU General Public License
17! along with this program. If not, see <http://www.gnu.org/licenses/>.
18
19#include "config.h"
20
77
79
86!use list_mix
89use vol7d_serialize_dballe_class
90
91IMPLICIT NONE
92
93character (len=255),parameter:: subcategory="vol7d_dballe_class"
94
101
102TYPE vol7d_dballe
103
104 TYPE(vol7d) :: vol7d
105 type(dbaconnection) :: idbhandle
106 type(dbasession) :: handle
109 integer ,pointer :: data_id(:,:,:,:,:)
110 integer :: time_definition
111 integer :: category = 0
112 logical :: file
113
114END TYPE vol7d_dballe
115
116INTEGER, PARAMETER, PRIVATE :: nftype = 2
117CHARACTER(len=16), PARAMETER, PRIVATE :: &
118 pathlist(2,nftype) = reshape((/ &
119 '/usr/share ', '/usr/local/share', &
120 '/etc ', '/usr/local/etc ' /), &
121 (/2,nftype/))
122
123
124type(vol7d_var),allocatable,private :: blocal(:) ! cache of dballe.txt
125
126CHARACTER(len=20),PRIVATE :: dballe_name='wreport', dballe_name_env='DBA_TABLES'
127
128
130INTERFACE init
131 MODULE PROCEDURE vol7d_dballe_init
132END INTERFACE init
133
135INTERFACE delete
136 MODULE PROCEDURE vol7d_dballe_delete
137END INTERFACE delete
138
139
141INTERFACE import
142 MODULE PROCEDURE vol7d_dballe_importvvnv,vol7d_dballe_import, vol7d_dballe_import_old, dba2v7d
143END INTERFACE import
144
146INTERFACE export
147 MODULE PROCEDURE vol7d_dballe_export_old,vol7d_dballe_export, v7d2dba
148END INTERFACE export
149
150
151PRIVATE
152PUBLIC vol7d_dballe, init, delete, import, export, vol7d_dballe_import_dballevar, vol7d_dballe_set_var_du
153
154CONTAINS
155
156
158SUBROUTINE vol7d_dballe_init(this,dsn,user,password,write,wipe,repinfo,&
159 filename,format,file,categoryappend,time_definition,idbhandle,template)
160
161
162TYPE(vol7d_dballe),INTENT(out) :: this
163character(len=*), INTENT(in),OPTIONAL :: dsn
164character(len=*), INTENT(in),OPTIONAL :: user
165character(len=*), INTENT(in),OPTIONAL :: password
166logical,INTENT(in),OPTIONAL :: write
167logical,INTENT(in),OPTIONAL :: wipe
168character(len=*), INTENT(in),OPTIONAL :: repinfo
169character(len=*),intent(inout),optional :: filename
170character(len=*),intent(in),optional :: format
171logical,INTENT(in),OPTIONAL :: file
172character(len=*),INTENT(in),OPTIONAL :: categoryappend
173integer,INTENT(in),OPTIONAL :: time_definition
174integer,INTENT(in),OPTIONAL :: idbhandle
177character(len=*),intent(in),optional :: template
178
179logical :: quiwrite,loadfile
180character(len=512) :: a_name
181character(len=254) :: arg,lfilename,lformat
182
183quiwrite=.false.
184if (present(write))then
185 quiwrite=write
186endif
187
188if (present(categoryappend))then
189 call l4f_launcher(a_name,a_name_append=trim(subcategory)//"."//trim(categoryappend))
190else
191 call l4f_launcher(a_name,a_name_append=trim(subcategory))
192endif
193this%category=l4f_category_get(a_name)
194
195#ifdef DEBUG
196CALL l4f_category_log(this%category,l4f_debug,'vol7d_dballe_init start')
197#endif
198
199nullify(this%data_id)
200
201if (optio_log(file)) then
202
203 this%file=.true.
204
205 lformat="BUFR"
206 if (present(format))then
207 lformat=format
208 end if
209
210 CALL getarg(0,arg)
211
212 lfilename=trim(arg)//"."//trim(lformat)
213 if (index(arg,'/',back=.true.) > 0) lfilename=lfilename(index(arg,'/',back=.true.)+1 : )
214
215 if (present(filename))then
216 if (c_e(filename))then
217 lfilename=filename
218 end if
219 end if
220
221 if(quiwrite)then
222 ! this for write in memdb and write file on export
223 loadfile=.false.
224 else
225 loadfile=.true.
226 end if
227
228 this%handle=dbasession(wipe=wipe,write=quiwrite,repinfo=repinfo, &
229 filename=lfilename,format=lformat,template=template, &
230 memdb=.true.,loadfile=loadfile)
231
232else
233
234 this%file=.false.
235 this%idbhandle=dbaconnection(dsn,user,password,idbhandle=idbhandle)
236 this%handle=dbasession(this%idbhandle,wipe=wipe,write=quiwrite,repinfo=repinfo)
237
238endif
239
240! this init has been added here for cleaningness, this%vol7d gets
241! reinitialised afterwards in dba2v7d and this%vol7d%time_definition is
242! overwritten by this%time_definition, this duplication is required in
243! order to pass time_definition down to dba2v7d
244CALL init(this%vol7d, time_definition)
245this%time_definition = optio_i(time_definition)
246
247#ifdef DEBUG
248CALL l4f_category_log(this%category,l4f_debug,'vol7d_dballe_init end')
249#endif
250
251END SUBROUTINE vol7d_dballe_init
252
253
254
258
259SUBROUTINE vol7d_dballe_importvvnv(this, var, network, coordmin,coordmax, timei, timef, level,timerange,set_network,&
260 attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,dataonly,ana)
261TYPE(vol7d_dballe),INTENT(inout) :: this
262CHARACTER(len=*),INTENT(in) :: var(:)
263TYPE(geo_coord),INTENT(inout),optional :: coordmin,coordmax
264TYPE(vol7d_ana),INTENT(inout),optional :: ana
265TYPE(datetime),INTENT(in),optional :: timei, timef
266TYPE(vol7d_network),INTENT(in) :: network(:)
267TYPE(vol7d_network),INTENT(in),OPTIONAL :: set_network
268TYPE(vol7d_level),INTENT(in),optional :: level
269TYPE(vol7d_timerange),INTENT(in),optional :: timerange
270CHARACTER(len=*),INTENT(in),OPTIONAL :: attr(:),anavar(:),anaattr(:)
271CHARACTER(len=*),INTENT(in),OPTIONAL :: varkind(:),attrkind(:),anavarkind(:),anaattrkind(:)
272logical,intent(in),optional :: anaonly
273LOGICAL,INTENT(in),OPTIONAL :: dataonly
274TYPE(vol7d_dballe) :: v7ddbatmp
275
276INTEGER :: i
277
278IF (SIZE(network) == 0 )THEN
279 CALL import(this, var, coordmin=coordmin, coordmax=coordmax, timei=timei, &
280 timef=timef, level=level, timerange=timerange, set_network=set_network, &
281 attr=attr, anavar=anavar, anaattr=anaattr, varkind=varkind, attrkind=attrkind, &
282 anavarkind=anavarkind, anaattrkind=anaattrkind, anaonly=anaonly, &
283 dataonly=dataonly, ana=ana)
284ELSE
285 CALL init(this%vol7d)
286 v7ddbatmp = this ! shallow copy
287 DO i = 1, SIZE(network)
288 CALL import(v7ddbatmp, var, network(i), coordmin, coordmax, timei, timef, &
289 level,timerange, set_network, attr,anavar,anaattr, varkind, attrkind, &
290 anavarkind, anaattrkind, anaonly, dataonly, ana)
291 CALL vol7d_merge(this%vol7d, v7ddbatmp%vol7d, sort=.true.)
292 ENDDO
293ENDIF
295END SUBROUTINE vol7d_dballe_importvvnv
296
298SUBROUTINE vol7d_dballe_import_old(this, var, network, coordmin, coordmax, timei, timef,level,timerange, set_network,&
299 attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,dataonly,ana)
300
301TYPE(vol7d_dballe),INTENT(inout) :: this
302CHARACTER(len=*),INTENT(in),OPTIONAL :: var(:)
303TYPE(geo_coord),INTENT(inout),optional :: coordmin,coordmax
304TYPE(vol7d_ana),INTENT(inout),optional :: ana
305TYPE(datetime),INTENT(in),OPTIONAL :: timei, timef
306TYPE(vol7d_network),INTENT(in),OPTIONAL :: network,set_network
307TYPE(vol7d_level),INTENT(in),optional :: level
308TYPE(vol7d_timerange),INTENT(in),optional :: timerange
309CHARACTER(len=*),INTENT(in),OPTIONAL :: attr(:),anavar(:),anaattr(:)
310CHARACTER(len=*),INTENT(in),OPTIONAL :: varkind(:),attrkind(:),anavarkind(:),anaattrkind(:)
311logical,intent(in),optional :: anaonly
312logical,intent(in),optional :: dataonly
313
314
315INTEGER,PARAMETER :: maxvarlist=100
316 !TYPE(vol7d) :: v7d
317 ! da non fare (con gfortran?)!!!!!
318 !CHARACTER(len=SIZE(var)*7) :: varlist
319 !CHARACTER(len=SIZE(attr)*8) :: starvarlist
320
321LOGICAL :: ldegnet
322
323INTEGER :: i
324integer :: nvar
325integer :: nanavar
326
327 !CHARACTER(len=10),allocatable :: lvar(:), lanavar(:)
328type(dbadcv) :: vars,starvars,anavars,anastarvars
329type(dbafilter) :: filter
330type(dbacoord) :: mydbacoordmin, mydbacoordmax
331type(dbaana) :: mydbaana
332type(dbadatetime) :: mydatetimemin, mydatetimemax
333type(dbatimerange) :: mydbatimerange
334type(dbalevel) :: mydbalevel
335type(dbanetwork) :: mydbanetwork
336
337integer :: nanaattr,nattr
338
339character(len=40) :: query
340
341#ifdef DEBUG
342CALL l4f_category_log(this%category,l4f_debug,'inizio')
343#endif
344
345
346IF (PRESENT(set_network)) THEN
347 if (c_e(set_network)) then
348 ldegnet = .true.
349 else
350 ldegnet = .false.
351 end if
352ELSE
353 ldegnet = .false.
354ENDIF
355
356if(ldegnet) then
357 query = "best"
358else
359 query=cmiss
360end if
361
362
363 ! uncommenti this if you want compatibility API with old import
364
365!!$ if (allocated(starvars%dcv)) then
366!!$ ldataonly=.false.
367!!$ else
368!!$ ldataonly=.true.
369!!$ end if
370
371
372!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
373 ! ------------- prepare filter options
374
375!!
376!! translate import option for dballe2003 api
377!!
378
379if (present(var)) then
380 nvar=count(c_e(var))
381 if (nvar > 0) then
382 allocate (vars%dcv(nvar))
383 do i=1,size(var)
384 if (c_e(var(i)))then
385 if (present(varkind))then
386 select case (varkind(i))
387 case("r")
388 allocate (vars%dcv(i)%dat,source=dbadatar(var(i)))
389 case("i")
390 allocate (vars%dcv(i)%dat,source=dbadatai(var(i)))
391 case("b")
392 allocate (vars%dcv(i)%dat,source=dbadatab(var(i)))
393 case("d")
394 allocate (vars%dcv(i)%dat,source=dbadatad(var(i)))
395 case("c")
396 allocate (vars%dcv(i)%dat,source=dbadatac(var(i)))
397 case default
398 call l4f_category_log(this%category,l4f_error,"var and varkind mismach")
399 CALL raise_fatal_error()
400 end select
401 else
402 allocate (vars%dcv(i)%dat,source=dbadatac(var(i))) !char is default
403 end if
404 end if
405 end do
406 end if
407end if
408
409if (present(anavar)) then
410 nanavar=count(c_e(anavar))
411 if (nanavar > 0) then
412 allocate (anavars%dcv(nanavar))
413 do i=1,size(anavar)
414 if (c_e(anavar(i)))then
415 if (present(anavarkind))then
416 select case (anavarkind(i))
417 case("r")
418 allocate (anavars%dcv(i)%dat,source=dbadatar(anavar(i)))
419 case("i")
420 allocate (anavars%dcv(i)%dat,source=dbadatai(anavar(i)))
421 case("b")
422 allocate (anavars%dcv(i)%dat,source=dbadatab(anavar(i)))
423 case("d")
424 allocate (anavars%dcv(i)%dat,source=dbadatad(anavar(i)))
425 case("c")
426 allocate (anavars%dcv(i)%dat,source=dbadatac(anavar(i)))
427 case default
428 call l4f_category_log(this%category,l4f_error,"anavar and anavarkind mismach")
429 CALL raise_fatal_error()
430 end select
431 else
432 allocate (anavars%dcv(i)%dat,source=dbadatac(anavar(i))) !char is default
433 end if
434 end if
435 end do
436 end if
437end if
438
439if (present(attr)) then
440 nattr=size(attr)
441 if (nattr == 0) then
442 allocate (starvars%dcv(nattr))
443 else
444 nattr=count(c_e(attr))
445 if (nattr > 0) then
446 allocate (starvars%dcv(nattr))
447 do i=1,size(attr)
448 if (c_e(attr(i)))then
449 if (present(attrkind))then
450 select case (attrkind(i))
451 case("r")
452 allocate (starvars%dcv(i)%dat,source=dbadatar(attr(i)))
453 case("i")
454 allocate (starvars%dcv(i)%dat,source=dbadatai(attr(i)))
455 case("b")
456 allocate (starvars%dcv(i)%dat,source=dbadatab(attr(i)))
457 case("d")
458 allocate (starvars%dcv(i)%dat,source=dbadatad(attr(i)))
459 case("c")
460 allocate (starvars%dcv(i)%dat,source=dbadatac(attr(i)))
461 case default
462 call l4f_category_log(this%category,l4f_error,"attr and attrkind mismach")
463 CALL raise_fatal_error()
464 end select
465 else
466 allocate (starvars%dcv(i)%dat,source=dbadatac(attr(i))) !char is default
467 end if
468 end if
469 end do
470 end if
471 endif
472end if
473
474if (present(anaattr)) then
475 nanaattr=size(anaattr)
476 if (nanaattr == 0) then
477 allocate (anastarvars%dcv(nanaattr))
478 else
479 nanaattr=count(c_e(anaattr))
480 if (nanaattr > 0) then
481 allocate (anastarvars%dcv(nanaattr))
482 do i=1,size(anaattr)
483 if (c_e(anaattr(i)))then
484 if (present(anaattrkind))then
485 select case (anaattrkind(i))
486 case("r")
487 allocate (anastarvars%dcv(i)%dat,source=dbadatar(anaattr(i)))
488 case("i")
489 allocate (anastarvars%dcv(i)%dat,source=dbadatai(anaattr(i)))
490 case("b")
491 allocate (anastarvars%dcv(i)%dat,source=dbadatab(anaattr(i)))
492 case("d")
493 allocate (anastarvars%dcv(i)%dat,source=dbadatad(anaattr(i)))
494 case("c")
495 allocate (anastarvars%dcv(i)%dat,source=dbadatac(anaattr(i)))
496 case default
497 call l4f_category_log(this%category,l4f_error,"attr and attrkind mismach")
498 CALL raise_fatal_error()
499 end select
500 else
501 allocate (anastarvars%dcv(i)%dat,source=dbadatac(anaattr(i))) !char is default
502 end if
503 end if
504 end do
505 end if
506 end if
507end if
508
509
510 ! like a cast
511mydbacoordmin=dbacoord()
512if (present(coordmin)) mydbacoordmin%geo_coord=coordmin
513mydbacoordmax=dbacoord()
514if (present(coordmax)) mydbacoordmax%geo_coord=coordmax
515mydbaana=dbaana()
516if (present(ana)) mydbaana%vol7d_ana=ana
517mydatetimemin=dbadatetime()
518if (present(timei)) mydatetimemin%datetime=timei
519mydatetimemax=dbadatetime()
520if (present(timef)) mydatetimemax%datetime=timef
521mydbatimerange=dbatimerange()
522if (present(timerange)) mydbatimerange%vol7d_timerange=timerange
523mydbalevel=dbalevel()
524if (present(level)) mydbalevel%vol7d_level=level
525mydbanetwork=dbanetwork()
526if (present(network)) mydbanetwork%vol7d_network=network
527
528!!
529!! here we have options ready for filter
530!!
531filter=dbafilter(coordmin=mydbacoordmin,coordmax=mydbacoordmax,ana=mydbaana, &
532 datetimemin=mydatetimemin,datetimemax=mydatetimemax, &
533 timerange=mydbatimerange,level=mydbalevel,network=mydbanetwork,query=query,&
534 vars=vars,starvars=starvars,anavars=anavars,anastarvars=anastarvars,&
535 dataonly=dataonly,anaonly=anaonly)
536!!$ print *, "filter:"
537!!$ call filter%display()
538
539call import(this,filter,set_network)
540
541
542END SUBROUTINE vol7d_dballe_import_old
543
544
545
547subroutine vol7d_dballe_import(this,filter,set_network)
548
549TYPE(vol7d_dballe),INTENT(inout) :: this
550type(dbafilter),INTENT(in) :: filter
551TYPE(vol7d_network),INTENT(in),OPTIONAL :: set_network
552
553TYPE(vol7d) :: vol7dtmp
554type(dbametaanddata),allocatable :: metaanddatav(:)
555type(dbafilter) :: myfilter
556
557CALL l4f_category_log(this%category,l4f_debug,'start import vol7d_dballe')
558
559if ( .not. filter%dataonly) then
560 ! ----------------> constant station data
561 myfilter=dbafilter(filter=filter,contextana=.true.,query=cmiss)
562! ! set filter
563! call this%handle%set(filter=myfilter)
564 ! estrude the data
565 CALL l4f_category_log(this%category,l4f_debug,'start import vol7d_dballe ingest for constant station data')
566! call this%handle%ingest(filter=myfilter)
567 call this%handle%ingest(metaanddatav,filter=myfilter)
568 CALL l4f_category_log(this%category,l4f_debug,'end import vol7d_dballe ingest')
569 CALL l4f_category_log(this%category,l4f_debug,'start import vol7d_dballe dba2v7d')
570 call dba2v7d(this%vol7d, metaanddatav,this%time_definition,set_network)
571 CALL l4f_category_log(this%category,l4f_debug,'end import vol7d_dballe dba2v7d')
572
573 deallocate (metaanddatav)
574
575else
576 ! empty volume
577 call init(this%vol7d)
578 call vol7d_alloc(this%vol7d)
579 call vol7d_alloc_vol(this%vol7d)
580end if
581 ! ----------------> constant station data end
582
583if ( .not. filter%anaonly) then
584 ! ----------------> working on data
585 myfilter=dbafilter(filter=filter,contextana=.false.)
586! ! set filter
587! call this%handle%set(filter=myfilter)
588 ! estrude the data
589
590 CALL l4f_category_log(this%category,l4f_debug,'start import vol7d_dballe ingest for station data')
591! call this%handle%ingest(filter=myfilter)
592 call this%handle%ingest(metaanddatav,filter=myfilter)
593 CALL l4f_category_log(this%category,l4f_debug,'end import vol7d_dballe ingest')
594 CALL l4f_category_log(this%category,l4f_debug,'start import vol7d_dballe dba2v7d')
595 call dba2v7d(vol7dtmp,metaanddatav,this%time_definition,set_network)
596 CALL l4f_category_log(this%category,l4f_debug,'end import vol7d_dballe dba2v7d')
597
598 deallocate (metaanddatav)
599
600 CALL vol7d_merge(this%vol7d, vol7dtmp, sort=.true.) ! Smart merge
601!!$else
602!!$ ! should we sort separately in case no merge is done?
603!!$ CALL vol7d_smart_sort(this%vol7d, lsort_time=.TRUE., lsort_timerange=.TRUE., lsort_level=.TRUE.)
604end if
605
606call vol7d_dballe_set_var_du(this%vol7d)
607
608
609#ifdef NONE
610
611!!$if (lattr) then
612!!$
613!!$ allocate (this%data_id( nana, ntime, nlevel, ntimerange, nnetwork),stat=istat)
614!!$ if (istat/= 0) THEN
615!!$ CALL l4f_category_log(this%category,L4F_ERROR,'cannot allocate ' &
616!!$ //TRIM(to_char(nana*ntime*nlevel*ntimerange*nnetwork))//' data_id elements')
617!!$ CALL raise_fatal_error()
618!!$
619!!$ ENDIF
620!!$
621!!$ this%data_id=DBA_MVI
622!!$
623!!$else
624
625nullify(this%data_id)
626
627!!$end if
628
629
630 !memorizzo data_id
631#ifdef DEBUG
632 !CALL l4f_category_log(this%category,L4F_DEBUG,"data_id: "//trim(to_char(buffer(i)%data_id)))
633#endif
634
635this%data_id(indana,indtime,indlevel,indtimerange,indnetwork)=buffer(i)%data_id
636
637
638ier=idba_set(this%handle,"*context_id",buffer(i)%data_id)
639ier=idba_set(this%handle,"*var_related",buffer(i)%btable)
640 !per ogni dato ora lavoro sugli attributi
641ier=idba_set(this%handle, "*varlist",starvarlist )
642ier=idba_voglioancora(this%handle,nn)
643 !print*,buffer(i)%btable," numero attributi",nn
644
645#endif
646
647CALL l4f_category_log(this%category,l4f_debug,'end import vol7d_dballe')
648
649end subroutine vol7d_dballe_import
650
651
652
654
655SUBROUTINE vol7d_dballe_delete(this, preserveidbhandle)
656TYPE(vol7d_dballe) :: this
657logical,intent(in), optional :: preserveidbhandle
658
659# ifndef F2003_FULL_FEATURES
660call this%handle%delete()
661
662if (.not. optio_log(preserveidbhandle)) call this%idbhandle%delete()
663# endif
664
665!!$if (associated(this%data_id)) then
666!!$ deallocate (this%data_id)
667!!$ nullify(this%data_id)
668!!$end if
669
670CALL delete(this%vol7d)
671
672 !chiudo il logger
673call l4f_category_delete(this%category)
674 !ier=l4f_fini()
675
676END SUBROUTINE vol7d_dballe_delete
677
678
679
681!subroutine dba2v7d(this,metaanddatav,vars,starvars,anavars,anastarvars,time_definition, set_network)
682subroutine dba2v7d(this,metaanddatav,time_definition, set_network)
683
684type(dbametaanddata),intent(inout) :: metaanddatav(:) ! change value in datetime reguard timedefinition
685TYPE(vol7d),INTENT(inout) :: this
686integer,INTENT(in),OPTIONAL :: time_definition
687TYPE(vol7d_network),INTENT(in),OPTIONAL :: set_network
688type(dbadcv) :: vars
689type(dbadcv) :: starvars
690type(dbadcv) :: anavars
691type(dbadcv) :: anastarvars
692
693
694LOGICAL :: ldegnet
695integer :: indana,indtime,indlevel,indtimerange,inddativar,indnetwork,indattrvar
696
697integer :: nana,ntime,ntimerange,nlevel,nnetwork
698
699INTEGER :: i, j, k, n
700integer :: inddativarattr
701integer :: nanavar, indanavar,indanavarattr,nanavarattr
702
703integer :: ndativarr, ndativari, ndativarb, ndativard, ndativarc
704integer :: ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc
705integer :: ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc
706
707integer :: nanavarr, nanavari, nanavarb, nanavard, nanavarc
708integer :: nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc
709integer :: nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
710
711integer :: ndativar,ndativarattr
712
713type(characterlist) :: dativarl,dativarattrl,anavarl,anavarattrl
714
715character(len=listcharmaxlen),allocatable :: dativara(:),dativarattra(:),anavara(:),anavarattra(:)
716logical :: status
717integer :: ltime_definition
718
719type(datetime),allocatable :: tmptime(:)
720type(vol7d_network),allocatable :: tmpnetwork(:)
721type(vol7d_level),allocatable :: tmplevel(:)
722type(vol7d_timerange),allocatable :: tmptimerange(:)
723type(vol7d_ana),allocatable :: tmpana(:)
724
725
726ltime_definition=optio_i(time_definition)
727if (.not. c_e(ltime_definition)) ltime_definition = 1
728
729 ! take in account time_definition
730if (ltime_definition == 0) then
731 do i =1,size(metaanddatav)
732 metaanddatav(i)%metadata%datetime%datetime = &
733 metaanddatav(i)%metadata%datetime%datetime - &
734 timedelta_new(sec=metaanddatav(i)%metadata%timerange%vol7d_timerange%p1)
735 end do
736end if
737
738
739IF (PRESENT(set_network)) THEN
740 if (c_e(set_network)) then
741 ldegnet = .true.
742 else
743 ldegnet = .false.
744 end if
745ELSE
746 ldegnet = .false.
747ENDIF
748
749
750
751!!--------------------------------------------------------------------------
752!! find vars, starvars, anavars, anastarvars
753!!
754
755! create lists of all
756 ! data
757do i =1, size(metaanddatav)
758 do j=1, size(metaanddatav(i)%dataattrv%dataattr)
759 if (c_e(metaanddatav(i)%metadata%datetime%datetime)) then
760 !print *,"dativarl: ", metaanddatav(i)%dataattrv%dataattr(j)%dat%btable
761 call dativarl%append(metaanddatav(i)%dataattrv%dataattr(j)%dat%btable)
762 else
763 !print *,"anavarl: ", metaanddatav(i)%dataattrv%dataattr(j)%dat%btable
764 call anavarl%append(metaanddatav(i)%dataattrv%dataattr(j)%dat%btable)
765 end if
766 end do
767end do
768
769!count and put in vector of unuique key
770ndativar = count_distinct(toarray_charl(dativarl) , back=.true.)
771allocate(dativara(ndativar))
772call pack_distinct_c (toarray_charl(dativarl) , dativara , back=.true.)
773status = dativarl%delete()
774allocate (vars%dcv(ndativar))
775
776nanavar = count_distinct(toarray_charl(anavarl) , back=.true.)
777allocate(anavara(nanavar))
778call pack_distinct_c (toarray_charl(anavarl) , anavara , back=.true.)
779status = anavarl%delete()
780allocate (anavars%dcv(nanavar))
781
782
783an: do n=1,ndativar
784 do i =1, size(metaanddatav)
785 do j=1, size(metaanddatav(i)%dataattrv%dataattr)
786 if (c_e(metaanddatav(i)%metadata%datetime%datetime)) then
787 if (metaanddatav(i)%dataattrv%dataattr(j)%dat%btable == dativara(n)) then
788 allocate(vars%dcv(n)%dat,source=metaanddatav(i)%dataattrv%dataattr(j)%dat)
789 cycle an
790 end if
791 end if
792 end do
793 end do
794end do an
795
796bn: do n=1,nanavar
797 do i =1, size(metaanddatav)
798 do j=1, size(metaanddatav(i)%dataattrv%dataattr)
799 if (.not. c_e(metaanddatav(i)%metadata%datetime%datetime)) then
800 if (metaanddatav(i)%dataattrv%dataattr(j)%dat%btable == anavara(n)) then
801 allocate(anavars%dcv(n)%dat,source=metaanddatav(i)%dataattrv%dataattr(j)%dat)
802 cycle bn
803 end if
804 end if
805 end do
806 end do
807end do bn
808
809 ! attributes
810do i =1, size(metaanddatav)
811 do j=1, size(metaanddatav(i)%dataattrv%dataattr)
812 do k=1, size(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv)
813 if (c_e(metaanddatav(i)%metadata%datetime%datetime)) then
814 !print *,"dativarattrl: ", metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat%btable
815 call dativarattrl%append(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat%btable)
816 else
817 !print *,"anavarattrl: ", metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat%btable
818 call anavarattrl%append(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat%btable)
819 end if
820 end do
821 end do
822end do
823
824
825ndativarattr = count_distinct(toarray_charl(dativarattrl), back=.true.)
826allocate(dativarattra(ndativarattr))
827call pack_distinct_c (toarray_charl(dativarattrl), dativarattra, back=.true.)
828status = dativarattrl%delete()
829allocate(starvars%dcv(ndativarattr))
830
831nanavarattr = count_distinct(toarray_charl(anavarattrl) , back=.true.)
832allocate(anavarattra(nanavarattr))
833call pack_distinct_c (toarray_charl(anavarattrl) , anavarattra , back=.true.)
834status = anavarattrl%delete()
835allocate(anastarvars%dcv(nanavarattr))
836
837
838cn: do n=1,ndativarattr
839 do i =1, size(metaanddatav)
840 do j=1, size(metaanddatav(i)%dataattrv%dataattr)
841 do k=1, size(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv)
842 if (c_e(metaanddatav(i)%metadata%datetime%datetime)) then
843 if (metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat%btable == dativarattra(n))then
844 allocate(starvars%dcv(n)%dat,source=metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat)
845 cycle cn
846 end if
847 end if
848 end do
849 end do
850 end do
851end do cn
852
853
854dn: do n=1,nanavarattr
855 do i =1, size(metaanddatav)
856 do j=1, size(metaanddatav(i)%dataattrv%dataattr)
857 do k=1, size(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv)
858 if (.not. c_e(metaanddatav(i)%metadata%datetime%datetime)) then
859 if (metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat%btable == anavarattra(n))then
860 allocate(anastarvars%dcv(n)%dat,source=metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat)
861 cycle dn
862 end if
863 end if
864 end do
865 end do
866 end do
867end do dn
868
869
870!!--------------------------------------------------------------------------
871
872
873!!
874!! count all unique metadata
875!!
876
877if(ldegnet) then
878 nnetwork=1
879else
880 !nnetwork = count_distinct(metaanddatav(:)%metadata%network%vol7d_network, back=.TRUE.)
881 allocate (tmpnetwork(size(metaanddatav(:))),&
882 source=metaanddatav(:)%metadata%network%vol7d_network)
883 call sort(tmpnetwork)
884 nnetwork = count_distinct_sorted(tmpnetwork)
885end if
886
887!ntime = count_distinct(metaanddatav(:)%metadata%datetime%datetime, &
888! mask=c_e(metaanddatav(:)%metadata%datetime%datetime),back=.TRUE.)
889allocate (tmptime(size(metaanddatav(:))),&
890 source=metaanddatav(:)%metadata%datetime%datetime)
891call sort(tmptime)
892ntime = count_distinct_sorted(tmptime,mask=c_e(tmptime))
893
894!ntimerange = count_distinct(metaanddatav(:)%metadata%timerange%vol7d_timerange, &
895! mask=c_e(metaanddatav(:)%metadata%timerange%vol7d_timerange), back=.TRUE.)
896allocate (tmptimerange(size(metaanddatav(:))),&
897 source=metaanddatav(:)%metadata%timerange%vol7d_timerange)
898call sort(tmptimerange)
899ntimerange = count_distinct_sorted(tmptimerange,mask=c_e(tmptimerange))
900
901!nlevel = count_distinct(metaanddatav(:)%metadata%level%vol7d_level, &
902! mask=c_e(metaanddatav(:)%metadata%level%vol7d_level),back=.TRUE.)
903allocate (tmplevel(size(metaanddatav(:))),&
904 source=metaanddatav(:)%metadata%level%vol7d_level)
905call sort(tmplevel)
906nlevel = count_distinct_sorted(tmplevel,mask=c_e(tmplevel))
907
908!nana = count_distinct(metaanddatav(:)%metadata%ana%vol7d_ana, back=.TRUE.)
909allocate (tmpana(size(metaanddatav(:))),&
910 source=metaanddatav(:)%metadata%ana%vol7d_ana)
911call sort(tmpana)
912nana = count_distinct_sorted(tmpana)
913
914!!$if(ldegnet) then
915!!$ nnetwork=1
916!!$else
917!!$ nnetwork = size(metaanddatav(:)%metadata%network%vol7d_network)
918!!$end if
919!!$ntime = size(metaanddatav(:)%metadata%datetime%datetime)
920!!$ntimerange = size(metaanddatav(:)%metadata%timerange%vol7d_timerange)
921!!$nlevel = size(metaanddatav(:)%metadata%level%vol7d_level)
922!!$nana = size(metaanddatav(:)%metadata%ana%vol7d_ana)
923
924 ! var
925
926ndativarr = 0
927ndativari = 0
928ndativarb = 0
929ndativard = 0
930ndativarc = 0
931
932do i =1 ,size(vars%dcv)
933 associate(dato => vars%dcv(i)%dat)
934 select type (dato)
935 type is (dbadatar)
936 ndativarr = ndativarr + 1
937 type is (dbadatai)
938 ndativari = ndativari + 1
939 type is (dbadatab)
940 ndativarb = ndativarb + 1
941 type is (dbadatad)
942 ndativard = ndativard + 1
943 type is (dbadatac)
944 ndativarc = ndativarc + 1
945 end select
946 end associate
947end do
948
949
950 !attr
951
952ndatiattrr = 0
953ndatiattri = 0
954ndatiattrb = 0
955ndatiattrd = 0
956ndatiattrc = 0
957
958do i =1 ,size(starvars%dcv)
959 associate(dato => starvars%dcv(i)%dat)
960 select type (dato)
961 type is (dbadatar)
962 ndatiattrr = ndatiattrr + 1
963 type is (dbadatai)
964 ndatiattri = ndatiattri + 1
965 type is (dbadatab)
966 ndatiattrb = ndatiattrb + 1
967 type is (dbadatad)
968 ndatiattrd = ndatiattrd + 1
969 type is (dbadatac)
970 ndatiattrc = ndatiattrc + 1
971 end select
972 end associate
973end do
974
975
976 ! ana var
977
978nanavarr = 0
979nanavari = 0
980nanavarb = 0
981nanavard = 0
982nanavarc = 0
983
984do i =1 ,size(anavars%dcv)
985 associate(dato => anavars%dcv(i)%dat)
986 select type (dato)
987 type is (dbadatar)
988 nanavarr = nanavarr + 1
989 type is (dbadatai)
990 nanavari = nanavari + 1
991 type is (dbadatab)
992 nanavarb = nanavarb + 1
993 type is (dbadatad)
994 nanavard = nanavard + 1
995 type is (dbadatac)
996 nanavarc = nanavarc + 1
997 end select
998 end associate
999end do
1000
1001
1002 ! ana attr
1003
1004nanaattrr = 0
1005nanaattri = 0
1006nanaattrb = 0
1007nanaattrd = 0
1008nanaattrc = 0
1009
1010do i =1 ,size(anastarvars%dcv)
1011 associate(dato => anastarvars%dcv(i)%dat)
1012 select type (dato)
1013 type is (dbadatar)
1014 nanaattrr = nanaattrr + 1
1015 type is (dbadatai)
1016 nanaattri = nanaattri + 1
1017 type is (dbadatab)
1018 nanaattrb = nanaattrb + 1
1019 type is (dbadatad)
1020 nanaattrd = nanaattrd + 1
1021 type is (dbadatac)
1022 nanaattrc = nanaattrc + 1
1023 end select
1024 end associate
1025end do
1026
1027
1028 !refine
1029
1030ndativarattrr=0
1031ndativarattri=0
1032ndativarattrb=0
1033ndativarattrd=0
1034ndativarattrc=0
1035
1036if (ndatiattrr > 0 ) ndativarattrr=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1037if (ndatiattri > 0 ) ndativarattri=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1038if (ndatiattrb > 0 ) ndativarattrb=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1039if (ndatiattrd > 0 ) ndativarattrd=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1040if (ndatiattrc > 0 ) ndativarattrc=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1041
1042
1043nanavarattrr=0
1044nanavarattri=0
1045nanavarattrb=0
1046nanavarattrd=0
1047nanavarattrc=0
1048
1049if (nanaattrr > 0 ) nanavarattrr=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1050if (nanaattri > 0 ) nanavarattri=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1051if (nanaattrb > 0 ) nanavarattrb=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1052if (nanaattrd > 0 ) nanavarattrd=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1053if (nanaattrc > 0 ) nanavarattrc=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1054
1055
1056CALL init(this,time_definition=ltime_definition)
1057
1058!!$print *, "nana=",nana, "ntime=",ntime, "ntimerange=",ntimerange, &
1059!!$ "nlevel=",nlevel, "nnetwork=",nnetwork, &
1060!!$ "ndativarr=",ndativarr, "ndativari=",ndativari, &
1061!!$ "ndativarb=",ndativarb, "ndativard=",ndativard, "ndativarc=",ndativarc,&
1062!!$ "ndatiattrr=",ndatiattrr, "ndatiattri=",ndatiattri, "ndatiattrb=",ndatiattrb,&
1063!!$ "ndatiattrd=",ndatiattrd, "ndatiattrc=",ndatiattrc,&
1064!!$ "ndativarattrr=",ndativarattrr, "ndativarattri=",ndativarattri, "ndativarattrb=",ndativarattrb,&
1065!!$ "ndativarattrd=",ndativarattrd, "ndativarattrc=",ndativarattrc
1066!!$
1067!!$print *,"nanaattrr,nanaattri,nanaattrb,nanaattrd,nanaattrc"
1068!!$print *,nanaattrr,nanaattri,nanaattrb,nanaattrd,nanaattrc
1069
1070
1071call vol7d_alloc (this, &
1072nana=nana, ntime=ntime, ntimerange=ntimerange, &
1073nlevel=nlevel, nnetwork=nnetwork, &
1074ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb, ndativard=ndativard, ndativarc=ndativarc,&
1075ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb, ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
1076ndativarattrr=ndativarattrr, &
1077ndativarattri=ndativarattri, &
1078ndativarattrb=ndativarattrb, &
1079ndativarattrd=ndativarattrd, &
1080ndativarattrc=ndativarattrc,&
1081nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, nanavard=nanavard, nanavarc=nanavarc,&
1082nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb, nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
1083nanavarattrr=nanavarattrr, &
1084nanavarattri=nanavarattri, &
1085nanavarattrb=nanavarattrb, &
1086nanavarattrd=nanavarattrd, &
1087nanavarattrc=nanavarattrc)
1088
1089
1090! fill metadata removing contextana metadata
1091
1092!nana=count_and_pack_distinct(metaanddatav(:)%metadata%ana%vol7d_ana,this%ana, back=.TRUE.)
1093!this%ana=pack_distinct(metaanddatav(:)%metadata%ana%vol7d_ana, nana, back=.TRUE.)
1094this%ana=pack_distinct_sorted(tmpana, nana)
1095deallocate(tmpana)
1096!call sort(this%ana)
1097
1098!ntime=count_and_pack_distinct(metaanddatav(:)%metadata%datetime%datetime,this%time, &
1099! mask=c_e(metaanddatav(:)%metadata%datetime%datetime), back=.TRUE.)
1100!this%time=pack_distinct(metaanddatav(:)%metadata%datetime%datetime, ntime, &
1101! mask=c_e(metaanddatav(:)%metadata%datetime%datetime),back=.TRUE.)
1102this%time=pack_distinct_sorted(tmptime, ntime,mask=c_e(tmptime))
1103deallocate(tmptime)
1104!call sort(this%time)
1105
1106!ntimerange=count_and_pack_distinct(metaanddatav(:)%metadata%timerange%vol7d_timerange,this%timerange, &
1107! mask=c_e(metaanddatav(:)%metadata%timerange%vol7d_timerange), back=.TRUE.)
1108!this%timerange=pack_distinct(metaanddatav(:)%metadata%timerange%vol7d_timerange, ntimerange, &
1109! mask=c_e(metaanddatav(:)%metadata%timerange%vol7d_timerange), back=.TRUE.)
1110this%timerange=pack_distinct_sorted(tmptimerange, ntimerange,mask=c_e(tmptimerange))
1111deallocate(tmptimerange)
1112!call sort(this%timerange)
1113
1114!nlevel=count_and_pack_distinct(metaanddatav(:)%metadata%level%vol7d_level,this%level, &
1115! mask=c_e(metaanddatav(:)%metadata%level%vol7d_level), back=.TRUE.)
1116!this%level=pack_distinct(metaanddatav(:)%metadata%level%vol7d_level, nlevel, &
1117! mask=c_e(metaanddatav(:)%metadata%level%vol7d_level), back=.TRUE.)
1118this%level=pack_distinct_sorted(tmplevel, nlevel,mask=c_e(tmplevel))
1119deallocate(tmplevel)
1120!call sort(this%level)
1121
1122if(ldegnet)then
1123 nnetwork=1
1124 ALLOCATE(this%network(1))
1125 this%network(1)=set_network
1126else
1127 !nnetwork=count_and_pack_distinct(metaanddatav(:)%metadata%network%vol7d_network,this%network, back=.TRUE.)
1128 !this%network=pack_distinct(metaanddatav(:)%metadata%network%vol7d_network, nnetwork, back=.TRUE.)
1129 this%network=pack_distinct_sorted(tmpnetwork, nnetwork)
1130 deallocate(tmpnetwork)
1131end if
1132!call sort(this%network)
1133
1134 ! var
1135
1136ndativarr = 0
1137ndativari = 0
1138ndativarb = 0
1139ndativard = 0
1140ndativarc = 0
1141
1142do i =1 ,size(vars%dcv)
1143 associate(dato => vars%dcv(i)%dat)
1144 select type (dato)
1145 type is (dbadatar)
1146 ndativarr = ndativarr + 1
1147 call init (this%dativar%r(ndativarr), btable=dato%btable)
1148 type is (dbadatai)
1149 ndativari = ndativari + 1
1150 call init (this%dativar%i(ndativari), btable=dato%btable)
1151 type is (dbadatab)
1152 ndativarb = ndativarb + 1
1153 call init (this%dativar%b(ndativarb), btable=dato%btable)
1154 type is (dbadatad)
1155 ndativard = ndativard + 1
1156 call init (this%dativar%d(ndativard), btable=dato%btable)
1157 type is (dbadatac)
1158 ndativarc = ndativarc + 1
1159 call init (this%dativar%c(ndativarc), btable=dato%btable)
1160 end select
1161 end associate
1162end do
1163
1164
1165 !attr
1166
1167ndatiattrr = 0
1168ndatiattri = 0
1169ndatiattrb = 0
1170ndatiattrd = 0
1171ndatiattrc = 0
1172
1173do i =1 ,size(starvars%dcv)
1174 associate(dato => starvars%dcv(i)%dat)
1175 select type (dato)
1176 type is (dbadatar)
1177 ndatiattrr = ndatiattrr + 1
1178 call init (this%datiattr%r(ndatiattrr), btable=dato%btable)
1179 type is (dbadatai)
1180 ndatiattri = ndatiattri + 1
1181 call init (this%datiattr%i(ndatiattri), btable=dato%btable)
1182 type is (dbadatab)
1183 ndatiattrb = ndatiattrb + 1
1184 call init (this%datiattr%b(ndatiattrb), btable=dato%btable)
1185 type is (dbadatad)
1186 ndatiattrd = ndatiattrd + 1
1187 call init (this%datiattr%d(ndatiattrd), btable=dato%btable)
1188 type is (dbadatac)
1189 ndatiattrc = ndatiattrc + 1
1190 call init (this%datiattr%c(ndatiattrc), btable=dato%btable)
1191 end select
1192 end associate
1193end do
1194
1195
1196 ! ana var
1197
1198nanavarr = 0
1199nanavari = 0
1200nanavarb = 0
1201nanavard = 0
1202nanavarc = 0
1203
1204do i =1 ,size(anavars%dcv)
1205 associate(dato => anavars%dcv(i)%dat)
1206 select type (dato)
1207 type is (dbadatar)
1208 nanavarr = nanavarr + 1
1209 call init (this%anavar%r(nanavarr), btable=dato%btable)
1210 type is (dbadatai)
1211 nanavari = nanavari + 1
1212 call init (this%anavar%i(nanavari), btable=dato%btable)
1213 type is (dbadatab)
1214 nanavarb = nanavarb + 1
1215 call init (this%anavar%b(nanavarb), btable=dato%btable)
1216 type is (dbadatad)
1217 nanavard = nanavard + 1
1218 call init (this%anavar%d(nanavard), btable=dato%btable)
1219 type is (dbadatac)
1220 nanavarc = nanavarc + 1
1221 call init (this%anavar%c(nanavarc), btable=dato%btable)
1222 end select
1223 end associate
1224end do
1225
1226
1227 ! ana attr
1228
1229nanaattrr = 0
1230nanaattri = 0
1231nanaattrb = 0
1232nanaattrd = 0
1233nanaattrc = 0
1234
1235do i =1 ,size(anastarvars%dcv)
1236 associate(dato => anastarvars%dcv(i)%dat)
1237 select type (dato)
1238 type is (dbadatar)
1239 nanaattrr = nanaattrr + 1
1240 call init (this%anaattr%r(nanaattrr), btable=dato%btable)
1241 type is (dbadatai)
1242 nanaattri = nanaattri + 1
1243 call init (this%anaattr%i(nanaattri), btable=dato%btable)
1244 type is (dbadatab)
1245 nanaattrb = nanaattrb + 1
1246 call init (this%anaattr%b(nanaattrb), btable=dato%btable)
1247 type is (dbadatad)
1248 nanaattrd = nanaattrd + 1
1249 call init (this%anaattr%d(nanaattrd), btable=dato%btable)
1250 type is (dbadatac)
1251 nanaattrc = nanaattrc + 1
1252 call init (this%anaattr%c(nanaattrc), btable=dato%btable)
1253 end select
1254 end associate
1255end do
1256
1257
1258 ! here we colcolate the link from attributes and vars
1259do i =1, size(vars%dcv)
1260 associate(dato => vars%dcv(i)%dat)
1261 if ( ndativarattri > 0 ) call init(this%dativarattr%i(i),btable=dato%btable)
1262 if ( ndativarattrr > 0 ) call init(this%dativarattr%r(i),btable=dato%btable)
1263 if ( ndativarattrd > 0 ) call init(this%dativarattr%d(i),btable=dato%btable)
1264 if ( ndativarattrb > 0 ) call init(this%dativarattr%b(i),btable=dato%btable)
1265 if ( ndativarattrc > 0 ) call init(this%dativarattr%c(i),btable=dato%btable)
1266 end associate
1267end do
1268
1269do i =1, size(anavars%dcv)
1270 associate(dato => anavars%dcv(i)%dat)
1271 if ( nanavarattri > 0 ) call init(this%anavarattr%i(i),btable=dato%btable)
1272 if ( nanavarattrr > 0 ) call init(this%anavarattr%r(i),btable=dato%btable)
1273 if ( nanavarattrd > 0 ) call init(this%anavarattr%d(i),btable=dato%btable)
1274 if ( nanavarattrb > 0 ) call init(this%anavarattr%b(i),btable=dato%btable)
1275 if ( nanavarattrc > 0 ) call init(this%anavarattr%c(i),btable=dato%btable)
1276 end associate
1277end do
1278
1279 ! set index in dativaratt*
1280call vol7d_set_attr_ind(this)
1281
1282call vol7d_alloc_vol (this)
1283
1284 ! Ora qui bisogna metterci dentro idati
1285indana = 0
1286indtime = 0
1287indnetwork = 0
1288indtime = 0
1289indtimerange = 0
1290indlevel = 0
1291do i =1, size(metaanddatav)
1292
1293 indana = index_sorted(this%ana, metaanddatav(i)%metadata%ana%vol7d_ana)
1294
1295 if (ldegnet)then
1296 indnetwork=1
1297 else
1298 indnetwork = index_sorted(this%network, metaanddatav(i)%metadata%network%vol7d_network)
1299 endif
1300
1301 if (c_e(metaanddatav(i)%metadata%datetime%datetime) .and. &
1302 c_e(metaanddatav(i)%metadata%timerange%vol7d_timerange) .and. &
1303 c_e(metaanddatav(i)%metadata%level%vol7d_level) ) then ! dati
1304
1305 indtime = index_sorted(this%time, metaanddatav(i)%metadata%datetime%datetime)
1306 indtimerange = index_sorted(this%timerange, metaanddatav(i)%metadata%timerange%vol7d_timerange)
1307 indlevel = index_sorted(this%level, metaanddatav(i)%metadata%level%vol7d_level)
1308
1309 do j=1, size(metaanddatav(i)%dataattrv%dataattr)
1310
1311 associate(dato => metaanddatav(i)%dataattrv%dataattr(j)%dat)
1312 select type (dato)
1313 type is (dbadatai)
1314 inddativar = firsttrue(dato%btable == this%dativar%i%btable)
1315 this%voldatii( &
1316 indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
1317 ) = dato%value
1318
1319 type is (dbadatar)
1320 inddativar = firsttrue(dato%btable == this%dativar%r%btable)
1321 this%voldatir( &
1322 indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
1323 ) = dato%value
1324
1325 type is (dbadatad)
1326 inddativar = firsttrue(dato%btable == this%dativar%d%btable)
1327 this%voldatid( &
1328 indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
1329 ) = dato%value
1330
1331 type is (dbadatab)
1332 inddativar = firsttrue(dato%btable == this%dativar%b%btable)
1333 this%voldatib( &
1334 indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
1335 ) = dato%value
1336
1337 type is (dbadatac)
1338 inddativar = firsttrue(dato%btable == this%dativar%c%btable)
1339 this%voldatic( &
1340 indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
1341 ) = dato%value
1342
1343 end select
1344
1345
1346 ! dati attributes
1347 do k=1, size(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv)
1348 associate(attr => metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat)
1349 select type (attr)
1350
1351 type is (dbadatai)
1352 inddativarattr = firsttrue(dato%btable == this%dativarattr%i%btable)
1353 indattrvar = firsttrue(attr%btable == this%datiattr%i%btable)
1354 this%voldatiattri( &
1355 indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar &
1356 ) = attr%value
1357 type is (dbadatar)
1358 inddativarattr = firsttrue(dato%btable == this%dativarattr%r%btable)
1359 indattrvar = firsttrue(attr%btable == this%datiattr%r%btable)
1360 this%voldatiattrr( &
1361 indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar &
1362 ) = attr%value
1363 type is (dbadatad)
1364 inddativarattr = firsttrue(dato%btable == this%dativarattr%d%btable)
1365 indattrvar = firsttrue(attr%btable == this%datiattr%d%btable)
1366 this%voldatiattrd( &
1367 indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar &
1368 ) = attr%value
1369 type is (dbadatab)
1370 inddativarattr = firsttrue(dato%btable == this%dativarattr%b%btable)
1371 indattrvar = firsttrue(attr%btable == this%datiattr%b%btable)
1372 this%voldatiattrb( &
1373 indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar &
1374 ) = attr%value
1375 type is (dbadatac)
1376 inddativarattr = firsttrue(dato%btable == this%dativarattr%c%btable)
1377 indattrvar = firsttrue(attr%btable == this%datiattr%c%btable)
1378 this%voldatiattrc( &
1379 indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar &
1380 ) = attr%value
1381
1382 end select
1383 end associate
1384 end do
1385 end associate
1386 end do
1387
1388 else
1389 ! ana
1390 do j=1, size(metaanddatav(i)%dataattrv%dataattr)
1391
1392 associate(dato => metaanddatav(i)%dataattrv%dataattr(j)%dat)
1393 select type (dato)
1394 type is (dbadatai)
1395 indanavar = firsttrue(dato%btable == this%anavar%i%btable)
1396 this%volanai( &
1397 indana,indanavar,indnetwork &
1398 ) = dato%value
1399
1400 type is (dbadatar)
1401 indanavar = firsttrue(dato%btable == this%anavar%r%btable)
1402 this%volanar( &
1403 indana,indanavar,indnetwork &
1404 ) = dato%value
1405
1406 type is (dbadatad)
1407 indanavar = firsttrue(dato%btable == this%anavar%d%btable)
1408 this%volanad( &
1409 indana,indanavar,indnetwork &
1410 ) = dato%value
1411
1412 type is (dbadatab)
1413 indanavar = firsttrue(dato%btable == this%anavar%b%btable)
1414 this%volanab( &
1415 indana,indanavar,indnetwork &
1416 ) = dato%value
1417
1418 type is (dbadatac)
1419 indanavar = firsttrue(dato%btable == this%anavar%c%btable)
1420 this%volanac( &
1421 indana,indanavar,indnetwork &
1422 ) = dato%value
1423
1424 end select
1425
1426
1427 ! ana attributes
1428 do k=1, size(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv)
1429 associate(attr => metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat)
1430 select type (attr)
1431
1432 type is (dbadatai)
1433 indanavarattr = firsttrue(dato%btable == this%anavarattr%i%btable)
1434 indattrvar = firsttrue(attr%btable == this%anaattr%i%btable)
1435 this%volanaattri( &
1436 indana,indanavarattr,indnetwork,indattrvar &
1437 ) = attr%value
1438 type is (dbadatar)
1439 indanavarattr = firsttrue(dato%btable == this%anavarattr%r%btable)
1440 indattrvar = firsttrue(attr%btable == this%anaattr%r%btable)
1441 this%volanaattrr( &
1442 indana,indanavarattr,indnetwork,indattrvar &
1443 ) = attr%value
1444 type is (dbadatad)
1445 indanavarattr = firsttrue(dato%btable == this%anavarattr%d%btable)
1446 indattrvar = firsttrue(attr%btable == this%anaattr%d%btable)
1447 this%volanaattrd( &
1448 indana,indanavarattr,indnetwork,indattrvar &
1449 ) = attr%value
1450 type is (dbadatab)
1451 indanavarattr = firsttrue(dato%btable == this%anavarattr%b%btable)
1452 indattrvar = firsttrue(attr%btable == this%anaattr%b%btable)
1453 this%volanaattrb( &
1454 indana,indanavarattr,indnetwork,indattrvar &
1455 ) = attr%value
1456 type is (dbadatac)
1457 indanavarattr = firsttrue(dato%btable == this%anavarattr%c%btable)
1458 indattrvar = firsttrue(attr%btable == this%anaattr%c%btable)
1459 this%volanaattrc( &
1460 indana,indanavarattr,indnetwork,indattrvar &
1461 ) = attr%value
1462
1463 end select
1464 end associate
1465 end do
1466 end associate
1467 end do
1468 end if
1469end do
1470
1471contains
1472
1473!!$!> /brief Return an dbadcv from a mixlist with dbadata* type
1474!!$function todcv_dbadat(this)
1475!!$type(dbadcv) :: todcv_dbadat !< array
1476!!$type(mixlist) :: this
1477!!$
1478!!$integer :: i
1479!!$
1480!!$allocate (todcv_dbadat%dcv(this%countelements()))
1481!!$
1482!!$call this%rewind()
1483!!$i=0
1484!!$do while(this%element())
1485!!$ i=i+1
1486!!$
1487!!$ associate (dato => this%current())
1488!!$ select type (dato)
1489!!$ type is (dbadatar)
1490!!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato)
1491!!$ type is (dbadatai)
1492!!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato)
1493!!$ type is (dbadatab)
1494!!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato)
1495!!$ type is (dbadatad)
1496!!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato)
1497!!$ type is (dbadatac)
1498!!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato)
1499!!$ end select
1500!!$ end associate
1501!!$
1502!!$ call this%next()
1503!!$end do
1504!!$end function todcv_dbadat
1505
1506!!$! Definisce le funzioni count_distinct e pack_distinct
1507!!$#define VOL7D_POLY_TYPE TYPE(dbadata)
1508!!$#define VOL7D_POLY_TYPES _dbadata
1509!!$#undef ENABLE_SORT
1510!!$#include "array_utilities_inc.F90"
1511!!$#undef VOL7D_POLY_TYPE
1512!!$#undef VOL7D_POLY_TYPES
1513
1514
1515end subroutine dba2v7d
1516
1517
1518subroutine vol7d_dballe_import_dballevar(this)
1519
1520type(vol7d_var),pointer :: this(:)
1521INTEGER :: i,un,n
1522
1523IF (associated(this)) return
1524IF (allocated(blocal)) then
1525 ALLOCATE(this(size(blocal)))
1526 this=blocal
1527 return
1528end if
1529
1530un = open_dballe_file('dballe.txt', filetype_data)
1531IF (un < 0) then
1532
1533 call l4f_log(l4f_error,"error open_dballe_file: dballe.txt")
1534 CALL raise_error("error open_dballe_file: dballe.txt")
1535 return
1536end if
1537
1538n = 0
1539DO WHILE(.true.)
1540 READ(un,*,END=100)
1541 n = n + 1
1542ENDDO
1543100 CONTINUE
1544
1545IF (n > 0) THEN
1546 ALLOCATE(this(n))
1547 ALLOCATE(blocal(n))
1548 rewind(un)
1549 readline: do i = 1 ,n
1550 READ(un,'(1x,A6,1x,a65,a24,i4)')blocal(i)%btable,blocal(i)%description,blocal(i)%unit,&
1551 blocal(i)%scalefactor
1552 blocal(i)%btable(:1)="B"
1553 !print*,"B=",blocal(i)%btable
1554 !print*," D=",blocal(i)%description
1555 !PRINT*," U=",blocal(i)%unit
1556 !PRINT*," D=",blocal(i)%scalefactor
1557 ENDDO readline
1558
1559 CALL l4f_log(l4f_info,'Found '//trim(to_char(i-1))//' variables in dballe master table')
1560
1561 this=blocal
1562
1563ENDIF
1564CLOSE(un)
1565
1566END SUBROUTINE vol7d_dballe_import_dballevar
1567
1568
1569
1572
1573subroutine vol7d_dballe_set_var_du(this)
1574
1575TYPE(vol7d) :: this
1576integer :: i,j
1577type(vol7d_var),pointer :: dballevar(:)
1578
1579nullify(dballevar)
1580call vol7d_dballe_import_dballevar(dballevar)
1581
1582#undef VOL7D_POLY_NAME
1583#define VOL7D_POLY_NAME dativar
1584
1585
1586#undef VOL7D_POLY_TYPES_V
1587#define VOL7D_POLY_TYPES_V r
1588#include "vol7d_dballe_class_var_du.F90"
1589#undef VOL7D_POLY_TYPES_V
1590#define VOL7D_POLY_TYPES_V i
1591#include "vol7d_dballe_class_var_du.F90"
1592#undef VOL7D_POLY_TYPES_V
1593#define VOL7D_POLY_TYPES_V b
1594#include "vol7d_dballe_class_var_du.F90"
1595#undef VOL7D_POLY_TYPES_V
1596#define VOL7D_POLY_TYPES_V d
1597#include "vol7d_dballe_class_var_du.F90"
1598#undef VOL7D_POLY_TYPES_V
1599#define VOL7D_POLY_TYPES_V c
1600#include "vol7d_dballe_class_var_du.F90"
1601#undef VOL7D_POLY_TYPES_V
1602
1603#undef VOL7D_POLY_NAME
1604#define VOL7D_POLY_NAME anavar
1605
1606
1607#undef VOL7D_POLY_TYPES_V
1608#define VOL7D_POLY_TYPES_V r
1609#include "vol7d_dballe_class_var_du.F90"
1610#undef VOL7D_POLY_TYPES_V
1611#define VOL7D_POLY_TYPES_V i
1612#include "vol7d_dballe_class_var_du.F90"
1613#undef VOL7D_POLY_TYPES_V
1614#define VOL7D_POLY_TYPES_V b
1615#include "vol7d_dballe_class_var_du.F90"
1616#undef VOL7D_POLY_TYPES_V
1617#define VOL7D_POLY_TYPES_V d
1618#include "vol7d_dballe_class_var_du.F90"
1619#undef VOL7D_POLY_TYPES_V
1620#define VOL7D_POLY_TYPES_V c
1621#include "vol7d_dballe_class_var_du.F90"
1622#undef VOL7D_POLY_TYPES_V
1623
1624
1625#undef VOL7D_POLY_NAME
1626#define VOL7D_POLY_NAME datiattr
1627
1628
1629#undef VOL7D_POLY_TYPES_V
1630#define VOL7D_POLY_TYPES_V r
1631#include "vol7d_dballe_class_var_du.F90"
1632#undef VOL7D_POLY_TYPES_V
1633#define VOL7D_POLY_TYPES_V i
1634#include "vol7d_dballe_class_var_du.F90"
1635#undef VOL7D_POLY_TYPES_V
1636#define VOL7D_POLY_TYPES_V b
1637#include "vol7d_dballe_class_var_du.F90"
1638#undef VOL7D_POLY_TYPES_V
1639#define VOL7D_POLY_TYPES_V d
1640#include "vol7d_dballe_class_var_du.F90"
1641#undef VOL7D_POLY_TYPES_V
1642#define VOL7D_POLY_TYPES_V c
1643#include "vol7d_dballe_class_var_du.F90"
1644#undef VOL7D_POLY_TYPES_V
1645
1646
1647#undef VOL7D_POLY_NAME
1648#define VOL7D_POLY_NAME anaattr
1649
1650
1651#undef VOL7D_POLY_TYPES_V
1652#define VOL7D_POLY_TYPES_V r
1653#include "vol7d_dballe_class_var_du.F90"
1654#undef VOL7D_POLY_TYPES_V
1655#define VOL7D_POLY_TYPES_V i
1656#include "vol7d_dballe_class_var_du.F90"
1657#undef VOL7D_POLY_TYPES_V
1658#define VOL7D_POLY_TYPES_V b
1659#include "vol7d_dballe_class_var_du.F90"
1660#undef VOL7D_POLY_TYPES_V
1661#define VOL7D_POLY_TYPES_V d
1662#include "vol7d_dballe_class_var_du.F90"
1663#undef VOL7D_POLY_TYPES_V
1664#define VOL7D_POLY_TYPES_V c
1665#include "vol7d_dballe_class_var_du.F90"
1666#undef VOL7D_POLY_TYPES_V
1667
1668
1669deallocate(dballevar)
1670
1671return
1672
1673end subroutine vol7d_dballe_set_var_du
1674
1675
1676
1677FUNCTION get_dballe_filepath(filename, filetype) RESULT(path)
1678CHARACTER(len=*), INTENT(in) :: filename
1679INTEGER, INTENT(in) :: filetype
1680
1681INTEGER :: j
1682CHARACTER(len=512) :: path
1683LOGICAL :: exist
1684
1685IF (dballe_name == ' ') THEN
1686 CALL getarg(0, dballe_name)
1687 ! dballe_name_env
1688ENDIF
1689
1690IF (filetype < 1 .OR. filetype > nftype) THEN
1691 path = ""
1692 CALL l4f_log(l4f_error, 'dballe file type '//trim(to_char(filetype))// &
1693 ' not valid')
1694 CALL raise_error()
1695 RETURN
1696ENDIF
1697
1698! try with environment variable
1699CALL getenv(trim(dballe_name_env), path)
1700IF (path /= ' ') THEN
1701
1702 path=trim(path)//'/'//filename
1703 INQUIRE(file=path, exist=exist)
1704 IF (exist) THEN
1705 CALL l4f_log(l4f_info, 'dballe file '//trim(path)//' found')
1706 RETURN
1707 ENDIF
1708ENDIF
1709! try with pathlist
1710DO j = 1, SIZE(pathlist,1)
1711 IF (pathlist(j,filetype) == ' ') EXIT
1712 path=trim(pathlist(j,filetype))//'/'//trim(dballe_name)//'/'//filename
1713 INQUIRE(file=path, exist=exist)
1714 IF (exist) THEN
1715 CALL l4f_log(l4f_info, 'dballe file '//trim(path)//' found')
1716 RETURN
1717 ENDIF
1718ENDDO
1719CALL l4f_log(l4f_error, 'dballe file '//trim(filename)//' not found')
1720CALL raise_error()
1721path = ""
1722
1723END FUNCTION get_dballe_filepath
1724
1726FUNCTION open_dballe_file(filename, filetype) RESULT(unit)
1727CHARACTER(len=*), INTENT(in) :: filename
1728INTEGER, INTENT(in) :: filetype
1729INTEGER :: unit,i
1730
1731CHARACTER(len=512) :: path
1732
1733unit = -1
1734path=get_dballe_filepath(filename, filetype)
1735IF (path == '') RETURN
1736
1737unit = getunit()
1738IF (unit == -1) RETURN
1739
1740OPEN(unit, file=path, status='old', iostat = i)
1741IF (i == 0) THEN
1742 CALL l4f_log(l4f_info, 'dballe file '//trim(path)//' opened')
1743 RETURN
1744ENDIF
1745
1746CALL l4f_log(l4f_error, 'dballe file '//trim(filename)//' not found')
1747CALL raise_error()
1748unit = -1
1749
1750END FUNCTION open_dballe_file
1751
1752
1757
1758
1759!!! TODO manage attr_only
1760!!! attention template migrated in init
1761!SUBROUTINE vol7d_dballe_export(this, network, coordmin, coordmax,&
1762! timei, timef,level,timerange,var,attr,anavar,anaattr,attr_only,ana,dataonly)
1763
1764SUBROUTINE vol7d_dballe_export_old(this, network, coordmin, coordmax,&
1765 timei, timef,level,timerange,var,attr,anavar,anaattr,ana,dataonly,anaonly,template,attr_only)
1766
1767TYPE(vol7d_dballe),INTENT(inout) :: this
1768character(len=network_name_len),INTENT(in),optional :: network
1771TYPE(geo_coord),INTENT(in),optional :: coordmin,coordmax
1773TYPE(datetime),INTENT(in),optional :: timei, timef
1774TYPE(vol7d_level),INTENT(in),optional :: level
1775TYPE(vol7d_timerange),INTENT(in),optional :: timerange
1778CHARACTER(len=*),INTENT(in),OPTIONAL :: var(:),attr(:),anavar(:),anaattr(:)
1779!!$!> permette di riscrivere su un DSN letto precedentemente, modificando solo gli attributi ai dati,
1780!!$!! ottimizzando enormente le prestazioni: gli attributi riscritti saranno quelli con this%data_id definito
1781!!$!! (solitamente ricopiato dall'oggetto letto)
1782!!$logical,intent(in),optional :: attr_only
1783TYPE(vol7d_ana),INTENT(inout),optional :: ana
1784logical, intent(in),optional :: dataonly
1785logical, intent(in),optional :: anaonly
1788character(len=*),intent(in),optional :: template
1789logical, intent(in),optional :: attr_only
1790
1791
1792type(dbadcv) :: vars,starvars,anavars,anastarvars
1793type(dbafilter) :: filter
1794type(dbacoord) :: mydbacoordmin, mydbacoordmax
1795type(dbaana) :: mydbaana
1796type(dbadatetime) :: mydatetimemin, mydatetimemax
1797type(dbatimerange) :: mydbatimerange
1798type(dbalevel) :: mydbalevel
1799type(dbanetwork) :: mydbanetwork
1800
1801integer :: i
1802LOGICAL :: lattr, lanaattr
1803integer :: nanaattr,nattr,nanavar,nvar
1804
1805
1806 ! ------------- prepare filter options
1807
1808!!
1809!! translate export option for dballe2003 api
1810!!
1811
1812if (present(var)) then
1813 nvar=count(c_e(var))
1814 if (nvar > 0) then
1815 allocate (vars%dcv(nvar))
1816 do i=1,size(var)
1817 if (c_e(var(i)))then
1818 allocate (vars%dcv(i)%dat,source=dbadatac(var(i))) !char is default
1819 end if
1820 end do
1821 end if
1822end if
1823
1824if (present(anavar)) then
1825 nanavar=count(c_e(anavar))
1826 if (nanavar > 0) then
1827 allocate (anavars%dcv(nanavar))
1828 do i=1,size(anavar)
1829 if (c_e(anavar(i)))then
1830 allocate (anavars%dcv(i)%dat,source=dbadatac(anavar(i))) !char is default
1831 end if
1832 end do
1833 end if
1834end if
1835
1836lattr = .false.
1837if (present(attr)) then
1838 nattr=count(c_e(attr))
1839 if (nattr > 0) then
1840 lattr = .true.
1841 allocate (starvars%dcv(nattr))
1842 do i=1,size(attr)
1843 if (c_e(attr(i)))then
1844 allocate (starvars%dcv(i)%dat,source=dbadatac(attr(i))) !char is default
1845 end if
1846 end do
1847 end if
1848end if
1849
1850lanaattr = .false.
1851if (present(anaattr)) then
1852 nanaattr=count(c_e(anaattr))
1853 if (nanaattr > 0) then
1854 lanaattr = .true.
1855 allocate (anastarvars%dcv(nanaattr))
1856 do i=1,size(anaattr)
1857 if (c_e(anaattr(i)))then
1858 allocate (anastarvars%dcv(i)%dat,source=dbadatac(anaattr(i))) !char is default
1859 end if
1860 end do
1861 end if
1862end if
1863
1864
1865 ! like a cast
1866mydbacoordmin=dbacoord()
1867if (present(coordmin)) mydbacoordmin%geo_coord=coordmin
1868mydbacoordmax=dbacoord()
1869if (present(coordmax)) mydbacoordmax%geo_coord=coordmax
1870mydbaana=dbaana()
1871if (present(ana)) mydbaana%vol7d_ana=ana
1872mydatetimemin=dbadatetime()
1873if (present(timei)) mydatetimemin%datetime=timei
1874mydatetimemax=dbadatetime()
1875if (present(timef)) mydatetimemax%datetime=timef
1876mydbatimerange=dbatimerange()
1877if (present(timerange)) mydbatimerange%vol7d_timerange=timerange
1878mydbalevel=dbalevel()
1879if (present(level)) mydbalevel%vol7d_level=level
1880mydbanetwork=dbanetwork()
1881if (present(network)) call init(mydbanetwork%vol7d_network,name=network)
1882
1883!!
1884!! here we have options ready for filter
1885!!
1886filter=dbafilter(coordmin=mydbacoordmin,coordmax=mydbacoordmax,ana=mydbaana, &
1887 datetimemin=mydatetimemin,datetimemax=mydatetimemax, &
1888 timerange=mydbatimerange,level=mydbalevel,network=mydbanetwork,&
1889 vars=vars,starvars=starvars,anavars=anavars,anastarvars=anastarvars,&
1890 dataonly=dataonly,anaonly=anaonly)
1891
1892!!$ print *, "filter:"
1893!!$ call filter%display()
1894
1895call export (this, filter,template,attr_only)
1896
1897end SUBROUTINE vol7d_dballe_export_old
1898
1899
1900subroutine vol7d_dballe_export (this, filter, template, attr_only)
1901
1902TYPE(vol7d_dballe),INTENT(inout) :: this
1903type(dbafilter),intent(in) :: filter
1906character(len=*),intent(in),optional :: template
1907logical, intent(in),optional :: attr_only
1908
1909character(len=40) :: ltemplate
1910
1911type(dbametaanddatalist) :: metaanddatal
1912logical :: stat
1913
1914metaanddatal=dbametaanddatalist()
1915
1916call v7d2dba(this%vol7d,metaanddatal)
1917!call metaanddatal%display()
1918
1919!clean memdb
1920if (this%file) call this%handle%remove_all()
1921
1922! using filter here can limit memory use for memdb
1923call metaanddatal%extrude(session=this%handle,filter=filter,attronly=attr_only,template=template)
1924
1925if (this%file) then
1926 !!!!! this if we have written in memdb and now we have to write the file
1927
1928 !filter is already in extrude
1929 !this%handle%set(filter=filter)
1930
1931 ! export to file
1932 !! TODO : revert template from init to export !!!!!!!!!!!!!!!!!!!!!
1933 !!call this%handle%messages_write_next(template)
1934
1935 ! note that you can use unsetall hera because the filter was used in extrude
1936 call filter%dbaset(this%handle)
1937
1938 ltemplate=this%handle%template
1939 if (present(template))then
1940 ltemplate=template
1941 end if
1942
1943 call this%handle%messages_write_next(ltemplate)
1944
1945 !clean memdb
1946 call this%handle%remove_all()
1947
1948end if
1949
1950stat = metaanddatal%delete()
1951
1952end subroutine vol7d_dballe_export
1953
1954
1955subroutine v7d2dba(v7d,metaanddatal)
1956TYPE(vol7d),INTENT(in) :: v7d !!!!!! dovrebbe essere intent(in)
1957type(dbametaanddatalist),intent(inout) :: metaanddatal
1958
1959TYPE(vol7d_serialize_dballe) :: serialize
1960
1961serialize = vol7d_serialize_dballe_new()
1962serialize%anaonly=.true.
1963call serialize%vol7d_serialize_setup(v7d)
1964call serialize%vol7d_serialize_export(metaanddatal)
1965
1966serialize = vol7d_serialize_dballe_new()
1967serialize%dataonly=.true.
1968call serialize%vol7d_serialize_setup(v7d)
1969call serialize%vol7d_serialize_export(metaanddatal)
1970
1971end subroutine v7d2dba
1972
1973
1974end MODULE vol7d_dballe_class
1975
1979
1984
Index method.
Emit log message for a category with specific priority.
This module defines usefull general purpose function and subroutine.
Utilities for CHARACTER variables.
class for import and export data from e to DB-All.e.
Classes for handling georeferenced sparse points in geographical corodinates.
class to use character lists in fortran 2003 WARNING !!!! CHAR LEN IS FIXED TO listcharmaxlen.
class to manage links for lists in fortran 2003.
classe per la gestione del logging
Classe per la gestione di un volume completo di dati osservati.
classe per import ed export di volumi da e in DB-All.e
manage connection handle to a DSN
fortran 2003 interface to geo_coord
byte version for dbadata
character version for dbadata
doubleprecision version for dbadata
integer version for dbadata
real version for dbadata
vector of container of dbadata
filter to apply before ingest data
one metadata with more data plus attributes
manage session handle
Derived type defining an isolated georeferenced point on Earth in polar geographical coordinates.
Character specific implementation of doubly-linked list.
Definisce un oggetto contenente i volumi anagrafica e dati e tutti i descrittori delle loro dimension...
Oggetto per import ed export da DB-All.e.

Generated with Doxygen.