1 SUBROUTINE SINTO (JUMP,WORK) 2c Copyright (c) 1996 California Institute of Technology, Pasadena, CA. 3c ALL RIGHTS RESERVED. 4c Based on Government Sponsored Research NAS7-03001. 5c>> 2009-07-15 SINTO Krogh Fixed incorrect outputs of KDIM 6c>> 2008-01-17 SINTO Krogh Updated generated error message text. 7C>> 2000-12-01 SINTO Krogh Removed unused parameters LABSC & MASA16. 8C>> 1996-03-31 SINTO Krogh Removed unused variable in common. 9C>> 1995-11-20 SINTO Krogh Converted from SFTRAN to Fortran 77. 10C>> 1994-11-17 SINTO Krogh Rearranged parameter statments. 11C>> 1994-11-14 SINTO Krogh Declared all vars. 12c>> 1994-10-19 SINTO Krogh Changes to use M77CON 13c>> 1994-07-07 SINTO Snyder set up for CHGTYP. 14C>> 1994-06-13 SINTO Krogh -- Fixed value of LLOC3 "+2" not "+3". 15C>> 1993-05-18 SINTO Krogh -- Changed "END" to "END PROGRAM" 16c>> 1993-04-29 SINTO Krogh Additions for Conversion to C. 17C>> 1993-04-13 SINTO Krogh Minor changes for new MESS. 18C>> 1992-05-28 SINTO Krogh Corrected minor problem in error message. 19C>> 1992-04-08 SINTO Krogh unused label 210, FDAT in MESS calls removed 20C>> 1992-03-03 SINTO Krogh converted to use message processor. 21C>> 1991-09-20 SINTO Krogh converted '(1)' dimensioning to '(*)'. 22C>> 1988-11-17 SINTO Snyder Remove unnecessary specializer comments. 23C>> 1988-06-07 SINTO Snyder Correct format statement 20. 24C>> 1987-11-19 SINTO Snyder Initial code. 25C 26C PRINT SOMETHING FOR SINTA. 27c 28c--S replaces "?": ?INT, ?INTA, ?intc, ?intec, ?INTNC, ?INTO, ?MESS 29C 30C ***** DESCRIPTION OF VARIABLES WITH SPECIAL USE HERE ********* 31C 32C AACUM First floating point variable in saved common area. 33C ACUM Double precision result accumulated. 34C AINIT First floating point variable in the unsaved common area. 35C DISCHK Nonzero if checking for a discontinuity. This and WORRY are 36C only printed if DISCHK is not zero. 37C SMESS Used when message contains floating point. 38C FDAT Temporary storage for floating point variables to be printed. 39C FNSAV Array equivalenced to AINIT, access to unsaved floating point. 40C FSAV Array equivalenced to AACUM, access to saved floating point. 41C I First integer in the saved common area. 42C IDAT Temporary storage for integer variables to be printed. 43C IDFLT1 Parameter, see description of MESSA. 44C IDINT1 Parameter, see description of MESSA. 45C IDINT2 Parameter, see description of MESSA. 46C IF1 Pointer to floating point variable, see MESSA. 47C II1 First integer extracted from MESSF, see MESSA. 48C II2 Second integer extracted from MESSF, see MESSA. 49C INSAV Array equivalenced to KDIM for access to unsaved integers. 50C ISAV Array equivalenced to I for access to saved integers. 51C JUMP Input variable defining what is to be printed. 52C = 1 Panel boundaries 53C = 2 Header (if needed) and K, ERRI, ERR, EPSMIN, EPS, RE, ... 54C = 3 No action. 55C = 4 Note that direction of accumulation has been reversed. 56C = 5 x's, f's, difference lines, etc. 57C = 6 Estimated errors during a search. 58C = 7 Panel boundaries after a disconinuity found. 59C = 8 New round off level after noise detected. 60C = 9 Indicate a nonintegrable singularity. 61C =10 Note that abscissae have coalesced. 62C =11 Data for an accepted answer. 63C =12 Step size from an initial interval search. 64C =13 Message that there appears to be a discontinuity. 65C KDIM First integer variable in the unsaved common area. 66C L?? Many names starting with L identify the locations of variables 67C the common blocks. The letters following the L serve to 68C identify which variable in the common blocks. All of these 69C variables are defined in a block of parameter statements 70C separated from others by header and ending comments. 71C LENDT Number of x's, f,s and differences to be printed. 72C LIDAT Current location for saving integers in IDAT. 73C LMACT Current base location for saving data in MACT. 74C LMESS Value taken from MESSL and updated depending on MESSF, see 75C description of MESSA below. If > 0, provides an index 76C into MESSA for the action. After getting actions, if this 77C is > 1, it gives the next value of LMESS; else data is printed 78C and a return is made with printout of exterior abscissae 79C following the other data if LMESS is 1. If LMESS < 0, -LMESS 80C is packed data like that in MESSA, except that in this case 81C II1 gives the next value to be assigned to LMESS, and both the 82C integer and floating point data is to be printed from the 83C unsaved common block. 84C LTXTA? All names of this type were generated by running the data in 85C SINTO.ERR through PMESS. These are all parameters that define 86C where various text starts in MTXTAx. 87C MACT Array used to store actions for calls to MESS. 88C MACTAR As for MACT except for printing a vector. 89C MACTH As for MACT except only need pointer to one text entry. 90C MACTMA As for MACT except for printing the array containing x's, f's, 91C and differences. 92C MECONT Parameter defined in MESS, means return, print is to continue. 93C MEFDAT Parameter defined in MESS, means set index for next floating 94C point item to print. 95C MEFMAT Parameter defined in MESS, means print a matrix. 96C MEFVEC Parameter defined in MESS, means print a vector. 97C MENTXT Parameter defined in MESS, as for MEFDAT execpt for text. 98C MERET Parameter defined in MESS, means print buffers and return. 99C MESAdd Where dd is one or two digits. These define parameters that 100C are used in the data statement for MESSA, see comments there. 101C MESLd As for the above, execpt used in assigning value to MESSL, when 102C those value are < 0. 103C MESS Message routine, when no floating point is to be printed. 104C MESSA An array containing packed integers that define the actions to 105C be taken. Entries in MESSA have the form IDINT1*II1 + 106C IDINT2*II2 + IDFLT1*IF1 + t, where in every case the first 107C multiplier in a product is a parameter which is a power of 2, 108C and the second defines an action as follows: 109C II1 first integer to be printed. In most cases, LMESS increases 110C by 1, but if this is > 31, LMESS is set to II1 / 32 - 1 and 111C II1 is replaced by mod(II1,32). If the result is: 112C 31 Print out of final results (some vars. are always double 113C precision). 114C 30 Check on NDIM to see if KDIM should print. 115C 29 Check on DISCHK to decide if it and WORRY are to print. 116C >12 Subtract 12, and use to get an integer from unsaved common. 117C <12 Use to get an integer from the saved common area. 118C II2 Second integer. Treated like the first, except always < 25. 119C IF1 Used to get a floating point number from the saved common 120C block. 121C t Location of text for message in MTXTAA. 122C MESSF Obtained from MESSA or -MESSL(LMESS), see above. 123C MESSL Maps value of JUMP into actions. If > 0, gives an index into 124C MESSA, else the negative defines the value of MESSF. Also see 125C LMESS above. 126C METEXT Parameter defined in MESS, means print as defined by MTXTAx. 127C MTXTAx Character arrays containing text and instructions for the 128C printing of messages by MESS. 129C NDIM Number of dimensions in the total integral. 130C NEEDH .TRUE. if heading needed when JUMP is 2, else is .FALSE. 131C SMESS Used when message contains single precision floating point. 132C WORK Array passed in containing exterior abscissae. 133C 134C ***** PROGRAM VARIABLES ********************************** 135C 136 INTEGER JUMP 137 REAL WORK(*) 138 INTEGER IDAT(5), INSAV(7), ISAV(8), MESSL(13), MESSA(15) 139 REAL FDAT(4), FNSAV(11), FSAV(169) 140 integer LDELMN, LDELTA, LDISCX, LEPS, LERRI, LINC, 141 1 LISTOP, LK, LKAIMT, LKDIM, LLOC1, LLOC3, LNFEVA, LNSUB, LPART, 142 2 LPHISU, LRNDC, LSEARC, LTPS, LWHERE, LWORRY, LX, LXJ, LXT, 143 3 IDFLT1, IDINT2, IDINT1, MESA1, MESA2, MESA3, MESA4, MESA5, 144 4 MESA6, MESA7, MESA8, MESA9, MESA10, MESA11, MESA12, MESA13, 145 5 MESA14, MESA15, MESL3, MESL5, MESL6, MESL8, MESL9, 146 6 MESL13, LMACT, LIDAT, LMESS, MESSF, II1, II2, IF1 147C 148C ***** COMMON VARIABLES *********************************** 149C 150C COMMON /SINTNC/ CONTAINS VARIABLES NOT SEPARATELY SAVED FOR 151C EACH DIMENSION OF A MULTIPLE QUADRATURE. COMMON /SINTC/ 152C CONTAINS VARIABLES THAT MUST BE SAVED FOR EACH DIMENSION OF THE 153C QUADRATURE. THE VARIABLES IN EACH COMMON BLOCK ARE STORED IN THE 154C ORDER - ALWAYS DOUBLE, DOUBLE IF DOUBLE PRECISION PROGRAM, DOUBLE 155C IF DOUBLE PRECISION PROGRAM AND EXPONENT RANGE OF DOUBLE AND 156C SINGLE VERY DIFFERENT, SINGLE, INTEGER, LOGICAL. A PAD OF LOGICAL 157C VARIABLES IS INCLUDED AT THE END OF /SINTC/. THE DIMENSION OF 158C THE PAD MAY NEED TO BE VARIED SO THAT NO VARIABLES BEYOND THE END 159C OF THE COMMON BLOCK ARE ALTERED. 160C 161C DECLARATIONS OF COMMON /SINTNC/ VARIABLES. 162C 163 REAL AINIT, BINIT, FNCVAL, S, TP 164 REAL FER, FER1, RELOBT, TPS, XJ, XJP 165 INTEGER FEA, FEA1, INC, INC2, IPRINT, 166 1 ISTOP(2,2),JPRINT, KDIM, KK, KMAXF, NDIM, 167 2 NFINDX, NFMAX, NFMAXM, RELTOL, REVERM, REVERS, 168 3 WHEREM 169 LOGICAL NEEDH 170C 171C DECLARATIONS OF COMMON /SINTC/ VARIABLES. 172C 173c--D Next line special: S => D, X => Q, D => D, P => D 174 DOUBLE PRECISION ACUM, PACUM, RESULT(2) 175C 139 $.TYPE.$ VARIABLES 176 REAL 177 1 AACUM, ABSCIS, DELMIN, DELTA, DIFF, DISCX(2), 178 2 END(2), ERRINA, ERRINB, FAT(2), FSAVE, 179 3 FUNCT(24), F1, F2, LOCAL(4), PAACUM, PF1, 180 4 PF2, PHISUM, PHTSUM, PX, SPACE(6), 181 5 STEP(2), START(2), SUM, T, TA, TASAVE, 182 6 TB, TEND, WORRY(2), X, X1, 183 7 X2, XT(17), FT(17), PHI(34) 184c Note XT, FT, and PHI above are last, because they must be in adjacent 185c locations in SINTC. 186C 30 $DSTYP$ VARIABLES 187 REAL 188 1 ABSDIF, COUNT, EDUE2A, EDUE2B, EP, EPNOIZ, 189 2 EPS, EPSMAX, EPSMIN, EPSO, EPSR, EPSS, 190 3 ERR, ERRAT(2), ERRC, ERRF, ERRI, ERRT(2), 191 4 ESOLD, EXTRA, PEPSMN, RE, RELEPS, REP, 192 5 REPROD, RNDC, TLEN, XJUMP 193C 29 INTEGER VARIABLES 194 INTEGER DISCF, DISCHK, ENDPTS, I, INEW, 195 1 IOLD, IP, IXKDIM, J, J1, J1OLD, 196 2 J2, J2OLD, K, KAIMT, KMAX, KMIN, 197 3 L, LENDT, NFEVAL, NFJUMP, NSUB, NSUBSV, 198 4 NXKDIM, PART, SEARCH, TALOC, WHERE, WHERE2 199C 11 TO 18 LOGICALS (7 ARE PADDING). 200 LOGICAL DID1, FAIL, FATS(2), FSAVED, HAVDIF, 201 1 IEND, INIT, ROUNDF, XCDOBT(2), PAD(7) 202C 203C THE COMMON BLOCKS. 204C 205 COMMON /SINTNC/ 206c 1 2 3 4 5 6 7 8 207 W AINIT, BINIT, FNCVAL, S, TP, FER, FER1, RELOBT, 208c 9 10 11 12 13 1 2 3 209 X TPS, XJ, XJP, FEA, FEA1, KDIM, INC, INC2, 210c 4 (2,2) 8 9 10 11 12 13 14 211 Y ISTOP, JPRINT, IPRINT, KK, KMAXF, NDIM, NFINDX, NFMAX, 212c 15 16 17 18 19 20 213 Z NFMAXM, RELTOL, REVERM, REVERS, WHEREM, NEEDH 214 COMMON /SINTC/ 215 1 ACUM, PACUM, RESULT 216 COMMON /SINTC/ 217c 1 2 (4) 6 7 8 9 10 11 (2) 218 1 AACUM, LOCAL, ABSCIS, TA, DELTA, DELMIN, DIFF, DISCX, 219c 13 (2) 15 16 17 (2) 19 20 (24) 44 220 2 END, ERRINA, ERRINB, FAT, FSAVE, FUNCT, F2, 221c 45 46 47 48 49 50 51 (6) 222 3 PAACUM, PF1, PF2, PHISUM, PHTSUM, PX, SPACE, 223c 57 (2) 59 (2) 61 62 63 64 65 224 4 STEP, START, SUM, T, TASAVE, TB, TEND, 225c 66 (2) 68 69 70 71 72 226 5 WORRY, X1, X2, X, F1, COUNT, 227c 73 (17) 90 (17) 107 (34) 228 6 XT, FT, PHI 229 COMMON /SINTC/ 230c 141 142 143 144 145 146 231 1 ABSDIF, EDUE2A, EDUE2B, EP, EPNOIZ, EPSMAX, 232c 147 148 149 150 (2) 152 153 233 2 EPSO, EPSR, EPSS, ERRAT, ERRC, ERRF, 234c 154 (2) 156 157 158 159 160 235 3 ERRT, ESOLD, EXTRA, PEPSMN, RELEPS, REP, 236c 161 162 163 237 4 RNDC, TLEN, XJUMP, 238c 164 165 166 167 168 169 239 5 ERRI, ERR, EPSMIN, EPS, RE, REPROD 240 COMMON /SINTC/ 241c 170 171 172 242 1 DISCF, DISCHK, ENDPTS, INEW, IOLD, IP, IXKDIM, 243 2 J, J1, J1OLD, J2, J2OLD, KMAX, KMIN, 244 3 L, LENDT, NFJUMP, NSUBSV, NXKDIM, TALOC, WHERE2, 245c 1 2 3 4 5 6 7 8 246 4 I, K, KAIMT, NSUB, PART, SEARCH, WHERE, NFEVAL 247 COMMON /SINTC/ 248 1 DID1, FAIL, FATS, FSAVED, HAVDIF, IEND, INIT, ROUNDF, 249 2 XCDOBT, PAD 250 SAVE /SINTNC/, /SINTC/ 251C 252C THE VARIABLES HERE DEFINE THE MACHINE ENVIRONMENT. ALL ARE SET 253C IN DINTOP. THE MEANING ATTACHED TO THESE VARIABLES CAN BE 254C FOUND BY LOOKING AT THE DEFINITIONS IN DINTOP. 255 REAL 256 1 EMEPS, EEPSM8, EDELM2, EDELM3, ESQEPS, ERSQEP, ERSQE6, EMINF, 257 2 ESMALL, ENZER, EDELM1, ENINF 258 COMMON /SINTEC/ 259 1 EMEPS, EEPSM8, EDELM2, EDELM3, ESQEPS, ERSQEP, ERSQE6, EMINF, 260 2 ESMALL, ENZER, EDELM1, ENINF 261 SAVE /SINTEC/ 262C 263C ***** EQUIVALENCE STATEMENTS ***************************** 264C 265 EQUIVALENCE (INSAV,KDIM), (FNSAV,AINIT), (ISAV,I), (FSAV,AACUM) 266C 267C ***** Statements for Processing Messages ********************** 268C 269 INTEGER MENTXT, MEFDAT, MECONT, MERET, MEEMES, METEXT, MEFVEC, 270 1 MEFMAT 271 PARAMETER (MENTXT =23) 272 PARAMETER (MEFDAT =25) 273 PARAMETER (MECONT =50) 274 PARAMETER (MERET =51) 275 PARAMETER (MEEMES =52) 276 PARAMETER (METEXT =53) 277 PARAMETER (MEFVEC =61) 278 PARAMETER (MEFMAT =62) 279 INTEGER MACT(26), MACTMA(7), MACTAR(6), MACTH(2), MACTER(5) 280C Parameters defining locations in the common blocks. 281 PARAMETER (LTPS=9) 282 PARAMETER (LXJ=10) 283c 284 PARAMETER (LINC=2) 285 PARAMETER (LISTOP=4) 286 PARAMETER (LKDIM=1) 287c 288 PARAMETER (LDELMN=9) 289 PARAMETER (LDELTA=8) 290 PARAMETER (LDISCX=11) 291 PARAMETER (LEPS=167) 292 PARAMETER (LERRI=164) 293 PARAMETER (LPHISU=48) 294 PARAMETER (LRNDC=161) 295 PARAMETER (LWORRY=66) 296 PARAMETER (LX=70) 297 PARAMETER (LXT=73) 298c 299 PARAMETER (LK=2) 300 PARAMETER (LKAIMT=3) 301 PARAMETER (LNSUB=4) 302 PARAMETER (LPART=5) 303 PARAMETER (LSEARC=6) 304 PARAMETER (LWHERE=7) 305 PARAMETER (LNFEVA=8) 306c 307 PARAMETER (LLOC1=2) 308 PARAMETER (LLOC3=LLOC1+2) 309c 310C End of parameters defining locations in the common blocks. 311C 312c ********* Error message text *************** 313c[Last 2 letters of Param. name] [Text generating message.] 314cAA NSUB=$I on ($F, $F) KDIM=$I$B 315cAB DEL=$(E12.5) DELMIN=$(E09.3) $B 316cAC EPS=$G PART=$I AIM=$I$B 317cAD DISCHK=$I WORRY=$F$B 318cAE KDIM=$I$B 319cAF TA=$F$E 320cAG $(I2) $(E11.4) $G $G $G $G $G $J$E 321cAH **** Reverse Direction ****$E 322cAI ISTOP=$I $I $I $I, XJ=$F XJP=$F$B 323cAJ XT$HFT$HPHI$HPHIT$E 324cAK $# 325cAL INC=$I INC2=$I E=$F $B 326cAM X=$F F1=$F COUNT=$F$E 327cAN Round-Off = $F. $B 328cAO Apparent non-integrable singularity near $F. $B 329cAP Absiccae have coalesced. WHERE=$I, DELMIN=$F, NSUB=$I$E 330cAQ DELTA chosen by search = $F.$E 331cAR Discontinuity in ($F, $F).$E 332cAS Used $I function values -- the maximium.$E 333c $ 334cAT K ERRI ERR EPSMIN EPS $C 335c RE REPROD KDIM$E 336c $ 337cAU PHISUM=$F PHTSUM=$F SEARCH=$I$E 338c $ 339cAV Accept result $I = $F, ACCUM=$F, ERR=$(E10.4), EPSMIN=$G,$C 340c KDIM=$I$E 341c $ 342cAW Abscissae for dimensions $I to $I: $B 343c $ 344cAX Really on ($F, $F) KDIM=$I DEL=$(E12.5) TA=$(E10.3) $E 345c $ 346cAY SINT$B 347 integer LTXTAA,LTXTAB,LTXTAC,LTXTAD,LTXTAE,LTXTAF,LTXTAG,LTXTAH, 348 * LTXTAI,LTXTAJ,LTXTAK,LTXTAL,LTXTAM,LTXTAN,LTXTAO,LTXTAP,LTXTAQ, 349 * LTXTAR,LTXTAS,LTXTAT,LTXTAU,LTXTAV,LTXTAW,LTXTAX,LTXTAY 350 parameter (LTXTAA= 1,LTXTAB= 30,LTXTAC= 62,LTXTAD= 85,LTXTAE=106, 351 * LTXTAF=116,LTXTAG=123,LTXTAH=157,LTXTAI=186,LTXTAJ=220, 352 * LTXTAK=239,LTXTAL=241,LTXTAM=264,LTXTAN=285,LTXTAO=304, 353 * LTXTAP=352,LTXTAQ=409,LTXTAR=439,LTXTAS=467,LTXTAT= 1, 354 * LTXTAU= 1,LTXTAV= 1,LTXTAW= 1,LTXTAX= 1,LTXTAY= 1) 355 character MTXTAA(3) * (170) 356 character MTXTAB(1) * (80) 357 character MTXTAC(1) * (32) 358 character MTXTAD(1) * (67) 359 character MTXTAE(1) * (37) 360 character MTXTAF(1) * (58) 361 character MTXTAG(1) * (6) 362 data MTXTAA/'NSUB=$I on ($F, $F) KDIM=$I$B DEL=$(E12.5) DELMIN=$(E 363 *09.3) $BEPS=$G PART=$I AIM=$I$B DISCHK=$I WORRY=$F$B KDIM=$I$BTA=$ 364 *F$E$(I2) $(E11.4) $G $G $G $G $G $J$E**** Reverse D','irection *** 365 **$EISTOP=$I $I $I $I, XJ=$F XJP=$F$BXT$HFT$HPHI$HPHIT$E$#INC=$I I 366 *NC2=$I E=$F $BX=$F F1=$F COUNT=$F$ERound-Off = $F. $BApparent no 367 *n-integrable singularity n','ear $F. $BAbsiccae have coalesced. $ 368 * WHERE=$I, DELMIN=$F, NSUB=$I$EDELTA chosen by search = $F.$EDisco 369 *ntinuity in ($F, $F).$EUsed $I function values -- the maximium.$E 370 * '/ 371 data MTXTAB/' K ERRI ERR EPSMIN EPS $ 372 * RE REPROD KDIM$E'/ 373 data MTXTAC/' PHISUM=$F PHTSUM=$F SEARCH=$I$E'/ 374 data MTXTAD/'Accept result $I = $F, ACCUM=$F, ERR=$(E10.4), EPSMIN 375 *=$G, KDIM=$I$E'/ 376 data MTXTAE/'Abscissae for dimensions $I to $I: $B'/ 377 data MTXTAF/'Really on ($F, $F) KDIM=$I DEL=$(E12.5) TA=$(E10. 378 *3) $E'/ 379 data MTXTAG/'SINT$B'/ 380c **** End of automatically generated text 381 PARAMETER (IDFLT1=1024) 382 PARAMETER (IDINT2=IDFLT1*256) 383 PARAMETER (IDINT1=IDINT2*32) 384 PARAMETER (MESA1=IDINT1*LNSUB+(12+LKDIM)*IDINT2+IDFLT1*LLOC1 385 1 +LTXTAA) 386 PARAMETER (MESA2=IDFLT1*LDELTA+LTXTAB) 387 PARAMETER (MESA3=IDINT1*LPART+IDINT2*LKAIMT+IDFLT1*LEPS+LTXTAC) 388 PARAMETER (MESA4=29*IDINT1+IDFLT1*LWORRY+LTXTAD) 389 PARAMETER (MESA5=30*IDINT1+LTXTAE) 390 PARAMETER (MESA6=(32+LK)*IDINT1+(12+LKDIM)*IDINT2+IDFLT1*LERRI+ 391 * LTXTAG) 392 PARAMETER (MESA7=32*IDINT1+LTXTAH) 393 PARAMETER (MESA8=32*IDINT1+IDFLT1*LX+LTXTAM) 394 PARAMETER (MESA9=IDINT1*(96+LNSUB)+IDFLT1*LDISCX+LTXTAA) 395 PARAMETER (MESA10=64*IDINT1+IDFLT1*LRNDC+LTXTAN) 396 PARAMETER (MESA11=64*IDINT1+IDFLT1*LLOC3+LTXTAO) 397 PARAMETER (MESA12=IDINT1*(64+LWHERE)+IDINT2*LNSUB+IDFLT1*LDELMN+ 398 * LTXTAP) 399 PARAMETER (MESA13=31*IDINT1) 400 PARAMETER (MESA14=32*IDINT1+IDFLT1*LDELTA+LTXTAQ) 401 PARAMETER (MESA15=64*IDINT1+IDFLT1*LDISCX+LTXTAR) 402C 403 PARAMETER (MESL3=-(16*IDINT1+5*IDINT2+57)) 404 PARAMETER (MESL5=-(IDINT2*LISTOP+IDFLT1*LXJ+LTXTAI)) 405 PARAMETER (MESL6=-(8*IDINT1+IDINT2*LINC+IDFLT1*LTPS+LTXTAL)) 406 PARAMETER (MESL8=-(10*IDINT1+1*IDINT2+24)) 407 PARAMETER (MESL9=-(11*IDINT1+6*IDINT2+68)) 408 PARAMETER (MESL13=-(15*IDINT1+3*IDINT2+25)) 409C JUMP = 1 2 3 4 5 6 7 8 9 410 DATA MESSL / 1, 6, MESL3, 7, MESL5, MESL6, 9, MESL8, MESL9, 411 * 12, 13, 14, MESL13 / 412C JUMP = 10 11 12 13 413 414 DATA MESSA / MESA1, MESA2, MESA3, MESA4, MESA5, MESA6, MESA7, 415 * MESA8, MESA9, MESA10, MESA11, MESA12, MESA13, MESA14, MESA15 / 416 417 DATA MACT / MENTXT, 0, MEFDAT, 0, METEXT, 418 * MENTXT, 0, MEFDAT, 0, METEXT, 419 * MENTXT, 0, MEFDAT, 0, METEXT, 420 * MENTXT, 0, MEFDAT, 0, METEXT, 421 * MENTXT, 0, MEFDAT, 0, METEXT, MERET/ 422 DATA MACTMA / MEFMAT, 17, 0, 4, LTXTAK, LTXTAJ, MERET / 423 DATA MACTAR / METEXT, MEFDAT, 0, MEFVEC, 0, MERET / 424 DATA MACTH / METEXT, MERET / 425 DATA MACTER / MEEMES, 0, 0, -1, MECONT / 426C 427C ***** EXECUTABLE STATEMENTS ****************************** 428C 429 IF (JUMP .EQ. 2) THEN 430 IF (NEEDH) CALL MESS(MACTH, MTXTAB, IDAT) 431 NEEDH = .FALSE. 432 ELSE 433 NEEDH = .TRUE. 434 END IF 435 LMACT = 2 436 LIDAT = 1 437 LMESS = MESSL(JUMP) 438 IF (LMESS .LT. 0) THEN 439C Output data from the unsaved common block 440 MESSF = -LMESS 441 GO TO 20 442 END IF 443 10 MESSF = MESSA(LMESS) 444 20 II1 = MESSF / IDINT1 445 MESSF = MESSF - II1 * IDINT1 446 II2 = MESSF / IDINT2 447 MESSF = MESSF - II2 * IDINT2 448 IF1 = MESSF / IDFLT1 449 MACT(LMACT) = MESSF - IF1 * IDFLT1 450 MACT(LMACT+2) = IF1 451 IF (LMESS .LE. 0) THEN 452 LMESS = II1 453 IF (IF1 .EQ. 0) THEN 454 IF (LMESS .EQ. 0) RETURN 455 MACTER(2) = MACT(LMACT) 456 MACTER(3) = II2 457 CALL MESS(MACTER, MTXTAG, IDAT) 458 NDIM = NDIM + 100 459 GO TO 10 460 END IF 461 MACT(6) = MECONT 462 CALL SMESS(MACT, MTXTAA, INSAV(II2), FNSAV) 463 MACT(6) = MENTXT 464 IF (IF1 .NE. LXJ) GO TO 10 465 CALL SMESS(MACTH, MTXTAC, ISAV(LSEARC), FSAV(LPHISU)) 466 MACTMA(3) = LENDT 467 CALL SMESS(MACTMA, MTXTAA, IDAT, FSAV(LXT)) 468 RETURN 469 ELSE 470 IF (II1 .GE. 32) THEN 471 LMESS = II1 / 32 472 II1 = II1 - 32*LMESS 473 LMESS = LMESS - 1 474 ELSE 475 LMESS = LMESS + 1 476 END IF 477 IF (II1 .NE. 0) THEN 478 IF (II1 .GT. 12) THEN 479 IF (II1 .GE. 28) THEN 480 GO TO (100, 110, 120), II1-28 481 LMESS = 1 482 GO TO 220 483 100 IF (DISCHK .EQ. 0) GO TO 10 484 IDAT(LIDAT) = DISCHK 485 MACT(LMACT+2) = IF1 + PART - 1 486 GO TO 200 487 110 LMESS = 1 488 IF (NSUB .NE. 0) LMESS = -1 489 IF (NDIM .EQ. 1) GO TO 220 490 IDAT(LIDAT) = KDIM 491 GO TO 200 492C Take care of stuff that is double precision in single precision code. 493 120 FDAT(1) = RESULT(I) 494 FDAT(2) = ACUM 495 FDAT(3) = ERR 496 FDAT(4) = EPSMIN 497 IDAT(1) = I 498 IDAT(2) = KDIM 499 CALL SMESS(MACTH, MTXTAD, IDAT, FDAT) 500 GO TO 230 501 ELSE 502 IDAT(LIDAT) = INSAV(II1-12) 503 END IF 504 ELSE 505 IDAT(LIDAT) = ISAV(II1) 506 END IF 507 IF (II2 .NE. 0) THEN 508 LIDAT = LIDAT + 1 509 IF (II2 .GT. 12) THEN 510 IDAT(LIDAT) = INSAV(II2-12) 511 ELSE 512 IDAT(LIDAT) = ISAV(II2) 513 END IF 514 END IF 515 LIDAT = LIDAT + 1 516 END IF 517 END IF 518 200 LMACT = LMACT + 5 519 IF (LMESS .GT. 1) GO TO 10 520 220 MACT(LMACT-1) = MERET 521 IF (NDIM .GT. 100) MACT(LMACT-1) = MECONT 522 CALL SMESS(MACT, MTXTAA, IDAT, FSAV) 523 MACT(LMACT-1) = MEFDAT 524 IF (LMESS .EQ. 0) RETURN 525 IF (LMESS .LT. 0) then 526 ABSCIS = abs(LOCAL(4) - LOCAL(3)) 527 IDAT(1) = KDIM 528 CALL SMESS(MACTH, MTXTAF, IDAT, FSAV(LLOC3)) 529 end if 530 230 IF (NDIM .LE. KDIM) RETURN 531 LMACT = 1 532 IF (NDIM .GT. 100) THEN 533 NDIM = NDIM - 100 534 IF (NDIM .LE. KDIM) LMACT = 2 535 END IF 536 IDAT(2) = NDIM 537 IDAT(1) = KDIM+1 538 MACTAR(3) = IDAT(1) 539 MACTAR(5) = -NDIM 540 CALL SMESS(MACTAR(LMACT), MTXTAE, IDAT, WORK) 541 RETURN 542 END 543