21 module volgrid6d_alchimia_class
33 module procedure make_vg6d
37 MODULE PROCEDURE alchemy_vg6dv, 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)
73 do 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)
86 nvarin=count(
c_e(newbout))
89 do 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)
102 nvar=count(
c_e(newbout))
104 allocate(myout(nx*ny,nvar))
107 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
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)
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 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)
240 if (.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))
256 deallocate (varv7d,varvg6d)
258 end subroutine make_vg6d
261 integer function alchemy_vg6dv(myin,vfn,mybout,myout,copy,vfnoracle,allvarcomputed)
263 character(len=*),
intent(in) :: mybout(:)
264 type(fndsv),
intent(in) :: vfn
266 type(volgrid6d),
intent(out),
pointer ::myout(:)
267 logical,
intent(in),
optional ::
copy
268 type(
fndsv),
intent(out),
optional :: vfnoracle
269 logical,
optional :: allvarcomputed
272 type(fndsv) :: myvfn,vfntmp
273 character(len=10),
allocatable:: mybin(:)
279 allocate(myout(
size(myin)))
283 alchemy_vg6dv = alchemy(myin(i),vfn,mybout,myout(i),
copy,vfnoracle,allvarcomputed)
284 IF (alchemy_vg6dv /= 0)
RETURN
287 end function alchemy_vg6dv
289 integer function alchemy_vg6d(myin,vfn,mybout,myout,copy,vfnoracle,allvarcomputed)
291 character(len=*),
intent(in) :: mybout(:)
292 type(fndsv),
intent(in) :: vfn
295 logical,
intent(in),
optional ::
copy
296 type(
fndsv),
intent(out),
optional :: vfnoracle
297 logical,
optional :: allvarcomputed
300 type(fndsv) :: myvfn,vfntmp
301 character(len=10),
allocatable:: mybin(:)
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)
352 end function alchemy_vg6d
354 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.