/*Translated by FOR_C, v3.4.2 (-), on 07/09/115 at 08:30:09 */ /*FOR_C Options SET: ftn=u io=c no=p op=aimnv s=dbov str=l x=f - prototypes */ #include #include "fcrt.h" #include "sintsm.h" #include /* 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 */ float /*FUNCTION*/ sintsm( float sxmin) { float sg, sintsm_v, smin, sqrttb, sx; /* Copyright (c) 1996 California Institute of Technology, Pasadena, CA. * ALL RIGHTS RESERVED. * Based on Government Sponsored Research NAS7-03001. *>> 1996-03-31 SINTSM Krogh Removed unused variable in common. *>> 1995-11-20 SINTSM Krogh Converted from SFTRAN to Fortran 77. *>> 1994-10-19 SINTSM Krogh Changes to use M77CON *>> 1994-07-07 SINTSM Snyder set up for CHGTYP. *>> 1994-07-05 SINTSM Snyder Corrected calculation *>> 1993-05-18 SINTSM Krogh -- Changed "END" to "END PROGRAM" *>> 1987-11-19 SINTSM Snyder Initial code. * *--S replaces "?": ?intc, ?intec, ?intnc, ?INTSM * * CALCULATE THE MINIMUM STEPSIZE TO USE IF ALOCAL WERE SET EQUAL TO * SXMIN. * * WRITE X = TA + (T-TA)**2/TB. IF WE LET X2 - X1 BE THE SMALLEST * ALLOWED STEP AT X1, SAY SMIN, THEN * TB*(X2-X1) = TB*SMIN = (T2-TA)**2 - (T1-TA)**2, OR * TB*SMIN = (T2-T1)*(T2-T1+2*(T1-TA)). SOLVING FOR T2-T1 PROVIDES * THE EXPRESSIONS IN THE CODE BELOW. THE ANALYSIS PROCEEDS * SIMILARLY WHEN X = TA + (T-TA)**4/TB**3. * */ /* ***** LOCAL VARIABLES ************************************ * * SG IS A TEMPORARY VARIABLE */ /* SMIN IS THE VALUE THAT WILL BE RETURNED AS THE MINIMUM STEPSIZE. */ /* SOLVE IS AN ARITHMETIC STATEMENT FUNCTION DEFINED BELOW. */ /* SQRTTB IS SQRT(ABS(TB)) */ /* SX IS A LOCAL COPY OF SXMIN. */ /* TDECR IS AN ARITHMETIC STATEMENT FUNCTION DEFINED BELOW. */ /* ***** COMMON VARIABLES *********************************** * * 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 DINTOP. THE MEANING ATTACHED TO THESE VARIABLES CAN BE * FOUND BY LOOKING AT THE DEFINITIONS IN DINTOP. */ /* ***** STATEMENT FUNCTIONS ******************************** * * SOLVE PROVIDES THE SOLUTION OF A QUADRATIC EQUATION. */ #define SOLVE(sx,sg) ((float)(sqrttb*(sx)/((sg)*sqrttb + sqrtf( fabsf( sintc.tb )*\ (sg)*(sg) + (sx) )))) /* TDECR IS USED TO TRANSFORM AN ABSCISSA FROM THE CURRENT COORDINATE * SYSTEM TO ONE IN WHICH NSUB IS DECREMENTED BY A FACTOR OF 2. * TDECR(SX)=TA+(SX-TA)*((SX-TA)/TB) */ #define TDECR(sx) ((float)(sintc.ta*(1.0 + sintc.ta/sintc.tb) + \ (sx)*(((sx) - sintc.ta)/sintc.tb - sintc.ta/sintc.tb))) /* ***** EXECUTABLE STATEMENTS ****************************** * */ sx = sxmin; if (sintc.nsub == 0) { sg = sx; } else { sg = TDECR( sx ); if (sintc.nsub != 2) sg = TDECR( sg ); } smin = sintec.edelm3*fmaxf( sintec.edelm1, fabsf( sg ) ); if (sintc.nsub != 0) { sqrttb = sqrtf( fabsf( sintc.tb ) ); sg = fabsf( (sx - sintc.ta)/sintc.tb ); smin = SOLVE( smin, sg ); if (sintc.nsub != 2) smin = SOLVE( smin, sg*sg ); } sintsm_v = smin; return( sintsm_v ); #undef TDECR #undef SOLVE } /* end of function */