libsim  Versione7.2.3
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
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
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
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))
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 
Module for quickly interpreting the OPTIONAL parameters passed to a subprogram.
Vector of function to transform the input to alchimia module.
Definition: alchimia.F03:258
Do the real work to transform the input data to the output.
Definition: alchimia.F03:298
Delete fndsv.
Definition: alchimia.F03:293
Vector of shoplists that are list of variables.
Definition: alchimia.F03:270
show on the screen the fnds and fndsv structure
Definition: alchimia.F03:288
This module defines objects and methods for generating derivative variables.
Definition: alchimia.F03:224
This module defines usefull general purpose function and subroutine.
Definitions of constants and functions for working with missing values.
Check missing values for fnds.
Definition: alchimia.F03:275
classe per la gestione del logging
Utilities for CHARACTER variables.
shoplist are list of variables
Definition: alchimia.F03:265

Generated with Doxygen.