/*Translated by FOR_C, v3.4.2 (-), on 07/09/115 at 08:30:52 */ /*FOR_C Options SET: ftn=u io=c no=p op=aimnv s=dbov str=l x=f - prototypes */ #include #include "fcrt.h" #include "dintns.h" #include /* COMMON translations */ struct t_dintnc { double ainit, binit, fncval, s, tp, fer, fer1, relobt, tps, xj, xjp; long int fea, fea1, kdim, inc, inc2, istop[2][2], jprint, iprint, kk, kmaxf, ndim, nfindx, nfmax, nfmaxm, reltol, reverm, revers, wherem; LOGICAL32 needh; } dintnc; struct t_dintc { double acum, pacum, result[2], aacum, local[4], abscis, ta, delta, delmin, diff, discx[2], end[2], errina, errinb, fat[2], fsave, funct[24], f2, paacum, pf1, pf2, phisum, phtsum, px, space[6], step[2], start[2], sum, t, tasave, tb, tend, worry[2], x1, x2, x, f1, count, xt[17], ft[17], phi[34], absdif, edue2a, edue2b, ep, epnoiz, epsmax, epso, epsr, epss, errat[2], errc, errf, errt[2], esold, extra, pepsmn, releps, rep, rndc, tlen, xjump, erri, err, epsmin, eps, re, reprod; long int discf, dischk, endpts, inew, iold, ip, ixkdim, j, j1, j1old, j2, j2old, kmax, kmin, l, lendt, nfjump, nsubsv, nxkdim, taloc, where2, i, k, kaimt, nsub, part, search, where, nfeval; LOGICAL32 did1, fail, fats[2], fsaved, havdif, iend, init, roundf, xcdobt[2], pad[7]; } dintc; struct t_dintec { double emeps, eepsm8, edelm2, edelm3, esqeps, ersqep, ersqe6, eminf, esmall, enzer, edelm1, eninf; } dintec; /* end of COMMON translations */ void /*FUNCTION*/ dintns( long jumpto) { double zl1; double *const alocal = (double*)dintc.local; double *const blocal = (double*)((double*)dintc.local + 1); LOGICAL32 *const fatas = (LOGICAL32*)dintc.fats; LOGICAL32 *const fatbs = (LOGICAL32*)((LOGICAL32*)dintc.fats + 1); /* OFFSET Vectors w/subscript range: 1 to dimension */ double *const End = &dintc.end[0] - 1; double *const Start = &dintc.start[0] - 1; double *const Step = &dintc.step[0] - 1; double *const Worry = &dintc.worry[0] - 1; /* end of OFFSET VECTORS */ /* Copyright (c) 1996 California Institute of Technology, Pasadena, CA. * ALL RIGHTS RESERVED. * Based on Government Sponsored Research NAS7-03001. *>> 1996-03-31 DINTNS Krogh Removed unused variable in common. *>> 1996-03-30 DINTNS Krogh Change specific intrinsics to generics. *>> 1995-11-20 DINTNS Krogh Converted from SFTRAN to Fortran 77. *>> 1994-11-14 DINTNS Krogh Declared all vars. *>> 1994-10-19 DINTNS Krogh Changes to use M77CON *>> 1994-07-07 DINTNS Snyder set up for CHGTYP. *>> 1993-05-18 DINTNS Krogh -- Changed "END" to "END PROGRAM" *>> 1987-11-19 DINTNS Snyder Initial code. * * REDUCE OR INCREASE NSUB, DEPENDING ON JUMPTO. VALUES OF JUMPTO * ARE GIVEN BY THE PARAMETERS NSRA, NSRB, NSIA, NSIB IN DINTA. * *--D replaces "?": ?INTA, ?INTC, ?INTEC, ?INTNC, ?INTNS, ?INTSM * * ***** EXTERNAL REFERENCES ******************************** * * DINTSM TO CALCULATE THE MINIMUM STEPSIZE. */ /* ***** LOCAL VARIABLES ************************************ * * TDECR IS AN ARITHMETIC STATEMENT FUNCTION DEFINED BELOW. */ /* TINCR IS AN ARITHMETIC STATEMENT FUNCTION DEFINED BELOW. */ /* ZL1 IS AN ARGUMENT OF ARITHMETIC STATEMENT FUNCTIONS. */ /* ***** COMMON VARIABLES *********************************** * * ALOCAL IS EQUIVALENT TO /DINTC/ LOCAL(1). * BLOCAL IS EQUIVALENT TO /DINTC/ LOCAL(2). */ /* FATAS, FATBS * ARE EQUIVALENCED TO FATS. */ /* COMMON /DINTNC/ CONTAINS VARIABLES NOT SEPARATELY SAVED FOR * EACH DIMENSION OF A MULTIPLE QUADRATURE. COMMON /DINTC/ * CONTAINS VARIABLES THAT MUST BE SAVED FOR EACH DIMENSION OF THE * QUADRATURE. THE VARIABLES IN EACH COMMON BLOCK ARE STORED IN THE * ORDER - ALWAYS DOUBLE, DOUBLE IF DOUBLE PRECISION PROGRAM, DOUBLE * IF DOUBLE PRECISION PROGRAM AND EXPONENT RANGE OF DOUBLE AND * SINGLE VERY DIFFERENT, SINGLE, INTEGER, LOGICAL. A PAD OF LOGICAL * VARIABLES IS INCLUDED AT THE END OF /DINTC/. THE DIMENSION OF * THE PAD MAY NEED TO BE VARIED SO THAT NO VARIABLES BEYOND THE END * OF THE COMMON BLOCK ARE ALTERED. * * DECLARATIONS OF COMMON /DINTNC/ VARIABLES. * */ /* DECLARATIONS OF COMMON /DINTC/ VARIABLES. * *--D Next line special: S => D, X => Q, D => D, P => D */ /* 139 $.TYPE.$ VARIABLES */ /* Note XT, FT, and PHI above are last, because they must be in adjacent * locations in DINTC. * 30 $DSTYP$ VARIABLES */ /* 29 INTEGER VARIABLES */ /* 11 TO 18 LOGICALS (7 ARE PADDING). */ /* THE COMMON BLOCKS. * */ /* 1 2 3 4 5 6 7 8 * 9 10 11 12 13 1 2 3 * 4 (2,2) 8 9 10 11 12 13 14 * 15 16 17 18 19 20 */ /* 1 2 (4) 6 7 8 9 10 11 (2) * 13 (2) 15 16 17 (2) 19 20 (24) 44 * 45 46 47 48 49 50 51 (6) * 57 (2) 59 (2) 61 62 63 64 65 * 66 (2) 68 69 70 71 72 * 73 (17) 90 (17) 107 (34) */ /* 141 142 143 144 145 146 * 147 148 149 150 (2) 152 153 * 154 (2) 156 157 158 159 160 * 161 162 163 * 164 165 166 167 168 169 */ /* 170 171 172 * 1 2 3 4 5 6 7 8 */ /* THE VARIABLES HERE DEFINE THE MACHINE ENVIRONMENT. ALL ARE SET * IN DINTOP. THE MEANING ATTACHED TO THESE VARIABLES CAN BE * FOUND BY LOOKING AT THE DEFINITIONS IN DINTOP. */ /* ***** EQUIVALENCE STATEMENTS ***************************** * */ /* ***** STATEMENT FUNCTIONS ******************************** * * TDECR IS USED TO TRANSFORM AN ABSCISSA FROM THE CURRENT COORDINATE * SYSTEM TO ONE IN WHICH NSUB IS DECREMENTED BY A FACTOR OF 2. */ #define TDECR(zl1) ((double)(dintc.ta + ((zl1) - dintc.ta)*(((zl1) - \ dintc.ta)/dintc.tb))) /* TINCR IS USED TO TRANSFORM AN ABSCISSA FROM THE CURRENT COORDINATE * SYSTEM TO ONE IN WHICH NSUB IS INCREMENTED BY A FACTOR OF 2. */ #define TINCR(zl1) ((double)(dintc.ta + sign( sqrt( fabs( dintc.tb*\ ((zl1) - dintc.ta) ) ), dintc.tb ))) /* ***** EXECUTABLE STATEMENTS ****************************** * */ switch (jumpto) { case 1: goto L_2670; case 2: goto L_2680; case 3: goto L_2690; case 4: goto L_2700; } /* REDUCE NSUB * */ L_2670: *blocal = TDECR( *blocal ); L_2680: *alocal = TDECR( *alocal ); Worry[dintc.part] = TDECR( Worry[dintc.part] ); dintc.abscis = TDECR( Start[dintc.part] + sign( Step[dintc.part], dintc.tb ) ); Start[dintc.part] = TDECR( Start[dintc.part] ); dintc.nsub = 2*(dintc.nsub/4); goto L_2710; /* INCREASE NSUB * */ L_2690: *blocal = TINCR( *blocal ); L_2700: *alocal = TINCR( *alocal ); Worry[dintc.part] = TINCR( Worry[dintc.part] ); dintc.abscis = TINCR( Start[dintc.part] + sign( Step[dintc.part], dintc.tb ) ); Start[dintc.part] = TINCR( Start[dintc.part] ); dintc.nsub = max( dintc.nsub + dintc.nsub, 2 ); L_2710: dintc.fsaved = FALSE; *fatas = FALSE; *fatbs = FALSE; dintc.endpts = 1; Step[dintc.part] = sign( dintc.abscis - Start[dintc.part], Step[dintc.part] ); dintc.delta = fabs( *blocal - *alocal ); dintc.absdif = 0.5e0*dintc.delta; dintc.tlen = fabs( End[1] - Start[1] ); if (dintc.part == 2) dintc.tlen += fabs( End[2] - Start[2] ); if (dintc.dischk == 0) dintc.dischk = -1; dintc.delmin = dintsm( *alocal ); return; #undef TINCR #undef TDECR } /* end of function */