libsim Versione 7.2.0
alchimia_full_2003.F03
1module alchimia
4!USE volgrid6d_class
6
7IMPLICIT NONE
8
9private
10public fnds, fndsv
11
12integer, parameter :: nmaxb=100
13
14abstract 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
24end interface
25
26type 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
40end type fnds
41
42type fndsv
43 integer :: nout = imiss
44 type(fnds),allocatable :: fnds(:)
45end type fndsv
46
47
48interface display
49 module procedure fnv_display
50end interface
51
52interface delete
53 module procedure fnv_delete
54end interface
55
56interface make
57 module procedure makev
58end 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
69contains
70
71
72subroutine init_fn(fn,name,bin,bout,priority,order,func)
73CLASS(fnds),intent(inout) :: fn
74CHARACTER(len=*),optional :: name
75CHARACTER(len=*),optional :: bin(:)
76CHARACTER(len=*),optional :: bout(:)
77integer,optional :: priority
78integer,optional :: order
79procedure(elabora),optional :: func
80
81call optio(name,fn%name)
82
83if (present(bin)) then
84 fn%bin=bin
85else
86 allocate(fn%bin(1))
87 fn%bin=cmiss
88end if
89
90if (present(bout)) then
91 fn%bout=bout
92else
93 allocate(fn%bout(1))
94 fn%bout=cmiss
95end if
96
97call optio(priority,fn%priority)
98call optio(order,fn%order)
99
100if (present(func)) then
101 fn%fn => func
102else
103 fn%fn => null()
104end if
105
106end subroutine init_fn
107
108
109
110subroutine fnv_delete(fnv)
111type(fndsv),intent(inout) :: fnv
112type(fndsv) :: fn
114fnv=fn
115
116end subroutine fnv_delete
117
118
119subroutine fnregister(vfn,fn,order)
120
121type(fndsv),intent(inout) :: vfn
122type(fnds),intent(in),optional :: fn
123integer,optional :: order
124
125integer :: nfn
126type(fndsv) :: vfntmp
127
128if (.not. allocated(vfn%fnds))then
129 allocate(vfn%fnds(0))
130 vfn%nout=0
131end if
132
133if (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
149end if
150
151end subroutine fnregister
152
153
154elemental logical function c_e_fn(fn)
155class(fnds),intent(in) :: fn
156
157c_e_fn= c_e(fn%name)
158
159end function c_e_fn
160
161elemental logical function equal_fn(this,that)
162class(fnds),intent(in) :: this,that
163
164equal_fn= this%name == that%name
165
166end function equal_fn
167
168
169subroutine display_fn(fn)
170class(fnds),intent(in) :: fn
171
172print *,fn%name," : ",fn%bin(:count(c_e(fn%bin)))
173print *,"get : ",fn%bout(:count(c_e(fn%bout)))
174print *,""
175
176end subroutine display_fn
177
178subroutine fnv_display(fnv)
179type(fndsv),intent(in) :: fnv
180integer :: i
181
182print *, "Here we have the solution:"
183do i = count(fnv%fnds%c_e()),1,-1
184 call fnv%fnds(i)%display()
185end do
186end subroutine fnv_display
187
188recursive logical function oracle(mybin,mybout,vfn,mayvfn,recurse) result(stat)
189type(fndsv),intent(in) :: vfn
190character(len=*),intent(in) :: mybin(:),mybout(:)
191type(fndsv),intent(out) :: mayvfn
192
193type(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
201integer :: i,j,k,iin,iout
202logical :: allfoundout, foundout, somefoundin, foundin
203logical,optional :: recurse
204integer,save :: order,num
205character(len=10) :: newbin(nmaxb), newbout(nmaxb), tmpbin(nmaxb)
206
207
208! delte only on the main call
209if (.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
216end if
217
218!print *,"oracle",order
219
220newbin=cmiss
221newbin(:size(mybin))=mybin
222newbout=cmiss
223newbout(:size(mybin))=mybin
224
225! order is level to put functions
226order=order+1
227somefoundin = .false.
228num=count(maybefn%fnds%c_e())
229tmpbin=cmiss
230
231!search for functions starting from input
232do 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
248end do
249
250do i = 1, count(c_e(tmpbin))
251 newbin(firsttrue(.not. c_e(newbin)))=tmpbin(i)
252end 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
259stat = .false.
260if (.not. somefoundin) return
261if (num == count(maybefn%fnds%c_e())) return
262
263!check if we have finish
264allfoundout = .true.
265do 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.
271end do
272
273
274! ok, all is done
275if (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
314else
315
316 stat=oracle(newbin,mybout,vfn,mayvfn,.true.)
317
318end if
319
320! delete on exit only on the main call
321if (.not. optio_log(recurse)) then
322 call delete(maybefn)
323 call delete(usefullfn)
324 order=0
325end if
326
327end function oracle
328
329
330subroutine makev(mayvfn,mybin,mybout,myin,myout)
331type(fndsv),intent(inout) :: mayvfn
332character(len=*),intent(in) :: mybin(:),mybout(:)
333real,intent(in) :: myin(:,:)
334real,intent(out) :: myout(:,:)
335integer :: i
336
337do 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
342end do
343
344end 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
394end module alchimia
395
396
Check missing values for fnds.
Definition: alchimia.F03:265
Delete fndsv.
Definition: alchimia.F03:283
show on the screen the fnds and fndsv structure
Definition: alchimia.F03:278
Do the real work to transform the input data to the output.
Definition: alchimia.F03:288
Generic subroutine for checking OPTIONAL parameters.
This module defines objects and methods for generating derivative variables.
Definition: alchimia.F03:214
This module defines usefull general purpose function and subroutine.
Definitions of constants and functions for working with missing values.
Module for quickly interpreting the OPTIONAL parameters passed to a subprogram.
Vector of function to transform the input to alchimia module.
Definition: alchimia.F03:248

Generated with Doxygen.