12integer,
parameter :: nmaxb=100
15 subroutine elabora(mybin,mybout,bin,bout,in,out)
17 CHARACTER(len=10),
intent(in) :: mybin(:)
18 CHARACTER(len=10),
intent(in) :: mybout(:)
19 CHARACTER(len=10),
intent(in) :: bin(:)
20 CHARACTER(len=10),
intent(in) :: bout(:)
21 real,
intent(in) :: in(:,:)
22 real,
intent(out) :: out(:,:)
23 end subroutine elabora
27 CHARACTER(len=10) :: name=cmiss
28 CHARACTER(len=10),
allocatable :: bin(:)
29 CHARACTER(len=10),
allocatable :: bout(:)
32 procedure(elabora),
nopass,
pointer :: fn
36 procedure :: c_e => c_e_fn
37 generic ::
operator(==) => equal_fn
38 procedure :: init => init_fn
39 procedure :: display => display_fn
43 integer :: nout = imiss
44 type(fnds),
allocatable :: fnds(:)
49 module procedure fnv_display
53 module procedure fnv_delete
57 module procedure makev
72subroutine init_fn(fn,name,bin,bout,priority,order,func)
73CLASS(fnds),
intent(inout) :: fn
74CHARACTER(len=*),
optional :: name
75CHARACTER(len=*),
optional :: bin(:)
76CHARACTER(len=*),
optional :: bout(:)
77integer,
optional :: priority
78integer,
optional :: order
79procedure(elabora),
optional :: func
81call optio(name,fn%name)
90if (
present(bout))
then
97call optio(priority,fn%priority)
98call optio(order,fn%order)
100if (
present(func))
then
106end subroutine init_fn
110subroutine fnv_delete(fnv)
111type(fndsv),
intent(inout) :: fnv
116end subroutine fnv_delete
119subroutine fnregister(vfn,fn,order)
121type(
fndsv),
intent(inout) :: vfn
122type(fnds),
intent(in),
optional :: fn
123integer,
optional :: order
128if (.not.
allocated(vfn%fnds))
then
129 allocate(vfn%fnds(0))
135 if (firsttrue(vfn%fnds == fn) /= 0)
return
138 allocate(vfntmp%fnds(nfn+1))
140 vfntmp%fnds(:nfn)=vfn%fnds
142 call move_alloc(from=vfntmp%fnds ,to=vfn%fnds)
145 if (
present(order)) vfn%fnds(nfn+1)%order = order
147 vfn%nout=vfn%nout+
size(fn%bout)
151end subroutine fnregister
154elemental logical function c_e_fn(fn)
155class(fnds),
intent(in) :: fn
161elemental logical function equal_fn(this,that)
162class(fnds),
intent(in) :: this,that
164equal_fn= this%name == that%name
169subroutine display_fn(fn)
170class(fnds),
intent(in) :: fn
172print *,fn%name,
" : ",fn%bin(:count(
c_e(fn%bin)))
173print *,
"get : ",fn%bout(:count(
c_e(fn%bout)))
176end subroutine display_fn
178subroutine fnv_display(fnv)
179type(
fndsv),
intent(in) :: fnv
182print *,
"Here we have the solution:"
183do i = count(fnv%fnds%c_e()),1,-1
184 call fnv%fnds(i)%display()
186end subroutine fnv_display
188recursive logical function oracle(mybin,mybout,vfn,mayvfn,recurse)
result(stat)
189type(
fndsv),
intent(in) :: vfn
190character(len=*),
intent(in) :: mybin(:),mybout(:)
191type(
fndsv),
intent(out) :: mayvfn
193type(
fndsv),
save :: usefullfn,maybefn
201integer :: i,j,k,iin,iout
202logical :: allfoundout, foundout, somefoundin, foundin
203logical,
optional :: recurse
204integer,
save :: order,num
205character(len=10) :: newbin(nmaxb), newbout(nmaxb), tmpbin(nmaxb)
209if (.not. optio_log(recurse))
then
213 call fnregister(maybefn)
214 call fnregister(usefullfn)
221newbin(:
size(mybin))=mybin
223newbout(:
size(mybin))=mybin
228num=count(maybefn%fnds%c_e())
232do i =1, count(vfn%fnds%c_e())
234 do j = 1, count(
c_e(vfn%fnds(i)%bin(:)))
235 if (.not. any(vfn%fnds(i)%bin(j) == newbin)) foundin = .false.
241 call fnregister(maybefn,vfn%fnds(i),order)
242 do k=1,
size(vfn%fnds(i)%bout)
243 tmpbin(firsttrue(.not.
c_e(tmpbin)))=vfn%fnds(i)%bout(k)
244 newbout(firsttrue(.not.
c_e(newbout)))=vfn%fnds(i)%bout(k)
250do i = 1, count(
c_e(tmpbin))
251 newbin(firsttrue(.not.
c_e(newbin)))=tmpbin(i)
260if (.not. somefoundin)
return
261if (num == count(maybefn%fnds%c_e()))
return
265do i=1, count(
c_e(mybout))
267 do j =1, count(
c_e(newbout))
268 if (newbout(j) == mybout(i)) foundout = .true.
270 if (.not. foundout) allfoundout = .false.
284 newbout(:
size(mybout))=mybout
287 do i = count(maybefn%fnds%c_e()),1,-1
288 if (maybefn%fnds(i)%order /= order)
then
290 order=maybefn%fnds(i)%order
291 iin=count(
c_e(tmpbin))
292 iout=count(
c_e(newbout))
293 newbout(iout+1:iout+iin)=tmpbin(:iin)
300 do j=1, count(
c_e(newbout))
301 if (any(maybefn%fnds(i)%bout(:) == newbout(j))) foundout = .true.
305 call fnregister(mayvfn,maybefn%fnds(i),order)
306 do k=1,count(
c_e(maybefn%fnds(i)%bin))
307 tmpbin(firsttrue(.not.
c_e(tmpbin)))=maybefn%fnds(i)%bin(k)
316 stat=oracle(newbin,mybout,vfn,mayvfn,.true.)
321if (.not. optio_log(recurse))
then
330subroutine makev(mayvfn,mybin,mybout,myin,myout)
331type(
fndsv),
intent(inout) :: mayvfn
332character(len=*),
intent(in) :: mybin(:),mybout(:)
333real,
intent(in) :: myin(:,:)
334real,
intent(out) :: myout(:,:)
337do i=
size(mayvfn%fnds),1,-1
338 if (mayvfn%fnds(i)%c_e())
then
339 call mayvfn%fnds(i)%fn(mybin,mybout,mayvfn%fnds(i)%bin,mayvfn%fnds(i)%bout,myin,myout)
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.
Generic subroutine for checking OPTIONAL parameters.
This module defines objects and methods for generating derivative variables.
This module defines usefull general purpose function and subroutine.
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.