Mercurial > hg > octave-max

changeset 10103:0e71ead7359d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Use CALL XSTOPX instead of STOP in Fortran ranlib routines New call allows Octave's error handler to intercept otherwise fatal errors in Fortran code
author Rik <rdrider0-list@yahoo.com>
date Wed, 13 Jan 2010 22:22:46 -0800
parents 8b4e3388a254
children 20b74e630faf
files libcruft/ChangeLog libcruft/ranlib/advnst.f libcruft/ranlib/genbet.f libcruft/ranlib/genchi.f libcruft/ranlib/genexp.f libcruft/ranlib/genf.f libcruft/ranlib/gengam.f libcruft/ranlib/genmul.f libcruft/ranlib/gennch.f libcruft/ranlib/gennf.f libcruft/ranlib/gennor.f libcruft/ranlib/genunf.f libcruft/ranlib/getcgn.f libcruft/ranlib/getsd.f libcruft/ranlib/ignbin.f libcruft/ranlib/ignnbn.f libcruft/ranlib/ignpoi.f libcruft/ranlib/ignuin.f libcruft/ranlib/initgn.f libcruft/ranlib/mltmod.f libcruft/ranlib/setant.f libcruft/ranlib/setgmn.f libcruft/ranlib/setsd.f
diffstat 23 files changed, 51 insertions(+), 33 deletions(-) [+]
line wrap: on
line diff
--- a/libcruft/ChangeLog
+++ b/libcruft/ChangeLog
@@ -1,3 +1,13 @@
+2009-01-13  Rik <octave@nomad.inbox5.com>
+
+	* ranlib/advnst.f ranlib/genbet.f ranlib/genchi.f ranlib/genexp.f
+	ranlib/genf.f ranlib/gengam.f ranlib/genmul.f ranlib/gennch.f
+	ranlib/gennf.f ranlib/gennor.f ranlib/genunf.f ranlib/getcgn.f
+	ranlib/getsd.f ranlib/ignbin.f ranlib/ignnbn.f ranlib/ignpoi.f
+	ranlib/ignuin.f ranlib/initgn.f ranlib/mltmod.f ranlib/setant.f
+	ranlib/setgmn.f ranlib/setsd.f: call XSTOPX instead of STOP so Octave's
+	error handler can intercept errors in Fortran code
+
 2010-01-07  Jaroslav Hajek  <highegg@gmail.com>
 
 	* misc/quit.cc (octave_rethrow_exception): Set octave_interrupt_state
--- a/libcruft/ranlib/advnst.f
+++ b/libcruft/ranlib/advnst.f
@@ -60,7 +60,8 @@
       IF (qrgnin()) GO TO 10
       WRITE (*,*) ' ADVNST called before random number generator ',
      +  ' initialized -- abort!'
-      STOP ' ADVNST called before random number generator initialized'
+      CALL XSTOPX
+     + (' ADVNST called before random number generator initialized')
 
    10 CALL getcgn(g)
 C
--- a/libcruft/ranlib/genbet.f
+++ b/libcruft/ranlib/genbet.f
@@ -77,7 +77,7 @@
       IF (.NOT. (aa.LT.minlog.OR.bb.LT.minlog)) GO TO 10
       WRITE (*,*) ' AA or BB < ',minlog,' in GENBET - Abort!'
       WRITE (*,*) ' AA: ',aa,' BB ',bb
-      STOP ' AA or BB too small in GENBET - Abort!'
+      CALL XSTOPX (' AA or BB too small in GENBET - Abort!')
 
    10 olda = aa
       oldb = bb
--- a/libcruft/ranlib/genchi.f
+++ b/libcruft/ranlib/genchi.f
@@ -39,7 +39,7 @@
       IF (.NOT. (df.LE.0.0)) GO TO 10
       WRITE (*,*) 'DF <= 0 in GENCHI - ABORT'
       WRITE (*,*) 'Value of DF: ',df
-      STOP 'DF <= 0 in GENCHI - ABORT'
+      CALL XSTOPX ('DF <= 0 in GENCHI - ABORT')
 
 C     JJV changed this to call sgamma directly
 C   10 genchi = 2.0*gengam(1.0,df/2.0)
--- a/libcruft/ranlib/genexp.f
+++ b/libcruft/ranlib/genexp.f
@@ -52,7 +52,7 @@
       IF (av.GE.0.0) GO TO 10
       WRITE (*,*) 'AV < 0.0 in GENEXP - ABORT'
       WRITE (*,*) 'Value of AV: ',av
