libsim  Versione6.3.0
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 
21 module volgrid6d_alchimia_class
22 
24 USE alchimia
25 USE grid_id_class
29 
30 implicit NONE
31 
32 interface make
33  module procedure make_vg6d
34 end interface
35 
36 interface alchemy
37  module procedure alchemy_vg6d
38 end interface
39 
40 private
41 public make, alchemy
42 
43 contains
44 
45 subroutine make_vg6d(mayvfn,mybin,mybout,vg6din,vg6dout,allvarcomputed)
46 type(fndsv),intent(inout) :: mayvfn
47 character(len=*),intent(in) :: mybin(:),mybout(:)
48 type(volgrid6d),intent(in) :: vg6din
49 type(volgrid6d),intent(out) :: vg6dout
50 TYPE(conv_func), pointer :: c_funcgb(:),c_funcbg(:)
51 logical, optional :: allvarcomputed
52 
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)
57 TYPE(vol7d_var),allocatable :: varv7d(:)
58 TYPE(volgrid6d_var),allocatable :: varvg6d(:)
59 TYPE(grid_id) :: gaid_template
60 
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)
66 
67 !we have to make a new volume with var required in input function plus var for output
68 
69 !star with input variables
70 newbout=cmiss
71 
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)
79  end if
80  end if
81  end do
82  end if
83 end do
84 
85 nvarin=count(c_e(newbout))
86 
87 !add output variables
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)
94  end if
95  end if
96  end do
97  end if
98 end do
99 
100 
101 nvar=count(c_e(newbout))
102 
103 allocate(myout(nx*ny,nvar))
104 
105 ! create output volume
106 call init(vg6dout, vg6din%griddim, vg6din%time_definition, categoryappend="generated by alchimia make")
107 !call volgrid6d_alloc(vg6dout, vg6din%griddim%dim, ntime, nlevel, ntimerange, nvar)
108 call volgrid6d_alloc(vg6dout, ntime=ntime, nlevel=nlevel, ntimerange=ntimerange, nvar=nvar)
109 call volgrid6d_alloc_vol(vg6dout,inivol=.true.,decode=.true.)
110 
111 ! allocate vector of conversion variables
112 allocate(varvg6d(nvar),source=volgrid6d_var_miss)
113 allocate (varv7d(nvar),source=vol7d_var_miss)
114 
115 ! now I copy the needed input variables from input volume to output
116 do ivar=1, nvar
117  ivarin = index_c(mybin,newbout(ivar))
118  ivarout = ivar
119 
120  if (ivarin == 0) then
121  call l4f_log(l4f_debug,"variable to compute in make_vg6d: "//newbout(ivar))
122  cycle
123  end if
124 
125  varvg6d(ivarout)=vg6din%var(ivarin)
126  call init(gaid_template)
127 
128  do ilevel=1,nlevel
129  do itime=1,ntime
130  do itimerange=1,ntimerange
131  if ( .not. ASSOCIATED(vg6din%voldati)) then
132 ! call display(vg6din%gaid(ilevel,itime,itimerange,ivar),namespace="parameter")
133  CALL grid_id_decode_data(vg6din%gaid(ilevel,itime,itimerange,ivarin),&
134  vg6dout%voldati(:,:,ilevel,itime,itimerange,ivarout))
135  else
136  vg6dout%voldati(:,:,ilevel,itime,itimerange,ivarout)=vg6din%voldati(:,:,ilevel,itime,itimerange,ivarin)
137  end if
138 
139  call copy (vg6din%gaid(ilevel,itime,itimerange,ivarin), vg6dout%gaid(ilevel,itime,itimerange,ivarout))
140 ! save the first valid gaid for helping successive variable conversion
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)
144 
145 ! print *,&
146 ! minval(vg6dout%voldati(:,:,ilevel,itime,itimerange,ivarout),&
147 ! c_e(vg6dout%voldati(:,:,ilevel,itime,itimerange,ivarout))),&
148 ! maxval(vg6dout%voldati(:,:,ilevel,itime,itimerange,ivarout),&
149 ! c_e(vg6dout%voldati(:,:,ilevel,itime,itimerange,ivarout)))
150 
151  end do
152  end do
153  end do
154 end do
155 
156 CALL vargrib2varbufr(varvg6d(:nvarin), varv7d(:nvarin), c_funcgb)
157 
158 do ivar = nvarin+1, nvar
159  call init(varv7d(ivar),newbout(ivar))
160 end DO
161 
162 CALL varbufr2vargrib(varv7d(nvarin+1:), varvg6d(nvarin+1:), c_funcbg, gaid_template)
163 
164 vg6dout%time=vg6din%time
165 vg6dout%timerange=vg6din%timerange
166 vg6dout%level=vg6din%level
167 vg6dout%var=varvg6d
168 
169 do 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 
215  !print *, "DDD search",newbout(ivarout)
216  !print *, "DDD index",index_c(mybout,newbout(ivarout))
217  !if ( index_c(mybout,newbout(ivarout)) > 0)then
218 
219  call copy (vg6dout%gaid(ilevel,itime,itimerange,ivarin), vg6dout%gaid(ilevel,itime,itimerange,ivarout))
220 
221 #ifdef HAVE_LIBGRIBAPI
222  if (c_e(grid_id_get_gaid(vg6dout%gaid(ilevel,itime,itimerange,ivarout)))) then
223  !if (.not. match(mayvfn%fnds(i)%name,"copy*")) then
224  !print*,"force bit number to 24"
225  call grib_set(grid_id_get_gaid(vg6dout%gaid(ilevel,itime,itimerange,ivarout)),"bitsPerValue",24)
226  end if
227 #endif
228  !end if
229  end if
230  end do
231  end if
232  end do
233  end do
234  end do
235 end do
236 
237 
238 if (.not. optio_log(allvarcomputed)) then
239  do ivar=1, nvar
240  if (index_c(mybout,newbout(ivar)) <= 0) then
241  do ilevel=1,nlevel
242  do itime=1,ntime
243  do itimerange=1,ntimerange
244  call delete(vg6dout%gaid(ilevel,itime,itimerange,ivar))
245  end do
246  end do
247  end do
248  end if
249  end do
250 end if
251 
252 DEALLOCATE(c_funcgb)
253 DEALLOCATE(c_funcbg)
254 deallocate (varv7d,varvg6d)
255 
256 end subroutine make_vg6d
257 
258 
259 integer function alchemy_vg6d(myin,vfn,mybout,myout,copy,vfnoracle,allvarcomputed)
260 
261 character(len=*),intent(in) :: mybout(:)
262 type(fndsv),intent(in) :: vfn
263 type(volgrid6d),intent(in) :: myin(:)
264 type(volgrid6d),intent(out),pointer ::myout(:)
265 logical,intent(in),optional :: copy
266 type(fndsv),intent(out),optional :: vfnoracle
267 logical, optional :: allvarcomputed
268 
269 integer :: i,j,nvar
270 type(fndsv) :: myvfn,vfntmp
271 character(len=10), allocatable:: mybin(:)
272 TYPE(conv_func), pointer :: c_func(:)
273 TYPE(vol7d_var),allocatable :: varv7d(:)
274 
275 alchemy_vg6d=0
276 
277 allocate(myout(size(myin)))
278 
279 do i=1,size(myin)
280 
281  nvar=size(myin(i)%var)
282  allocate(varv7d(nvar))
283  CALL vargrib2varbufr(myin(i)%var, varv7d, c_func)
284 
285  DEALLOCATE(c_func)
286 
287  !print *,"varv7d"
288  !print *,varv7d
289 
290  mybin=varv7d(:)%btable
291  deallocate(varv7d)
292 
293  vfntmp=vfn
294  if (optio_log(copy)) call register_copy(vfntmp,mybin)
295 
296 
297  do j=1,size(mybin)
298  call l4f_log(l4f_info,"alchemy_vg6d: I have: "//mybin(j))
299  end do
300 
301  do j=1,size(mybout)
302  call l4f_log(l4f_info,"alchemy_vg6d: To make: "//mybout(j))
303  end do
304 
305  if (.not. oracle(mybin,mybout,vfntmp,myvfn)) then
306  call l4f_log(l4f_warn,"alchemy_vg6d: I cannot make your request")
307  alchemy_vg6d = 1
308  if(.not. shoppinglist(mybout,vfntmp,myvfn,copy=optio_log(copy))) then
309  call l4f_log(l4f_warn,"shoppinglist: return error status")
310  alchemy_vg6d = 2
311  end if
312  if (present(vfnoracle))vfnoracle=myvfn
313  return
314  end if
315 
316  if (present(vfnoracle))vfnoracle=myvfn
317 
318  !call display(myvfn)
319  call l4f_log(l4f_info,"alchemy_vg6d: I need "//t2c(myvfn%nout)//" more variables")
320 
321  call make(myvfn,mybin,mybout,myin(i),myout(i), allvarcomputed)
322 
323  call delete(myvfn)
324  call delete(vfntmp)
325 
326  !print *,"varvg6d"
327  !print *,varvg6d
328 
329 end do
330 
331 end function alchemy_vg6d
332 
333 end module volgrid6d_alchimia_class
Constructor, it creates a new instance of the object.
Destructor, it releases every information and memory buffer associated with the object.
This module defines an abstract interface to different drivers for access to files containing gridded...
This module defines objects and methods for managing data volumes on rectangular georeferenced grids...
Classe per la gestione delle variabili osservate da stazioni meteo e affini.
This module defines objects and methods for generating derivative variables.
Definition: alchimia.F03:239
This module defines usefull general purpose function and subroutine.
Make a deep copy, if possible, of the grid identifier.
Check missing values for fnds.
Definition: alchimia.F03:290
Class for managing physical variables in a grib 1/2 fashion.

Generated with Doxygen.