/*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 "sintdu.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 */ void /*FUNCTION*/ sintdu() { float epscor; float *const fata = (float*)sintc.fat; float *const fatb = (float*)((float*)sintc.fat + 1); float *const phit = (float*)((float*)sintc.phi + 17); /* OFFSET Vectors w/subscript range: 1 to dimension */ float *const Ft = &sintc.ft[0] - 1; float *const Phi = &sintc.phi[0] - 1; float *const Phit = &phit[0] - 1; float *const Xt = &sintc.xt[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. *>> 2007-03-28 SINTDU Snyder Don't look at XT(0) or FT(0) *>> 2007-03-28 SINTDU Krogh l .le. 0 changed to l .le. 1 *>> 1996-03-31 SINTDU Krogh Removed unused variable in common. *>> 1995-11-20 SINTDU Krogh Converted from SFTRAN to Fortran 77. *>> 1994-10-19 SINTDU Krogh Changes to use M77CON *>> 1994-08-19 SINTDU Snyder correct "middle" that's really at alocal *>> 1994-07-07 SINTDU Snyder set up for CHGTYP. *>> 1993-05-18 SINTDU Krogh -- Changed "END" to "END PROGRAM" *>> 1987-11-20 SINTDU Snyder Initial code. * * THIS SUBROUTINE UPDATES DIFFERENCE LINES FOR SINTA DURING * THE SEARCHES. * *--S replaces "?": ?INTA, ?intc, ?INTDU, ?intec, ?intnc * * ***** INTERNAL AND COMMON VARIABLES ************************ * * EPSCOR IS A CORRECTION TO BE ADDED ONTO EPSMIN. */ /* FATA THE FUNCTION VALUE AT THE ALOCAL END OF THE INTERVAL. * FATB THE FUNCTION VALUE AT THE BLOCAL END OF THE INTERVAL. */ /* PHIT IS THE BACKWARD DIFFERENCE LINE. */ /* ***** 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 DINTOP. THE MEANING ATTACHED TO THESE VARIABLES CAN BE * FOUND BY LOOKING AT THE DEFINITIONS IN DINTOP. */ /* ***** EQUIVALENCE STATEMENTS ******************************* * */ /* ***** PROCEDURES ****************************************** * */ switch (IARITHIF(sintc.where - 5)) { case -1: goto L_200; case 0: goto L_40; case 1: goto L_10; } /* UPDATE BY ADDING A FUNCTION VALUE IN THE MIDDLE. * */ L_10: sintc.havdif = FALSE; if (sintc.nfeval > sintc.nfjump + 6) { if (sintc.l <= 1) goto L_70; sintc.where = 0; sintc.l = min( sintc.l, sintc.lendt + 1 ); if (sintc.l >= sintc.lendt + 1) goto L_180; sintc.i = sintc.lendt; epscor = 0.5e0*(-fabsf( Xt[sintc.l - 1]*(Ft[sintc.l] - Ft[sintc.l - 1]) ) + fabsf( Xt[sintc.l - 1]*(sintnc.fncval - Ft[sintc.l - 1]) ) + fabsf( sintc.x*(Ft[sintc.l] - sintnc.fncval) )); epscor *= sintec.emeps; epscor += fabsf( sintnc.fncval*sintc.rndc*(Xt[sintc.l] - Xt[sintc.l - 1]) ); if (sintnc.fea != 0) epscor += fabsf( 0.5e0*sintc.errf*(Xt[sintc.l] - Xt[sintc.l - 1]) ); sintc.epsmin += fmaxf( epscor, 0.0e0 ); /* DO FOREVER */ L_20: ; Xt[sintc.i + 1] = Xt[sintc.i]; Ft[sintc.i + 1] = Ft[sintc.i]; if (sintc.i == sintc.l) goto L_180; sintc.i -= 1; goto L_20; /* END FOREVER */ } switch (IARITHIF(sintc.l - sintc.lendt - 1)) { case -1: goto L_80; case 0: goto L_50; case 1: goto L_50; } /* UPDATE BY ADDING A FUNCTION VALUE ON THE BLOCAL END. * */ L_40: if (sintc.where2 == 1) goto L_70; sintnc.fncval = *fatb; sintc.l = sintc.lendt + 1; /* ADD ONE AT THE BLOCAL END */ L_50: Phit[sintc.l] = sintnc.fncval; sintnc.tp = 1.0e0; Phit[sintc.lendt] = sintnc.fncval - Phit[sintc.lendt]; sintc.i = sintc.lendt; L_60: sintnc.tp *= (sintc.x - Xt[sintc.i])/(Xt[sintc.lendt] - Xt[sintc.i - 1]); Phit[sintc.i - 1] = Phit[sintc.i] - sintnc.tp*Phit[sintc.i - 1]; sintc.i -= 1; if (sintc.i >= 2) goto L_60; goto L_140; /* UPDATE BY ADDING A FUNCTION VALUE ON THE ALOCAL END. * */ L_70: sintnc.fncval = *fata; sintc.l = 1; /* ADD ONE IN THE MIDDLE OR AT THE ALOCAL END. */ L_80: sintc.i = sintc.lendt; sintnc.tp = Phit[sintc.i] - sintnc.fncval; sintnc.s = Xt[sintc.i] - sintc.x; /* DO FOREVER */ L_90: ; Xt[sintc.i + 1] = Xt[sintc.i]; Ft[sintc.i + 1] = Ft[sintc.i]; Phit[sintc.i + 1] = Phit[sintc.i]; Phi[sintc.i + 1] = Phi[sintc.i]; sintc.i -= 1; if (sintc.i < sintc.l) goto L_100; sintnc.tp += (sintnc.s/(sintc.x - Xt[sintc.i]))*(sintnc.tp - Phit[sintc.i]); goto L_90; /* END FOREVER */ L_100: ; Phit[sintc.l] = sintnc.tp; if (sintc.l == 1) { /* ADD ONE AT THE ALOCAL END. */ Phi[1] = sintnc.fncval; sintnc.tp = 1.0e0; Phi[2] = sintnc.fncval - Phi[2]; sintc.i = 2; L_110: sintnc.tp *= (sintc.x - Xt[sintc.i])/(Xt[1] - Xt[sintc.i + 1]); Phi[sintc.i + 1] = Phi[sintc.i] - sintnc.tp*Phi[sintc.i + 1]; sintc.i += 1; if (sintc.i <= sintc.lendt) goto L_110; goto L_180; } /* UPDATE PHIT FOR ADDING ONE IN THE INTERIOR. */ sintc.i = sintc.l - 1; L_130: Phit[sintc.i] = Phit[sintc.i + 1] + (sintnc.s/(sintc.x - Xt[sintc.i]))* (Phit[sintc.i + 1] - Phit[sintc.i]); sintc.i -= 1; if (sintc.i > 0) goto L_130; /* UPDATE PHI FOR ADDING ONE IN THE INTERIOR OR AT THE BLOCAL END. */ L_140: sintnc.tp = Phi[1] - sintnc.fncval; sintnc.s = Xt[1] - sintc.x; sintc.i = 2; if (sintc.l != 2) { L_150: sintnc.tp += (sintnc.s/(sintc.x - Xt[sintc.i]))*(sintnc.tp - Phi[sintc.i]); sintc.i += 1; if (sintc.i < sintc.l) goto L_150; } Phi[sintc.l] = sintnc.tp; if (sintc.l != sintc.lendt + 1) { /* I = L AT THIS TIME. */ L_170: Phi[sintc.i + 1] = Phi[sintc.i] + (sintnc.s/(sintc.x - Xt[sintc.i + 1]))* (Phi[sintc.i] - Phi[sintc.i + 1]); sintc.i += 1; if (sintc.i <= sintc.lendt) goto L_170; } L_180: sintc.lendt += 1; Xt[sintc.l] = sintc.x; Ft[sintc.l] = sintnc.fncval; if (sintc.j1old != 18) { if (sintc.j1old >= sintc.l) sintc.j1old += 1; } if (sintc.j2old >= sintc.l) sintc.j2old += 1; if (sintc.where != 0) goto L_230; /* REFORM THE DIFFERENCE LINES. * */ L_200: sintc.nfjump = sintc.nfeval; Phi[1] = Ft[1]; Phit[1] = Ft[2] - Ft[1]; Phi[2] = -Phit[1]; Phit[2] = Ft[2]; for (sintc.j = 3; sintc.j <= sintc.lendt; sintc.j++) { sintnc.tp = 1.0e0; sintnc.s = 1.0e0; Phit[sintc.j] = Ft[sintc.j]; for (sintc.i = 3; sintc.i <= sintc.j; sintc.i++) { Phit[sintc.j - sintc.i + 2] = Phit[sintc.j - sintc.i + 3] - sintnc.tp*Phit[sintc.j - sintc.i + 2]; sintnc.tp *= (Xt[sintc.j] - Xt[sintc.j - sintc.i + 2])/ (Xt[sintc.j - 1] - Xt[sintc.j - sintc.i + 1]); sintnc.s *= (Xt[1] - Xt[sintc.j - sintc.i + 2])/(Xt[sintc.j] - Xt[sintc.j - sintc.i + 2]); } Phit[1] = Phit[2] - sintnc.tp*Phit[1]; Phi[sintc.j] = -sintnc.s*Phit[1]; } L_230: ; return; } /* end of function */