/*Translated by FOR_C, v3.4.2 (-), on 07/09/115 at 08:32:04 */ /*FOR_C Options SET: ftn=u io=c no=p op=aimnv s=dbov str=l x=f - prototypes */ #include #include "fcrt.h" #include "sintma.h" #include #include /* PARAMETER translations */ #define DIMS 5 #define KDBLE 4 #define KINT 29 #define KLOG 11 #define KREAL 169 #define LTXTAB 9 #define LTXTAC 62 #define LTXTAD 164 #define MEEMES 52 #define MERET 51 /* end of PARAMETER translations */ /* COMMON translations */ struct t_sintnc { float 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; } sintnc; struct t_sintc { double acum, pacum, result[2]; float 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]; } sintc; struct t_sintec { float emeps, eepsm8, edelm2, edelm3, esqeps, ersqep, ersqe6, eminf, esmall, enzer, edelm1, eninf; } sintec; /* end of COMMON translations */ void /*FUNCTION*/ sintma( float *answer, float work[], long iflag[]) { static LOGICAL32 lsave[DIMS][KLOG]; long int idat[3], lc, nwork; static long int isave[DIMS][KINT]; static float rsave[DIMS][KREAL]; static double dsave[DIMS][KDBLE]; void dcopy(); static char mtxtaa[1][243]={"SINTMA$BNWORK = $I, needs to be at least $I, for NDIM = $I.$ESince you are using reverse communication you probably forgot to exit when IOPT(1) + NDIM was .le. 0$E$I = IFLAG($I) should$ be an inner integral dimension in the interval [1,$I].$E"}; static long mact[5]={MEEMES,88,0,0,MERET}; long int *const imove = (long*)&sintc.discf; LOGICAL32 *const lmove = (LOGICAL32*)&sintc.did1; float *const rmove = (float*)&sintc.aacum; /* OFFSET Vectors w/subscript range: 1 to dimension */ long *const Idat = &idat[0] - 1; long *const Iflag = &iflag[0] - 1; long *const Imove = &imove[0] - 1; LOGICAL32 *const Lmove = &lmove[0] - 1; long *const Mact = &mact[0] - 1; double *const Result = &sintc.result[0] - 1; float *const Rmove = &rmove[0] - 1; float *const Work = &work[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. *>> 2009-10-31 SINTMA Krogh Initialized ACUM,PACUM,RESULT(2). *>> 2008-01-11 SINTMA Krogh Added new error message. *>> 1996-03-31 SINTMA Krogh Removed unused variable in common. *>> 1995-11-20 SINTMA Krogh Converted from SFTRAN to Fortran 77. *>> 1995-11-16 SINTMA Krogh Corrected comment. *>> 1994-11-23 SINTMA Snyder Make recursion storage local *>> 1994-11-14 SINTMA Krogh Declared all vars. *>> 1994-10-19 SINTMA Krogh Changes to use M77CON *>> 1994-07-07 SINTMA Snyder set up for CHGTYP. *>> 1993-05-18 SINTMA Krogh Changed "END" to "END PROGRAM" *>> 1993-05-04 SINTMA Krogh Additions for Conversion to C. *>> 1992-04-09 SINTMA Krogh added error message processing. *>> 1991-09-20 SINTMA Krogh converted '(1)' dimensioning to '(*)'. *>> 1989-02-28 SINTMA Snyder Dimensioned MOVE *>> 1988-04-28 SINTMA Snyder Initial code. * * MULTIDIMENSIONAL QUADRATURE SUPERVISION PROGRAM. * *--S replaces "?": ?INTA,?INTC,?INTEC,?INTF,?INTM,?INTMA,?INTNC,?INTOP * * ***** M77CON INFORMATION ********************************* * * This program unit has two versions. One will use ?COPY to * store the entire common block /SINTC/ in WORK. This will work * in all environments where storage unit sizes follow the Fortran * standard: DOUBLE PRECISION uses twice as much storage as REAL, and * INTEGER and LOGICAL are the same size as real. This version is * selected by setting STORE = WORK. * * The other version has local SAVE arrays of types DOUBLE PRECISION, * REAL, INTEGER and LOGICAL, with enough space for DIMS+1 dimensions * of integration. The default for DIMS is 5. This version is * selected by setting STORE = LOCAL (or anything other than WORK). * * One cannot automatically derive an extended precision version that * stores in WORK. * *++ Default STORE = LOCAL * DON'T SET SW, DW or SL in M77JOB !!! *++ Default DW = {D} & STORE == WORK *++ Default SW = {S} & STORE == WORK *++ Default SL = ~(DW | SW) *++ Default DIMS = 5 * * ***** PARAMETERS ***************************************** * * The following apply to the case when STORE = LOCAL: */ /* DIMS is the number of dimensions for which to provide storage. * 1 + DIMS dimensions may be integrated. * KDBLE is the number of double precision cells to copy. * KINT is the number of integer cells to copy. * KLOG is the number of logical cells to copy. * KREAL is the number of real or double precision cells to copy. * */ /*++ Substitute for DIMS below */ /* KWORK IS THE AMOUNT OF WORKING STORAGE NEEDED FOR EVERY DIMENSION * OTHER THAN THE INNERMOST. THE TOTAL SIZE OF WORK MUST BE AT * LEAST 3*NDIMI + KWORK*(NDIMI-1). THE VALUE OF KWORK DEPENDS * ON THE MACHINE AND THE PRECISION OF THE PROGRAM, BUT FOR * PORTABILITY, THE USAGE SHOULD ALWAYS ASSUME THE WORST CASE FOR * EACH PRECISION. * *++ Code for ~SL is INACTIVE * INTEGER KWORK *++ Code for DW is INACTIVE * parameter ( KWORK = KDBLE + KREAL + (KINT+KLOG+1)/2 ) *++ Code for SW is INACTIVE * parameter ( KWORK = 2*KDBLE + KREAL + KINT + KLOG ) *++ End * * ***** FORMAL ARGUMENTS *********************************** * * ANSWER THE INTEGRAL OVER ALL DIMENSIONS WHEN THE INTEGRATION IS * COMPLETE. THE INTEGRAL OVER THE INNER DIMENSIONS WHEN * THE INTEGRATION IS IN PROGRESS. */ /* WORK WORKING STORAGE AS DESCRIBED IN SINTM. */ /* IFLAG INDICATES THE ACTION OR STATUS, AS DESCRIBED IN SINTM. */ /* ***** EXTERNAL REFERENCES ******************************** * *-- Begin mask code changes * DCOPY is used to copy DOUBLE PRECISION data. * D1MACH is used to get characteristics of DOUBLE PRECISION storage. * I1MACH is used to get characteristics of INTEGER storage. We assume * INTEGER and LOGICAL occupy the same amount of storage. * QCOPY is used to copy EXTENDED PRECISION data. * R1MACH is used to get characteristics of REAL storage. * SCOPY is used to copy REAL data. *-- End mask code changes * */ /*++ Code for SL & {XQ} is INACTIVE * external QCOPY *++ Code for SL & {SP} is ACTIVE */ /*++ Code for ~SL is INACTIVE *c--D Next line special: S => D, X => Q, D => D * double precision D1MACH *c--D Next line special: S => D, X => Q, D => D * external D1MACH * integer I1MACH * external I1MACH *++ Code for SW is INACTIVE * real R1MACH * external R1MACH *++ End * * ***** LOCAL VARIABLES ************************************ * * NWORK is the necessary amount of work space per dimension. */ /*++ Code for SL is ACTIVE * DSAVE is used to save variables that are DOUBLE PRECISION in all * versions. * ISAVE is used to save variables that are INTEGER. * LC is used for loop control. * LSAVE is used to save variables that are LOGICAL. * RSAVE is used to save variables that are REAL or DOUBLE PRECISION * depending on the version. * *--D Next line special: S => D, X => Q, D => D */ /*++ Code for ~SL is INACTIVE *c DROUND is the DOUBLE PRECISION round-off level. *c FIRST indicates whether the first call to SINTMA is in progress. *c IBIG is the biggest integer. *c RROUND is the REAL round-off level. *c--D Next line special: S => D, X => Q, D => D * double precision DROUND * logical FIRST * save FIRST * integer IBIG *++ Code for SW is INACTIVE * real RROUND *++ END * * ***** COMMON VARIABLES *********************************** * * MOVE IS EQUIVALENCED TO ACUM. MOVE IS USED TO PASS THE CORRECT * TYPE VARIABLE TO DCOPY, AND TO MAKE SINTC THE CORRECT * LENGTH. *++ Code for ~SL is INACTIVE * REAL MOVE(KWORK) *++ Code for SL is ACTIVE * DMOVE is equivalenced to ACUM, to save DOUBLE PRECISION variables. * IMOVE is equivalenced to DISCF, to save INTEGER variables. * LMOVE is equivalenced to DID1, to save LOGICAL variables. * RMOVE is equivalenced to AACUM, to save variables that are REAL * or DOUBLE PRECISION depending on the version. */ /*++ Code for SL & {XQ} is INACTIVE *c--D Next line special: S => D, X => Q, D => D, P => D * double precision DMOVE(KDBLE) *++ END * * THE VARIABLES BELOW ARE NOT SEPARATELY SAVED FOR EACH DIMENSION * OF THE INTEGRATION, OR ARE ONLY USED FOR THE MULTIDIMENSIONAL * QUADRATURE. SEE SINTA FOR DESCRIPTIONS OF VARIABLES NOT * EXPLAINED BELOW. * * ERRF IS THE ERROR COMMITTED ON AN INNER INTEGRAL. IT IS USED AS * THE ESTIMATED ERROR IN THE INTEGRAND FOR AN OUTER INTEGRAL. * FEA1 STORES THE VALUE OF FEA FOR THE INNER INTEGRAL. * FER1 STORES THE VALUE OF FER FOR THE INNER INTEGRAL. * IPRINT IS THE CURRENT DIAGNOSTIC PRINT LEVEL. SEE SINTA. * IXKDIM INDEX IN IFLAG (=IOPT) IN WHICH UNUSUAL DIMENSION CHANGES ARE * TO BE STORED. THIS IS SET BY OPTION 12, BUT THE DEFAULT IS 1. * JPRINT IS AN NDIM DIGIT INTEGER SPECIFYING ALL DIAGNOSTIC PRINT * LEVELS. THE LOW ORDER DIGIT IS FOR THE INNER DIMENSION. * SEE SINTM. * KDIM IS THE CURRENT DIMENSION. * NDIM IS THE NUMBER OF DIMENSIONS. * NFMAXM IS THE TOTAL NUMBER OF FUNCTION VALUES ALLOWED IN THE INNER * INTEGRAL. BY CONTRAST, NFMAX IS THE NUMBER OF FUNCTION VALUES * ALLOWED ON A SINGLE ITERATION OF THE INNER INTEGRAL. * NXKDIM INDEX-1 OF THE DIMENSION TO RESUME WHEN CALCULATION OF THE * INTEGRAL OVER THE CURRENT DIMENSION IS COMPLETE. NXKDIM IS * USUALLY KDIM, BUT MAY BE DIFFERENT IF THE USER MAKES UNUSUAL * DIMENSION CHANGES. * REVERM IS THE USERS SELECTION OF REVERSE COMMUNICATION. * REVERS IS THE REVERSE COMMUNICATION FLAG FOR SINTA. * WHEREM IS USED AS A COMPUTED GO TO INDEX IF REVERM IS NON-ZERO. * * COMMON /SINTNC/ CONTAINS VARIABLES NOT SEPARATELY SAVED FOR * EACH DIMENSION OF A MULTIPLE QUADRATURE. COMMON /SINTC/ * 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 /SINTC/. 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 /SINTNC/ VARIABLES. * */ /* DECLARATIONS OF COMMON /SINTC/ 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 SINTC. * 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 SINTOP. THE MEANING ATTACHED TO THESE VARIABLES CAN BE * FOUND BY LOOKING AT THE DEFINITIONS IN SINTOP. */ /* ***** EQUIVALENCE STATEMENTS ***************************** * *++ Code for ~SL is INACTIVE * EQUIVALENCE (ACUM, MOVE) *++ Code for SL is ACTIVE */ /*++ Code for SL & {XQ} is INACTIVE * equivalence (ACUM, DMOVE) *++ End * * ***** Statements for Processing Messages ********************** * */ /* ********* Error message text *************** *[Last 2 letters of Param. name] [Text generating message.] *AA SINTMA$B *AB NWORK = $I, needs to be at least $I, for NDIM = $I.$E *AC Since you are using reverse communication you probably $C * forgot to exit when IOPT(1) + NDIM was .le. 0$E *AD $I = IFLAG($I) should be an inner integral dimension $C * in the interval [1,$I].$E */ /* **** End of automatically generated text */ /* ***** DATA Statement ************************************* * *++ Code for ~SL is INACTIVE * data FIRST /.TRUE./ *++ End * * ***** PROCEDURES ***************************************** * */ if (sintnc.wherem != 0) { switch (sintnc.wherem) { case 1: goto L_90; case 2: goto L_75; case 3: goto L_30; } } /* OUTERMOST DIMENSION. * *++ Code for SL is ACTIVE */ nwork = 0; /*++ Code for ~SL is INACTIVE * if (first) then * first = .false. *c--D Next line special: S => D, X => Q, D => D * dround = d1mach(4) * ibig = i1mach(9) *++ Code for SW is INACTIVE * rround = r1mach(4) * if (rround .ge. 0.875*dround) then * nwork = kdble + kreal * else * nwork = 2*kdble + kreal * end if * if (ibig * rround .ge. 0.125) then * nwork = nwork + kint + klog * else * nwork = nwork + (kint + klog + 1) / 2 * end if *++ Code for DW is INACTIVE * if (ibig * dround .ge. 0.125) then * nwork = kdble + kreal + kint + klog * else * nwork = kdble + kreal + (kint + klog + 1) / 2 * end if * end if *++ End */ Idat[2] = nwork*(sintnc.ndim - 1) + 3*sintnc.ndim; if (sintnc.kdim < Idat[2]) { Iflag[1] = -sintnc.ndim - 3; if ((sintnc.reverm != 0) && (sintnc.kdim >= sintnc.ndim)) { Mact[4] = LTXTAC; } else { Mact[4] = LTXTAB; } Idat[1] = sintnc.kdim; Idat[3] = sintnc.ndim; goto L_118; } sintnc.kdim = sintnc.ndim; sintnc.fea1 = sintnc.fea; sintnc.fer1 = sintnc.fer; if (sintnc.nfindx != 0) Iflag[sintnc.nfindx] = 0; goto L_25; /* ASK FOR LIMITS OF THE KDIMTH DIMENSION. * */ L_20: sintc.taloc = 0; L_25: sintnc.wherem = 3; Iflag[1] = sintnc.kdim; Iflag[sintc.ixkdim] = sintnc.kdim; Work[1] = 1.0e0; sintc.errina = 0.0e0; sintc.errinb = 0.0e0; sintc.nfeval = 1; /* NFEVAL IS TESTED IN SINTOP. SINTF MAY CALL SINTOP. * Intialize ACUM,PACUM,RESULT(2) to avoid diagnostics. */ sintc.acum = 0.e0; sintc.pacum = 0.e0; Result[2] = 0.e0; if (sintnc.reverm != 0) return; sintf( answer, work, &Iflag[1] ); L_30: if (labs( Iflag[1] ) > sintnc.ndim) sintc.taloc = Iflag[1]; sintc.where = 0; if (sintnc.kdim != sintnc.ndim) { /* WE CAN USE EPS HERE BECAUSE SINTA WILL CHANGE IT BEFORE USE */ sintc.eps = fabsf( (Work[sintnc.ndim + sintnc.kdim + 1] - Work[2*sintnc.ndim + sintnc.kdim + 1])* Work[1] ); sintc.eps = fmaxf( sintc.eps, fmaxf( sintc.epso*sintec.esmall, sintec.esmall ) ); sintc.epso /= sintc.eps; if (labs( Iflag[1] ) <= sintnc.ndim && Iflag[sintc.ixkdim] <= sintnc.ndim) { if (Iflag[sintc.ixkdim] < 1 || Iflag[sintc.ixkdim] > sintnc.kdim) goto L_115; /* INNER DIMENSION MAY BE LESS THAN EXPECTED. */ sintnc.kdim = Iflag[sintc.ixkdim]; } } L_50: sintnc.iprint = (sintnc.jprint/ipow(10,sintnc.kdim - 1))%10; sintnc.ainit = Work[sintnc.ndim + sintnc.kdim]; sintnc.binit = Work[2*sintnc.ndim + sintnc.kdim]; if (sintnc.kdim == 1) { sintnc.fea = sintnc.fea1; sintnc.fer = sintnc.fer1; if (sintnc.nfindx != 0) sintc.nfeval = Iflag[sintnc.nfindx]; sintnc.nfmax = sintnc.nfmaxm; sintnc.revers = sintnc.reverm; } else { sintnc.fea = 1; sintnc.fer = sintec.emeps; /* FER=EFERVL * EFERVL was EMEPS in single precision, and 8*EMEPS in double */ sintnc.nfmax = 0; sintnc.revers = 1; } Iflag[1] = 0; /* TEST IFLAG(1) IN CASE REVERSE COMMUNICATION IS IN EFFECT, AND THE * CALLING PROGRAM IS ITERATING CALLS TO SINTA. */ L_75: if (Iflag[1] < 0) goto L_80; sinta( answer, &Work[1], iflag ); switch (IARITHIF(Iflag[1])) { case -1: goto L_80; case 0: goto L_100; case 1: goto L_110; } /* FINISHED WITH INTEGRAL OF KDIMTH DIMENSION. * */ L_80: if (sintnc.kdim == sintnc.ndim) goto L_120; L_85: sintnc.wherem = 1; Iflag[1] = -sintnc.kdim; Iflag[sintc.ixkdim] = -sintnc.kdim; if (sintnc.reverm != 0) return; sintf( answer, work, &Iflag[1] ); /* ***** ITERATE ON INNER INTEGRALS IF NECESSARY HERE ******* */ L_90: ; sintnc.kdim = sintc.nxkdim; if (Iflag[sintc.ixkdim] >= 0) { if (Iflag[sintc.ixkdim] > sintc.nxkdim) goto L_115; sintnc.kdim = Iflag[sintc.ixkdim]; /* INTEGRAND IS A FUNCTION OF MORE INTEGRALS. */ goto L_20; } /*++ Code for DW is INACTIVE * CALL DCOPY (KWORK,WORK(3*NDIM+KWORK*KDIM-KWORK+1),1,MOVE,1) *++ Code for SW is INACTIVE * CALL SCOPY (KWORK,WORK(3*NDIM+KWORK*KDIM-KWORK+1),1,MOVE,1) *++ Code for SL & {XQ} is INACTIVE * call qcopy (kdble, dsave(1,kdim), 1, dmove, 1) *++ Code for SL & (~{XQ}) is ACTIVE */ sintc.acum = dsave[sintnc.kdim - 1][0]; sintc.pacum = dsave[sintnc.kdim - 1][1]; Result[1] = dsave[sintnc.kdim - 1][2]; Result[2] = dsave[sintnc.kdim - 1][3]; /*++ Code for SL & {Q} is INACTIVE * call qcopy (kreal, rsave(1,kdim), 1, rmove, 1) *++ Code for SL & {XD} is INACTIVE * call dcopy (kreal, rsave(1,kdim), 1, rmove, 1) *++ Code for SL & {PS} is ACTIVE */ scopy( KREAL, &rsave[sintnc.kdim - 1][0], 1, rmove, 1 ); /*++ Code for SL is ACTIVE */ for (lc = 1; lc <= KINT; lc++) { Imove[lc] = isave[sintnc.kdim - 1][lc - 1]; } for (lc = 1; lc <= KLOG; lc++) { Lmove[lc] = lsave[sintnc.kdim - 1][lc - 1]; } /*++ End */ sintnc.kdim += 1; goto L_50; /* NEED A FUNCTION VALUE FOR THE KDIMTH DIMENSION. * */ L_100: sintnc.wherem = 2; if (sintnc.kdim == 1) return; sintnc.kdim -= 1; /*++ Code for DW is INACTIVE * CALL DCOPY (KWORK,MOVE,1,WORK(3*NDIM+KWORK*KDIM-KWORK+1),1) *++ Code for SW is INACTIVE * CALL SCOPY (KWORK,MOVE,1,WORK(3*NDIM+KWORK*KDIM-KWORK+1),1) *++ Code for SL & {XQ} is INACTIVE * call qcopy (kdble, dmove, 1, dsave(1,kdim), 1) *++ Code for SL & (~{XQ}) is ACTIVE */ dsave[sintnc.kdim - 1][0] = sintc.acum; dsave[sintnc.kdim - 1][1] = sintc.pacum; dsave[sintnc.kdim - 1][2] = Result[1]; dsave[sintnc.kdim - 1][3] = Result[2]; /*++ Code for SL & {Q} is INACTIVE * call qcopy (kreal, rmove, 1, rsave(1,kdim), 1) *++ Code for SL & {XD} is INACTIVE * call dcopy (kreal, rmove, 1, rsave(1,kdim), 1) *++ Code for SL & {PS} is ACTIVE */ scopy( KREAL, rmove, 1, &rsave[sintnc.kdim - 1][0], 1 ); /*++ Code for SL is ACTIVE */ for (lc = 1; lc <= KINT; lc++) { isave[sintnc.kdim - 1][lc - 1] = Imove[lc]; } for (lc = 1; lc <= KLOG; lc++) { lsave[sintnc.kdim - 1][lc - 1] = Lmove[lc]; } /*++ End */ sintc.nxkdim = sintnc.kdim; goto L_20; /* ERROR. * */ L_110: ; if (sintnc.kdim != sintnc.ndim) { if (Iflag[1] == 6) { /* NON-INTEGRABLE SINGULARITY IN INNER INTEGRAL. USE ALMOST * MACHINE INFINITY WITH THE SIGN OF ACUM FOR THE ANSWER, AND * ALMOST MACHINE INFINITY FOR THE ERROR ESTIMATE. * THE "SIGN" FUNCTION WANTS ITS ARGUMENTS TO BE THE SAME TYPE. */ *answer = sintc.acum; *answer = signf( sintec.eninf, *answer ); Work[1] = sintec.eninf; goto L_85; } } sintnc.wherem = 2; if (Iflag[1] != 5) sintnc.wherem = 0; Iflag[1] = -sintnc.ndim - Iflag[1]; goto L_130; /* ERRONEOUS INNER INTEGRAL DIMENSIONALITY. * */ L_115: Mact[4] = LTXTAD; Idat[3] = sintnc.kdim; Idat[2] = sintc.ixkdim; Idat[1] = Iflag[sintc.ixkdim]; Iflag[1] = -sintnc.ndim - sintnc.ndim - sintnc.kdim - 5; /* Print an error message and stop. */ L_118: Mact[3] = Iflag[1]; mess( mact, (char*)mtxtaa,243, idat ); goto L_130; /* NORMAL COMPLETION. * */ L_120: Iflag[1] = -(sintnc.ndim - (Iflag[1] + 1)); sintnc.wherem = 0; L_130: ; return; } /* end of function */