scilab/modules/differential_equations/sci_gateway/fortran/bjac.f

   1 c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
   2 c Copyright (C) INRIA
   3 c ...
   4 c
   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.1-en.txt
  10 c
  11       subroutine bjac(ny,t,y,ml,mu,jac,nrowj)
  12 c
  13       INCLUDE 'stack.h'
  14       integer iadr,sadr
  15 c
  16       double precision y(ny),jac(nrowj,ny),t(*)
  17 c
  18       logical allowptr
  19       integer vol,tops,nordre
  20       data nordre/2/,mlhs/1/
  21 c
  22       iadr(l)=l+l-1
  23       sadr(l)=(l/2)+1
  24 c
  25       ierror=0
  26       mrhs=2
  27 c
  28       ilp=iadr(lstk(top))
  29       il=istk(ilp+nordre)
  30 c
  31       tops=istk(il)
  32       ils=iadr(lstk(tops))
  33 c
  34       if(istk(ils).eq.10) then
  35 c     Case of a Fortran simulator
  36          call fjac(ny,t,y,ml,mu,jac,nrowj)
  37          return
  38       endif
  39 c     external is a Scilab function
  40
  41 c     On return ierror=1 is used to notify to the ode solver that
  42 c     scilab was not able to evaluate the external
  43       ierror=1
  44
  45 c     Putting Fortran arguments on Scilab stack
  46 c+
  47       call ftob(t,1,istk(il+1))
  48       if(err.gt.0.or.err1.gt.0) return
  49       call ftob(y,ny,istk(il+2))
  50       if(err.gt.0.or.err1.gt.0) return
  51 c+
  52 c
  53
  54 c
  55 c     Retrieving the simulator's address
  56       fin=lstk(tops)
  57 c
  58       if(istk(ils).eq.15) then
  59 c     Case when the simulator is described by a list
  60       nelt=istk(ils+1)
  61       l=sadr(ils+3+nelt)
  62       ils=ils+2
  63 c
  64 c     Retrieving the simulator's address
  65       fin=l
  66 c
  67 c     Managing the additional simulator parameters coming from
  68 c     the context (elements of the list describing the simulator)
  69 c
  70       nelt=nelt-1
  71       if(nelt.eq.0) goto 40
  72       l=l+istk(ils+1)-istk(ils)
  73       vol=istk(ils+nelt+1)-istk(ils+1)
  74       if(top+1+nelt.ge.bot) then
  75          call error(18)
  76          return
  77       endif
  78       err=lstk(top+1)+vol-lstk(bot)
  79       if(err.gt.0) then
  80          call error(17)
  81          return
  82       endif
  83       call unsfdcopy(vol,stk(l),1,stk(lstk(top+1)),1)
  84       do 11 i=1,nelt
  85          top=top+1
  86          lstk(top+1)=lstk(top)+istk(ils+i+1)-istk(ils+i)
  87  11   continue
  88       mrhs=mrhs+nelt
  89       endif
  90  40   continue
  91 c
  92 c     Running the macro defining the simulator
  93 c
  94       pt=pt+1
  95       if(pt.gt.psiz) then
  96          call error(26)
  97          goto 9999
  98       endif
  99       ids(1,pt)=lhs
 100       ids(2,pt)=rhs
 101       rstk(pt)=1001
 102       lhs=mlhs
 103       rhs=mrhs
 104       niv=niv+1
 105       fun=0
 106 c
 107       icall=5
 108
 109       include 'callinter.h.f'
 110 c
 111  200  lhs=ids(1,pt)
 112       rhs=ids(2,pt)
 113       pt=pt-1
 114       niv=niv-1
 115 c+
 116 c     Transferring the output to Fortran
 117       if(ml.gt.0.or.mu.gt.0) then
 118          mm=ml+mu+1
 119          call btofm(jac,nrowj,mm,ny)
 120          else
 121          nnn=ny*ny
 122          call btof(jac,nnn)
 123       endif
 124       if(err.gt.0.or.err1.gt.0) return
 125 c+
 126 c     normal return ierror set to 0
 127       ierror=0
 128       return
 129 c
 130  9999 continue
 131       niv=niv-1
 132       if(err1.gt.0) then
 133          lhs=ids(1,pt)
 134          rhs=ids(2,pt)
 135          pt=pt-1
 136          fun=0
 137       endif
 138       return
 139       end