/*Translated by FOR_C, v3.4.2 (-), on 07/09/115 at 08:30:55 */ /*FOR_C Options SET: ftn=u io=c no=p op=aimnv s=dbov str=l x=f - prototypes */ #include #include "fcrt.h" #include "sintop.h" #include #include #include /* PARAMETER translations */ #define LTXTAB 7 #define LTXTAC 62 #define MEEMES 52 #define MEIVEC 57 #define MEMDA1 27 #define MEMDA2 28 #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*/ sintop( long iopt[], float work[]) { long int _l0, ii, jj; static char mtxtaa[1][126]={"SINT$BLast value is IOPT specfies bad option, IOPT(1:$M) = $BOption $M, can not be changed while integrating, IOPT(1:$M) = $B"}; static long mact[11]={MEMDA1,0,MEMDA2,0,MEEMES,77,4,0,MEIVEC,0, MERET}; static long ichg[13]={1,1,0,0,0,1,1,1,1,0,1,1,0}; /* OFFSET Vectors w/subscript range: 1 to dimension */ long *const Ichg = &ichg[0] - 1; long *const Iopt = &iopt[0] - 1; long *const Mact = &mact[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. *>> 2000-12-01 SINTOP Krogh Removed unused variable MENTXT. *>> 1996-03-31 SINTOP Krogh Removed unused variable in common. *>> 1996-03-30 SINTOP Krogh Added external statement. *>> 1995-11-20 SINTOP Krogh Converted from SFTRAN to Fortran 77. *>> 1994-11-14 SINTOP Krogh Declared all vars. *>> 1994-10-19 SINTOP Krogh Changes to use M77CON *>> 1994-08-15 SINTOP Snyder corrected mixed types in MAX and MIN *>> 1994-07-07 SINTOP Snyder set up for CHGTYP. *>> 1993-05-18 SINTOP Krogh -- Changed "END" to "END PROGRAM" *>> 1993-04-29 SINTOP Krogh Additions for Conversion to C. *>> 1992-03-03 SINTOP Krogh added error messages. *>> 1991-09-20 SINTOP Krogh converted '(1)' dimensioning to '(*)'. *>> 1987-12-07 SINTOP Snyder Initial code. * *--S replaces "?": ?INT, ?INT1, ?intc, ?intec, ?INTM, ?INTNC, ?INTOP * * ****************************************************************** * * THIS SUBROUTINE IS USED TO SPECIFY OPTIONS FOR SINT1 AND SINTM. * IT IS CALLED BY SINT1 AND SINTM. IT MAY ALSO BE CALLED * BY THE USER DURING THE INTEGRATION TO CHANGE A RESTRICTED * SET OF THE OPTIONS. IF IT IS CALLED WITH NFEVAL = 0, IT IS * ASSUMED THAT THE CALL CAME FROM SINT1 OR SINTM. IN * THIS CASE, ALL OPTIONS ARE FIRST SET TO THEIR DEFAULT VALUES. * IF IT IS CALLED WITH NFEVAL .NE. 0, IT IS ASSUMED THAT THE * CALL CAME DIRECTLY FROM THE USER. IN THIS CASE, ONLY A SUBSET * OF THE OPTIONS MAY BE CHANGED. THE OPTIONS THAT MAY BE CHANGED * DO NOT REFER TO THE WORK VECTOR. THUS WORK IS IN THIS CASE A * DUMMY ARGUMENT. THE OPTIONS THAT MAY BE CHANGED CORRESPOND TO * NON-ZERO ELEMENTS OF THE VECTOR ICHG. * SEE SINT1 OR SINTM FOR A DESCRIPTION OF THE OPTIONS. * * ***** FORMAL ARGUMENTS *********************************** * * IOPT IS THE OPTION VECTOR (SEE SINT1 OR SINTM). */ /* WORK IS THE WORK VECTOR (SEE SINT1 OR SINTM). */ /* ***** EXTERNAL REFERENCES ******************************** * * R1MACH FETCHES MACHINE PARAMETERS. */ /* ***** LOCAL VARIABLES ************************************* * * ICHG A VECTOR DEFINING WHICH OPTIONS MAY BE CHANGED WHEN NFEVAL * IS NON-ZERO. */ /* II JJ INDICES. */ /* ***** COMMON STORAGE ****************************************** * * 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. */ /* ***** Statements for Processing Messages ********************** * */ /* ********* Error message text ***************************** *[Last 2 letters of Param. name] [Text generating message.] *AA SINT$B *AB Last value is IOPT specfies bad option, IOPT(1:$M) = $B *AC Option $M, can not be changed while integrating, IOPT(1:$M) = $B */ /* 1 2 3 4 5 6 7 8 9 10 11 */ /* ***** DATA STATEMENTS *************************************** * */ /* ***** PROCEDURES ****************************************** * * * SET OPTIONS TO DEFAULT VALUES. * */ Iopt[1] = 0; if (sintc.nfeval == 0) { sintec.emeps = FLT_EPSILON; sintec.eminf = FLT_MAX; sintec.esmall = 2.0*fmaxf( FLT_MIN, 1.0/sintec.eminf ); sintec.edelm1 = sintec.esmall/sintec.emeps; sintec.edelm2 = 202.48; sintec.edelm3 = sintec.emeps*sintec.edelm2; sintec.eepsm8 = 8.0*sintec.emeps; sintec.eninf = 0.001*sintec.eminf; sintec.enzer = 50.0*sintec.esmall; sintec.esqeps = sqrtf( sintec.emeps ); sintec.ersqep = 1.0/sintec.esqeps; sintec.ersqe6 = 0.001*sintec.ersqep; sintc.epso = 0.0; sintc.errina = 0.0; sintc.errinb = 0.0; sintnc.fea = 0; /* FER=EFERVL * EFERVL was EMEPS in single precision, and 8*EMEPS in double */ sintnc.fer = sintec.emeps; sintnc.kmaxf = 3; sintnc.nfindx = 0; sintnc.relobt = 0.75; sintnc.reltol = 0; sintc.taloc = 0; if (sintnc.ndim != 1) { sintnc.jprint = 1; for (ii = 2; ii <= sintnc.ndim; ii++) { sintnc.jprint = 10*sintnc.jprint + 1; } sintnc.reverm = 0; sintnc.nfmaxm = 0; sintc.ixkdim = 1; } else { sintnc.iprint = 1; sintnc.revers = 0; sintnc.nfmax = 0; } } /* SET OPTIONS SPECIFIED IN THE OPTION VECTOR. * */ ii = 2; /* DO BLOCK * DO FOREVER */ L_20: ; jj = Iopt[ii]; if (jj == 0) goto L_300; if (jj < 0 || jj > 13) { Mact[2] = ii; Mact[8] = LTXTAB; goto L_320; } if (sintc.nfeval != 0) { if (Ichg[jj] == 0) { Mact[2] = jj; Mact[4] = ii; Mact[8] = LTXTAC; goto L_320; } } /* DO CASE (JJ,13) */ switch (jj) { case 1: goto L_110; case 2: goto L_120; case 3: goto L_130; case 4: goto L_140; case 5: goto L_150; case 6: goto L_160; case 7: goto L_170; case 8: goto L_180; case 9: goto L_190; case 10: goto L_200; case 11: goto L_210; case 12: goto L_220; case 13: goto L_230; } /* CASE 1 * No longer used. */ L_110: ; goto L_290; /* CASE 2 */ L_120: ; if (sintnc.ndim == 1) { sintnc.iprint = Iopt[ii + 1]; } else { sintnc.jprint = Iopt[ii + 1]; if (sintc.nfeval != 0) sintnc.iprint = (sintnc.jprint/ipow(10,sintnc.kdim - 1))% 10; } goto L_290; /* CASE 3 */ L_130: ; sintnc.reltol = Iopt[ii + 1]; sintc.epso = Work[sintnc.reltol]; sintnc.relobt = 1.0e0 - fmaxf( 0.0e0, fminf( 1.0e0, Work[sintnc.reltol + 1] ) ); goto L_290; /* CASE 4 */ L_140: ; sintnc.fea = Iopt[ii + 1]; goto L_290; /* CASE 5 */ L_150: ; jj = Iopt[ii + 1]; /* FER=MAX(EFERVL,WORK(JJ)) * EFERVL was EMEPS in single precision, and 8*EMEPS in double */ sintnc.fer = fmaxf( sintec.emeps, Work[jj] ); goto L_290; /* CASE 6 */ L_160: ; sintnc.reverm = 1; sintnc.revers = 1; ii -= 1; goto L_290; /* CASE 7 */ L_170: ; sintnc.kmaxf = max( 3, min( 8, Iopt[ii + 1] ) ); goto L_290; /* CASE 8 */ L_180: ; goto L_290; /* CASE 9 */ L_190: ; sintnc.nfmaxm = Iopt[ii + 1]; sintnc.nfmax = sintnc.nfmaxm; goto L_290; /* CASE 10 */ L_200: ; sintnc.nfindx = ii + 1; goto L_290; /* CASE 11 */ L_210: ; sintc.taloc = Iopt[ii + 1]; goto L_290; /* CASE 12 */ L_220: ; sintc.errina = Work[Iopt[ii + 1]]; sintc.errinb = Work[Iopt[ii + 1] + 1]; goto L_290; /* CASE 13 */ L_230: ; sintc.ixkdim = ii + 1; /* END CASE */ L_290: ii += 2; goto L_20; L_300: ; /* END FOREVER */ return; L_320: ; /* END BLOCK */ Mact[10] = ii; Iopt[1] = 4; mess( mact, (char*)mtxtaa,126, iopt ); return; } /* end of function */