a7bea469443284f85739a1f9e55e4785af3dd928
[scilab.git] / scilab / modules / differential_equations / sci_gateway / fortran / intg.f
1 c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
2 c Copyright (C) INRIA
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 intg
12 c     --------------------------------------------
13 c     Scilab intg 
14 c      implicit undefined (a-z)
15       character*(4) fname
16       character*6   namef
17       include 'stack.h'
18       integer iero 
19       common/ierajf/iero
20       common/cintg/namef
21       external bintg,fintg
22       double precision epsa,epsr,a,b,val,abserr
23       logical getexternal, getscalar,type ,cremat
24       integer topk,lr,katop,kydot,top2,lra,lrb,lc
25       integer iipal,lpal,lw,liw,lpali,ifail
26       integer iadr,sadr
27       external setfintg
28 c
29       iadr(l)=l+l-1
30       sadr(l)=(l/2)+1
31       fname='intg'
32       if(rhs.lt.3) then
33          call error(39)
34          return
35       endif
36       type=.false.
37       top2=top
38       topk=top
39       if(rhs.eq.5) then
40          if (.not.getscalar(fname,topk,top,lr)) return
41          epsr=stk(lr)
42          top=top-1
43       else
44          epsr=1.0d-8
45       endif
46       if (rhs.ge.4) then 
47          if (.not.getscalar(fname,topk,top,lr)) return
48          epsa=stk(lr)
49          top=top-1
50       else
51          epsa=1.0d-14
52       endif
53 c     cas standard
54       if (.not.getexternal(fname,topk,top,namef,type,
55      $     setfintg)) return
56       kydot=top
57       top=top-1
58       if (.not.getscalar(fname,topk,top,lrb)) return
59       b=stk(lrb)
60       top=top-1
61       katop=top
62       if (.not.getscalar(fname,topk,top,lra)) return
63       a=stk(lra)
64 c     tableaux de travail 
65       top=top2+1
66       lw=3000
67       if (.not.cremat(fname,top,0,1,lw,lpal,lc)) return
68       top=top+1
69 c     tableau de travail entier necessaire 
70       liw=3000/8+2
71       if (.not.cremat(fname,top,0,1,iadr(liw)+1,lpali,lc)) return
72       top=top+1
73 c
74 c     external scilab
75 c
76       iipal=iadr(lstk(top))
77       istk(iipal)=1
78       istk(iipal+1)=iipal+2
79       istk(iipal+2)=kydot
80       istk(iipal+3)=katop
81       lstk(top+1)=sadr(iipal+4)
82       if(type) then 
83          call dqag0(fintg,a,b,epsa,epsr,val,abserr,
84      +        stk(lpal),lw,stk(lpali),liw,ifail)
85       else
86          call dqag0(bintg,a,b,epsa,epsr,val,abserr,
87      +        stk(lpal),lw,stk(lpali),liw,ifail)
88       endif
89       if(err.gt.0.or.err1.gt.0)return
90       if(ifail.gt.0) then
91          call error(24)
92          return
93       endif
94       top=top2-rhs+1
95       stk(lra)=val
96       if(lhs.eq.2) then
97          top=top+1
98          stk(lrb)=abserr
99          return
100       endif
101       return
102       end
103