21module volgrid6d_alchimia_class
33 module procedure make_vg6d
37 MODULE PROCEDURE alchemy_vg6dv, alchemy_vg6d
45subroutine make_vg6d(mayvfn,mybin,mybout,vg6din,vg6dout,allvarcomputed)
46type(fndsv),
intent(inout) :: mayvfn
47character(len=*),
intent(in) :: mybin(:),mybout(:)
48type(volgrid6d),
intent(in) :: vg6din
49type(volgrid6d),
intent(out) :: vg6dout
50TYPE(conv_func),
pointer :: c_funcgb(:),c_funcbg(:)
51logical,
optional :: allvarcomputed
53integer :: i,j,nx,ny,nlevel,ntime,ntimerange,nvar,nvarin
54integer :: ilevel,itime,itimerange,ivar,ivarin,ivarout
55real,
allocatable :: myin(:,:),myout(:,:)
56character(len=10) :: newbout(mayvfn%nout+mayvfn%nin)
57TYPE(vol7d_var),
allocatable :: varv7d(:)
58TYPE(volgrid6d_var),
allocatable :: varvg6d(:)
59TYPE(grid_id) :: gaid_template
61nx=vg6din%griddim%dim%nx
62ny=vg6din%griddim%dim%ny
63nlevel=
size(vg6din%level)
64ntime=
size(vg6din%time)
65ntimerange=
size(vg6din%timerange)
73do i=1,
size(mayvfn%fnds)
74 if (
c_e(mayvfn%fnds(i)))
then
75 do j=1,
size(mayvfn%fnds(i)%bin)
76 if (
c_e(mayvfn%fnds(i)%bin(j)))
then
77 if (index_c(mybin,mayvfn%fnds(i)%bin(j)) == 0)cycle
78 if (index_c(newbout,mayvfn%fnds(i)%bin(j)) <= 0)
then
79 newbout(index_c(newbout,cmiss)) = mayvfn%fnds(i)%bin(j)
86nvarin=count(
c_e(newbout))
89do i=1,
size(mayvfn%fnds)
90 if (
c_e(mayvfn%fnds(i)))
then
91 do j=1,
size(mayvfn%fnds(i)%bout)
92 if (
c_e(mayvfn%fnds(i)%bout(j)))
then
93 if (index_c(newbout,mayvfn%fnds(i)%bout(j)) <= 0)
then
94 newbout(index_c(newbout,cmiss)) = mayvfn%fnds(i)%bout(j)
102nvar=count(
c_e(newbout))
104allocate(myout(nx*ny,nvar))
107call init(vg6dout, vg6din%griddim, vg6din%time_definition, categoryappend=
"generated by alchimia make")
108call volgrid6d_alloc(vg6dout, ntime=ntime, nlevel=nlevel, ntimerange=ntimerange, nvar=nvar)
109call volgrid6d_alloc_vol(vg6dout,inivol=.true.,decode=.true.)
112allocate(varvg6d(nvar),source=volgrid6d_var_miss)
113allocate (varv7d(nvar),source=vol7d_var_miss)
117 ivarin = index_c(mybin,newbout(ivar))
120 IF (ivarin == 0)
THEN
122 CALL l4f_log(l4f_debug,
"variable to compute in make_vg6d: "//newbout(ivar))
129 varvg6d(ivarout)=vg6din%var(ivarin)
130 call init(gaid_template)
134 DO itimerange=1,ntimerange
135 IF (
c_e(vg6din%gaid(ilevel,itime,itimerange,ivarin)))
THEN
136 IF (.NOT.
ASSOCIATED(vg6din%voldati))
THEN
137 CALL grid_id_decode_data(vg6din%gaid(ilevel,itime,itimerange,ivarin),&
138 vg6dout%voldati(:,:,ilevel,itime,itimerange,ivarout))
140 vg6dout%voldati(:,:,ilevel,itime,itimerange,ivarout) = &
141 vg6din%voldati(:,:,ilevel,itime,itimerange,ivarin)
144 CALL copy(vg6din%gaid(ilevel,itime,itimerange,ivarin), &
145 vg6dout%gaid(ilevel,itime,itimerange,ivarout))
147 IF (.NOT.
c_e(gaid_template)) &
148 gaid_template = vg6din%gaid(ilevel,itime,itimerange,ivarin)
156CALL vargrib2varbufr(varvg6d(:nvarin), varv7d(:nvarin), c_funcgb)
158do ivar = nvarin+1, nvar
159 call init(varv7d(ivar),newbout(ivar))
162CALL varbufr2vargrib(varv7d(nvarin+1:), varvg6d(nvarin+1:), c_funcbg, gaid_template)
164vg6dout%time=vg6din%time
165vg6dout%timerange=vg6din%timerange
166vg6dout%level=vg6din%level
171 do itimerange=1,ntimerange
172 do i=
size(mayvfn%fnds),1,-1
174 if (
c_e(mayvfn%fnds(i)) .and. .not. match(mayvfn%fnds(i)%name,
"copy*") )
then
176 call l4f_log(l4f_debug,
"execute function: "//mayvfn%fnds(i)%name)
178 myin=reshape(vg6dout%voldati(:,:,ilevel,itime,itimerange,:),(/nx*ny,nvar/))
180 IF (
ASSOCIATED(c_funcgb))
THEN
182 call compute(c_funcgb(ivar),myin(:,ivar))
190 call mayvfn%fnds(i)%fn(newbout,newbout,mayvfn%fnds(i)%bin,mayvfn%fnds(i)%bout,myin,myout)
192 IF (
ASSOCIATED(c_funcbg))
THEN
193 DO ivar = 1,
size(mayvfn%fnds(i)%bout)
194 ivarout = index_c(newbout,mayvfn%fnds(i)%bout(ivar))
195 if (ivarout > nvarin)
call compute(c_funcbg(ivarout-nvarin),myout(:,ivarout))
201 vg6dout%voldati(:,:,ilevel,itime,itimerange,:)=reshape(myout,(/nx,ny,nvar/))
204 do ivar=1,
size(mayvfn%fnds(i)%bout)
205 do j=1,
size(mayvfn%fnds(i)%bin)
206 ivarin = index_c(mybin,mayvfn%fnds(i)%bin(j))
207 if (ivarin > 0) ivarin = index_c(newbout,mybin(ivarin))
210 if (ivarin == 0) ivarin=firsttrue(
c_e(vg6dout%gaid(ilevel,itime,itimerange,:)))
211 ivarout = index_c(newbout,mayvfn%fnds(i)%bout(ivar))
213 IF (ivarin > 0 .AND. ivarout > 0)
THEN
219 IF (ivarin /= ivarout) &
220 CALL copy(vg6dout%gaid(ilevel,itime,itimerange,ivarin), &
221 vg6dout%gaid(ilevel,itime,itimerange,ivarout))
223#ifdef HAVE_LIBGRIBAPI
224 if (
c_e(grid_id_get_gaid(vg6dout%gaid(ilevel,itime,itimerange,ivarout))))
then
227 call grib_set(grid_id_get_gaid(vg6dout%gaid(ilevel,itime,itimerange,ivarout)),
"bitsPerValue",24)
240if (.not. optio_log(allvarcomputed))
then
242 if (index_c(mybout,newbout(ivar)) <= 0)
then
245 do itimerange=1,ntimerange
246 call delete(vg6dout%gaid(ilevel,itime,itimerange,ivar))
256deallocate (varv7d,varvg6d)
258end subroutine make_vg6d
261integer function alchemy_vg6dv(myin,vfn,mybout,myout,copy,vfnoracle,allvarcomputed)
263character(len=*),
intent(in) :: mybout(:)
264type(fndsv),
intent(in) :: vfn
265type(volgrid6d),
intent(in) :: myin(:)
266type(volgrid6d),
intent(out),
pointer ::myout(:)
267logical,
intent(in),
optional :: copy
268type(fndsv),
intent(out),
optional :: vfnoracle
269logical,
optional :: allvarcomputed
272type(fndsv) :: myvfn,vfntmp
273character(len=10),
allocatable:: mybin(:)
274TYPE(conv_func),
pointer :: c_func(:)
275TYPE(vol7d_var),
allocatable :: varv7d(:)
279allocate(myout(
size(myin)))
283 alchemy_vg6dv = alchemy(myin(i),vfn,mybout,myout(i),
copy,vfnoracle,allvarcomputed)
284 IF (alchemy_vg6dv /= 0)
RETURN
287end function alchemy_vg6dv
289integer function alchemy_vg6d(myin,vfn,mybout,myout,copy,vfnoracle,allvarcomputed)
291character(len=*),
intent(in) :: mybout(:)
292type(fndsv),
intent(in) :: vfn
293type(volgrid6d),
intent(in) :: myin
294type(volgrid6d),
intent(out) ::myout
295logical,
intent(in),
optional :: copy
296type(fndsv),
intent(out),
optional :: vfnoracle
297logical,
optional :: allvarcomputed
300type(fndsv) :: myvfn,vfntmp
301character(len=10),
allocatable:: mybin(:)
302TYPE(conv_func),
pointer :: c_func(:)
303TYPE(vol7d_var),
allocatable :: varv7d(:)
308 allocate(varv7d(nvar))
309 CALL vargrib2varbufr(myin%var, varv7d, c_func)
316 mybin=varv7d(:)%btable
320 if (optio_log(
copy))
call register_copy(vfntmp,mybin)
324 call l4f_log(l4f_info,
"alchemy_vg6d: I have: "//mybin(j))
328 call l4f_log(l4f_info,
"alchemy_vg6d: To make: "//mybout(j))
331 if (.not. oracle(mybin,mybout,vfntmp,myvfn))
then
332 call l4f_log(l4f_warn,
"alchemy_vg6d: I cannot make your request")
334 if(.not. shoppinglist(mybout,vfntmp,myvfn,
copy=optio_log(
copy)))
then
335 call l4f_log(l4f_warn,
"shoppinglist: return error status")
338 if (
present(vfnoracle))vfnoracle=myvfn
342 if (
present(vfnoracle))vfnoracle=myvfn
345 call l4f_log(l4f_info,
"alchemy_vg6d: I need "//t2c(myvfn%nout)//
" more variables")
347 call make(myvfn,mybin,mybout,myin,myout, allvarcomputed)
352end function alchemy_vg6d
354end module volgrid6d_alchimia_class
Check missing values for fnds.
Make a deep copy, if possible, of the grid identifier.
This module defines objects and methods for generating derivative variables.
This module defines usefull general purpose function and subroutine.
This module defines an abstract interface to different drivers for access to files containing gridded...
Classe per la gestione delle variabili osservate da stazioni meteo e affini.
This module defines objects and methods for managing data volumes on rectangular georeferenced grids.
Class for managing physical variables in a grib 1/2 fashion.