36integer,
parameter :: nmaxb=100
39 subroutine elabora(mybin,mybout,bin,bout,in,out)
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
51 CHARACTER(len=50) :: name=cmiss
52 CHARACTER(len=10),
allocatable :: bin(:)
53 CHARACTER(len=10),
allocatable :: bout(:)
56 procedure(elabora) ,
nopass,
pointer :: fn
61 integer :: nin = imiss
62 integer :: nout = imiss
63 type(fnds),
allocatable :: fnds(:)
68 CHARACTER(len=10),
allocatable :: bvar(:)
73 type(shoplist),
allocatable :: shoplist(:)
78 module procedure c_e_fn
81interface OPERATOR (==)
82 module procedure equal_fn
86 module procedure fn_init
91 module procedure fn_display, fnv_display, vfnv_display, fnv_display_byorder, sl_display
96 module procedure fnv_delete
101 module procedure makev
114public shoppinglist,
shoplists, compile_sl
119subroutine register_copy(vfn,bin)
121 type(fndsv),
intent(inout) :: vfn
122 CHARACTER(len=10),
intent(in) :: bin(:)
126 call fnregister(vfn,alchimia_copy_def(bin(i)))
129end subroutine register_copy
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(:,:)
139 out(:,index_c(mybout,bout(1)))=in(:,index_c(mybin,bin(1)))
141end subroutine alchimia_copy
143type(fnds) function alchimia_copy_def(bvar)
144 CHARACTER(len=10),
intent(in) :: bvar
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
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
161call optio(name,fn%name)
163if (
present(bin))
then
170if (
present(bout))
then
177call optio(priority,fn%priority)
178call optio(order,fn%order)
180if (
present(func))
then
186end subroutine fn_init
190elemental subroutine fnv_delete(fnv)
191type(fndsv),
intent(inout) :: fnv
196end subroutine fnv_delete
201subroutine fnregister(vfn,fn,order)
203type(fndsv),
intent(inout) :: vfn
204type(fnds),
intent(in),
optional :: fn
205integer,
optional :: order
210if (.not.
allocated(vfn%fnds))
then
211 allocate(vfn%fnds(0))
218 if (firsttrue(vfn%fnds == fn) /= 0)
return
221 allocate(vfntmp%fnds(nfn+1))
223 vfntmp%fnds(:nfn)=vfn%fnds
225 call move_alloc(from=vfntmp%fnds ,to=vfn%fnds)
228 if (
present(order)) vfn%fnds(nfn+1)%order = order
230 vfn%nin=vfn%nin+
size(fn%bin)
231 vfn%nout=vfn%nout+
size(fn%bout)
233 CALL l4f_log(l4f_debug,
'fnregister: adding function object '//trim(fn%name)//
' ; nout '//t2c(vfn%nout))
237end subroutine fnregister
240elemental logical function c_e_fn(fn)
241type(fnds),
intent(in) :: fn
247elemental logical function equal_fn(this,that)
248type(fnds),
intent(in) :: this,that
250equal_fn= this%name == that%name
256subroutine sl_display(sl)
261do i = 1,
size(sl%shoplist)
262 print *,
"shopping list : ",i
263 print *,
"varlist : ",sl%shoplist(i)%bvar
267end subroutine sl_display
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
280 print *,
"function : ",fn%name
282print *,
"input : ",fn%bin (:count(
c_e(fn%bin)))
283print *,
"output : ",fn%bout(:count(
c_e(fn%bout)))
286end subroutine fn_display
289subroutine fnv_display(fnv)
290type(fndsv),
intent(in) :: fnv
293if (.not.
allocated(fnv%fnds))
return
295print *,
"-------------------------------------------------"
296print *,
"Here the function tree:"
297do i = count(
c_e(fnv%fnds)),1,-1
300print *,
"-------------------------------------------------"
301end subroutine fnv_display
306subroutine fnv_display_byorder(fnv,order)
308integer,
intent(in) :: order
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
319print *,
"-------------------------------------------------"
320end subroutine fnv_display_byorder
325subroutine vfnv_display(vfnv)
326type(
fndsv),
intent(in) :: vfnv(:)
329print *,
">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>"
331 print*,
">> Function tree number:",i
334print *,
"<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<"
335end subroutine vfnv_display
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
349type(
fndsv),
save :: usefullfn,maybefn
357integer :: i,j,k,iin,iout
358logical :: allfoundout, foundout, somefoundin, foundin
359integer,
save :: order,num
360character(len=10) :: newbin(nmaxb), newbout(nmaxb), tmpbin(nmaxb)
364if (.not. optio_log(recurse))
then
365 CALL l4f_log(l4f_debug,
"oracle: delete and register")
369 call fnregister(maybefn)
370 call fnregister(usefullfn)
371 call fnregister(myvfn)
375CALL l4f_log(l4f_debug,
"oracle: order "//t2c(order))
377newbin(:
size(mybin))=mybin
379newbout(:
size(mybin))=mybin
384num=count(
c_e(maybefn%fnds))
388do i =1, count(
c_e(vfn%fnds))
390 do j = 1, count(
c_e(vfn%fnds(i)%bin(:)))
391 if (.not. any(vfn%fnds(i)%bin(j) == newbin)) foundin = .false.
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)
406do i = 1, count(
c_e(tmpbin))
407 newbin(firsttrue(.not.
c_e(newbin)))=tmpbin(i)
416if (.not. somefoundin)
return
417if (num == count(
c_e(maybefn%fnds)))
return
421do i=1, count(
c_e(mybout))
423 do j =1, count(
c_e(newbout))
424 if (newbout(j) == mybout(i)) foundout = .true.
426 if (.not. foundout) allfoundout = .false.
440 newbout(:
size(mybout))=mybout
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)
456 do j=1, count(
c_e(newbout))
457 if (any(maybefn%fnds(i)%bout(:) == newbout(j))) foundout = .true.
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)
472 stat=oracle(newbin,mybout,vfn,myvfn,.true.)
477if (.not. optio_log(recurse))
then
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
498logical :: somefoundout
500character(len=10) :: newbout(nmaxb)
507if (.not. optio_log(recurse))
then
508 CALL l4f_log(l4f_debug,
"shoppinglist: main call (delete and register)")
511 call fnregister(myvfn)
513 newbout(:
size(mybout))=mybout
515 if (optio_log(copy))
call register_copy(vfntmp,mybout)
519 CALL l4f_log(l4f_debug,
"shoppinglist: sub call; order:"//t2c(order))
523 do i=1, count(
c_e(myvfn%fnds(:)))
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)
538somefoundout = .false.
540CALL l4f_log(l4f_debug,
"shoppinglist: order "//t2c(order))
543do i =1, count(
c_e(vfntmp%fnds))
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.
555if (.not. somefoundout)
return
557stat=shoppinglist(mybout,vfntmp,myvfn,copy=optio_log(copy), recurse=.true.)
560if (.not. optio_log(recurse))
then
565end function shoppinglist
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(:,:)
577character(len=10) :: newbout(mayvfn%nout)
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)
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
597 call mayvfn%fnds(i)%fn(mybin,newbout,mayvfn%fnds(i)%bin,mayvfn%fnds(i)%bout,myin,myout)
610function compile_sl(myvfn)
613type(
fndsv),
intent(in) :: myvfn
615integer :: i,j,k,nshoplist,nvar,nfunc,indfunc,indvar
616CHARACTER(len=10),
allocatable :: bvartmp(:)
619nshoplist=(maxval(myvfn%fnds(:)%order))
620nshoplist=max(0,nshoplist)
621allocate (compile_sl%shoplist(nshoplist))
626 nfunc=count(myvfn%fnds(:)%order==i)
627 allocate(compile_sl%shoplist(i)%bvar(nvar-1))
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
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)
647 indfunc=indfunc+nfunc
651 compile_sl%shoplist(i)%bvar=pack(compile_sl%shoplist(i)%bvar,
c_e(compile_sl%shoplist(i)%bvar))
654end function compile_sl
Check missing values for fnds.
show on the screen the fnds and fndsv structure
Do the real work to transform the input data to the output.
This module defines objects and methods for generating derivative variables.
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.
shoplist are list of variables
Vector of shoplists that are list of variables.