# HG changeset patch # User Rik # Date 1263450166 28800 # Node ID 0e71ead7359da5272cffba1d7c3b7c4ba6706f73 # Parent 8b4e3388a25412f8e5d351fd70c293d71985f34a 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 diff --git a/libcruft/ChangeLog b/libcruft/ChangeLog --- a/libcruft/ChangeLog +++ b/libcruft/ChangeLog @@ -1,3 +1,13 @@ +2009-01-13 Rik + + * 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 * misc/quit.cc (octave_rethrow_exception): Set octave_interrupt_state diff --git a/libcruft/ranlib/advnst.f b/libcruft/ranlib/advnst.f --- 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 diff --git a/libcruft/ranlib/genbet.f b/libcruft/ranlib/genbet.f --- 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 diff --git a/libcruft/ranlib/genchi.f b/libcruft/ranlib/genchi.f --- 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) diff --git a/libcruft/ranlib/genexp.f b/libcruft/ranlib/genexp.f --- 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 diff --git a/libcruft/ranlib/genf.f b/libcruft/ranlib/genf.f --- 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 diff --git a/libcruft/ranlib/gengam.f b/libcruft/ranlib/gengam.f --- 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 diff --git a/libcruft/ranlib/genmul.f b/libcruft/ranlib/genmul.f --- 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 diff --git a/libcruft/ranlib/gennch.f b/libcruft/ranlib/gennch.f --- 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 diff --git a/libcruft/ranlib/gennf.f b/libcruft/ranlib/gennf.f --- 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 diff --git a/libcruft/ranlib/gennor.f b/libcruft/ranlib/gennor.f --- 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 diff --git a/libcruft/ranlib/genunf.f b/libcruft/ranlib/genunf.f --- 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() diff --git a/libcruft/ranlib/getcgn.f b/libcruft/ranlib/getcgn.f --- 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 diff --git a/libcruft/ranlib/getsd.f b/libcruft/ranlib/getsd.f --- 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) diff --git a/libcruft/ranlib/ignbin.f b/libcruft/ranlib/ignbin.f --- 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 diff --git a/libcruft/ranlib/ignnbn.f b/libcruft/ranlib/ignnbn.f --- 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, diff --git a/libcruft/ranlib/ignpoi.f b/libcruft/ranlib/ignpoi.f --- 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)) diff --git a/libcruft/ranlib/ignuin.f b/libcruft/ranlib/ignuin.f --- 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 diff --git a/libcruft/ranlib/initgn.f b/libcruft/ranlib/initgn.f --- 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) diff --git a/libcruft/ranlib/mltmod.f b/libcruft/ranlib/mltmod.f --- 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 diff --git a/libcruft/ranlib/setant.f b/libcruft/ranlib/setant.f --- 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 diff --git a/libcruft/ranlib/setgmn.f b/libcruft/ranlib/setgmn.f --- 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 diff --git a/libcruft/ranlib/setsd.f b/libcruft/ranlib/setsd.f --- 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