dba2v7d vol7d_dballe_import vol7d_dballe_import_old vol7d_dballe_importvvnv

dba2v7d() subroutine dba2v7d ( type(vol7d), intent(inout)  this, type(dbametaanddata), dimension(:), intent(inout)  metaanddatav, integer, intent(in), optional  time_definition, type(vol7d_network), intent(in), optional  set_network  ) import dba objects in vol7d Parametri [in] time_definition 0=time is reference time ; 1=time is validity time (default=1) Definizione alla linea 845 del file vol7d_dballe_class.F03. do i =1, size(metaanddatav) do j=1, size(metaanddatav(i)%dataattrv%dataattr) do k=1, size(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv) if (c_e(metaanddatav(i)%metadata%datetime%datetime)) then if (metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat%btable == dativarattra(n))then allocate(starvars%dcv(n)%dat,source=metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat) cycle cn end if end if end do end do end do end do cn dn: do n=1,nanavarattr do i =1, size(metaanddatav) do j=1, size(metaanddatav(i)%dataattrv%dataattr) do k=1, size(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv) if (.not. c_e(metaanddatav(i)%metadata%datetime%datetime)) then if (metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat%btable == anavarattra(n))then allocate(anastarvars%dcv(n)%dat,source=metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat) cycle dn end if end if end do end do end do end do dn !!-------------------------------------------------------------------------- !! !! count all unique metadata !! if(ldegnet) then nnetwork=1 else !nnetwork = count_distinct(metaanddatav(:)%metadata%network%vol7d_network, back=.TRUE.) allocate (tmpnetwork(size(metaanddatav(:))),& source=metaanddatav(:)%metadata%network%vol7d_network) call sort(tmpnetwork) nnetwork = count_distinct_sorted(tmpnetwork) end if !ntime = count_distinct(metaanddatav(:)%metadata%datetime%datetime, & ! mask=c_e(metaanddatav(:)%metadata%datetime%datetime),back=.TRUE.) allocate (tmptime(size(metaanddatav(:))),& source=metaanddatav(:)%metadata%datetime%datetime) call sort(tmptime) ntime = count_distinct_sorted(tmptime,mask=c_e(tmptime)) !ntimerange = count_distinct(metaanddatav(:)%metadata%timerange%vol7d_timerange, & ! mask=c_e(metaanddatav(:)%metadata%timerange%vol7d_timerange), back=.TRUE.) allocate (tmptimerange(size(metaanddatav(:))),& source=metaanddatav(:)%metadata%timerange%vol7d_timerange) call sort(tmptimerange) ntimerange = count_distinct_sorted(tmptimerange,mask=c_e(tmptimerange)) !nlevel = count_distinct(metaanddatav(:)%metadata%level%vol7d_level, & ! mask=c_e(metaanddatav(:)%metadata%level%vol7d_level),back=.TRUE.) allocate (tmplevel(size(metaanddatav(:))),& source=metaanddatav(:)%metadata%level%vol7d_level) call sort(tmplevel) nlevel = count_distinct_sorted(tmplevel,mask=c_e(tmplevel)) !nana = count_distinct(metaanddatav(:)%metadata%ana%vol7d_ana, back=.TRUE.) allocate (tmpana(size(metaanddatav(:))),& source=metaanddatav(:)%metadata%ana%vol7d_ana) call sort(tmpana) nana = count_distinct_sorted(tmpana) !!$if(ldegnet) then !!$ nnetwork=1 !!$else !!$ nnetwork = size(metaanddatav(:)%metadata%network%vol7d_network) !!$end if !!$ntime = size(metaanddatav(:)%metadata%datetime%datetime) !!$ntimerange = size(metaanddatav(:)%metadata%timerange%vol7d_timerange) !!$nlevel = size(metaanddatav(:)%metadata%level%vol7d_level) !!$nana = size(metaanddatav(:)%metadata%ana%vol7d_ana) ! var ndativarr = 0 ndativari = 0 ndativarb = 0 ndativard = 0 ndativarc = 0 do i =1 ,size(vars%dcv) associate(dato => vars%dcv(i)%dat) select type (dato) type is (dbadatar) ndativarr = ndativarr + 1 type is (dbadatai) ndativari = ndativari + 1 type is (dbadatab) ndativarb = ndativarb + 1 type is (dbadatad) ndativard = ndativard + 1 type is (dbadatac) ndativarc = ndativarc + 1 end select end associate end do !attr ndatiattrr = 0 ndatiattri = 0 ndatiattrb = 0 ndatiattrd = 0 ndatiattrc = 0 do i =1 ,size(starvars%dcv) associate(dato => starvars%dcv(i)%dat) select type (dato) type is (dbadatar) ndatiattrr = ndatiattrr + 1 type is (dbadatai) ndatiattri = ndatiattri + 1 type is (dbadatab) ndatiattrb = ndatiattrb + 1 type is (dbadatad) ndatiattrd = ndatiattrd + 1 type is (dbadatac) ndatiattrc = ndatiattrc + 1 end select end associate end do ! ana var nanavarr = 0 nanavari = 0 nanavarb = 0 nanavard = 0 nanavarc = 0 do i =1 ,size(anavars%dcv) associate(dato => anavars%dcv(i)%dat) select type (dato) type is (dbadatar) nanavarr = nanavarr + 1 type is (dbadatai) nanavari = nanavari + 1 type is (dbadatab) nanavarb = nanavarb + 1 type is (dbadatad) nanavard = nanavard + 1 type is (dbadatac) nanavarc = nanavarc + 1 end select end associate end do ! ana attr nanaattrr = 0 nanaattri = 0 nanaattrb = 0 nanaattrd = 0 nanaattrc = 0 do i =1 ,size(anastarvars%dcv) associate(dato => anastarvars%dcv(i)%dat) select type (dato) type is (dbadatar) nanaattrr = nanaattrr + 1 type is (dbadatai) nanaattri = nanaattri + 1 type is (dbadatab) nanaattrb = nanaattrb + 1 type is (dbadatad) nanaattrd = nanaattrd + 1 type is (dbadatac) nanaattrc = nanaattrc + 1 end select end associate end do !refine ndativarattrr=0 ndativarattri=0 ndativarattrb=0 ndativarattrd=0 ndativarattrc=0 if (ndatiattrr > 0 ) ndativarattrr=ndativarr+ndativari+ndativarb+ndativard+ndativarc if (ndatiattri > 0 ) ndativarattri=ndativarr+ndativari+ndativarb+ndativard+ndativarc if (ndatiattrb > 0 ) ndativarattrb=ndativarr+ndativari+ndativarb+ndativard+ndativarc if (ndatiattrd > 0 ) ndativarattrd=ndativarr+ndativari+ndativarb+ndativard+ndativarc if (ndatiattrc > 0 ) ndativarattrc=ndativarr+ndativari+ndativarb+ndativard+ndativarc nanavarattrr=0 nanavarattri=0 nanavarattrb=0 nanavarattrd=0 nanavarattrc=0 if (nanaattrr > 0 ) nanavarattrr=nanavarr+nanavari+nanavarb+nanavard+nanavarc if (nanaattri > 0 ) nanavarattri=nanavarr+nanavari+nanavarb+nanavard+nanavarc if (nanaattrb > 0 ) nanavarattrb=nanavarr+nanavari+nanavarb+nanavard+nanavarc if (nanaattrd > 0 ) nanavarattrd=nanavarr+nanavari+nanavarb+nanavard+nanavarc if (nanaattrc > 0 ) nanavarattrc=nanavarr+nanavari+nanavarb+nanavard+nanavarc CALL init(this,time_definition=ltime_definition) !!$print *, "nana=",nana, "ntime=",ntime, "ntimerange=",ntimerange, & !!$ "nlevel=",nlevel, "nnetwork=",nnetwork, & !!$ "ndativarr=",ndativarr, "ndativari=",ndativari, & !!$ "ndativarb=",ndativarb, "ndativard=",ndativard, "ndativarc=",ndativarc,& !!$ "ndatiattrr=",ndatiattrr, "ndatiattri=",ndatiattri, "ndatiattrb=",ndatiattrb,& !!$ "ndatiattrd=",ndatiattrd, "ndatiattrc=",ndatiattrc,& !!$ "ndativarattrr=",ndativarattrr, "ndativarattri=",ndativarattri, "ndativarattrb=",ndativarattrb,& !!$ "ndativarattrd=",ndativarattrd, "ndativarattrc=",ndativarattrc !!$ !!$print *,"nanaattrr,nanaattri,nanaattrb,nanaattrd,nanaattrc" !!$print *,nanaattrr,nanaattri,nanaattrb,nanaattrd,nanaattrc call vol7d_alloc (this, & nana=nana, ntime=ntime, ntimerange=ntimerange, & nlevel=nlevel, nnetwork=nnetwork, & ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb, ndativard=ndativard, ndativarc=ndativarc,& ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb, ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,& ndativarattrr=ndativarattrr, & ndativarattri=ndativarattri, & ndativarattrb=ndativarattrb, & ndativarattrd=ndativarattrd, & ndativarattrc=ndativarattrc,& nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, nanavard=nanavard, nanavarc=nanavarc,& nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb, nanaattrd=nanaattrd, nanaattrc=nanaattrc,& nanavarattrr=nanavarattrr, & nanavarattri=nanavarattri, & nanavarattrb=nanavarattrb, & nanavarattrd=nanavarattrd, & nanavarattrc=nanavarattrc) ! fill metadata removing contextana metadata !nana=count_and_pack_distinct(metaanddatav(:)%metadata%ana%vol7d_ana,this%ana, back=.TRUE.) !this%ana=pack_distinct(metaanddatav(:)%metadata%ana%vol7d_ana, nana, back=.TRUE.) this%ana=pack_distinct_sorted(tmpana, nana) deallocate(tmpana) !call sort(this%ana) !ntime=count_and_pack_distinct(metaanddatav(:)%metadata%datetime%datetime,this%time, & ! mask=c_e(metaanddatav(:)%metadata%datetime%datetime), back=.TRUE.) !this%time=pack_distinct(metaanddatav(:)%metadata%datetime%datetime, ntime, & ! mask=c_e(metaanddatav(:)%metadata%datetime%datetime),back=.TRUE.) this%time=pack_distinct_sorted(tmptime, ntime,mask=c_e(tmptime)) deallocate(tmptime) !call sort(this%time) !ntimerange=count_and_pack_distinct(metaanddatav(:)%metadata%timerange%vol7d_timerange,this%timerange, & ! mask=c_e(metaanddatav(:)%metadata%timerange%vol7d_timerange), back=.TRUE.) !this%timerange=pack_distinct(metaanddatav(:)%metadata%timerange%vol7d_timerange, ntimerange, & ! mask=c_e(metaanddatav(:)%metadata%timerange%vol7d_timerange), back=.TRUE.) this%timerange=pack_distinct_sorted(tmptimerange, ntimerange,mask=c_e(tmptimerange)) deallocate(tmptimerange) !call sort(this%timerange) !nlevel=count_and_pack_distinct(metaanddatav(:)%metadata%level%vol7d_level,this%level, & ! mask=c_e(metaanddatav(:)%metadata%level%vol7d_level), back=.TRUE.) !this%level=pack_distinct(metaanddatav(:)%metadata%level%vol7d_level, nlevel, & ! mask=c_e(metaanddatav(:)%metadata%level%vol7d_level), back=.TRUE.) this%level=pack_distinct_sorted(tmplevel, nlevel,mask=c_e(tmplevel)) deallocate(tmplevel) !call sort(this%level) if(ldegnet)then nnetwork=1 ALLOCATE(this%network(1)) this%network(1)=set_network else !nnetwork=count_and_pack_distinct(metaanddatav(:)%metadata%network%vol7d_network,this%network, back=.TRUE.) !this%network=pack_distinct(metaanddatav(:)%metadata%network%vol7d_network, nnetwork, back=.TRUE.) this%network=pack_distinct_sorted(tmpnetwork, nnetwork) deallocate(tmpnetwork) end if !call sort(this%network) ! var ndativarr = 0 ndativari = 0 ndativarb = 0 ndativard = 0 ndativarc = 0 do i =1 ,size(vars%dcv) associate(dato => vars%dcv(i)%dat) select type (dato) type is (dbadatar) ndativarr = ndativarr + 1 call init (this%dativar%r(ndativarr), btable=dato%btable) type is (dbadatai) ndativari = ndativari + 1 call init (this%dativar%i(ndativari), btable=dato%btable) type is (dbadatab) ndativarb = ndativarb + 1 call init (this%dativar%b(ndativarb), btable=dato%btable) type is (dbadatad) ndativard = ndativard + 1 call init (this%dativar%d(ndativard), btable=dato%btable) type is (dbadatac) ndativarc = ndativarc + 1 call init (this%dativar%c(ndativarc), btable=dato%btable) end select end associate end do !attr ndatiattrr = 0 ndatiattri = 0 ndatiattrb = 0 ndatiattrd = 0 ndatiattrc = 0 do i =1 ,size(starvars%dcv) associate(dato => starvars%dcv(i)%dat) select type (dato) type is (dbadatar) ndatiattrr = ndatiattrr + 1 call init (this%datiattr%r(ndatiattrr), btable=dato%btable) type is (dbadatai) ndatiattri = ndatiattri + 1 call init (this%datiattr%i(ndatiattri), btable=dato%btable) type is (dbadatab) ndatiattrb = ndatiattrb + 1 call init (this%datiattr%b(ndatiattrb), btable=dato%btable) type is (dbadatad) ndatiattrd = ndatiattrd + 1 call init (this%datiattr%d(ndatiattrd), btable=dato%btable) type is (dbadatac) ndatiattrc = ndatiattrc + 1 call init (this%datiattr%c(ndatiattrc), btable=dato%btable) end select end associate end do ! ana var nanavarr = 0 nanavari = 0 nanavarb = 0 nanavard = 0 nanavarc = 0 do i =1 ,size(anavars%dcv) associate(dato => anavars%dcv(i)%dat) select type (dato) type is (dbadatar) nanavarr = nanavarr + 1 call init (this%anavar%r(nanavarr), btable=dato%btable) type is (dbadatai) nanavari = nanavari + 1 call init (this%anavar%i(nanavari), btable=dato%btable) type is (dbadatab) nanavarb = nanavarb + 1 call init (this%anavar%b(nanavarb), btable=dato%btable) type is (dbadatad) nanavard = nanavard + 1 call init (this%anavar%d(nanavard), btable=dato%btable) type is (dbadatac) nanavarc = nanavarc + 1 call init (this%anavar%c(nanavarc), btable=dato%btable) end select end associate end do ! ana attr nanaattrr = 0 nanaattri = 0 nanaattrb = 0 nanaattrd = 0 nanaattrc = 0 do i =1 ,size(anastarvars%dcv) associate(dato => anastarvars%dcv(i)%dat) select type (dato) type is (dbadatar) nanaattrr = nanaattrr + 1 call init (this%anaattr%r(nanaattrr), btable=dato%btable) type is (dbadatai) nanaattri = nanaattri + 1 call init (this%anaattr%i(nanaattri), btable=dato%btable) type is (dbadatab) nanaattrb = nanaattrb + 1 call init (this%anaattr%b(nanaattrb), btable=dato%btable) type is (dbadatad) nanaattrd = nanaattrd + 1 call init (this%anaattr%d(nanaattrd), btable=dato%btable) type is (dbadatac) nanaattrc = nanaattrc + 1 call init (this%anaattr%c(nanaattrc), btable=dato%btable) end select end associate end do ! here we colcolate the link from attributes and vars do i =1, size(vars%dcv) associate(dato => vars%dcv(i)%dat) if ( ndativarattri > 0 ) call init(this%dativarattr%i(i),btable=dato%btable) if ( ndativarattrr > 0 ) call init(this%dativarattr%r(i),btable=dato%btable) if ( ndativarattrd > 0 ) call init(this%dativarattr%d(i),btable=dato%btable) if ( ndativarattrb > 0 ) call init(this%dativarattr%b(i),btable=dato%btable) if ( ndativarattrc > 0 ) call init(this%dativarattr%c(i),btable=dato%btable) end associate end do do i =1, size(anavars%dcv) associate(dato => anavars%dcv(i)%dat) if ( nanavarattri > 0 ) call init(this%anavarattr%i(i),btable=dato%btable) if ( nanavarattrr > 0 ) call init(this%anavarattr%r(i),btable=dato%btable) if ( nanavarattrd > 0 ) call init(this%anavarattr%d(i),btable=dato%btable) if ( nanavarattrb > 0 ) call init(this%anavarattr%b(i),btable=dato%btable) if ( nanavarattrc > 0 ) call init(this%anavarattr%c(i),btable=dato%btable) end associate end do ! set index in dativaratt* call vol7d_set_attr_ind(this) call vol7d_alloc_vol (this) ! Ora qui bisogna metterci dentro idati indana = 0 indtime = 0 indnetwork = 0 indtime = 0 indtimerange = 0 indlevel = 0 do i =1, size(metaanddatav) indana = index_sorted(this%ana, metaanddatav(i)%metadata%ana%vol7d_ana) if (ldegnet)then indnetwork=1 else indnetwork = index_sorted(this%network, metaanddatav(i)%metadata%network%vol7d_network) endif if (c_e(metaanddatav(i)%metadata%datetime%datetime) .and. & c_e(metaanddatav(i)%metadata%timerange%vol7d_timerange) .and. & c_e(metaanddatav(i)%metadata%level%vol7d_level) ) then ! dati indtime = index_sorted(this%time, metaanddatav(i)%metadata%datetime%datetime) indtimerange = index_sorted(this%timerange, metaanddatav(i)%metadata%timerange%vol7d_timerange) indlevel = index_sorted(this%level, metaanddatav(i)%metadata%level%vol7d_level) do j=1, size(metaanddatav(i)%dataattrv%dataattr) associate(dato => metaanddatav(i)%dataattrv%dataattr(j)%dat) select type (dato) type is (dbadatai) inddativar = firsttrue(dato%btable == this%dativar%i%btable) this%voldatii( & indana,indtime,indlevel,indtimerange,inddativar,indnetwork & ) = dato%value type is (dbadatar) inddativar = firsttrue(dato%btable == this%dativar%r%btable) this%voldatir( & indana,indtime,indlevel,indtimerange,inddativar,indnetwork & ) = dato%value type is (dbadatad) inddativar = firsttrue(dato%btable == this%dativar%d%btable) this%voldatid( & indana,indtime,indlevel,indtimerange,inddativar,indnetwork & ) = dato%value type is (dbadatab) inddativar = firsttrue(dato%btable == this%dativar%b%btable) this%voldatib( & indana,indtime,indlevel,indtimerange,inddativar,indnetwork & ) = dato%value type is (dbadatac) inddativar = firsttrue(dato%btable == this%dativar%c%btable) this%voldatic( & indana,indtime,indlevel,indtimerange,inddativar,indnetwork & ) = dato%value end select ! dati attributes do k=1, size(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv) associate(attr => metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat) select type (attr) type is (dbadatai) inddativarattr = firsttrue(dato%btable == this%dativarattr%i%btable) indattrvar = firsttrue(attr%btable == this%datiattr%i%btable) this%voldatiattri( & indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar & ) = attr%value type is (dbadatar) inddativarattr = firsttrue(dato%btable == this%dativarattr%r%btable) indattrvar = firsttrue(attr%btable == this%datiattr%r%btable) this%voldatiattrr( & indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar & ) = attr%value type is (dbadatad) inddativarattr = firsttrue(dato%btable == this%dativarattr%d%btable) indattrvar = firsttrue(attr%btable == this%datiattr%d%btable) this%voldatiattrd( & indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar & ) = attr%value type is (dbadatab) inddativarattr = firsttrue(dato%btable == this%dativarattr%b%btable) indattrvar = firsttrue(attr%btable == this%datiattr%b%btable) this%voldatiattrb( & indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar & ) = attr%value type is (dbadatac) inddativarattr = firsttrue(dato%btable == this%dativarattr%c%btable) indattrvar = firsttrue(attr%btable == this%datiattr%c%btable) this%voldatiattrc( & indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar & ) = attr%value end select end associate end do end associate end do else ! ana do j=1, size(metaanddatav(i)%dataattrv%dataattr) associate(dato => metaanddatav(i)%dataattrv%dataattr(j)%dat) select type (dato) type is (dbadatai) indanavar = firsttrue(dato%btable == this%anavar%i%btable) this%volanai( & indana,indanavar,indnetwork & ) = dato%value type is (dbadatar) indanavar = firsttrue(dato%btable == this%anavar%r%btable) this%volanar( & indana,indanavar,indnetwork & ) = dato%value type is (dbadatad) indanavar = firsttrue(dato%btable == this%anavar%d%btable) this%volanad( & indana,indanavar,indnetwork & ) = dato%value type is (dbadatab) indanavar = firsttrue(dato%btable == this%anavar%b%btable) this%volanab( & indana,indanavar,indnetwork & ) = dato%value type is (dbadatac) indanavar = firsttrue(dato%btable == this%anavar%c%btable) this%volanac( & indana,indanavar,indnetwork & ) = dato%value end select ! ana attributes do k=1, size(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv) associate(attr => metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat) select type (attr) type is (dbadatai) indanavarattr = firsttrue(dato%btable == this%anavarattr%i%btable) indattrvar = firsttrue(attr%btable == this%anaattr%i%btable) this%volanaattri( & indana,indanavarattr,indnetwork,indattrvar & ) = attr%value type is (dbadatar) indanavarattr = firsttrue(dato%btable == this%anavarattr%r%btable) indattrvar = firsttrue(attr%btable == this%anaattr%r%btable) this%volanaattrr( & indana,indanavarattr,indnetwork,indattrvar & ) = attr%value type is (dbadatad) indanavarattr = firsttrue(dato%btable == this%anavarattr%d%btable) indattrvar = firsttrue(attr%btable == this%anaattr%d%btable) this%volanaattrd( & indana,indanavarattr,indnetwork,indattrvar & ) = attr%value type is (dbadatab) indanavarattr = firsttrue(dato%btable == this%anavarattr%b%btable) indattrvar = firsttrue(attr%btable == this%anaattr%b%btable) this%volanaattrb( & indana,indanavarattr,indnetwork,indattrvar & ) = attr%value type is (dbadatac) indanavarattr = firsttrue(dato%btable == this%anavarattr%c%btable) indattrvar = firsttrue(attr%btable == this%anaattr%c%btable) this%volanaattrc( & indana,indanavarattr,indnetwork,indattrvar & ) = attr%value end select end associate end do end associate end do end if end do contains !!$!> /brief Return an dbadcv from a mixlist with dbadata* type !!$function todcv_dbadat(this) !!$type(dbadcv) :: todcv_dbadat !< array !!$type(mixlist) :: this !!$ !!$integer :: i !!$ !!$allocate (todcv_dbadat%dcv(this%countelements())) !!$ !!$call this%rewind() !!$i=0 !!$do while(this%element()) !!$ i=i+1 !!$ !!$ associate (dato => this%current()) !!$ select type (dato) !!$ type is (dbadatar) !!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato) !!$ type is (dbadatai) !!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato) !!$ type is (dbadatab) !!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato) !!$ type is (dbadatad) !!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato) !!$ type is (dbadatac) !!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato) !!$ end select !!$ end associate !!$ !!$ call this%next() !!$end do !!$end function todcv_dbadat !!$! Definisce le funzioni count_distinct e pack_distinct !!$#define VOL7D_POLY_TYPE TYPE(dbadata) !!$#define VOL7D_POLY_TYPES _dbadata !!$#undef ENABLE_SORT !!$#include "array_utilities_inc.F90" !!$#undef VOL7D_POLY_TYPE !!$#undef VOL7D_POLY_TYPES end subroutine dba2v7d subroutine vol7d_dballe_import_dballevar(this) type(vol7d_var),pointer :: this(:) INTEGER :: i,un,n IF (associated(this)) return IF (allocated(blocal)) then ALLOCATE(this(size(blocal))) this=blocal return end if un = open_dballe_file('dballe.txt', filetype_data) IF (un < 0) then call l4f_log(l4f_error,"error open_dballe_file: dballe.txt") CALL raise_error("error open_dballe_file: dballe.txt") return end if n = 0 DO WHILE(.true.) READ(un,*,end=100) n = n + 1 ENDDO 100 CONTINUE IF (n > 0) THEN ALLOCATE(this(n)) ALLOCATE(blocal(n)) rewind(un) readline: do i = 1 ,n READ(un,'(1x,A6,1x,a65,a24,i4)')blocal(i)%btable,blocal(i)%description,blocal(i)%unit,& blocal(i)%scalefactor blocal(i)%btable(:1)="B" !print*,"B=",blocal(i)%btable !print*," D=",blocal(i)%description !PRINT*," U=",blocal(i)%unit !PRINT*," D=",blocal(i)%scalefactor ENDDO readline CALL l4f_log(l4f_info,'Found '//trim(to_char(i-1))//' variables in dballe master table') this=blocal ENDIF CLOSE(un) END SUBROUTINE vol7d_dballe_import_dballevar subroutine vol7d_dballe_set_var_du(this) TYPE(vol7d) :: this integer :: i,j type(vol7d_var),pointer :: dballevar(:) nullify(dballevar) call vol7d_dballe_import_dballevar(dballevar) #undef VOL7D_POLY_NAME #define VOL7D_POLY_NAME dativar #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V r #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V i #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V b #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V d #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V c #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #undef VOL7D_POLY_NAME #define VOL7D_POLY_NAME anavar #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V r #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V i #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V b #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V d #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V c #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #undef VOL7D_POLY_NAME #define VOL7D_POLY_NAME datiattr #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V r #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V i #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V b #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V d #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V c #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #undef VOL7D_POLY_NAME #define VOL7D_POLY_NAME anaattr #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V r #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V i #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V b #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V d #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V #define VOL7D_POLY_TYPES_V c #include "vol7d_dballe_class_var_du.F90" #undef VOL7D_POLY_TYPES_V deallocate(dballevar) return end subroutine vol7d_dballe_set_var_du