libsim  Versione 7.1.8
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 
78 MODULE vol7d_dballe_class
79 
80 USE dballe_class
82 USE vol7d_class
84 use log4fortran
86 !use list_mix
88 use list_linkchar
89 use vol7d_serialize_dballe_class
90 
91 IMPLICIT NONE
92 
93 character (len=255),parameter:: subcategory="vol7d_dballe_class"
94 
101 
102 TYPE 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 
114 END TYPE vol7d_dballe
115 
116 INTEGER, PARAMETER, PRIVATE :: nftype = 2
117 CHARACTER(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 
124 type(vol7d_var),allocatable,private :: blocal(:) ! cache of dballe.txt
125 
126 CHARACTER(len=20),PRIVATE :: dballe_name='wreport', dballe_name_env='DBA_TABLES'
127 
128 
130 INTERFACE init
131  MODULE PROCEDURE vol7d_dballe_init
132 END INTERFACE init
133 
135 INTERFACE delete
136  MODULE PROCEDURE vol7d_dballe_delete
137 END INTERFACE delete
138 
139 
141 INTERFACE import
142  MODULE PROCEDURE vol7d_dballe_importvvnv,vol7d_dballe_import, vol7d_dballe_import_old, dba2v7d
143 END INTERFACE import
144 
146 INTERFACE export
147  MODULE PROCEDURE vol7d_dballe_export_old,vol7d_dballe_export, v7d2dba
148 END INTERFACE export
149 
150 
151 PRIVATE
152 PUBLIC vol7d_dballe, init, delete, import, export, vol7d_dballe_import_dballevar, vol7d_dballe_set_var_du
153 
154 CONTAINS
155 
156 
158 SUBROUTINE vol7d_dballe_init(this,dsn,user,password,write,wipe,repinfo,&
159  filename,format,file,categoryappend,time_definition,idbhandle,template)
160 
161 
162 TYPE(vol7d_dballe),INTENT(out) :: this
163 character(len=*), INTENT(in),OPTIONAL :: dsn
164 character(len=*), INTENT(in),OPTIONAL :: user
165 character(len=*), INTENT(in),OPTIONAL :: password
166 logical,INTENT(in),OPTIONAL :: write
167 logical,INTENT(in),OPTIONAL :: wipe
168 character(len=*), INTENT(in),OPTIONAL :: repinfo
169 character(len=*),intent(inout),optional :: filename
170 character(len=*),intent(in),optional :: format
171 logical,INTENT(in),OPTIONAL :: file
172 character(len=*),INTENT(in),OPTIONAL :: categoryappend
173 integer,INTENT(in),OPTIONAL :: time_definition
174 integer,INTENT(in),OPTIONAL :: idbhandle
177 character(len=*),intent(in),optional :: template
178 
179 logical :: quiwrite,loadfile
180 character(len=512) :: a_name
181 character(len=254) :: arg,lfilename,lformat
182 
183 quiwrite=.false.
184 if (present(write))then
185  quiwrite=write
186 endif
187 
188 if (present(categoryappend))then
189  call l4f_launcher(a_name,a_name_append=trim(subcategory)//"."//trim(categoryappend))
190 else
191  call l4f_launcher(a_name,a_name_append=trim(subcategory))
192 endif
193 this%category=l4f_category_get(a_name)
194 
195 #ifdef DEBUG
196 CALL l4f_category_log(this%category,l4f_debug,'vol7d_dballe_init start')
197 #endif
198 
199 nullify(this%data_id)
200 
201 if (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 
232 else
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 
238 endif
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
244 CALL init(this%vol7d, time_definition)
245 this%time_definition = optio_i(time_definition)
246 
247 #ifdef DEBUG
248 CALL l4f_category_log(this%category,l4f_debug,'vol7d_dballe_init end')
249 #endif
250 
251 END SUBROUTINE vol7d_dballe_init
252 
253 
254 
258 
259 SUBROUTINE 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)
261 TYPE(vol7d_dballe),INTENT(inout) :: this
262 CHARACTER(len=*),INTENT(in) :: var(:)
263 TYPE(geo_coord),INTENT(inout),optional :: coordmin,coordmax
264 TYPE(vol7d_ana),INTENT(inout),optional :: ana
265 TYPE(datetime),INTENT(in),optional :: timei, timef
266 TYPE(vol7d_network),INTENT(in) :: network(:)
267 TYPE(vol7d_network),INTENT(in),OPTIONAL :: set_network
268 TYPE(vol7d_level),INTENT(in),optional :: level
269 TYPE(vol7d_timerange),INTENT(in),optional :: timerange
270 CHARACTER(len=*),INTENT(in),OPTIONAL :: attr(:),anavar(:),anaattr(:)
271 CHARACTER(len=*),INTENT(in),OPTIONAL :: varkind(:),attrkind(:),anavarkind(:),anaattrkind(:)
272 logical,intent(in),optional :: anaonly
273 LOGICAL,INTENT(in),OPTIONAL :: dataonly
274 TYPE(vol7d_dballe) :: v7ddbatmp
275 
276 INTEGER :: i
277 
278 IF (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)
284 ELSE
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
293 ENDIF
294 
295 END SUBROUTINE vol7d_dballe_importvvnv
296 
298 SUBROUTINE 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 
301 TYPE(vol7d_dballe),INTENT(inout) :: this
302 CHARACTER(len=*),INTENT(in),OPTIONAL :: var(:)
303 TYPE(geo_coord),INTENT(inout),optional :: coordmin,coordmax
304 TYPE(vol7d_ana),INTENT(inout),optional :: ana
305 TYPE(datetime),INTENT(in),OPTIONAL :: timei, timef
306 TYPE(vol7d_network),INTENT(in),OPTIONAL :: network,set_network
307 TYPE(vol7d_level),INTENT(in),optional :: level
308 TYPE(vol7d_timerange),INTENT(in),optional :: timerange
309 CHARACTER(len=*),INTENT(in),OPTIONAL :: attr(:),anavar(:),anaattr(:)
310 CHARACTER(len=*),INTENT(in),OPTIONAL :: varkind(:),attrkind(:),anavarkind(:),anaattrkind(:)
311 logical,intent(in),optional :: anaonly
312 logical,intent(in),optional :: dataonly
313 
314 
315 INTEGER,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 
321 LOGICAL :: ldegnet
322 
323 INTEGER :: i
324 integer :: nvar
325 integer :: nanavar
326 
327  !CHARACTER(len=10),allocatable :: lvar(:), lanavar(:)
328 type(dbadcv) :: vars,starvars,anavars,anastarvars
329 type(dbafilter) :: filter
330 type(dbacoord) :: mydbacoordmin, mydbacoordmax
331 type(dbaana) :: mydbaana
332 type(dbadatetime) :: mydatetimemin, mydatetimemax
333 type(dbatimerange) :: mydbatimerange
334 type(dbalevel) :: mydbalevel
335 type(dbanetwork) :: mydbanetwork
336 
337 integer :: nanaattr,nattr
338 
339 character(len=40) :: query
340 
341 #ifdef DEBUG
342 CALL l4f_category_log(this%category,l4f_debug,'inizio')
343 #endif
344 
345 
346 IF (PRESENT(set_network)) THEN
347  if (c_e(set_network)) then
348  ldegnet = .true.
349  else
350  ldegnet = .false.
351  end if
352 ELSE
353  ldegnet = .false.
354 ENDIF
355 
356 if(ldegnet) then
357  query = "best"
358 else
359  query=cmiss
360 end 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 
379 if (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
407 end if
408 
409 if (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
437 end if
438 
439 if (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
472 end if
473 
474 if (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
507 end if
508 
509 
510  ! like a cast
511 mydbacoordmin=dbacoord()
512 if (present(coordmin)) mydbacoordmin%geo_coord=coordmin
513 mydbacoordmax=dbacoord()
514 if (present(coordmax)) mydbacoordmax%geo_coord=coordmax
515 mydbaana=dbaana()
516 if (present(ana)) mydbaana%vol7d_ana=ana
517 mydatetimemin=dbadatetime()
518 if (present(timei)) mydatetimemin%datetime=timei
519 mydatetimemax=dbadatetime()
520 if (present(timef)) mydatetimemax%datetime=timef
521 mydbatimerange=dbatimerange()
522 if (present(timerange)) mydbatimerange%vol7d_timerange=timerange
523 mydbalevel=dbalevel()
524 if (present(level)) mydbalevel%vol7d_level=level
525 mydbanetwork=dbanetwork()
526 if (present(network)) mydbanetwork%vol7d_network=network
527 
528 !!
529 !! here we have options ready for filter
530 !!
531 filter=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 
539 call import(this,filter,set_network)
540 
541 
542 END SUBROUTINE vol7d_dballe_import_old
543 
544 
545 
547 subroutine vol7d_dballe_import(this,filter,set_network)
548 
549 TYPE(vol7d_dballe),INTENT(inout) :: this
550 type(dbafilter),INTENT(in) :: filter
551 TYPE(vol7d_network),INTENT(in),OPTIONAL :: set_network
552 
553 TYPE(vol7d) :: vol7dtmp
554 type(dbametaanddata),allocatable :: metaanddatav(:)
555 type(dbafilter) :: myfilter
556 
557 CALL l4f_category_log(this%category,l4f_debug,import vol7d_dballe')
558 
559 .not.if ( 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 
575 else
576  ! empty volume
577  call init(this%vol7d)
578  call vol7d_alloc(this%vol7d)
579  call vol7d_alloc_vol(this%vol7d)
580 end if
581  ! ----------------> constant station data end
582 
583 .not.if ( 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.)
604 end if
605 
606 call 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 
625 nullify(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 
635 this%data_id(indana,indtime,indlevel,indtimerange,indnetwork)=buffer(i)%data_id
636 
637 
638 ier=idba_set (this%handle,"*context_id",buffer(i)%data_id)
639 ier=idba_set (this%handle,"*var_related",buffer(i)%btable)
640  !per ogni dato ora lavoro sugli attributi
641 ier=idba_set(this%handle, "*varlist",starvarlist )
642 ier=idba_voglioancora (this%handle,nn)
643  !print*,buffer(i)%btable," numero attributi",nn
644 
645 #endif
646 
647 CALL l4f_category_log(this%category,L4F_DEBUG,'end import vol7d_dballe')
648 
649 importend subroutine vol7d_dballe_
650 
651 
652 
653  !>\brief Cancella l'oggetto !>\brief Cancella l'
654 
655 SUBROUTINE vol7d_dballe_delete(this, preserveidbhandle)
656 TYPE(vol7d_dballe) :: this !< oggetto da cancellare
657 logical,intent(in), optional :: preserveidbhandle !< do not close connection to dsn
658 
659 # ifndef F2003_FULL_FEATURES
660 call this%handle%delete()
661 
662 .not.if ( 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 
670 CALL delete(this%vol7d)
671 
672  !chiudo il logger
673 call l4f_category_delete(this%category)
674  !ier=l4f_fini()
675 
676 END SUBROUTINE vol7d_dballe_delete
677 
678 
679 
680 import dba objects in vol7d !>\brief
681 !subroutine dba2v7d(this,metaanddatav,vars,starvars,anavars,anastarvars,time_definition, set_network)
682 subroutine dba2v7d(this,metaanddatav,time_definition, set_network)
683 
684 type(dbametaanddata),intent(inout) :: metaanddatav(:) ! change value in datetime reguard timedefinition
685 TYPE(vol7d),INTENT(inout) :: this
686 integer,INTENT(in),OPTIONAL :: time_definition !< 0=time is reference time ; 1=time is validity time (default=1)
687 TYPE(vol7d_network),INTENT(in),OPTIONAL :: set_network
688 type(dbadcv) :: vars
689 type(dbadcv) :: starvars
690 type(dbadcv) :: anavars
691 type(dbadcv) :: anastarvars
692 
693 
694 LOGICAL :: ldegnet
695 integer :: indana,indtime,indlevel,indtimerange,inddativar,indnetwork,indattrvar
696 
697 integer :: nana,ntime,ntimerange,nlevel,nnetwork
698 
699 INTEGER :: i, j, k, n
700 integer :: inddativarattr
701 integer :: nanavar, indanavar,indanavarattr,nanavarattr
702 
703 integer :: ndativarr, ndativari, ndativarb, ndativard, ndativarc
704 integer :: ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc
705 integer :: ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc
706 
707 integer :: nanavarr, nanavari, nanavarb, nanavard, nanavarc
708 integer :: nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc
709 integer :: nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
710 
711 integer :: ndativar,ndativarattr
712 
713 type(characterlist) :: dativarl,dativarattrl,anavarl,anavarattrl
714 
715 character(len=listcharmaxlen),allocatable :: dativara(:),dativarattra(:),anavara(:),anavarattra(:)
716 logical :: status
717 integer :: ltime_definition
718 
719 type(datetime),allocatable :: tmptime(:)
720 type(vol7d_network),allocatable :: tmpnetwork(:)
721 type(vol7d_level),allocatable :: tmplevel(:)
722 type(vol7d_timerange),allocatable :: tmptimerange(:)
723 type(vol7d_ana),allocatable :: tmpana(:)
724 
725 
726 ltime_definition=optio_i(time_definition)
727 .not.if ( c_e(ltime_definition)) ltime_definition = 1
728 
729  ! take in account time_definition
730 if (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
736 end if
737 
738 
739 IF (PRESENT(set_network)) THEN
740  if (c_e(set_network)) then
741  ldegnet = .TRUE.
742  else
743  ldegnet = .FALSE.
744  end if
745 ELSE
746  ldegnet = .FALSE.
747 ENDIF
748 
749 
750 
751 !!--------------------------------------------------------------------------
752 !! find vars, starvars, anavars, anastarvars
753 !!
754 
755 ! create lists of all
756  ! data
757 do 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
767 end do
768 
769 !count and put in vector of unuique key
770 ndativar = count_distinct (toarray_charl(dativarl) , back=.TRUE.)
771 allocate(dativara(ndativar))
772 call pack_distinct_c (toarray_charl(dativarl) , dativara , back=.TRUE.)
773 status = dativarl%delete()
774 allocate (vars%dcv(ndativar))
775 
776 nanavar = count_distinct (toarray_charl(anavarl) , back=.TRUE.)
777 allocate(anavara(nanavar))
778 call pack_distinct_c (toarray_charl(anavarl) , anavara , back=.TRUE.)
779 status = anavarl%delete()
780 allocate (anavars%dcv(nanavar))
781 
782 
783 an: 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
794 end do an
795 
796 bn: do n=1,nanavar
797  do i =1, size(metaanddatav)
798  do j=1, size(metaanddatav(i)%dataattrv%dataattr)
799 .not. if ( 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
807 end do bn
808 
809  ! attributes
810 do 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
822 end do
823 
824 
825 ndativarattr = count_distinct (toarray_charl(dativarattrl), back=.TRUE.)
826 allocate(dativarattra(ndativarattr))
827 call pack_distinct_c (toarray_charl(dativarattrl), dativarattra, back=.TRUE.)
828 status = dativarattrl%delete()
829 allocate(starvars%dcv(ndativarattr))
830 
831 nanavarattr = count_distinct (toarray_charl(anavarattrl) , back=.TRUE.)
832 allocate(anavarattra(nanavarattr))
833 call pack_distinct_c (toarray_charl(anavarattrl) , anavarattra , back=.TRUE.)
834 status = anavarattrl%delete()
835 allocate(anastarvars%dcv(nanavarattr))
836 
837 
838 cn: 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
851 end do cn
852 
853 
854 dn: 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 .not. if ( 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
867 end do dn
868 
869 
870 !!--------------------------------------------------------------------------
871 
872 
873 !!
874 !! count all unique metadata
875 !!
876 
877 if(ldegnet) then
878  nnetwork=1
879 else
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)
885 end if
886 
887 !ntime = count_distinct(metaanddatav(:)%metadata%datetime%datetime, &
888 ! mask=c_e(metaanddatav(:)%metadata%datetime%datetime),back=.TRUE.)
889 allocate (tmptime(size(metaanddatav(:))),&
890  source=metaanddatav(:)%metadata%datetime%datetime)
891 call sort(tmptime)
892 ntime = 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.)
896 allocate (tmptimerange(size(metaanddatav(:))),&
897  source=metaanddatav(:)%metadata%timerange%vol7d_timerange)
898 call sort(tmptimerange)
899 ntimerange = 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.)
903 allocate (tmplevel(size(metaanddatav(:))),&
904  source=metaanddatav(:)%metadata%level%vol7d_level)
905 call sort(tmplevel)
906 nlevel = count_distinct_sorted(tmplevel,mask=c_e(tmplevel))
907 
908 !nana = count_distinct(metaanddatav(:)%metadata%ana%vol7d_ana, back=.TRUE.)
909 allocate (tmpana(size(metaanddatav(:))),&
910  source=metaanddatav(:)%metadata%ana%vol7d_ana)
911 call sort(tmpana)
912 nana = 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 
926 ndativarr = 0
927 ndativari = 0
928 ndativarb = 0
929 ndativard = 0
930 ndativarc = 0
931 
932 do 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
947 end do
948 
949 
950  !attr
951 
952 ndatiattrr = 0
953 ndatiattri = 0
954 ndatiattrb = 0
955 ndatiattrd = 0
956 ndatiattrc = 0
957 
958 do 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
973 end do
974 
975 
976  ! ana var
977 
978 nanavarr = 0
979 nanavari = 0
980 nanavarb = 0
981 nanavard = 0
982 nanavarc = 0
983 
984 do 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
999 end do
1000 
1001 
1002  ! ana attr
1003 
1004 nanaattrr = 0
1005 nanaattri = 0
1006 nanaattrb = 0
1007 nanaattrd = 0
1008 nanaattrc = 0
1009 
1010 do 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
1025 end do
1026 
1027 
1028  !refine
1029 
1030 ndativarattrr=0
1031 ndativarattri=0
1032 ndativarattrb=0
1033 ndativarattrd=0
1034 ndativarattrc=0
1035 
1036 if (ndatiattrr > 0 ) ndativarattrr=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1037 if (ndatiattri > 0 ) ndativarattri=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1038 if (ndatiattrb > 0 ) ndativarattrb=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1039 if (ndatiattrd > 0 ) ndativarattrd=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1040 if (ndatiattrc > 0 ) ndativarattrc=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1041 
1042 
1043 nanavarattrr=0
1044 nanavarattri=0
1045 nanavarattrb=0
1046 nanavarattrd=0
1047 nanavarattrc=0
1048 
1049 if (nanaattrr > 0 ) nanavarattrr=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1050 if (nanaattri > 0 ) nanavarattri=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1051 if (nanaattrb > 0 ) nanavarattrb=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1052 if (nanaattrd > 0 ) nanavarattrd=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1053 if (nanaattrc > 0 ) nanavarattrc=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1054 
1055 
1056 CALL 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 
1071 call vol7d_alloc (this, &
1072 nana=nana, ntime=ntime, ntimerange=ntimerange, &
1073 nlevel=nlevel, nnetwork=nnetwork, &
1074 ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb, ndativard=ndativard, ndativarc=ndativarc,&
1075 ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb, ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
1076 ndativarattrr=ndativarattrr, &
1077 ndativarattri=ndativarattri, &
1078 ndativarattrb=ndativarattrb, &
1079 ndativarattrd=ndativarattrd, &
1080 ndativarattrc=ndativarattrc,&
1081 nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, nanavard=nanavard, nanavarc=nanavarc,&
1082 nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb, nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
1083 nanavarattrr=nanavarattrr, &
1084 nanavarattri=nanavarattri, &
1085 nanavarattrb=nanavarattrb, &
1086 nanavarattrd=nanavarattrd, &
1087 nanavarattrc=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.)
1094 this%ana=pack_distinct_sorted(tmpana, nana)
1095 deallocate(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.)
1102 this%time=pack_distinct_sorted(tmptime, ntime,mask=c_e(tmptime))
1103 deallocate(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.)
1110 this%timerange=pack_distinct_sorted(tmptimerange, ntimerange,mask=c_e(tmptimerange))
1111 deallocate(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.)
1118 this%level=pack_distinct_sorted(tmplevel, nlevel,mask=c_e(tmplevel))
1119 deallocate(tmplevel)
1120 !call sort(this%level)
1121 
1122 if(ldegnet)then
1123  nnetwork=1
1124  ALLOCATE(this%network(1))
1125  this%network(1)=set_network
1126 else
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)
1131 end if
1132 !call sort(this%network)
1133 
1134  ! var
1135 
1136 ndativarr = 0
1137 ndativari = 0
1138 ndativarb = 0
1139 ndativard = 0
1140 ndativarc = 0
1141 
1142 do 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
1162 end do
1163 
1164 
1165  !attr
1166 
1167 ndatiattrr = 0
1168 ndatiattri = 0
1169 ndatiattrb = 0
1170 ndatiattrd = 0
1171 ndatiattrc = 0
1172 
1173 do 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
1193 end do
1194 
1195 
1196  ! ana var
1197 
1198 nanavarr = 0
1199 nanavari = 0
1200 nanavarb = 0
1201 nanavard = 0
1202 nanavarc = 0
1203 
1204 do 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
1224 end do
1225 
1226 
1227  ! ana attr
1228 
1229 nanaattrr = 0
1230 nanaattri = 0
1231 nanaattrb = 0
1232 nanaattrd = 0
1233 nanaattrc = 0
1234 
1235 do 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
1255 end do
1256 
1257 
1258  ! here we colcolate the link from attributes and vars
1259 do 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
1267 end do
1268 
1269 do 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
1277 end do
1278 
1279  ! set index in dativaratt*
1280 call vol7d_set_attr_ind(this)
1281 
1282 call vol7d_alloc_vol (this)
1283 
1284  ! Ora qui bisogna metterci dentro idati
1285 indana = 0
1286 indtime = 0
1287 indnetwork = 0
1288 indtime = 0
1289 indtimerange = 0
1290 indlevel = 0
1291 do 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 .and. if (c_e(metaanddatav(i)%metadata%datetime%datetime) &
1302 .and. c_e(metaanddatav(i)%metadata%timerange%vol7d_timerange) &
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
1469 end do
1470 
1471 contains
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 
1515 end subroutine dba2v7d
1516 
1517 
1518 subroutine vol7d_dballe_import_dballevar(this)
1519 
1520 type(vol7d_var),pointer :: this(:)
1521 INTEGER :: i,un,n
1522 
1523 IF (associated(this)) return
1524 IF (allocated(blocal)) then
1525  ALLOCATE(this(size(blocal)))
1526  this=blocal
1527  return
1528 end if
1529 
1530 un = open_dballe_file('dballe.txt', filetype_data)
1531 IF (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
1536 end if
1537 
1538 n = 0
1539 DO WHILE(.TRUE.)
1540  READ(un,*,END=100)
1541  n = n + 1
1542 ENDDO
1543 100 CONTINUE
1544 
1545 IF (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 
1563 ENDIF
1564 CLOSE(un)
1565 
1566 END SUBROUTINE vol7d_dballe_import_dballevar
1567 
1568 
1569 
1570 à!> \brief Integra il vettore delle variabili in vol7d con le descrizioni e le unit di misura
1571 !!eventualmente mancanti.
1572 
1573 subroutine vol7d_dballe_set_var_du(this)
1574 
1575 TYPE(vol7d) :: this !< oggetto vol7d con le variabili da completare
1576 integer :: i,j
1577 type(vol7d_var),pointer :: dballevar(:)
1578 
1579 nullify(dballevar)
1580 call 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 
1669 deallocate(dballevar)
1670 
1671 return
1672 
1673 end subroutine vol7d_dballe_set_var_du
1674 
1675 
1676 
1677 FUNCTION get_dballe_filepath(filename, filetype) RESULT(path)
1678 CHARACTER(len=*), INTENT(in) :: filename
1679 INTEGER, INTENT(in) :: filetype
1680 
1681 INTEGER :: j
1682 CHARACTER(len=512) :: path
1683 LOGICAL :: exist
1684 
1685 IF (dballe_name == ' ') THEN
1686  CALL getarg(0, dballe_name)
1687  ! dballe_name_env
1688 ENDIF
1689 
1690 .OR.IF (filetype < 1 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
1696 ENDIF
1697 
1698 ! try with environment variable
1699 CALL getenv(TRIM(dballe_name_env), path)
1700 IF (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
1708 ENDIF
1709 ! try with pathlist
1710 DO 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
1718 ENDDO
1719 CALL l4f_log(L4F_ERROR, 'dballe file '//TRIM(filename)//' not found')
1720 CALL raise_error()
1721 path = ""
1722 
1723 END FUNCTION get_dballe_filepath
1724 
1725 
1726 FUNCTION open_dballe_file(filename, filetype) RESULT(unit)
1727 CHARACTER(len=*), INTENT(in) :: filename
1728 INTEGER, INTENT(in) :: filetype
1729 INTEGER :: unit,i
1730 
1731 CHARACTER(len=512) :: path
1732 
1733 unit = -1
1734 path=get_dballe_filepath(filename, filetype)
1735 IF (path == '') RETURN
1736 
1737 unit = getunit()
1738 IF (unit == -1) RETURN
1739 
1740 OPEN(unit, file=path, status='old', iostat = i)
1741 IF (i == 0) THEN
1742  CALL l4f_log(L4F_INFO, 'dballe file '//TRIM(path)//' opened')
1743  RETURN
1744 ENDIF
1745 
1746 CALL l4f_log(L4F_ERROR, 'dballe file '//TRIM(filename)//' not found')
1747 CALL raise_error()
1748 unit = -1
1749 
1750 END FUNCTION open_dballe_file
1751 
1752 
1753 !> \brief Exporta un volume dati a un DSN DB-all.e
1754 !!
1755 à!! Riscrive i dati nel DSN di DB-All.e con la possibilit di attivare
1756 !! una serie di filtri.
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 
1764 SUBROUTINE vol7d_dballe_export_old(this, network, coordmin, coordmax,&
1765  timei, timef,level,timerange,var,attr,anavar,anaattr,ana,dataonly,anaonly,template,attr_only)
1766 
1767 TYPE(vol7d_dballe),INTENT(inout) :: this !< oggetto contenente il volume e altre info per l'accesso al dsn
1768 character(len=network_name_len),INTENT(in),optional :: network
1771 TYPE(geo_coord),INTENT(in),optional :: coordmin,coordmax
1773 TYPE(datetime),INTENT(in),optional :: timei, timef
1774 TYPE(vol7d_level),INTENT(in),optional :: level
1775 TYPE(vol7d_timerange),INTENT(in),optional :: timerange
1778 CHARACTER(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
1783 TYPE(vol7d_ana),INTENT(inout),optional :: ana
1784 logical, intent(in),optional :: dataonly
1785 logical, intent(in),optional :: anaonly
1788 character(len=*),intent(in),optional :: template
1789 logical, intent(in),optional :: attr_only
1790 
1791 
1792 type(dbadcv) :: vars,starvars,anavars,anastarvars
1793 type(dbafilter) :: filter
1794 type(dbacoord) :: mydbacoordmin, mydbacoordmax
1795 type(dbaana) :: mydbaana
1796 type(dbadatetime) :: mydatetimemin, mydatetimemax
1797 type(dbatimerange) :: mydbatimerange
1798 type(dbalevel) :: mydbalevel
1799 type(dbanetwork) :: mydbanetwork
1800 
1801 integer :: i
1802 LOGICAL :: lattr, lanaattr
1803 integer :: nanaattr,nattr,nanavar,nvar
1804 
1805 
1806  ! ------------- prepare filter options
1807 
1808 !!
1809 !! translate export option for dballe2003 api
1810 !!
1811 
1812 if (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
1822 end if
1823 
1824 if (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
1834 end if
1835 
1836 lattr = .false.
1837 if (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
1848 end if
1849 
1850 lanaattr = .false.
1851 if (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
1862 end if
1863 
1864 
1865  ! like a cast
1866 mydbacoordmin=dbacoord()
1867 if (present(coordmin)) mydbacoordmin%geo_coord=coordmin
1868 mydbacoordmax=dbacoord()
1869 if (present(coordmax)) mydbacoordmax%geo_coord=coordmax
1870 mydbaana=dbaana()
1871 if (present(ana)) mydbaana%vol7d_ana=ana
1872 mydatetimemin=dbadatetime()
1873 if (present(timei)) mydatetimemin%datetime=timei
1874 mydatetimemax=dbadatetime()
1875 if (present(timef)) mydatetimemax%datetime=timef
1876 mydbatimerange=dbatimerange()
1877 if (present(timerange)) mydbatimerange%vol7d_timerange=timerange
1878 mydbalevel=dbalevel()
1879 if (present(level)) mydbalevel%vol7d_level=level
1880 mydbanetwork=dbanetwork()
1881 if (present(network)) call init(mydbanetwork%vol7d_network,name=network)
1882 
1883 !!
1884 !! here we have options ready for filter
1885 !!
1886 filter=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 
1895 call export (this, filter,template,attr_only)
1896 
1897 end SUBROUTINE vol7d_dballe_export_old
1898 
1899 
1900 subroutine vol7d_dballe_export (this, filter, template, attr_only)
1901 
1902 TYPE(vol7d_dballe),INTENT(inout) :: this
1903 type(dbafilter),intent(in) :: filter
1906 character(len=*),intent(in),optional :: template
1907 logical, intent(in),optional :: attr_only
1908 
1909 character(len=40) :: ltemplate
1910 
1911 type(dbametaanddatalist) :: metaanddatal
1912 logical :: stat
1913 
1914 metaanddatal=dbametaanddatalist()
1915 
1916 call v7d2dba(this%vol7d,metaanddatal)
1917 !call metaanddatal%display()
1918 
1919 !clean memdb
1920 if (this%file) call this%handle%remove_all()
1921 
1922 ! using filter here can limit memory use for memdb
1923 call metaanddatal%extrude(session=this%handle,filter=filter,attronly=attr_only,template=template)
1924 
1925 if (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 
1948 end if
1949 
1950 stat = metaanddatal%delete()
1951 
1952 end subroutine vol7d_dballe_export
1953 
1954 
1955 subroutine v7d2dba(v7d,metaanddatal)
1956 TYPE(vol7d),INTENT(in) :: v7d !!!!!! dovrebbe essere intent(in)
1957 type(dbametaanddatalist),intent(inout) :: metaanddatal
1958 
1959 TYPE(vol7d_serialize_dballe) :: serialize
1960 
1961 serialize = vol7d_serialize_dballe_new()
1962 serialize%anaonly=.true.
1963 call serialize%vol7d_serialize_setup(v7d)
1964 call serialize%vol7d_serialize_export(metaanddatal)
1965 
1966 serialize = vol7d_serialize_dballe_new()
1967 serialize%dataonly=.true.
1968 call serialize%vol7d_serialize_setup(v7d)
1969 call serialize%vol7d_serialize_export(metaanddatal)
1970 
1971 end subroutine v7d2dba
1972 
1973 
1974 end MODULE vol7d_dballe_class
1975 
1979 
1984 
Index method.
Emit log message for a category with specific priority.
Test for a missing volume.
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
double linked list of dbametaanddata
manage session handle
Derived type defining an isolated georeferenced point on Earth in polar geographical coordinates.
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.