libsim Versione 7.1.11
volgrid6d_alchimia_class.F03
1! Copyright (C) 2012 ARPA-SIM <urpsim@smr.arpa.emr.it>
2! authors:
3! Davide Cesari <dcesari@arpa.emr.it>
4! Paolo Patruno <ppatruno@arpa.emr.it>
5
6! This program is free software; you can redistribute it and/or
7! modify it under the terms of the GNU General Public License as
8! published by the Free Software Foundation; either version 2 of
9! the License, or (at your option) any later version.
10
11! This program is distributed in the hope that it will be useful,
12! but WITHOUT ANY WARRANTY; without even the implied warranty of
13! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14! GNU General Public License for more details.
15
16! You should have received a copy of the GNU General Public License
17! along with this program. If not, see <http://www.gnu.org/licenses/>.
18
19#include "config.h"
20
21module volgrid6d_alchimia_class
22
24USE alchimia
29
30implicit NONE
31
32interface make
33 module procedure make_vg6d
34end interface
35
36interface alchemy
37 MODULE PROCEDURE alchemy_vg6dv, alchemy_vg6d
38end interface
39
40private
41public make, alchemy
42
43contains
44
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
52
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
60
61nx=vg6din%griddim%dim%nx
62ny=vg6din%griddim%dim%ny
63nlevel=size(vg6din%level)
64ntime=size(vg6din%time)
65ntimerange=size(vg6din%timerange)
66
67! we have to make a new volume with var required in input function plus var for output
68! start with input variables
69! deletenote: mybin() corresponds to vg6din%var()
70! deletenote: after 2 following big loops it is not guaranteed that all elements of mybin are in newbout
71newbout=cmiss
72
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)
80 end if
81 end if
82 end do
83 end if
84end do
85
86nvarin=count(c_e(newbout))
87
88!add output variables
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)
95 end if
96 end if
97 end do
98 end if
99end do
100
101
102nvar=count(c_e(newbout))
103
104allocate(myout(nx*ny,nvar))
105
106! create output volume
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.)
110
111! allocate vector of conversion variables
112allocate(varvg6d(nvar),source=volgrid6d_var_miss)
113allocate (varv7d(nvar),source=vol7d_var_miss)
114
115! now I copy the needed input variables from input volume to output
116DO ivar=1, nvar
117 ivarin = index_c(mybin,newbout(ivar))
118 ivarout = ivar ! why do i need to use ivarout as alias for ivar?
119
120 IF (ivarin == 0) THEN
121#ifdef DEBUG
122 CALL l4f_log(l4f_debug,"variable to compute in make_vg6d: "//newbout(ivar))
123#endif
124 cycle
125 ENDIF
126
127! delete note: varvg6d (future vg6dout%var? is filled in sparse mode? probably not because newbout
128! contains at the beginning only elements that are also in mybin
129 varvg6d(ivarout)=vg6din%var(ivarin)
130 call init(gaid_template)
131
132 DO ilevel=1,nlevel
133 DO itime=1,ntime
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))
139 ELSE
140 vg6dout%voldati(:,:,ilevel,itime,itimerange,ivarout) = &
141 vg6din%voldati(:,:,ilevel,itime,itimerange,ivarin)
142 ENDIF
143
144 CALL copy(vg6din%gaid(ilevel,itime,itimerange,ivarin), &
145 vg6dout%gaid(ilevel,itime,itimerange,ivarout))
146! save the first valid gaid for helping successive variable conversion
147 IF (.NOT.c_e(gaid_template)) &
148 gaid_template = vg6din%gaid(ilevel,itime,itimerange,ivarin)
149 ENDIF
150 ENDDO
151 ENDDO
152 ENDDO
153ENDDO
154
155! delete note: am i sure that up to now i have filled varvg6d exactly up to nvarin?
156CALL vargrib2varbufr(varvg6d(:nvarin), varv7d(:nvarin), c_funcgb)
157
158do ivar = nvarin+1, nvar
159 call init(varv7d(ivar),newbout(ivar))
160end DO
161
162CALL varbufr2vargrib(varv7d(nvarin+1:), varvg6d(nvarin+1:), c_funcbg, gaid_template)
163
164vg6dout%time=vg6din%time
165vg6dout%timerange=vg6din%timerange
166vg6dout%level=vg6din%level
167vg6dout%var=varvg6d
168
169do ilevel=1,nlevel
170 do itime=1,ntime
171 do itimerange=1,ntimerange
172 do i=size(mayvfn%fnds),1,-1
173
174 if (c_e(mayvfn%fnds(i)) .and. .not. match(mayvfn%fnds(i)%name,"copy*") ) then
175#ifdef DEBUG
176 call l4f_log(l4f_debug,"execute function: "//mayvfn%fnds(i)%name)
177#endif
178 myin=reshape(vg6dout%voldati(:,:,ilevel,itime,itimerange,:),(/nx*ny,nvar/))
179
180 IF (ASSOCIATED(c_funcgb)) THEN
181 DO ivar = 1, nvarin
182 call compute(c_funcgb(ivar),myin(:,ivar))
183 ENDDO
184 else
185 myin=rmiss
186 ENDIF
187
188 myout=myin
189
190 call mayvfn%fnds(i)%fn(newbout,newbout,mayvfn%fnds(i)%bin,mayvfn%fnds(i)%bout,myin,myout)
191
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))
196 ENDDO
197 else
198 myout=rmiss
199 ENDIF
200
201 vg6dout%voldati(:,:,ilevel,itime,itimerange,:)=reshape(myout,(/nx,ny,nvar/))
202
203 !search gaid to clone starting from input function variables
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)) ! search in original fields
207 if (ivarin > 0) ivarin = index_c(newbout,mybin(ivarin)) ! if found i get it from already cloned ones in output volume
208 if (ivarin > 0) exit
209 end do
210 if (ivarin == 0) ivarin=firsttrue(c_e(vg6dout%gaid(ilevel,itime,itimerange,:))) ! if not found is enought from one present variables
211 ivarout = index_c(newbout,mayvfn%fnds(i)%bout(ivar))
212
213 IF (ivarin > 0 .AND. ivarout > 0) THEN
214!print *, "DDD search",newbout(ivarout)
215!print *, "DDD index",index_c(mybout,newbout(ivarout))
216!if ( index_c(mybout,newbout(ivarout)) > 0)then
217! the following identity happened and generated invalid grib id error
218! is it a reasonable case or a bug?
219 IF (ivarin /= ivarout) &
220 CALL copy(vg6dout%gaid(ilevel,itime,itimerange,ivarin), &
221 vg6dout%gaid(ilevel,itime,itimerange,ivarout))
222
223#ifdef HAVE_LIBGRIBAPI
224 if (c_e(grid_id_get_gaid(vg6dout%gaid(ilevel,itime,itimerange,ivarout)))) then
225 !if (.not. match(mayvfn%fnds(i)%name,"copy*")) then
226 !print*,"force bit number to 24"
227 call grib_set(grid_id_get_gaid(vg6dout%gaid(ilevel,itime,itimerange,ivarout)),"bitsPerValue",24)
228 end if
229#endif
230 !end if
231 end if
232 end do
233 end if
234 end do
235 end do
236 end do
237end do
238
239
240if (.not. optio_log(allvarcomputed)) then
241 do ivar=1, nvar
242 if (index_c(mybout,newbout(ivar)) <= 0) then
243 do ilevel=1,nlevel
244 do itime=1,ntime
245 do itimerange=1,ntimerange
246 call delete(vg6dout%gaid(ilevel,itime,itimerange,ivar))
247 end do
248 end do
249 end do
250 end if
251 end do
252end if
253
254DEALLOCATE(c_funcgb)
255DEALLOCATE(c_funcbg)
256deallocate (varv7d,varvg6d)
257
258end subroutine make_vg6d
259
260
261integer function alchemy_vg6dv(myin,vfn,mybout,myout,copy,vfnoracle,allvarcomputed)
262
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
270
271integer :: i,j,nvar
272type(fndsv) :: myvfn,vfntmp
273character(len=10), allocatable:: mybin(:)
274TYPE(conv_func), pointer :: c_func(:)
275TYPE(vol7d_var),allocatable :: varv7d(:)
276
277alchemy_vg6dv=0
278
279allocate(myout(size(myin)))
280
281do i=1,size(myin)
282
283 alchemy_vg6dv = alchemy(myin(i),vfn,mybout,myout(i),copy,vfnoracle,allvarcomputed)
284 IF (alchemy_vg6dv /= 0) RETURN
285end do
286
287end function alchemy_vg6dv
288
289integer function alchemy_vg6d(myin,vfn,mybout,myout,copy,vfnoracle,allvarcomputed)
290
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
298
299integer :: j,nvar
300type(fndsv) :: myvfn,vfntmp
301character(len=10), allocatable:: mybin(:)
302TYPE(conv_func), pointer :: c_func(:)
303TYPE(vol7d_var),allocatable :: varv7d(:)
304
305alchemy_vg6d=0
306
307 nvar=size(myin%var)
308 allocate(varv7d(nvar))
309 CALL vargrib2varbufr(myin%var, varv7d, c_func)
310
311 DEALLOCATE(c_func)
312
313 !print *,"varv7d"
314 !print *,varv7d
315
316 mybin=varv7d(:)%btable
317 deallocate(varv7d)
318
319 vfntmp=vfn
320 if (optio_log(copy)) call register_copy(vfntmp,mybin)
321
322
323 do j=1,size(mybin)
324 call l4f_log(l4f_info,"alchemy_vg6d: I have: "//mybin(j))
325 end do
326
327 do j=1,size(mybout)
328 call l4f_log(l4f_info,"alchemy_vg6d: To make: "//mybout(j))
329 end do
330
331 if (.not. oracle(mybin,mybout,vfntmp,myvfn)) then
332 call l4f_log(l4f_warn,"alchemy_vg6d: I cannot make your request")
333 alchemy_vg6d = 1
334 if(.not. shoppinglist(mybout,vfntmp,myvfn,copy=optio_log(copy))) then
335 call l4f_log(l4f_warn,"shoppinglist: return error status")
336 alchemy_vg6d = 2
337 end if
338 if (present(vfnoracle))vfnoracle=myvfn
339 return
340 end if
341
342 if (present(vfnoracle))vfnoracle=myvfn
343
344 !call display(myvfn)
345 call l4f_log(l4f_info,"alchemy_vg6d: I need "//t2c(myvfn%nout)//" more variables")
346
347 call make(myvfn,mybin,mybout,myin,myout, allvarcomputed)
348
349 call delete(myvfn)
350 call delete(vfntmp)
351
352end function alchemy_vg6d
353
354end module volgrid6d_alchimia_class
Check missing values for fnds.
Definition: alchimia.F03:271
Delete fndsv.
Definition: alchimia.F03:289
Make a deep copy, if possible, of the grid identifier.
This module defines objects and methods for generating derivative variables.
Definition: alchimia.F03:220
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.

Generated with Doxygen.