1module vol7d_alchimia_class
13 module procedure make_v7d
17 module procedure alchemy_v7d
21public make, alchemy, v7d_all_var, sl_display_pretty
26function pretty_var(var)
27CHARACTER(len=80) :: pretty_var
28character(len=*) :: var
33TYPE(vol7d_var),
pointer,
save :: dballevar(:) => null()
35call vol7d_dballe_import_dballevar(dballevar)
36ind=index_c(dballevar(:)%btable,var)
39 pretty_var=dballevar(ind)%description
48end function pretty_var
51subroutine make_v7d(mayvfn,mybin,mybout,v7din,v7dout)
52type(fndsv),
intent(inout) :: mayvfn
53character(len=*),
intent(in) :: mybin(:),mybout(:)
54type(vol7d),
intent(inout) :: v7din
55type(vol7d),
intent(out) :: v7dout
56integer :: i,j,nana,nlevel,ntime,ntimerange,nvarin,nvarout,nnetwork
57integer :: ilevel,itime,itimerange,inetwork,ivar,ind,ivarin,ivarout
59character(len=1) :: type
60character(len=10) :: newbout(mayvfn%nout+mayvfn%nin)
64nlevel=
size(v7din%level)
65ntimerange=
size(v7din%timerange)
66nnetwork=
size(v7din%network)
68call copy (v7din,v7dout,&
69 ldativarr=(/.false./),&
70 ldativari=(/.false./),&
71 ldativard=(/.false./),&
72 ldativarb=(/.false./),&
73 ldativarc=(/.false./))
80do i=1,
size(mayvfn%fnds)
81 if (
c_e(mayvfn%fnds(i)))
then
82 do j=1,
size(mayvfn%fnds(i)%bin)
83 if (
c_e(mayvfn%fnds(i)%bin(j)))
then
84 if (index_c(mybin,mayvfn%fnds(i)%bin(j)) <= 0)cycle
85 if (index_c(newbout,mayvfn%fnds(i)%bin(j)) <= 0)
then
86 newbout(index_c(newbout,cmiss)) = mayvfn%fnds(i)%bin(j)
93nvarin=count(
c_e(newbout))
96do i=1,
size(mayvfn%fnds)
97 if (
c_e(mayvfn%fnds(i)))
then
98 do j=1,
size(mayvfn%fnds(i)%bout)
99 if (
c_e(mayvfn%fnds(i)%bout(j)))
then
100 if (index_c(newbout,mayvfn%fnds(i)%bout(j)) <= 0)
then
101 newbout(index_c(newbout,cmiss)) = mayvfn%fnds(i)%bout(j)
108nvarout=count(
c_e(newbout))
110call vol7d_alloc(v7dout, ndativarr=nvarout)
113 call init(v7dout%dativar%r(ivar),btable=newbout(ivar))
116call vol7d_alloc_vol(v7dout,inivol=.true.)
123 ivarin = index_c(mybin,newbout(ivar))
126 call init(var, btable=newbout(ivarout))
129 ind =
index(v7din%dativar, var, type=type)
134 v7dout%voldatir(:,:,:,:,ivarout,:)= &
135 realdat(v7din%voldatid(:,:,:,:,ind,:),v7din%dativar%d(ind))
137 v7dout%voldatir(:,:,:,:,ivarout,:)= &
138 realdat(v7din%voldatir(:,:,:,:,ind,:),v7din%dativar%r(ind))
140 v7dout%voldatir(:,:,:,:,ivarout,:)= &
141 realdat(v7din%voldatii(:,:,:,:,ind,:),v7din%dativar%i(ind))
143 v7dout%voldatir(:,:,:,:,ivarout,:)= &
144 realdat(v7din%voldatib(:,:,:,:,ind,:),v7din%dativar%b(ind))
146 v7dout%voldatir(:,:,:,:,ivarout,:)= &
147 realdat(v7din%voldatic(:,:,:,:,ind,:),v7din%dativar%c(ind))
150 v7dout%voldatir(:,:,:,:,ivarout,:)=rmiss
156do i=
size(mayvfn%fnds),1,-1
157 if (
c_e(mayvfn%fnds(i)) .and. .not. match(mayvfn%fnds(i)%name,
"copy*") )
then
160 call l4f_log(l4f_debug,
"execute function: "//mayvfn%fnds(i)%name)
165 do itimerange=1,ntimerange
166 do inetwork=1,nnetwork
167 call mayvfn%fnds(i)%fn(newbout,newbout,mayvfn%fnds(i)%bin,mayvfn%fnds(i)%bout,&
168 v7dout%voldatir(:,itime,ilevel,itimerange,:,inetwork),&
169 v7dout%voldatir(:,itime,ilevel,itimerange,:,inetwork))
178end subroutine make_v7d
181subroutine v7d_all_var(myin,mybin)
183type(vol7d),
intent(in) :: myin
184character(len=10),
allocatable:: mybin(:)
189if (
associated(myin%dativar%r)) nbin = nbin +
size(myin%dativar%r)
190if (
associated(myin%dativar%i)) nbin = nbin +
size(myin%dativar%i)
191if (
associated(myin%dativar%d)) nbin = nbin +
size(myin%dativar%d)
192if (
associated(myin%dativar%b)) nbin = nbin +
size(myin%dativar%b)
193if (
associated(myin%dativar%c)) nbin = nbin +
size(myin%dativar%c)
195allocate (mybin(nbin))
198if (
associated(myin%dativar%r))
then
199 nbinn=nbin+
size(myin%dativar%r)
200 mybin(nbin+1:nbinn) = myin%dativar%r(:)%btable
204if (
associated(myin%dativar%i))
then
205 nbinn=nbin+
size(myin%dativar%i)
206 mybin(nbin+1:nbinn) = myin%dativar%i(:)%btable
210if (
associated(myin%dativar%d))
then
211 nbinn=nbin+
size(myin%dativar%d)
212 mybin(nbin+1:nbinn) = myin%dativar%d(:)%btable
216if (
associated(myin%dativar%b))
then
217 nbinn=nbin+
size(myin%dativar%b)
218 mybin(nbin+1:nbinn) = myin%dativar%b(:)%btable
222if (
associated(myin%dativar%c))
then
223 nbinn=nbin+
size(myin%dativar%c)
224 mybin(nbin+1:nbinn) = myin%dativar%c(:)%btable
228end subroutine v7d_all_var
231integer function alchemy_v7d(myin,vfn,mybout,myout,copy,vfnoracle)
233character(len=10),
intent(in) :: mybout(:)
234type(fndsv),
intent(in) :: vfn
235type(vol7d),
intent(inout) :: myin
236type(vol7d),
intent(out) :: myout
237logical,
intent(in),
optional :: copy
238type(fndsv),
intent(out),
optional :: vfnoracle
241type(fndsv) :: vfntmp, myvfn
242character(len=10),
allocatable:: mybin(:)
246call v7d_all_var(myin,mybin)
249if (optio_log(
copy))
call register_copy(vfntmp,mybin)
252 call l4f_log(l4f_info,
"alchemy_v7d: I have: "//mybin(i))
256 call l4f_log(l4f_info,
"alchemy_v7d: To make: "//mybout(i))
259if (.not. oracle(mybin,mybout,vfntmp,myvfn))
then
260 call l4f_log(l4f_warn,
"alchemy_v7d: I cannot make your request")
262 if(.not. shoppinglist(mybout,vfntmp,myvfn,
copy=optio_log(
copy)))
then
263 call l4f_log(l4f_warn,
"shoppinglist: return error status")
266 if (
present(vfnoracle)) vfnoracle=myvfn
270if (
present(vfnoracle)) vfnoracle=myvfn
273call l4f_log(l4f_info,
"alchemy_v7d: I need "//t2c(myvfn%nout)//
" variables")
275call make(myvfn,mybin,mybout,myin,myout)
280end function alchemy_v7d
284subroutine sl_display_pretty(sl)
285type(shoplists),
intent(in) :: sl
289do i = 1,
size(sl%shoplist)
290 print *,
"shopping list : ",i
291 do j=1,
size(sl%shoplist(i)%bvar)
292 print *,
"required var : ",sl%shoplist(i)%bvar(j),
" -> ",pretty_var(sl%shoplist(i)%bvar(j))
297end subroutine sl_display_pretty
300end module vol7d_alchimia_class
Check missing values for fnds.
This module defines objects and methods for generating derivative variables.
classe per la gestione del logging
Classe per la gestione di un volume completo di dati osservati.
classe per import ed export di volumi da e in DB-All.e