libsim  Versione6.3.0
vol7d_dballeold_class.F90
1 ! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2 ! authors:
3 ! Davide Cesari <dcesari@arpa.emr.it>
4 ! Paolo Patruno <ppatruno@arpa.emr.it>
5 
6 ! This program is free software; you can redistribute it and/or
7 ! modify it under the terms of the GNU General Public License as
8 ! published by the Free Software Foundation; either version 2 of
9 ! the License, or (at your option) any later version.
10 
11 ! This program is distributed in the hope that it will be useful,
12 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ! GNU General Public License for more details.
15 
16 ! You should have received a copy of the GNU General Public License
17 ! along with this program. If not, see <http://www.gnu.org/licenses/>.
18 
19 #include "config.h"
20 
77 
79 
81 USE vol7d_class
83 use log4fortran
85 
86 IMPLICIT NONE
87 
88 include "dballeff.h"
89 
90 !external v7d_dballe_error_handler
91 
92 character (len=255),parameter:: subcategory="vol7d_dballe_class"
93 
100 
101 TYPE vol7d_dballe
102 
103  TYPE(vol7d) :: vol7d
104  integer :: idbhandle
105  integer :: handle,handle_staz
106  integer :: handle_err
109  integer ,pointer :: data_id(:,:,:,:,:)
110  logical :: file=.false.
111  integer :: category
112 
113 END TYPE vol7d_dballe
114 
115 INTEGER, PARAMETER, PRIVATE :: nftype = 2
116 CHARACTER(len=16), PARAMETER, PRIVATE :: &
117  pathlist(2,nftype) = reshape((/ &
118  '/usr/share ', '/usr/local/share', &
119  '/etc ', '/usr/local/etc ' /), &
120  (/2,nftype/))
121 
122 
123 CHARACTER(len=20),PRIVATE :: dballe_name='wreport', dballe_name_env='DBA_TABLES'
124 
125 
127 INTERFACE init
128  MODULE PROCEDURE vol7d_dballe_init
129 END INTERFACE
130 
132 INTERFACE delete
133  MODULE PROCEDURE vol7d_dballe_delete
134 END INTERFACE
135 
137 INTERFACE import
138  MODULE PROCEDURE vol7d_dballe_importvsns, vol7d_dballe_importvvns, &
139  vol7d_dballe_importvsnv, vol7d_dballe_importvvnv
140 END INTERFACE
141 
143 INTERFACE export
144  MODULE PROCEDURE vol7d_dballe_export
145 END INTERFACE
146 
147 
148 type record
149 
150  !! prime 5 dimensioni
151  integer :: data_id
152  TYPE(vol7d_ana) :: ana
153  TYPE(datetime) :: time
154  TYPE(vol7d_level) :: level
155  TYPE(vol7d_timerange) :: timerange
156  TYPE(vol7d_network) :: network
157  !TYPE(vol7d_var) :: dativar
158  CHARACTER(len=10) :: btable
159  !! Volumi di valori e attributi per dati
160  REAL :: dator
161  REAL(kind=fp_d) :: datod
162  INTEGER :: datoi
163  INTEGER(kind=int_b) :: datob
164  CHARACTER(len=vol7d_cdatalen) :: datoc
165 
166 ! INTEGER(kind=int_b) :: datiattrb(3)
167 ! REAL(kind=fp_d),POINTER :: voldatiattrd(:,:,:,:,:,:,:)
168 ! INTEGER,POINTER :: voldatiattri(:,:,:,:,:,:,:)
169 ! INTEGER(kind=int_b),POINTER :: voldatiattrb(:,:,:,:,:,:,:)
170 ! CHARACTER(len=vol7d_cdatalen),POINTER :: voldatiattrc(:,:,:,:,:,:,:)
171 
172 END TYPE record
173 
174 type(vol7d_var),allocatable,private :: blocal(:) ! cache of dballe.txt
175 
176 PRIVATE
177 PUBLIC vol7d_dballe, init, delete, import, export, vol7d_dballe_set_var_du, &
178  vol7d_dballe_import_dballevar
179 
180 CONTAINS
181 
182 
184 SUBROUTINE vol7d_dballe_init(this,dsn,user,password,write,wipe,repinfo,&
185  filename,format,file,categoryappend,time_definition,idbhandle)
186 
187 
188 TYPE(vol7d_dballe),INTENT(out) :: this
189 character(len=*), INTENT(in),OPTIONAL :: dsn
190 character(len=*), INTENT(in),OPTIONAL :: user
191 character(len=*), INTENT(in),OPTIONAL :: password
192 logical,INTENT(in),OPTIONAL :: write
193 logical,INTENT(in),OPTIONAL :: wipe
194 character(len=*), INTENT(in),OPTIONAL :: repinfo
195 character(len=*),intent(inout),optional :: filename
196 character(len=*),intent(in),optional :: format
197 logical,INTENT(in),OPTIONAL :: file
198 character(len=*),INTENT(in),OPTIONAL :: categoryappend
199 integer,INTENT(in),OPTIONAL :: time_definition
200 integer,INTENT(in),OPTIONAL :: idbhandle
201 
202 character(len=1):: mode ! the open mode ("r" for read, "w" for write or create, "a" append) (comandato da "write", default="r" )
203 
204 character(len=50) :: quidsn,quiuser,quipassword
205 character(len=255) :: quirepinfo
206 logical :: quiwrite,quiwipe,quifile
207 
208 character(len=512) :: a_name
209 character(len=254) :: arg,lfilename,lformat
210 logical :: exist
211 integer :: ier
212 #ifndef DBALLELT67
213 logical :: read_next
214 #endif
215 
216 this%idbhandle=imiss
217 this%handle=imiss
218 this%handle_err=imiss
219 this%handle_staz=imiss
220 
221 if (present(categoryappend))then
222  call l4f_launcher(a_name,a_name_append=trim(subcategory)//"."//trim(categoryappend))
223 else
224  call l4f_launcher(a_name,a_name_append=trim(subcategory))
225 endif
226 this%category=l4f_category_get(a_name)
227 
228 nullify(this%data_id)
229 
230 !TODO: quando scrivo bisogna gestire questo che non รจ da fare ?
231 CALL init(this%vol7d,time_definition=time_definition)
232 
233  ! impostiamo la gestione dell'errore
234 ier=idba_error_set_callback(0,v7d_dballe_error_handler, &
235  this%category,this%handle_err)
236 
237 quiwrite=.false.
238 if (present(write))then
239  quiwrite=write
240 endif
241 
242 quiwipe=.false.
243 quirepinfo=""
244 if (present(wipe))then
245  quiwipe=wipe
246  if (present(repinfo))then
247  quirepinfo=repinfo
248  endif
249 endif
250 
251 quifile=.false.
252 if (present(file))then
253  quifile=file
254 endif
255 
256 
257 if (quifile) then
258 
259  call getarg(0,arg)
260 
261  lformat="BUFR"
262  if (present(format))then
263  lformat=format
264  end if
265 
266 
267  lfilename=trim(arg)//"."//trim(lformat)
268  if (index(arg,'/',back=.true.) > 0) lfilename=lfilename(index(arg,'/',back=.true.)+1 : )
269 
270  if (present(filename))then
271  if (filename /= "")then
272  lfilename=filename
273  end if
274  end if
275 
276  inquire(file=lfilename,exist=exist)
277 
278  mode="r"
279  if (quiwrite)then
280  if (quiwipe.or..not.exist) then
281  mode="w"
282  else
283  mode="a"
284  call l4f_category_log(this%category,l4f_info,"file exists; appending data to file: "//trim(lfilename))
285  end if
286  else
287  if (.not.exist) then
288  call l4f_category_log(this%category,l4f_error,"file does not exist; cannot open file for read: "//trim(lfilename))
289  CALL raise_fatal_error()
290  end if
291  end if
292 
293 #ifndef DBALLELT67
294 
295  if(quiwrite)then
296  ier=idba_messaggi(this%handle,lfilename,mode,lformat)
297  this%file=.true.
298  else
299 
300  ier=idba_presentati(this%idbhandle,dsn="mem:",user="",password="")
301  ier=idba_preparati(this%idbhandle,this%handle,"write","write","write")
302  ier=idba_preparati(this%idbhandle,this%handle_staz,"write","write","write")
303  ier = idba_messages_open_input(this%handle, lfilename, mode, lformat, simplified=.true.)
304  ier=idba_messages_read_next(this%handle, read_next)
305  do while (read_next)
306  ier=idba_messages_read_next(this%handle, read_next)
307  end do
308  this%file=.false.
309  end if
310 #else
311 
312  ier=idba_messaggi(this%handle,lfilename,mode,lformat)
313  this%file=.true.
315 #endif
318 #ifdef DEBUG
319  call l4f_category_log(this%category,l4f_debug,"handle from idba_messaggi: "//t2c(this%handle))
320  call l4f_category_log(this%category,l4f_debug,"filename: "//trim(lfilename))
321  call l4f_category_log(this%category,l4f_debug,"mode: "//trim(mode))
322  call l4f_category_log(this%category,l4f_debug,"format: "//trim(lformat))
323 #endif
325 else
326 
327 
328  if (.not. c_e(optio_i(idbhandle))) then
329 
330  quidsn = "test"
331  quiuser = "test"
332  quipassword = ""
333  IF (PRESENT(dsn)) THEN
334  IF (c_e(dsn)) quidsn = dsn
335  ENDIF
336  IF (PRESENT(user)) THEN
337  IF (c_e(user)) quiuser = user
338  ENDIF
339  IF (PRESENT(password)) THEN
340  IF (c_e(password)) quipassword = password
341  ENDIF
342 
343  !print*,"write=",quiwrite,"wipe=",quiwipe,"dsn=",quidsn
344  ier=idba_presentati(this%idbhandle,quidsn,quiuser,quipassword)
345  else
346  this%idbhandle=optio_i(idbhandle)
347  end if
348 
349  if(quiwrite)then
350  ier=idba_preparati(this%idbhandle,this%handle,"write","write","write")
351  ier=idba_preparati(this%idbhandle,this%handle_staz,"write","write","write")
352  else
353  ier=idba_preparati(this%idbhandle,this%handle,"read","read","read")
354  ier=idba_preparati(this%idbhandle,this%handle_staz,"read","read","read")
355  end if
356 
357  if (quiwipe)ier=idba_scopa(this%handle,quirepinfo)
358 
359  this%file=.false.
360 
361 endif
362 
363 END SUBROUTINE vol7d_dballe_init
364 
365 
370 
371 SUBROUTINE vol7d_dballe_importvsns(this, var, network, coordmin, coordmax, timei, timef,level,timerange, set_network,&
372  attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,ana)
373 TYPE(vol7d_dballe),INTENT(inout) :: this
374 CHARACTER(len=*),INTENT(in) :: var
377 TYPE(geo_coord),INTENT(inout),optional :: coordmin,coordmax
379 TYPE(vol7d_ana),INTENT(inout),optional :: ana
381 TYPE(datetime),INTENT(in),optional :: timei, timef
382 TYPE(vol7d_network),INTENT(in),optional :: network
386 TYPE(vol7d_network),INTENT(in),OPTIONAL ::set_network
387 TYPE(vol7d_level),INTENT(in),optional :: level
388 TYPE(vol7d_timerange),INTENT(in),optional :: timerange
390 CHARACTER(len=*),INTENT(in),OPTIONAL :: attr(:)
392 CHARACTER(len=*),INTENT(in),OPTIONAL :: anavar(:)
394 CHARACTER(len=*),INTENT(in),OPTIONAL :: anaattr(:)
401 CHARACTER(len=*),INTENT(in),OPTIONAL :: varkind(:)
408 CHARACTER(len=*),INTENT(in),OPTIONAL :: attrkind(:)
415 CHARACTER(len=*),INTENT(in),OPTIONAL :: anavarkind(:)
422 CHARACTER(len=*),INTENT(in),OPTIONAL :: anaattrkind(:)
423 logical,intent(in),optional :: anaonly
424 
425 CALL import(this, (/var/), network, coordmin, coordmax, timei, timef,level,timerange, set_network,&
426  attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,ana)
427 
428 END SUBROUTINE vol7d_dballe_importvsns
429 
433 
434 SUBROUTINE vol7d_dballe_importvsnv(this, var, network, coordmin, coordmax, timei, timef,level,timerange, set_network,&
435  attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,ana)
436 TYPE(vol7d_dballe),INTENT(inout) :: this
437 CHARACTER(len=*),INTENT(in) :: var
438 TYPE(geo_coord),INTENT(inout),optional :: coordmin,coordmax
439 TYPE(vol7d_ana),INTENT(inout),optional :: ana
440 TYPE(datetime),INTENT(in),optional :: timei, timef
441 TYPE(vol7d_network),INTENT(in) :: network(:)
442 TYPE(vol7d_network),INTENT(in),OPTIONAL :: set_network
443 TYPE(vol7d_level),INTENT(in),optional :: level
444 TYPE(vol7d_timerange),INTENT(in),optional :: timerange
445 CHARACTER(len=*),INTENT(in),OPTIONAL :: attr(:),anavar(:),anaattr(:)
446 CHARACTER(len=*),INTENT(in),OPTIONAL :: varkind(:),attrkind(:),anavarkind(:),anaattrkind(:)
447 logical,intent(in),optional :: anaonly
448 
449 
450 INTEGER :: i
451 
452 if (size(network) == 0) then
453 
454  CALL import(this, (/var/), coordmin=coordmin, coordmax=coordmax, timei=timei, timef=timef, level=level,&
455  timerange=timerange,set_network=set_network, attr=attr,anavar=anavar,anaattr=anaattr,&
456  varkind=varkind,attrkind=attrkind,anavarkind=anavarkind,anaattrkind=anaattrkind,anaonly=anaonly,ana=ana)
457 
458 else
459 
460  DO i = 1, SIZE(network)
461  CALL import(this, (/var/), network(i), coordmin, coordmax, timei, timef, level,timerange,set_network,&
462  attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,ana)
463  ENDDO
464 end if
465 
466 
467 
468 END SUBROUTINE vol7d_dballe_importvsnv
469 
473 
474 SUBROUTINE vol7d_dballe_importvvnv(this, var, network, coordmin,coordmax, timei, timef, level,timerange,set_network,&
475  attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,ana)
476 TYPE(vol7d_dballe),INTENT(inout) :: this
477 CHARACTER(len=*),INTENT(in) :: var(:)
478 TYPE(geo_coord),INTENT(inout),optional :: coordmin,coordmax
479 TYPE(vol7d_ana),INTENT(inout),optional :: ana
480 TYPE(datetime),INTENT(in),optional :: timei, timef
481 TYPE(vol7d_network),INTENT(in) :: network(:)
482 TYPE(vol7d_network),INTENT(in),OPTIONAL :: set_network
483 TYPE(vol7d_level),INTENT(in),optional :: level
484 TYPE(vol7d_timerange),INTENT(in),optional :: timerange
485 CHARACTER(len=*),INTENT(in),OPTIONAL :: attr(:),anavar(:),anaattr(:)
486 CHARACTER(len=*),INTENT(in),OPTIONAL :: varkind(:),attrkind(:),anavarkind(:),anaattrkind(:)
487 logical,intent(in),optional :: anaonly
488 
489 INTEGER :: i
490 
491 if (size(network) == 0 )then
492  CALL import(this,var, coordmin=coordmin, coordmax=coordmax, timei=timei, timef=timef, level=level,&
493  timerange=timerange,set_network=set_network, attr=attr,anavar=anavar,anaattr=anaattr,&
494  varkind=varkind,attrkind=attrkind,anavarkind=anavarkind,anaattrkind=anaattrkind,anaonly=anaonly,ana=ana)
495 else
496  DO i = 1, SIZE(network)
497  CALL import(this, var, network(i), coordmin, coordmax, timei, timef, level,timerange,set_network,&
498  attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,ana)
499  ENDDO
500 end if
501 
502 END SUBROUTINE vol7d_dballe_importvvnv
503 
507 
508 SUBROUTINE vol7d_dballe_importvvns(this, var, network, coordmin, coordmax, timei, timef,level,timerange, set_network,&
509  attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,ana)
510 
511 TYPE(vol7d_dballe),INTENT(inout) :: this
512 CHARACTER(len=*),INTENT(in),optional :: var(:)
513 TYPE(geo_coord),INTENT(inout),optional :: coordmin,coordmax
514 TYPE(vol7d_ana),INTENT(inout),optional :: ana
515 TYPE(datetime),INTENT(in),OPTIONAL :: timei, timef
516 TYPE(vol7d_network),INTENT(in),OPTIONAL :: network,set_network
517 TYPE(vol7d_level),INTENT(in),optional :: level
518 TYPE(vol7d_timerange),INTENT(in),optional :: timerange
519 CHARACTER(len=*),INTENT(in),OPTIONAL :: attr(:),anavar(:),anaattr(:)
520 CHARACTER(len=*),INTENT(in),OPTIONAL :: varkind(:),attrkind(:),anavarkind(:),anaattrkind(:)
521 logical,intent(in),optional :: anaonly
522 
523 if (this%file) then
524 
525  call vol7d_dballe_importvvns_file(this, var, network, coordmin, coordmax, timei, timef,level,timerange, set_network,&
526  attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,ana)
527 
528 else
529 !!$ if (optio_log(anaonly)) then
530 !!$ CALL l4f_category_log(this%category,L4F_ERROR,"anaonly=.true. not supported accessing to dba")
531 !!$ CALL raise_fatal_error()
532 !!$ end if
533 
534  call vol7d_dballe_importvvns_dba(this, var, network, coordmin, coordmax, timei, timef,level,timerange, set_network,&
535  attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,ana)
536 
537 end if
538 
539 end SUBROUTINE vol7d_dballe_importvvns
540 
541 
542 
546 SUBROUTINE vol7d_dballe_importvvns_dba(this, var, network, coordmin, coordmax, timei, timef,level,timerange, set_network,&
547  attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,ana)
548 
549 TYPE(vol7d_dballe),INTENT(inout) :: this
550 CHARACTER(len=*),INTENT(in),OPTIONAL :: var(:)
551 TYPE(geo_coord),INTENT(inout),optional :: coordmin,coordmax
552 TYPE(vol7d_ana),INTENT(inout),optional :: ana
553 TYPE(datetime),INTENT(in),OPTIONAL :: timei, timef
554 TYPE(vol7d_network),INTENT(in),OPTIONAL :: network,set_network
555 TYPE(vol7d_level),INTENT(in),optional :: level
556 TYPE(vol7d_timerange),INTENT(in),optional :: timerange
557 CHARACTER(len=*),INTENT(in),OPTIONAL :: attr(:),anavar(:),anaattr(:)
558 CHARACTER(len=*),INTENT(in),OPTIONAL :: varkind(:),attrkind(:),anavarkind(:),anaattrkind(:)
559 logical,intent(in),optional :: anaonly
560 
561 TYPE(vol7d_network) :: lnetwork
562 TYPE(vol7d_level) :: llevel
563 TYPE(vol7d_timerange) :: ltimerange
564 
565 INTEGER,PARAMETER :: maxvarlist=100
566 !TYPE(vol7d) :: v7d
567 ! da non fare (con gfortran?)!!!!!
568 !CHARACTER(len=SIZE(var)*7) :: varlist
569 !CHARACTER(len=SIZE(attr)*8) :: starvarlist
570 CHARACTER(len=maxvarlist*7) :: varlist
571 CHARACTER(len=maxvarlist*8) :: starvarlist
572 CHARACTER(len=6) :: btable
573 CHARACTER(len=7) ::starbtable
574 
575 LOGICAL :: ldegnet, lattr, lanaattr
576 integer :: year,month,day,hour,minute,sec,msec
577 integer :: rlevel1, rl1,rlevel2, rl2
578 integer :: rtimerange, p1, p2
579 character(len=network_name_len) :: rep_memo
580 integer :: indana,indtime,indlevel,indtimerange,inddativar,indnetwork
581 
582 
583 integer :: nana,ntime,ntimerange,nlevel,nnetwork
584 TYPE(vol7d_var) :: var_tmp
585 
586 INTEGER :: i,ii, iii,n,n_ana,nn,nvarattr,istat,indattr
587 integer :: nvar ,inddatiattr,inddativarattr
588 integer :: nanavar ,indanavar,indanaattr,indanavarattr,nanavarattr
589 
590 INTEGER(kind=int_l) :: ilat,ilon
591 CHARACTER(len=vol7d_ana_lenident) :: ident
592 CHARACTER(len=10),allocatable :: lvar(:), lanavar(:)
593 !INTEGER(kind=int_b)::attrdatib
594 
595 integer :: ndativarr, ndativari, ndativarb, ndativard, ndativarc
596 integer :: ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc
597 integer :: ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc
598 
599 integer :: nanavarr, nanavari, nanavarb, nanavard, nanavarc
600 integer :: nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc
601 integer :: nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
602 
603 integer :: ir,ib,id,ic,ier
604 
605 
606 !TYPE(datetime) :: odatetime
607 ! nobs, ntime, nana, nvout, nvin, nvbt, &
608 ! datai(3), orai(2), dataf(3), oraf(2),ist
609 !CHARACTER(len=12),ALLOCATABLE :: tmtmp(:)
610 !INTEGER,ALLOCATABLE :: anatmp(:), vartmp(:), mapdatao(:)
611 !LOGICAL :: found, non_valid, varbt_req(SIZE(vartable))
612 
613 TYPE(vol7d) :: vol7dtmp
614 
615 type(record),ALLOCATABLE :: buffer(:),bufferana(:)
616 
617 !!! CALL print_info('Estratte dall''archivio '//TRIM(to_char(nobs)) // ' osservazioni')
618 
619 #ifdef DEBUG
620 CALL l4f_category_log(this%category,l4f_debug,'inizio')
621 #endif
622 
623 IF (PRESENT(set_network)) THEN
624  if (c_e(set_network)) then
625  ldegnet = .true.
626  else
627  ldegnet = .false.
628  end if
629 ELSE
630  ldegnet = .false.
631 ENDIF
632 
633 IF (PRESENT(attr)) THEN
634  if (any(c_e(attr)).and. size(attr) > 0)then
635 #ifdef DEBUG
636  CALL l4f_category_log(this%category,l4f_debug,'lattr true')
637 #endif
638  lattr = .true.
639  else
640 #ifdef DEBUG
641  CALL l4f_category_log(this%category,l4f_debug,'lattr false')
642 #endif
643  lattr = .false.
644  end if
645 ELSE
646 #ifdef DEBUG
647  CALL l4f_category_log(this%category,l4f_debug,'lattr false')
648 #endif
649  lattr = .false.
650 ENDIF
651 
652 IF (PRESENT(anaattr)) THEN
653  if (size(anaattr) > 0) then
654  lanaattr = .true.
655  else
656  lanaattr = .false.
657  end if
658 ELSE
659  lanaattr = .false.
660 ENDIF
661 
662 IF (PRESENT(var)) THEN
663  allocate(lvar(size(var)))
664  lvar=var
665 ELSE
666  allocate(lvar(0))
667 ENDIF
668 
669 IF (PRESENT(anavar)) THEN
670  allocate(lanavar(size(anavar)))
671  lanavar=anavar
672 ELSE
673  allocate(lanavar(0))
674 ENDIF
675 
676 if (present(network)) then
677  lnetwork=network
678 else
679  call init(lnetwork)
680 end if
681 
682 if (present(level)) then
683  llevel=level
684 else
685  call init(llevel)
686 end if
687 
688 if (present(timerange)) then
689  ltimerange=timerange
690 else
691  call init(ltimerange)
692 end if
693 
694 
695 ier=idba_unsetall(this%handle)
696 
697 #ifdef DEBUG
698 CALL l4f_category_log(this%category,l4f_debug,'unsetall handle')
699 #endif
700 
701 if(c_e(lnetwork))ier=idba_set(this%handle,"rep_memo",lnetwork%name)
702 
703 #ifdef DEBUG
704 CALL l4f_category_log(this%category,l4f_debug,'query rep_memo:'//t2c(lnetwork%name,miss="missing"))
705 #endif
706 
707 if(ldegnet)ier=idba_set(this%handle,"query","best")
708 #ifdef DEBUG
709 CALL l4f_category_log(this%category,l4f_debug,'query best:'//t2c(ldegnet))
710 #endif
711 
712 if (present(coordmin)) then
713 ! CALL geo_coord_to_geo(coordmin)
714  CALL getval(coordmin, ilat=ilat,ilon=ilon)
715 
716 #ifdef DEBUG
717  CALL l4f_category_log(this%category,l4f_debug,'query coordmin:'//t2c(ilon,miss="missing")//"/"//t2c(ilat,miss="missing"))
718 #endif
719  ier=idba_set(this%handle,"lonmin",ilon)
720  ier=idba_set(this%handle,"latmin",ilat)
721 end if
722 
723 if (present(coordmax)) then
724 ! CALL geo_coord_to_geo(coordmax)
725  CALL getval(coordmax, ilat=ilat,ilon=ilon)
726 #ifdef DEBUG
727  CALL l4f_category_log(this%category,l4f_debug,'query coordmax:'//t2c(ilon,miss="missing")//"/"//t2c(ilat,miss="missing"))
728 #endif
729  ier=idba_set(this%handle,"lonmax",ilon)
730  ier=idba_set(this%handle,"latmax",ilat)
731 end if
732 
733 if (present(ana)) then
734  CALL getval(ana%coord, ilat=ilat,ilon=ilon)
735 #ifdef DEBUG
736  CALL l4f_category_log(this%category,l4f_debug,'query coord:'//t2c(ilon,miss="missing")//"/"//t2c(ilat,miss="missing"))
737  CALL l4f_category_log(this%category,l4f_debug,'query ident:'//t2c(ana%ident,miss="missing"))
738 #endif
739  ier=idba_set(this%handle,"lon",ilon)
740  ier=idba_set(this%handle,"lat",ilat)
741  if (c_e(ana%ident)) then
742  ier=idba_set(this%handle,"ident",ana%ident)
743  ! mobile ignored
744  ier=idba_set(this%handle,"mobile",1)
745  else
746  ier=idba_set(this%handle,"mobile",0)
747  end if
748 end if
749 
750 if (present(timei)) then
751  if (c_e(timei)) then
752 #ifdef DEBUG
753  CALL l4f_category_log(this%category,l4f_debug,'query timei:'//to_char(timei))
754 #endif
755  CALL getval(timei, year=year, month=month, day=day, hour=hour, minute=minute,msec=msec)
756  sec=nint(float(msec)/1000.)
757  ier=idba_setdatemin(this%handle,year,month,day,hour,minute,sec)
758  !print *,"datemin",year,month,day,hour,minute,sec
759  end if
760 end if
762 if (present(timef)) then
763  if (c_e(timef)) then
764 #ifdef DEBUG
765  CALL l4f_category_log(this%category,l4f_debug,'query timef:'//to_char(timef))
766 #endif
767  CALL getval(timef, year=year, month=month, day=day, hour=hour, minute=minute,msec=msec)
768  sec=nint(float(msec)/1000.)
769  ier=idba_setdatemax(this%handle,year,month,day,hour,minute,sec)
770  !print *,"datemax",year,month,day,hour,minute,sec
771  end if
772 end if
773 
774 
775 nvar=0
776 
777 !if (any(c_e(lvar)) .and. .not. optio_log(anaonly)) then
778 if (any(c_e(lvar)) .and. .not. optio_log(anaonly)) then
779  !usefull for anaonly starting from dballe 6.6
780 
781  IF (SIZE(lvar) > maxvarlist) THEN
782  CALL l4f_category_log(this%category,l4f_error,"too many variables requested: "//t2c(SIZE(lvar)))
783  call raise_fatal_error()
784  ENDIF
785 
786  ! creo la stringa con l'elenco
787  varlist = ''
788  DO i = 1, SIZE(lvar)
789  nvar = nvar + 1
790  IF (nvar > 1) varlist(len_trim(varlist)+1:) = ','
791  varlist(len_trim(varlist)+1:) = trim(lvar(i))
792  ENDDO
793  !print *,"varlist",varlist
794 
795 #ifdef DEBUG
796  CALL l4f_category_log(this%category,l4f_debug,'query varlist:'//t2c(SIZE(lvar))//":"//varlist)
797 #endif
798  if (varlist /= '' ) ier=idba_set(this%handle, "varlist",varlist )
799 
800 end if
801 
802 if (c_e(ltimerange))then
803 #ifdef DEBUG
804  CALL l4f_category_log(this%category,l4f_debug,'query timerange:'//to_char(timerange))
805 #endif
806  ier=idba_settimerange(this%handle, timerange%timerange, timerange%p1, timerange%p2)
807 end if
808 
809 if (c_e(llevel))then
810 #ifdef DEBUG
811  CALL l4f_category_log(this%category,l4f_debug,'query level:'//to_char(level))
812 #endif
813  ier=idba_setlevel(this%handle, level%level1, level%l1,level%level2, level%l2)
814 end if
815 
816 ier=idba_voglioquesto(this%handle,n)
817 !print*,"numero di dati ",N
818 #ifdef DEBUG
819 CALL l4f_category_log(this%category,l4f_debug,'numero di dati:'//t2c(n))
820 #endif
821 
822 if (optio_log(anaonly)) n=0
823 
824 !ora che so quanti dati ho alloco la memoria per buffer
825 allocate(buffer(n),stat=istat)
826 IF (istat/= 0) THEN
827  CALL l4f_category_log(this%category,l4f_error,'cannot allocate ' &
828  //trim(to_char(n))//' buffer elements')
829  CALL raise_fatal_error()
830 ENDIF
831 
832 
833 ! dammi tutti i dati
834 do i=1,n
835 
836  ier=idba_dammelo(this%handle,btable)
837 
838  ier=idba_enqdate(this%handle,year,month,day,hour,minute,sec)
839  IF (.NOT.c_e(sec)) sec = 0
840  ier=idba_enqlevel(this%handle, rlevel1, rl1, rlevel2,rl2)
841  ier=idba_enqtimerange(this%handle, rtimerange, p1, p2)
842  ier=idba_enq(this%handle, "rep_memo",rep_memo)
843  !print *,"trovato network",rep_memo
844 
845  !nbtable=btable_numerico(btable)
846  ! ind = firsttrue(qccli%v7d%dativar%r(:)%btable == nbtable)
847  ! IF (ind<1) cycle ! non c'e'
848 
849  buffer(i)%dator=dba_mvr
850  buffer(i)%datoi=dba_mvi
851  buffer(i)%datob=dba_mvb
852  buffer(i)%datod=dba_mvd
853  buffer(i)%datoc=dba_mvc
854 
855  if (any(c_e(lvar)).and. present(varkind))then
856  ii= index_c(lvar, btable)
857  if (ii > 0)then
858  !print*, "indici",ii, btable,(varkind(ii))
859  if(varkind(ii) == "r") ier=idba_enq(this%handle,btable,buffer(i)%dator)
860  if(varkind(ii) == "i") ier=idba_enq(this%handle,btable,buffer(i)%datoi)
861  if(varkind(ii) == "b") ier=idba_enq(this%handle,btable,buffer(i)%datob)
862  if(varkind(ii) == "d") ier=idba_enq(this%handle,btable,buffer(i)%datod)
863  if(varkind(ii) == "c") ier=idba_enq(this%handle,btable,buffer(i)%datoc)
864  end if
865  else
866  ier=idba_enq(this%handle,btable,buffer(i)%datoc) !char is default
867  end if
868 
869  !metto in memoria l'identificatore numerico dei dati
870  !print*,buffer(i)%data_id
871  ier=idba_enq(this%handle,"context_id",buffer(i)%data_id)
872 
873  !recupero i dati di anagrafica
874  ier=idba_enq(this%handle,"lat", ilat)
875  ier=idba_enq(this%handle,"lon", ilon)
876  ier=idba_enq(this%handle,"ident",ident)
877 
878 !!$ print*,"ident",ident
879 !!$ do ier=1,len(ident)
880 !!$ print *,iachar(ident(ier:ier))
881 !!$ end do
882 
883  !bufferizzo il contesto
884  !print *,"lat,lon,ident",lat,lon,ident
885  !print*,year,month,day,hour,minute,sec
886  !print*,btable,dato,buffer(i)%datiattrb
887 
888  call init(buffer(i)%ana,ilat=ilat,ilon=ilon,ident=ident)
889  call init(buffer(i)%time, year=year, month=month, day=day, hour=hour, minute=minute,msec=sec*1000)
890  call init(buffer(i)%level, rlevel1,rl1,rlevel2,rl2)
891  call init(buffer(i)%timerange, rtimerange, p1, p2)
892  call init(buffer(i)%network, rep_memo)
893  buffer(i)%btable = btable
894 
895  ! take in account time_definition
896  if (this%vol7d%time_definition == 0) buffer(i)%time = buffer(i)%time - &
897  timedelta_new(sec=buffer(i)%timerange%p1)
898 
899 end do
900 
901 ! ----------------> anagrafica
902 
903 !ora legge tutti i dati di anagrafica e li mette in bufferana
904 
905 ier=idba_unsetall(this%handle_staz)
906 #ifdef DEBUG
907 CALL l4f_category_log(this%category,l4f_debug,'unsetall handle_staz')
908 #endif
909 
910 if(c_e(lnetwork))ier=idba_set(this%handle_staz,"rep_memo",lnetwork%name)
911 if(ldegnet)ier=idba_set(this%handle_staz,"query","best")
912 
913 if (present(coordmin)) then
914 ! CALL geo_coord_to_geo(coordmin)
915  CALL getval(coordmin, ilat=ilat,ilon=ilon)
916  ier=idba_set(this%handle_staz,"lonmin",ilon)
917  ier=idba_set(this%handle_staz,"latmin",ilat)
918 end if
919 
920 if (present(coordmax)) then
921 ! CALL geo_coord_to_geo(coordmax)
922  CALL getval(coordmax, ilat=ilat,ilon=ilon)
923  ier=idba_set(this%handle_staz,"lonmax",ilon)
924  ier=idba_set(this%handle_staz,"latmax",ilat)
925 end if
926 
927 if (present(ana)) then
928  CALL getval(ana%coord, ilat=ilat,ilon=ilon)
929  ier=idba_set(this%handle_staz,"lon",ilon)
930  ier=idba_set(this%handle_staz,"lat",ilat)
931  if (c_e(ana%ident)) then
932  ier=idba_set(this%handle_staz,"ident",ana%ident)
933 ! mobile ignored
934  ier=idba_set(this%handle_staz,"mobile",1)
935  else
936  ier=idba_set(this%handle_staz,"mobile",0)
937  end if
938 end if
939 
940 nanavar=0
941 
942 if (size (lanavar) > 0 ) then
943  ! creo la stringa con l'elenco
944  varlist = ''
945  DO i = 1, SIZE(lanavar)
946  nanavar = nanavar + 1
947  IF (nanavar > 1) varlist(len_trim(varlist)+1:) = ','
948  varlist(len_trim(varlist)+1:) = trim(lanavar(i))
949  ENDDO
950 !!$ print *,"varlist :",trim(varlist)
951 !!$ ier=idba_set(this%handle_staz, "varlist",trim(varlist))
952 
953 end if
954 
955 
956 ier=idba_setcontextana(this%handle_staz)
957 ier=idba_voglioquesto(this%handle_staz,n_ana)
958 !!$print*,"numero di dati ",N_ana
959 
960 !ora che so quanti dati ho alloco la memoria per bufferana
961 allocate(bufferana(n_ana),stat=istat)
962 if (istat/= 0) THEN
963  CALL l4f_category_log(this%category,l4f_error,'cannot allocate ' &
964  //trim(to_char(n_ana))//' bufferana elements')
965  CALL raise_fatal_error()
966 ENDIF
967 
968 
969 ! dammi tutti i dati di anagrafica
970 do i=1,n_ana
971  call init(bufferana(i)%ana)
972  call init(bufferana(i)%network)
973 
974  bufferana(i)%dator=dba_mvr
975  bufferana(i)%datoi=dba_mvi
976  bufferana(i)%datob=dba_mvb
977  bufferana(i)%datod=dba_mvd
978  bufferana(i)%datoc=dba_mvc
979  bufferana(i)%btable = dba_mvc
980 
981  ier=idba_dammelo(this%handle_staz,btable)
982 
983 
984  ier=idba_enqdate(this%handle_staz,year,month,day,hour,minute,sec)
985  IF (.NOT.c_e(sec)) sec = 0
986  ier=idba_enqlevel(this%handle_staz, rlevel1, rl1, rlevel2,rl2)
987  ier=idba_enqtimerange(this%handle_staz, rtimerange, p1, p2)
988  ier=idba_enq(this%handle_staz, "rep_memo",rep_memo)
989  !print *,"trovato network",rep_memo
990  !nbtable=btable_numerico(btable)
991  ! ind = firsttrue(qccli%v7d%dativar%r(:)%btable == nbtable)
992  ! IF (ind<1) cycle ! non c'e'
993 
994 
995  !metto in memoria l'identificatore numerico dei dati
996  !print*,bufferana(i)%data_id
997  ier=idba_enq(this%handle_staz,"context_id",bufferana(i)%data_id)
998 
999  !recupero i dati di anagrafica
1000  ier=idba_enq(this%handle_staz,"lat", ilat)
1001  ier=idba_enq(this%handle_staz,"lon", ilon)
1002  ier=idba_enq(this%handle_staz,"ident",ident)
1003 
1004 
1005  !bufferizzo il contesto
1006 
1007  call init(bufferana(i)%ana,ilat=ilat,ilon=ilon,ident=ident)
1008  call init(bufferana(i)%network, rep_memo)
1009 
1010  !salto lat lon e ident e network
1011  if (btable == "B05001" .or. btable == "B06001" .or. btable == "B01011" .or. btable == "B01194" ) cycle
1012 
1013  if ( size(lanavar) > 0 .and. present(anavarkind))then
1014  ii= index_c(lanavar, btable)
1015  if (ii > 0)then
1016  !print*, "indici",ii, btable,(varkind(ii))
1017  if(anavarkind(ii) == "r") ier=idba_enq(this%handle_staz,btable,bufferana(i)%dator)
1018  if(anavarkind(ii) == "i") ier=idba_enq(this%handle_staz,btable,bufferana(i)%datoi)
1019  if(anavarkind(ii) == "b") ier=idba_enq(this%handle_staz,btable,bufferana(i)%datob)
1020  if(anavarkind(ii) == "d") ier=idba_enq(this%handle_staz,btable,bufferana(i)%datod)
1021  if(anavarkind(ii) == "c") ier=idba_enq(this%handle_staz,btable,bufferana(i)%datoc)
1022  end if
1023  else
1024  ier=idba_enq(this%handle_staz,btable,bufferana(i)%datoc) !char is default
1025  !print*,"dato anagrafica",btable," ",bufferana(i)%dator
1026  end if
1027 
1028  call init(bufferana(i)%time, year=year, month=month, day=day, hour=hour, minute=minute,msec=sec*1000)
1029  call init(bufferana(i)%level, rlevel1,rl1,rlevel2,rl2)
1030  call init(bufferana(i)%timerange, rtimerange, p1, p2)
1031  bufferana(i)%btable = btable
1032 
1033 end do
1034 
1035 ! ----------------> anagrafica fine
1036 
1037 if (.not. any(c_e(lvar)))then
1038  nvar = count_distinct(buffer%btable, back=.true.)
1039 end if
1040 
1041 if (optio_log(anaonly)) then
1042  nana = count_distinct(bufferana%ana, back=.true.)
1043 else
1044  nana = count_distinct(buffer%ana, back=.true.)
1045 end if
1046 
1047 if(ldegnet) then
1048  nnetwork=1
1049 else
1050  if (optio_log(anaonly)) then
1051  nnetwork = count_distinct(bufferana%network, back=.true.)
1052  else
1053  nnetwork = count_distinct(buffer%network, back=.true.)
1054  end if
1055 end if
1056 
1057 
1058 ntime = count_distinct(buffer%time, back=.true.)
1059 ntimerange = count_distinct(buffer%timerange, back=.true.)
1060 nlevel = count_distinct(buffer%level, back=.true.)
1061 
1062 
1063 if (present(varkind))then
1064  ndativarr= count(varkind == "r")
1065  ndativari= count(varkind == "i")
1066  ndativarb= count(varkind == "b")
1067  ndativard= count(varkind == "d")
1068  ndativarc= count(varkind == "c")
1069 
1070 else
1071  ndativarr= 0
1072  ndativari= 0
1073  ndativarb= 0
1074  ndativard= 0
1075  ndativarc= nvar
1076 end if
1077 
1078 !print *, "nana=",nana," ntime=",ntime," ntimerange=",ntimerange, &
1079 !" nlevel=",nlevel," nnetwork=",nnetwork," ndativarr=",ndativarr
1080 
1081 if (lattr)then
1082 
1083  if (present(attrkind))then
1084  ndatiattrr= count(attrkind == "r")
1085  ndatiattri= count(attrkind == "i")
1086  ndatiattrb= count(attrkind == "b")
1087  ndatiattrd= count(attrkind == "d")
1088  ndatiattrc= count(attrkind == "c")
1089 
1090  else
1091  ndatiattrr= 0
1092  ndatiattri= 0
1093  ndatiattrb= 0
1094  ndatiattrd= 0
1095  ndatiattrc= size(attr)
1096  end if
1097 
1098 else
1099  ndatiattrr=0
1100  ndatiattri=0
1101  ndatiattrb=0
1102  ndatiattrd=0
1103  ndatiattrc=0
1104 end if
1105 
1106 ndativarattrr=0
1107 ndativarattri=0
1108 ndativarattrb=0
1109 ndativarattrd=0
1110 ndativarattrc=0
1111 
1112 if (ndatiattrr > 0 ) ndativarattrr=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1113 if (ndatiattri > 0 ) ndativarattri=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1114 if (ndatiattrb > 0 ) ndativarattrb=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1115 if (ndatiattrd > 0 ) ndativarattrd=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1116 if (ndatiattrc > 0 ) ndativarattrc=ndativarr+ndativari+ndativarb+ndativard+ndativarc
1117 
1118 
1119 ! ----------------> anagrafica
1120 
1121 if ( size(lanavar) == 0 )then
1122  nanavar = count_distinct(bufferana%btable, back=.true.,mask=(bufferana%btable /= dba_mvc))
1123 end if
1124 
1125 if (present(anavarkind))then
1126  nanavarr= count(anavarkind == "r")
1127  nanavari= count(anavarkind == "i")
1128  nanavarb= count(anavarkind == "b")
1129  nanavard= count(anavarkind == "d")
1130  nanavarc= count(anavarkind == "c")
1131 
1132 else
1133  nanavarr= 0
1134  nanavari= 0
1135  nanavarb= 0
1136  nanavard= 0
1137  nanavarc= nanavar
1138 end if
1139 
1140 !print *, "nana=",nana," ntime=",ntime," ntimerange=",ntimerange, &
1141 !" nlevel=",nlevel," nnetwork=",nnetwork," ndativarr=",ndativarr
1142 
1143 if (lanaattr)then
1144 
1145  if (present(anaattrkind))then
1146  nanaattrr= count(anaattrkind == "r")
1147  nanaattri= count(anaattrkind == "i")
1148  nanaattrb= count(anaattrkind == "b")
1149  nanaattrd= count(anaattrkind == "d")
1150  nanaattrc= count(anaattrkind == "c")
1151 
1152  else
1153  nanaattrr= 0
1154  nanaattri= 0
1155  nanaattrb= 0
1156  nanaattrd= 0
1157  nanaattrc= size(anaattr)
1158  end if
1159 
1160 else
1161  nanaattrr=0
1162  nanaattri=0
1163  nanaattrb=0
1164  nanaattrd=0
1165  nanaattrc=0
1166 end if
1167 
1168 nanavarattrr=0
1169 nanavarattri=0
1170 nanavarattrb=0
1171 nanavarattrd=0
1172 nanavarattrc=0
1173 
1174 if (nanaattrr > 0 ) nanavarattrr=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1175 if (nanaattri > 0 ) nanavarattri=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1176 if (nanaattrb > 0 ) nanavarattrb=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1177 if (nanaattrd > 0 ) nanavarattrd=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1178 if (nanaattrc > 0 ) nanavarattrc=nanavarr+nanavari+nanavarb+nanavard+nanavarc
1179 
1180 ! ----------------> anagrafica fine
1181 
1182 
1183 CALL init(vol7dtmp,time_definition=this%vol7d%time_definition)
1184 
1185 !print*,"ho fatto init"
1186 
1187 call vol7d_alloc (vol7dtmp, &
1188  nana=nana, ntime=ntime, ntimerange=ntimerange, &
1189  nlevel=nlevel, nnetwork=nnetwork, &
1190  ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb, ndativard=ndativard, ndativarc=ndativarc,&
1191  ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb, ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
1192  ndativarattrr=ndativarattrr, &
1193  ndativarattri=ndativarattri, &
1194  ndativarattrb=ndativarattrb, &
1195  ndativarattrd=ndativarattrd, &
1196  ndativarattrc=ndativarattrc,&
1197  nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, nanavard=nanavard, nanavarc=nanavarc,&
1198  nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb, nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
1199  nanavarattrr=nanavarattrr, &
1200  nanavarattri=nanavarattri, &
1201  nanavarattrb=nanavarattrb, &
1202  nanavarattrd=nanavarattrd, &
1203  nanavarattrc=nanavarattrc)
1204 
1205 !!$print *, "nana=",nana, "ntime=",ntime, "ntimerange=",ntimerange, &
1206 !!$ "nlevel=",nlevel, "nnetwork=",nnetwork, &
1207 !!$ "ndativarr=",ndativarr, "ndativari=",ndativari, &
1208 !!$ "ndativarb=",ndativarb, "ndativard=",ndativard, "ndativarc=",ndativarc,&
1209 !!$ "ndatiattrr=",ndatiattrr, "ndatiattri=",ndatiattri, "ndatiattrb=",ndatiattrb,&
1210 !!$ "ndatiattrd=",ndatiattrd, "ndatiattrc=",ndatiattrc,&
1211 !!$ "ndativarattrr=",ndativarattrr, "ndativarattri=",ndativarattri, "ndativarattrb=",ndativarattrb,&
1212 !!$ "ndativarattrd=",ndativarattrd, "ndativarattrc=",ndativarattrc
1213 !!$print*,"ho fatto alloc"
1214 
1215 if (optio_log(anaonly)) then
1216  vol7dtmp%ana=pack_distinct(bufferana%ana, nana, back=.true.)
1217 else
1218  vol7dtmp%ana=pack_distinct(buffer%ana, nana, back=.true.)
1219 endif
1220 
1221 vol7dtmp%time=pack_distinct(buffer%time, ntime, back=.true.)
1222 call sort(vol7dtmp%time)
1223 
1224 vol7dtmp%timerange=pack_distinct(buffer%timerange, ntimerange, back=.true.)
1225 call sort(vol7dtmp%timerange)
1226 
1227 vol7dtmp%level=pack_distinct(buffer%level, nlevel, back=.true.)
1228 call sort(vol7dtmp%level)
1229 
1230 if(ldegnet)then
1231  vol7dtmp%network(1)=set_network
1232 else
1233  if (optio_log(anaonly)) then
1234  vol7dtmp%network=pack_distinct(bufferana%network, nnetwork, back=.true.)
1235  else
1236  vol7dtmp%network=pack_distinct(buffer%network, nnetwork, back=.true.)
1237  end if
1238 end if
1239 
1240 !print*,"reti presenti", vol7dtmp%network%name,buffer%network%name
1241 
1242 if (any(c_e(lvar)).and. present(varkind))then
1243 
1244  ir=0
1245  ii=0
1246  ib=0
1247  id=0
1248  ic=0
1249 
1250  do i=1,size(varkind)
1251  if (varkind(i) == "r") then
1252  ir=ir+1
1253  call init (vol7dtmp%dativar%r(ir), btable=var(i))
1254  end if
1255  if (varkind(i) == "i") then
1256  ii=ii+1
1257  call init (vol7dtmp%dativar%i(ii), btable=var(i))
1258  end if
1259  if (varkind(i) == "b") then
1260  ib=ib+1
1261  call init (vol7dtmp%dativar%b(ib), btable=var(i))
1262  end if
1263  if (varkind(i) == "d") then
1264  id=id+1
1265  call init (vol7dtmp%dativar%d(id), btable=var(i))
1266  end if
1267  if (varkind(i) == "c") then
1268  ic=ic+1
1269  call init (vol7dtmp%dativar%c(ic), btable=var(i))
1270  end if
1271  end do
1272 else if (any(c_e(lvar)))then
1273  do i=1, nvar
1274  call init (vol7dtmp%dativar%c(i), btable=var(i))
1275  end do
1276 else
1277 
1278  do i=1,ndativarc
1279  call init(vol7dtmp%dativar%c(i))
1280  end do
1281 
1282  if (ndativarc > 0) then
1283  call pack_distinct_c(buffer%btable, vol7dtmp%dativar%c%btable, back=.true.,mask=(buffer%btable /= dba_mvc))
1284  end if
1285 
1286 end if
1287 
1288 
1289 
1290 if ( present(attrkind).and. present(attr).and. any(c_e(lvar)))then
1291 
1292  ir=0
1293  ii=0
1294  ib=0
1295  id=0
1296  ic=0
1297 
1298  do i=1,size(lvar)
1299 
1300  if ( ndativarattrr > 0 )then
1301  ir=ir+1
1302  call init (vol7dtmp%dativarattr%r(ir), btable=lvar(i))
1303  end if
1304 
1305  if ( ndativarattri > 0 )then
1306  ii=ii+1
1307  call init (vol7dtmp%dativarattr%i(ii), btable=lvar(i))
1308  end if
1309 
1310  if ( ndativarattrb > 0 )then
1311  ib=ib+1
1312  call init (vol7dtmp%dativarattr%b(ib), btable=lvar(i))
1313  end if
1314 
1315  if ( ndativarattrd > 0 )then
1316  id=id+1
1317  call init (vol7dtmp%dativarattr%d(id), btable=lvar(i))
1318  end if
1319 
1320  if ( ndativarattrc > 0 )then
1321  ic=ic+1
1322  call init (vol7dtmp%dativarattr%c(ic), btable=lvar(i))
1323  end if
1324 
1325  end do
1326 
1327 else if (present(attr).and. any(c_e(lvar)))then
1328 
1329  do i=1,size(lvar)
1330  if ( ndativarattrc > 0 )call init (vol7dtmp%dativarattr%c(i), btable=lvar(i))
1331  end do
1332 
1333 else if (associated(vol7dtmp%dativarattr%c).and. associated(vol7dtmp%dativar%c)) then
1334 
1335  vol7dtmp%dativarattr%c=vol7dtmp%dativar%c
1336 
1337 end if
1338 
1339 
1340 if (present(attrkind).and. lattr)then
1341 
1342  ir=0
1343  ii=0
1344  ib=0
1345  id=0
1346  ic=0
1347 
1348  do i=1,size(attrkind)
1349 
1350  if (attrkind(i) == "r") then
1351  ir=ir+1
1352  call init (vol7dtmp%datiattr%r(ir), btable=attr(i))
1353  end if
1354  if (attrkind(i) == "i") then
1355  ii=ii+1
1356  call init (vol7dtmp%datiattr%i(ii), btable=attr(i))
1357  end if
1358  if (attrkind(i) == "b") then
1359  ib=ib+1
1360  call init (vol7dtmp%datiattr%b(ib), btable=attr(i))
1361  end if
1362  if (attrkind(i) == "d") then
1363  id=id+1
1364  call init (vol7dtmp%datiattr%d(id), btable=attr(i))
1365  end if
1366  if (attrkind(i) == "c") then
1367  ic=ic+1
1368  call init (vol7dtmp%datiattr%c(ic), btable=attr(i))
1369  end if
1370  end do
1371 else if (present(attr))then
1372 
1373  do i=1, size(attr)
1374  call init (vol7dtmp%datiattr%c(i), btable=attr(i))
1375  end do
1376 
1377 end if
1378 
1379 !-----------------------> anagrafica
1380 
1381 if ( size(lanavar) > 0 .and. present(anavarkind))then
1382 
1383  ir=0
1384  ii=0
1385  ib=0
1386  id=0
1387  ic=0
1388 
1389  do i=1,size(anavarkind)
1390  if (anavarkind(i) == "r") then
1391  ir=ir+1
1392  call init (vol7dtmp%anavar%r(ir), btable=anavar(i))
1393  end if
1394  if (anavarkind(i) == "i") then
1395  ii=ii+1
1396  call init (vol7dtmp%anavar%i(ii), btable=anavar(i))
1397  end if
1398  if (anavarkind(i) == "b") then
1399  ib=ib+1
1400  call init (vol7dtmp%anavar%b(ib), btable=anavar(i))
1401  end if
1402  if (anavarkind(i) == "d") then
1403  id=id+1
1404  call init (vol7dtmp%anavar%d(id), btable=anavar(i))
1405  end if
1406  if (anavarkind(i) == "c") then
1407  ic=ic+1
1408  call init (vol7dtmp%anavar%c(ic), btable=anavar(i))
1409  end if
1410  end do
1411 else if ( size(lanavar) > 0 )then
1412 
1413  do i=1, nanavar
1414  call init (vol7dtmp%anavar%c(i), btable=anavar(i))
1415  end do
1416 
1417 else
1418 
1419  do i=1,nanavarc
1420  call init(vol7dtmp%anavar%c(i))
1421  end do
1422  if (nanavarc > 0) then
1423  call pack_distinct_c(bufferana%btable, vol7dtmp%anavar%c%btable, back=.true.,mask=(bufferana%btable /= dba_mvc))
1424  end if
1425 end if
1426 
1427 
1428 
1429 if ( present(anaattrkind) .and. present(anaattr) .and. size(anavar) > 0 )then
1430 
1431  ir=0
1432  ii=0
1433  ib=0
1434  id=0
1435  ic=0
1436 
1437  do i=1,size(anavar)
1438 
1439  if ( nanavarattrr > 0 )then
1440  ir=ir+1
1441  call init (vol7dtmp%anavarattr%r(ir), btable=anavar(i))
1442  end if
1443 
1444  if ( nanavarattri > 0 )then
1445  ii=ii+1
1446  call init (vol7dtmp%anavarattr%i(ii), btable=anavar(i))
1447  end if
1448 
1449  if ( nanavarattrb > 0 )then
1450  ib=ib+1
1451  call init (vol7dtmp%anavarattr%b(ib), btable=anavar(i))
1452  end if
1453 
1454  if ( nanavarattrd > 0 )then
1455  id=id+1
1456  call init (vol7dtmp%anavarattr%d(id), btable=anavar(i))
1457  end if
1458 
1459  if ( nanavarattrc > 0 )then
1460  ic=ic+1
1461  call init (vol7dtmp%anavarattr%c(ic), btable=anavar(i))
1462  end if
1463 
1464  end do
1465 
1466 else if (present(anaattr) .and. size(anavar) > 0 )then
1467 
1468  do i=1,size(anavar)
1469  if ( nanavarattrc > 0 )call init(vol7dtmp%anavarattr%c(i), btable=anavar(i))
1470  end do
1471 
1472 else if (associated(vol7dtmp%anavarattr%c) .and. associated(vol7dtmp%anavar%c)) then
1473 
1474  vol7dtmp%anavarattr%c=vol7dtmp%anavar%c
1475 
1476 end if
1477 
1478 
1479 if (present(anaattrkind).and. present(anaattr))then
1480 
1481  ir=0
1482  ii=0
1483  ib=0
1484  id=0
1485  ic=0
1486 
1487  do i=1,size(anaattrkind)
1488 
1489  if (anaattrkind(i) == "r") then
1490  ir=ir+1
1491  call init (vol7dtmp%anaattr%r(ir), btable=anaattr(i))
1492  end if
1493  if (anaattrkind(i) == "i") then
1494  ii=ii+1
1495  call init (vol7dtmp%anaattr%i(ii), btable=anaattr(i))
1496  end if
1497  if (anaattrkind(i) == "b") then
1498  ib=ib+1
1499  call init (vol7dtmp%anaattr%b(ib), btable=anaattr(i))
1500  end if
1501  if (anaattrkind(i) == "d") then
1502  id=id+1
1503  call init (vol7dtmp%anaattr%d(id), btable=anaattr(i))
1504  end if
1505  if (anaattrkind(i) == "c") then
1506  ic=ic+1
1507  call init (vol7dtmp%anaattr%c(ic), btable=anaattr(i))
1508  end if
1509  end do
1510 else if (present(anaattr))then
1511 
1512  do i=1, size(anaattr)
1513  call init (vol7dtmp%anaattr%c(i), btable=anaattr(i))
1514  end do
1515 
1516 end if
1517 
1518 
1519 !print*,"numero variabili anagrafica",size(vol7dtmp%anavar%r)
1520 !do i=1,size(vol7dtmp%anavar%r)
1521 ! print*,"elenco variabili anagrafica>",vol7dtmp%anavar%r(i)%btable,"<fine"
1522 !end do
1523 
1524 !-----------------------> anagrafica fine
1525 
1526 call vol7d_alloc_vol (vol7dtmp)
1527 
1528 if (lattr) then
1529 
1530  allocate (this%data_id( nana, ntime, nlevel, ntimerange, nnetwork),stat=istat)
1531  if (istat/= 0) THEN
1532  CALL l4f_category_log(this%category,l4f_error,'cannot allocate ' &
1533  //trim(to_char(nana*ntime*nlevel*ntimerange*nnetwork))//' data_id elements')
1534  CALL raise_fatal_error()
1535 
1536  ENDIF
1537 
1538  this%data_id=dba_mvi
1539 
1540 else
1541 
1542  nullify(this%data_id)
1543 
1544 end if
1545 
1546 !vol7dtmp%voldatir=DBA_MVR
1547 !vol7dtmp%voldatii=DBA_MVI
1548 !vol7dtmp%voldatib=DBA_MVB
1549 !vol7dtmp%voldatid=DBA_MVD
1550 !vol7dtmp%voldatic=DBA_MVC
1551 !vol7dtmp%voldatiattrr=DBA_MVR
1552 !vol7dtmp%voldatiattri=DBA_MVI
1553 !vol7dtmp%voldatiattrb=DBA_MVB
1554 !vol7dtmp%voldatiattrd=DBA_MVD
1555 !vol7dtmp%voldatiattrc=DBA_MVC
1556 
1557 if (lattr)then
1558 
1559  IF (SIZE(attr) > maxvarlist) THEN
1560  CALL l4f_category_log(this%category,l4f_error,"too many attributes requested: "//t2c(SIZE(attr)))
1561  call raise_fatal_error()
1562  ENDIF
1563 
1564  ! creo la stringa con l'elenco delle variabili di attributo
1565  starvarlist = ''
1566  nvarattr=0
1567  DO ii = 1, SIZE(attr)
1568  nvarattr = nvarattr + 1
1569  IF (nvarattr > 1) starvarlist(len_trim(starvarlist)+1:) = ','
1570  starvarlist(len_trim(starvarlist)+1:) = trim(attr(ii))
1571  ENDDO
1572  !print *,"starvarlist",starvarlist
1573 
1574 end if
1575 
1576 do i =1, n
1577 
1578  indana = firsttrue(buffer(i)%ana == vol7dtmp%ana)
1579  indtime = firsttrue(buffer(i)%time == vol7dtmp%time)
1580  indtimerange = firsttrue(buffer(i)%timerange == vol7dtmp%timerange)
1581  indlevel = firsttrue(buffer(i)%level == vol7dtmp%level)
1582  if (ldegnet)then
1583  indnetwork=1
1584  else
1585  indnetwork = firsttrue(buffer(i)%network == vol7dtmp%network)
1586  endif
1587  !print *, indana,indtime,indlevel,indtimerange,indnetwork
1588 
1589  if(c_e(buffer(i)%dator))then
1590  inddativar = firsttrue(buffer(i)%btable == vol7dtmp%dativar%r%btable)
1591  vol7dtmp%voldatir( &
1592  indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
1593  ) = buffer(i)%dator
1594  end if
1595 
1596  if(c_e(buffer(i)%datoi)) then
1597  inddativar = firsttrue(buffer(i)%btable == vol7dtmp%dativar%i%btable)
1598  vol7dtmp%voldatii( &
1599  indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
1600  ) = buffer(i)%datoi
1601  end if
1602 
1603  if(c_e(buffer(i)%datob)) then
1604  inddativar = firsttrue(buffer(i)%btable == vol7dtmp%dativar%b%btable)
1605  vol7dtmp%voldatib( &
1606  indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
1607  ) = buffer(i)%datob
1608  end if
1609 
1610  if(c_e(buffer(i)%datod)) then
1611  inddativar = firsttrue(buffer(i)%btable == vol7dtmp%dativar%d%btable)
1612  vol7dtmp%voldatid( &
1613  indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
1614  ) = buffer(i)%datod
1615  end if
1616 
1617  if(c_e(buffer(i)%datoc)) then
1618  inddativar = firsttrue(buffer(i)%btable == vol7dtmp%dativar%c%btable)
1619  vol7dtmp%voldatic( &
1620  indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
1621  ) = buffer(i)%datoc
1622  end if
1623 
1624  if (lattr)then
1625 
1626  !memorizzo data_id
1627 #ifdef DEBUG
1628  !CALL l4f_category_log(this%category,L4F_DEBUG,"data_id: "//trim(to_char(buffer(i)%data_id)))
1629 #endif
1630 
1631  this%data_id(indana,indtime,indlevel,indtimerange,indnetwork)=buffer(i)%data_id
1632 
1633  ier=idba_unsetall(this%handle)
1634 #ifdef DEBUG
1635  CALL l4f_category_log(this%category,l4f_debug,'unsetall handle')
1636 #endif
1637  ier=idba_set(this%handle,"*context_id",buffer(i)%data_id)
1638  ier=idba_set(this%handle,"*var_related",buffer(i)%btable)
1639  !per ogni dato ora lavoro sugli attributi
1640  ier=idba_set(this%handle, "*varlist",starvarlist )
1641  ier=idba_voglioancora(this%handle,nn)
1642  !print*,buffer(i)%btable," numero attributi",nn
1643 
1644  do ii=1,nn ! Se ho piu` di 1 attributo devo forse trovare l'indice (ii)
1645  ier=idba_ancora(this%handle,starbtable)
1646  !print *, starbtable
1647  indattr = firsttrue(attr == starbtable)
1648  IF (indattr<1) cycle ! non c'e'
1649 
1650  call init (var_tmp, btable=starbtable)
1651 
1652  if (present(attrkind))then
1653  iii=( firsttrue(attr == starbtable))
1654  !print *,"ho letto indice attributo ",starbtable,iii
1655  if (iii > 0)then
1656 
1658  if(attrkind(iii) == "r") then
1659  inddativarattr = firsttrue(buffer(i)%btable == vol7dtmp%dativarattr%r%btable)
1660  inddatiattr = firsttrue(var_tmp == vol7dtmp%datiattr%r)
1661  ier=idba_enq(this%handle,starbtable,&
1662  vol7dtmp%voldatiattrr(indana,indtime,indlevel,indtimerange,&
1663  inddativarattr,indnetwork,inddatiattr))
1664  end if
1665  if(attrkind(iii) == "i") then
1666  inddativarattr = firsttrue(buffer(i)%btable == vol7dtmp%dativarattr%i%btable)
1667  inddatiattr = firsttrue(var_tmp == vol7dtmp%datiattr%i)
1668  ier=idba_enq(this%handle,starbtable,&
1669  vol7dtmp%voldatiattri(indana,indtime,indlevel,indtimerange,&
1670  inddativarattr,indnetwork,inddatiattr))
1671  end if
1672  if(attrkind(iii) == "b") then
1673  inddativarattr = firsttrue(buffer(i)%btable == vol7dtmp%dativarattr%b%btable)
1674  inddatiattr = firsttrue(var_tmp == vol7dtmp%datiattr%b)
1675  !print *,"indici voldatiattr ",indana,indtime,indlevel,indtimerange,&
1676  !inddativarattr,indnetwork,inddatiattr
1677  ier=idba_enq(this%handle,starbtable,&
1678  vol7dtmp%voldatiattrb(indana,indtime,indlevel,indtimerange,&
1679  inddativarattr,indnetwork,inddatiattr))
1680  end if
1681  if(attrkind(iii) == "d") then
1682  inddativarattr = firsttrue(buffer(i)%btable == vol7dtmp%dativarattr%d%btable)
1683  inddatiattr = firsttrue(var_tmp == vol7dtmp%datiattr%d)
1684  ier=idba_enq(this%handle,starbtable,&
1685  vol7dtmp%voldatiattrd(indana,indtime,indlevel,indtimerange,&
1686  inddativarattr,indnetwork,inddatiattr))
1687  end if
1688  if(attrkind(iii) == "c") then
1689  inddativarattr = firsttrue(buffer(i)%btable == vol7dtmp%dativarattr%c%btable)
1690  inddatiattr = firsttrue(var_tmp == vol7dtmp%datiattr%c)
1691  ier=idba_enq(this%handle,starbtable,&
1692  vol7dtmp%voldatiattrc(indana,indtime,indlevel,indtimerange,&
1693  inddativarattr,indnetwork,inddatiattr))
1694  end if
1695  end if
1696  else
1697 
1698  inddativarattr = firsttrue(buffer(i)%btable == vol7dtmp%dativarattr%c%btable)
1699  inddatiattr = firsttrue(var_tmp == vol7dtmp%datiattr%c)
1700  ier=idba_enq(this%handle,starbtable,&
1701  vol7dtmp%voldatiattrc(indana,indtime,indlevel,indtimerange,&
1702  inddativarattr,indnetwork,inddatiattr)) !char is default
1703  !print*,starbtable,vol7dtmp%voldatiattrc(indana,indtime,indlevel,indtimerange,&
1704  ! inddativarattr,indnetwork,inddatiattr)
1705  end if
1706 
1707  end do
1708  end if
1709 
1710 !( voldati*(nana,ntime,nlevel,ntimerange,ndativar*,nnetwork)
1711 ! voldatiattr*(nana,ntime,nlevel,ntimerange,ndativarattr*,network,ndatiattr*) )
1712 
1713  end do
1714 
1715 !------------------------- anagrafica
1716 
1717 
1718 if (lanaattr)then
1719  ! creo la stringa con l'elenco variabili attributi di anagrafica
1720  starvarlist = ''
1721  nanavarattr=0
1722  DO ii = 1, SIZE(anaattr)
1723  nanavarattr = nanavarattr + 1
1724  IF (nanavarattr > 1) starvarlist(len_trim(starvarlist)+1:) = ','
1725  starvarlist(len_trim(starvarlist)+1:) = trim(anaattr(ii))
1726  ENDDO
1727  !print *,"starvarlist",starvarlist
1728 end if
1729 
1730 
1731 do i =1, n_ana
1732 
1733  indana = firsttrue(bufferana(i)%ana == vol7dtmp%ana)
1734 
1735  if (ldegnet)then
1736  indnetwork=1
1737  else
1738  indnetwork = firsttrue(bufferana(i)%network == vol7dtmp%network)
1739  endif
1740 
1741  if (indana < 1 .or. indnetwork < 1 )cycle
1742 
1743  !print *, indana,indtime,indlevel,indtimerange,indnetwork
1744 
1745  if(c_e(bufferana(i)%dator))then
1746  indanavar = firsttrue(bufferana(i)%btable == vol7dtmp%anavar%r%btable)
1747  vol7dtmp%volanar( indana,indanavar,indnetwork ) = bufferana(i)%dator
1748  end if
1749  if(c_e(bufferana(i)%datoi))then
1750  indanavar = firsttrue(bufferana(i)%btable == vol7dtmp%anavar%i%btable)
1751  vol7dtmp%volanai( indana,indanavar,indnetwork ) = bufferana(i)%datoi
1752  end if
1753  if(c_e(bufferana(i)%datob))then
1754  indanavar = firsttrue(bufferana(i)%btable == vol7dtmp%anavar%b%btable)
1755  vol7dtmp%volanab( indana,indanavar,indnetwork ) = bufferana(i)%datob
1756  end if
1757  if(c_e(bufferana(i)%datod))then
1758  indanavar = firsttrue(bufferana(i)%btable == vol7dtmp%anavar%d%btable)
1759  vol7dtmp%volanad( indana,indanavar,indnetwork ) = bufferana(i)%datod
1760  end if
1761  if(c_e(bufferana(i)%datoc))then
1762  indanavar = firsttrue(bufferana(i)%btable == vol7dtmp%anavar%c%btable)
1763  vol7dtmp%volanac( indana,indanavar,indnetwork ) = bufferana(i)%datoc
1764  end if
1765 
1766 
1767  if (lanaattr)then
1768 
1769 #ifdef DEBUG
1770  CALL l4f_category_log(this%category,l4f_debug,'unsetall handle_staz')
1771 #endif
1772  ier=idba_unsetall(this%handle_staz)
1773  ier=idba_set(this%handle_staz,"*context_id",bufferana(i)%data_id)
1774  ier=idba_set(this%handle_staz,"*var_related",bufferana(i)%btable)
1775 
1776  !per ogni dato ora lavoro sugli attributi
1777  ier=idba_set(this%handle_staz, "*varlist",starvarlist )
1778  ier=idba_voglioancora(this%handle_staz,nn)
1779  !print*,buffer(i)%dativar%btable," numero attributi",nn
1780 
1781  do ii=1,nn ! Se ho piu` di 1 attributo devo forse trovare l'indice (ii)
1782  ier=idba_ancora(this%handle_staz,starbtable)
1783  !print *, starbtable
1784  indattr = firsttrue(anaattr == starbtable)
1785  IF (indattr<1) cycle ! non c'e'
1786 
1787 
1788  call init (var_tmp, btable=starbtable)
1789 
1790 
1791  if (present(anaattrkind))then
1792  iii=( firsttrue(anaattr == starbtable))
1793  !print *,"ho letto indice attributo ",starbtable,iii
1794  if (iii > 0)then
1795 
1796  if(anaattrkind(iii) == "r") then
1797  indanavarattr = firsttrue(bufferana(i)%btable == vol7dtmp%anavarattr%r%btable)
1798  indanaattr = firsttrue(var_tmp == vol7dtmp%anaattr%r)
1799  ier=idba_enq(this%handle_staz,starbtable,&
1800  vol7dtmp%volanaattrr(indana,indanavarattr,indnetwork,indanaattr))
1801  end if
1802  if(anaattrkind(iii) == "i") then
1803  indanavarattr = firsttrue(bufferana(i)%btable == vol7dtmp%anavarattr%i%btable)
1804  indanaattr = firsttrue(var_tmp == vol7dtmp%anaattr%i)
1805  ier=idba_enq(this%handle_staz,starbtable,&
1806  vol7dtmp%volanaattri(indana,indanavarattr,indnetwork,indanaattr))
1807  end if
1808  if(anaattrkind(iii) == "b") then
1809  indanavarattr = firsttrue(bufferana(i)%btable == vol7dtmp%anavarattr%b%btable)
1810  indanaattr = firsttrue(var_tmp == vol7dtmp%anaattr%b)
1811  ier=idba_enq(this%handle_staz,starbtable,&
1812  vol7dtmp%volanaattrb(indana,indanavarattr,indnetwork,indanaattr))
1813  end if
1814  if(anaattrkind(iii) == "d") then
1815  indanavarattr = firsttrue(bufferana(i)%btable == vol7dtmp%anavarattr%d%btable)
1816  indanaattr = firsttrue(var_tmp == vol7dtmp%anaattr%d)
1817  ier=idba_enq(this%handle_staz,starbtable,&
1818  vol7dtmp%volanaattrd(indana,indanavarattr,indnetwork,indanaattr))
1819  end if
1820  if(anaattrkind(iii) == "c") then
1821  indanavarattr = firsttrue(bufferana(i)%btable == vol7dtmp%anavarattr%c%btable)
1822  indanaattr = firsttrue(var_tmp == vol7dtmp%anaattr%c)
1823  ier=idba_enq(this%handle_staz,starbtable,&
1824  vol7dtmp%volanaattrc(indana,indanavarattr,indnetwork,indanaattr))
1825  end if
1826 
1827  end if
1828  else
1829  indanavarattr = firsttrue(bufferana(i)%btable == vol7dtmp%anavarattr%c%btable)
1830  indanaattr = firsttrue(var_tmp == vol7dtmp%anaattr%c)
1831  ier=idba_enq(this%handle,starbtable,&
1832  vol7dtmp%volanaattrc(indana,indanavarattr,indnetwork,indanaattr)) !char is default
1833  end if
1834 
1835  end do
1836  end if
1837 
1838  end do
1839 
1840 !------------------------- anagrafica fine
1841 
1842 deallocate (buffer)
1843 deallocate (bufferana)
1844 
1845 ! Smart merge
1846 CALL vol7d_merge(this%vol7d, vol7dtmp, sort=.true.)
1847 ! should we sort separately in case no merge is done?
1848 !CALL vol7d_smart_sort(this%vol7d, ltime=.TRUE., ltimerange=.TRUE., llevel=.TRUE,)
1849 
1850 call vol7d_set_attr_ind(this%vol7d)
1851 
1852 call vol7d_dballe_set_var_du(this%vol7d)
1853 
1854 !print *,"R-R",this%vol7d%dativar%r(:)%r
1855 !print *,"R-I",this%vol7d%dativar%r(:)%i
1856 !print *,"R-B",this%vol7d%dativar%r(:)%b
1857 !print *,"R-D",this%vol7d%dativar%r(:)%d
1858 !print *,"R-C",this%vol7d%dativar%r(:)%c
1859 
1860 !print *,"I-R",this%vol7d%dativar%i(:)%r
1861 !print *,"I-I",this%vol7d%dativar%i(:)%i
1862 !print *,"I-B",this%vol7d%dativar%i(:)%b
1863 !print *,"I-D",this%vol7d%dativar%i(:)%d
1864 !print *,"I-C",this%vol7d%dativar%i(:)%c
1865 
1866 deallocate(lvar,lanavar)
1867 
1868 
1869 END SUBROUTINE vol7d_dballe_importvvns_dba
1870 
1871 
1880 SUBROUTINE vol7d_dballe_export(this, network, coordmin, coordmax,&
1881  timei, timef,level,timerange,var,attr,anavar,anaattr,attr_only,template,ana)
1882 
1883 TYPE(vol7d_dballe),INTENT(inout) :: this
1884 character(len=network_name_len),INTENT(in),optional :: network
1887 TYPE(geo_coord),INTENT(in),optional :: coordmin,coordmax
1888 TYPE(vol7d_ana),INTENT(inout),optional :: ana
1890 TYPE(datetime),INTENT(in),optional :: timei, timef
1891 TYPE(vol7d_level),INTENT(in),optional :: level
1892 TYPE(vol7d_timerange),INTENT(in),optional :: timerange
1895 CHARACTER(len=*),INTENT(in),OPTIONAL :: var(:),attr(:),anavar(:),anaattr(:)
1899 logical,intent(in),optional :: attr_only
1902 character(len=*),intent(in),optional :: template
1903 
1904 !!$ Conversazioni con spanezz@jabber.linux.it su gio 27 mag 2010 09:38:52 CEST:
1905 !!$ (09:39:00) pat1@jabber.linux.it/Home:
1906 !!$ ho una domanda
1907 !!$ scrivo dei bufr generici
1908 !!$ quando setto query a "message" viene chiuso un bufr
1909 !!$ posso scrive migliaia di cose senza mai mettere query a message
1910 !!$ il bufr viene piu' piccolo
1911 !!$ quindi nel generico mi conviene scrivere dopo un sensato uso di memoria ?
1912 !!$ (09:41:54) spanezz@jabber.linux.it:
1913 !!$ dipende da cosa vuoi mettere nel messaggio
1914 !!$ (09:42:21) spanezz@jabber.linux.it:
1915 !!$ puoi salvare tutto in un unico genericone se vuoi
1916 !!$ poi se lo archivi quando queri queri sempre tutto
1917 !!$ (09:42:40) pat1@jabber.linux.it/Home:
1918 !!$ nel caso sto scrivendo un volume v7d di dati
1919 !!$ posso farne solo un bufr oppure migliaia
1920 !!$ (09:48:14) spanezz@jabber.linux.it:
1921 !!$ se non scrivi generici lui mette nel messaggio solo quello che ci sta nel template, ovviamente
1922 !!$ quindi ci sono solo un certo numero di dati che puoi settare e finiscono nell'output
1923 !!$ (09:49:38) pat1@jabber.linux.it/Home:
1924 !!$ quindi ad esempio se scrivo generici e cambio stazione me ne POSSO fregare e mettere un solo "query=message"
1925 !!$ alla fine di tutto
1926 !!$ ma se scrivo synop e faccio lo stesso scrivo solo l'ultima stazione ?
1927 !!$ (09:50:04) spanezz@jabber.linux.it:
1928 !!$ ni
1929 !!$ (09:51:41) spanezz@jabber.linux.it:
1930 !!$ la roba in cui scrivi temporaneamente i dati non รจ una versione in memoria di dballe (del DB di dballe intendo)
1931 !!$ in particolare, una un unico livello di anagrafica in cui ci sta una stazione e un'orario solo
1932 !!$ in particolare, ha un unico livello di anagrafica in cui ci sta una stazione e un'orario solo
1933 !!$ quindi se metti due stazioni, sovrascrivi la seconda
1934 !!$ รจ indicizzato per (livello, scadenza, codice variabile)
1935 !!$ se fai due prendilo con gli stessi (livello, scadenza, codice variabile), la seconda sovrascrive la prima
1936 !!$ e data ora stazione report vanno nel (livello, scadenza) di "anagrafica" (257,0, 0,0, 0,0,0)
1937 !!$ (09:56:43) pat1@jabber.linux.it/Home:
1938 !!$ quindi per scrivere N^N roba
1939 !!$ devo ciclare su (livello, scadenza, codice variabile) e ogni volta fare una prendilo
1940 !!$ poi all'esterno devo ciclare su tutto il resto e fare una prendilo con query="message"
1941 
1942 !REAL(kind=fp_geo) :: latmin,latmax,lonmin,lonmax
1943 logical, allocatable :: lnetwork(:),llevel(:),ltimerange(:)
1944 integer,allocatable :: ana_id(:,:)
1945 logical :: write,writeattr,lattr_only, generic_frag
1946 character(len=80) :: ltemplate
1947 
1948 !CHARACTER(len=6) :: btable
1949 !CHARACTER(len=7) ::starbtable
1950 
1951 integer :: year,month,day,hour,minute,sec,msec
1952 integer :: nstaz,ntime,ntimerange,nlevel,nnetwork
1953 
1954 
1955 INTEGER :: i,ii,iii,iiii,iiiii,iiiiii,a,ind,inddatiattr,indanaattr,ier
1956 
1957 INTEGER(kind=int_l) :: ilat,ilon
1958 !INTEGER(kind=int_b)::attrdatib
1959 
1960 
1961 integer :: ndativarr,ndatiattrr
1962 integer :: ndativari,ndatiattri
1963 integer :: ndativarb,ndatiattrb
1964 integer :: ndativard,ndatiattrd
1965 integer :: ndativarc,ndatiattrc
1966 
1967 integer :: nanavarr,nanaattrr
1968 integer :: nanavari,nanaattri
1969 integer :: nanavarb,nanaattrb
1970 integer :: nanavard,nanaattrd
1971 integer :: nanavarc,nanaattrc
1972 
1973 logical, allocatable :: lvarr(:),lattrr(:)
1974 logical, allocatable :: lvari(:),lattri(:)
1975 logical, allocatable :: lvarb(:),lattrb(:)
1976 logical, allocatable :: lvard(:),lattrd(:)
1977 logical, allocatable :: lvarc(:),lattrc(:)
1978 
1979 logical, allocatable :: lanavarr(:),lanaattrr(:)
1980 logical, allocatable :: lanavari(:),lanaattri(:)
1981 logical, allocatable :: lanavarb(:),lanaattrb(:)
1982 logical, allocatable :: lanavard(:),lanaattrd(:)
1983 logical, allocatable :: lanavarc(:),lanaattrc(:)
1984 
1985 
1986 ndativarr=0
1987 ndatiattrr=0
1988 ndativari=0
1989 ndatiattri=0
1990 ndativarb=0
1991 ndatiattrb=0
1992 ndativard=0
1993 ndatiattrd=0
1994 ndativarc=0
1995 ndatiattrc=0
1996 
1997 nanavarr=0
1998 nanaattrr=0
1999 nanavari=0
2000 nanaattri=0
2001 nanavarb=0
2002 nanaattrb=0
2003 nanavard=0
2004 nanaattrd=0
2005 nanavarc=0
2006 nanaattrc=0
2007 
2008 call vol7d_alloc_vol(this%vol7d) ! be safe
2009 nstaz=size(this%vol7d%ana(:))
2010 
2011 ntimerange=size(this%vol7d%timerange(:))
2012 allocate (ltimerange(ntimerange))
2013 ltimerange=.false.
2014 
2015 if (present(timerange))then
2016  where (timerange == this%vol7d%timerange(:))
2017  ltimerange(:)=.true.
2018  end where
2019 else
2020  ltimerange=.true.
2021 end if
2022 
2023 nlevel=size(this%vol7d%level(:))
2024 allocate (llevel(nlevel))
2025 llevel=.false.
2026 
2027 if (present(level))then
2028  where (level == this%vol7d%level(:))
2029  llevel(:)=.true.
2030  end where
2031 else
2032  llevel=.true.
2033 end if
2034 
2035 if (present(attr_only))then
2036  lattr_only=attr_only
2037 else
2038  lattr_only=.false.
2039 end if
2040 
2041 if ( .not. associated(this%data_id))then
2042  lattr_only=.false.
2043 end if
2044 
2045 
2046 nnetwork=size(this%vol7d%network(:))
2047 ntime=size(this%vol7d%time(:))
2048 
2049 allocate (lnetwork(nnetwork))
2050 lnetwork=.false.
2051 allocate (ana_id(nstaz,nnetwork))
2052 ana_id=dba_mvi
2053 
2054 
2055 if (present(network))then
2056  where (network == this%vol7d%network(:)%name)
2057  lnetwork(:)=.true.
2058  end where
2059 else
2060  lnetwork=.true.
2061 end if
2062 
2063 ltemplate=optio_c(template,len(ltemplate))
2064 if (template == "generic-frag") then
2065  ltemplate="generic"
2066  generic_frag=.true.
2067 else
2068  ltemplate=template
2069  generic_frag=.false.
2070 end if
2071 
2072 
2073 
2074 !!!!! anagrafica
2075 
2076 #undef VOL7D_POLY_TYPES_V
2077 #define VOL7D_POLY_TYPES_V r
2078 #ifdef DEBUG
2079 call l4f_category_log(this%category,l4f_debug,"macro nana tipo r")
2080 #endif
2081 #include "vol7d_dballe_class_nana.F90"
2082 #undef VOL7D_POLY_TYPES_V
2083 #define VOL7D_POLY_TYPES_V i
2084 #ifdef DEBUG
2085 call l4f_category_log(this%category,l4f_debug,"macro nana tipo i")
2086 #endif
2087 #include "vol7d_dballe_class_nana.F90"
2088 #undef VOL7D_POLY_TYPES_V
2089 #define VOL7D_POLY_TYPES_V b
2090 #ifdef DEBUG
2091 call l4f_category_log(this%category,l4f_debug,"macro nana tipo b")
2092 #endif
2093 #include "vol7d_dballe_class_nana.F90"
2094 #undef VOL7D_POLY_TYPES_V
2095 #define VOL7D_POLY_TYPES_V d
2096 #ifdef DEBUG
2097 call l4f_category_log(this%category,l4f_debug,"macro nana tipo d")
2098 #endif
2099 #include "vol7d_dballe_class_nana.F90"
2100 #undef VOL7D_POLY_TYPES_V
2101 #define VOL7D_POLY_TYPES_V c
2102 #ifdef DEBUG
2103 call l4f_category_log(this%category,l4f_debug,"macro nana tipo c")
2104 #endif
2105 #include "vol7d_dballe_class_nana.F90"
2106 #undef VOL7D_POLY_TYPES_V
2107 
2108 
2109 !!!!!!! dati
2110 
2111 #undef VOL7D_POLY_TYPES_V
2112 #define VOL7D_POLY_TYPES_V r
2113 #ifdef DEBUG
2114 call l4f_category_log(this%category,l4f_debug,"macro ndati tipo r")
2115 #endif
2116 #include "vol7d_dballe_class_ndati.F90"
2117 #undef VOL7D_POLY_TYPES_V
2118 #define VOL7D_POLY_TYPES_V i
2119 #ifdef DEBUG
2120 call l4f_category_log(this%category,l4f_debug,"macro ndati tipo i")
2121 #endif
2122 #include "vol7d_dballe_class_ndati.F90"
2123 #undef VOL7D_POLY_TYPES_V
2124 #define VOL7D_POLY_TYPES_V b
2125 #ifdef DEBUG
2126 call l4f_category_log(this%category,l4f_debug,"macro ndati tipo b")
2127 #endif
2128 #include "vol7d_dballe_class_ndati.F90"
2129 #undef VOL7D_POLY_TYPES_V
2130 #define VOL7D_POLY_TYPES_V d
2131 #ifdef DEBUG
2132 call l4f_category_log(this%category,l4f_debug,"macro ndati tipo d")
2133 #endif
2134 #include "vol7d_dballe_class_ndati.F90"
2135 #undef VOL7D_POLY_TYPES_V
2136 #define VOL7D_POLY_TYPES_V c
2137 #ifdef DEBUG
2138 call l4f_category_log(this%category,l4f_debug,"macro ndati tipo c")
2139 #endif
2140 #include "vol7d_dballe_class_ndati.F90"
2141 #undef VOL7D_POLY_TYPES_V
2142 
2143 
2144 ! vital statistics data
2145 
2146 !print *,"nstaz,ntime,nlevel,ntimerange,nnetwork",nstaz,ntime,nlevel,ntimerange,nnetwork
2147 
2148 do iiiiii=1, nnetwork
2149  if (.not.lnetwork(iiiiii))cycle
2150 
2151 ! l'anagrafica su file la scrivo solo per i generici_frag or for ana_only datasets
2152  if (this%file .and. .not. generic_frag .and. ntime > 0 ) cycle
2153 
2154  do i=1, nstaz
2155 
2156  if (present(coordmin).and.present(coordmax))then
2157  if (.not. inside(this%vol7d%ana(i)%coord,coordmin,coordmax)) cycle
2158  end if
2159 
2160  CALL getval(this%vol7d%ana(i)%coord, ilat=ilat,ilon=ilon)
2161  ier=idba_unsetall(this%handle)
2162 #ifdef DEBUG
2163  CALL l4f_category_log(this%category,l4f_debug,'unsetall handle')
2164 #endif
2165  ier=idba_setcontextana(this%handle)
2166 
2167  ier=idba_set(this%handle,"lat",ilat)
2168  ier=idba_set(this%handle,"lon",ilon)
2169 
2170  if (present(ana))then
2171  if (c_e(ana%ident) .and. ana%ident /= this%vol7d%ana(i)%ident ) cycle
2172  if (c_e(ana%coord) .and. ana%coord /= this%vol7d%ana(i)%coord ) cycle
2173  end if
2174 
2175 ! this%vol7d%ana(i)%ident=cmiss
2176 
2177 !!$ print*,"ident",this%vol7d%ana(i)%ident
2178 !!$ do ier=1,len(this%vol7d%ana(i)%ident)
2179 !!$ print *,iachar(this%vol7d%ana(i)%ident(ier:ier))
2180 !!$ end do
2181 
2182  if ( c_e(this%vol7d%ana(i)%ident)) then
2183 #ifdef DEBUG
2184  call l4f_category_log(this%category,l4f_debug,"I have found a mobile station! ident: "//&
2185  this%vol7d%ana(i)%ident)
2186 #endif
2187  ier=idba_set(this%handle,"ident",this%vol7d%ana(i)%ident)
2188  ier=idba_set(this%handle,"mobile",1)
2189  else
2190  ier=idba_set(this%handle,"mobile",0)
2191  end if
2192 
2193  ier=idba_set(this%handle,"rep_memo",this%vol7d%network(iiiiii)%name)
2194 
2195  write=.false.
2196 
2197 #undef VOL7D_POLY_TYPES_V
2198 #define VOL7D_POLY_TYPES_V r
2199 !print*,"ana macro tipo r"
2200 #include "vol7d_dballe_class_ana.F90"
2201 #undef VOL7D_POLY_TYPES_V
2202 #define VOL7D_POLY_TYPES_V i
2203 !print*,"ana macro tipo i"
2204 #include "vol7d_dballe_class_ana.F90"
2205 #undef VOL7D_POLY_TYPES_V
2206 #define VOL7D_POLY_TYPES_V b
2207 !print*,"ana macro tipo b"
2208 #include "vol7d_dballe_class_ana.F90"
2209 #undef VOL7D_POLY_TYPES_V
2210 #define VOL7D_POLY_TYPES_V d
2211 !print*,"ana macro tipo d"
2212 #include "vol7d_dballe_class_ana.F90"
2213 #undef VOL7D_POLY_TYPES_V
2214 #define VOL7D_POLY_TYPES_V c
2215 !print*,"ana macro tipo c"
2216 #include "vol7d_dballe_class_ana.F90"
2217 #undef VOL7D_POLY_TYPES_V
2218 
2219 
2220  if (this%file)then
2221  if (write .or. generic_frag) then
2222 
2223  if (c_e(ltemplate)) then
2224  ier=idba_set(this%handle,"query","message "//trim(ltemplate))
2225  else
2226  ier=idba_set(this%handle,"query","message")
2227  end if
2228 
2229 #ifdef DEBUG
2230  call l4f_category_log(this%category,l4f_debug,"eseguo una main prendilo di anagrafica")
2231 #endif
2232  ier=idba_prendilo(this%handle)
2233  end if
2234 
2235  else
2236 
2237  !se NON ho dati di anagrafica (ma solo lat e long ..) devo fare comunque una prendilo
2238 #ifdef DEBUG
2239  call l4f_category_log(this%category,l4f_debug,"eseguo una main prendilo di anagrafica")
2240 #endif
2241  ier=idba_prendilo(this%handle)
2242  ier=idba_enq(this%handle,"*ana_id",ana_id(i,iiiiii))
2243 
2244  end if
2245 
2246  do ii=1,nanavarr
2247  if (c_e(this%vol7d%anavar%r(ii)%btable))ier=idba_unset(this%handle,this%vol7d%anavar%r(ii)%btable )
2248 #ifdef DEBUG
2249  call l4f_category_log(this%category,l4f_debug,"unset ana: "//this%vol7d%anavar%r(ii)%btable)
2250 #endif
2251  end do
2252  do ii=1,nanavari
2253  if (c_e(this%vol7d%anavar%i(ii)%btable))ier=idba_unset(this%handle,this%vol7d%anavar%i(ii)%btable )
2254 #ifdef DEBUG
2255  call l4f_category_log(this%category,l4f_debug,"unset ana: "//this%vol7d%anavar%i(ii)%btable)
2256 #endif
2257  end do
2258  do ii=1,nanavarb
2259  if (c_e(this%vol7d%anavar%b(ii)%btable))ier=idba_unset(this%handle,this%vol7d%anavar%b(ii)%btable )
2260 #ifdef DEBUG
2261  call l4f_category_log(this%category,l4f_debug,"unset ana: "//this%vol7d%anavar%b(ii)%btable)
2262 #endif
2263  end do
2264  do ii=1,nanavard
2265  if (c_e(this%vol7d%anavar%d(ii)%btable))ier=idba_unset(this%handle,this%vol7d%anavar%d(ii)%btable )
2266 #ifdef DEBUG
2267  call l4f_category_log(this%category,l4f_debug,"unset ana: "//this%vol7d%anavar%d(ii)%btable)
2268 #endif
2269  end do
2270  do ii=1,nanavarc
2271  if (c_e(this%vol7d%anavar%c(ii)%btable))ier=idba_unset(this%handle,this%vol7d%anavar%c(ii)%btable )
2272 #ifdef DEBUG
2273  call l4f_category_log(this%category,l4f_debug,"unset ana: "//this%vol7d%anavar%c(ii)%btable)
2274 #endif
2275  end do
2276 
2277  end do
2278 end do
2279 
2280 
2281 ! data
2282 !print *,"nstaz,ntime,nlevel,ntimerange,nnetwork",nstaz,ntime,nlevel,ntimerange,nnetwork
2283 
2284 
2285 do iiiiii=1, nnetwork
2286  if (.not.lnetwork(iiiiii))cycle
2287 
2288  do i=1, nstaz
2289 
2290  if ( (.not. this%file) .and. (.not. c_e(ana_id(i,iiiiii))) ) cycle
2291  if (present(coordmin).and.present(coordmax))then
2292  if (.not. inside(this%vol7d%ana(i)%coord,coordmin,coordmax)) cycle
2293  end if
2294 
2295  do ii=1,ntime
2296  if (present(timei) )then
2297  if ( this%vol7d%time(ii) < timei ) cycle
2298  endif
2299  if (present(timef) )then
2300  if ( this%vol7d%time(ii) > timef ) cycle
2301  endif
2303 
2304  ier=idba_unsetall(this%handle)
2305 #ifdef DEBUG
2306  CALL l4f_category_log(this%category,l4f_debug,'unsetall handle')
2307 #endif
2308 
2309  ier=idba_set(this%handle,"rep_memo",this%vol7d%network(iiiiii)%name)
2310 #ifdef DEBUG
2311  CALL l4f_category_log(this%category,l4f_debug,'set rep_memo:'//this%vol7d%network(iiiiii)%name)
2312 #endif
2313 
2314  if (this%file)then
2315  ! writing on file cannot use ana_id
2316  call getval(this%vol7d%ana(i)%coord, ilat=ilat,ilon=ilon)
2317  ier=idba_set(this%handle,"lat",ilat)
2318  ier=idba_set(this%handle,"lon",ilon)
2319 #ifdef DEBUG
2320  call l4f_category_log(this%category,l4f_debug,"dati riferiti a lat: "//to_char(ilat)//" lon: "//to_char(ilon))
2321 #endif
2322 
2323  if (present(ana))then
2324  if (c_e(ana%ident) .and. ana%ident /= this%vol7d%ana(i)%ident ) cycle
2325  if (c_e(ana%coord) .and. ana%coord /= this%vol7d%ana(i)%coord ) cycle
2326  end if
2327 
2328  if ( c_e(this%vol7d%ana(i)%ident)) then
2329  ier=idba_set(this%handle,"ident",this%vol7d%ana(i)%ident)
2330  ier=idba_set(this%handle,"mobile",1)
2331 #ifdef DEBUG
2332  call l4f_category_log(this%category,l4f_debug,"there is a mobile station! identity: "&
2333  //this%vol7d%ana(i)%ident)
2334 #endif
2335  else
2336  ier=idba_set(this%handle,"mobile",0)
2337  end if
2338 
2339 
2340 ! l'anagrafica su file la scrivo solo per i non generici_frag
2341  if (.not. generic_frag) then
2342 
2343 #ifdef DEBUG
2344  call l4f_category_log(this%category,l4f_debug,"setcontextana")
2345 #endif
2346  ier=idba_setcontextana(this%handle)
2347 
2348  write=.false.
2349 
2350 #undef VOL7D_POLY_TYPES_V
2351 #define VOL7D_POLY_TYPES_V r
2352 !print*,"ana macro tipo r"
2353 #include "vol7d_dballe_class_ana.F90"
2354 #undef VOL7D_POLY_TYPES_V
2355 #define VOL7D_POLY_TYPES_V i
2356 !print*,"ana macro tipo i"
2357 #include "vol7d_dballe_class_ana.F90"
2358 #undef VOL7D_POLY_TYPES_V
2359 #define VOL7D_POLY_TYPES_V b
2360 !print*,"ana macro tipo b"
2361 #include "vol7d_dballe_class_ana.F90"
2362 #undef VOL7D_POLY_TYPES_V
2363 #define VOL7D_POLY_TYPES_V d
2364 !print*,"ana macro tipo d"
2365 #include "vol7d_dballe_class_ana.F90"
2366 #undef VOL7D_POLY_TYPES_V
2367 #define VOL7D_POLY_TYPES_V c
2368 !print*,"ana macro tipo c"
2369 #include "vol7d_dballe_class_ana.F90"
2370 #undef VOL7D_POLY_TYPES_V
2371 
2372 
2373  if (write) then
2374 #ifdef DEBUG
2375  call l4f_category_log(this%category,l4f_debug,"eseguo una main prendilo di anagrafica")
2376 #endif
2377  ier=idba_prendilo(this%handle)
2378  end if
2379 
2380  end if
2381  else
2382 #ifdef DEBUG
2383  call l4f_category_log(this%category,l4f_debug,"specify ana_id: "&
2384  //to_char(ana_id(i,iiiiii)))
2385 #endif
2386  ier=idba_set(this%handle,"ana_id",ana_id(i,iiiiii))
2387  end if
2388 
2389  CALL getval(this%vol7d%time(ii), year=year, month=month, day=day, hour=hour, minute=minute,msec=msec)
2390  sec=nint(float(msec)/1000.)
2391 #ifdef DEBUG
2392  call l4f_category_log(this%category,l4f_debug,"setdate: "&
2393  //t2c(year)//t2c(month)//t2c(day)//t2c(hour)//t2c(minute)//t2c(sec))
2394 #endif
2395  ier=idba_setdate(this%handle,year,month,day,hour,minute,sec)
2396 
2397  do iii=1,nlevel
2398  if (.not.llevel(iii))cycle
2399 
2400  do iiii=1,ntimerange
2401  if (.not.ltimerange(iiii))cycle
2402 
2403  if (.not. lattr_only) then
2404 
2405 
2406  ier=idba_setlevel(this%handle, this%vol7d%level(iii)%level1, this%vol7d%level(iii)%l1,&
2407  this%vol7d%level(iii)%level2, this%vol7d%level(iii)%l2)
2408 
2409 #ifdef DEBUG
2410  call l4f_category_log(this%category,l4f_debug,"level1: "//to_char(this%vol7d%level(iii)%level1))
2411  call l4f_category_log(this%category,l4f_debug,"l1: "//to_char(this%vol7d%level(iii)%l1))
2412  call l4f_category_log(this%category,l4f_debug,"level2: "//to_char(this%vol7d%level(iii)%level2))
2413  call l4f_category_log(this%category,l4f_debug,"l2: "//to_char(this%vol7d%level(iii)%l2))
2414 #endif
2415 
2416  ier=idba_settimerange(this%handle, this%vol7d%timerange(iiii)%timerange, &
2417  this%vol7d%timerange(iiii)%p1, this%vol7d%timerange(iiii)%p2)
2418 
2419 #ifdef DEBUG
2420  call l4f_category_log(this%category,l4f_debug,"timerange: "//to_char(this%vol7d%timerange(iiii)%timerange))
2421  call l4f_category_log(this%category,l4f_debug,"T1: "//to_char(this%vol7d%timerange(iiii)%p1))
2422  call l4f_category_log(this%category,l4f_debug,"T2: "//to_char(this%vol7d%timerange(iiii)%p2))
2423 #endif
2424 
2425  end if
2426 
2427  !print *, ">>>>> ",ana_id(i,iiiiii),this%vol7d%network(iiiiii)%name
2428  !print *, year,month,day,hour,minute
2429  !print *, this%vol7d%level(iii)%level1, this%vol7d%level(iii)%l1, this%vol7d%level(iii)%l2
2430  !print *, this%vol7d%timerange(iiii)%timerange,this%vol7d%timerange(iiii)%p1, this%vol7d%timerange(iiii)%p2
2431 
2432 
2433  write=.false.
2434 
2435 #undef VOL7D_POLY_TYPES_V
2436 #define VOL7D_POLY_TYPES_V r
2437 #ifdef DEBUG
2438  call l4f_category_log(this%category,l4f_debug,"macro tipo r")
2439 #endif
2440 #include "vol7d_dballe_class_dati.F90"
2441 #undef VOL7D_POLY_TYPES_V
2442 #define VOL7D_POLY_TYPES_V i
2443 #ifdef DEBUG
2444  call l4f_category_log(this%category,l4f_debug,"macro tipo i")
2445 #endif
2446 #include "vol7d_dballe_class_dati.F90"
2447 #undef VOL7D_POLY_TYPES_V
2448 #define VOL7D_POLY_TYPES_V b
2449 #ifdef DEBUG
2450  call l4f_category_log(this%category,l4f_debug,"macro tipo b")
2451 #endif
2452 #include "vol7d_dballe_class_dati.F90"
2453 #undef VOL7D_POLY_TYPES_V
2454 #define VOL7D_POLY_TYPES_V d
2455 #ifdef DEBUG
2456  call l4f_category_log(this%category,l4f_debug,"macro tipo d")
2457 #endif
2458 #include "vol7d_dballe_class_dati.F90"
2459 #undef VOL7D_POLY_TYPES_V
2460 #define VOL7D_POLY_TYPES_V c
2461 #ifdef DEBUG
2462  call l4f_category_log(this%category,l4f_debug,"macro tipo c")
2463 #endif
2464 #include "vol7d_dballe_class_dati.F90"
2465 #undef VOL7D_POLY_TYPES_V
2466 
2467 
2468  if (write) then
2469 
2470 ! if (.not. this%file)then
2471 !
2472 ! !!!!!!!!!!! workaround to dballe fortran api bug
2473 ! ! TODO remove this duplicated set of ana_id
2474 !#ifdef DEBUG
2475 ! call l4f_category_log(this%category,L4F_DEBUG,"rispecify ana_id: "&
2476 ! //to_char(ana_id(i,iiiiii)))
2477 !#endif
2478 ! ier=idba_set (this%handle,"ana_id",ana_id(i,iiiiii))
2479 ! end if
2480 
2481  !print*,"eseguo una main prendilo"
2482 #ifdef DEBUG
2483  call l4f_category_log(this%category,l4f_debug,"eseguo una main prendilo sui dati")
2484 #endif
2485  ier=idba_prendilo(this%handle)
2486 
2487  end if
2488 
2489 
2490 !ana
2491 
2492  if (this%file .and. .not. generic_frag) then
2493 
2494  do a=1,nanavarr
2495  if (c_e(this%vol7d%anavar%r(a)%btable))ier=idba_unset(this%handle,this%vol7d%anavar%r(a)%btable )
2496 #ifdef DEBUG
2497  call l4f_category_log(this%category,l4f_debug,"unset ana: "//this%vol7d%anavar%r(a)%btable)
2498 #endif
2499  end do
2500  do a=1,nanavari
2501  if (c_e(this%vol7d%anavar%i(a)%btable))ier=idba_unset(this%handle,this%vol7d%anavar%i(a)%btable )
2502 #ifdef DEBUG
2503  call l4f_category_log(this%category,l4f_debug,"unset ana: "//this%vol7d%anavar%i(a)%btable)
2504 #endif
2505  end do
2506  do a=1,nanavarb
2507  if (c_e(this%vol7d%anavar%b(a)%btable))ier=idba_unset(this%handle,this%vol7d%anavar%b(a)%btable )
2508 #ifdef DEBUG
2509  call l4f_category_log(this%category,l4f_debug,"unset ana: "//this%vol7d%anavar%b(a)%btable)
2510 #endif
2511  end do
2512  do a=1,nanavard
2513  if (c_e(this%vol7d%anavar%d(a)%btable))ier=idba_unset(this%handle,this%vol7d%anavar%d(a)%btable )
2514 #ifdef DEBUG
2515  call l4f_category_log(this%category,l4f_debug,"unset ana: "//this%vol7d%anavar%d(a)%btable)
2516 #endif
2517  end do
2518  do a=1,nanavarc
2519  if (c_e(this%vol7d%anavar%c(a)%btable))ier=idba_unset(this%handle,this%vol7d%anavar%c(a)%btable )
2520 #ifdef DEBUG
2521  call l4f_category_log(this%category,l4f_debug,"unset ana: "//this%vol7d%anavar%c(a)%btable)
2522 #endif
2523  end do
2524 
2525  end if
2526 
2527 ! data
2528 
2529  do iiiii=1,ndativarr
2530  if(c_e(this%vol7d%dativar%r(iiiii)%btable))ier=idba_unset(this%handle,this%vol7d%dativar%r(iiiii)%btable )
2531 #ifdef DEBUG
2532  call l4f_category_log(this%category,l4f_debug,"unset dati: "//this%vol7d%dativar%r(iiiii)%btable)
2533 #endif
2534  end do
2535  do iiiii=1,ndativari
2536  if(c_e(this%vol7d%dativar%i(iiiii)%btable))ier=idba_unset(this%handle,this%vol7d%dativar%i(iiiii)%btable )
2537 #ifdef DEBUG
2538  call l4f_category_log(this%category,l4f_debug,"unset dati: "//this%vol7d%dativar%i(iiiii)%btable)
2539 #endif
2540  end do
2541  do iiiii=1,ndativarb
2542  if(c_e(this%vol7d%dativar%b(iiiii)%btable))ier=idba_unset(this%handle,this%vol7d%dativar%b(iiiii)%btable )
2543 #ifdef DEBUG
2544  call l4f_category_log(this%category,l4f_debug,"unset dati: "//this%vol7d%dativar%b(iiiii)%btable)
2545 #endif
2546  end do
2547  do iiiii=1,ndativard
2548  if(c_e(this%vol7d%dativar%d(iiiii)%btable))ier=idba_unset(this%handle,this%vol7d%dativar%d(iiiii)%btable )
2549 #ifdef DEBUG
2550  call l4f_category_log(this%category,l4f_debug,"unset dati: "//this%vol7d%dativar%d(iiiii)%btable)
2551 #endif
2552  end do
2553  do iiiii=1,ndativarc
2554  if(c_e(this%vol7d%dativar%c(iiiii)%btable))ier=idba_unset(this%handle,this%vol7d%dativar%c(iiiii)%btable )
2555 #ifdef DEBUG
2556  call l4f_category_log(this%category,l4f_debug,"unset dati: "//this%vol7d%dativar%c(iiiii)%btable)
2557 #endif
2558  end do
2559 
2560 
2561  end do
2562  end do
2563 
2564  if (this%file)then
2565  if (c_e(ltemplate)) then
2566  ier=idba_set(this%handle,"query","message "//trim(ltemplate))
2567  else
2568  ier=idba_set(this%handle,"query","message")
2569  end if
2570 #ifdef DEBUG
2571  call l4f_category_log(this%category,l4f_debug,"close message ")
2572 
2573  !print*,"eseguo una main prendilo"
2574  call l4f_category_log(this%category,l4f_debug,"eseguo una main prendilo sui dati")
2575 #endif
2576  ier=idba_prendilo(this%handle)
2577 
2578  end if
2579  end do
2580  end do
2581 end do
2582 
2583 END SUBROUTINE vol7d_dballe_export
2584 
2585 
2587 
2588 SUBROUTINE vol7d_dballe_delete(this, preserveidbhandle)
2589 TYPE(vol7d_dballe) :: this
2590 logical,intent(in), optional :: preserveidbhandle
2591 integer :: ier
2592 
2593 if (this%file)then
2594 
2595  ier=idba_fatto(this%handle)
2596 
2597 else
2598 
2599  ier=idba_fatto(this%handle)
2600  ier=idba_fatto(this%handle_staz)
2601  if (.not. optio_log(preserveidbhandle)) ier=idba_arrivederci(this%idbhandle)
2602 
2603 end if
2604 
2605 ier=idba_error_remove_callback(this%handle_err)
2606 
2607 !this%dsn=cmiss
2608 !this%user=cmiss
2609 !this%password=cmiss
2610 this%idbhandle=imiss
2611 this%handle=imiss
2612 this%handle_err=imiss
2613 this%handle_staz=imiss
2614 
2615 if (associated(this%data_id)) then
2616  deallocate (this%data_id)
2617  nullify(this%data_id)
2618 end if
2619 CALL delete(this%vol7d)
2620 
2621 !chiudo il logger
2622 call l4f_category_delete(this%category)
2623 !ier=l4f_fini()
2624 
2625 END SUBROUTINE vol7d_dballe_delete
2626 
2627 
2628 
2629 subroutine vol7d_dballe_import_dballevar(this)
2630 
2631 type(vol7d_var),pointer :: this(:)
2632 INTEGER :: i,un,n
2633 
2634 IF (associated(this)) return
2635 IF (allocated(blocal)) then
2636  ALLOCATE(this(size(blocal)))
2637  this=blocal
2638  return
2639 end if
2640 
2641 un = open_dballe_file('dballe.txt', filetype_data)
2642 IF (un < 0) then
2643 
2644  call l4f_log(l4f_error,"error open_dballe_file: dballe.txt")
2645  CALL raise_error("error open_dballe_file: dballe.txt")
2646  return
2647 end if
2648 
2649 n = 0
2650 DO WHILE(.true.)
2651  READ(un,*,end=100)
2652  n = n + 1
2653 ENDDO
2654 100 CONTINUE
2655 
2656 IF (n > 0) THEN
2657  ALLOCATE(this(n))
2658  ALLOCATE(blocal(n))
2659  rewind(un)
2660  readline: do i = 1 ,n
2661  READ(un,'(1x,A6,1x,a65,a24,i4)')blocal(i)%btable,blocal(i)%description,blocal(i)%unit,&
2662  blocal(i)%scalefactor
2663  blocal(i)%btable(:1)="B"
2664  !print*,"B=",blocal(i)%btable
2665  !print*," D=",blocal(i)%description
2666  !PRINT*," U=",blocal(i)%unit
2667  !PRINT*," D=",blocal(i)%scalefactor
2668  ENDDO readline
2669 
2670  CALL l4f_log(l4f_info,'Found '//trim(to_char(i-1))//' variables in dballe master table')
2671 
2672  this=blocal
2673 
2674 ENDIF
2675 CLOSE(un)
2676 
2677 END SUBROUTINE vol7d_dballe_import_dballevar
2678 
2679 
2680 
2683 
2684 subroutine vol7d_dballe_set_var_du(this)
2685 
2686 TYPE(vol7d) :: this
2687 integer :: i,j
2688 type(vol7d_var),pointer :: dballevar(:)
2689 
2690 
2691 call vol7d_dballe_import_dballevar(dballevar)
2692 
2693 #undef VOL7D_POLY_NAME
2694 #define VOL7D_POLY_NAME dativar
2695 
2696 
2697 #undef VOL7D_POLY_TYPES_V
2698 #define VOL7D_POLY_TYPES_V r
2699 #include "vol7d_dballe_class_var_du.F90"
2700 #undef VOL7D_POLY_TYPES_V
2701 #define VOL7D_POLY_TYPES_V i
2702 #include "vol7d_dballe_class_var_du.F90"
2703 #undef VOL7D_POLY_TYPES_V
2704 #define VOL7D_POLY_TYPES_V b
2705 #include "vol7d_dballe_class_var_du.F90"
2706 #undef VOL7D_POLY_TYPES_V
2707 #define VOL7D_POLY_TYPES_V d
2708 #include "vol7d_dballe_class_var_du.F90"
2709 #undef VOL7D_POLY_TYPES_V
2710 #define VOL7D_POLY_TYPES_V c
2711 #include "vol7d_dballe_class_var_du.F90"
2712 #undef VOL7D_POLY_TYPES_V
2713 
2714 #undef VOL7D_POLY_NAME
2715 #define VOL7D_POLY_NAME anavar
2716 
2717 
2718 #undef VOL7D_POLY_TYPES_V
2719 #define VOL7D_POLY_TYPES_V r
2720 #include "vol7d_dballe_class_var_du.F90"
2721 #undef VOL7D_POLY_TYPES_V
2722 #define VOL7D_POLY_TYPES_V i
2723 #include "vol7d_dballe_class_var_du.F90"
2724 #undef VOL7D_POLY_TYPES_V
2725 #define VOL7D_POLY_TYPES_V b
2726 #include "vol7d_dballe_class_var_du.F90"
2727 #undef VOL7D_POLY_TYPES_V
2728 #define VOL7D_POLY_TYPES_V d
2729 #include "vol7d_dballe_class_var_du.F90"
2730 #undef VOL7D_POLY_TYPES_V
2731 #define VOL7D_POLY_TYPES_V c
2732 #include "vol7d_dballe_class_var_du.F90"
2733 #undef VOL7D_POLY_TYPES_V
2734 
2735 
2736 #undef VOL7D_POLY_NAME
2737 #define VOL7D_POLY_NAME datiattr
2738 
2739 
2740 #undef VOL7D_POLY_TYPES_V
2741 #define VOL7D_POLY_TYPES_V r
2742 #include "vol7d_dballe_class_var_du.F90"
2743 #undef VOL7D_POLY_TYPES_V
2744 #define VOL7D_POLY_TYPES_V i
2745 #include "vol7d_dballe_class_var_du.F90"
2746 #undef VOL7D_POLY_TYPES_V
2747 #define VOL7D_POLY_TYPES_V b
2748 #include "vol7d_dballe_class_var_du.F90"
2749 #undef VOL7D_POLY_TYPES_V
2750 #define VOL7D_POLY_TYPES_V d
2751 #include "vol7d_dballe_class_var_du.F90"
2752 #undef VOL7D_POLY_TYPES_V
2753 #define VOL7D_POLY_TYPES_V c
2754 #include "vol7d_dballe_class_var_du.F90"
2755 #undef VOL7D_POLY_TYPES_V
2756 
2757 
2758 #undef VOL7D_POLY_NAME
2759 #define VOL7D_POLY_NAME anaattr
2760 
2761 
2762 #undef VOL7D_POLY_TYPES_V
2763 #define VOL7D_POLY_TYPES_V r
2764 #include "vol7d_dballe_class_var_du.F90"
2765 #undef VOL7D_POLY_TYPES_V
2766 #define VOL7D_POLY_TYPES_V i
2767 #include "vol7d_dballe_class_var_du.F90"
2768 #undef VOL7D_POLY_TYPES_V
2769 #define VOL7D_POLY_TYPES_V b
2770 #include "vol7d_dballe_class_var_du.F90"
2771 #undef VOL7D_POLY_TYPES_V
2772 #define VOL7D_POLY_TYPES_V d
2773 #include "vol7d_dballe_class_var_du.F90"
2774 #undef VOL7D_POLY_TYPES_V
2775 #define VOL7D_POLY_TYPES_V c
2776 #include "vol7d_dballe_class_var_du.F90"
2777 #undef VOL7D_POLY_TYPES_V
2778 
2779 
2780 deallocate(dballevar)
2781 
2782 return
2783 
2784 end subroutine vol7d_dballe_set_var_du
2785 
2786 
2787 
2788 FUNCTION get_dballe_filepath(filename, filetype) RESULT(path)
2789 CHARACTER(len=*), INTENT(in) :: filename
2790 INTEGER, INTENT(in) :: filetype
2791 
2792 INTEGER :: j
2793 CHARACTER(len=512) :: path
2794 LOGICAL :: exist
2795 
2796 IF (dballe_name == ' ') THEN
2797  CALL getarg(0, dballe_name)
2798  ! dballe_name_env
2799 ENDIF
2800 
2801 IF (filetype < 1 .OR. filetype > nftype) THEN
2802  path = ""
2803  CALL l4f_log(l4f_error, 'dballe file type '//trim(to_char(filetype))// &
2804  ' not valid')
2805  CALL raise_error()
2806  RETURN
2807 ENDIF
2808 
2809 ! try with environment variable
2810 CALL getenv(trim(dballe_name_env), path)
2811 IF (path /= ' ') THEN
2812 
2813  path=trim(path)//'/'//filename
2814  INQUIRE(file=path, exist=exist)
2815  IF (exist) THEN
2816  CALL l4f_log(l4f_info, 'dballe file '//trim(path)//' found')
2817  RETURN
2818  ENDIF
2819 ENDIF
2820 ! try with pathlist
2821 DO j = 1, SIZE(pathlist,1)
2822  IF (pathlist(j,filetype) == ' ') EXIT
2823  path=trim(pathlist(j,filetype))//'/'//trim(dballe_name)//'/'//filename
2824  INQUIRE(file=path, exist=exist)
2825  IF (exist) THEN
2826  CALL l4f_log(l4f_info, 'dballe file '//trim(path)//' found')
2827  RETURN
2828  ENDIF
2829 ENDDO
2830 CALL l4f_log(l4f_error, 'dballe file '//trim(filename)//' not found')
2831 CALL raise_error()
2832 path = ""
2833 
2834 END FUNCTION get_dballe_filepath
2835 
2836 
2837 FUNCTION open_dballe_file(filename, filetype) RESULT(unit)
2838 CHARACTER(len=*), INTENT(in) :: filename
2839 INTEGER, INTENT(in) :: filetype
2840 INTEGER :: unit,i
2841 
2842 CHARACTER(len=512) :: path
2843 
2844 unit = -1
2845 path=get_dballe_filepath(filename, filetype)
2846 IF (path == '') RETURN
2847 
2848 unit = getunit()
2849 IF (unit == -1) RETURN
2850 
2851 OPEN(unit, file=path, status='old', iostat = i)
2852 IF (i == 0) THEN
2853  CALL l4f_log(l4f_info, 'dballe file '//trim(path)//' opened')
2854  RETURN
2855 ENDIF
2856 
2857 CALL l4f_log(l4f_error, 'dballe file '//trim(filename)//' not found')
2858 CALL raise_error()
2859 unit = -1
2860 
2861 END FUNCTION open_dballe_file
2862 
2863 
2864 
2865 FUNCTION v7d_dballe_error_handler(category)
2866 INTEGER :: category, code, l4f_level
2867 INTEGER :: v7d_dballe_error_handler
2868 
2869 CHARACTER(len=1000) :: message, buf
2870 
2871 code = idba_error_code()
2872 
2873 ! check if "Value outside acceptable domain"
2874 if (code == 13 ) then
2875  l4f_level=l4f_warn
2876 else
2877  l4f_level=l4f_error
2878 end if
2879 
2880 call idba_error_message(message)
2881 call l4f_category_log(category,l4f_level,message)
2882 
2883 call idba_error_context(buf)
2884 
2885 call l4f_category_log(category,l4f_level,trim(buf))
2886 
2887 call idba_error_details(buf)
2888 call l4f_category_log(category,l4f_info,trim(buf))
2889 
2890 
2891 ! if "Value outside acceptable domain" do not raise error
2892 if (l4f_level == l4f_error ) CALL raise_fatal_error("dballe: "//message)
2893 
2894 v7d_dballe_error_handler = 0
2895 return
2896 
2897 END FUNCTION v7d_dballe_error_handler
2898 
2899 
2900 
2905 
2906 #ifndef F2003_EXTENDED_FEATURES
2907 !! Attributes will not be imported at all.
2908 #endif
2909 
2910 SUBROUTINE vol7d_dballe_importvvns_file(this, var, network, coordmin, coordmax, timei, timef,level,timerange, set_network,&
2911  attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,ana)
2912 
2913 TYPE(vol7d_dballe),INTENT(inout) :: this
2914 CHARACTER(len=*),INTENT(in),OPTIONAL :: var(:)
2915 TYPE(geo_coord),INTENT(inout),optional :: coordmin,coordmax
2916 TYPE(vol7d_ana),INTENT(inout),optional :: ana
2917 TYPE(datetime),INTENT(in),OPTIONAL :: timei, timef
2918 TYPE(vol7d_network),INTENT(in),OPTIONAL :: network,set_network
2919 TYPE(vol7d_level),INTENT(in),optional :: level
2920 TYPE(vol7d_timerange),INTENT(in),optional :: timerange
2921 CHARACTER(len=*),INTENT(in),OPTIONAL :: attr(:),anavar(:),anaattr(:)
2922 CHARACTER(len=*),INTENT(in),OPTIONAL :: varkind(:),attrkind(:),anavarkind(:),anaattrkind(:)
2923 logical,intent(in),optional :: anaonly
2924 
2925 !TYPE(vol7d) :: v7d
2926 !CHARACTER(len=SIZE(var)*7) :: varlist
2927 !CHARACTER(len=SIZE(attr)*8) :: starvarlist
2928 CHARACTER(len=6) :: btable
2929 
2930 LOGICAL :: ldegnet, lanaonly
2931 integer :: year,month,day,hour,minute,sec
2932 integer :: rlevel1, rl1,rlevel2, rl2
2933 integer :: rtimerange, p1, p2
2934 character(len=network_name_len) ::rep_memo
2935 integer :: indana,indtime,indlevel,indtimerange,inddativar,indnetwork
2936 
2937 
2938 integer :: nana,ntime,ntimerange,nlevel,nnetwork
2939 TYPE(vol7d_network),ALLOCATABLE :: networktmp(:)
2940 
2941 INTEGER :: i,ii, n, na, nd
2942 integer :: nvar, nanavar ,indanavar
2943 
2944 INTEGER(kind=int_l) :: ilat,ilon,latmin,latmax,lonmin,lonmax,ilata,ilona
2945 CHARACTER(len=vol7d_ana_lenident) :: ident
2946 !INTEGER(kind=int_b)::attrdatib
2947 
2948 integer :: ndativarr, ndativari, ndativarb, ndativard, ndativarc
2949 integer :: ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc
2950 integer :: ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc
2951 
2952 integer :: nanavarr, nanavari, nanavarb, nanavard, nanavarc
2953 integer :: nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc
2954 integer :: nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
2955 
2956 integer :: ir,ib,id,ic,ier
2957 
2958 TYPE(datetime) :: timee
2959 TYPE(vol7d_level) :: levele
2960 TYPE(vol7d_timerange) :: timerangee
2961 
2962 TYPE(vol7d_network) :: lnetwork
2963 TYPE(vol7d_level) :: llevel
2964 TYPE(vol7d_timerange) :: ltimerange
2965 logical :: lattr
2966 
2967 !TYPE(datetime) :: odatetime
2968 ! nobs, ntime, nana, nvout, nvin, nvbt, &
2969 ! datai(3), orai(2), dataf(3), oraf(2),ist
2970 !CHARACTER(len=12),ALLOCATABLE :: tmtmp(:)
2971 !INTEGER,ALLOCATABLE :: anatmp(:), vartmp(:), mapdatao(:)
2972 !LOGICAL :: found, non_valid, varbt_req(SIZE(vartable))
2973 
2974 
2975 TYPE(vol7d) :: vol7dtmp
2976 
2977 type(record),pointer :: buffer(:),bufferana(:)
2978 
2979 !!! CALL print_info('Estratte dall''archivio '//TRIM(to_char(nobs)) // ' osservazioni')
2980 
2981 call optio(anaonly,lanaonly)
2982 
2983 
2984 IF (PRESENT(set_network)) THEN
2985  if (c_e(set_network)) then
2986  ldegnet = .true.
2987  call l4f_category_log(this%category,l4f_info,&
2988  "set_network is not fully implemented in BUFR/CREX import: priority will be ignored")
2989  else
2990  ldegnet = .false.
2991  end if
2992 ELSE
2993  ldegnet = .false.
2994 ENDIF
2995 
2996 if (present(attr))then
2997  if (size(attr) > 0 )then
2998  lattr=.true.
2999  else
3000  lattr=.false.
3001  end if
3002 else
3003  lattr=.false.
3004 end if
3005 
3006 if ( lattr .or. present(anaattr) .or. present(attrkind) .or. present(anaattrkind))then
3007  call l4f_category_log(this%category,l4f_error,"attributes not managed in BUFR/CREX import: try --disable-qc when is possible")
3008  CALL raise_error()
3009 end if
3010 
3011 
3012 if (present(network)) then
3013  lnetwork=network
3014 else
3015  call init(lnetwork)
3016 end if
3017 
3018 if (present(level)) then
3019  llevel=level
3020 else
3021  call init(llevel)
3022 end if
3023 
3024 if (present(timerange)) then
3025  ltimerange=timerange
3026 else
3027  call init(ltimerange)
3028 end if
3029 
3030 
3031 ier=idba_unsetall(this%handle)
3032 #ifdef DEBUG
3033 CALL l4f_category_log(this%category,l4f_debug,'unsetall handle')
3034 #endif
3035 
3036 n=1
3037 nd=0
3038 na=0
3039 
3040 call mem_acquire( buffer,nd,1000,this%category )
3041 call mem_acquire( bufferana,na,100,this%category )
3042 
3043 ier=idba_setcontextana(this%handle)
3044 do while ( .true. )
3045 
3046  ier=idba_voglioquesto(this%handle,n)
3047  if (ier /= 0) then
3048  call l4f_category_log(this%category,l4f_error,"voglioquesto return error status")
3049  n=1 ! I do not want terminate while loop
3050  cycle
3051  end if
3052 
3053  call l4f_category_log(this%category,l4f_debug,"numero dati voglioquesto:"//to_char(n))
3054 
3055  if (.not. c_e(n)) exit
3056 
3057 #ifdef DBALLELT67
3058  if (n == 0) exit ! use only with dballe svn <= 4266
3059 #endif
3060 
3061  ! dammi tutti i dati
3062  do i=1,n
3063 
3064  ier=idba_dammelo(this%handle,btable)
3065 
3066  ier=idba_enqdate(this%handle,year,month,day,hour,minute,sec)
3067  IF (.NOT.c_e(sec)) sec = 0
3068  ier=idba_enqlevel(this%handle, rlevel1, rl1, rlevel2,rl2)
3069  ier=idba_enqtimerange(this%handle, rtimerange, p1, p2)
3070  ier=idba_enq(this%handle, "rep_memo",rep_memo)
3071  !print *,"trovato network",rep_memo
3072 
3073  !nbtable=btable_numerico(btable)
3074  ! ind = firsttrue(qccli%v7d%dativar%r(:)%btable == nbtable)
3075  ! IF (ind<1) cycle ! non c'e'
3076 
3077  !recupero i dati di anagrafica
3078  ier=idba_enq(this%handle,"lat", ilat)
3079  ier=idba_enq(this%handle,"lon", ilon)
3080  ier=idba_enq(this%handle,"ident",ident)
3081 
3082 !!$ print*,"ident",ident
3083 !!$ do ier=1,len(ident)
3084 !!$ print *,iachar(ident(ier:ier))
3085 !!$ end do
3086 
3087  ! inizio la serie dei test con i parametri richiesti
3088 
3089  if(c_e(lnetwork)) then
3090  if (rep_memo /= lnetwork%name) cycle
3091  end if
3092 
3093 ! in alternativa si trattano insieme
3094 !!$ call init(ana,lat=lat,lon=lon,ident=ident)
3095 !!$
3096 !!$ if (present(coordmin).and.present(coordmax))then
3097 !!$
3098 !!$ if (.not. inside(this%vol7d%ana(i)%coord,coordmin,coordmax)) cycle
3099 !!$ !print * ,"sei dentro, OK"
3100 !!$ end if
3101 
3102 
3103  if (present(coordmin)) then
3104 ! CALL geo_coord_to_geo(coordmin)
3105  if (c_e(coordmin)) then
3106  CALL getval(coordmin, ilat=latmin,ilon=lonmin)
3107  if (lonmin > ilon) cycle
3108  if (latmin > ilat) cycle
3109  end if
3110  end if
3111 
3112  if (present(coordmax)) then
3113 ! CALL geo_coord_to_geo(coordmax)
3114  if (c_e(coordmax)) then
3115  CALL getval(coordmax, ilat=latmax,ilon=lonmax)
3116  if (lonmax < ilon) cycle
3117  if (latmax < ilat) cycle
3118  end if
3119  end if
3120 
3121 
3122  if (present(ana)) then
3123  if (c_e(ana%coord)) then
3124  CALL getval(ana%coord, ilat=ilata,ilon=ilona)
3125  if (ilona /= ilon) cycle
3126  if (ilata /= ilat) cycle
3127  end if
3128  if (c_e(ana%ident)) then
3129  if (ana%ident /= ident) cycle
3130  end if
3131  end if
3132 
3133  call init(timee, year=year, month=month, day=day, hour=hour, minute=minute,msec=sec*1000)
3134 
3135  if (present(timei)) then
3136  if (c_e(timei) .and. timee < timei) cycle
3137  end if
3138 
3139  if (present(timef)) then
3140  if (c_e(timef) .and. timee > timef) cycle
3141  end if
3142 
3143  if (c_e(ltimerange))then
3144  call init(timerangee, timerange%timerange, timerange%p1, timerange%p2)
3145  if (timerangee /= ltimerange) cycle
3146  end if
3147 
3148  if (c_e(llevel))then
3149  call init (levele, rlevel1, rl1,rlevel2, rl2)
3150  if (levele /= llevel) cycle
3151  end if
3152 
3153  if (rlevel1 /= 257)then
3154  ! dati
3155 
3156  if (present (var)) then
3157 ! nvar=count(c_e(var))
3158  if (any(c_e(var)) .and. (all(btable /= var))) cycle
3159  end if
3160 
3161  ! fine test
3162 
3163 
3164  nd =nd+1
3165 #ifdef DEBUG
3166  call l4f_category_log(this%category,l4f_debug,"numero dati dati:"//to_char(nd)//btable)
3167 #endif
3168  call mem_acquire( buffer,nd,0,this%category )
3169 
3170  buffer(nd)%dator=dba_mvr
3171  buffer(nd)%datoi=dba_mvi
3172  buffer(nd)%datob=dba_mvb
3173  buffer(nd)%datod=dba_mvd
3174  buffer(nd)%datoc=dba_mvc
3175 
3176  if (present(var).and. present(varkind))then
3177  ii=( firsttrue(var == btable))
3178  if (ii > 0)then
3179  !print*, "indici",ii, btable,(varkind(ii))
3180  if(varkind(ii) == "r") ier=idba_enq(this%handle,btable,buffer(nd)%dator)
3181  if(varkind(ii) == "i") ier=idba_enq(this%handle,btable,buffer(nd)%datoi)
3182  if(varkind(ii) == "b") ier=idba_enq(this%handle,btable,buffer(nd)%datob)
3183  if(varkind(ii) == "d") ier=idba_enq(this%handle,btable,buffer(nd)%datod)
3184  if(varkind(ii) == "c") ier=idba_enq(this%handle,btable,buffer(nd)%datoc)
3185  end if
3186  else
3187  ier=idba_enq(this%handle,btable,buffer(nd)%datoc) !char is default
3188  end if
3189 
3190  !bufferizzo il contesto
3191  !print *,"lat,lon,ident",lat,lon,ident
3192  !print*,year,month,day,hour,minute,sec
3193  !print*,btable,dato,buffer(nd)%datiattrb
3194 
3195 
3196  call init(buffer(nd)%ana,ilat=ilat,ilon=ilon,ident=ident)
3197  call init(buffer(nd)%time, year=year, month=month, day=day, hour=hour, minute=minute,msec=sec*1000)
3198  call init(buffer(nd)%level, rlevel1,rl1,rlevel2,rl2)
3199  call init(buffer(nd)%timerange, rtimerange, p1, p2)
3200  call init(buffer(nd)%network, rep_memo)
3201  buffer(nd)%btable = btable
3202 
3203  ! take in account time_definition
3204  IF (this%vol7d%time_definition == 0) buffer(nd)%time = buffer(nd)%time - &
3205  timedelta_new(sec=buffer(nd)%timerange%p1)
3206 
3207  ! put ana in bufferana becouse we can have no station data but we need ana
3208  !todo ; we have to do the same for network but I am tired ....
3209  if ( index(bufferana%ana,buffer(nd)%ana) <= 0) then
3210  na=na+1
3211  call mem_acquire( bufferana,na,0,this%category )
3212 
3213  call init(bufferana(na)%ana,ilat=ilat,ilon=ilon,ident=ident)
3214  call init(bufferana(na)%time, year=year, month=month, day=day, hour=hour, minute=minute,msec=sec*1000)
3215  call init(bufferana(na)%level, rlevel1,rl1,rlevel2,rl2)
3216  call init(bufferana(na)%timerange, rtimerange, p1, p2)
3217  call init(bufferana(na)%network, rep_memo)
3218 
3219  bufferana(na)%dator=dba_mvr
3220  bufferana(na)%datoi=dba_mvi
3221  bufferana(na)%datob=dba_mvb
3222  bufferana(na)%datod=dba_mvd
3223  bufferana(na)%datoc=dba_mvc
3224  bufferana(na)%btable = dba_mvc
3225 
3226  end if
3227 
3228 
3229  else
3230 
3231  ! ----------------> anagrafica
3232 
3233 
3234  !ora legge tutti i dati di anagrafica e li mette in bufferana
3235 
3236 
3237  !anno mese giorno
3238  if (btable == "B04001" .or. btable == "B04002" .or. btable == "B04003") cycle
3239  !ora minuti secondi
3240  if (btable == "B04004" .or. btable == "B04005" .or. btable == "B04006") cycle
3241  ! network
3242  if (btable == "B01193" .or. btable == "B01194") cycle
3243 
3244 
3245  if (present (anavar)) then
3246  if (any(c_e(anavar)) .and. (all(btable /= anavar))) btable=dba_mvc
3247  end if
3248 
3249 
3250  if (.not. lanaonly)then
3251  !salto lat lon e ident
3252  if (btable == "B05001" .or. btable == "B06001" .or. btable == "B01011" .or. btable == "B01194") btable=dba_mvc
3253 
3254  end if
3255 
3256  na=na+1
3257  call l4f_category_log(this%category,l4f_debug,"numero dati ana:"//to_char(na)//btable)
3258 
3259  call mem_acquire( bufferana,na,0,this%category )
3260 
3261  bufferana(na)%dator=dba_mvr
3262  bufferana(na)%datoi=dba_mvi
3263  bufferana(na)%datob=dba_mvb
3264  bufferana(na)%datod=dba_mvd
3265  bufferana(na)%datoc=dba_mvc
3266  bufferana(na)%btable = dba_mvc
3267 
3268 
3269  if (c_e(btable)) then
3270 
3271  if (present(anavar).and. present(anavarkind))then
3272  ii=( firsttrue(anavar == btable))
3273  if (ii > 0)then
3274  !print*, "indici",ii, btable,(varkind(ii))
3275  if(anavarkind(ii) == "r") ier=idba_enq(this%handle,btable,bufferana(na)%dator)
3276  if(anavarkind(ii) == "i") ier=idba_enq(this%handle,btable,bufferana(na)%datoi)
3277  if(anavarkind(ii) == "b") ier=idba_enq(this%handle,btable,bufferana(na)%datob)
3278  if(anavarkind(ii) == "d") ier=idba_enq(this%handle,btable,bufferana(na)%datod)
3279  if(anavarkind(ii) == "c") ier=idba_enq(this%handle,btable,bufferana(na)%datoc)
3280  end if
3281  else
3282  ier=idba_enq(this%handle,btable,bufferana(na)%datoc) !char is default
3283  !print*,"dato anagrafica",btable," ",bufferana(na)%dator
3284  end if
3285  end if
3286  !bufferizzo il contesto
3287  !print *,"lat,lon",lat,lon
3288  !print*,year,month,day,hour,minute,sec
3289  !print*,btable,na
3290 
3291  call init(bufferana(na)%ana,ilat=ilat,ilon=ilon,ident=ident)
3292  call init(bufferana(na)%time, year=year, month=month, day=day, hour=hour, minute=minute,msec=sec*1000)
3293  call init(bufferana(na)%level, rlevel1,rl1,rlevel2,rl2)
3294  call init(bufferana(na)%timerange, rtimerange, p1, p2)
3295  call init(bufferana(na)%network, rep_memo)
3296  bufferana(na)%btable = btable
3297 
3298  end if
3299  end do
3300 end do
3301 
3302 ! ----------------> anagrafica fine
3303 
3304 if (.not. present(var))then
3305  nvar = count_distinct(buffer(:nd)%btable, back=.true.)
3306 else
3307  if ( all(.not. c_e(var))) then
3308  nvar = count_distinct(buffer(:nd)%btable, back=.true.)
3309  else
3310  nvar=count(c_e(var))
3311  end if
3312 end if
3313 
3314 nana = count_distinct(bufferana(:na)%ana, back=.true.)
3315 !nana = count_distinct(buffer(:nd)%ana, back=.TRUE.)
3316 ntime = count_distinct(buffer(:nd)%time, back=.true.)
3317 ntimerange = count_distinct(buffer(:nd)%timerange, back=.true.)
3318 nlevel = count_distinct(buffer(:nd)%level, back=.true.)
3319 if (ldegnet) then
3320  nnetwork=1
3321 else
3322  ALLOCATE(networktmp(na+nd))
3323  networktmp(1:nd) = buffer(1:nd)%network
3324  networktmp(nd+1:na+nd) = bufferana(1:na)%network
3325  nnetwork = count_distinct(networktmp, back=.true.)
3326 endif
3327 
3328 
3329 if (present(varkind))then
3330  ndativarr= count(varkind == "r")
3331  ndativari= count(varkind == "i")
3332  ndativarb= count(varkind == "b")
3333  ndativard= count(varkind == "d")
3334  ndativarc= count(varkind == "c")
3335 
3336 else
3337  ndativarr= 0
3338  ndativari= 0
3339  ndativarb= 0
3340  ndativard= 0
3341  ndativarc= nvar
3342 end if
3343 
3344 !!$print *, "nana=",nana," ntime=",ntime," ntimerange=",ntimerange, &
3345 !!$ " nlevel=",nlevel," nnetwork=",nnetwork," ndativarr=",ndativarr
3346 
3347 ndatiattrr=0
3348 ndatiattri=0
3349 ndatiattrb=0
3350 ndatiattrd=0
3351 ndatiattrc=0
3352 
3353 ndativarattrr=0
3354 ndativarattri=0
3355 ndativarattrb=0
3356 ndativarattrd=0
3357 ndativarattrc=0
3358 
3359 ! ----------------> anagrafica
3360 
3361 if (.not. present(anavar))then
3362  nanavar = count_distinct(bufferana(:na)%btable, back=.true.,mask=(bufferana(:na)%btable /= dba_mvc))
3363 else
3364  if (all(.not. c_e(anavar))) then
3365  nanavar = count_distinct(bufferana(:na)%btable, back=.true.,mask=(bufferana(:na)%btable /= dba_mvc))
3366  else
3367  nanavar = count(c_e(anavar))
3368  end if
3369 end if
3370 
3371 if (present(anavarkind))then
3372  nanavarr= count(anavarkind == "r")
3373  nanavari= count(anavarkind == "i")
3374  nanavarb= count(anavarkind == "b")
3375  nanavard= count(anavarkind == "d")
3376  nanavarc= count(anavarkind == "c")
3377 
3378 else
3379  nanavarr= 0
3380  nanavari= 0
3381  nanavarb= 0
3382  nanavard= 0
3383  nanavarc= nanavar
3384 end if
3385 
3386 
3387 nanaattrr=0
3388 nanaattri=0
3389 nanaattrb=0
3390 nanaattrd=0
3391 nanaattrc=0
3392 
3393 nanavarattrr=0
3394 nanavarattri=0
3395 nanavarattrb=0
3396 nanavarattrd=0
3397 nanavarattrc=0
3398 
3399 
3400 ! ----------------> anagrafica fine
3401 
3402 
3403 CALL init(vol7dtmp,time_definition=this%vol7d%time_definition)
3404 
3405 if (lanaonly)then
3406 
3407  ! qui faccio le operazioni minime per avere solo l'anagrafica utile per certe operazioni
3408 
3409  CALL vol7d_alloc (vol7dtmp, nana=nana, nnetwork=nnetwork)
3410  call vol7d_alloc_vol(vol7dtmp)
3411  vol7dtmp%ana=pack_distinct(bufferana(:na)%ana, nana, back=.true.)
3412 
3413  ! Release memory
3414  deallocate (buffer)
3415  deallocate (bufferana)
3416 
3417  if(ldegnet)then
3418  vol7dtmp%network(1)=set_network
3419  else
3420  vol7dtmp%network=pack_distinct(networktmp, nnetwork, back=.true.)
3421  DEALLOCATE(networktmp)
3422  end if
3423 
3424  ! Smart merge
3425  CALL vol7d_merge(this%vol7d, vol7dtmp)
3426 
3427  return
3428 
3429 end if
3430 
3431 
3432 call vol7d_alloc (vol7dtmp, &
3433  nana=nana, ntime=ntime, ntimerange=ntimerange, &
3434  nlevel=nlevel, nnetwork=nnetwork, &
3435  ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb, ndativard=ndativard, ndativarc=ndativarc,&
3436  ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb, ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
3437  ndativarattrr=ndativarattrr, &
3438  ndativarattri=ndativarattri, &
3439  ndativarattrb=ndativarattrb, &
3440  ndativarattrd=ndativarattrd, &
3441  ndativarattrc=ndativarattrc,&
3442  nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, nanavard=nanavard, nanavarc=nanavarc,&
3443  nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb, nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
3444  nanavarattrr=nanavarattrr, &
3445  nanavarattri=nanavarattri, &
3446  nanavarattrb=nanavarattrb, &
3447  nanavarattrd=nanavarattrd, &
3448  nanavarattrc=nanavarattrc)
3449 
3450 vol7dtmp%ana=pack_distinct(bufferana(:na)%ana, nana, back=.true.)
3451 !vol7dtmp%ana=pack_distinct(buffer(:nd)%ana, nana, back=.TRUE.)
3452 vol7dtmp%time=pack_distinct(buffer(:nd)%time, ntime, back=.true.)
3453 call sort(vol7dtmp%time)
3454 vol7dtmp%timerange=pack_distinct(buffer(:nd)%timerange, ntimerange, back=.true.)
3455 call sort(vol7dtmp%timerange)
3456 vol7dtmp%level=pack_distinct(buffer(:nd)%level, nlevel, back=.true.)
3457 call sort(vol7dtmp%level)
3458 
3459 if(ldegnet)then
3460  vol7dtmp%network(1)=set_network
3461 else
3462  vol7dtmp%network=pack_distinct(networktmp, nnetwork, back=.true.)
3463  DEALLOCATE(networktmp)
3464 end if
3465 
3466 !print*,"reti presenti", vol7dtmp%network%name,buffer%network%name
3467 
3468 if (present(var).and. present(varkind))then
3469 
3470  ir=0
3471  ii=0
3472  ib=0
3473  id=0
3474  ic=0
3475 
3476  do i=1,size(varkind)
3477  if (varkind(i) == "r") then
3478  ir=ir+1
3479  call init (vol7dtmp%dativar%r(ir), btable=var(i))
3480  end if
3481  if (varkind(i) == "i") then
3482  ii=ii+1
3483  call init (vol7dtmp%dativar%i(ii), btable=var(i))
3484  end if
3485  if (varkind(i) == "b") then
3486  ib=ib+1
3487  call init (vol7dtmp%dativar%b(ib), btable=var(i))
3488  end if
3489  if (varkind(i) == "d") then
3490  id=id+1
3491  call init (vol7dtmp%dativar%d(id), btable=var(i))
3492  end if
3493  if (varkind(i) == "c") then
3494  ic=ic+1
3495  call init (vol7dtmp%dativar%c(ic), btable=var(i))
3496  end if
3497  end do
3498 else if (present(var))then
3499  if (any(c_e(var))) then
3500  do i=1, nvar
3501  call init (vol7dtmp%dativar%c(i), btable=var(i))
3502  end do
3503 
3504  else
3505 
3506  do i=1,ndativarc
3507  call init(vol7dtmp%dativar%c(i))
3508  end do
3509  if (ndativarc > 0) then
3510  call pack_distinct_c(buffer(:nd)%btable,vol7dtmp%dativar%c%btable, back=.true.)
3511  end if
3512  end if
3513 
3514 else
3515  do i=1,ndativarc
3516  call init(vol7dtmp%dativar%c(i))
3517  end do
3518  if (ndativarc > 0) then
3519  call pack_distinct_c(buffer(:nd)%btable,vol7dtmp%dativar%c%btable, back=.true.)
3520  end if
3521 end if
3522 
3523 
3524 !-----------------------> anagrafica
3525 
3526 if (present(anavar).and. present(anavarkind))then
3527 
3528  ir=0
3529  ii=0
3530  ib=0
3531  id=0
3532  ic=0
3533 
3534  do i=1,size(anavarkind)
3535  if (anavarkind(i) == "r") then
3536  ir=ir+1
3537  call init (vol7dtmp%anavar%r(ir), btable=anavar(i))
3538  end if
3539  if (anavarkind(i) == "i") then
3540  ii=ii+1
3541  call init (vol7dtmp%anavar%i(ii), btable=anavar(i))
3542  end if
3543  if (anavarkind(i) == "b") then
3544  ib=ib+1
3545  call init (vol7dtmp%anavar%b(ib), btable=anavar(i))
3546  end if
3547  if (anavarkind(i) == "d") then
3548  id=id+1
3549  call init (vol7dtmp%anavar%d(id), btable=anavar(i))
3550  end if
3551  if (anavarkind(i) == "c") then
3552  ic=ic+1
3553  call init (vol7dtmp%anavar%c(ic), btable=anavar(i))
3554  end if
3555  end do
3556 else if (present(anavar))then
3557 
3558  IF (any(c_e(anavar))) THEN
3559  DO i=1, nanavar
3560  CALL init (vol7dtmp%anavar%c(i), btable=anavar(i))
3561  END DO
3562  ELSE
3563 
3564  do i=1,nanavarc
3565  call init(vol7dtmp%anavar%c(i))
3566  end do
3567 
3568  if (nanavarc > 0) then ! we can have only lat lon and ident and not btables at all (so here we can get a strange segfault)
3569  call pack_distinct_c(bufferana(:na)%btable,vol7dtmp%anavar%c%btable, back=.true.,&
3570  mask=(bufferana(:na)%btable /= dba_mvc))
3571  end if
3572 
3573  ENDIF
3574 
3575 else
3576 
3577  do i=1,nanavarc
3578  call init(vol7dtmp%anavar%c(i))
3579  end do
3580 
3581  if (nanavarc > 0) then ! we can have only lat lon and ident and not btables at all (so here we can get a strange segfault)
3582  call pack_distinct_c(bufferana(:na)%btable,vol7dtmp%anavar%c%btable, back=.true.,&
3583  mask=(bufferana(:na)%btable /= dba_mvc))
3584  end if
3585 end if
3586 
3587 !-----------------------> anagrafica fine
3588 
3589 call vol7d_alloc_vol (vol7dtmp)
3590 
3591 do i =1, nd
3592 
3593  indana = firsttrue(buffer(i)%ana == vol7dtmp%ana)
3594  indtime = firsttrue(buffer(i)%time == vol7dtmp%time)
3595  indtimerange = firsttrue(buffer(i)%timerange == vol7dtmp%timerange)
3596  indlevel = firsttrue(buffer(i)%level == vol7dtmp%level)
3597  if (ldegnet)then
3598  indnetwork=1
3599  else
3600  indnetwork = firsttrue(buffer(i)%network == vol7dtmp%network)
3601  endif
3602  !print *, indana,indtime,indlevel,indtimerange,indnetwork
3603 
3604  if(c_e(buffer(i)%dator))then
3605  inddativar = firsttrue(buffer(i)%btable == vol7dtmp%dativar%r%btable)
3606  vol7dtmp%voldatir( &
3607  indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
3608  ) = buffer(i)%dator
3609  end if
3610 
3611  if(c_e(buffer(i)%datoi)) then
3612  inddativar = firsttrue(buffer(i)%btable == vol7dtmp%dativar%i%btable)
3613  vol7dtmp%voldatii( &
3614  indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
3615  ) = buffer(i)%datoi
3616  end if
3617 
3618  if(c_e(buffer(i)%datob)) then
3619  inddativar = firsttrue(buffer(i)%btable == vol7dtmp%dativar%b%btable)
3620  vol7dtmp%voldatib( &
3621  indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
3622  ) = buffer(i)%datob
3623  end if
3624 
3625  if(c_e(buffer(i)%datod)) then
3626  inddativar = firsttrue(buffer(i)%btable == vol7dtmp%dativar%d%btable)
3627  vol7dtmp%voldatid( &
3628  indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
3629  ) = buffer(i)%datod
3630  end if
3631 
3632  if(c_e(buffer(i)%datoc)) then
3633  inddativar = firsttrue(buffer(i)%btable == vol7dtmp%dativar%c%btable)
3634  vol7dtmp%voldatic( &
3635  indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
3636  ) = buffer(i)%datoc
3637  end if
3638 
3639 end do
3640 
3641 !------------------------- anagrafica
3642 
3643 
3644 do i =1, na
3645 
3646  indana = firsttrue(bufferana(i)%ana == vol7dtmp%ana)
3647 
3648  if (ldegnet)then
3649  indnetwork=1
3650  else
3651  indnetwork = firsttrue(bufferana(i)%network == vol7dtmp%network)
3652  endif
3653 
3654  if (indana < 1 .or. indnetwork < 1 )cycle
3655 
3656  !print *, indana,indtime,indlevel,indtimerange,indnetwork
3657 
3658  if(c_e(bufferana(i)%dator))then
3659  indanavar = firsttrue(bufferana(i)%btable == vol7dtmp%anavar%r%btable)
3660  vol7dtmp%volanar( indana,indanavar,indnetwork ) = bufferana(i)%dator
3661  end if
3662  if(c_e(bufferana(i)%datoi))then
3663  indanavar = firsttrue(bufferana(i)%btable == vol7dtmp%anavar%i%btable)
3664  vol7dtmp%volanai( indana,indanavar,indnetwork ) = bufferana(i)%datoi
3665  end if
3666  if(c_e(bufferana(i)%datob))then
3667  indanavar = firsttrue(bufferana(i)%btable == vol7dtmp%anavar%b%btable)
3668  vol7dtmp%volanab( indana,indanavar,indnetwork ) = bufferana(i)%datob
3669  end if
3670  if(c_e(bufferana(i)%datod))then
3671  indanavar = firsttrue(bufferana(i)%btable == vol7dtmp%anavar%d%btable)
3672  vol7dtmp%volanad( indana,indanavar,indnetwork ) = bufferana(i)%datod
3673  end if
3674  if (nanavarc > 0) then
3675  if(c_e(bufferana(i)%datoc))then
3676  indanavar = firsttrue(bufferana(i)%btable == vol7dtmp%anavar%c%btable)
3677  vol7dtmp%volanac( indana,indanavar,indnetwork ) = bufferana(i)%datoc
3678  end if
3679  end if
3680 
3681  end do
3682 
3683 !------------------------- anagrafica fine
3684 
3685 !
3686 ! Release memory
3687 !
3688 
3689 deallocate (buffer)
3690 deallocate (bufferana)
3691 
3692 ! Smart merge
3693 CALL vol7d_merge(this%vol7d, vol7dtmp, sort=.true.)
3694 ! should we sort separately in case no merge is done?
3695 !CALL vol7d_smart_sort(this%vol7d, ltime=.TRUE., ltimerange=.TRUE., llevel=.TRUE,)
3696 
3697 call vol7d_set_attr_ind(this%vol7d)
3698 
3699 call vol7d_dballe_set_var_du(this%vol7d)
3700 
3701 !print *,"R-R",this%vol7d%dativar%r(:)%r
3702 !print *,"R-I",this%vol7d%dativar%r(:)%i
3703 !print *,"R-B",this%vol7d%dativar%r(:)%b
3704 !print *,"R-D",this%vol7d%dativar%r(:)%d
3705 !print *,"R-C",this%vol7d%dativar%r(:)%c
3706 
3707 !print *,"I-R",this%vol7d%dativar%i(:)%r
3708 !print *,"I-I",this%vol7d%dativar%i(:)%i
3709 !print *,"I-B",this%vol7d%dativar%i(:)%b
3710 !print *,"I-D",this%vol7d%dativar%i(:)%d
3711 !print *,"I-C",this%vol7d%dativar%i(:)%c
3712 
3713 
3714 END SUBROUTINE vol7d_dballe_importvvns_file
3715 
3716 
3717 
3718 subroutine mem_acquire( buffer,n,npool,category )
3719 
3720 INTEGER :: n,mem,npool,category,istat
3721 type(record),pointer :: buffer(:)
3722 type(record),pointer :: buffertmp(:)
3723 
3724 
3725 if ( n == 0 ) then
3726 
3727  allocate (buffer(npool))
3728  return
3729 
3730 end if
3731 
3732 mem=size(buffer)
3733 
3734 !call l4f_category_log(category,L4F_DEBUG,"mem_acquire dimension of buffer: "//to_char(mem)//" "//to_char(n))
3735 
3736 if (n > mem) then
3737 
3738  ALLOCATE (buffertmp(max(mem*2,n)),stat=istat)
3739  IF (istat /= 0) THEN
3740  CALL l4f_category_log(category,l4f_error,'mem_acquire, cannot allocate ' &
3741  //trim(to_char(mem*2))//' buffer elements')
3742  CALL raise_fatal_error()
3743  endif
3744 
3745  buffertmp(:mem)=buffer(:)
3746 
3747  deallocate (buffer)
3748 
3749  buffer=>buffertmp
3750 
3751 end if
3752 
3753 end subroutine mem_acquire
3754 
3755 
3756 end MODULE vol7d_dballeold_class
3757 
3761 
3766 
3771 
3772 
Set of functions that return a trimmed CHARACTER representation of the input variable.
Oggetto per import ed export da DB-All.e.
Test for a missing volume.
Index method.
Classes for handling georeferenced sparse points in geographical corodinates.
Determine whether a point lies inside a polygon or a rectangle.
Set of functions that return a CHARACTER representation of the input variable.
Classe per la gestione di un volume completo di dati osservati.
This module defines usefull general purpose function and subroutine.
classe per la gestione del logging
classe per import ed export di volumi da e in DB-All.e
Utilities for CHARACTER variables.
Methods for returning the value of object members.
Emit log message for a category with specific priority.

Generated with Doxygen.