libsim  Versione 7.1.7
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 
26 module alchimia
27 
31 USE log4fortran
33 
34 IMPLICIT NONE
35 
36 integer, parameter :: nmaxb=100
37 
38 abstract 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
48 end interface
49 
50 type 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
57 end type fnds
58 
60 type fndsv
61  integer :: nin = imiss
62  integer :: nout = imiss
63  type(fnds),allocatable :: fnds(:)
64 end type fndsv
65 
67 type shoplist
68  CHARACTER(len=10),allocatable :: bvar(:)
69 end type shoplist
70 
72 type shoplists
73  type(shoplist),allocatable :: shoplist(:)
74 end type shoplists
75 
77 interface c_e
78  module procedure c_e_fn
79 end interface
80 
81 interface OPERATOR (==)
82  module procedure equal_fn
83 end interface
84 
85 interface init
86  module procedure fn_init
87 end interface
88 
90 interface display
91  module procedure fn_display, fnv_display, vfnv_display, fnv_display_byorder, sl_display
92 end interface
93 
95 interface delete
96  module procedure fnv_delete
97 end interface
98 
100 interface make
101  module procedure makev
102 end 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
112 private
113 public fnds,fndsv,make,init,c_e,display,delete,fnregister,oracle,register_copy
114 public shoppinglist, shoplists, compile_sl
115 
116 contains
117 
119 subroutine 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 
129 end subroutine register_copy
130 
131 subroutine 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 
141 end subroutine alchimia_copy
142 
143 type(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)
149 end function alchimia_copy_def
150 
152 subroutine fn_init(fn,name,bin,bout,priority,order,func)
153 type(fnds),intent(inout) :: fn
154 CHARACTER(len=*),optional :: name
155 CHARACTER(len=*),optional :: bin(:)
156 CHARACTER(len=*),optional :: bout(:)
157 integer,optional :: priority
158 integer,optional :: order
159 procedure(elabora),optional :: func
160 
161 call optio(name,fn%name)
162 
163 if (present(bin)) then
164  fn%bin=bin
165 else
166  allocate(fn%bin(1))
167  fn%bin=cmiss
168 end if
169 
170 if (present(bout)) then
171  fn%bout=bout
172 else
173  allocate(fn%bout(1))
174  fn%bout=cmiss
175 end if
176 
177 call optio(priority,fn%priority)
178 call optio(order,fn%order)
179 
180 if (present(func)) then
181  fn%fn => func
182 else
183  fn%fn => null()
184 end if
185 
186 end subroutine fn_init
187 
188 
190 elemental subroutine fnv_delete(fnv)
191 type(fndsv),intent(inout) :: fnv
192 type(fndsv) :: fn
193 
194 fnv=fn
195 
196 end subroutine fnv_delete
197 
201 subroutine fnregister(vfn,fn,order)
202 
203 type(fndsv),intent(inout) :: vfn
204 type(fnds),intent(in),optional :: fn
205 integer,optional :: order
206 
207 integer :: nfn
208 type(fndsv) :: vfntmp
209 
210 if (.not. allocated(vfn%fnds))then
211  allocate(vfn%fnds(0))
212  vfn%nin=0
213  vfn%nout=0
214 end if
215 
216 if (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 
235 end if
236 
237 end subroutine fnregister
238 
240 elemental logical function c_e_fn(fn)
241 type(fnds),intent(in) :: fn
242 
243 c_e_fn= c_e(fn%name)
244 
245 end function c_e_fn
246 
247 elemental logical function equal_fn(this,that)
248 type(fnds),intent(in) :: this,that
249 
250 equal_fn= this%name == that%name
251 
252 end function equal_fn
253 
254 
256 subroutine sl_display(sl)
257 type(shoplists),intent(in) :: sl
258 
259 integer :: i
260 
261 do i = 1, size(sl%shoplist)
262  print *,"shopping list : ",i
263  print *,"varlist : ",sl%shoplist(i)%bvar
264  print *,""
265 end do
266 
267 end subroutine sl_display
268 
269 
271 subroutine fn_display(fn)
272 type(fnds),intent(in) :: fn
273 if (c_e(fn%order) .and. c_e(fn%priority)) then
274  print *,"function : ",fn%name," order :",fn%order," priority :",fn%priority
275 else if (c_e(fn%order)) then
276  print *,"function : ",fn%name," order :",fn%order
277 else if (c_e(fn%priority)) then
278  print *,"function : ",fn%name," priority :",fn%priority
279 else
280  print *,"function : ",fn%name
281 end if
282 print *,"input : ",fn%bin (:count(c_e(fn%bin)))
283 print *,"output : ",fn%bout(:count(c_e(fn%bout)))
284 print *,""
285 
286 end subroutine fn_display
287 
289 subroutine fnv_display(fnv)
290 type(fndsv),intent(in) :: fnv
291 integer :: i
292 
293 if (.not. allocated(fnv%fnds))return
294 
295 print *,"-------------------------------------------------"
296 print *, "Here the function tree:"
297 do i = count(c_e(fnv%fnds)),1,-1
298  call display(fnv%fnds(i))
299 end do
300 print *,"-------------------------------------------------"
301 end subroutine fnv_display
302 
303 
304 
306 subroutine fnv_display_byorder(fnv,order)
307 type(fndsv),intent(in) :: fnv
308 integer,intent(in) :: order
309 
310 integer :: i
311 
312 print *,"-------------------------------------------------"
313 print *, "Here the function tree for order: ",order
314 do 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
318 end do
319 print *,"-------------------------------------------------"
320 end subroutine fnv_display_byorder
321 
322 
323 
325 subroutine vfnv_display(vfnv)
326 type(fndsv),intent(in) :: vfnv(:)
327 integer :: i
328 
329 print *,">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>"
330 do i = 1, size(vfnv)
331  print*,">> Function tree number:",i
332  call display(vfnv(i))
333 end do
334 print *,"<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<"
335 end subroutine vfnv_display
336 
337 
338 
342 recursive logical function oracle(mybin,mybout,vfn,myvfn,recurse) result(stat)
343 type(fndsv),intent(in) :: vfn
344 character(len=*),intent(in) :: mybin(:)
345 character(len=*),intent(in) :: mybout(:)
346 type(fndsv),intent(out) :: myvfn
347 logical,optional :: recurse
348 
349 type(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 
357 integer :: i,j,k,iin,iout
358 logical :: allfoundout, foundout, somefoundin, foundin
359 integer,save :: order,num
360 character(len=10) :: newbin(nmaxb), newbout(nmaxb), tmpbin(nmaxb)
361 
362 
363 ! delete only on the main call
364 if (.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
373 end if
374 
375 CALL l4f_log(l4f_debug, "oracle: order "//t2c(order))
376 newbin=cmiss
377 newbin(:size(mybin))=mybin
378 newbout=cmiss
379 newbout(:size(mybin))=mybin
380 
381 ! order is level to put functions
382 order=order+1
383 somefoundin = .false.
384 num=count(c_e(maybefn%fnds))
385 tmpbin=cmiss
386 
387 !search for functions starting from input
388 do 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
404 end do
405 
406 do i = 1, count(c_e(tmpbin))
407  newbin(firsttrue(.not. c_e(newbin)))=tmpbin(i)
408 end 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
415 stat = .false.
416 if (.not. somefoundin) return
417 if (num == count(c_e(maybefn%fnds))) return
418 
419 !check if we have finish
420 allfoundout = .true.
421 do 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.
427 end do
428 
429 
430 ! ok, all is done
431 if (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 
470 else
471 
472  stat=oracle(newbin,mybout,vfn,myvfn,.true.)
473 
474 end if
475 
476 ! delete on exit only on the main call
477 if (.not. optio_log(recurse)) then
478  call delete(maybefn)
479  call delete(usefullfn)
480  order=0
481 end if
482 
483 end function oracle
484 
485 
489 recursive logical function shoppinglist(mybout,vfn,myvfn, copy, recurse) result(stat)
490 type(fndsv),intent(in) :: vfn
491 character(len=*),intent(in) :: mybout(:)
492 type(fndsv),intent(inout) :: myvfn
493 logical,intent(in),optional :: copy
494 logical,intent(in),optional :: recurse
495 
496 type(fndsv) :: vfntmp
497 integer :: i,j,k
498 logical :: somefoundout
499 integer,save :: order
500 character(len=10) :: newbout(nmaxb)
501 
502 stat=.true.
503 newbout=cmiss
504 vfntmp=vfn
505 
506 ! delete only on the main call
507 if (.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 
517 else
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 
532 end if
533 
534 !print*,pack(newbout,c_e(newbout))
535 
536 ! order is level to put functions
537 order=order+1
538 somefoundout = .false.
539 
540 CALL l4f_log(l4f_debug, "shoppinglist: order "//t2c(order))
541 
542 !search for functions outputing my output
543 do 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
552 end do
553 
554 !check if we can work anymore
555 if (.not. somefoundout) return
556 
557 stat=shoppinglist(mybout,vfntmp,myvfn,copy=optio_log(copy), recurse=.true.)
558 
559 ! delete on exit only on the main call
560 if (.not. optio_log(recurse)) then
561  call delete(vfntmp)
562  order=0
563 end if
564 
565 end function shoppinglist
566 
567 
570 subroutine makev(mayvfn,mybin,mybout,myin,myout)
571 type(fndsv),intent(inout) :: mayvfn
572 character(len=*),intent(in) :: mybin(:)
573 character(len=*),intent(in) :: mybout(:)
574 real,intent(in) :: myin(:,:)
575 real,intent(out) :: myout(:,:)
576 integer :: i,j
577 character(len=10) :: newbout(mayvfn%nout)
578 
579 
580 newbout=cmiss
581 do 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
591 end do
592 
593 do 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
600 end do
601 
602 !!$#include "arrayof_post.F90"
603 
604 end subroutine makev
605 
606 
607 
608 
610 function compile_sl(myvfn)
611 
612 type(shoplists) :: compile_sl
613 type(fndsv),intent(in) :: myvfn
614 
615 integer :: i,j,k,nshoplist,nvar,nfunc,indfunc,indvar
616 CHARACTER(len=10),allocatable :: bvartmp(:)
617 
618 indfunc=0
619 nshoplist=(maxval(myvfn%fnds(:)%order))
620 nshoplist=max(0,nshoplist)
621 allocate (compile_sl%shoplist(nshoplist))
622 
623 nvar=1
624 
625 do 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
648 end do
649 
650 do i=1,nshoplist
651  compile_sl%shoplist(i)%bvar=pack(compile_sl%shoplist(i)%bvar,c_e(compile_sl%shoplist(i)%bvar))
652 end do
653 
654 end function compile_sl
655 
656 end module alchimia
657 
662 
665 
Check missing values for fnds.
Definition: alchimia.F03:271
Delete fndsv.
Definition: alchimia.F03:289
show on the screen the fnds and fndsv structure
Definition: alchimia.F03:284
Do the real work to transform the input data to the output.
Definition: alchimia.F03:294
This module defines objects and methods for generating derivative variables.
Definition: alchimia.F03:220
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:254
shoplist are list of variables
Definition: alchimia.F03:261
Vector of shoplists that are list of variables.
Definition: alchimia.F03:266

Generated with Doxygen.