21 module volgrid6d_alchimia_class
33 module procedure make_vg6d
37 module procedure alchemy_vg6d
45 subroutine make_vg6d(mayvfn,mybin,mybout,vg6din,vg6dout,allvarcomputed)
46 type(fndsv),
intent(inout) :: mayvfn
47 character(len=*),
intent(in) :: mybin(:),mybout(:)
50 TYPE(conv_func),
pointer :: c_funcgb(:),c_funcbg(:)
51 logical,
optional :: allvarcomputed
53 integer :: i,j,nx,ny,nlevel,ntime,ntimerange,nvar,nvarin
54 integer :: ilevel,itime,itimerange,ivar,ivarin,ivarout
55 real,
allocatable :: myin(:,:),myout(:,:)
56 character(len=10) :: newbout(mayvfn%nout+mayvfn%nin)
61 nx=vg6din%griddim%dim%nx
62 ny=vg6din%griddim%dim%ny
63 nlevel=
size(vg6din%level)
64 ntime=
size(vg6din%time)
65 ntimerange=
size(vg6din%timerange)
72 do i=1,
size(mayvfn%fnds)
73 if (
c_e(mayvfn%fnds(i)))
then
74 do j=1,
size(mayvfn%fnds(i)%bin)
75 if (
c_e(mayvfn%fnds(i)%bin(j)))
then
76 if (index_c(mybin,mayvfn%fnds(i)%bin(j)) == 0)cycle
77 if (index_c(newbout,mayvfn%fnds(i)%bin(j)) <= 0)
then
78 newbout(index_c(newbout,cmiss)) = mayvfn%fnds(i)%bin(j)
85 nvarin=count(
c_e(newbout))
88 do i=1,
size(mayvfn%fnds)
89 if (
c_e(mayvfn%fnds(i)))
then
90 do j=1,
size(mayvfn%fnds(i)%bout)
91 if (
c_e(mayvfn%fnds(i)%bout(j)))
then
92 if (index_c(newbout,mayvfn%fnds(i)%bout(j)) <= 0)
then
93 newbout(index_c(newbout,cmiss)) = mayvfn%fnds(i)%bout(j)
101 nvar=count(
c_e(newbout))
103 allocate(myout(nx*ny,nvar))
106 call
init(vg6dout, vg6din%griddim, vg6din%time_definition, categoryappend=
"generated by alchimia make")
108 call volgrid6d_alloc(vg6dout, ntime=ntime, nlevel=nlevel, ntimerange=ntimerange, nvar=nvar)
109 call volgrid6d_alloc_vol(vg6dout,inivol=.true.,decode=.true.)
112 allocate(varvg6d(nvar),source=volgrid6d_var_miss)
113 allocate (varv7d(nvar),source=vol7d_var_miss)
117 ivarin = index_c(mybin,newbout(ivar))
120 if (ivarin == 0)
then
121 call l4f_log(l4f_debug,
"variable to compute in make_vg6d: "//newbout(ivar))
125 varvg6d(ivarout)=vg6din%var(ivarin)
126 call
init(gaid_template)
130 do itimerange=1,ntimerange
131 if ( .not.
ASSOCIATED(vg6din%voldati))
then
133 CALL grid_id_decode_data(vg6din%gaid(ilevel,itime,itimerange,ivarin),&
134 vg6dout%voldati(:,:,ilevel,itime,itimerange,ivarout))
136 vg6dout%voldati(:,:,ilevel,itime,itimerange,ivarout)=vg6din%voldati(:,:,ilevel,itime,itimerange,ivarin)
139 call
copy(vg6din%gaid(ilevel,itime,itimerange,ivarin), vg6dout%gaid(ilevel,itime,itimerange,ivarout))
141 IF (.NOT.
c_e(gaid_template) .AND. &
142 c_e(vg6din%gaid(ilevel,itime,itimerange,ivarin))) &
143 gaid_template = vg6din%gaid(ilevel,itime,itimerange,ivarin)
156 CALL vargrib2varbufr(varvg6d(:nvarin), varv7d(:nvarin), c_funcgb)
158 do ivar = nvarin+1, nvar
159 call
init(varv7d(ivar),newbout(ivar))
162 CALL varbufr2vargrib(varv7d(nvarin+1:), varvg6d(nvarin+1:), c_funcbg, gaid_template)
164 vg6dout%time=vg6din%time
165 vg6dout%timerange=vg6din%timerange
166 vg6dout%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 call
copy(vg6dout%gaid(ilevel,itime,itimerange,ivarin), vg6dout%gaid(ilevel,itime,itimerange,ivarout))
221 #ifdef HAVE_LIBGRIBAPI
222 if (
c_e(grid_id_get_gaid(vg6dout%gaid(ilevel,itime,itimerange,ivarout))))
then
225 call grib_set(grid_id_get_gaid(vg6dout%gaid(ilevel,itime,itimerange,ivarout)),
"bitsPerValue",24)
238 if (.not. optio_log(allvarcomputed))
then
240 if (index_c(mybout,newbout(ivar)) <= 0)
then
243 do itimerange=1,ntimerange
244 call
delete(vg6dout%gaid(ilevel,itime,itimerange,ivar))
254 deallocate (varv7d,varvg6d)
256 end subroutine make_vg6d
259 integer function alchemy_vg6d(myin,vfn,mybout,myout,copy,vfnoracle,allvarcomputed)
261 character(len=*),
intent(in) :: mybout(:)
262 type(fndsv),
intent(in) :: vfn
264 type(volgrid6d),
intent(out),
pointer ::myout(:)
265 logical,
intent(in),
optional ::
copy
266 type(
fndsv),
intent(out),
optional :: vfnoracle
267 logical,
optional :: allvarcomputed
270 type(fndsv) :: myvfn,vfntmp
271 character(len=10),
allocatable:: mybin(:)
277 allocate(myout(
size(myin)))
281 nvar=
size(myin(i)%var)
282 allocate(varv7d(nvar))
283 CALL vargrib2varbufr(myin(i)%var, varv7d, c_func)
290 mybin=varv7d(:)%btable
294 if (optio_log(
copy)) call register_copy(vfntmp,mybin)
298 call l4f_log(l4f_info,
"alchemy_vg6d: I have: "//mybin(j))
302 call l4f_log(l4f_info,
"alchemy_vg6d: To make: "//mybout(j))
305 if (.not. oracle(mybin,mybout,vfntmp,myvfn))
then
306 call l4f_log(l4f_warn,
"alchemy_vg6d: I cannot make your request")
308 if(.not. shoppinglist(mybout,vfntmp,myvfn,
copy=optio_log(
copy)))
then
309 call l4f_log(l4f_warn,
"shoppinglist: return error status")
312 if (present(vfnoracle))vfnoracle=myvfn
316 if (present(vfnoracle))vfnoracle=myvfn
319 call l4f_log(l4f_info,
"alchemy_vg6d: I need "//
t2c(myvfn%nout)//
" more variables")
321 call make(myvfn,mybin,mybout,myin(i),myout(i), allvarcomputed)
331 end function alchemy_vg6d
333 end module volgrid6d_alchimia_class
Functions that return a trimmed CHARACTER representation of the input variable.
Derived type associated to a block/message/record/band of gridded data coming from a file-like object...
Definition of a physical variable in grib coding style.
This module defines an abstract interface to different drivers for access to files containing gridded...
Tries to match the given string with the pattern Result: .true.
Object describing a rectangular, homogeneous gridded dataset.
Vector of function to transform the input to alchimia module.
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...
Distruttori per le 2 classi.
Costruttori per le classi datetime e timedelta.
This module defines objects and methods for generating derivative variables.
Copy an object, creating a fully new instance.
Class for managing physical variables in a grib 1/2 fashion.
Definisce una variabile meteorologica osservata o un suo attributo.
Class defining a real conversion function between units.
This module defines usefull general purpose function and subroutine.