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

Generated with Doxygen.