36 integer,
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
81 interface 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
114 public shoppinglist,
shoplists, compile_sl
119 subroutine 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)))
129 end subroutine register_copy
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(:,:)
139 out(:,index_c(mybout,bout(1)))=in(:,index_c(mybin,bin(1)))
141 end subroutine alchimia_copy
143 type(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)
149 end function alchimia_copy_def
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
161 call optio(name,fn%name)
163 if (
present(bin))
then
170 if (
present(bout))
then
177 call optio(priority,fn%priority)
178 call optio(order,fn%order)
180 if (
present(func))
then
186 end subroutine fn_init
190 elemental subroutine fnv_delete(fnv)
191 type(fndsv),
intent(inout) :: fnv
196 end subroutine fnv_delete
201 subroutine fnregister(vfn,fn,order)
203 type(fndsv),
intent(inout) :: vfn
204 type(fnds),
intent(in),
optional :: fn
205 integer,
optional :: order
208 type(fndsv) :: vfntmp
210 if (.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))
237 end subroutine fnregister
240 elemental logical function c_e_fn(fn)
241 type(fnds),
intent(in) :: fn
247 elemental logical function equal_fn(this,that)
248 type(fnds),
intent(in) :: this,that
250 equal_fn= this%name == that%name
252 end function equal_fn
256 subroutine sl_display(sl)
257 type(shoplists),
intent(in) :: sl
261 do i = 1,
size(sl%shoplist)
262 print *,
"shopping list : ",i
263 print *,
"varlist : ",sl%shoplist(i)%bvar
267 end subroutine sl_display
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
280 print *,
"function : ",fn%name
282 print *,
"input : ",fn%bin (:count(
c_e(fn%bin)))
283 print *,
"output : ",fn%bout(:count(
c_e(fn%bout)))
286 end subroutine fn_display
289 subroutine fnv_display(fnv)
290 type(fndsv),
intent(in) :: fnv
293 if (.not.
allocated(fnv%fnds))
return
295 print *,
"-------------------------------------------------"
296 print *,
"Here the function tree:"
297 do i = count(
c_e(fnv%fnds)),1,-1
300 print *,
"-------------------------------------------------"
301 end subroutine fnv_display
306 subroutine fnv_display_byorder(fnv,order)
307 type(fndsv),
intent(in) :: fnv
308 integer,
intent(in) :: order
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
319 print *,
"-------------------------------------------------"
320 end subroutine fnv_display_byorder
325 subroutine vfnv_display(vfnv)
326 type(
fndsv),
intent(in) :: vfnv(:)
329 print *,
">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>"
331 print*,
">> Function tree number:",i
334 print *,
"<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<"
335 end subroutine vfnv_display
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
349 type(
fndsv),
save :: usefullfn,maybefn
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)
364 if (.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)
375 CALL l4f_log(l4f_debug,
"oracle: order "//t2c(order))
377 newbin(:
size(mybin))=mybin
379 newbout(:
size(mybin))=mybin
383 somefoundin = .false.
384 num=count(
c_e(maybefn%fnds))
388 do 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)
406 do i = 1, count(
c_e(tmpbin))
407 newbin(firsttrue(.not.
c_e(newbin)))=tmpbin(i)
416 if (.not. somefoundin)
return
417 if (num == count(
c_e(maybefn%fnds)))
return
421 do 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.
431 if (allfoundout)
then
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.)
477 if (.not. optio_log(recurse))
then
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
496 type(
fndsv) :: vfntmp
498 logical :: somefoundout
499 integer,
save :: order
500 character(len=10) :: newbout(nmaxb)
507 if (.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)
538 somefoundout = .false.
540 CALL l4f_log(l4f_debug,
"shoppinglist: order "//t2c(order))
543 do 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.
555 if (.not. somefoundout)
return
557 stat=shoppinglist(mybout,vfntmp,myvfn,copy=optio_log(copy), recurse=.true.)
560 if (.not. optio_log(recurse))
then
565 end function shoppinglist
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(:,:)
577 character(len=10) :: newbout(mayvfn%nout)
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)
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
597 call mayvfn%fnds(i)%fn(mybin,newbout,mayvfn%fnds(i)%bin,mayvfn%fnds(i)%bout,myin,myout)
610 function compile_sl(myvfn)
613 type(
fndsv),
intent(in) :: myvfn
615 integer :: i,j,k,nshoplist,nvar,nfunc,indfunc,indvar
616 CHARACTER(len=10),
allocatable :: bvartmp(:)
619 nshoplist=(maxval(myvfn%fnds(:)%order))
620 nshoplist=max(0,nshoplist)
621 allocate (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))
654 end 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.