libsim  Versione7.1.6
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_vg6dv, 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 ! 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
71 newbout=cmiss
72 
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)
80  end if
81  end if
82  end do
83  end if
84 end do
85 
86 nvarin=count(c_e(newbout))
87 
88 !add output variables
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)
95  end if
96  end if
97  end do
98  end if
99 end do
100 
101 
102 nvar=count(c_e(newbout))
103 
104 allocate(myout(nx*ny,nvar))
105 
106 ! create output volume
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.)
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 ! 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
153 ENDDO
154 
155 ! delete note: am i sure that up to now i have filled varvg6d exactly up to nvarin?
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 !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
237 end do
238 
239 
240 if (.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
252 end if
253 
254 DEALLOCATE(c_funcgb)
255 DEALLOCATE(c_funcbg)
256 deallocate (varv7d,varvg6d)
257 
258 end subroutine make_vg6d
259 
260 
261 integer function alchemy_vg6dv(myin,vfn,mybout,myout,copy,vfnoracle,allvarcomputed)
262 
263 character(len=*),intent(in) :: mybout(:)
264 type(fndsv),intent(in) :: vfn
265 type(volgrid6d),intent(in) :: myin(:)
266 type(volgrid6d),intent(out),pointer ::myout(:)
267 logical,intent(in),optional :: copy
268 type(fndsv),intent(out),optional :: vfnoracle
269 logical, optional :: allvarcomputed
270 
271 integer :: i,j,nvar
272 type(fndsv) :: myvfn,vfntmp
273 character(len=10), allocatable:: mybin(:)
274 TYPE(conv_func), pointer :: c_func(:)
275 TYPE(vol7d_var),allocatable :: varv7d(:)
276 
277 alchemy_vg6dv=0
278 
279 allocate(myout(size(myin)))
280 
281 do i=1,size(myin)
282 
283  alchemy_vg6dv = alchemy(myin(i),vfn,mybout,myout(i),copy,vfnoracle,allvarcomputed)
284  IF (alchemy_vg6dv /= 0) RETURN
285 end do
286 
287 end function alchemy_vg6dv
288 
289 integer function alchemy_vg6d(myin,vfn,mybout,myout,copy,vfnoracle,allvarcomputed)
290 
291 character(len=*),intent(in) :: mybout(:)
292 type(fndsv),intent(in) :: vfn
293 type(volgrid6d),intent(in) :: myin
294 type(volgrid6d),intent(out) ::myout
295 logical,intent(in),optional :: copy
296 type(fndsv),intent(out),optional :: vfnoracle
297 logical, optional :: allvarcomputed
298 
299 integer :: j,nvar
300 type(fndsv) :: myvfn,vfntmp
301 character(len=10), allocatable:: mybin(:)
302 TYPE(conv_func), pointer :: c_func(:)
303 TYPE(vol7d_var),allocatable :: varv7d(:)
304 
305 alchemy_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 
352 end function alchemy_vg6d
353 
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.
Definition: alchimia.F03:245
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.
Definition: alchimia.F03:211
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.

Generated with Doxygen.