-      STOP 'AV < 0.0 in GENEXP - ABORT'
+      CALL XSTOPX ('AV < 0.0 in GENEXP - ABORT')
 
  10   genexp = sexpo()*av
       RETURN
--- a/libcruft/ranlib/genf.f
+++ b/libcruft/ranlib/genf.f
@@ -47,7 +47,7 @@
       IF (.NOT. (dfn.LE.0.0.OR.dfd.LE.0.0)) GO TO 10
       WRITE (*,*) 'Degrees of freedom nonpositive in GENF - abort!'
       WRITE (*,*) 'DFN value: ',dfn,'DFD value: ',dfd
-      STOP 'Degrees of freedom nonpositive in GENF - abort!'
+      CALL XSTOPX ('Degrees of freedom nonpositive in GENF - abort!')
 
  10   xnum = 2.0*sgamma(dfn/2.0)/dfn
 
--- a/libcruft/ranlib/gengam.f
+++ b/libcruft/ranlib/gengam.f
@@ -61,7 +61,8 @@
       WRITE (*,*) 'In GENGAM - Either (1) Location param A <= 0.0 or'
       WRITE (*,*) '(2) Shape param R <= 0.0 - ABORT!'
       WRITE (*,*) 'A value: ',a,'R value: ',r
-      STOP 'Location or shape param out of range in GENGAM - ABORT!'
+      CALL XSTOPX
+     + ('Location or shape param out of range in GENGAM - ABORT!')
 C     JJV end addition
 
  10   gengam = sgamma(r)/a
--- a/libcruft/ranlib/genmul.f
+++ b/libcruft/ranlib/genmul.f
@@ -59,15 +59,15 @@
 C     .. Executable Statements ..
 
 C     Check Arguments
-      IF (n.LT.0) STOP 'N < 0 in GENMUL'
-      IF (ncat.LE.1) STOP 'NCAT <= 1 in GENMUL'
+      IF (n.LT.0) CALL XSTOPX ('N < 0 in GENMUL')
+      IF (ncat.LE.1) CALL XSTOPX ('NCAT <= 1 in GENMUL')
       ptot = 0.0
       DO 10,i = 1,ncat - 1
-          IF (p(i).LT.0.0) STOP 'Some P(i) < 0 in GENMUL'
-          IF (p(i).GT.1.0) STOP 'Some P(i) > 1 in GENMUL'
+          IF (p(i).LT.0.0) CALL XSTOPX ('Some P(i) < 0 in GENMUL')
+          IF (p(i).GT.1.0) CALL XSTOPX ('Some P(i) > 1 in GENMUL')
           ptot = ptot + p(i)
    10 CONTINUE
-      IF (ptot.GT.0.99999) STOP 'Sum of P(i) > 1 in GENMUL'
+      IF (ptot.GT.0.99999) CALL XSTOPX ('Sum of P(i) > 1 in GENMUL')
 
 C     Initialize variables
       ntot = n
--- a/libcruft/ranlib/gennch.f
+++ b/libcruft/ranlib/gennch.f
@@ -52,7 +52,7 @@
       IF (.NOT. (df.LT.1.0.OR.xnonc.LT.0.0)) GO TO 10
       WRITE (*,*) 'DF < 1 or XNONC < 0 in GENNCH - ABORT'
       WRITE (*,*) 'Value of DF: ',df,' Value of XNONC',xnonc
-      STOP 'DF < 1 or XNONC < 0 in GENNCH - ABORT'
+      CALL XSTOPX ('DF < 1 or XNONC < 0 in GENNCH - ABORT')
 
 C     JJV changed this to call SGAMMA and SNORM directly
 C      gennch = genchi(df-1.0) + gennor(sqrt(xnonc),1.0)**2
--- a/libcruft/ranlib/gennf.f
+++ b/libcruft/ranlib/gennf.f
@@ -61,7 +61,9 @@
       WRITE (*,*) '(3) Noncentrality parameter < 0.0'
       WRITE (*,*) 'DFN value: ',dfn,'DFD value: ',dfd,'XNONC value: ',
      +  xnonc
-      STOP 'Degrees of freedom or noncent param out of range in GENNF'
+
+      CALL XSTOPX
+     + ('Degrees of freedom or noncent param out of range in GENNF')
 
 C      GENNF = ( GENNCH( DFN, XNONC ) / DFN ) / ( GENCHI( DFD ) / DFD )
 C     JJV changed this to call SGAMMA and SNORM directly
