Generate block GUI
[scilab.git] / scilab / modules / differential_equations / sci_gateway / fortran / sci_f_bvode.f
1 c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
2 c Copyright (C) ENPC - Jean-Philippe Chancelier
3 c ...
4
5 c This file must be used under the terms of the CeCILL.
6 c This source file is licensed as described in the file COPYING, which
7 c you should have received as part of this distribution.  The terms
8 c are also available at    
9 c http://www.cecill.info/licences/Licence_CeCILL_V2-en.txt
10 c
11       subroutine scibvode(fname)
12 c
13 c      implicit undefined (a-z)
14 c     -----------------------------------------------------
15       include 'stack.h'
16       character*(*) fname
17       character tmpbuf * (bsiz)      
18       character*(nlgh+1)   efsub,edfsub,egsub,edgsub,eguess
19       integer    kfsub,kdfsub,kgsub,kdgsub,kguess,topk
20       external   fsub,dfsub,gsub,dgsub,dguess
21       external setfcolgu,setfcoldg,setfcolg,setfcoldf
22       external setfcolf
23       integer    mstar,ncomp,io
24       double precision aleft,aright
25       integer iadr,lr,iflag,mf,nf,lfixpnt,mtol,ntol,ltol,l
26       integer mltol,nltol,lltol,iero,mipar,nipar,lipar,mzeta,nzeta,lzeta
27       integer mm,mn,lrm,i,lispace,lspace,lc,ki,kz,kx,lr1,lc1
28       integer mres,nres,lres
29       integer itfsub,itdfsub,itgsub,itdgsub,itguess,gettype
30       logical type,getexternal,getrmat,cremat,getscalar
31       common/iercol/iero
32 C     External names 
33       common / colname / efsub,edfsub,egsub,edgsub,eguess
34 C     External Position in stack and arguments model position in stack
35       common / coladr / kfsub,kdfsub,kgsub,kdgsub,kguess,kx,ki,kz
36 C     Type of externals 
37       common / coltyp / itfsub,itdfsub,itgsub,itdgsub,itguess
38       common / icolnew/  ncomp,mstar
39 c
40       iadr(l)=l+l-1
41
42 c
43       if (ddt .eq. 4) then
44          write(tmpbuf(1:4),'(i4)') fin
45          call basout(io,wte,' bva '//tmpbuf(1:4))
46       endif
47 c
48 c     fin  1
49 c         bvode
50 c
51 c     z=bvode(res,ncomp,m,aleft,aright,zeta,ipar,ltol,tol,fixpnt,...
52 c       fsub1,dfsub1,gsub1,dgsub1,guess1)
53 c
54 c     Interface for the colnew program for boundary values problem.
55       type=.false.
56       topk=top
57       kguess=top
58 c     guess1 external
59       itguess= gettype(top)
60       if (.not.getexternal(fname,topk,top,eguess,type,
61      $     setfcolgu)) return
62       top=top-1
63 c     dgsub1 external
64       itdgsub=gettype(top)
65       kdgsub=top
66       if (.not.getexternal(fname,topk,top,edgsub,type,
67      $     setfcoldg)) return
68       top=top-1
69 c     gsub1 external
70       itgsub=gettype(top)
71       kgsub=top
72       if (.not.getexternal(fname,topk,top,egsub,type,
73      $     setfcolg)) return
74       top=top-1
75 c     dfsub1 external
76       itdfsub=gettype(top)
77       kdfsub=top
78       if (.not.getexternal(fname,topk,top,edfsub,type,
79      $     setfcoldf)) return
80       top=top-1
81 c     fsub1 external
82       itfsub=gettype(top)
83       kfsub=top
84       if (.not.getexternal(fname,topk,top,efsub,type,
85      $     setfcolf)) return
86 c      write(06,*) 'args',itfsub,itdfsub,itgsub,itdgsub,itguess
87       top=top-1
88 c     fixpnt
89       if (.not.getrmat(fname,topk,top,mf,nf,lfixpnt))  return
90       top=top-1
91 c     tol
92       if (.not.getrmat(fname,topk,top,mtol,ntol,ltol))  return
93       top=top-1
94 c     ltol
95       if (.not.getrmat(fname,topk,top,mltol,nltol,lltol))  return
96       call entier(mltol*nltol,stk(lltol),istk(iadr(lltol)))
97       top=top-1
98 c     ipar  
99       if (.not.getrmat(fname,topk,top,mipar,nipar,lipar))  return
100       if(mipar*nipar.lt.11) then 
101 c     .  bvode: ipar dimensioned at least 11
102          call error(251) 
103       endif
104       ilipar=iadr(lipar)
105       call entier(mipar*nipar,stk(lipar),istk(ilipar))
106 c
107       if(istk(ilipar+3).ne.mltol*nltol) then 
108 C     .  bvode: ltol must be of size ipar(4)
109          call error(252) 
110       endif
111       if(istk(ilipar+10).ne.mf*nf.and.istk(ilipar+10).ne.0) then 
112 c     .  bvode: fixpnt must be of size ipar(11)
113          call error(253) 
114       endif
115       top=top-1
116 c     zeta 
117       if (.not.getrmat(fname,topk,top,mzeta,nzeta,lzeta))  return
118       top=top-1
119 c     aright  
120       if (.not.getscalar(fname,topk,top,lr))  return
121       aright=stk(lr)
122       top=top-1
123 c     aleft
124       if (.not.getscalar(fname,topk,top,lr))  return
125       aleft=stk(lr)
126       top=top-1
127 c     m
128       if (.not. getrmat(fname,topk,top,mm,mn,lrm)) return 
129       call entier(mm*mn,stk(lrm),istk(iadr(lrm)))
130       mstar=0
131       do 10 i=1,mm*mn
132          mstar=mstar+ istk(iadr(lrm)+i-1)
133  10   continue
134       top=top-1
135 c     ncomp
136       if (.not.getscalar(fname,topk,top,lr))  return
137       ncomp=int(stk(lr))
138       if(ncomp.gt.20) then 
139 c     .  bvode: ncomp < 20 requested 
140          call error(254) 
141       endif
142       if(mm*mn.ne.ncomp) then 
143 c     .  bvode: m must be of size ncomp
144          call error(255) 
145       endif
146       if(mstar.gt.40) then 
147 c     .  bvode: sum(m must be less than 40
148          call error(256) 
149       endif
150
151       top=top-1
152 c     res
153       if (.not.getrmat(fname,topk,top,mres,nres,lres))  return
154 c
155 c     create working arrays
156       top=topk+1
157       if (.not.cremat(fname,top,0,1,istk(iadr(lipar)+6-1),lispace,lc)) 
158      $     return
159       top=top+1
160       if (.not.cremat(fname,top,0,1,istk(iadr(lipar)+5-1),lspace,lc)) 
161      $     return
162 C     Modele des arguments des external x scalaire z vecteur 
163       top=top+1
164       ki=top
165       kx=top
166       if (.not.cremat(fname,top,0,1,1,lr,lc)) return
167       top=top+1
168       kz=top
169       if (.not.cremat(fname,top,0,mstar,1,lr,lc)) return
170       iero=0
171       call colnew (ncomp,istk(iadr(lrm)),aleft,aright,stk(lzeta),
172      $     istk(iadr(lipar)),istk(iadr(lltol)), stk(ltol),stk(lfixpnt),
173      $     istk(iadr(lispace)), stk(lspace), iflag, fsub, 
174      $             dfsub, gsub, dgsub, dguess) 
175       if(err.gt.0.or.err1.gt.0) return
176       if(iero.gt.0) then
177          call error(24)
178          Return
179       endif
180       if ( iflag.ne.1) then 
181          goto (101,102,103,104) iflag+4
182  101     call error(258)
183          return 
184  102     call error(24)
185          return
186  103     call error(259)
187          return
188  104     call error(260)
189          return
190       endif
191       top=top+1
192       if (.not.cremat(fname,top,0,mstar,mres*nres,lr,lc)) return
193          do 20 i=1,mres*nres
194             call appsln(stk(lres+i-1),stk(lr+(i-1)*mstar),stk(lspace),
195      $           istk(iadr(lispace)))
196  20      continue
197       top=topk-rhs+1
198       if (.not.cremat(fname,top,0,mstar,mres*nres,lr1,lc1)) return
199       call unsfdcopy(mstar*mres*nres,stk(lr),1,stk(lr1),1)
200       return
201       end
202