libsim Versione 7.2.1
vol7d_alchimia_class.F03
1module vol7d_alchimia_class
2#include "config.h"
3
5USE alchimia
7#ifdef HAVE_DBALLE
9#endif
10implicit NONE
11
12interface make
13 module procedure make_v7d
14end interface
15
16interface alchemy
17 module procedure alchemy_v7d
18end interface
19
20private
21public make, alchemy, v7d_all_var, sl_display_pretty
22
23contains
24
25
26function pretty_var(var)
27CHARACTER(len=80) :: pretty_var
28character(len=*) :: var
29
30integer :: ind
31
32#ifdef HAVE_DBALLE
33TYPE(vol7d_var),pointer,save :: dballevar(:) => null()
34
35call vol7d_dballe_import_dballevar(dballevar)
36ind=index_c(dballevar(:)%btable,var)
37
38if (ind > 0 )then
39 pretty_var=dballevar(ind)%description
40else
41 pretty_var=var
42end if
43#else
44
45pretty_var=var
46
47#endif
48end function pretty_var
49
50
51subroutine make_v7d(mayvfn,mybin,mybout,v7din,v7dout)
52type(fndsv),intent(inout) :: mayvfn
53character(len=*),intent(in) :: mybin(:),mybout(:)
54type(vol7d),intent(inout) :: v7din
55type(vol7d),intent(out) :: v7dout
56integer :: i,j,nana,nlevel,ntime,ntimerange,nvarin,nvarout,nnetwork
57integer :: ilevel,itime,itimerange,inetwork,ivar,ind,ivarin,ivarout
58type(vol7d_var) :: var
59character(len=1) :: type
60character(len=10) :: newbout(mayvfn%nout+mayvfn%nin)
61
62nana=size(v7din%ana)
63ntime=size(v7din%time)
64nlevel=size(v7din%level)
65ntimerange=size(v7din%timerange)
66nnetwork=size(v7din%network)
67
68call 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
78newbout=cmiss
79
80do 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
91end do
92
93nvarin=count(c_e(newbout))
94
95!add output variables
96do 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
106end do
107
108nvarout=count(c_e(newbout))
109
110call vol7d_alloc(v7dout, ndativarr=nvarout)
111
112do ivar=1,nvarout
113 call init(v7dout%dativar%r(ivar),btable=newbout(ivar))
114end do
115
116call 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
121do 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
153end do
154
155
156do 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
175end do
176
177
178end subroutine make_v7d
179
180
181subroutine v7d_all_var(myin,mybin)
182
183type(vol7d),intent(in) :: myin
184character(len=10), allocatable:: mybin(:)
185integer :: nbin,nbinn
186
187nbin=0
188
189if (associated(myin%dativar%r)) nbin = nbin + size(myin%dativar%r)
190if (associated(myin%dativar%i)) nbin = nbin + size(myin%dativar%i)
191if (associated(myin%dativar%d)) nbin = nbin + size(myin%dativar%d)
192if (associated(myin%dativar%b)) nbin = nbin + size(myin%dativar%b)
193if (associated(myin%dativar%c)) nbin = nbin + size(myin%dativar%c)
194
195allocate (mybin(nbin))
196
197nbin=0
198if (associated(myin%dativar%r)) then
199 nbinn=nbin+size(myin%dativar%r)
200 mybin(nbin+1:nbinn) = myin%dativar%r(:)%btable
201 nbin=nbinn
202end if
203
204if (associated(myin%dativar%i)) then
205 nbinn=nbin+size(myin%dativar%i)
206 mybin(nbin+1:nbinn) = myin%dativar%i(:)%btable
207 nbin=nbinn
208end if
209
210if (associated(myin%dativar%d)) then
211 nbinn=nbin+size(myin%dativar%d)
212 mybin(nbin+1:nbinn) = myin%dativar%d(:)%btable
213 nbin=nbinn
214end if
215
216if (associated(myin%dativar%b)) then
217 nbinn=nbin+size(myin%dativar%b)
218 mybin(nbin+1:nbinn) = myin%dativar%b(:)%btable
219 nbin=nbinn
220end if
221
222if (associated(myin%dativar%c)) then
223 nbinn=nbin+size(myin%dativar%c)
224 mybin(nbin+1:nbinn) = myin%dativar%c(:)%btable
225end if
226
227
228end subroutine v7d_all_var
229
230
231integer function alchemy_v7d(myin,vfn,mybout,myout,copy,vfnoracle)
232
233character(len=10),intent(in) :: mybout(:)
234type(fndsv),intent(in) :: vfn
235type(vol7d),intent(inout) :: myin
236type(vol7d),intent(out) :: myout
237logical,intent(in),optional :: copy
238type(fndsv),intent(out),optional :: vfnoracle
239
240integer :: i
241type(fndsv) :: vfntmp, myvfn
242character(len=10), allocatable:: mybin(:)
243
244alchemy_v7d = 0
245
246call v7d_all_var(myin,mybin)
247
248vfntmp=vfn
249if (optio_log(copy)) call register_copy(vfntmp,mybin)
250
251do i=1,size(mybin)
252 call l4f_log(l4f_info,"alchemy_v7d: I have: "//mybin(i))
253end do
254
255do i=1,size(mybout)
256 call l4f_log(l4f_info,"alchemy_v7d: To make: "//mybout(i))
257end do
258
259if (.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
268end if
269
270if (present(vfnoracle)) vfnoracle=myvfn
271
272!call display(myvfn)
273call l4f_log(l4f_info,"alchemy_v7d: I need "//t2c(myvfn%nout)//" variables")
274
275call make(myvfn,mybin,mybout,myin,myout)
276
277call delete(myvfn)
278call delete(vfntmp)
279
280end function alchemy_v7d
281
282
284subroutine sl_display_pretty(sl)
285type(shoplists),intent(in) :: sl
286
287integer :: i,j
288
289do 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 *,""
295end do
296
297end subroutine sl_display_pretty
298
299
300end module vol7d_alchimia_class
Check missing values for fnds.
Definition alchimia.F03:265
Delete fndsv.
Definition alchimia.F03:283
Index method.
real data conversion
This module defines objects and methods for generating derivative variables.
Definition alchimia.F03:214
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.