libsim  Versione 7.2.6
vol7d_alchimia_class.F03
1 module vol7d_alchimia_class
2 #include "config.h"
3 
4 USE vol7d_class
5 USE alchimia
6 USE log4fortran
7 #ifdef HAVE_DBALLE
9 #endif
10 implicit NONE
11 
12 interface make
13  module procedure make_v7d
14 end interface
15 
16 interface alchemy
17  module procedure alchemy_v7d
18 end interface
19 
20 private
21 public make, alchemy, v7d_all_var, sl_display_pretty
22 
23 contains
24 
25 
26 function pretty_var(var)
27 CHARACTER(len=80) :: pretty_var
28 character(len=*) :: var
29 
30 integer :: ind
31 
32 #ifdef HAVE_DBALLE
33 TYPE(vol7d_var),pointer,save :: dballevar(:) => null()
34 
35 call vol7d_dballe_import_dballevar(dballevar)
36 ind=index_c(dballevar(:)%btable,var)
37 
38 if (ind > 0 )then
39  pretty_var=dballevar(ind)%description
40 else
41  pretty_var=var
42 end if
43 #else
44 
45 pretty_var=var
46 
47 #endif
48 end function pretty_var
49 
50 
51 subroutine make_v7d(mayvfn,mybin,mybout,v7din,v7dout)
52 type(fndsv),intent(inout) :: mayvfn
53 character(len=*),intent(in) :: mybin(:),mybout(:)
54 type(vol7d),intent(inout) :: v7din
55 type(vol7d),intent(out) :: v7dout
56 integer :: i,j,nana,nlevel,ntime,ntimerange,nvarin,nvarout,nnetwork
57 integer :: ilevel,itime,itimerange,inetwork,ivar,ind,ivarin,ivarout
58 type(vol7d_var) :: var
59 character(len=1) :: type
60 character(len=10) :: newbout(mayvfn%nout+mayvfn%nin)
61 
62 nana=size(v7din%ana)
63 ntime=size(v7din%time)
64 nlevel=size(v7din%level)
65 ntimerange=size(v7din%timerange)
66 nnetwork=size(v7din%network)
67 
68 call copy (v7din,v7dout,&
69  ldativarr=(/.false./),&
70  ldativari=(/.false./),&
71  ldativard=(/.false./),&
72  ldativarb=(/.false./),&
73  ldativarc=(/.false./))
74 
75 !we have to make a new volume with var required in input function plus var for output
76 
77 !star with input variables
78 newbout=cmiss
79 
80 do i=1, size(mayvfn%fnds)
81  if (c_e(mayvfn%fnds(i))) then
82  do j=1, size(mayvfn%fnds(i)%bin)
83  if (c_e(mayvfn%fnds(i)%bin(j))) then
84  if (index_c(mybin,mayvfn%fnds(i)%bin(j)) <= 0)cycle
85  if (index_c(newbout,mayvfn%fnds(i)%bin(j)) <= 0) then
86  newbout(index_c(newbout,cmiss)) = mayvfn%fnds(i)%bin(j)
87  end if
88  end if
89  end do
90  end if
91 end do
92 
93 nvarin=count(c_e(newbout))
94 
95 !add output variables
96 do i=1, size(mayvfn%fnds)
97  if (c_e(mayvfn%fnds(i))) then
98  do j=1, size(mayvfn%fnds(i)%bout)
99  if (c_e(mayvfn%fnds(i)%bout(j))) then
100  if (index_c(newbout,mayvfn%fnds(i)%bout(j)) <= 0) then
101  newbout(index_c(newbout,cmiss)) = mayvfn%fnds(i)%bout(j)
102  end if
103  end if
104  end do
105  end if
106 end do
107 
108 nvarout=count(c_e(newbout))
109 
110 call vol7d_alloc(v7dout, ndativarr=nvarout)
111 
112 do ivar=1,nvarout
113  call init(v7dout%dativar%r(ivar),btable=newbout(ivar))
114 end do
115 
116 call vol7d_alloc_vol(v7dout,inivol=.true.)
117 
118 ! now I copy the needed input variables from input volume to output
119 ! converting to real values
120 
121 do ivar=1,nvarin
122 
123  ivarin = index_c(mybin,newbout(ivar))
124  ivarout = ivar
125 
126  call init(var, btable=newbout(ivarout))
127 
128  type=cmiss
129  ind = index(v7din%dativar, var, type=type)
130 
131  select case (type)
132 
133  case("d")
134  v7dout%voldatir(:,:,:,:,ivarout,:)= &
135  realdat(v7din%voldatid(:,:,:,:,ind,:),v7din%dativar%d(ind))
136  case("r")
137  v7dout%voldatir(:,:,:,:,ivarout,:)= &
138  realdat(v7din%voldatir(:,:,:,:,ind,:),v7din%dativar%r(ind))
139  case("i")
140  v7dout%voldatir(:,:,:,:,ivarout,:)= &
141  realdat(v7din%voldatii(:,:,:,:,ind,:),v7din%dativar%i(ind))
142  case("b")
143  v7dout%voldatir(:,:,:,:,ivarout,:)= &
144  realdat(v7din%voldatib(:,:,:,:,ind,:),v7din%dativar%b(ind))
145  case("c")
146  v7dout%voldatir(:,:,:,:,ivarout,:)= &
147  realdat(v7din%voldatic(:,:,:,:,ind,:),v7din%dativar%c(ind))
148 
149  case default
150  v7dout%voldatir(:,:,:,:,ivarout,:)=rmiss
151 
152  end select
153 end do
154 
155 
156 do i=size(mayvfn%fnds),1,-1
157  if (c_e(mayvfn%fnds(i)) .and. .not. match(mayvfn%fnds(i)%name,"copy*") ) then
158 
159 #ifdef DEBUG
160  call l4f_log(l4f_debug,"execute function: "//mayvfn%fnds(i)%name)
161 #endif
162 
163  do ilevel=1,nlevel
164  do itime=1,ntime
165  do itimerange=1,ntimerange
166  do inetwork=1,nnetwork
167  call mayvfn%fnds(i)%fn(newbout,newbout,mayvfn%fnds(i)%bin,mayvfn%fnds(i)%bout,&
168  v7dout%voldatir(:,itime,ilevel,itimerange,:,inetwork),&
169  v7dout%voldatir(:,itime,ilevel,itimerange,:,inetwork))
170  end do
171  end do
172  end do
173  end do
174  end if
175 end do
176 
177 
178 end subroutine make_v7d
179 
180 
181 subroutine v7d_all_var(myin,mybin)
182 
183 type(vol7d),intent(in) :: myin
184 character(len=10), allocatable:: mybin(:)
185 integer :: nbin,nbinn
186 
187 nbin=0
188 
189 if (associated(myin%dativar%r)) nbin = nbin + size(myin%dativar%r)
190 if (associated(myin%dativar%i)) nbin = nbin + size(myin%dativar%i)
191 if (associated(myin%dativar%d)) nbin = nbin + size(myin%dativar%d)
192 if (associated(myin%dativar%b)) nbin = nbin + size(myin%dativar%b)
193 if (associated(myin%dativar%c)) nbin = nbin + size(myin%dativar%c)
194 
195 allocate (mybin(nbin))
196 
197 nbin=0
198 if (associated(myin%dativar%r)) then
199  nbinn=nbin+size(myin%dativar%r)
200  mybin(nbin+1:nbinn) = myin%dativar%r(:)%btable
201  nbin=nbinn
202 end if
203 
204 if (associated(myin%dativar%i)) then
205  nbinn=nbin+size(myin%dativar%i)
206  mybin(nbin+1:nbinn) = myin%dativar%i(:)%btable
207  nbin=nbinn
208 end if
209 
210 if (associated(myin%dativar%d)) then
211  nbinn=nbin+size(myin%dativar%d)
212  mybin(nbin+1:nbinn) = myin%dativar%d(:)%btable
213  nbin=nbinn
214 end if
215 
216 if (associated(myin%dativar%b)) then
217  nbinn=nbin+size(myin%dativar%b)
218  mybin(nbin+1:nbinn) = myin%dativar%b(:)%btable
219  nbin=nbinn
220 end if
221 
222 if (associated(myin%dativar%c)) then
223  nbinn=nbin+size(myin%dativar%c)
224  mybin(nbin+1:nbinn) = myin%dativar%c(:)%btable
225 end if
226 
227 
228 end subroutine v7d_all_var
229 
230 
231 integer function alchemy_v7d(myin,vfn,mybout,myout,copy,vfnoracle)
232 
233 character(len=10),intent(in) :: mybout(:)
234 type(fndsv),intent(in) :: vfn
235 type(vol7d),intent(inout) :: myin
236 type(vol7d),intent(out) :: myout
237 logical,intent(in),optional :: copy
238 type(fndsv),intent(out),optional :: vfnoracle
239 
240 integer :: i
241 type(fndsv) :: vfntmp, myvfn
242 character(len=10), allocatable:: mybin(:)
243 
244 alchemy_v7d = 0
245 
246 call v7d_all_var(myin,mybin)
247 
248 vfntmp=vfn
249 if (optio_log(copy)) call register_copy(vfntmp,mybin)
250 
251 do i=1,size(mybin)
252  call l4f_log(l4f_info,"alchemy_v7d: I have: "//mybin(i))
253 end do
254 
255 do i=1,size(mybout)
256  call l4f_log(l4f_info,"alchemy_v7d: To make: "//mybout(i))
257 end do
258 
259 if (.not. oracle(mybin,mybout,vfntmp,myvfn)) then
260  call l4f_log(l4f_warn,"alchemy_v7d: I cannot make your request")
261  alchemy_v7d = 1
262  if(.not. shoppinglist(mybout,vfntmp,myvfn,copy=optio_log(copy))) then
263  call l4f_log(l4f_warn,"shoppinglist: return error status")
264  alchemy_v7d = 2
265  end if
266  if (present(vfnoracle)) vfnoracle=myvfn
267  return
268 end if
269 
270 if (present(vfnoracle)) vfnoracle=myvfn
271 
272 !call display(myvfn)
273 call l4f_log(l4f_info,"alchemy_v7d: I need "//t2c(myvfn%nout)//" variables")
274 
275 call make(myvfn,mybin,mybout,myin,myout)
276 
277 call delete(myvfn)
278 call delete(vfntmp)
279 
280 end function alchemy_v7d
281 
282 
284 subroutine sl_display_pretty(sl)
285 type(shoplists),intent(in) :: sl
286 
287 integer :: i,j
288 
289 do i = 1, size(sl%shoplist)
290  print *,"shopping list : ",i
291  do j=1,size(sl%shoplist(i)%bvar)
292  print *,"required var : ",sl%shoplist(i)%bvar(j)," -> ",pretty_var(sl%shoplist(i)%bvar(j))
293  end do
294  print *,""
295 end do
296 
297 end subroutine sl_display_pretty
298 
299 
300 end module vol7d_alchimia_class
Index method.
Test for a missing volume.
Distruttore per la classe vol7d.
Costruttore per la classe vol7d.
real data conversion
This module defines objects and methods for generating derivative variables.
Definition: alchimia.F03:224
classe per la gestione del logging
Classe per la gestione di un volume completo di dati osservati.
classe per import ed export di volumi da e in DB-All.e

Generated with Doxygen.