From 82850d3d3e134bc4325be7c5491d22f37856ea76 Mon Sep 17 00:00:00 2001 From: Antoine ELIAS Date: Tue, 10 Dec 2013 14:43:18 +0100 Subject: [PATCH] fix import/export of ierode common on Windows Change-Id: Ibebda6a9e8dcada17a4451116d1babe5f5cf7b32 --- .../sci_gateway/fortran/badd.f | 9 +-- .../sci_gateway/fortran/bj2.f | 13 ++- .../sci_gateway/fortran/bjac.f | 11 ++- .../sci_gateway/fortran/bjacd.f | 14 ++-- .../sci_gateway/fortran/bpjacd.f | 11 ++- .../sci_gateway/fortran/bpsold.f | 11 ++- .../sci_gateway/fortran/bresd.f | 11 ++- .../sci_gateway/fortran/bresid.f | 9 +-- .../sci_gateway/fortran/bsurf.f | 11 ++- .../sci_gateway/fortran/bsurfd.f | 14 ++-- .../sci_gateway/fortran/bydot2.f | 11 ++- .../sci_gateway/fortran/sci_f_daskr.f | 3 +- .../sci_gateway/fortran/sci_f_dasrt.f | 3 +- .../sci_gateway/fortran/sci_f_dassl.f | 3 +- .../sci_gateway/fortran/sci_f_impl.f | 3 +- .../differential_equations/src/fortran/ainvg.f | 12 +-- .../differential_equations/src/fortran/ddasrt.f | 83 +++++++++++--------- .../differential_equations/src/fortran/ddassl.f | 23 +++--- .../differential_equations/src/fortran/lsdisc.f | 6 +- .../differential_equations/src/fortran/lsoda.f | 10 +-- .../differential_equations/src/fortran/lsodar.f | 15 ++-- .../differential_equations/src/fortran/lsode.f | 11 +-- .../differential_equations/src/fortran/lsodi.f | 12 +-- .../differential_equations/src/fortran/prepj.f | 15 ++-- .../differential_equations/src/fortran/prepji.f | 28 +++---- .../differential_equations/src/fortran/prja.f | 13 +-- .../differential_equations/src/fortran/rchek.f | 16 ++-- .../differential_equations/src/fortran/rchek2.f | 8 +- .../differential_equations/src/fortran/rkf45.f | 25 +++--- .../differential_equations/src/fortran/rksimp.f | 20 ++--- .../differential_equations/src/fortran/stoda.f | 14 ++-- .../differential_equations/src/fortran/stode.f | 13 +-- .../differential_equations/src/fortran/stodi.f | 8 +- .../differential_equations/src/fortran/xerrwv.f | 4 +- scilab/modules/scicos_blocks/src/fortran/sciblk.f | 7 +- 35 files changed, 238 insertions(+), 242 deletions(-) diff --git a/scilab/modules/differential_equations/sci_gateway/fortran/badd.f b/scilab/modules/differential_equations/sci_gateway/fortran/badd.f index e623c0f..b735b24 100644 --- a/scilab/modules/differential_equations/sci_gateway/fortran/badd.f +++ b/scilab/modules/differential_equations/sci_gateway/fortran/badd.f @@ -18,7 +18,6 @@ c integer iadr,sadr c double precision y(ny),p(nrowp,ny),t(*) - common/ierode/iero logical allowptr c integer vol,tops,nordre @@ -30,16 +29,16 @@ c c nordre=external number c mlhs (mrhs) = number ot output (input) parameters of the c external - iero=0 + ierror=0 mrhs=3 c ilp=iadr(lstk(top)) il=istk(ilp+nordre) c external is a Scilab function -c on return iero=1 is used to notify to the ode solver that +c on return ierror=1 is used to notify to the ode solver that c scilab was not able to evaluate the external - iero=1 + ierror=1 c c transfer of input parameters @@ -138,7 +137,7 @@ c transfer of output parameters of external to fortran if(err.gt.0.or.err1.gt.0) return c+ c normal return - iero=0 + ierror=0 return c 9999 continue diff --git a/scilab/modules/differential_equations/sci_gateway/fortran/bj2.f b/scilab/modules/differential_equations/sci_gateway/fortran/bj2.f index 84867dc..0bcc8d2 100644 --- a/scilab/modules/differential_equations/sci_gateway/fortran/bj2.f +++ b/scilab/modules/differential_equations/sci_gateway/fortran/bj2.f @@ -18,8 +18,7 @@ c integer iadr,sadr c double precision y(n),s(n),jac(nrowj,n),t(*) - common/ierode/iero -c + logical allowptr integer vol,tops,nordre data nordre/3/,mlhs/1/ @@ -32,16 +31,16 @@ c de donnee, c mlhs (mrhs) est le nombre de parametres de sortie (entree) c du simulateur c - iero=0 + ierror=0 mrhs=3 c ilp=iadr(lstk(top)) il=istk(ilp+nordre) c external is a Scilab function -c on return iero=1 is used to notify to the ode solver that +c on return ierror=1 is used to notify to the ode solver that c scilab was not able to evaluate the external - iero=1 + ierror=1 c Putting Fortran arguments on Scilab stack c+ @@ -121,8 +120,8 @@ c+ c transfert des variables de sortie vers fortran call btof(jac,n*n) if(err.gt.0.or.err1.gt.0) return -c normal return iero set to 0 - iero=0 +c normal return ierror set to 0 + ierror=0 return c+ diff --git a/scilab/modules/differential_equations/sci_gateway/fortran/bjac.f b/scilab/modules/differential_equations/sci_gateway/fortran/bjac.f index db00e10..088d56f 100644 --- a/scilab/modules/differential_equations/sci_gateway/fortran/bjac.f +++ b/scilab/modules/differential_equations/sci_gateway/fortran/bjac.f @@ -14,7 +14,6 @@ c integer iadr,sadr c double precision y(ny),jac(nrowj,ny),t(*) - common/ierode/iero c logical allowptr integer vol,tops,nordre @@ -23,7 +22,7 @@ c iadr(l)=l+l-1 sadr(l)=(l/2)+1 c - iero=0 + ierror=0 mrhs=2 c ilp=iadr(lstk(top)) @@ -39,9 +38,9 @@ c Case of a Fortran simulator endif c external is a Scilab function -c On return iero=1 is used to notify to the ode solver that +c On return ierror=1 is used to notify to the ode solver that c scilab was not able to evaluate the external - iero=1 + ierror=1 c Putting Fortran arguments on Scilab stack c+ @@ -124,8 +123,8 @@ c Transferring the output to Fortran endif if(err.gt.0.or.err1.gt.0) return c+ -c normal return iero set to 0 - iero=0 +c normal return ierror set to 0 + ierror=0 return c 9999 continue diff --git a/scilab/modules/differential_equations/sci_gateway/fortran/bjacd.f b/scilab/modules/differential_equations/sci_gateway/fortran/bjacd.f index 17ca611..25434e6 100644 --- a/scilab/modules/differential_equations/sci_gateway/fortran/bjacd.f +++ b/scilab/modules/differential_equations/sci_gateway/fortran/bjacd.f @@ -17,9 +17,7 @@ c ====================================================================== c INCLUDE 'stack.h' integer iadr,sadr -c - common/ierode/iero -c + character tmpbuf * (bsiz) logical allowptr double precision t, y(*),ydot(*),res(*),rpar(*),cj @@ -40,7 +38,7 @@ c data structure, c mlhs (mrhs) is the number of output (input) parameters c of the simulator c - iero=0 + ierror=0 mrhs=4 c ilp=iadr(lstk(top)) @@ -56,9 +54,9 @@ c Case of a Fortran simulator endif c external is a Scilab function -c On return iero=1 is used to notify to the ode solver that +c On return ierror=1 is used to notify to the ode solver that c scilab was not able to evaluate the external - iero=1 + ierror=1 c Putting Fortran arguments on Scilab stack c+ @@ -146,8 +144,8 @@ c+ c Transferring the output to Fortran call btof(res,neq*neq) if(err.gt.0.or.err1.gt.0) return -c normal return iero set to 0 - iero=0 +c normal return ierror set to 0 + ierror=0 return c 9999 continue diff --git a/scilab/modules/differential_equations/sci_gateway/fortran/bpjacd.f b/scilab/modules/differential_equations/sci_gateway/fortran/bpjacd.f index dc04994..4136b8f 100644 --- a/scilab/modules/differential_equations/sci_gateway/fortran/bpjacd.f +++ b/scilab/modules/differential_equations/sci_gateway/fortran/bpjacd.f @@ -17,7 +17,6 @@ c INCLUDE 'stack.h' integer iadr,sadr c - common/ierode/iero logical allowptr c character tmpbuf * (bsiz) @@ -42,7 +41,7 @@ c mlhs (mrhs) is the number of output (input) parameters c of the simulator c mrhs=8 - iero=0 + ierror=0 c ilp=iadr(lstk(top)) il=istk(ilp+nordre) @@ -58,9 +57,9 @@ c Fortran simulator case endif c external is a Scilab function -c On return iero=1 is used to notify to the ode solver that +c On return ierror=1 is used to notify to the ode solver that c scilab was not able to evaluate the external - iero=1 + ierror=1 c Putting Fortran arguments on Scilab stack c @@ -174,8 +173,8 @@ c Test if the variable on the stack has same type and size as the theoretica if(err.gt.0.or.err1.gt.0) return c+ -c Normal return iero set to 0 - iero=0 +c Normal return ierror set to 0 + ierror=0 return c 9999 continue diff --git a/scilab/modules/differential_equations/sci_gateway/fortran/bpsold.f b/scilab/modules/differential_equations/sci_gateway/fortran/bpsold.f index 0b708b8..8193b7b 100644 --- a/scilab/modules/differential_equations/sci_gateway/fortran/bpsold.f +++ b/scilab/modules/differential_equations/sci_gateway/fortran/bpsold.f @@ -17,7 +17,6 @@ c INCLUDE 'stack.h' integer iadr,sadr c - common/ierode/iero logical allowptr c character tmpbuf * (bsiz) @@ -40,7 +39,7 @@ c mlhs (mrhs) is the number of output (input) parameters c of the simulator c mrhs=3 - iero=0 + ierror=0 c ilp=iadr(lstk(top)) il=istk(ilp+nordre) @@ -56,9 +55,9 @@ c Fortran simulator case endif c external is a Scilab function -c On return iero=1 is used to notify to the ode solver that +c On return ierror=1 is used to notify to the ode solver that c scilab was not able to evaluate the external - iero=1 + ierror=1 c Putting Fortran arguments on Scilab stack c @@ -164,8 +163,8 @@ c Transferring the output to Fortran call btof(b,neq) if(err.gt.0.or.err1.gt.0) return c+ -c Normal return iero set to 0 - iero=0 +c Normal return ierror set to 0 + ierror=0 return c 9999 continue diff --git a/scilab/modules/differential_equations/sci_gateway/fortran/bresd.f b/scilab/modules/differential_equations/sci_gateway/fortran/bresd.f index 3f81297..7a77946 100644 --- a/scilab/modules/differential_equations/sci_gateway/fortran/bresd.f +++ b/scilab/modules/differential_equations/sci_gateway/fortran/bresd.f @@ -18,7 +18,6 @@ c INCLUDE 'stack.h' integer iadr,sadr c - common/ierode/iero logical allowptr c character tmpbuf * (bsiz) @@ -41,7 +40,7 @@ c mlhs (mrhs) is the number of output (input) parameters c of the simulator c mrhs=3 - iero=0 + ierror=0 c ilp=iadr(lstk(top)) il=istk(ilp+nordre) @@ -56,9 +55,9 @@ c Case of a Fortran simulator endif c external is a Scilab function -c On return iero=1 is used to notify to the ode solver that +c On return ierror=1 is used to notify to the ode solver that c scilab was not able to evaluate the external - iero=1 + ierror=1 c Putting Fortran arguments on Scilab stack c @@ -145,8 +144,8 @@ c Transferring the output to Fortran call btof(res,neq) if(err.gt.0.or.err1.gt.0) return c+ -c normal return iero set to 0 - iero=0 +c normal return ierror set to 0 + ierror=0 return c 9999 continue diff --git a/scilab/modules/differential_equations/sci_gateway/fortran/bresid.f b/scilab/modules/differential_equations/sci_gateway/fortran/bresid.f index d608a2d..3bd920f 100644 --- a/scilab/modules/differential_equations/sci_gateway/fortran/bresid.f +++ b/scilab/modules/differential_equations/sci_gateway/fortran/bresid.f @@ -19,7 +19,6 @@ c c logical allowptr double precision t(*), y(n),res(n),s(n) - common/ierode/iero c integer vol,tops,nordre data nordre/1/,mlhs/1/ @@ -32,16 +31,16 @@ c nordre=external number c mlhs (mrhs) = number ot output (input) parameters of the c external c - iero=0 + ierror=0 mrhs=3 c ilp=iadr(lstk(top)) il=istk(ilp+nordre) c c external is a Scilab function -c on return iero=1 is used to notify to the ode solver that +c on return ierror=1 is used to notify to the ode solver that c scilab was not able to evaluate the external - iero=1 + ierror=1 c c transfer of input parameters call ftob(t,1,istk(il+1)) @@ -118,7 +117,7 @@ c transfert des variables de sortie vers fortran if(err.gt.0.or.err1.gt.0) return c+ c normal return - iero=0 + ierror=0 return c 9999 continue diff --git a/scilab/modules/differential_equations/sci_gateway/fortran/bsurf.f b/scilab/modules/differential_equations/sci_gateway/fortran/bsurf.f index bf4e319..76e0993 100644 --- a/scilab/modules/differential_equations/sci_gateway/fortran/bsurf.f +++ b/scilab/modules/differential_equations/sci_gateway/fortran/bsurf.f @@ -20,7 +20,6 @@ c c logical allowptr double precision y(ny),gout(ng),t(*) - common/ierode/iero c character tmpbuf * (bsiz) integer vol,tops,nordre @@ -39,7 +38,7 @@ c call basout(io,wte,' bsurf top:'//tmpbuf(1:4)) endif c - iero=0 + ierror=0 mrhs=2 c ilp=iadr(lstk(top)) @@ -55,9 +54,9 @@ c cas d'un simulateur en fortran endif c external is a Scilab function -c on return iero=1 is used to notify to the ode solver that +c on return ierror=1 is used to notify to the ode solver that c scilab was not able to evaluate the external - iero=1 + ierror=1 c Putting Fortran arguments on Scilab stack c+ @@ -134,8 +133,8 @@ c transfert des variables de sortie vers fortran call btof(gout,ng) if(err.gt.0.or.err1.gt.0) return c+ -c normal return iero set to 0 - iero=0 +c normal return ierror set to 0 + ierror=0 return c 9999 continue diff --git a/scilab/modules/differential_equations/sci_gateway/fortran/bsurfd.f b/scilab/modules/differential_equations/sci_gateway/fortran/bsurfd.f index 62534c9..321e681 100644 --- a/scilab/modules/differential_equations/sci_gateway/fortran/bsurfd.f +++ b/scilab/modules/differential_equations/sci_gateway/fortran/bsurfd.f @@ -16,9 +16,7 @@ c ==================================== c INCLUDE 'stack.h' integer iadr,sadr -c - common/ierode/iero -c + character tmpbuf * (bsiz) logical allowptr double precision y(ny),gout(ng),t(*) @@ -40,7 +38,7 @@ c data structure, c mlhs (mrhs) is the number of output (input) parameters c of the simulator c - iero=0 + ierror=0 mrhs=2 c ilp=iadr(lstk(top)) @@ -57,9 +55,9 @@ c Case of a Fortran simulator c c external is a Scilab function -c On return iero=1 is used to notify to the ode solver that +c On return ierror=1 is used to notify to the ode solver that c scilab was not able to evaluate the external - iero=1 + ierror=1 c Putting Fortran arguments on Scilab stack c+ @@ -135,8 +133,8 @@ c transfert des variables de sortie vers Fortran call btof(gout,ng) if(err.gt.0.or.err1.gt.0) return c+ -c normal return iero set to 0 - iero=0 +c normal return ierror set to 0 + ierror=0 return c 9999 continue diff --git a/scilab/modules/differential_equations/sci_gateway/fortran/bydot2.f b/scilab/modules/differential_equations/sci_gateway/fortran/bydot2.f index 7af5659..a9c77a4e 100644 --- a/scilab/modules/differential_equations/sci_gateway/fortran/bydot2.f +++ b/scilab/modules/differential_equations/sci_gateway/fortran/bydot2.f @@ -13,7 +13,6 @@ c INCLUDE 'stack.h' integer iadr,sadr c - common/ierode/iero common/odecd/nd,iflag c logical allowptr @@ -29,7 +28,7 @@ c nordre=external number c mlhs (mrhs) = number ot output (input) parameters of the c external c - iero=0 + ierror=0 mrhs=4 c ilp=iadr(lstk(top)) @@ -47,9 +46,9 @@ c fortran external c c external is a Scilab function -c on return iero=1 is used to notify to the ode solver that +c on return ierror=1 is used to notify to the ode solver that c scilab was not able to evaluate the external - iero=1 + ierror=1 c transfer of input parameters c+ @@ -159,8 +158,8 @@ c transfer of output parameters of external to fortran endif if(err.gt.0.or.err1.gt.0) return c+ -c normal return iero set to 0 - iero=0 +c normal return ierror set to 0 + ierror=0 return c 9999 continue diff --git a/scilab/modules/differential_equations/sci_gateway/fortran/sci_f_daskr.f b/scilab/modules/differential_equations/sci_gateway/fortran/sci_f_daskr.f index 15ddc1b..38905fbe 100644 --- a/scilab/modules/differential_equations/sci_gateway/fortran/sci_f_daskr.f +++ b/scilab/modules/differential_equations/sci_gateway/fortran/sci_f_daskr.f @@ -34,7 +34,6 @@ c common /dassln/ namer,namej,names,namep,namepj external bresd,bjacd,bsurfd,bpsold,bpjacd external setfresd,setfjacd,setfsurfd,setfpsold,setfpjacd - common/ierode/iero c data atol/1.d-7/,rtol/1.d-9/ c @@ -45,7 +44,7 @@ c SCILAB function : daskr c -------------------------- c [y0,nvs[,hotdata]]=daskr(y0,t0,t1[,atol[,rtol]],res[,jac],nh,h[,info c [,psol][,pjac]][,hotdata]) - iero=0 + ierror=0 maxord=5 lbuf = 1 topk=top diff --git a/scilab/modules/differential_equations/sci_gateway/fortran/sci_f_dasrt.f b/scilab/modules/differential_equations/sci_gateway/fortran/sci_f_dasrt.f index ba61531..5e76a9e 100644 --- a/scilab/modules/differential_equations/sci_gateway/fortran/sci_f_dasrt.f +++ b/scilab/modules/differential_equations/sci_gateway/fortran/sci_f_dasrt.f @@ -29,7 +29,6 @@ c common /dassln/ namer,namej,names external bresd,bjacd,bsurfd external setfresd,setfjacd,setfsurfd - common/ierode/iero c data atol/1.d-7/,rtol/1.d-9/ c @@ -40,7 +39,7 @@ c SCILAB function : dasrt c -------------------------- c [y0,nvs,[,hotdata]]=dasrt(y0,t0,t1[,atol,rtol],res[,jac],nh,h,info c [,hotdata]) - iero=0 + ierror=0 maxord=5 lbuf = 1 topk=top diff --git a/scilab/modules/differential_equations/sci_gateway/fortran/sci_f_dassl.f b/scilab/modules/differential_equations/sci_gateway/fortran/sci_f_dassl.f index 00a293b..59eba07 100644 --- a/scilab/modules/differential_equations/sci_gateway/fortran/sci_f_dassl.f +++ b/scilab/modules/differential_equations/sci_gateway/fortran/sci_f_dassl.f @@ -25,7 +25,6 @@ c external setfresd,setfjacd common /dassln/ namer,namej,names - common/ierode/iero common/cjac/namjac c data atol/1.d-7/,rtol/1.d-9/ @@ -37,7 +36,7 @@ c SCILAB function : dassl c -------------------------- c [y0 [,hotdata]]=dassl(y0,t0,t1 [,atol,rtol],res [,jac],info.. c [,hotdata]) - iero=0 + ierror=0 maxord=5 lbuf = 1 topk=top diff --git a/scilab/modules/differential_equations/sci_gateway/fortran/sci_f_impl.f b/scilab/modules/differential_equations/sci_gateway/fortran/sci_f_impl.f index 699c048..7f9eb4b 100644 --- a/scilab/modules/differential_equations/sci_gateway/fortran/sci_f_impl.f +++ b/scilab/modules/differential_equations/sci_gateway/fortran/sci_f_impl.f @@ -29,7 +29,6 @@ c character*1 strf common/cjac/namjac external setfres,setfadda,setfj2 - common/ierode/iero c data atol/1.d-7/,rtol/1.d-9/ c @@ -39,7 +38,7 @@ c C XXXXXX : pour l'instant if (.not.checklhs(fname,1,3)) return c --------------------------------- - iero=0 + ierror=0 topk=top topw=top+1 iskip=1 diff --git a/scilab/modules/differential_equations/src/fortran/ainvg.f b/scilab/modules/differential_equations/src/fortran/ainvg.f index 9811673..0baea1e 100644 --- a/scilab/modules/differential_equations/src/fortran/ainvg.f +++ b/scilab/modules/differential_equations/src/fortran/ainvg.f @@ -2,13 +2,13 @@ C/MEMBR ADD NAME=AINVG,SSI=0 subroutine ainvg (res, adda, neq, t, y, ydot, miter, 1 ml, mu, pw, ipvt, ier ) clll. optimize + + include 'stack.h' external res, adda integer neq, miter, ml, mu, ipvt, ier integer i, lenpw, mlp1, nrowpw double precision t, y, ydot, pw dimension y(*), ydot(*), pw(*), ipvt(*) - integer iero - common /ierode/ iero c----------------------------------------------------------------------- c%purpose c this subroutine computes the initial value @@ -33,11 +33,11 @@ c c ier = 1 call res ( neq, t, y, pw, ydot, ier ) - if(iero.gt.0) return + if(ierror.gt.0) return if (ier .gt. 1) return c call adda ( neq, t, y, 0, 0, pw, neq ) - if(iero.gt.0) return + if(ierror.gt.0) return call dgefa ( pw, neq, neq, ipvt, ier ) if (ier .eq. 0) go to 20 ier = -ier @@ -55,12 +55,12 @@ c c ier = 1 call res ( neq, t, y, pw, ydot, ier ) - if(iero.gt.0) return + if(ierror.gt.0) return if (ier .gt. 1) return c mlp1 = ml + 1 call adda ( neq, t, y, ml, mu, pw(mlp1), nrowpw ) - if(iero.gt.0) return + if(ierror.gt.0) return call dgbfa ( pw, nrowpw, neq, ml, mu, ipvt, ier ) if (ier .eq. 0) go to 120 ier = -ier diff --git a/scilab/modules/differential_equations/src/fortran/ddasrt.f b/scilab/modules/differential_equations/src/fortran/ddasrt.f index cbf8cc8..88ef75a 100644 --- a/scilab/modules/differential_equations/src/fortran/ddasrt.f +++ b/scilab/modules/differential_equations/src/fortran/ddasrt.f @@ -859,7 +859,12 @@ C***END PROLOGUE DDASRT C C**End C + + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + + include 'stack.h' + LOGICAL DONE EXTERNAL RES, JAC, G DIMENSION Y(*),YPRIME(*) @@ -884,7 +889,6 @@ C SET POINTERS INTO RWORK * LALPHA=11, LBETA=17, LGAMMA=23, * LPSI=29, LSIGMA=35, LT0=41, LTLAST=42, LALPHR=43, LX2=44, * LDELTA=51) - common/ierode/iero C C***FIRST EXECUTABLE STATEMENT DDASRT @@ -1029,7 +1033,7 @@ C C C SET ERROR WEIGHT VECTOR WT CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) -c if(iero.gt.0) return +c if(ierror.gt.0) return DO 305 I = 1,NEQ IF(RWORK(LWT+I-1).LE.0.0D0) GO TO 713 305 CONTINUE @@ -1075,7 +1079,7 @@ C COMPUTE INITIAL DERIVATIVE, UPDATING TN AND Y, IF APPLICABLE * RWORK(LPHI),RWORK(LDELTA),RWORK(LE), * RWORK(LWM),IWORK(LIWM),HMIN,RWORK(LROUND), * INFO(10),NTEMP) - if(iero.gt.0) return + if(ierror.gt.0) return IF (IDID .LT. 0) GO TO 390 C C LOAD H WITH H0. STORE H IN RWORK(LH) @@ -1101,7 +1105,7 @@ C * RWORK(LPSI),IWORK(LKOLD),RWORK(LG0),RWORK(LG1), * RWORK(LGX),JROOT,IRT,RWORK(LROUND),INFO(3), * RWORK,IWORK,RPAR,IPAR) - if(iero.gt.0) return + if(ierror.gt.0) return IF(IRT .NE. 0) GO TO 732 C C Check for a root in the interval (T0,TN], unless DDASRT @@ -1112,7 +1116,7 @@ C * RWORK(LPSI),IWORK(LKOLD),RWORK(LG0),RWORK(LG1), * RWORK(LGX),JROOT,IRT,RWORK(LROUND),INFO(3), * RWORK,IWORK,RPAR,IPAR) - if (iero.gt.0) return + if (ierror.gt.0) return IF(IRT .NE. 1) GO TO 390 IWORK(LIRFND) = 1 IDID = 4 @@ -1143,7 +1147,7 @@ C * RWORK(LPSI),IWORK(LKOLD),RWORK(LG0),RWORK(LG1), * RWORK(LGX),JROOT,IRT,RWORK(LROUND),INFO(3), * RWORK,IWORK,RPAR,IPAR) - if(iero.gt.0) return + if(ierror.gt.0) return IF(IRT .NE. 1) GO TO 405 IWORK(LIRFND) = 1 IDID = 4 @@ -1165,7 +1169,7 @@ C IF((TN-TOUT)*H.LT.0.0D0)GO TO 490 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) - if(iero.gt.0) return + if(ierror.gt.0) return T=TOUT IDID = 3 DONE = .TRUE. @@ -1174,7 +1178,7 @@ C IF((TN - TOUT)*H .GT. 0.0D0) GO TO 425 CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) - if(iero.gt.0) return + if(ierror.gt.0) return T = TN IDID = 1 DONE = .TRUE. @@ -1182,7 +1186,7 @@ C 425 CONTINUE CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) - if(iero.gt.0) return + if(ierror.gt.0) return T = TOUT IDID = 3 DONE = .TRUE. @@ -1194,7 +1198,7 @@ C IF((TN-TOUT)*H.LT.0.0D0)GO TO 450 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) - if(iero.gt.0) return + if(ierror.gt.0) return T=TOUT IDID = 3 DONE = .TRUE. @@ -1206,7 +1210,7 @@ C IF((TN - TOUT)*H .GT. 0.0D0) GO TO 445 CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) - if(iero.gt.0) return + if(ierror.gt.0) return T = TN IDID = 1 DONE = .TRUE. @@ -1214,7 +1218,7 @@ C 445 CONTINUE CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) - if(iero.gt.0) return + if(ierror.gt.0) return T = TOUT IDID = 3 DONE = .TRUE. @@ -1225,7 +1229,7 @@ C CHECK WHETHER WE ARE WITH IN ROUNDOFF OF TSTOP * (DABS(TN)+DABS(H)))GO TO 460 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) - if(iero.gt.0) return + if(ierror.gt.0) return IDID=2 T=TSTOP DONE = .TRUE. @@ -1260,7 +1264,7 @@ C C UPDATE WT 510 CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI), * RWORK(LWT),RPAR,IPAR) - if(iero.gt.0) return + if(ierror.gt.0) return DO 520 I=1,NEQ IF(RWORK(I+LWT-1).GT.0.0D0)GO TO 520 IDID=-3 @@ -1303,7 +1307,7 @@ C * RWORK(LS),HMIN,RWORK(LROUND), * IWORK(LPHASE),IWORK(LJCALC),IWORK(LK), * IWORK(LKOLD),IWORK(LNS),INFO(10),NTEMP) - if(iero.gt.0) return + if(ierror.gt.0) return 527 IF(IDID.LT.0)GO TO 600 C C-------------------------------------------------------- @@ -1319,7 +1323,7 @@ C * RWORK(LPSI),IWORK(LKOLD),RWORK(LG0),RWORK(LG1), * RWORK(LGX),JROOT,IRT,RWORK(LROUND),INFO(3), * RWORK,IWORK,RPAR,IPAR) - if(iero.gt.0) return + if(ierror.gt.0) return IF(IRT .NE. 1) GO TO 529 IWORK(LIRFND) = 1 IDID = 4 @@ -1334,7 +1338,7 @@ C IF((TN-TOUT)*H.LT.0.0D0)GO TO 500 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - if(iero.gt.0) return + if(ierror.gt.0) return IDID=3 T=TOUT GO TO 580 @@ -1344,7 +1348,7 @@ C GO TO 580 535 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - if(iero.gt.0) return + if(ierror.gt.0) return IDID=3 T=TOUT GO TO 580 @@ -1352,7 +1356,7 @@ C IF((TN-TOUT)*H.LT.0.0D0)GO TO 542 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - if(iero.gt.0) return + if(ierror.gt.0) return T=TOUT IDID=3 GO TO 580 @@ -1364,7 +1368,7 @@ C GO TO 500 545 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - if(iero.gt.0) return + if(ierror.gt.0) return IDID=2 T=TSTOP GO TO 580 @@ -1375,13 +1379,13 @@ C GO TO 580 552 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - if(iero.gt.0) return + if(ierror.gt.0) return IDID=2 T=TSTOP GO TO 580 555 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - if(iero.gt.0) return + if(ierror.gt.0) return T=TOUT IDID=3 580 CONTINUE @@ -1582,7 +1586,11 @@ C***DATE WRITTEN 821001 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C***END PROLOGUE DRCHEK C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + + include 'stack.h' + PARAMETER (LNGE=16, LIRFND=18, LLAST=19, LIMAX=20, * LT0=41, LTLAST=42, LALPHR=43, LX2=44) EXTERNAL G @@ -1634,7 +1642,6 @@ C STORED IN THE GLOBAL ARRAY IWORK. C INFO3 = COPY OF INFO(3) (INPUT ONLY). C----------------------------------------------------------------------- C - common/ierode/iero H = PSI(1) IRT = 0 DO 10 I = 1,NG @@ -1647,9 +1654,9 @@ C EVALUATE G AT INITIAL T (STORED IN RWORK(LT0)), AND CHECK FOR C ZERO VALUES.---------------------------------------------------------- 100 CONTINUE CALL DDATRP(TN,RWORK(LT0),Y,YP,NEQ,KOLD,PHI,PSI) - if(iero.gt.0) return + if(ierror.gt.0) return CALL G (NEQ, RWORK(LT0), Y, NG, G0, RPAR, IPAR) - if(iero.gt.0) return + if(ierror.gt.0) return IWORK(LNGE) = 1 ZROOT = .FALSE. DO 110 I = 1,NG @@ -1662,7 +1669,7 @@ C G HAS A ZERO AT T. LOOK AT G AT T + (SMALL INCREMENT). -------------- DO 120 I = 1,NEQ 120 Y(I) = Y(I) + TEMP2*PHI(I,2) CALL G (NEQ, RWORK(LT0), Y, NG, G0, RPAR, IPAR) - if(iero.gt.0) return + if(ierror.gt.0) return IWORK(LNGE) = IWORK(LNGE) + 1 ZROOT = .FALSE. DO 130 I = 1,NG @@ -1680,9 +1687,9 @@ C IF (IWORK(LIRFND) .EQ. 0) GO TO 260 C IF A ROOT WAS FOUND ON THE PREVIOUS STEP, EVALUATE G0 = G(T0). ------- CALL DDATRP (TN, RWORK(LT0), Y, YP, NEQ, KOLD, PHI, PSI) - if(iero.gt.0) return + if(ierror.gt.0) return CALL G (NEQ, RWORK(LT0), Y, NG, G0, RPAR, IPAR) - if(iero.gt.0) return + if(ierror.gt.0) return IWORK(LNGE) = IWORK(LNGE) + 1 ZROOT = .FALSE. DO 210 I = 1,NG @@ -1697,9 +1704,9 @@ C G HAS A ZERO AT T0. LOOK AT G AT T + (SMALL INCREMENT). ------------- 220 Y(I) = Y(I) + TEMP2*PHI(I,2) GO TO 240 230 CALL DDATRP (TN, RWORK(LT0), Y, YP, NEQ, KOLD, PHI, PSI) - if(iero.gt.0) return + if(ierror.gt.0) return 240 CALL G (NEQ, RWORK(LT0), Y, NG, G0, RPAR, IPAR) - if(iero.gt.0) return + if(ierror.gt.0) return IWORK(LNGE) = IWORK(LNGE) + 1 ZROOT = .FALSE. DO 250 I = 1,NG @@ -1722,13 +1729,13 @@ C SET T1 TO TN OR TOUT, WHICHEVER COMES FIRST, AND GET G AT T1. -------- T1 = TOUT IF ((T1 - RWORK(LT0))*H .LE. 0.0D0) GO TO 390 CALL DDATRP (TN, T1, Y, YP, NEQ, KOLD, PHI, PSI) - if(iero.gt.0) return + if(ierror.gt.0) return GO TO 330 310 T1 = TN DO 320 I = 1,NEQ 320 Y(I) = PHI(I,1) 330 CALL G (NEQ, T1, Y, NG, G1, RPAR, IPAR) - if(iero.gt.0) return + if(ierror.gt.0) return IWORK(LNGE) = IWORK(LNGE) + 1 C CALL DROOTS TO SEARCH FOR ROOT IN INTERVAL FROM T0 TO T1. ------------ JFLAG = 0 @@ -1736,12 +1743,12 @@ C CALL DROOTS TO SEARCH FOR ROOT IN INTERVAL FROM T0 TO T1. ------------ CALL DROOTS (NG, HMING, JFLAG, RWORK(LT0), T1, G0, G1, GX, X, * JROOT, IWORK(LIMAX), IWORK(LLAST), RWORK(LALPHR), * RWORK(LX2)) - if(iero.gt.0) return + if(ierror.gt.0) return IF (JFLAG .GT. 1) GO TO 360 CALL DDATRP (TN, X, Y, YP, NEQ, KOLD, PHI, PSI) - if(iero.gt.0) return + if(ierror.gt.0) return CALL G (NEQ, X, Y, NG, GX, RPAR, IPAR) - if(iero.gt.0) return + if(ierror.gt.0) return IWORK(LNGE) = IWORK(LNGE) + 1 GO TO 350 360 RWORK(LT0) = X @@ -1749,7 +1756,7 @@ C CALL DROOTS TO SEARCH FOR ROOT IN INTERVAL FROM T0 TO T1. ------------ IF (JFLAG .EQ. 4) GO TO 390 C FOUND A ROOT. INTERPOLATE TO X AND RETURN. -------------------------- CALL DDATRP (TN, X, Y, YP, NEQ, KOLD, PHI, PSI) - if(iero.gt.0) return + if(ierror.gt.0) return IRT = 1 RETURN C @@ -1769,6 +1776,9 @@ C***REVISION DATE 900926 (YYMMDD) C***END PROLOGUE DROOTS C IMPLICIT DOUBLE PRECISION(A-H,O-Z) + + include 'stack.h' + INTEGER NG, JFLAG, JROOT, IMAX, LAST DOUBLE PRECISION HMIN, X0, X1, G0, G1, GX, X, ALPHA, X2 DIMENSION G0(NG), G1(NG), GX(NG), JROOT(NG) @@ -1853,7 +1863,6 @@ C----------------------------------------------------------------------- INTEGER I, IMXOLD, NXLAST DOUBLE PRECISION T2, TMAX, ZERO LOGICAL ZROOT, SGNCHG, XROOT - common/ierode/iero DATA ZERO/0.0D0/ C IF (JFLAG .EQ. 1) GO TO 200 diff --git a/scilab/modules/differential_equations/src/fortran/ddassl.f b/scilab/modules/differential_equations/src/fortran/ddassl.f index c0c58fa..a55b268 100644 --- a/scilab/modules/differential_equations/src/fortran/ddassl.f +++ b/scilab/modules/differential_equations/src/fortran/ddassl.f @@ -1,7 +1,7 @@ SUBROUTINE DDAINI (X, Y, YPRIME, NEQ, RES, JAC, H, WT, IDID, RPAR, + IPAR, PHI, DELTA, E, WM, IWM, HMIN, UROUND, NONNEG, NTEMP) - common/ierode/iero + include 'stack.h' C***BEGIN PROLOGUE DDAINI C***SUBSIDIARY C***PURPOSE Initialization routine for DDASSL. @@ -66,7 +66,7 @@ C INTEGER I, IER, IRES, JCALC, LNJE, LNRE, M, MAXIT, MJAC, NCF, * NEF, NSF DOUBLE PRECISION - * CJ, DAMP, DELNRM, ERR, OLDNRM, R, RATE, S, XOLD, YNORM + * CJ, DAMP, DELNRM, IERR, OLDNRM, R, RATE, S, XOLD, YNORM LOGICAL CONVGD C PARAMETER (LNRE=12) @@ -212,9 +212,9 @@ C----------------------------------------------------- C DO 510 I=1,NEQ 510 E(I)=Y(I)-PHI(I,1) - ERR=DDANRM(NEQ,E,WT,RPAR,IPAR) + IERR=DDANRM(NEQ,E,WT,RPAR,IPAR) C - IF (ERR.LE.1.0D0) RETURN + IF (IERR.LE.1.0D0) RETURN C C C @@ -249,7 +249,7 @@ C RETURN C 640 NEF=NEF+1 - R=0.90D0/(2.0D0*ERR+0.0001D0) + R=0.90D0/(2.0D0*IERR+0.0001D0) R=MAX(0.1D0,MIN(0.5D0,R)) H=H*R IF (ABS(H).GE.HMIN.AND.NEF.LT.10) GO TO 690 @@ -262,7 +262,7 @@ C-------------END OF SUBROUTINE DDAINI---------------------- SUBROUTINE DDAJAC (NEQ, X, Y, YPRIME, DELTA, CJ, H, + IER, WT, E, WM, IWM, RES, IRES, UROUND, JAC, RPAR, + IPAR, NTEMP) - common/ierode/iero + include 'stack.h' C***BEGIN PROLOGUE DDAJAC C***SUBSIDIARY @@ -549,7 +549,7 @@ C------END OF SUBROUTINE DDASLV------ END SUBROUTINE DDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, + IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) - common/ierode/iero + include 'stack.h' C***BEGIN PROLOGUE DDASSL C***PURPOSE This code solves a system of differential/algebraic C equations of the form G(T,Y,YPRIME) = 0. @@ -2159,7 +2159,8 @@ C-----------END OF SUBROUTINE DDASSL------------------------------------ + IDID, RPAR, IPAR, PHI, DELTA, E, WM, IWM, ALPHA, BETA, GAMMA, + PSI, SIGMA, CJ, CJOLD, HOLD, S, HMIN, UROUND, IPHASE, JCALC, + K, KOLD, NS, NONNEG, NTEMP) - common/ierode/iero + + include 'stack.h' C***BEGIN PROLOGUE DDASTP C***SUBSIDIARY @@ -2265,7 +2266,7 @@ C * LETF, LMXORD, LNJE, LNRE, LNST, M, MAXIT, NCF, NEF, NSF, NSP1 DOUBLE PRECISION * ALPHA0, ALPHAS, CJLAST, CK, DELNRM, ENORM, ERK, ERKM1, - * ERKM2, ERKP1, ERR, EST, HNEW, OLDNRM, PNORM, R, RATE, TEMP1, + * ERKM2, ERKP1, IERR, EST, HNEW, OLDNRM, PNORM, R, RATE, TEMP1, * TEMP2, TERK, TERKM1, TERKM2, TERKP1, XOLD, XRATE LOGICAL CONVGD C @@ -2565,8 +2566,8 @@ C C CALCULATE THE LOCAL ERROR FOR THE CURRENT STEP C TO SEE IF THE STEP WAS SUCCESSFUL 430 CONTINUE - ERR = CK * ENORM - IF(ERR .GT. 1.0D0)GO TO 600 + IERR = CK * ENORM + IF(IERR .GT. 1.0D0)GO TO 600 C C C diff --git a/scilab/modules/differential_equations/src/fortran/lsdisc.f b/scilab/modules/differential_equations/src/fortran/lsdisc.f index 90b5770..08b04ba 100644 --- a/scilab/modules/differential_equations/src/fortran/lsdisc.f +++ b/scilab/modules/differential_equations/src/fortran/lsdisc.f @@ -35,13 +35,11 @@ C c----------------------------------------------------------------------- integer it,itout double precision tt - integer iero - common /ierode/ iero include 'stack.h' c it=int(t) itout=int(tout) - iero=0 + ierror=0 if ( itout.lt.it) then istate=-3 return @@ -52,7 +50,7 @@ c do 10 j=it,itout-1 tt=dble(j) call f (neq,tt, y, rwork) - if(iero.gt.0) then + if(ierror.gt.0) then istate=-4 return endif diff --git a/scilab/modules/differential_equations/src/fortran/lsoda.f b/scilab/modules/differential_equations/src/fortran/lsoda.f index d7eb70b..9a1d2c2 100644 --- a/scilab/modules/differential_equations/src/fortran/lsoda.f +++ b/scilab/modules/differential_equations/src/fortran/lsoda.f @@ -975,6 +975,8 @@ c----------------------------------------------------------------------- c the following card is for optimized compilation on lll compilers. clll. optimize c----------------------------------------------------------------------- + + include 'stack.h' external prja, solsy integer illin, init, lyh, lewt, lacor, lsavf, lwm, liwm, 1 mxstep, mxhnil, nhnil, ntrep, nslast, nyh, iowns @@ -1008,8 +1010,6 @@ c in subroutines lsoda, stoda, and prja. groups of variables are c replaced by dummy arrays in the common declarations in routines c where those variables are not used. c----------------------------------------------------------------------- - integer iero - common /ierode/ iero common /ls0001/ tret, rowns(209), 1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, 2 illin, init, lyh, lewt, lacor, lsavf, lwm, liwm, @@ -1028,7 +1028,7 @@ c if istate .gt. 1 but the flag init shows that initialization has c not yet been done, an error return occurs. c if istate = 1 and tout = t, jump to block g and return immediately. c----------------------------------------------------------------------- - iero=0 + ierror=0 if (istate .lt. 1 .or. istate .gt. 3) go to 601 if (itask .lt. 1 .or. itask .gt. 5) go to 602 if (istate .eq. 1) go to 10 @@ -1219,7 +1219,7 @@ c----------------------------------------------------------------------- c initial call to f. (lf0 points to yh(*,2).) ------------------------- lf0 = lyh + nyh call f (neq, t, y, rwork(lf0)) - if(iero.gt.0) return + if(ierror.gt.0) return nfe = 1 c load the initial value vector in yh. --------------------------------- do 115 i = 1,n @@ -1365,7 +1365,7 @@ c----------------------------------------------------------------------- call stoda (neq, y, rwork(lyh), nyh, rwork(lyh), rwork(lewt), 1 rwork(lsavf), rwork(lacor), rwork(lwm), iwork(liwm), 2 f, jac, prja, solsy) - if(iero.gt.0) return + if(ierror.gt.0) return kgo = 1 - kflag go to (300, 530, 540), kgo c----------------------------------------------------------------------- diff --git a/scilab/modules/differential_equations/src/fortran/lsodar.f b/scilab/modules/differential_equations/src/fortran/lsodar.f index be4fa6d..e4fa421 100644 --- a/scilab/modules/differential_equations/src/fortran/lsodar.f +++ b/scilab/modules/differential_equations/src/fortran/lsodar.f @@ -1092,6 +1092,9 @@ c----------------------------------------------------------------------- c the following card is for optimized compilation on lll compilers. clll. optimize c----------------------------------------------------------------------- + + include 'stack.h' + external prja, solsy integer illin, init, lyh, lewt, lacor, lsavf, lwm, liwm, 1 mxstep, mxhnil, nhnil, ntrep, nslast, nyh, iowns @@ -1130,8 +1133,6 @@ c in subroutines lsodar, rchek, and roots. groups of variables are c replaced by dummy arrays in the common declarations in routines c where those variables are not used. c----------------------------------------------------------------------- - integer iero - common /ierode/ iero common /ls0001/ tret, rowns(209), 1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, 2 illin, init, lyh, lewt, lacor, lsavf, lwm, liwm, @@ -1361,7 +1362,7 @@ c----------------------------------------------------------------------- c initial call to f. (lf0 points to yh(*,2).) ------------------------- lf0 = lyh + nyh call f (neq, t, y, rwork(lf0)) - if(iero.gt.0) return + if(ierror.gt.0) return nfe = 1 c load the initial value vector in yh. --------------------------------- do 115 i = 1,n @@ -1428,7 +1429,7 @@ c check for a zero of g at t. ------------------------------------------ if (ngc .eq. 0) go to 270 call rchek (1, g, neq, y, rwork(lyh), nyh, 1 rwork(lg0), rwork(lg1), rwork(lgx), jroot, irt) - if(iero.gt.0) return + if(ierror.gt.0) return if (irt .eq. 0) go to 270 go to 632 c----------------------------------------------------------------------- @@ -1447,7 +1448,7 @@ c if (itask .eq. 1 .or. itask .eq. 4) toutc = tout call rchek (2, g, neq, y, rwork(lyh), nyh, 1 rwork(lg0), rwork(lg1), rwork(lgx), jroot, irt) - if(iero.gt.0) return + if(ierror.gt.0) return if (irt .lt. 0) go to 632 if (irt .ne. 1) go to 205 irfnd = 1 @@ -1538,7 +1539,7 @@ c----------------------------------------------------------------------- call stoda (neq, y, rwork(lyh), nyh, rwork(lyh), rwork(lewt), 1 rwork(lsavf), rwork(lacor), rwork(lwm), iwork(liwm), 2 f, jac, prja, solsy) - if(iero.gt.0) return + if(ierror.gt.0) return kgo = 1 - kflag go to (300, 530, 540), kgo c----------------------------------------------------------------------- @@ -1575,7 +1576,7 @@ c if (ngc .eq. 0) go to 315 call rchek (3, g, neq, y, rwork(lyh), nyh, 1 rwork(lg0), rwork(lg1), rwork(lgx), jroot, irt) - if(iero.gt.0) return + if(ierror.gt.0) return if (irt .ne. 1) go to 315 irfnd = 1 istate = 3 diff --git a/scilab/modules/differential_equations/src/fortran/lsode.f b/scilab/modules/differential_equations/src/fortran/lsode.f index f41025c..d1b0564 100644 --- a/scilab/modules/differential_equations/src/fortran/lsode.f +++ b/scilab/modules/differential_equations/src/fortran/lsode.f @@ -1,5 +1,8 @@ subroutine lsode (f, neq, y, t, tout, itol, rtol, atol, itask, 1 istate, iopt, rwork, lrw, iwork, liw, jac, mf) + + include 'stack.h' + external f, jac integer neq, itol, itask, istate, iopt, lrw, iwork, liw, mf double precision y, t, tout, rtol, atol, rwork @@ -973,8 +976,6 @@ c lsode, intdy, stode, prepj, and solsy. groups of variables are c replaced by dummy arrays in the common declarations in routines c where those variables are not used. c----------------------------------------------------------------------- - integer iero - common /ierode/ iero common /ls0001/ tret, rowns(209), 1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, 2 illin, init, lyh, lewt, lacor, lsavf, lwm, liwm, @@ -992,7 +993,7 @@ c if istate .gt. 1 but the flag init shows that initialization has c not yet been done, an error return occurs. c if istate = 1 and tout = t, jump to block g and return immediately. c----------------------------------------------------------------------- - iero=0 + ierror=0 if (istate .lt. 1 .or. istate .gt. 3) go to 601 if (itask .lt. 1 .or. itask .gt. 5) go to 602 if (istate .eq. 1) go to 10 @@ -1134,7 +1135,7 @@ c----------------------------------------------------------------------- c initial call to f. (lf0 points to yh(*,2).) ------------------------- lf0 = lyh + nyh call f (neq, t, y, rwork(lf0)) - if(iero.gt.0) return + if(ierror.gt.0) return nfe = 1 c load the initial value vector in yh. --------------------------------- do 115 i = 1,n @@ -1269,7 +1270,7 @@ c----------------------------------------------------------------------- call stode (neq, y, rwork(lyh), nyh, rwork(lyh), rwork(lewt), 1 rwork(lsavf), rwork(lacor), rwork(lwm), iwork(liwm), 2 f, jac, prepj, solsy) - if(iero.gt.0) return + if(ierror.gt.0) return kgo = 1 - kflag go to (300, 530, 540), kgo c----------------------------------------------------------------------- diff --git a/scilab/modules/differential_equations/src/fortran/lsodi.f b/scilab/modules/differential_equations/src/fortran/lsodi.f index af15c50..91c96ba 100644 --- a/scilab/modules/differential_equations/src/fortran/lsodi.f +++ b/scilab/modules/differential_equations/src/fortran/lsodi.f @@ -1136,6 +1136,8 @@ c----------------------------------------------------------------------- c the following card is for optimized compilation on llnl compilers. clll. optimize c----------------------------------------------------------------------- + include 'stack.h' + external prepji, solsy integer illin, init, lyh, lewt, lacor, lsavr, lwm, liwm, 1 mxstep, mxhnil, nhnil, ntrep, nslast, nyh, iowns @@ -1165,8 +1167,6 @@ c lsodi, intdy, stodi, prepji, and solsy. groups of variables are c replaced by dummy arrays in the common declarations in routines c where those variables are not used. c----------------------------------------------------------------------- - integer iero - common /ierode/ iero common /ls0001/ tret, rowns(209), 1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, 2 illin, init, lyh, lewt, lacor, lsavr, lwm, liwm, @@ -1184,7 +1184,7 @@ c not yet been done, an error return occurs. c if istate = 0 or 1 and tout = t, jump to block g and return c immediately. c----------------------------------------------------------------------- - iero=0 + ierror=0 if (istate .lt. 0 .or. istate .gt. 3) go to 601 if (itask .lt. 1 .or. itask .gt. 5) go to 602 if (istate .le. 1) go to 10 @@ -1338,7 +1338,7 @@ c lsodi must compute initial dy/dt (lyd0 points to yh(*,2)). ----------- goto 565 endif 110 continue - if(iero.gt.0) return + if(ierror.gt.0) return do 115 i = 1, n 115 rwork(i+lyh-1) = y(i) go to 130 @@ -1479,7 +1479,7 @@ c----------------------------------------------------------------------- call stodi (neq, y, rwork(lyh), nyh, rwork(lyh), rwork(lewt), 1 ydoti, rwork(lsavr), rwork(lacor), rwork(lwm), 2 iwork(liwm), res, adda, jac, prepji, solsy ) - if(iero.gt.0) return + if(ierror.gt.0) return kgo = 1 - kflag go to (300, 530, 540, 400, 550), kgo c @@ -1637,7 +1637,7 @@ c compute residual if relevant. ---------------------------------------- 585 y(i) = rwork( i+lyh-1 ) ires = 1 call res ( neq, tn, y, rwork(lsavr), ydoti, ires ) - if(iero.gt.0) return + if(ierror.gt.0) return nre = nre + 1 if (ires .le. 1) go to 595 call xerrwv('lsodi-- routine for evaluation od residue returns', diff --git a/scilab/modules/differential_equations/src/fortran/prepj.f b/scilab/modules/differential_equations/src/fortran/prepj.f index 5357222..365a460 100644 --- a/scilab/modules/differential_equations/src/fortran/prepj.f +++ b/scilab/modules/differential_equations/src/fortran/prepj.f @@ -2,6 +2,9 @@ C/MEMBR ADD NAME=PREPJ,SSI=0 subroutine prepj (neq, y, yh, nyh, ewt, ftem, savf, wm, iwm, 1 f, jac) clll. optimize + + include 'stack.h' + external f, jac integer neq, nyh, iwm integer iownd, iowns, @@ -16,8 +19,6 @@ clll. optimize 1 vnorm dimension neq(*), y(*), yh(nyh,*), ewt(*), ftem(*), savf(*), 1 wm(*), iwm(*) - integer iero - common /ierode/ iero common /ls0001/ rownd, rowns(209), 2 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, 3 iownd(14), iowns(6), @@ -71,7 +72,7 @@ c if miter = 1, call jac and multiply by scalar. ----------------------- do 110 i = 1,lenp 110 wm(i+2) = 0.0d+0 call jac (neq, tn, y, 0, 0, wm(3), n) - if(iero.gt.0) return + if(ierror.gt.0) return con = -hl0 do 120 i = 1,lenp 120 wm(i+2) = wm(i+2)*con @@ -88,7 +89,7 @@ c if miter = 2, make n calls to f to approximate j. -------------------- y(j) = y(j) + r fac = -hl0/r call f (neq, tn, y, ftem) - if(iero.gt.0) return + if(ierror.gt.0) return do 220 i = 1,n 220 wm(i+j1) = (ftem(i) - savf(i))*fac y(j) = yj @@ -110,7 +111,7 @@ c if miter = 3, construct a diagonal approximation to j and p. --------- do 310 i = 1,n 310 y(i) = y(i) + r*(h*savf(i) - yh(i,2)) call f (neq, tn, y, wm(3)) - if(iero.gt.0) return + if(ierror.gt.0) return nfe = nfe + 1 do 320 i = 1,n r0 = h*savf(i) - yh(i,2) @@ -136,7 +137,7 @@ cc fin do 410 i = 1,lenp 410 wm(i+2) = 0.0d+0 call jac (neq, tn, y, ml, mu, wm(ml3), meband) - if(iero.gt.0) return + if(ierror.gt.0) return con = -hl0 do 420 i = 1,lenp 420 wm(i+2) = wm(i+2)*con @@ -158,7 +159,7 @@ c if miter = 5, make mband calls to f to approximate j. ---------------- r = max(srur*abs(yi),r0/ewt(i)) 530 y(i) = y(i) + r call f (neq, tn, y, ftem) - if(iero.gt.0) return + if(ierror.gt.0) return do 550 jj = j,n,mband y(jj) = yh(jj,1) yjj = y(jj) diff --git a/scilab/modules/differential_equations/src/fortran/prepji.f b/scilab/modules/differential_equations/src/fortran/prepji.f index acfa0da..c7426cd 100644 --- a/scilab/modules/differential_equations/src/fortran/prepji.f +++ b/scilab/modules/differential_equations/src/fortran/prepji.f @@ -2,6 +2,8 @@ C/MEMBR ADD NAME=PREPJI,SSI=0 subroutine prepji (neq, y, yh, nyh, ewt, rtem, savr, s, wm, iwm, 1 res, jac, adda) clll. optimize + include 'stack.h' + external res, jac, adda integer neq, nyh, iwm integer iownd, iowns, @@ -20,8 +22,6 @@ clll. optimize 3 iownd(14), iowns(6), 4 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, 5 maxord, maxcor, msbp, mxncf, n, nq, nst, nre, nje, nqu - integer iero - common /ierode/ iero c----------------------------------------------------------------------- c%purpose c prepji is called by stodi to compute and process the matrix @@ -69,14 +69,14 @@ c----------------------------------------------------------------------- c if miter = 1, call res, then jac, and multiply by scalar. ------------ 100 ires = 1 call res (neq, tn, y, s, savr, ires) - if(iero.gt.0) return + if(ierror.gt.0) return nre = nre + 1 if (ires .gt. 1) go to 600 lenp = n*n do 110 i = 1,lenp 110 wm(i+2) = 0.0d+0 call jac ( neq, tn, y, s, 0, 0, wm(3), n ) - if(iero.gt.0) return + if(ierror.gt.0) return con = -hl0 do 120 i = 1,lenp 120 wm(i+2) = wm(i+2)*con @@ -85,7 +85,7 @@ c if miter = 2, make n + 1 calls to res to approximate j. -------------- 200 continue ires = -1 call res (neq, tn, y, s, savr, ires) - if(iero.gt.0) return + if(ierror.gt.0) return nre = nre + 1 if (ires .gt. 1) go to 600 srur = wm(1) @@ -96,7 +96,7 @@ c if miter = 2, make n + 1 calls to res to approximate j. -------------- y(j) = y(j) + r fac = -hl0/r call res ( neq, tn, y, s, rtem, ires ) - if(iero.gt.0) return + if(ierror.gt.0) return nre = nre + 1 if (ires .gt. 1) go to 600 do 220 i = 1,n @@ -106,13 +106,13 @@ c if miter = 2, make n + 1 calls to res to approximate j. -------------- 230 continue ires = 1 call res (neq, tn, y, s, savr, ires) - if(iero.gt.0) return + if(ierror.gt.0) return nre = nre + 1 if (ires .gt. 1) go to 600 c add matrix a. -------------------------------------------------------- 240 continue call adda(neq, tn, y, 0, 0, wm(3), n) - if(iero.gt.0) return + if(ierror.gt.0) return c do lu decomposition on p. -------------------------------------------- call dgefa (wm(3), n, n, iwm(21), ier) if (ier .ne. 0) ierpj = 1 @@ -122,7 +122,7 @@ c dummy section for miter = 3 c if miter = 4, call res, then jac, and multiply by scalar. ------------ 400 ires = 1 call res (neq, tn, y, s, savr, ires) - if(iero.gt.0) return + if(ierror.gt.0) return nre = nre + 1 if (ires .gt. 1) go to 600 ml = iwm(1) @@ -137,7 +137,7 @@ cc fin do 410 i = 1,lenp 410 wm(i+2) = 0.0d+0 call jac ( neq, tn, y, s, ml, mu, wm(ml3), meband) - if(iero.gt.0) return + if(ierror.gt.0) return con = -hl0 do 420 i = 1,lenp 420 wm(i+2) = wm(i+2)*con @@ -146,7 +146,7 @@ c if miter = 5, make ml + mu + 2 calls to res to approximate j. -------- 500 continue ires = -1 call res (neq, tn, y, s, savr, ires) - if(iero.gt.0) return + if(ierror.gt.0) return nre = nre + 1 if (ires .gt. 1) go to 600 ml = iwm(1) @@ -163,7 +163,7 @@ c if miter = 5, make ml + mu + 2 calls to res to approximate j. -------- r = max(srur*abs(yi),0.010d+0/ewt(i)) 530 y(i) = y(i) + r call res ( neq, tn, y, s, rtem, ires) - if(iero.gt.0) return + if(ierror.gt.0) return nre = nre + 1 if (ires .gt. 1) go to 600 do 550 jj = j,n,mband @@ -180,13 +180,13 @@ c if miter = 5, make ml + mu + 2 calls to res to approximate j. -------- 560 continue ires = 1 call res (neq, tn, y, s, savr, ires) - if(iero.gt.0) return + if(ierror.gt.0) return nre = nre + 1 if (ires .gt. 1) go to 600 c add matrix a. -------------------------------------------------------- 570 continue call adda(neq, tn, y, ml, mu, wm(ml3), meband) - if(iero.gt.0) return + if(ierror.gt.0) return c do lu decomposition of p. -------------------------------------------- call dgbfa (wm(3), meband, n, ml, mu, iwm(21), ier) if (ier .ne. 0) ierpj = 1 diff --git a/scilab/modules/differential_equations/src/fortran/prja.f b/scilab/modules/differential_equations/src/fortran/prja.f index 6cecbac..d9def4c 100644 --- a/scilab/modules/differential_equations/src/fortran/prja.f +++ b/scilab/modules/differential_equations/src/fortran/prja.f @@ -2,6 +2,9 @@ C/MEMBR ADD NAME=PRJA,SSI=0 subroutine prja (neq, y, yh, nyh, ewt, ftem, savf, wm, iwm, 1 f, jac) clll. optimize + + include 'stack.h' + external f, jac integer neq, nyh, iwm integer iownd, iowns, @@ -18,8 +21,6 @@ clll. optimize 1 vmnorm, fnorm, bnorm dimension neq(*), y(*), yh(nyh,*), ewt(*), ftem(*), savf(*), 1 wm(*), iwm(*) - integer iero - common /ierode/ iero common /ls0001/ rownd, rowns(209), 2 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, 3 iownd(14), iowns(6), @@ -74,7 +75,7 @@ c if miter = 1, call jac and multiply by scalar. ----------------------- do 110 i = 1,lenp 110 wm(i+2) = 0.0d+0 call jac (neq, tn, y, 0, 0, wm(3), n) - if(iero.gt.0) return + if(ierror.gt.0) return con = -hl0 do 120 i = 1,lenp 120 wm(i+2) = wm(i+2)*con @@ -91,7 +92,7 @@ c if miter = 2, make n calls to f to approximate j. -------------------- y(j) = y(j) + r fac = -hl0/r call f (neq, tn, y, ftem) - if(iero.gt.0) return + if(ierror.gt.0) return do 220 i = 1,n 220 wm(i+j1) = (ftem(i) - savf(i))*fac y(j) = yj @@ -122,7 +123,7 @@ c if miter = 4, call jac and multiply by scalar. ----------------------- do 410 i = 1,lenp 410 wm(i+2) = 0.0d+0 call jac (neq, tn, y, ml, mu, wm(ml3), meband) - if(iero.gt.0) return + if(ierror.gt.0) return con = -hl0 do 420 i = 1,lenp 420 wm(i+2) = wm(i+2)*con @@ -144,7 +145,7 @@ c if miter = 5, make mband calls to f to approximate j. ---------------- r = max(srur*abs(yi),r0/ewt(i)) 530 y(i) = y(i) + r call f (neq, tn, y, ftem) - if(iero.gt.0) return + if(ierror.gt.0) return do 550 jj = j,n,mband y(jj) = yh(jj,1) yjj = y(jj) diff --git a/scilab/modules/differential_equations/src/fortran/rchek.f b/scilab/modules/differential_equations/src/fortran/rchek.f index 6257230..c9d762f 100644 --- a/scilab/modules/differential_equations/src/fortran/rchek.f +++ b/scilab/modules/differential_equations/src/fortran/rchek.f @@ -1,5 +1,7 @@ subroutine rchek (job, g, neq, y, yh, nyh, g0, g1, gx, jroot, irt) clll. optimize + include 'stack.h' + external g integer job, neq, nyh, jroot, irt double precision y, yh, g0, g1, gx @@ -21,8 +23,6 @@ clll. optimize 5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu common /lsr001/ rownr3(2), t0, tlast, toutc, 1 iownd3(3), iownr3(2), irfnd, itaskc, ngc, nge - integer iero - common /ierode/ iero c!purpose @@ -74,7 +74,7 @@ c evaluate g at initial t, and check for zero values. ------------------ 100 continue t0 = tn call g (neq, t0, y, ngc, g0) - if(iero.gt.0) return + if(ierror.gt.0) return nge = 1 zroot = .false. do 110 i = 1,ngc @@ -87,7 +87,7 @@ c g has a zero at t. look at g at t + (small increment). -------------- do 120 i = 1,n 120 y(i) = y(i) + temp2*yh(i,2) call g (neq, t0, y, ngc, g0) - if(iero.gt.0) return + if(ierror.gt.0) return nge = nge + 1 zroot = .false. do 130 i = 1,ngc @@ -106,7 +106,7 @@ c c if a root was found on the previous step, evaluate g0 = g(t0). ------- call intdy (t0, 0, yh, nyh, y, iflag) call g (neq, t0, y, ngc, g0) - if(iero.gt.0) return + if(ierror.gt.0) return nge = nge + 1 zroot = .false. do 210 i = 1,ngc @@ -126,7 +126,7 @@ c g has a zero at t0. look at g at t + (small increment). ------------- go to 240 230 call intdy (t0, 0, yh, nyh, y, iflag) 240 call g (neq, t0, y, ngc, g0) - if(iero.gt.0) return + if(ierror.gt.0) return nge = nge + 1 zroot = .false. do 250 i = 1,ngc @@ -157,7 +157,7 @@ c set t1 to tn or toutc, whichever comes first, and get g at t1. ------- do 320 i = 1,n 320 y(i) = yh(i,1) 330 call g (neq, t1, y, ngc, g1) - if(iero.gt.0) return + if(ierror.gt.0) return nge = nge + 1 c call roots to search for root in interval from t0 to t1. ------------- jflag = 0 @@ -166,7 +166,7 @@ c call roots to search for root in interval from t0 to t1. ------------- if (jflag .gt. 1) go to 360 call intdy (x, 0, yh, nyh, y, iflag) call g (neq, x, y, ngc, gx) - if(iero.gt.0) return + if(ierror.gt.0) return nge = nge + 1 go to 350 360 t0 = x diff --git a/scilab/modules/differential_equations/src/fortran/rchek2.f b/scilab/modules/differential_equations/src/fortran/rchek2.f index cc60939..6503232 100644 --- a/scilab/modules/differential_equations/src/fortran/rchek2.f +++ b/scilab/modules/differential_equations/src/fortran/rchek2.f @@ -1,6 +1,8 @@ subroutine rchek2(job, g, neq, y, yh, nyh, g0, g1, gx, jroot, irt $ ,IWORK) clll. optimize + include 'stack.h' + external g integer job, neq, nyh, jroot, irt double precision y, yh, g0, g1, gx @@ -22,8 +24,6 @@ clll. optimize 5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu common /lsr001/ rownr3(2), t0, tlast, toutc, 1 iownd3(3), iownr3(2), irfnd, itaskc, ngc, nge - integer iero - common /ierode/ iero c ------------------ masking ---------------- integer IWORK dimension IWORK(*) @@ -134,7 +134,7 @@ c set t1 to tn or toutc, whichever comes first, and get g at t1. ------- do 320 i = 1,n 320 y(i) = yh(i,1) 330 call g (neq, t1, y, ngc, g1) - if(iero.gt.0) return + if(ierror.gt.0) return nge = nge + 1 C Call DROOTS to search for root in interval from T0 to T1. ----------- @@ -149,7 +149,7 @@ C Call DROOTS to search for root in interval from T0 to T1. ----------- IF (JFLAG .GT. 1) GO TO 360 call intdy (x, 0, yh, nyh, y, iflag) call g (neq, x, y, ngc, gx) - if(iero.gt.0) return + if(ierror.gt.0) return nge = nge + 1 GO TO 350 diff --git a/scilab/modules/differential_equations/src/fortran/rkf45.f b/scilab/modules/differential_equations/src/fortran/rkf45.f index 417a063..b93e52d 100644 --- a/scilab/modules/differential_equations/src/fortran/rkf45.f +++ b/scilab/modules/differential_equations/src/fortran/rkf45.f @@ -180,10 +180,11 @@ c required for subsequent integration. accordingly, work and iwork c should not be altered. c c + include 'stack.h' + integer neqn,iflag,iwork(5) double precision y(neqn),t,tout,rerr,aerr,work(1) c - common/ierode/iero external fydot c integer k1,k2,k3,k4,k5,k6,k1m @@ -232,13 +233,13 @@ c h - an appropriate stepsize to be used for the next step c nfe- counter on the number of derivative function evaluations c c + logical hfaild,output c integer neqn,iflag,nfe,kop,init,jflag,kflag double precision y(neqn),t,tout,rerr,aerr,h,yp(neqn), 1 f1(neqn),f2(neqn),f3(neqn),f4(neqn),f5(neqn),savre, 2 savae,savey(*) - common/ierode/iero c external fydot c @@ -359,7 +360,7 @@ c c a=t call fydot(neqn,a,y,yp) - if(iero.gt.0) return + if(ierror.gt.0) return nfe=1 if (t .ne. tout) go to 65 iflag=2 @@ -404,7 +405,7 @@ c 90 y(k)=y(k)+dt*yp(k) a=tout call fydot(neqn,a,y,yp) - if(iero.gt.0) return + if(ierror.gt.0) return nfe=nfe+1 go to 300 c @@ -539,7 +540,7 @@ c 270 y(k)=f1(k) a=t call fydot(neqn,a,y,yp) - if(iero.gt.0) return + if(ierror.gt.0) return nfe=nfe+1 c c @@ -599,43 +600,45 @@ c double precision y(neqn),t,h,yp(neqn),f1(neqn),f2(neqn), 1 f3(neqn),f4(neqn),f5(neqn),s(neqn),savey(neqn) c + + include 'stack.h' + double precision ch integer k external fydot - common/ierode/iero c ch=h/4.0d0 do 221 k=1,neqn 221 y(k)=savey(k)+ch*yp(k) call fydot(neqn,t+ch,y,f1) - if(iero.gt.0) return + if(ierror.gt.0) return c ch=3.0d0*h/32.0d0 do 222 k=1,neqn 222 y(k)=savey(k)+ch*(yp(k)+3.0d0*f1(k)) call fydot(neqn,t+3.0d0*h/8.0d0,y,f2) - if(iero.gt.0) return + if(ierror.gt.0) return c ch=h/2197.0d0 do 223 k=1,neqn 223 y(k)=savey(k)+ch*(1932.0d0*yp(k)+ 1 (7296.0d0*f2(k)-7200.0d0*f1(k))) call fydot(neqn,t+12.0d0*h/13.0d0,y,f3) - if(iero.gt.0) return + if(ierror.gt.0) return c ch=h/4104.0d0 do 224 k=1,neqn 224 y(k)=savey(k)+ch*((8341.0d0*yp(k)-845.0d0*f3(k))+ 1 (29440.0d0*f2(k)-32832.0d0*f1(k))) call fydot(neqn,t+h,y,f4) - if(iero.gt.0) return + if(ierror.gt.0) return c ch=h/20520.0d0 do 225 k=1,neqn 225 y(k)=savey(k)+ch*((-6080.0d0*yp(k)+(9295.0d0*f3(k)- 1 5643.0d0*f4(k)))+(41040.0d0*f1(k)-28352.0d0*f2(k))) call fydot(neqn,t+h/2.0d0,y,f5) - if(iero.gt.0) return + if(ierror.gt.0) return c c compute approximate solution at t+h c diff --git a/scilab/modules/differential_equations/src/fortran/rksimp.f b/scilab/modules/differential_equations/src/fortran/rksimp.f index 1bd5847..ab4bf56 100644 --- a/scilab/modules/differential_equations/src/fortran/rksimp.f +++ b/scilab/modules/differential_equations/src/fortran/rksimp.f @@ -4,15 +4,16 @@ c c fehlberg fourth-fifth order runge-kutta method c c + include 'stack.h' + integer neqn,iflag,iwork(*) double precision y(*),t,tout,rerr,aerr,work(*),h c double precision ae,scale,eeoet,et,esttol,ee - common/ierode/iero external fydot2 c integer k1,k2,k3,k4,k5,k6 - iero=0 + ierror=0 c c compute indices for the splitting of the work array c @@ -76,45 +77,46 @@ c double precision y(*),t,h,yp(neqn),f1(neqn),f2(neqn), 1 f3(neqn),f4(neqn),f5(neqn),s(neqn) c + include 'stack.h' + double precision ch integer k external fydot2 - common/ierode/iero c c write(6,*) 'inputfelh2:',y(1),y(2) call fydot2(neqn,t,y,yp) - if(iero.gt.0) return + if(ierror.gt.0) return ch=h/4.0d0 do 221 k=1,neqn 221 y(k)=y(k)+ch*yp(k) call fydot2(neqn,t+ch,y,f1) - if(iero.gt.0) return + if(ierror.gt.0) return c ch=3.0d0*h/32.0d0 do 222 k=1,neqn 222 y(k)=s(k)+ch*(yp(k)+3.0d0*f1(k)) call fydot2(neqn,t+3.0d0*h/8.0d0,y,f2) - if(iero.gt.0) return + if(ierror.gt.0) return c ch=h/2197.0d0 do 223 k=1,neqn 223 y(k)=s(k)+ch*(1932.0d0*yp(k)+(7296.0d0*f2(k)-7200.0d0*f1(k))) call fydot2(neqn,t+12.0d0*h/13.0d0,y,f3) - if(iero.gt.0) return + if(ierror.gt.0) return c ch=h/4104.0d0 do 224 k=1,neqn 224 y(k)=s(k)+ch*((8341.0d0*yp(k)-845.0d0*f3(k))+ 1 (29440.0d0*f2(k)-32832.0d0*f1(k))) call fydot2(neqn,t+h,y,f4) - if(iero.gt.0) return + if(ierror.gt.0) return c ch=h/20520.0d0 do 225 k=1,neqn 225 y(k)=s(k)+ch*((-6080.0d0*yp(k)+(9295.0d0*f3(k)- 1 5643.0d0*f4(k)))+(41040.0d0*f1(k)-28352.0d0*f2(k))) call fydot2(neqn,t+h/2.0d0,y,f5) - if(iero.gt.0) return + if(ierror.gt.0) return c c compute approximate solution at t+h c diff --git a/scilab/modules/differential_equations/src/fortran/stoda.f b/scilab/modules/differential_equations/src/fortran/stoda.f index 7f91f5c..5dd70eb 100644 --- a/scilab/modules/differential_equations/src/fortran/stoda.f +++ b/scilab/modules/differential_equations/src/fortran/stoda.f @@ -2,6 +2,8 @@ C/MEMBR ADD NAME=STODA,SSI=0 subroutine stoda (neq, y, yh, nyh, yh1, ewt, savf, acor, 1 wm, iwm, f, jac, pjac, slvs) clll. optimize + + include 'stack.h' external f, jac, pjac, slvs integer neq, nyh, iwm integer iownd, ialth, ipup, lmax, meo, nqnyh, nslp, @@ -23,8 +25,6 @@ clll. optimize dimension neq(*), y(*), yh(nyh,*), yh1(*), ewt(*), savf(*), 1 acor(*), wm(*), iwm(*) dimension sm1(12) - integer iero - common /ierode/ iero common /ls0001/ rownd, conit, crate, el(13), elco(13,12), 1 hold, rmax, tesco(3,12), 2 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, iownd(14), @@ -259,10 +259,10 @@ c----------------------------------------------------------------------- do 230 i = 1,n 230 y(i) = yh(i,1) call f (neq, tn, y, savf) - if(iero.gt.0) return + if(ierror.gt.0) return nfe = nfe + 1 if (tn.gt.64.7) then - iero=0 + ierror=0 endif if (ipup .le. 0) go to 250 c----------------------------------------------------------------------- @@ -275,7 +275,7 @@ c----------------------------------------------------------------------- nslp = nst crate = 0.70d+0 call pjac (neq, y, yh, nyh, ewt, acor, savf, wm, iwm, f, jac) - if(iero.gt.0) return + if(ierror.gt.0) return if (ierpj .ne. 0) go to 430 250 do 260 i = 1,n 260 acor(i) = 0.0d+0 @@ -337,7 +337,7 @@ c----------------------------------------------------------------------- if (m .ge. 2 .and. del .gt. 2.0d+0*delp) go to 410 delp = del call f (neq, tn, y, savf) - if(iero.gt.0) return + if(ierror.gt.0) return nfe = nfe + 1 go to 270 c----------------------------------------------------------------------- @@ -611,7 +611,7 @@ c----------------------------------------------------------------------- do 645 i = 1,n 645 y(i) = yh(i,1) call f (neq, tn, y, savf) - if(iero.gt.0) return + if(ierror.gt.0) return nfe = nfe + 1 do 650 i = 1,n 650 yh(i,2) = h*savf(i) diff --git a/scilab/modules/differential_equations/src/fortran/stode.f b/scilab/modules/differential_equations/src/fortran/stode.f index 41ccd8b..b795170 100644 --- a/scilab/modules/differential_equations/src/fortran/stode.f +++ b/scilab/modules/differential_equations/src/fortran/stode.f @@ -2,6 +2,9 @@ C/MEMBR ADD NAME=STODE,SSI=0 subroutine stode (neq, y, yh, nyh, yh1, ewt, savf, acor, 1 wm, iwm, f, jac, pjac, slvs) clll. optimize + + include 'stack.h' + external f, jac, pjac, slvs integer neq, nyh, iwm integer iownd, ialth, ipup, lmax, meo, nqnyh, nslp, @@ -16,8 +19,6 @@ clll. optimize 1 r, rh, rhdn, rhsm, rhup, told, vnorm dimension neq(*), y(*), yh(nyh,*), yh1(*), ewt(*), savf(*), 1 acor(*), wm(*), iwm(*) - integer iero - common /ierode/ iero common /ls0001/ rownd, conit, crate, el(13), elco(13,12), 1 hold, rmax, tesco(3,12), 2 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, iownd(14), @@ -236,7 +237,7 @@ c----------------------------------------------------------------------- do 230 i = 1,n 230 y(i) = yh(i,1) call f (neq, tn, y, savf) - if(iero.gt.0) return + if(ierror.gt.0) return nfe = nfe + 1 if (ipup .le. 0) go to 250 c----------------------------------------------------------------------- @@ -249,7 +250,7 @@ c----------------------------------------------------------------------- nslp = nst crate = 0.70d+0 call pjac (neq, y, yh, nyh, ewt, acor, savf, wm, iwm, f, jac) - if(iero.gt.0) return + if(ierror.gt.0) return if (ierpj .ne. 0) go to 430 250 do 260 i = 1,n 260 acor(i) = 0.0d+0 @@ -292,7 +293,7 @@ c----------------------------------------------------------------------- if (m .ge. 2 .and. del .gt. 2.0d+0*delp) go to 410 delp = del call f (neq, tn, y, savf) - if(iero.gt.0) return + if(ierror.gt.0) return nfe = nfe + 1 go to 270 c----------------------------------------------------------------------- @@ -450,7 +451,7 @@ c----------------------------------------------------------------------- do 645 i = 1,n 645 y(i) = yh(i,1) call f (neq, tn, y, savf) - if(iero.gt.0) return + if(ierror.gt.0) return nfe = nfe + 1 do 650 i = 1,n 650 yh(i,2) = h*savf(i) diff --git a/scilab/modules/differential_equations/src/fortran/stodi.f b/scilab/modules/differential_equations/src/fortran/stodi.f index 11d551a..a661202 100644 --- a/scilab/modules/differential_equations/src/fortran/stodi.f +++ b/scilab/modules/differential_equations/src/fortran/stodi.f @@ -23,8 +23,6 @@ clll. optimize 3 ialth, ipup, lmax, meo, nqnyh, nslp, 4 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, 5 maxord, maxcor, msbp, mxncf, n, nq, nst, nre, nje, nqu - integer iero - common /ierode/ iero c----------------------------------------------------------------------- c%purpose c stodi performs one step of the integration of an initial value @@ -255,14 +253,14 @@ c----------------------------------------------------------------------- crate = 0.70d+0 call pjac (neq, y, yh, nyh, ewt, acor, savr, savf, wm, iwm, 1 res, jac, adda ) - if(iero.gt.0) return + if(ierror.gt.0) return if (ierpj .eq. 0) go to 250 ires = ierpj go to (430, 435, 430), ires c get residual at predicted values, if not already done in pjac. ------- 240 ires = 1 call res ( neq, tn, y, savf, savr, ires ) - if(iero.gt.0) return + if(ierror.gt.0) return nre = nre + 1 kgo = abs(ires) go to ( 250, 435, 430 ) , kgo @@ -295,7 +293,7 @@ c----------------------------------------------------------------------- delp = del ires = 1 call res ( neq, tn, y, savf, savr, ires ) - if(iero.gt.0) return + if(ierror.gt.0) return nre = nre + 1 kgo = abs(ires) go to ( 270, 435, 410 ) , kgo diff --git a/scilab/modules/differential_equations/src/fortran/xerrwv.f b/scilab/modules/differential_equations/src/fortran/xerrwv.f index 2e24c35..9f8f03a 100644 --- a/scilab/modules/differential_equations/src/fortran/xerrwv.f +++ b/scilab/modules/differential_equations/src/fortran/xerrwv.f @@ -59,8 +59,6 @@ c----------------------------------------------------------------------- include 'stack.h' integer num, imess, imode common /eh0001/ mesflg, lunit - integer iero - common /ierode/ iero character*80 str c----------------------------------------------------------------------- if (mesflg .eq. 0) go to 100 @@ -111,5 +109,5 @@ cstd write (lun, 50) r1,r2 endif c abort the run if iert = 2. ------------------------------------------- 100 if (iert .ne. 2) return - iero = 1 + ierror = 1 end diff --git a/scilab/modules/scicos_blocks/src/fortran/sciblk.f b/scilab/modules/scicos_blocks/src/fortran/sciblk.f index 0e4967a..d540f3d 100644 --- a/scilab/modules/scicos_blocks/src/fortran/sciblk.f +++ b/scilab/modules/scicos_blocks/src/fortran/sciblk.f @@ -47,7 +47,6 @@ C integer mlhs,mrhs logical allowptr C - common /ierode/ iero common /scsptr/ ptr C if (ddt .eq. 4) then @@ -59,7 +58,7 @@ c & buf(5:8) ) C mlhs = 5 mrhs = 8 - iero = 0 + ierror = 0 call itosci(flag,1,1) if (err .gt. 0) goto 9999 call itosci(nevprt,1,1) @@ -140,8 +139,8 @@ C+ return C 9999 continue - iero = -1 - flag=iero + ierror = -1 + flag=ierror niv = niv - 1 return end -- 1.7.9.5