--- a/libcruft/ranlib/gennor.f
+++ b/libcruft/ranlib/gennor.f
@@ -53,7 +53,7 @@
       IF (sd.GE.0.0) GO TO 10
       WRITE (*,*) 'SD < 0.0 in GENNOR - ABORT'
       WRITE (*,*) 'Value of SD: ',sd
-      STOP 'SD < 0.0 in GENNOR - ABORT'
+      CALL XSTOPX ('SD < 0.0 in GENNOR - ABORT')
 
  10   gennor = sd*snorm() + av
       RETURN
--- a/libcruft/ranlib/genunf.f
+++ b/libcruft/ranlib/genunf.f
@@ -33,7 +33,7 @@
       IF (.NOT. (low.GT.high)) GO TO 10
       WRITE (*,*) 'LOW > HIGH in GENUNF: LOW ',low,' HIGH: ',high
       WRITE (*,*) 'Abort'
-      STOP 'LOW > High in GENUNF - Abort'
+      CALL XSTOPX ('LOW > High in GENUNF - Abort')
 
    10 genunf = low + (high-low)*ranf()
 
--- a/libcruft/ranlib/getcgn.f
+++ b/libcruft/ranlib/getcgn.f
@@ -47,7 +47,7 @@
       IF (.NOT. (g.LT.0.OR.g.GT.numg)) GO TO 10
       WRITE (*,*) ' Generator number out of range in SETCGN:',
      +  ' Legal range is 1 to ',numg,' -- ABORT!'
-      STOP ' Generator number out of range in SETCGN'
+      CALL XSTOPX (' Generator number out of range in SETCGN')
 
    10 curntg = g
       RETURN
--- a/libcruft/ranlib/getsd.f
+++ b/libcruft/ranlib/getsd.f
@@ -62,7 +62,8 @@
       IF (qrgnin()) GO TO 10
       WRITE (*,*) ' GETSD called before random number generator ',
      +  ' initialized -- abort!'
-      STOP ' GETSD called before random number generator initialized'
+      CALL XSTOPX 
+     + (' GETSD called before random number generator initialized')
 
    10 CALL getcgn(g)
       iseed1 = cg1(g)
--- a/libcruft/ranlib/ignbin.f
+++ b/libcruft/ranlib/ignbin.f
@@ -188,12 +188,12 @@
 C     JJV and 20 to the checkers and adding checkers
 C     JJV Only remaining problem - if called initially with the
 C     JJV initial values of psave and nsave, it will hang
- 10   IF (pp.LT.0.0) STOP 'PP < 0.0 in IGNBIN - ABORT!'
-      IF (pp.GT.1.0) STOP 'PP > 1.0 in IGNBIN - ABORT!'
+ 10   IF (pp.LT.0.0) CALL XSTOPX ('PP < 0.0 in IGNBIN - ABORT!')
+      IF (pp.GT.1.0) CALL XSTOPX ('PP > 1.0 in IGNBIN - ABORT!')
       psave = pp
       p = amin1(psave,1.-psave)
       q = 1. - p
- 20   IF (n.LT.0) STOP 'N < 0 in IGNBIN - ABORT!'
+ 20   IF (n.LT.0) CALL XSTOPX ('N < 0 in IGNBIN - ABORT!')
       xnp = n*p
       nsave = n
       IF (xnp.LT.30.) GO TO 140
--- a/libcruft/ranlib/ignnbn.f
+++ b/libcruft/ranlib/ignnbn.f
@@ -59,9 +59,9 @@
 C     .. Executable Statements ..
 C     Check Arguments
 C     JJV changed argumnet checker to abort if N <= 0
-      IF (n.LE.0) STOP 'N <= 0 in IGNNBN'
-      IF (p.LE.0.0) STOP 'P <= 0.0 in IGNNBN'
-      IF (p.GE.1.0) STOP 'P >= 1.0 in IGNNBN'
+      IF (n.LE.0) CALL XSTOPX ('N <= 0 in IGNNBN')
+      IF (p.LE.0.0) CALL XSTOPX ('P <= 0.0 in IGNNBN')
+      IF (p.GE.1.0) CALL XSTOPX ('P >= 1.0 in IGNNBN')
 
 C     Generate Y, a random gamma (n,(1-p)/p) variable
 C     JJV Note: the above parametrization is consistent with Devroye,
--- a/libcruft/ranlib/ignpoi.f
+++ b/libcruft/ranlib/ignpoi.f
@@ -237,7 +237,7 @@
       IF (mu.GE.0.0) GO TO 125
       WRITE (*,*) 'MU < 0 in IGNPOI - ABORT'
       WRITE (*,*) 'Value of MU: ',mu
