00006 {
00007 #define qxmon(zx,zy,zz) (int)((zx) <= (zy) && (zy) <= (zz))
00008 static double absstp,abstol,big,fbig,fsmall,relstp,reltol,small,step,stpmul,xhi,
00009     xlb,xlo,xsave,xub,yy;
00010 static int i99999;
00011 static unsigned long qbdd,qcond,qdum1,qdum2,qincr,qlim,qok,qup;
00012     switch(IENTRY){case 0: goto DINVR; case 1: goto DSTINV;}
00013 DINVR:
00014     if(*status > 0) goto S310;
00015     qcond = !qxmon(small,*x,big);
00016     if(qcond) ftnstop(" SMALL, X, BIG not monotone in INVR");
00017     xsave = *x;
00018 /*
00019      See that SMALL and BIG bound the zero and set QINCR
00020 */
00021     *x = small;
00022 /*
00023      GET-FUNCTION-VALUE
00024 */
00025     i99999 = 1;
00026     goto S300;
00027 S10:
00028     fsmall = *fx;
00029     *x = big;
00030 /*
00031      GET-FUNCTION-VALUE
00032 */
00033     i99999 = 2;
00034     goto S300;
00035 S20:
00036     fbig = *fx;
00037     qincr = fbig > fsmall;
00038     if(!qincr) goto S50;
00039     if(fsmall <= 0.0e0) goto S30;
00040     *status = -1;
00041     *qleft = *qhi = 1;
00042     return;
00043 S30:
00044     if(fbig >= 0.0e0) goto S40;
00045     *status = -1;
00046     *qleft = *qhi = 0;
00047     return;
00048 S40:
00049     goto S80;
00050 S50:
00051     if(fsmall >= 0.0e0) goto S60;
00052     *status = -1;
00053     *qleft = 1;
00054     *qhi = 0;
00055     return;
00056 S60:
00057     if(fbig <= 0.0e0) goto S70;
00058     *status = -1;
00059     *qleft = 0;
00060     *qhi = 1;
00061     return;
00062 S80:
00063 S70:
00064     *x = xsave;
00065     step = fifdmax1(absstp,relstp*fabs(*x));
00066 /*
00067       YY = F(X) - Y
00068      GET-FUNCTION-VALUE
00069 */
00070     i99999 = 3;
00071     goto S300;
00072 S90:
00073     yy = *fx;
00074     if(!(yy == 0.0e0)) goto S100;
00075     *status = 0;
00076     qok = 1;
00077     return;
00078 S100:
00079     qup = qincr && yy < 0.0e0 || !qincr && yy > 0.0e0;
00080 /*
00081 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00082      HANDLE CASE IN WHICH WE MUST STEP HIGHER
00083 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00084 */
00085     if(!qup) goto S170;
00086     xlb = xsave;
00087     xub = fifdmin1(xlb+step,big);
00088     goto S120;
00089 S110:
00090     if(qcond) goto S150;
00091 S120:
00092 /*
00093       YY = F(XUB) - Y
00094 */
00095     *x = xub;
00096 /*
00097      GET-FUNCTION-VALUE
00098 */
00099     i99999 = 4;
00100     goto S300;
00101 S130:
00102     yy = *fx;
00103     qbdd = qincr && yy >= 0.0e0 || !qincr && yy <= 0.0e0;
00104     qlim = xub >= big;
00105     qcond = qbdd || qlim;
00106     if(qcond) goto S140;
00107     step = stpmul*step;
00108     xlb = xub;
00109     xub = fifdmin1(xlb+step,big);
00110 S140:
00111     goto S110;
00112 S150:
00113     if(!(qlim && !qbdd)) goto S160;
00114     *status = -1;
00115     *qleft = 0;
00116     *qhi = !qincr;
00117     *x = big;
00118     return;
00119 S160:
00120     goto S240;
00121 S170:
00122 /*
00123 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00124      HANDLE CASE IN WHICH WE MUST STEP LOWER
00125 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00126 */
00127     xub = xsave;
00128     xlb = fifdmax1(xub-step,small);
00129     goto S190;
00130 S180:
00131     if(qcond) goto S220;
00132 S190:
00133 /*
00134       YY = F(XLB) - Y
00135 */
00136     *x = xlb;
00137 /*
00138      GET-FUNCTION-VALUE
00139 */
00140     i99999 = 5;
00141     goto S300;
00142 S200:
00143     yy = *fx;
00144     qbdd = qincr && yy <= 0.0e0 || !qincr && yy >= 0.0e0;
00145     qlim = xlb <= small;
00146     qcond = qbdd || qlim;
00147     if(qcond) goto S210;
00148     step = stpmul*step;
00149     xub = xlb;
00150     xlb = fifdmax1(xub-step,small);
00151 S210:
00152     goto S180;
00153 S220:
00154     if(!(qlim && !qbdd)) goto S230;
00155     *status = -1;
00156     *qleft = 1;
00157     *qhi = qincr;
00158     *x = small;
00159     return;
00160 S240:
00161 S230:
00162     dstzr(&xlb,&xub,&abstol,&reltol);
00163 /*
00164 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00165      IF WE REACH HERE, XLB AND XUB BOUND THE ZERO OF F.
00166 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
00167 */
00168     *status = 0;
00169     goto S260;
00170 S250:
00171     if(!(*status == 1)) goto S290;
00172 S260:
00173     dzror(status,x,fx,&xlo,&xhi,&qdum1,&qdum2);
00174     if(!(*status == 1)) goto S280;
00175 /*
00176      GET-FUNCTION-VALUE
00177 */
00178     i99999 = 6;
00179     goto S300;
00180 S280:
00181 S270:
00182     goto S250;
00183 S290:
00184     *x = xlo;
00185     *status = 0;
00186     return;
00187 DSTINV:
00188     small = *zsmall;
00189     big = *zbig;
00190     absstp = *zabsst;
00191     relstp = *zrelst;
00192     stpmul = *zstpmu;
00193     abstol = *zabsto;
00194     reltol = *zrelto;
00195     return;
00196 S300:
00197 /*
00198      TO GET-FUNCTION-VALUE
00199 */
00200     *status = 1;
00201     return;
00202 S310:
00203     switch((int)i99999){case 1: goto S10;case 2: goto S20;case 3: goto S90;case 
00204       4: goto S130;case 5: goto S200;case 6: goto S270;default: break;}
00205 #undef qxmon
00206 } /* END */