libsim Versione 7.2.1
alchimia.F03
1! Copyright (C) 2010 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#include "config.h"
19
22
26module alchimia
27
33
34IMPLICIT NONE
35
36integer, parameter :: nmaxb=100
37
38abstract interface
39 subroutine elabora(mybin,mybout,bin,bout,in,out)
40 import
41 CHARACTER(len=10),intent(in) :: mybin(:)
42 CHARACTER(len=10),intent(in) :: mybout(:)
43 CHARACTER(len=10),intent(in) :: bin(:)
44 CHARACTER(len=10),intent(in) :: bout(:)
45 real, intent(in) :: in(:,:)
46 real, intent(out) :: out(:,:)
47 end subroutine elabora
48end interface
49
50type fnds
51 CHARACTER(len=50) :: name=cmiss
52 CHARACTER(len=10),allocatable :: bin(:)
53 CHARACTER(len=10),allocatable :: bout(:)
54 integer :: priority
55 integer :: order
56 procedure(elabora) ,nopass, pointer :: fn
57end type fnds
58
60type fndsv
61 integer :: nin = imiss
62 integer :: nout = imiss
63 type(fnds),allocatable :: fnds(:)
64end type fndsv
65
67type shoplist
68 CHARACTER(len=10),allocatable :: bvar(:)
69end type shoplist
70
72type shoplists
73 type(shoplist),allocatable :: shoplist(:)
74end type shoplists
75
77interface c_e
78 module procedure c_e_fn
79end interface
80
81interface OPERATOR (==)
82 module procedure equal_fn
83end interface
84
85interface init
86 module procedure fn_init
87end interface
88
90interface display
91 module procedure fn_display, fnv_display, vfnv_display, fnv_display_byorder, sl_display
92end interface
93
95interface delete
96 module procedure fnv_delete
97end interface
98
100interface make
101 module procedure makev
102end interface
103
104
105!!$#define ARRAYOF_ORIGTYPE TYPE(fnds)
106!!$#define ARRAYOF_TYPE arrayof_fnds
107!!$#define ARRAYOF_ORIGEQ 0
108!!$#include "arrayof_pre.F90"
109!!$! from arrayof
110!!$PUBLIC insert, append, remove, packarray
111!!$PUBLIC insert_unique, append_unique
112private
113public fnds,fndsv,make,init,c_e,display,delete,fnregister,oracle,register_copy
114public shoppinglist, shoplists, compile_sl
115
116contains
117
119subroutine register_copy(vfn,bin)
120
121 type(fndsv),intent(inout) :: vfn
122 CHARACTER(len=10),intent(in) :: bin(:)
123 integer :: i
124
125 do i=1, size(bin)
126 call fnregister(vfn,alchimia_copy_def(bin(i)))
127 end do
128
129end subroutine register_copy
130
131subroutine alchimia_copy(mybin,mybout,bin,bout,in,out)
132 CHARACTER(len=10),intent(in) :: mybin(:)
133 CHARACTER(len=10),intent(in) :: mybout(:)
134 CHARACTER(len=10),intent(in) :: bin(:)
135 CHARACTER(len=10),intent(in) :: bout(:)
136 real, intent(in) :: in(:,:)
137 real, intent(out) :: out(:,:)
138
139 out(:,index_c(mybout,bout(1)))=in(:,index_c(mybin,bin(1)))
140
141end subroutine alchimia_copy
142
143type(fnds) function alchimia_copy_def(bvar)
144 CHARACTER(len=10),intent(in) :: bvar
145
146 call init(alchimia_copy_def,"copy"//bvar,&
147 [character(len=10) :: bvar],&
148 [character(len=10) :: bvar],0,func=alchimia_copy)
149end function alchimia_copy_def
150
152subroutine fn_init(fn,name,bin,bout,priority,order,func)
153type(fnds),intent(inout) :: fn
154CHARACTER(len=*),optional :: name
155CHARACTER(len=*),optional :: bin(:)
156CHARACTER(len=*),optional :: bout(:)
157integer,optional :: priority
158integer,optional :: order
159procedure(elabora),optional :: func
160
161call optio(name,fn%name)
162
163if (present(bin)) then
164 fn%bin=bin
165else
166 allocate(fn%bin(1))
167 fn%bin=cmiss
168end if
169
170if (present(bout)) then
171 fn%bout=bout
172else
173 allocate(fn%bout(1))
174 fn%bout=cmiss
175end if
176
177call optio(priority,fn%priority)
178call optio(order,fn%order)
179
180if (present(func)) then
181 fn%fn => func
182else
183 fn%fn => null()
184end if
185
186end subroutine fn_init
187
188
190elemental subroutine fnv_delete(fnv)
191type(fndsv),intent(inout) :: fnv
192type(fndsv) :: fn
193
194fnv=fn
195
196end subroutine fnv_delete
197
201subroutine fnregister(vfn,fn,order)
202
203type(fndsv),intent(inout) :: vfn
204type(fnds),intent(in),optional :: fn
205integer,optional :: order
206
207integer :: nfn
208type(fndsv) :: vfntmp
209
210if (.not. allocated(vfn%fnds))then
211 allocate(vfn%fnds(0))
212 vfn%nin=0
213 vfn%nout=0
214end if
215
216if (present(fn))then
217
218 if (firsttrue(vfn%fnds == fn) /= 0) return
219 nfn=size(vfn%fnds)
220
221 allocate(vfntmp%fnds(nfn+1))
222
223 vfntmp%fnds(:nfn)=vfn%fnds
224
225 call move_alloc(from=vfntmp%fnds ,to=vfn%fnds)
226
227 vfn%fnds(nfn+1)=fn
228 if (present(order)) vfn%fnds(nfn+1)%order = order
229
230 vfn%nin=vfn%nin+size(fn%bin)
231 vfn%nout=vfn%nout+size(fn%bout)
232
233 CALL l4f_log(l4f_debug, 'fnregister: adding function object '//trim(fn%name)//' ; nout '//t2c(vfn%nout))
234
235end if
236
237end subroutine fnregister
238
240elemental logical function c_e_fn(fn)
241type(fnds),intent(in) :: fn
242
243c_e_fn= c_e(fn%name)
244
245end function c_e_fn
246
247elemental logical function equal_fn(this,that)
248type(fnds),intent(in) :: this,that
249
250equal_fn= this%name == that%name
251
252end function equal_fn
253
254
256subroutine sl_display(sl)
257type(shoplists),intent(in) :: sl
258
259integer :: i
261do i = 1, size(sl%shoplist)
262 print *,"shopping list : ",i
263 print *,"varlist : ",sl%shoplist(i)%bvar
264 print *,""
265end do
266
267end subroutine sl_display
268
269
271subroutine fn_display(fn)
272type(fnds),intent(in) :: fn
273if (c_e(fn%order) .and. c_e(fn%priority)) then
274 print *,"function : ",fn%name," order :",fn%order," priority :",fn%priority
275else if (c_e(fn%order)) then
276 print *,"function : ",fn%name," order :",fn%order
277else if (c_e(fn%priority)) then
278 print *,"function : ",fn%name," priority :",fn%priority
279else
280 print *,"function : ",fn%name
281end if
282print *,"input : ",fn%bin (:count(c_e(fn%bin)))
283print *,"output : ",fn%bout(:count(c_e(fn%bout)))
284print *,""
285
286end subroutine fn_display
287
289subroutine fnv_display(fnv)
290type(fndsv),intent(in) :: fnv
291integer :: i
292
293if (.not. allocated(fnv%fnds))return
294
295print *,"-------------------------------------------------"
296print *, "Here the function tree:"
297do i = count(c_e(fnv%fnds)),1,-1
298 call display(fnv%fnds(i))
299end do
300print *,"-------------------------------------------------"
301end subroutine fnv_display
302
303
304
306subroutine fnv_display_byorder(fnv,order)
307type(fndsv),intent(in) :: fnv
308integer,intent(in) :: order
309
310integer :: i
311
312print *,"-------------------------------------------------"
313print *, "Here the function tree for order: ",order
314do i = count(c_e(fnv%fnds)),1,-1
315 if (fnv%fnds(i)%order == order ) then
316 call display(fnv%fnds(i))
317 end if
318end do
319print *,"-------------------------------------------------"
320end subroutine fnv_display_byorder
321
322
323
325subroutine vfnv_display(vfnv)
326type(fndsv),intent(in) :: vfnv(:)
327integer :: i
328
329print *,">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>"
330do i = 1, size(vfnv)
331 print*,">> Function tree number:",i
332 call display(vfnv(i))
333end do
334print *,"<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<"
335end subroutine vfnv_display
336
337
338
342recursive logical function oracle(mybin,mybout,vfn,myvfn,recurse) result(stat)
343type(fndsv),intent(in) :: vfn
344character(len=*),intent(in) :: mybin(:)
345character(len=*),intent(in) :: mybout(:)
346type(fndsv),intent(out) :: myvfn
347logical,optional :: recurse
348
349type(fndsv),save :: usefullfn,maybefn
350
351!!$type(arrayof_fnds) :: tmp
352!!$tmp = arrayof_fnds_new()
353!!$append(tmp,myfn(1))
354!!$CALL packarray(tmp)
355!!$print *,tmp%array
356
357integer :: i,j,k,iin,iout
358logical :: allfoundout, foundout, somefoundin, foundin
359integer,save :: order,num
360character(len=10) :: newbin(nmaxb), newbout(nmaxb), tmpbin(nmaxb)
361
362
363! delete only on the main call
364if (.not. optio_log(recurse)) then
365 CALL l4f_log(l4f_debug, "oracle: delete and register")
366 call delete(maybefn)
367 call delete(usefullfn)
368 call delete(myvfn)
369 call fnregister(maybefn)
370 call fnregister(usefullfn)
371 call fnregister(myvfn)
372 order=0
373end if
374
375CALL l4f_log(l4f_debug, "oracle: order "//t2c(order))
376newbin=cmiss
377newbin(:size(mybin))=mybin
378newbout=cmiss
379newbout(:size(mybin))=mybin
380
381! order is level to put functions
382order=order+1
383somefoundin = .false.
384num=count(c_e(maybefn%fnds))
385tmpbin=cmiss
386
387!search for functions starting from input
388do i =1, count(c_e(vfn%fnds))
389 foundin = .true.
390 do j = 1, count(c_e(vfn%fnds(i)%bin(:)))
391 if (.not. any(vfn%fnds(i)%bin(j) == newbin)) foundin = .false.
392!!$ print *,"compare: ",vfn(i)%bin(j)
393!!$ print *,"with: ",mybin
394 end do
395 if (foundin) then
396 CALL l4f_log(l4f_debug, "oracle: register "//trim(vfn%fnds(i)%name))
397 call fnregister(maybefn,vfn%fnds(i),order)
398 do k=1,size(vfn%fnds(i)%bout)
399 tmpbin(firsttrue(.not. c_e(tmpbin)))=vfn%fnds(i)%bout(k)
400 newbout(firsttrue(.not. c_e(newbout)))=vfn%fnds(i)%bout(k)
401 end do
402 somefoundin = .true.
403 end if
404end do
405
406do i = 1, count(c_e(tmpbin))
407 newbin(firsttrue(.not. c_e(newbin)))=tmpbin(i)
408end do
409
410! here bin and bout are bigger (newbin, newbout)
411! by the output of applicable functions
412
413
414!check if we can work anymore
415stat = .false.
416if (.not. somefoundin) return
417if (num == count(c_e(maybefn%fnds))) return
418
419!check if we have finish
420allfoundout = .true.
421do i=1, count(c_e(mybout))
422 foundout = .false.
423 do j =1, count(c_e(newbout))
424 if (newbout(j) == mybout(i)) foundout = .true.
425 end do
426 if (.not. foundout) allfoundout = .false.
427end do
429
430! ok, all is done
431if (allfoundout) then
432
433!!$ print *, "intermediate"
434!!$ do i =1,size(maybefn)
435!!$ if (c_e(maybefn(i))) print *,maybefn(i)
436!!$ end do
437
438 ! remove dry branch
439 newbout=cmiss
440 newbout(:size(mybout))=mybout
441 tmpbin=cmiss
442
443 do i = count(c_e(maybefn%fnds)),1,-1
444 if (maybefn%fnds(i)%order /= order) then
445 CALL l4f_log(l4f_debug, "oracle: change order "//t2c(maybefn%fnds(i)%order))
446 order=maybefn%fnds(i)%order
447 iin=count(c_e(tmpbin))
448 iout=count(c_e(newbout))
449 newbout(iout+1:iout+iin)=tmpbin(:iin)
450 tmpbin=cmiss
451 end if
452
453 !print *,"search:",newbout(:firsttrue(.not. c_e(newbout)))
454
455 foundout = .false.
456 do j=1, count(c_e(newbout))
457 if (any(maybefn%fnds(i)%bout(:) == newbout(j))) foundout = .true.
458 end do
459 if (foundout) then
460 CALL l4f_log(l4f_debug, "oracle: other register "// trim(maybefn%fnds(i)%name))
461 call fnregister(myvfn,maybefn%fnds(i),order)
462 do k=1,count(c_e(maybefn%fnds(i)%bin))
463 tmpbin(firsttrue(.not. c_e(tmpbin)))=maybefn%fnds(i)%bin(k)
464 end do
465 end if
466 end do
467
468 stat = .true.
469
470else
471
472 stat=oracle(newbin,mybout,vfn,myvfn,.true.)
473
474end if
475
476! delete on exit only on the main call
477if (.not. optio_log(recurse)) then
478 call delete(maybefn)
479 call delete(usefullfn)
480 order=0
481end if
482
483end function oracle
484
485
489recursive logical function shoppinglist(mybout,vfn,myvfn, copy, recurse) result(stat)
490type(fndsv),intent(in) :: vfn
491character(len=*),intent(in) :: mybout(:)
492type(fndsv),intent(inout) :: myvfn
493logical,intent(in),optional :: copy
494logical,intent(in),optional :: recurse
495
496type(fndsv) :: vfntmp
497integer :: i,j,k
498logical :: somefoundout
499integer,save :: order
500character(len=10) :: newbout(nmaxb)
501
502stat=.true.
503newbout=cmiss
504vfntmp=vfn
505
506! delete only on the main call
507if (.not. optio_log(recurse)) then
508 CALL l4f_log(l4f_debug, "shoppinglist: main call (delete and register)")
509
510 call delete(myvfn)
511 call fnregister(myvfn)
512 order=0
513 newbout(:size(mybout))=mybout
514
515 if (optio_log(copy)) call register_copy(vfntmp,mybout)
516
517else
518
519 CALL l4f_log(l4f_debug, "shoppinglist: sub call; order:"//t2c(order))
520
521 !print*,pack(newbout,c_e(newbout))
522
523 do i=1, count(c_e(myvfn%fnds(:)))
524 !print*,"order:",myvfn%fnds(i)%order, order
525 if (myvfn%fnds(i)%order == order) then
526 do k=1,size(myvfn%fnds(i)%bin(:))
527 newbout(firsttrue(.not. c_e(newbout)))=myvfn%fnds(i)%bin(k)
528 end do
529 end if
530 end do
531
532end if
533
534!print*,pack(newbout,c_e(newbout))
535
536! order is level to put functions
537order=order+1
538somefoundout = .false.
539
540CALL l4f_log(l4f_debug, "shoppinglist: order "//t2c(order))
541
542!search for functions outputing my output
543do i =1, count(c_e(vfntmp%fnds))
544 !call display(vfntmp%fnds(i))
545 do j = 1, count(c_e(vfntmp%fnds(i)%bout(:)))
546 if (any(vfntmp%fnds(i)%bout(j) == newbout)) then
547 CALL l4f_log(l4f_debug, "shoppinglist: register "//trim(vfntmp%fnds(i)%name))
548 call fnregister(myvfn,vfntmp%fnds(i),order)
549 somefoundout = .true.
550 end if
551 end do
552end do
553
554!check if we can work anymore
555if (.not. somefoundout) return
556
557stat=shoppinglist(mybout,vfntmp,myvfn,copy=optio_log(copy), recurse=.true.)
558
559! delete on exit only on the main call
560if (.not. optio_log(recurse)) then
561 call delete(vfntmp)
562 order=0
563end if
564
565end function shoppinglist
566
567
570subroutine makev(mayvfn,mybin,mybout,myin,myout)
571type(fndsv),intent(inout) :: mayvfn
572character(len=*),intent(in) :: mybin(:)
573character(len=*),intent(in) :: mybout(:)
574real,intent(in) :: myin(:,:)
575real,intent(out) :: myout(:,:)
576integer :: i,j
577character(len=10) :: newbout(mayvfn%nout)
578
579
580newbout=cmiss
581do i=1, size(mayvfn%fnds)
582 if (c_e(mayvfn%fnds(i))) then
583 do j=1, size(mayvfn%fnds(i)%bout)
584 if (c_e(mayvfn%fnds(i)%bout(j))) then
585 if (index_c(newbout,mayvfn%fnds(i)%bout(j)) <= 0) then
586 newbout(index_c(newbout,cmiss)) = mayvfn%fnds(i)%bout(j)
587 end if
588 end if
589 end do
590 end if
591end do
592
593do i=size(mayvfn%fnds),1,-1
594 if (c_e(mayvfn%fnds(i))) then
595 print *,"name:",mayvfn%fnds(i)%name,"order:",mayvfn%fnds(i)%order
596
597 call mayvfn%fnds(i)%fn(mybin,newbout,mayvfn%fnds(i)%bin,mayvfn%fnds(i)%bout,myin,myout)
598 !print *,"make",i,mayvfn%fnds(i)%bin,mayvfn%fnds(i)%bout
599 end if
600end do
601
602!!$#include "arrayof_post.F90"
603
604end subroutine makev
605
606
607
608
610function compile_sl(myvfn)
611
612type(shoplists) :: compile_sl
613type(fndsv),intent(in) :: myvfn
614
615integer :: i,j,k,nshoplist,nvar,nfunc,indfunc,indvar
616CHARACTER(len=10),allocatable :: bvartmp(:)
617
618indfunc=0
619nshoplist=(maxval(myvfn%fnds(:)%order))
620nshoplist=max(0,nshoplist)
621allocate (compile_sl%shoplist(nshoplist))
622
623nvar=1
624
625do i=1,nshoplist
626 nfunc=count(myvfn%fnds(:)%order==i)
627 allocate(compile_sl%shoplist(i)%bvar(nvar-1))
628 if (i > 1) then
629 compile_sl%shoplist(i)%bvar = compile_sl%shoplist(i-1)%bvar
630 do j = indfunc+1, indfunc+nfunc
631 do k = 1, size(myvfn%fnds(j)%bout)
632 indvar=index_c(compile_sl%shoplist(i)%bvar,myvfn%fnds(j)%bout(k))
633 if (indvar > 0) compile_sl%shoplist(i)%bvar(indvar)=cmiss
634 end do
635 end do
636 end if
637 do j = indfunc+1, indfunc+nfunc
638 do k = 1, size(myvfn%fnds(j)%bin)
639 if (index_c(compile_sl%shoplist(i)%bvar,myvfn%fnds(j)%bin(k)) > 0 ) cycle
640 allocate(bvartmp(nvar))
641 bvartmp(:nvar-1)=compile_sl%shoplist(i)%bvar
642 call move_alloc(from=bvartmp ,to=compile_sl%shoplist(i)%bvar)
643 compile_sl%shoplist(i)%bvar(nvar)=myvfn%fnds(j)%bin(k)
644 nvar=nvar+1
645 end do
646 end do
647 indfunc=indfunc+nfunc
648end do
649
650do i=1,nshoplist
651 compile_sl%shoplist(i)%bvar=pack(compile_sl%shoplist(i)%bvar,c_e(compile_sl%shoplist(i)%bvar))
652end do
653
654end function compile_sl
655
656end module alchimia
657
662
665
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
This module defines objects and methods for generating derivative variables.
Definition: alchimia.F03:214
This module defines usefull general purpose function and subroutine.
Utilities for CHARACTER variables.
classe per la gestione del logging
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
shoplist are list of variables
Definition: alchimia.F03:255
Vector of shoplists that are list of variables.
Definition: alchimia.F03:260

Generated with Doxygen.