-      STOP 'MU < 0 in IGNPOI - ABORT'
+      CALL XSTOPX ('MU < 0 in IGNPOI - ABORT')
 C     JJV added line label here
  125  muold = mu
       m = max0(1,ifix(mu))
--- a/libcruft/ranlib/ignuin.f
+++ b/libcruft/ranlib/ignuin.f
@@ -88,8 +88,8 @@
   100 WRITE (*,*) ' LOW: ',low,' HIGH: ',high
       WRITE (*,*) ' Abort on Fatal ERROR'
       IF (.NOT. (err.EQ.1)) GO TO 110
-      STOP 'LOW > HIGH in IGNUIN'
+      CALL XSTOPX ('LOW > HIGH in IGNUIN')
 
-  110 STOP ' ( HIGH - LOW ) > 2,147,483,561 in IGNUIN'
+  110 CALL XSTOPX (' ( HIGH - LOW ) > 2,147,483,561 in IGNUIN')
 
   120 END
--- a/libcruft/ranlib/initgn.f
+++ b/libcruft/ranlib/initgn.f
@@ -66,7 +66,8 @@
       IF (qrgnin()) GO TO 10
       WRITE (*,*) ' INITGN called before random number generator ',
      +  ' initialized -- abort!'
-      STOP ' INITGN called before random number generator initialized'
+      CALL XSTOPX 
+     + (' INITGN called before random number generator initialized')
 
    10 CALL getcgn(g)
       IF ((-1).NE. (isdtyp)) GO TO 20
@@ -83,7 +84,7 @@
       lg2(g) = mltmod(a2w,lg2(g),m2)
       GO TO 50
 
-   40 STOP 'ISDTYP NOT IN RANGE'
+   40 CALL XSTOPX ('ISDTYP NOT IN RANGE')
 
    50 cg1(g) = lg1(g)
       cg2(g) = lg2(g)
--- a/libcruft/ranlib/mltmod.f
+++ b/libcruft/ranlib/mltmod.f
@@ -39,7 +39,7 @@
       WRITE (*,*) ' A, M, S out of order in MLTMOD - ABORT!'
       WRITE (*,*) ' A = ',a,' S = ',s,' M = ',m
       WRITE (*,*) ' MLTMOD requires: 0 < A < M; 0 < S < M'
-      STOP ' A, M, S out of order in MLTMOD - ABORT!'
+      CALL XSTOPX (' A, M, S out of order in MLTMOD - ABORT!')
 
    10 IF (.NOT. (a.LT.h)) GO TO 20
       a0 = a
--- a/libcruft/ranlib/setant.f
+++ b/libcruft/ranlib/setant.f
@@ -65,7 +65,8 @@
       IF (qrgnin()) GO TO 10
       WRITE (*,*) ' SETANT called before random number generator ',
      +  ' initialized -- abort!'
-      STOP ' SETANT called before random number generator initialized'
+      CALL XSTOPX
+     + (' SETANT called before random number generator initialized')
 
    10 CALL getcgn(g)
       qanti(g) = qvalue
--- a/libcruft/ranlib/setgmn.f
+++ b/libcruft/ranlib/setgmn.f
@@ -68,7 +68,7 @@
       IF (.NOT. (p.LE.0)) GO TO 10
       WRITE (*,*) 'P nonpositive in SETGMN'
       WRITE (*,*) 'Value of P: ',p
-      STOP 'P nonpositive in SETGMN'
+      CALL XSTOPX ('P nonpositive in SETGMN')
 
    10 parm(1) = p
 C
@@ -85,7 +85,7 @@
       CALL spotrf ( 'Upper', p, covm, ldcovm, info)
       IF (.NOT. (info.NE.0)) GO TO 30
       WRITE (*,*) ' COVM not positive definite in SETGMN'
-      STOP ' COVM not positive definite in SETGMN'
+      CALL XSTOPX (' COVM not positive definite in SETGMN')
 
    30 icount = p + 1
 C
--- a/libcruft/ranlib/setsd.f
+++ b/libcruft/ranlib/setsd.f
@@ -62,7 +62,8 @@
       IF (qrgnin()) GO TO 10
       WRITE (*,*) ' SETSD called before random number generator ',
      +  ' initialized -- abort!'
-      STOP ' SETSD called before random number generator initialized'
+      CALL XSTOPX 
+     + (' SETSD called before random number generator initialized')
 
    10 CALL getcgn(g)
       ig1(g) = iseed1