12 integer,
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
72 subroutine init_fn(fn,name,bin,bout,priority,order,func)
73 CLASS(fnds),
intent(inout) :: fn
74 CHARACTER(len=*),
optional :: name
75 CHARACTER(len=*),
optional :: bin(:)
76 CHARACTER(len=*),
optional :: bout(:)
77 integer,
optional :: priority
78 integer,
optional :: order
79 procedure(elabora),
optional :: func
81 call optio(name,fn%name)
83 if (
present(bin))
then 90 if (
present(bout))
then 97 call optio(priority,fn%priority)
98 call optio(order,fn%order)
100 if (
present(func))
then 106 end subroutine init_fn
110 subroutine fnv_delete(fnv)
111 type(fndsv),
intent(inout) :: fnv
116 end subroutine fnv_delete
119 subroutine fnregister(vfn,fn,order)
121 type(fndsv),
intent(inout) :: vfn
122 type(fnds),
intent(in),
optional :: fn
123 integer,
optional :: order
126 type(fndsv) :: vfntmp
128 if (.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)
151 end subroutine fnregister
154 elemental logical function c_e_fn(fn)
155 class(fnds),
intent(in) :: fn
161 elemental logical function equal_fn(this,that)
162 class(fnds),
intent(in) :: this,that
164 equal_fn= this%name == that%name
166 end function equal_fn
169 subroutine display_fn(fn)
170 class(fnds),
intent(in) :: fn
172 print *,fn%name,
" : ",fn%bin(:count(
c_e(fn%bin)))
173 print *,
"get : ",fn%bout(:count(
c_e(fn%bout)))
176 end subroutine display_fn
178 subroutine fnv_display(fnv)
179 type(fndsv),
intent(in) :: fnv
182 print *,
"Here we have the solution:" 183 do i = count(fnv%fnds%c_e()),1,-1
184 call fnv%fnds(i)%display()
186 end subroutine fnv_display
188 recursive logical function oracle(mybin,mybout,vfn,mayvfn,recurse)
result(stat)
189 type(fndsv),
intent(in) :: vfn
190 character(len=*),
intent(in) :: mybin(:),mybout(:)
191 type(fndsv),
intent(out) :: mayvfn
193 type(fndsv),
save :: usefullfn,maybefn
201 integer :: i,j,k,iin,iout
202 logical :: allfoundout, foundout, somefoundin, foundin
203 logical,
optional :: recurse
204 integer,
save :: order,num
205 character(len=10) :: newbin(nmaxb), newbout(nmaxb), tmpbin(nmaxb)
209 if (.not. optio_log(recurse))
then 213 call fnregister(maybefn)
214 call fnregister(usefullfn)
221 newbin(:
size(mybin))=mybin
223 newbout(:
size(mybin))=mybin
227 somefoundin = .false.
228 num=count(maybefn%fnds%c_e())
232 do 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)
250 do i = 1, count(
c_e(tmpbin))
251 newbin(firsttrue(.not.
c_e(newbin)))=tmpbin(i)
260 if (.not. somefoundin)
return 261 if (num == count(maybefn%fnds%c_e()))
return 265 do 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.
275 if (allfoundout)
then 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.)
321 if (.not. optio_log(recurse))
then 330 subroutine makev(mayvfn,mybin,mybout,myin,myout)
331 type(fndsv),
intent(inout) :: mayvfn
332 character(len=*),
intent(in) :: mybin(:),mybout(:)
333 real,
intent(in) :: myin(:,:)
334 real,
intent(out) :: myout(:,:)
337 do 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)
Module for quickly interpreting the OPTIONAL parameters passed to a subprogram.
Vector of function to transform the input to alchimia module.
Do the real work to transform the input data to the output.
Generic subroutine for checking OPTIONAL parameters.
show on the screen the fnds and fndsv structure
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.
Check missing values for fnds.