libsim  Versione6.3.0
alchimia_full_2003.F03
1 module alchimia
4 !USE volgrid6d_class
6 
7 IMPLICIT NONE
8 
9 private
10 public fnds, fndsv
11 
12 integer, parameter :: nmaxb=100
13 
14 abstract interface
15  subroutine elabora(mybin,mybout,bin,bout,in,out)
16  import
17  CHARACTER(len=10),intent(in) :: mybin(:)
18  CHARACTER(len=10),intent(in) :: mybout(:)
19  CHARACTER(len=10),intent(in) :: bin(:)
20  CHARACTER(len=10),intent(in) :: bout(:)
21  real, intent(in) :: in(:,:)
22  real, intent(out) :: out(:,:)
23  end subroutine elabora
24 end interface
25 
26 type fnds
27  CHARACTER(len=10) :: name=cmiss
28  CHARACTER(len=10),allocatable :: bin(:)
29  CHARACTER(len=10),allocatable :: bout(:)
30  integer :: priority
31  integer :: order
32  procedure(elabora),nopass,pointer :: fn
33 
34  contains
35 
36  procedure :: c_e => c_e_fn
37  generic :: operator(==) => equal_fn
38  procedure :: init => init_fn
39  procedure :: display => display_fn
40 end type fnds
41 
42 type fndsv
43  integer :: nout = imiss
44  type(fnds),allocatable :: fnds(:)
45 end type fndsv
46 
47 
48 interface display
49  module procedure fnv_display
50 end interface
51 
52 interface delete
53  module procedure fnv_delete
54 end interface
55 
56 interface make
57  module procedure makev
58 end interface
59 
60 
61 !!$#define ARRAYOF_ORIGTYPE TYPE(fnds)
62 !!$#define ARRAYOF_TYPE arrayof_fnds
63 !!$#define ARRAYOF_ORIGEQ 0
64 !!$#include "arrayof_pre.F90"
65 !!$! from arrayof
66 !!$PUBLIC insert, append, remove, packarray
67 !!$PUBLIC insert_unique, append_unique
68 
69 contains
70 
71 
72 subroutine init_fn(fn,name,bin,bout,priority,order,func)
73 class(fnds),intent(inout) :: fn
74 CHARACTER(len=*),optional :: name
75 CHARACTER(len=*),optional :: bin(:)
76 CHARACTER(len=*),optional :: bout(:)
77 integer,optional :: priority
78 integer,optional :: order
79 procedure (elabora),optional :: func
80 
81 call optio(name,fn%name)
82 
83 if (present(bin)) then
84  fn%bin=bin
85 else
86  allocate(fn%bin(1))
87  fn%bin=cmiss
88 end if
89 
90 if (present(bout)) then
91  fn%bout=bout
92 else
93  allocate(fn%bout(1))
94  fn%bout=cmiss
95 end if
96 
97 call optio(priority,fn%priority)
98 call optio(order,fn%order)
99 
100 if (present(func)) then
101  fn%fn => func
102 else
103  fn%fn => null()
104 end if
106 end subroutine init_fn
107 
108 
109 
110 subroutine fnv_delete(fnv)
111 type(fndsv),intent(inout) :: fnv
112 type(fndsv) :: fn
113 
114 fnv=fn
115 
116 end subroutine fnv_delete
117 
118 
119 subroutine fnregister(vfn,fn,order)
120 
121 type(fndsv),intent(inout) :: vfn
122 type(fnds),intent(in),optional :: fn
123 integer,optional :: order
124 
125 integer :: nfn
126 type(fndsv) :: vfntmp
127 
128 if (.not. allocated(vfn%fnds))then
129  allocate(vfn%fnds(0))
130  vfn%nout=0
131 end if
132 
133 if (present(fn))then
134 
135  if (firsttrue(vfn%fnds == fn) /= 0) return
136  nfn=size(vfn%fnds)
137 
138  allocate(vfntmp%fnds(nfn+1))
139 
140  vfntmp%fnds(:nfn)=vfn%fnds
141 
142  call move_alloc(from=vfntmp%fnds ,to=vfn%fnds)
143 
144  vfn%fnds(nfn+1)=fn
145  if (present(order)) vfn%fnds(nfn+1)%order = order
146 
147  vfn%nout=vfn%nout+size(fn%bout)
148 
149 end if
150 
151 end subroutine fnregister
152 
153 
154 elemental logical function c_e_fn(fn)
155 class(fnds),intent(in) :: fn
156 
157 c_e_fn= c_e(fn%name)
158 
159 end function c_e_fn
160 
161 elemental logical function equal_fn(this,that)
162 class(fnds),intent(in) :: this,that
163 
164 equal_fn= this%name == that%name
165 
166 end function equal_fn
167 
168 
169 subroutine display_fn(fn)
170 class(fnds),intent(in) :: fn
171 
172 print *,fn%name," : ",fn%bin(:count(c_e(fn%bin)))
173 print *,"get : ",fn%bout(:count(c_e(fn%bout)))
174 print *,""
175 
176 end subroutine display_fn
177 
178 subroutine fnv_display(fnv)
179 type(fndsv),intent(in) :: fnv
180 integer :: i
181 
182 print *, "Here we have the solution:"
183 do i = count(fnv%fnds%c_e()),1,-1
184  call fnv%fnds(i)%display()
185 end do
186 end subroutine fnv_display
187 
188 recursive logical function oracle(mybin,mybout,vfn,mayvfn,recurse) result(stat)
189 type(fndsv),intent(in) :: vfn
190 character(len=*),intent(in) :: mybin(:),mybout(:)
191 type(fndsv),intent(out) :: mayvfn
192 
193 type(fndsv),save :: usefullfn,maybefn
194 
195 !!$type(arrayof_fnds) :: tmp
196 !!$tmp = arrayof_fnds_new()
197 !!$append(tmp,myfn(1))
198 !!$CALL packarray(tmp)
199 !!$print *,tmp%array
200 
201 integer :: i,j,k,iin,iout
202 logical :: allfoundout, foundout, somefoundin, foundin
203 logical,optional :: recurse
204 integer,save :: order,num
205 character(len=10) :: newbin(nmaxb), newbout(nmaxb), tmpbin(nmaxb)
206 
207 
208 ! delte only on the main call
209 if (.not. optio_log(recurse)) then
210  !print *,"cancello"
211  call delete(maybefn)
212  call delete(usefullfn)
213  call fnregister(maybefn)
214  call fnregister(usefullfn)
215  order=0
216 end if
217 
218 !print *,"oracle",order
219 
220 newbin=cmiss
221 newbin(:size(mybin))=mybin
222 newbout=cmiss
223 newbout(:size(mybin))=mybin
224 
225 ! order is level to put functions
226 order=order+1
227 somefoundin = .false.
228 num=count(maybefn%fnds%c_e())
229 tmpbin=cmiss
230 
231 !search for functions starting from input
232 do i =1, count(vfn%fnds%c_e())
233  foundin = .true.
234  do j = 1, count(c_e(vfn%fnds(i)%bin(:)))
235  if (.not. any(vfn%fnds(i)%bin(j) == newbin)) foundin = .false.
236 !!$ print *,"confronto: ",vfn(i)%bin(j)
237 !!$ print *,"con: ",mybin
238  end do
239  if (foundin) then
240  !print *,"registro ",vfn%fnds(i)%name
241  call fnregister(maybefn,vfn%fnds(i),order)
242  do k=1,size(vfn%fnds(i)%bout)
243  tmpbin(firsttrue(.not. c_e(tmpbin)))=vfn%fnds(i)%bout(k)
244  newbout(firsttrue(.not. c_e(newbout)))=vfn%fnds(i)%bout(k)
245  end do
246  somefoundin = .true.
247  end if
248 end do
249 
250 do i = 1, count(c_e(tmpbin))
251  newbin(firsttrue(.not. c_e(newbin)))=tmpbin(i)
252 end do
253 
254 ! here bin and bout are bigger (newbin, newbout)
255 ! by the output of applicable functions
256 
257 
258 !check if we can work anymore
259 stat = .false.
260 if (.not. somefoundin) return
261 if (num == count(maybefn%fnds%c_e())) return
262 
263 !check if we have finish
264 allfoundout = .true.
265 do i=1, count(c_e(mybout))
266  foundout = .false.
267  do j =1, count(c_e(newbout))
268  if (newbout(j) == mybout(i)) foundout = .true.
269  end do
270  if (.not. foundout) allfoundout = .false.
271 end do
272 
273 
274 ! ok, all is done
275 if (allfoundout) then
276 
277 !!$ print *, "intermediate"
278 !!$ do i =1,size(maybefn)
279 !!$ if (c_e(maybefn(i))) print *,maybefn(i)
280 !!$ end do
281 
282  ! toglie i rami secchi
283  newbout=cmiss
284  newbout(:size(mybout))=mybout
285  tmpbin=cmiss
286 
287  do i = count(maybefn%fnds%c_e()),1,-1
288  if (maybefn%fnds(i)%order /= order) then
289  !print *,"change order",maybefn(i)%order
290  order=maybefn%fnds(i)%order
291  iin=count(c_e(tmpbin))
292  iout=count(c_e(newbout))
293  newbout(iout+1:iout+iin)=tmpbin(:iin)
294  tmpbin=cmiss
295  end if
296 
297  !print *,"cerco:",newbout(:firsttrue(.not. c_e(newbout)))
298 
299  foundout = .false.
300  do j=1, count(c_e(newbout))
301  if (any(maybefn%fnds(i)%bout(:) == newbout(j))) foundout = .true.
302  end do
303  if (foundout) then
304  !print *,"altroregistro ",maybefn%fnds(i)%name
305  call fnregister(mayvfn,maybefn%fnds(i),order)
306  do k=1,count(c_e(maybefn%fnds(i)%bin))
307  tmpbin(firsttrue(.not. c_e(tmpbin)))=maybefn%fnds(i)%bin(k)
308  end do
309  end if
310  end do
311 
312  stat = .true.
313 
314 else
315 
316  stat=oracle(newbin,mybout,vfn,mayvfn,.true.)
317 
318 end if
319 
320 ! delete on exit only on the main call
321 if (.not. optio_log(recurse)) then
322  call delete(maybefn)
323  call delete(usefullfn)
324  order=0
325 end if
326 
327 end function oracle
328 
329 
330 subroutine makev(mayvfn,mybin,mybout,myin,myout)
331 type(fndsv),intent(inout) :: mayvfn
332 character(len=*),intent(in) :: mybin(:),mybout(:)
333 real,intent(in) :: myin(:,:)
334 real,intent(out) :: myout(:,:)
335 integer :: i
336 
337 do i=size(mayvfn%fnds),1,-1
338  if (mayvfn%fnds(i)%c_e()) then
339  call mayvfn%fnds(i)%fn(mybin,mybout,mayvfn%fnds(i)%bin,mayvfn%fnds(i)%bout,myin,myout)
340  !print *,"make",i,mayvfn%fnds(i)%bin,mayvfn%fnds(i)%bout
341  end if
342 end do
343 
344 end subroutine makev
345 
346 
347 !!$subroutine make_vg6d(mayvfn,mybin,mybout,vg6din,vg6dout)
348 !!$type(fndsv),intent(inout) :: mayvfn
349 !!$character(len=*),intent(in) :: mybin(:),mybout(:)
350 !!$type(volgrid6d),intent(in) :: vg6din
351 !!$type(volgrid6d),intent(out) :: vg6dout
352 !!$integer :: i,nx,ny,nlevel,ntime,ntimerange,nvar,nvarin,ilevel,itime,itimerange
353 !!$real,allocatable :: myin(:,:),myout(:,:)
354 !!$
355 !!$nx=size(vg6din%voldati,1)
356 !!$ny=size(vg6din%voldati,2)
357 !!$nlevel=size(vg6din%voldati,3)
358 !!$ntime=size(vg6din%voldati,4)
359 !!$ntimerange=size(vg6din%voldati,5)
360 !!$nvarin=size(mybin)
361 !!$nvar=size(mybout)
362 !!$
363 !!$allocate(myout(nx*ny,nvar))
364 !!$
365 !!$call init(vg6dout, vg6din%griddim, vg6din%time_definition, categoryappend="generated by alchimia make")
366 !!$call volgrid6d_alloc(vg6dout, vg6din%griddim%dim, ntime, nlevel, ntimerange, nvar)
367 !!$call volgrid6d_alloc_vol(vg6dout,inivol=.true.)
368 !!$
369 !!$vg6dout%time=vg6din%time
370 !!$vg6dout%timerange=vg6din%timerange
371 !!$vg6dout%level=vg6din%level
372 !!$
373 !!$do i=size(mayvfn%fnds),1,-1
374 !!$ if (mayvfn%fnds(i)%c_e()) then
375 !!$ do ilevel=1,nlevel
376 !!$ do itime=1,ntime
377 !!$ do itimerange=1,ntimerange
378 !!$ myin=reshape(vg6din%voldati(:,:,ilevel,itime,itimerange,:),(/nx*ny,nvarin/))
379 !!$ myout=rmiss
380 !!$ call mayvfn%fnds(i)%fn(mybin,mybout,mayvfn%fnds(i)%bin,mayvfn%fnds(i)%bout,myin,myout)
381 !!$ vg6dout%voldati(:,:,ilevel,itime,itimerange,:)=reshape(myout,(/nx,ny,nvar/))
382 !!$ end do
383 !!$ end do
384 !!$ end do
385 !!$ end if
386 !!$end do
387 !!$
388 !!$end subroutine make_vg6d
389 
390 
391 
392 !!$#include "arrayof_post.F90"
393 
394 end module alchimia
395 
396 
Definitions of constants and functions for working with missing values.
Vector of function to transform the input to alchimia module.
Definition: alchimia.F03:254
Do the real work to transform the input data to the output.
Definition: alchimia.F03:294
Delete fndsv.
Definition: alchimia.F03:289
Generic subroutine for checking OPTIONAL parameters.
show on the screen the fnds and fndsv structure
Definition: alchimia.F03:284
This module defines objects and methods for generating derivative variables.
Definition: alchimia.F03:220
Check missing values for fnds.
Definition: alchimia.F03:271
Module for quickly interpreting the OPTIONAL parameters passed to a subprogram.
This module defines usefull general purpose function and subroutine.

Generated with Doxygen.