1 DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) 2C***BEGIN PROLOGUE DASUM 3C***DATE WRITTEN 791001 (YYMMDD) 4C***REVISION DATE 820801 (YYMMDD) 5C***CATEGORY NO. D1A3A 6C***KEYWORDS ADD,BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAGNITUDE,SUM, 7C VECTOR 8C***AUTHOR LAWSON, C. L., (JPL) 9C HANSON, R. J., (SNLA) 10C KINCAID, D. R., (U. OF TEXAS) 11C KROGH, F. T., (JPL) 12C***PURPOSE Sum of magnitudes of d.p. vector components 13C***DESCRIPTION 14C 15C B L A S Subprogram 16C Description of Parameters 17C 18C --Input-- 19C N number of elements in input vector(s) 20C DX double precision vector with N elements 21C INCX storage spacing between elements of DX 22C 23C --Output-- 24C DASUM double precision result (zero if N .LE. 0) 25C 26C Returns sum of magnitudes of double precision DX. 27C DASUM = sum from 0 to N-1 of DABS(DX(1+I*INCX)) 28C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., 29C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, 30C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL 31C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 32C***ROUTINES CALLED (NONE) 33C***END PROLOGUE DASUM 34C 35 DOUBLE PRECISION DX(1) 36C***FIRST EXECUTABLE STATEMENT DASUM 37 DASUM = 0.D0 38 IF(N.LE.0)RETURN 39 IF(INCX.EQ.1)GOTO 20 40C 41C CODE FOR INCREMENTS NOT EQUAL TO 1. 42C 43 NS = N*INCX 44 DO 10 I=1,NS,INCX 45 DASUM = DASUM + DABS(DX(I)) 46 10 CONTINUE 47 RETURN 48C 49C CODE FOR INCREMENTS EQUAL TO 1. 50C 51C 52C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 6. 53C 54 20 M = MOD(N,6) 55 IF( M .EQ. 0 ) GO TO 40 56 DO 30 I = 1,M 57 DASUM = DASUM + DABS(DX(I)) 58 30 CONTINUE 59 IF( N .LT. 6 ) RETURN 60 40 MP1 = M + 1 61 DO 50 I = MP1,N,6 62 DASUM = DASUM + DABS(DX(I)) + DABS(DX(I+1)) + DABS(DX(I+2)) 63 1 + DABS(DX(I+3)) + DABS(DX(I+4)) + DABS(DX(I+5)) 64 50 CONTINUE 65 RETURN 66 END 67 SUBROUTINE DASYIK (X, FNU, KODE, FLGIK, RA, ARG, IN, Y) 68C***BEGIN PROLOGUE DASYIK 69C***SUBSIDIARY 70C***PURPOSE Subsidiary to DBESI and DBESK 71C***LIBRARY SLATEC 72C***TYPE DOUBLE PRECISION (ASYIK-S, DASYIK-D) 73C***AUTHOR Amos, D. E., (SNLA) 74C***DESCRIPTION 75C 76C DASYIK computes Bessel functions I and K 77C for arguments X.GT.0.0 and orders FNU.GE.35 78C on FLGIK = 1 and FLGIK = -1 respectively. 79C 80C INPUT 81C 82C X - Argument, X.GT.0.0D0 83C FNU - Order of first Bessel function 84C KODE - A parameter to indicate the scaling option 85C KODE=1 returns Y(I)= I/SUB(FNU+I-1)/(X), I=1,IN 86C or Y(I)= K/SUB(FNU+I-1)/(X), I=1,IN 87C on FLGIK = 1.0D0 or FLGIK = -1.0D0 88C KODE=2 returns Y(I)=EXP(-X)*I/SUB(FNU+I-1)/(X), I=1,IN 89C or Y(I)=EXP( X)*K/SUB(FNU+I-1)/(X), I=1,IN 90C on FLGIK = 1.0D0 or FLGIK = -1.0D0 91C FLGIK - Selection parameter for I or K FUNCTION 92C FLGIK = 1.0D0 gives the I function 93C FLGIK = -1.0D0 gives the K function 94C RA - SQRT(1.+Z*Z), Z=X/FNU 95C ARG - Argument of the leading exponential 96C IN - Number of functions desired, IN=1 or 2 97C 98C OUTPUT 99C 100C Y - A vector whose first IN components contain the sequence 101C 102C Abstract **** A double precision routine **** 103C DASYIK implements the uniform asymptotic expansion of 104C the I and K Bessel functions for FNU.GE.35 and real 105C X.GT.0.0D0. The forms are identical except for a change 106C in sign of some of the terms. This change in sign is 107C accomplished by means of the FLAG FLGIK = 1 or -1. 108C 109C***SEE ALSO DBESI, DBESK 110C***ROUTINES CALLED D1MACH 111C***REVISION HISTORY (YYMMDD) 112C 750101 DATE WRITTEN 113C 890531 Changed all specific intrinsics to generic. (WRB) 114C 890911 Removed unnecessary intrinsics. (WRB) 115C 891214 Prologue converted to Version 4.0 format. (BAB) 116C 900328 Added TYPE section. (WRB) 117C 910408 Updated the AUTHOR section. (WRB) 118C***END PROLOGUE DASYIK 119C 120C-----COMMON---------------------------------------------------------- 121C 122 INCLUDE 'DPCOMC.INC' 123 INCLUDE 'DPCOP2.INC' 124C 125 INTEGER IN, J, JN, K, KK, KODE, L 126 DOUBLE PRECISION AK,AP,ARG,C,COEF,CON,ETX,FLGIK,FN,FNU,GLN,RA, 127 1 S1, S2, T, TOL, T2, X, Y, Z 128 DIMENSION Y(*), C(65), CON(2) 129 SAVE CON, C 130 DATA CON(1), CON(2) / 131 1 3.98942280401432678D-01, 1.25331413731550025D+00/ 132 DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), 133 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), 134 2 C(19), C(20), C(21), C(22), C(23), C(24)/ 135 3 -2.08333333333333D-01, 1.25000000000000D-01, 136 4 3.34201388888889D-01, -4.01041666666667D-01, 137 5 7.03125000000000D-02, -1.02581259645062D+00, 138 6 1.84646267361111D+00, -8.91210937500000D-01, 139 7 7.32421875000000D-02, 4.66958442342625D+00, 140 8 -1.12070026162230D+01, 8.78912353515625D+00, 141 9 -2.36408691406250D+00, 1.12152099609375D-01, 142 1 -2.82120725582002D+01, 8.46362176746007D+01, 143 2 -9.18182415432400D+01, 4.25349987453885D+01, 144 3 -7.36879435947963D+00, 2.27108001708984D-01, 145 4 2.12570130039217D+02, -7.65252468141182D+02, 146 5 1.05999045252800D+03, -6.99579627376133D+02/ 147 DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), 148 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), 149 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ 150 3 2.18190511744212D+02, -2.64914304869516D+01, 151 4 5.72501420974731D-01, -1.91945766231841D+03, 152 5 8.06172218173731D+03, -1.35865500064341D+04, 153 6 1.16553933368645D+04, -5.30564697861340D+03, 154 7 1.20090291321635D+03, -1.08090919788395D+02, 155 8 1.72772750258446D+00, 2.02042913309661D+04, 156 9 -9.69805983886375D+04, 1.92547001232532D+05, 157 1 -2.03400177280416D+05, 1.22200464983017D+05, 158 2 -4.11926549688976D+04, 7.10951430248936D+03, 159 3 -4.93915304773088D+02, 6.07404200127348D+00, 160 4 -2.42919187900551D+05, 1.31176361466298D+06, 161 5 -2.99801591853811D+06, 3.76327129765640D+06/ 162 DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), 163 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), 164 2 C(65)/ 165 3 -2.81356322658653D+06, 1.26836527332162D+06, 166 4 -3.31645172484564D+05, 4.52187689813627D+04, 167 5 -2.49983048181121D+03, 2.43805296995561D+01, 168 6 3.28446985307204D+06, -1.97068191184322D+07, 169 7 5.09526024926646D+07, -7.41051482115327D+07, 170 8 6.63445122747290D+07, -3.75671766607634D+07, 171 9 1.32887671664218D+07, -2.78561812808645D+06, 172 1 3.08186404612662D+05, -1.38860897537170D+04, 173 2 1.10017140269247D+02/ 174C***FIRST EXECUTABLE STATEMENT DASYIK 175 TOL = D1MACH(3) 176 TOL = MAX(TOL,1.0D-15) 177 FN = FNU 178 Z = (3.0D0-FLGIK)/2.0D0 179 KK = INT(Z) 180 DO 50 JN=1,IN 181 IF (JN.EQ.1) GO TO 10 182 FN = FN - FLGIK 183 Z = X/FN 184 RA = SQRT(1.0D0+Z*Z) 185 GLN = LOG((1.0D0+RA)/Z) 186 ETX = KODE - 1 187 T = RA*(1.0D0-ETX) + ETX/(Z+RA) 188 ARG = FN*(T-GLN)*FLGIK 189 10 COEF = EXP(ARG) 190 T = 1.0D0/RA 191 T2 = T*T 192 T = T/FN 193 T = SIGN(T,FLGIK) 194 S2 = 1.0D0 195 AP = 1.0D0 196 L = 0 197 DO 30 K=2,11 198 L = L + 1 199 S1 = C(L) 200 DO 20 J=2,K 201 L = L + 1 202 S1 = S1*T2 + C(L) 203 20 CONTINUE 204 AP = AP*T 205 AK = AP*S1 206 S2 = S2 + AK 207 IF (MAX(ABS(AK),ABS(AP)) .LT.TOL) GO TO 40 208 30 CONTINUE 209 40 CONTINUE 210 T = ABS(T) 211 Y(JN) = S2*COEF*SQRT(T)*CON(KK) 212 50 CONTINUE 213 RETURN 214 END 215 FUNCTION DAWS (X) 216C***BEGIN PROLOGUE DAWS 217C***PURPOSE Compute Dawson's function. 218C***LIBRARY SLATEC (FNLIB) 219C***CATEGORY C8C 220C***TYPE SINGLE PRECISION (DAWS-S, DDAWS-D) 221C***KEYWORDS DAWSON'S FUNCTION, FNLIB, SPECIAL FUNCTIONS 222C***AUTHOR Fullerton, W., (LANL) 223C***DESCRIPTION 224C 225C DAWS(X) calculates Dawson's integral for real argument X. 226C 227C Series for DAW on the interval 0. to 1.00000D+00 228C with weighted error 3.83E-17 229C log weighted error 16.42 230C significant figures required 15.78 231C decimal places required 16.97 232C 233C Series for DAW2 on the interval 0. to 1.60000D+01 234C with weighted error 5.17E-17 235C log weighted error 16.29 236C significant figures required 15.90 237C decimal places required 17.02 238C 239C Series for DAWA on the interval 0. to 6.25000D-02 240C with weighted error 2.24E-17 241C log weighted error 16.65 242C significant figures required 14.73 243C decimal places required 17.36 244C 245C***REFERENCES (NONE) 246C***ROUTINES CALLED CSEVL, INITS, R1MACH, XERMSG 247C***REVISION HISTORY (YYMMDD) 248C 780401 DATE WRITTEN 249C 890531 Changed all specific intrinsics to generic. (WRB) 250C 890531 REVISION DATE from Version 3.2 251C 891214 Prologue converted to Version 4.0 format. (BAB) 252C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 253C 920618 Removed space from variable names. (RWC, WRB) 254C***END PROLOGUE DAWS 255C 256C-----COMMON---------------------------------------------------------- 257C 258 INCLUDE 'DPCOMC.INC' 259 INCLUDE 'DPCOP2.INC' 260C 261 DIMENSION DAWCS(13), DAW2CS(29), DAWACS(26) 262 LOGICAL FIRST 263 SAVE DAWCS, DAW2CS, DAWACS, NTDAW, NTDAW2, NTDAWA, 264 1 XSML, XBIG, XMAX, FIRST 265 DATA DAWCS( 1) / -.0063517343 75145949E0 / 266 DATA DAWCS( 2) / -.2294071479 6773869E0 / 267 DATA DAWCS( 3) / .0221305009 39084764E0 / 268 DATA DAWCS( 4) / -.0015492654 53892985E0 / 269 DATA DAWCS( 5) / .0000849732 77156849E0 / 270 DATA DAWCS( 6) / -.0000038282 66270972E0 / 271 DATA DAWCS( 7) / .0000001462 85480625E0 / 272 DATA DAWCS( 8) / -.0000000048 51982381E0 / 273 DATA DAWCS( 9) / .0000000001 42146357E0 / 274 DATA DAWCS(10) / -.0000000000 03728836E0 / 275 DATA DAWCS(11) / .0000000000 00088549E0 / 276 DATA DAWCS(12) / -.0000000000 00001920E0 / 277 DATA DAWCS(13) / .0000000000 00000038E0 / 278 DATA DAW2CS( 1) / -.0568865441 05215527E0 / 279 DATA DAW2CS( 2) / -.3181134699 6168131E0 / 280 DATA DAW2CS( 3) / .2087384541 3642237E0 / 281 DATA DAW2CS( 4) / -.1247540991 3779131E0 / 282 DATA DAW2CS( 5) / .0678693051 86676777E0 / 283 DATA DAW2CS( 6) / -.0336591448 95270940E0 / 284 DATA DAW2CS( 7) / .0152607812 71987972E0 / 285 DATA DAW2CS( 8) / -.0063483709 62596214E0 / 286 DATA DAW2CS( 9) / .0024326740 92074852E0 / 287 DATA DAW2CS(10) / -.0008621954 14910650E0 / 288 DATA DAW2CS(11) / .0002837657 33363216E0 / 289 DATA DAW2CS(12) / -.0000870575 49874170E0 / 290 DATA DAW2CS(13) / .0000249868 49985481E0 / 291 DATA DAW2CS(14) / -.0000067319 28676416E0 / 292 DATA DAW2CS(15) / .0000017078 57878557E0 / 293 DATA DAW2CS(16) / -.0000004091 75512264E0 / 294 DATA DAW2CS(17) / .0000000928 28292216E0 / 295 DATA DAW2CS(18) / -.0000000199 91403610E0 / 296 DATA DAW2CS(19) / .0000000040 96349064E0 / 297 DATA DAW2CS(20) / -.0000000008 00324095E0 / 298 DATA DAW2CS(21) / .0000000001 49385031E0 / 299 DATA DAW2CS(22) / -.0000000000 26687999E0 / 300 DATA DAW2CS(23) / .0000000000 04571221E0 / 301 DATA DAW2CS(24) / -.0000000000 00751873E0 / 302 DATA DAW2CS(25) / .0000000000 00118931E0 / 303 DATA DAW2CS(26) / -.0000000000 00018116E0 / 304 DATA DAW2CS(27) / .0000000000 00002661E0 / 305 DATA DAW2CS(28) / -.0000000000 00000377E0 / 306 DATA DAW2CS(29) / .0000000000 00000051E0 / 307 DATA DAWACS( 1) / .0169048563 7765704E0 / 308 DATA DAWACS( 2) / .0086832522 7840695E0 / 309 DATA DAWACS( 3) / .0002424864 0424177E0 / 310 DATA DAWACS( 4) / .0000126118 2399572E0 / 311 DATA DAWACS( 5) / .0000010664 5331463E0 / 312 DATA DAWACS( 6) / .0000001358 1597947E0 / 313 DATA DAWACS( 7) / .0000000217 1042356E0 / 314 DATA DAWACS( 8) / .0000000028 6701050E0 / 315 DATA DAWACS( 9) / -.0000000001 9013363E0 / 316 DATA DAWACS(10) / -.0000000003 0977804E0 / 317 DATA DAWACS(11) / -.0000000001 0294148E0 / 318 DATA DAWACS(12) / -.0000000000 0626035E0 / 319 DATA DAWACS(13) / .0000000000 0856313E0 / 320 DATA DAWACS(14) / .0000000000 0303304E0 / 321 DATA DAWACS(15) / -.0000000000 0025236E0 / 322 DATA DAWACS(16) / -.0000000000 0042106E0 / 323 DATA DAWACS(17) / -.0000000000 0004431E0 / 324 DATA DAWACS(18) / .0000000000 0004911E0 / 325 DATA DAWACS(19) / .0000000000 0001235E0 / 326 DATA DAWACS(20) / -.0000000000 0000578E0 / 327 DATA DAWACS(21) / -.0000000000 0000228E0 / 328 DATA DAWACS(22) / .0000000000 0000076E0 / 329 DATA DAWACS(23) / .0000000000 0000038E0 / 330 DATA DAWACS(24) / -.0000000000 0000011E0 / 331 DATA DAWACS(25) / -.0000000000 0000006E0 / 332 DATA DAWACS(26) / .0000000000 0000002E0 / 333 DATA FIRST /.TRUE./ 334C***FIRST EXECUTABLE STATEMENT DAWS 335 IF (FIRST) THEN 336 EPS = R1MACH(3) 337 NTDAW = INITS (DAWCS, 13, 0.1*EPS) 338 NTDAW2 = INITS (DAW2CS, 29, 0.1*EPS) 339 NTDAWA = INITS (DAWACS, 26, 0.1*EPS) 340C 341 XSML = SQRT (1.5*EPS) 342 XBIG = SQRT (0.5/EPS) 343 XMAX = EXP (MIN (-LOG(2.*R1MACH(1)), LOG(R1MACH(2))) - 1.0) 344 ENDIF 345 FIRST = .FALSE. 346C 347 Y = ABS(X) 348 IF (Y.GT.1.0) GO TO 20 349C 350 DAWS = X 351 IF (Y.LE.XSML) RETURN 352C 353 DAWS = X * (0.75 + CSEVL (2.0*Y*Y-1.0, DAWCS, NTDAW)) 354 RETURN 355C 356 20 IF (Y.GT.4.0) GO TO 30 357 DAWS = X * (0.25 + CSEVL (0.125*Y*Y-1.0, DAW2CS, NTDAW2)) 358 RETURN 359C 360 30 IF (Y.GT.XMAX) GO TO 40 361 DAWS = 0.5/X 362 IF (Y.GT.XBIG) RETURN 363C 364 DAWS = (0.5 + CSEVL (32.0/Y**2-1.0, DAWACS, NTDAWA)) / X 365 RETURN 366C 367 40 CONTINUE 368 WRITE(ICOUT,41) 369 CALL DPWRST('XXX','BUG ') 370 41 FORMAT('***** WARNING FROM DAWS, UNDERFLOW BECAUSE THE ', 371 1 'ABSOLUTE VALUE OF X IS SO LARGE. ****') 372 DAWS = 0.0 373 RETURN 374C 375 END 376 SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) 377C 378C CONSTANT TIMES A VECTOR PLUS A VECTOR. 379C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. 380C JACK DONGARRA, LINPACK, 3/11/78. 381C 382 DOUBLE PRECISION DX(*),DY(*),DA 383 INTEGER I,INCX,INCY,IX,IY,M,MP1,N 384C 385 IF(N.LE.0)RETURN 386 IF (DA .EQ. 0.0D0) RETURN 387 IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 388C 389C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS 390C NOT EQUAL TO 1 391C 392 IX = 1 393 IY = 1 394 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 395 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 396 DO 10 I = 1,N 397 DY(IY) = DY(IY) + DA*DX(IX) 398 IX = IX + INCX 399 IY = IY + INCY 400 10 CONTINUE 401 RETURN 402C 403C CODE FOR BOTH INCREMENTS EQUAL TO 1 404C 405C 406C CLEAN-UP LOOP 407C 408 20 M = MOD(N,4) 409 IF( M .EQ. 0 ) GO TO 40 410 DO 30 I = 1,M 411 DY(I) = DY(I) + DA*DX(I) 412 30 CONTINUE 413 IF( N .LT. 4 ) RETURN 414 40 MP1 = M + 1 415 DO 50 I = MP1,N,4 416 DY(I) = DY(I) + DA*DX(I) 417 DY(I + 1) = DY(I + 1) + DA*DX(I + 1) 418 DY(I + 2) = DY(I + 2) + DA*DX(I + 2) 419 DY(I + 3) = DY(I + 3) + DA*DX(I + 3) 420 50 CONTINUE 421 RETURN 422 END 423 SUBROUTINE DBESI (X, ALPHA, KODE, N, Y, NZ) 424C***BEGIN PROLOGUE DBESI 425C***PURPOSE Compute an N member sequence of I Bessel functions 426C I/SUB(ALPHA+K-1)/(X), K=1,...,N or scaled Bessel functions 427C EXP(-X)*I/SUB(ALPHA+K-1)/(X), K=1,...,N for nonnegative 428C ALPHA and X. 429C***LIBRARY SLATEC 430C***CATEGORY C10B3 431C***TYPE DOUBLE PRECISION (BESI-S, DBESI-D) 432C***KEYWORDS I BESSEL FUNCTION, SPECIAL FUNCTIONS 433C***AUTHOR Amos, D. E., (SNLA) 434C Daniel, S. L., (SNLA) 435C***DESCRIPTION 436C 437C Abstract **** a double precision routine **** 438C DBESI computes an N member sequence of I Bessel functions 439C I/sub(ALPHA+K-1)/(X), K=1,...,N or scaled Bessel functions 440C EXP(-X)*I/sub(ALPHA+K-1)/(X), K=1,...,N for nonnegative ALPHA 441C and X. A combination of the power series, the asymptotic 442C expansion for X to infinity, and the uniform asymptotic 443C expansion for NU to infinity are applied over subdivisions of 444C the (NU,X) plane. For values not covered by one of these 445C formulae, the order is incremented by an integer so that one 446C of these formulae apply. Backward recursion is used to reduce 447C orders by integer values. The asymptotic expansion for X to 448C infinity is used only when the entire sequence (specifically 449C the last member) lies within the region covered by the 450C expansion. Leading terms of these expansions are used to test 451C for over or underflow where appropriate. If a sequence is 452C requested and the last member would underflow, the result is 453C set to zero and the next lower order tried, etc., until a 454C member comes on scale or all are set to zero. An overflow 455C cannot occur with scaling. 456C 457C The maximum number of significant digits obtainable 458C is the smaller of 14 and the number of digits carried in 459C double precision arithmetic. 460C 461C Description of Arguments 462C 463C Input X,ALPHA are double precision 464C X - X .GE. 0.0D0 465C ALPHA - order of first member of the sequence, 466C ALPHA .GE. 0.0D0 467C KODE - a parameter to indicate the scaling option 468C KODE=1 returns 469C Y(K)= I/sub(ALPHA+K-1)/(X), 470C K=1,...,N 471C KODE=2 returns 472C Y(K)=EXP(-X)*I/sub(ALPHA+K-1)/(X), 473C K=1,...,N 474C N - number of members in the sequence, N .GE. 1 475C 476C Output Y is double precision 477C Y - a vector whose first N components contain 478C values for I/sub(ALPHA+K-1)/(X) or scaled 479C values for EXP(-X)*I/sub(ALPHA+K-1)/(X), 480C K=1,...,N depending on KODE 481C NZ - number of components of Y set to zero due to 482C underflow, 483C NZ=0 , normal return, computation completed 484C NZ .NE. 0, last NZ components of Y set to zero, 485C Y(K)=0.0D0, K=N-NZ+1,...,N. 486C 487C Error Conditions 488C Improper input arguments - a fatal error 489C Overflow with KODE=1 - a fatal error 490C Underflow - a non-fatal error(NZ .NE. 0) 491C 492C***REFERENCES D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600 493C subroutines IBESS and JBESS for Bessel functions 494C I(NU,X) and J(NU,X), X .GE. 0, NU .GE. 0, ACM 495C Transactions on Mathematical Software 3, (1977), 496C pp. 76-92. 497C F. W. J. Olver, Tables of Bessel Functions of Moderate 498C or Large Orders, NPL Mathematical Tables 6, Her 499C Majesty's Stationery Office, London, 1962. 500C***ROUTINES CALLED D1MACH, DASYIK, DLNGAM, I1MACH, XERMSG 501C***REVISION HISTORY (YYMMDD) 502C 750101 DATE WRITTEN 503C 890531 Changed all specific intrinsics to generic. (WRB) 504C 890911 Removed unnecessary intrinsics. (WRB) 505C 890911 REVISION DATE from Version 3.2 506C 891214 Prologue converted to Version 4.0 format. (BAB) 507C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 508C 900326 Removed duplicate information from DESCRIPTION section. 509C (WRB) 510C 920501 Reformatted the REFERENCES section. (WRB) 511C***END PROLOGUE DBESI 512C 513C-----COMMON---------------------------------------------------------- 514C 515 INCLUDE 'DPCOMC.INC' 516 INCLUDE 'DPCOP2.INC' 517C 518 INTEGER I, IALP, IN, INLIM, IS, I1, K, KK, KM, KODE, KT, 519 1 N, NN, NS, NZ 520 INTEGER I1MACH 521 DOUBLE PRECISION AIN,AK,AKM,ALPHA,ANS,AP,ARG,ATOL,TOLLN,DFN, 522 1 DTM, DX, EARG, ELIM, ETX, FLGIK,FN, FNF, FNI,FNP1,FNU,GLN,RA, 523 2 RTTPI, S, SX, SXO2, S1, S2, T, TA, TB, TEMP, TFN, TM, TOL, 524 3 TRX, T2, X, XO2, XO2L, Y, Z 525 DOUBLE PRECISION DLNGAM 526 DIMENSION Y(*), TEMP(3) 527 SAVE RTTPI, INLIM 528 DATA RTTPI / 3.98942280401433D-01/ 529 DATA INLIM / 80 / 530C***FIRST EXECUTABLE STATEMENT DBESI 531C 532 NZ = 0 533 KT = 1 534 NS = 0 535 KM = 0 536 XO2L = 0.0D0 537C 538C I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE 539C I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE 540 RA = D1MACH(3) 541 TOL = MAX(RA,1.0D-15) 542 I1 = -I1MACH(15) 543 GLN = D1MACH(5) 544 ELIM = 2.303D0*(I1*GLN-3.0D0) 545C TOLLN = -LN(TOL) 546 I1 = I1MACH(14)+1 547 TOLLN = 2.303D0*GLN*I1 548 TOLLN = MIN(TOLLN,34.5388D0) 549CCCCC IF (N-1) 590, 10, 20 550 IF (N-1.LT.0) THEN 551 GOTO 590 552 ELSEIF (N-1.EQ.0) THEN 553 GOTO 10 554 ELSEIF (N-1.GT.0) THEN 555 GOTO 20 556 ENDIF 557 10 KT = 2 558 20 NN = N 559 IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 570 560CCCCC IF (X) 600, 30, 80 561 IF (X.LT.0.0D0) THEN 562 GOTO 600 563 ELSEIF (X.EQ.0.0D0) THEN 564 GOTO 30 565 ELSEIF (X.GT.0.0D0) THEN 566 GOTO 80 567 ENDIF 568 30 CONTINUE 569CCCCC IF (ALPHA) 580, 40, 50 570 IF (ALPHA.LT.0.0D0)THEN 571 GOTO 580 572 ELSEIF (ALPHA.EQ.0.0D0)THEN 573 GOTO 40 574 ELSEIF (ALPHA.GT.0.0D0)THEN 575 GOTO 50 576 ENDIF 577 40 Y(1) = 1.0D0 578 IF (N.EQ.1) RETURN 579 I1 = 2 580 GO TO 60 581 50 I1 = 1 582 60 DO 70 I=I1,N 583 Y(I) = 0.0D0 584 70 CONTINUE 585 RETURN 586 80 CONTINUE 587 IF (ALPHA.LT.0.0D0) GO TO 580 588C 589 IALP = INT(ALPHA) 590 FNI = IALP + N - 1 591 FNF = ALPHA - IALP 592 DFN = FNI + FNF 593 FNU = DFN 594 IN = 0 595 XO2 = X*0.5D0 596 SXO2 = XO2*XO2 597 ETX = KODE - 1 598 SX = ETX*X 599C 600C DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X 601C TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE 602C APPLIED. 603C 604 IF (SXO2.LE.(FNU+1.0D0)) GO TO 90 605 IF (X.LE.12.0D0) GO TO 110 606 FN = 0.55D0*FNU*FNU 607 FN = MAX(17.0D0,FN) 608 IF (X.GE.FN) GO TO 430 609 ANS = MAX(36.0D0-FNU,0.0D0) 610 NS = INT(ANS) 611 FNI = FNI + NS 612 DFN = FNI + FNF 613 FN = DFN 614 IS = KT 615 KM = N - 1 + NS 616 IF (KM.GT.0) IS = 3 617 GO TO 120 618 90 FN = FNU 619 FNP1 = FN + 1.0D0 620 XO2L = LOG(XO2) 621 IS = KT 622 IF (X.LE.0.5D0) GO TO 230 623 NS = 0 624 100 FNI = FNI + NS 625 DFN = FNI + FNF 626 FN = DFN 627 FNP1 = FN + 1.0D0 628 IS = KT 629 IF (N-1+NS.GT.0) IS = 3 630 GO TO 230 631 110 XO2L = LOG(XO2) 632 NS = INT(SXO2-FNU) 633 GO TO 100 634 120 CONTINUE 635C 636C OVERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION 637C 638 IF (KODE.EQ.2) GO TO 130 639 IF (ALPHA.LT.1.0D0) GO TO 150 640 Z = X/ALPHA 641 RA = SQRT(1.0D0+Z*Z) 642 GLN = LOG((1.0D0+RA)/Z) 643 T = RA*(1.0D0-ETX) + ETX/(Z+RA) 644 ARG = ALPHA*(T-GLN) 645 IF (ARG.GT.ELIM) GO TO 610 646 IF (KM.EQ.0) GO TO 140 647 130 CONTINUE 648C 649C UNDERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION 650C 651 Z = X/FN 652 RA = SQRT(1.0D0+Z*Z) 653 GLN = LOG((1.0D0+RA)/Z) 654 T = RA*(1.0D0-ETX) + ETX/(Z+RA) 655 ARG = FN*(T-GLN) 656 140 IF (ARG.LT.(-ELIM)) GO TO 280 657 GO TO 190 658 150 IF (X.GT.ELIM) GO TO 610 659 GO TO 130 660C 661C UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY 662C 663 160 IF (KM.NE.0) GO TO 170 664 Y(1) = TEMP(3) 665 RETURN 666 170 TEMP(1) = TEMP(3) 667 IN = NS 668 KT = 1 669 I1 = 0 670 180 CONTINUE 671 IS = 2 672 FNI = FNI - 1.0D0 673 DFN = FNI + FNF 674 FN = DFN 675 IF(I1.EQ.2) GO TO 350 676 Z = X/FN 677 RA = SQRT(1.0D0+Z*Z) 678 GLN = LOG((1.0D0+RA)/Z) 679 T = RA*(1.0D0-ETX) + ETX/(Z+RA) 680 ARG = FN*(T-GLN) 681 190 CONTINUE 682 I1 = ABS(3-IS) 683 I1 = MAX(I1,1) 684 FLGIK = 1.0D0 685 CALL DASYIK(X,FN,KODE,FLGIK,RA,ARG,I1,TEMP(IS)) 686 GO TO (180, 350, 510), IS 687C 688C SERIES FOR (X/2)**2.LE.NU+1 689C 690 230 CONTINUE 691 GLN = DLNGAM(FNP1) 692 ARG = FN*XO2L - GLN - SX 693 IF (ARG.LT.(-ELIM)) GO TO 300 694 EARG = EXP(ARG) 695 240 CONTINUE 696 S = 1.0D0 697 IF (X.LT.TOL) GO TO 260 698 AK = 3.0D0 699 T2 = 1.0D0 700 T = 1.0D0 701 S1 = FN 702 DO 250 K=1,17 703 S2 = T2 + S1 704 T = T*SXO2/S2 705 S = S + T 706 IF (ABS(T).LT.TOL) GO TO 260 707 T2 = T2 + AK 708 AK = AK + 2.0D0 709 S1 = S1 + FN 710 250 CONTINUE 711 260 CONTINUE 712 TEMP(IS) = S*EARG 713 GO TO (270, 350, 500), IS 714 270 EARG = EARG*FN/XO2 715 FNI = FNI - 1.0D0 716 DFN = FNI + FNF 717 FN = DFN 718 IS = 2 719 GO TO 240 720C 721C SET UNDERFLOW VALUE AND UPDATE PARAMETERS 722C 723 280 Y(NN) = 0.0D0 724 NN = NN - 1 725 FNI = FNI - 1.0D0 726 DFN = FNI + FNF 727 FN = DFN 728CCCCC IF (NN-1) 340, 290, 130 729 IF (NN-1.LT.0) THEN 730 GOTO 340 731 ELSEIF (NN-1.EQ.0) THEN 732 GOTO 290 733 ELSEIF (NN-1.GT.0) THEN 734 GOTO 130 735 ENDIF 736 290 KT = 2 737 IS = 2 738 GO TO 130 739 300 Y(NN) = 0.0D0 740 NN = NN - 1 741 FNP1 = FN 742 FNI = FNI - 1.0D0 743 DFN = FNI + FNF 744 FN = DFN 745CCCCC IF (NN-1) 340, 310, 320 746 IF (NN-1.LT.0)THEN 747 GOTO340 748 ELSEIF(NN-1.EQ.0)THEN 749 GOTO310 750 ELSE 751 GOTO320 752 ENDIF 753 310 KT = 2 754 IS = 2 755 320 IF (SXO2.LE.FNP1) GO TO 330 756 GO TO 130 757 330 ARG = ARG - XO2L + LOG(FNP1) 758 IF (ARG.LT.(-ELIM)) GO TO 300 759 GO TO 230 760 340 NZ = N - NN 761 RETURN 762C 763C BACKWARD RECURSION SECTION 764C 765 350 CONTINUE 766 NZ = N - NN 767 360 CONTINUE 768 IF(KT.EQ.2) GO TO 420 769 S1 = TEMP(1) 770 S2 = TEMP(2) 771 TRX = 2.0D0/X 772 DTM = FNI 773 TM = (DTM+FNF)*TRX 774 IF (IN.EQ.0) GO TO 390 775C BACKWARD RECUR TO INDEX ALPHA+NN-1 776 DO 380 I=1,IN 777 S = S2 778 S2 = TM*S2 + S1 779 S1 = S 780 DTM = DTM - 1.0D0 781 TM = (DTM+FNF)*TRX 782 380 CONTINUE 783 Y(NN) = S1 784 IF (NN.EQ.1) RETURN 785 Y(NN-1) = S2 786 IF (NN.EQ.2) RETURN 787 GO TO 400 788 390 CONTINUE 789C BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA 790 Y(NN) = S1 791 Y(NN-1) = S2 792 IF (NN.EQ.2) RETURN 793 400 K = NN + 1 794 DO 410 I=3,NN 795 K = K - 1 796 Y(K-2) = TM*Y(K-1) + Y(K) 797 DTM = DTM - 1.0D0 798 TM = (DTM+FNF)*TRX 799 410 CONTINUE 800 RETURN 801 420 Y(1) = TEMP(2) 802 RETURN 803C 804C ASYMPTOTIC EXPANSION FOR X TO INFINITY 805C 806 430 CONTINUE 807 EARG = RTTPI/SQRT(X) 808 IF (KODE.EQ.2) GO TO 440 809 IF (X.GT.ELIM) GO TO 610 810 EARG = EARG*EXP(X) 811 440 ETX = 8.0D0*X 812 IS = KT 813 IN = 0 814 FN = FNU 815 450 DX = FNI + FNI 816 TM = 0.0D0 817 IF (FNI.EQ.0.0D0 .AND. ABS(FNF).LT.TOL) GO TO 460 818 TM = 4.0D0*FNF*(FNI+FNI+FNF) 819 460 CONTINUE 820 DTM = DX*DX 821 S1 = ETX 822 TRX = DTM - 1.0D0 823 DX = -(TRX+TM)/ETX 824 T = DX 825 S = 1.0D0 + DX 826 ATOL = TOL*ABS(S) 827 S2 = 1.0D0 828 AK = 8.0D0 829 DO 470 K=1,25 830 S1 = S1 + ETX 831 S2 = S2 + AK 832 DX = DTM - S2 833 AP = DX + TM 834 T = -T*AP/S1 835 S = S + T 836 IF (ABS(T).LE.ATOL) GO TO 480 837 AK = AK + 8.0D0 838 470 CONTINUE 839 480 TEMP(IS) = S*EARG 840 IF(IS.EQ.2) GO TO 360 841 IS = 2 842 FNI = FNI - 1.0D0 843 DFN = FNI + FNF 844 FN = DFN 845 GO TO 450 846C 847C BACKWARD RECURSION WITH NORMALIZATION BY 848C ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES. 849C 850 500 CONTINUE 851C COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION 852 AKM = MAX(3.0D0-FN,0.0D0) 853 KM = INT(AKM) 854 TFN = FN + KM 855 TA = (GLN+TFN-0.9189385332D0-0.0833333333D0/TFN)/(TFN+0.5D0) 856 TA = XO2L - TA 857 TB = -(1.0D0-1.0D0/TFN)/TFN 858 AIN = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5D0 859 IN = INT(AIN) 860 IN = IN + KM 861 GO TO 520 862 510 CONTINUE 863C COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION 864 T = 1.0D0/(FN*RA) 865 AIN = TOLLN/(GLN+SQRT(GLN*GLN+T*TOLLN)) + 1.5D0 866 IN = INT(AIN) 867 IF (IN.GT.INLIM) GO TO 160 868 520 CONTINUE 869 TRX = 2.0D0/X 870 DTM = FNI + IN 871 TM = (DTM+FNF)*TRX 872 TA = 0.0D0 873 TB = TOL 874 KK = 1 875 530 CONTINUE 876C 877C BACKWARD RECUR UNINDEXED 878C 879 DO 540 I=1,IN 880 S = TB 881 TB = TM*TB + TA 882 TA = S 883 DTM = DTM - 1.0D0 884 TM = (DTM+FNF)*TRX 885 540 CONTINUE 886C NORMALIZATION 887 IF (KK.NE.1) GO TO 550 888 TA = (TA/TB)*TEMP(3) 889 TB = TEMP(3) 890 KK = 2 891 IN = NS 892 IF (NS.NE.0) GO TO 530 893 550 Y(NN) = TB 894 NZ = N - NN 895 IF (NN.EQ.1) RETURN 896 TB = TM*TB + TA 897 K = NN - 1 898 Y(K) = TB 899 IF (NN.EQ.2) RETURN 900 DTM = DTM - 1.0D0 901 TM = (DTM+FNF)*TRX 902 KM = K - 1 903C 904C BACKWARD RECUR INDEXED 905C 906 DO 560 I=1,KM 907 Y(K-1) = TM*Y(K) + Y(K+1) 908 DTM = DTM - 1.0D0 909 TM = (DTM+FNF)*TRX 910 K = K - 1 911 560 CONTINUE 912 RETURN 913C 914C 915C 916 570 CONTINUE 917 WRITE(ICOUT,571) 918 571 FORMAT('***** ERORR FROM DBESI, KODE IS NOT 1 OR 2. ***') 919 CALL DPWRST('XXX','BUG ') 920 RETURN 921 580 CONTINUE 922 WRITE(ICOUT,581) 923 581 FORMAT('***** ERORR FROM DBESI, THE ORDER ALPHA IS NEGATIVE. **') 924 CALL DPWRST('XXX','BUG ') 925 RETURN 926 590 CONTINUE 927 WRITE(ICOUT,591) 928 591 FORMAT('***** ERORR FROM DBESI, N IS LESS THAN ONE.. ***') 929 CALL DPWRST('XXX','BUG ') 930 RETURN 931 600 CONTINUE 932 WRITE(ICOUT,601) 933 601 FORMAT('***** ERORR FROM DBESI, X IS LESS THAN ZERO.. ***') 934 CALL DPWRST('XXX','BUG ') 935 RETURN 936 610 CONTINUE 937 WRITE(ICOUT,611) 938 611 FORMAT('**** ERORR FROM DBESI, OVERFLOW BECAUSE X IS TOO BIG. *') 939 CALL DPWRST('XXX','BUG ') 940 RETURN 941 END 942 DOUBLE PRECISION FUNCTION DBESI0 (X) 943C***BEGIN PROLOGUE DBESI0 944C***PURPOSE Compute the hyperbolic Bessel function of the first kind 945C of order zero. 946C***LIBRARY SLATEC (FNLIB) 947C***CATEGORY C10B1 948C***TYPE DOUBLE PRECISION (BESI0-S, DBESI0-D) 949C***KEYWORDS FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION, 950C MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS 951C***AUTHOR Fullerton, W., (LANL) 952C***DESCRIPTION 953C 954C DBESI0(X) calculates the double precision modified (hyperbolic) 955C Bessel function of the first kind of order zero and double 956C precision argument X. 957C 958C Series for BI0 on the interval 0. to 9.00000E+00 959C with weighted error 9.51E-34 960C log weighted error 33.02 961C significant figures required 33.31 962C decimal places required 33.65 963C 964C***REFERENCES (NONE) 965C***ROUTINES CALLED D1MACH, DBSI0E, DCSEVL, INITDS, XERMSG 966C***REVISION HISTORY (YYMMDD) 967C 770701 DATE WRITTEN 968C 890531 Changed all specific intrinsics to generic. (WRB) 969C 890531 REVISION DATE from Version 3.2 970C 891214 Prologue converted to Version 4.0 format. (BAB) 971C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 972C***END PROLOGUE DBESI0 973C 974C-----COMMON---------------------------------------------------------- 975C 976 INCLUDE 'DPCOMC.INC' 977 INCLUDE 'DPCOP2.INC' 978C 979 DOUBLE PRECISION X, BI0CS(18), XMAX, XSML, Y, 980 1 DCSEVL, DBSI0E 981 LOGICAL FIRST 982 SAVE BI0CS, NTI0, XSML, XMAX, FIRST 983 DATA BI0CS( 1) / -.7660547252 8391449510 8189497624 3285 D-1 / 984 DATA BI0CS( 2) / +.1927337953 9938082699 5240875088 1196 D+1 / 985 DATA BI0CS( 3) / +.2282644586 9203013389 3702929233 0415 D+0 / 986 DATA BI0CS( 4) / +.1304891466 7072904280 7933421069 1888 D-1 / 987 DATA BI0CS( 5) / +.4344270900 8164874513 7868268102 6107 D-3 / 988 DATA BI0CS( 6) / +.9422657686 0019346639 2317174411 8766 D-5 / 989 DATA BI0CS( 7) / +.1434006289 5106910799 6209187817 9957 D-6 / 990 DATA BI0CS( 8) / +.1613849069 6617490699 1541971999 4611 D-8 / 991 DATA BI0CS( 9) / +.1396650044 5356696994 9509270814 2522 D-10 / 992 DATA BI0CS( 10) / +.9579451725 5054453446 2752317189 3333 D-13 / 993 DATA BI0CS( 11) / +.5333981859 8625021310 1510774400 0000 D-15 / 994 DATA BI0CS( 12) / +.2458716088 4374707746 9678591999 9999 D-17 / 995 DATA BI0CS( 13) / +.9535680890 2487700269 4434133333 3333 D-20 / 996 DATA BI0CS( 14) / +.3154382039 7214273367 8933333333 3333 D-22 / 997 DATA BI0CS( 15) / +.9004564101 0946374314 6666666666 6666 D-25 / 998 DATA BI0CS( 16) / +.2240647369 1236700160 0000000000 0000 D-27 / 999 DATA BI0CS( 17) / +.4903034603 2428373333 3333333333 3333 D-30 / 1000 DATA BI0CS( 18) / +.9508172606 1226666666 6666666666 6666 D-33 / 1001 DATA FIRST /.TRUE./ 1002C***FIRST EXECUTABLE STATEMENT DBESI0 1003 IF (FIRST) THEN 1004 NTI0 = INITDS (BI0CS, 18, 0.1*REAL(D1MACH(3))) 1005 XSML = SQRT(4.5D0*D1MACH(3)) 1006 XMAX = LOG (D1MACH(2)) 1007 ENDIF 1008 FIRST = .FALSE. 1009C 1010 Y = ABS(X) 1011 IF (Y.GT.3.0D0) GO TO 20 1012C 1013 DBESI0 = 1.0D0 1014 IF (Y.GT.XSML) DBESI0 = 2.75D0 + DCSEVL (Y*Y/4.5D0-1.D0, BI0CS, 1015 1 NTI0) 1016 RETURN 1017C 1018 20 CONTINUE 1019 IF (Y.GT.XMAX) THEN 1020 WRITE(ICOUT,1) 1021 CALL DPWRST('XXX','BUG ') 1022 DBESI0 = 0.0D0 1023 RETURN 1024 ENDIF 1025 1 FORMAT('***** ERORR FROM DBESI0, OVERFLOW BECAUSE THE ', 1026 1 'ABSOLUTE VALUE OF X IS TOO BIG. ****') 1027C 1028 DBESI0 = EXP(Y) * DBSI0E(X) 1029C 1030 RETURN 1031 END 1032 DOUBLE PRECISION FUNCTION DBESI1 (X) 1033C***BEGIN PROLOGUE DBESI1 1034C***PURPOSE Compute the modified (hyperbolic) Bessel function of the 1035C first kind of order one. 1036C***LIBRARY SLATEC (FNLIB) 1037C***CATEGORY C10B1 1038C***TYPE DOUBLE PRECISION (BESI1-S, DBESI1-D) 1039C***KEYWORDS FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION, 1040C MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS 1041C***AUTHOR Fullerton, W., (LANL) 1042C***DESCRIPTION 1043C 1044C DBESI1(X) calculates the double precision modified (hyperbolic) 1045C Bessel function of the first kind of order one and double precision 1046C argument X. 1047C 1048C Series for BI1 on the interval 0. to 9.00000E+00 1049C with weighted error 1.44E-32 1050C log weighted error 31.84 1051C significant figures required 31.45 1052C decimal places required 32.46 1053C 1054C***REFERENCES (NONE) 1055C***ROUTINES CALLED D1MACH, DBSI1E, DCSEVL, INITDS, XERMSG 1056C***REVISION HISTORY (YYMMDD) 1057C 770701 DATE WRITTEN 1058C 890531 Changed all specific intrinsics to generic. (WRB) 1059C 890531 REVISION DATE from Version 3.2 1060C 891214 Prologue converted to Version 4.0 format. (BAB) 1061C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 1062C***END PROLOGUE DBESI1 1063C 1064C-----COMMON---------------------------------------------------------- 1065C 1066 INCLUDE 'DPCOMC.INC' 1067 INCLUDE 'DPCOP2.INC' 1068C 1069 DOUBLE PRECISION X, BI1CS(17), XMAX, XMIN, XSML, Y, 1070 1 DCSEVL, DBSI1E 1071 LOGICAL FIRST 1072 SAVE BI1CS, NTI1, XMIN, XSML, XMAX, FIRST 1073 DATA BI1CS( 1) / -.1971713261 0998597316 1385032181 49 D-2 / 1074 DATA BI1CS( 2) / +.4073488766 7546480608 1553936520 14 D+0 / 1075 DATA BI1CS( 3) / +.3483899429 9959455866 2450377837 87 D-1 / 1076 DATA BI1CS( 4) / +.1545394556 3001236038 5984010584 89 D-2 / 1077 DATA BI1CS( 5) / +.4188852109 8377784129 4588320041 20 D-4 / 1078 DATA BI1CS( 6) / +.7649026764 8362114741 9597039660 69 D-6 / 1079 DATA BI1CS( 7) / +.1004249392 4741178689 1798080372 38 D-7 / 1080 DATA BI1CS( 8) / +.9932207791 9238106481 3712980548 63 D-10 / 1081 DATA BI1CS( 9) / +.7663801791 8447637275 2001716813 49 D-12 / 1082 DATA BI1CS( 10) / +.4741418923 8167394980 3880919481 60 D-14 / 1083 DATA BI1CS( 11) / +.2404114404 0745181799 8631720320 00 D-16 / 1084 DATA BI1CS( 12) / +.1017150500 7093713649 1211007999 99 D-18 / 1085 DATA BI1CS( 13) / +.3645093565 7866949458 4917333333 33 D-21 / 1086 DATA BI1CS( 14) / +.1120574950 2562039344 8106666666 66 D-23 / 1087 DATA BI1CS( 15) / +.2987544193 4468088832 0000000000 00 D-26 / 1088 DATA BI1CS( 16) / +.6973231093 9194709333 3333333333 33 D-29 / 1089 DATA BI1CS( 17) / +.1436794822 0620800000 0000000000 00 D-31 / 1090 DATA FIRST /.TRUE./ 1091C***FIRST EXECUTABLE STATEMENT DBESI1 1092 IF (FIRST) THEN 1093 NTI1 = INITDS (BI1CS, 17, 0.1*REAL(D1MACH(3))) 1094 XMIN = 2.0D0*D1MACH(1) 1095 XSML = SQRT(4.5D0*D1MACH(3)) 1096 XMAX = LOG (D1MACH(2)) 1097 ENDIF 1098 FIRST = .FALSE. 1099C 1100 Y = ABS(X) 1101 IF (Y.GT.3.0D0) GO TO 20 1102C 1103 DBESI1 = 0.D0 1104 IF (Y.EQ.0.D0) RETURN 1105C 1106 IF (Y .LE. XMIN) THEN 1107 WRITE(ICOUT,2) 1108 CALL DPWRST('XXX','BUG ') 1109 ENDIF 1110 2 FORMAT('***** WARNING FROM DBESI1, UNDERFLOW BECAUSE THE ', 1111 1 'ABSOLUTE VALUE OF X IS SO SMALL. ****') 1112 IF (Y.GT.XMIN) DBESI1 = 0.5D0*X 1113 IF (Y.GT.XSML) DBESI1 = X*(0.875D0 + DCSEVL (Y*Y/4.5D0-1.D0, 1114 1 BI1CS, NTI1)) 1115 RETURN 1116C 1117 20 CONTINUE 1118 IF (Y.GT.XMAX) THEN 1119 WRITE(ICOUT,1) 1120 CALL DPWRST('XXX','BUG ') 1121 DBESI1 = 0.0 1122 RETURN 1123 ENDIF 1124 1 FORMAT('***** ERORR FROM DBESI1, OVERFLOW BECAUSE THE ', 1125 1 'ABSOLUTE VALUE OF X IS TOO BIG. ****') 1126C 1127 DBESI1 = EXP(Y) * DBSI1E(X) 1128C 1129 RETURN 1130 END 1131 SUBROUTINE DBESK (X, FNU, KODE, N, Y, NZ) 1132C***BEGIN PROLOGUE DBESK 1133C***PURPOSE Implement forward recursion on the three term recursion 1134C relation for a sequence of non-negative order Bessel 1135C functions K/SUB(FNU+I-1)/(X), or scaled Bessel functions 1136C EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N for real, positive 1137C X and non-negative orders FNU. 1138C***LIBRARY SLATEC 1139C***CATEGORY C10B3 1140C***TYPE DOUBLE PRECISION (BESK-S, DBESK-D) 1141C***KEYWORDS K BESSEL FUNCTION, SPECIAL FUNCTIONS 1142C***AUTHOR Amos, D. E., (SNLA) 1143C***DESCRIPTION 1144C 1145C Abstract **** a double precision routine **** 1146C DBESK implements forward recursion on the three term 1147C recursion relation for a sequence of non-negative order Bessel 1148C functions K/sub(FNU+I-1)/(X), or scaled Bessel functions 1149C EXP(X)*K/sub(FNU+I-1)/(X), I=1,..,N for real X .GT. 0.0D0 and 1150C non-negative orders FNU. If FNU .LT. NULIM, orders FNU and 1151C FNU+1 are obtained from DBSKNU to start the recursion. If 1152C FNU .GE. NULIM, the uniform asymptotic expansion is used for 1153C orders FNU and FNU+1 to start the recursion. NULIM is 35 or 1154C 70 depending on whether N=1 or N .GE. 2. Under and overflow 1155C tests are made on the leading term of the asymptotic expansion 1156C before any extensive computation is done. 1157C 1158C The maximum number of significant digits obtainable 1159C is the smaller of 14 and the number of digits carried in 1160C double precision arithmetic. 1161C 1162C Description of Arguments 1163C 1164C Input X,FNU are double precision 1165C X - X .GT. 0.0D0 1166C FNU - order of the initial K function, FNU .GE. 0.0D0 1167C KODE - a parameter to indicate the scaling option 1168C KODE=1 returns Y(I)= K/sub(FNU+I-1)/(X), 1169C I=1,...,N 1170C KODE=2 returns Y(I)=EXP(X)*K/sub(FNU+I-1)/(X), 1171C I=1,...,N 1172C N - number of members in the sequence, N .GE. 1 1173C 1174C Output Y is double precision 1175C Y - a vector whose first N components contain values 1176C for the sequence 1177C Y(I)= k/sub(FNU+I-1)/(X), I=1,...,N or 1178C Y(I)=EXP(X)*K/sub(FNU+I-1)/(X), I=1,...,N 1179C depending on KODE 1180C NZ - number of components of Y set to zero due to 1181C underflow with KODE=1, 1182C NZ=0 , normal return, computation completed 1183C NZ .NE. 0, first NZ components of Y set to zero 1184C due to underflow, Y(I)=0.0D0, I=1,...,NZ 1185C 1186C Error Conditions 1187C Improper input arguments - a fatal error 1188C Overflow - a fatal error 1189C Underflow with KODE=1 - a non-fatal error (NZ .NE. 0) 1190C 1191C***REFERENCES F. W. J. Olver, Tables of Bessel Functions of Moderate 1192C or Large Orders, NPL Mathematical Tables 6, Her 1193C Majesty's Stationery Office, London, 1962. 1194C N. M. Temme, On the numerical evaluation of the modified 1195C Bessel function of the third kind, Journal of 1196C Computational Physics 19, (1975), pp. 324-337. 1197C***ROUTINES CALLED D1MACH, DASYIK, DBESK0, DBESK1, DBSK0E, DBSK1E, 1198C DBSKNU, I1MACH, XERMSG 1199C***REVISION HISTORY (YYMMDD) 1200C 790201 DATE WRITTEN 1201C 890531 Changed all specific intrinsics to generic. (WRB) 1202C 890911 Removed unnecessary intrinsics. (WRB) 1203C 890911 REVISION DATE from Version 3.2 1204C 891214 Prologue converted to Version 4.0 format. (BAB) 1205C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 1206C 920501 Reformatted the REFERENCES section. (WRB) 1207C***END PROLOGUE DBESK 1208C 1209C 1210C-----COMMON---------------------------------------------------------- 1211C 1212 INCLUDE 'DPCOMC.INC' 1213 INCLUDE 'DPCOP2.INC' 1214C 1215 INTEGER I, J, K, KODE, MZ, N, NB, ND, NN, NUD, NULIM, NZ 1216 DOUBLE PRECISION CN,DNU,ELIM,ETX,FLGIK,FN,FNN,FNU,GLN,GNU,RTZ, 1217 1 S, S1, S2, T, TM, TRX, W, X, XLIM, Y, ZN 1218 DOUBLE PRECISION DBESK0, DBESK1, DBSK1E, DBSK0E 1219 DIMENSION W(2), NULIM(2), Y(*) 1220 SAVE NULIM 1221 DATA NULIM(1),NULIM(2) / 35 , 70 / 1222C***FIRST EXECUTABLE STATEMENT DBESK 1223C 1224 TRX=0.0D0 1225 TM=0.0D0 1226 S2=0.0D0 1227C 1228 NN = -I1MACH(15) 1229 ELIM = 2.303D0*(NN*D1MACH(5)-3.0D0) 1230 XLIM = D1MACH(1)*1.0D+3 1231 IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 280 1232 IF (FNU.LT.0.0D0) GO TO 290 1233 IF (X.LE.0.0D0) GO TO 300 1234 IF (X.LT.XLIM) GO TO 320 1235 IF (N.LT.1) GO TO 310 1236 ETX = KODE - 1 1237C 1238C ND IS A DUMMY VARIABLE FOR N 1239C GNU IS A DUMMY VARIABLE FOR FNU 1240C NZ = NUMBER OF UNDERFLOWS ON KODE=1 1241C 1242 ND = N 1243 NZ = 0 1244 NUD = INT(FNU) 1245 DNU = FNU - NUD 1246 GNU = FNU 1247 NN = MIN(2,ND) 1248 FN = FNU + N - 1 1249 FNN = FN 1250 IF (FN.LT.2.0D0) GO TO 150 1251C 1252C OVERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION) 1253C FOR THE LAST ORDER, FNU+N-1.GE.NULIM 1254C 1255 ZN = X/FN 1256 IF (ZN.EQ.0.0D0) GO TO 320 1257 RTZ = SQRT(1.0D0+ZN*ZN) 1258 GLN = LOG((1.0D0+RTZ)/ZN) 1259 T = RTZ*(1.0D0-ETX) + ETX/(ZN+RTZ) 1260 CN = -FN*(T-GLN) 1261 IF (CN.GT.ELIM) GO TO 320 1262 IF (NUD.LT.NULIM(NN)) GO TO 30 1263 IF (NN.EQ.1) GO TO 20 1264 10 CONTINUE 1265C 1266C UNDERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION) 1267C FOR THE FIRST ORDER, FNU.GE.NULIM 1268C 1269 FN = GNU 1270 ZN = X/FN 1271 RTZ = SQRT(1.0D0+ZN*ZN) 1272 GLN = LOG((1.0D0+RTZ)/ZN) 1273 T = RTZ*(1.0D0-ETX) + ETX/(ZN+RTZ) 1274 CN = -FN*(T-GLN) 1275 20 CONTINUE 1276 IF (CN.LT.-ELIM) GO TO 230 1277C 1278C ASYMPTOTIC EXPANSION FOR ORDERS FNU AND FNU+1.GE.NULIM 1279C 1280 FLGIK = -1.0D0 1281 CALL DASYIK(X,GNU,KODE,FLGIK,RTZ,CN,NN,Y) 1282 IF (NN.EQ.1) GO TO 240 1283 TRX = 2.0D0/X 1284 TM = (GNU+GNU+2.0D0)/X 1285 GO TO 130 1286C 1287 30 CONTINUE 1288 IF (KODE.EQ.2) GO TO 40 1289C 1290C UNDERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION IN X) 1291C FOR ORDER DNU 1292C 1293 IF (X.GT.ELIM) GO TO 230 1294 40 CONTINUE 1295 IF (DNU.NE.0.0D0) GO TO 80 1296 IF (KODE.EQ.2) GO TO 50 1297 S1 = DBESK0(X) 1298 GO TO 60 1299 50 S1 = DBSK0E(X) 1300 60 CONTINUE 1301 IF (NUD.EQ.0 .AND. ND.EQ.1) GO TO 120 1302 IF (KODE.EQ.2) GO TO 70 1303 S2 = DBESK1(X) 1304 GO TO 90 1305 70 S2 = DBSK1E(X) 1306 GO TO 90 1307 80 CONTINUE 1308 NB = 2 1309 IF (NUD.EQ.0 .AND. ND.EQ.1) NB = 1 1310 CALL DBSKNU(X, DNU, KODE, NB, W, NZ) 1311 S1 = W(1) 1312 IF (NB.EQ.1) GO TO 120 1313 S2 = W(2) 1314 90 CONTINUE 1315 TRX = 2.0D0/X 1316 TM = (DNU+DNU+2.0D0)/X 1317C FORWARD RECUR FROM DNU TO FNU+1 TO GET Y(1) AND Y(2) 1318 IF (ND.EQ.1) NUD = NUD - 1 1319 IF (NUD.GT.0) GO TO 100 1320 IF (ND.GT.1) GO TO 120 1321 S1 = S2 1322 GO TO 120 1323 100 CONTINUE 1324 DO 110 I=1,NUD 1325 S = S2 1326 S2 = TM*S2 + S1 1327 S1 = S 1328 TM = TM + TRX 1329 110 CONTINUE 1330 IF (ND.EQ.1) S1 = S2 1331 120 CONTINUE 1332 Y(1) = S1 1333 IF (ND.EQ.1) GO TO 240 1334 Y(2) = S2 1335 130 CONTINUE 1336 IF (ND.EQ.2) GO TO 240 1337C FORWARD RECUR FROM FNU+2 TO FNU+N-1 1338 DO 140 I=3,ND 1339 Y(I) = TM*Y(I-1) + Y(I-2) 1340 TM = TM + TRX 1341 140 CONTINUE 1342 GO TO 240 1343C 1344 150 CONTINUE 1345C UNDERFLOW TEST FOR KODE=1 1346 IF (KODE.EQ.2) GO TO 160 1347 IF (X.GT.ELIM) GO TO 230 1348 160 CONTINUE 1349C OVERFLOW TEST 1350 IF (FN.LE.1.0D0) GO TO 170 1351 IF (-FN*(LOG(X)-0.693D0).GT.ELIM) GO TO 320 1352 170 CONTINUE 1353 IF (DNU.EQ.0.0D0) GO TO 180 1354 CALL DBSKNU(X, FNU, KODE, ND, Y, MZ) 1355 GO TO 240 1356 180 CONTINUE 1357 J = NUD 1358 IF (J.EQ.1) GO TO 210 1359 J = J + 1 1360 IF (KODE.EQ.2) GO TO 190 1361 Y(J) = DBESK0(X) 1362 GO TO 200 1363 190 Y(J) = DBSK0E(X) 1364 200 IF (ND.EQ.1) GO TO 240 1365 J = J + 1 1366 210 IF (KODE.EQ.2) GO TO 220 1367 Y(J) = DBESK1(X) 1368 GO TO 240 1369 220 Y(J) = DBSK1E(X) 1370 GO TO 240 1371C 1372C UPDATE PARAMETERS ON UNDERFLOW 1373C 1374 230 CONTINUE 1375 NUD = NUD + 1 1376 ND = ND - 1 1377 IF (ND.EQ.0) GO TO 240 1378 NN = MIN(2,ND) 1379 GNU = GNU + 1.0D0 1380 IF (FNN.LT.2.0D0) GO TO 230 1381 IF (NUD.LT.NULIM(NN)) GO TO 230 1382 GO TO 10 1383 240 CONTINUE 1384 NZ = N - ND 1385 IF (NZ.EQ.0) RETURN 1386 IF (ND.EQ.0) GO TO 260 1387 DO 250 I=1,ND 1388 J = N - I + 1 1389 K = ND - I + 1 1390 Y(J) = Y(K) 1391 250 CONTINUE 1392 260 CONTINUE 1393 DO 270 I=1,NZ 1394 Y(I) = 0.0D0 1395 270 CONTINUE 1396 RETURN 1397C 1398C 1399C 1400 280 CONTINUE 1401CCCCC CALL XERMSG ('SLATEC', 'DBESK', 1402CCCCC+ 'SCALING OPTION, KODE, NOT 1 OR 2', 2, 1) 1403CCCCC RETURN 1404CC290 CONTINUE 1405CCCCC CALL XERMSG ('SLATEC', 'DBESK', 'ORDER, FNU, LESS THAN ZERO', 2, 1406CCCCC+ 1) 1407CCCCC RETURN 1408CC300 CONTINUE 1409CCCCC CALL XERMSG ('SLATEC', 'DBESK', 'X LESS THAN OR EQUAL TO ZERO', 1410CCCCC+ 2, 1) 1411CCCCC RETURN 1412CC310 CONTINUE 1413CCCCC CALL XERMSG ('SLATEC', 'DBESK', 'N LESS THAN ONE', 2, 1) 1414CCCCC RETURN 1415CC320 CONTINUE 1416CCCCC CALL XERMSG ('SLATEC', 'DBESK', 1417CCCCC+ 'OVERFLOW, FNU OR N TOO LARGE OR X TOO SMALL', 6, 1) 1418 WRITE(ICOUT,281) 1419 281 FORMAT('***** ERORR FROM DBESK, KODE IS NOT 1 OR 2. ***') 1420 CALL DPWRST('XXX','BUG ') 1421 RETURN 1422 290 CONTINUE 1423 WRITE(ICOUT,291) 1424 291 FORMAT('***** ERORR FROM DBESK, THE ORDER FNU IS NEGATIVE.') 1425 CALL DPWRST('XXX','BUG ') 1426 RETURN 1427 300 CONTINUE 1428 WRITE(ICOUT,301) 1429 301 FORMAT('**** ERORR FROM DBESK, X IS LESS THAN OR EQUAL TO ZERO.') 1430 CALL DPWRST('XXX','BUG ') 1431 RETURN 1432 310 CONTINUE 1433 WRITE(ICOUT,311) 1434 311 FORMAT('***** ERORR FROM DBESK, N IS LESS THAN ONE.') 1435 CALL DPWRST('XXX','BUG ') 1436 RETURN 1437 320 CONTINUE 1438 WRITE(ICOUT,321) 1439 321 FORMAT('***** ERORR FROM DBESK, OVERFLOW, FNU OR N TOO LARGE OR', 1440 1 ' X TOO SMALL.') 1441 CALL DPWRST('XXX','BUG ') 1442 RETURN 1443 END 1444 DOUBLE PRECISION FUNCTION DBESK0 (X) 1445C***BEGIN PROLOGUE DBESK0 1446C***PURPOSE Compute the modified (hyperbolic) Bessel function of the 1447C third kind of order zero. 1448C***LIBRARY SLATEC (FNLIB) 1449C***CATEGORY C10B1 1450C***TYPE DOUBLE PRECISION (BESK0-S, DBESK0-D) 1451C***KEYWORDS FNLIB, HYPERBOLIC BESSEL FUNCTION, 1452C MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS, 1453C THIRD KIND 1454C***AUTHOR Fullerton, W., (LANL) 1455C***DESCRIPTION 1456C 1457C DBESK0(X) calculates the double precision modified (hyperbolic) 1458C Bessel function of the third kind of order zero for double 1459C precision argument X. The argument must be greater than zero 1460C but not so large that the result underflows. 1461C 1462C Series for BK0 on the interval 0. to 4.00000E+00 1463C with weighted error 3.08E-33 1464C log weighted error 32.51 1465C significant figures required 32.05 1466C decimal places required 33.11 1467C 1468C***REFERENCES (NONE) 1469C***ROUTINES CALLED D1MACH, DBESI0, DBSK0E, DCSEVL, INITDS, XERMSG 1470C***REVISION HISTORY (YYMMDD) 1471C 770701 DATE WRITTEN 1472C 890531 Changed all specific intrinsics to generic. (WRB) 1473C 890531 REVISION DATE from Version 3.2 1474C 891214 Prologue converted to Version 4.0 format. (BAB) 1475C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 1476C***END PROLOGUE DBESK0 1477C 1478C-----COMMON---------------------------------------------------------- 1479C 1480 INCLUDE 'DPCOMC.INC' 1481 INCLUDE 'DPCOP2.INC' 1482C 1483 DOUBLE PRECISION X, BK0CS(16), XMAX, XMAXT, XSML, Y, 1484 1 DCSEVL, DBESI0, DBSK0E 1485 LOGICAL FIRST 1486 SAVE BK0CS, NTK0, XSML, XMAX, FIRST 1487 DATA BK0CS( 1) / -.3532739323 3902768720 1140060063 153 D-1 / 1488 DATA BK0CS( 2) / +.3442898999 2462848688 6344927529 213 D+0 / 1489 DATA BK0CS( 3) / +.3597993651 5361501626 5721303687 231 D-1 / 1490 DATA BK0CS( 4) / +.1264615411 4469259233 8479508673 447 D-2 / 1491 DATA BK0CS( 5) / +.2286212103 1194517860 8269830297 585 D-4 / 1492 DATA BK0CS( 6) / +.2534791079 0261494573 0790013428 354 D-6 / 1493 DATA BK0CS( 7) / +.1904516377 2202088589 7214059381 366 D-8 / 1494 DATA BK0CS( 8) / +.1034969525 7633624585 1008317853 089 D-10 / 1495 DATA BK0CS( 9) / +.4259816142 7910825765 2445327170 133 D-13 / 1496 DATA BK0CS( 10) / +.1374465435 8807508969 4238325440 000 D-15 / 1497 DATA BK0CS( 11) / +.3570896528 5083735909 9688597333 333 D-18 / 1498 DATA BK0CS( 12) / +.7631643660 1164373766 7498666666 666 D-21 / 1499 DATA BK0CS( 13) / +.1365424988 4407818590 8053333333 333 D-23 / 1500 DATA BK0CS( 14) / +.2075275266 9066680831 9999999999 999 D-26 / 1501 DATA BK0CS( 15) / +.2712814218 0729856000 0000000000 000 D-29 / 1502 DATA BK0CS( 16) / +.3082593887 9146666666 6666666666 666 D-32 / 1503 DATA FIRST /.TRUE./ 1504C***FIRST EXECUTABLE STATEMENT DBESK0 1505 IF (FIRST) THEN 1506 NTK0 = INITDS (BK0CS, 16, 0.1*REAL(D1MACH(3))) 1507 XSML = SQRT(4.0D0*D1MACH(3)) 1508 XMAXT = -LOG(D1MACH(1)) 1509 XMAX = XMAXT - 0.5D0*XMAXT*LOG(XMAXT)/(XMAXT+0.5D0) 1510 ENDIF 1511 FIRST = .FALSE. 1512C 1513CCCCC IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'DBESK0', 1514CCCCC+ 'X IS ZERO OR NEGATIVE', 2, 2) 1515 IF (X .LE. 0.D0) THEN 1516 WRITE(ICOUT,1) 1517 1 FORMAT('***** ERORR FROM DBESK0, X IS ZERO OR NEGATIVE.') 1518 CALL DPWRST('XXX','BUG ') 1519 DBESK0 = 0.0 1520 RETURN 1521 ENDIF 1522 IF (X.GT.2.0D0) GO TO 20 1523C 1524 Y = 0.D0 1525 IF (X.GT.XSML) Y = X*X 1526 DBESK0 = -LOG(0.5D0*X)*DBESI0(X) - 0.25D0 + DCSEVL (.5D0*Y-1.D0, 1527 1 BK0CS, NTK0) 1528 RETURN 1529C 1530 20 DBESK0 = 0.D0 1531CCCCC IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'DBESK0', 1532CCCCC+ 'X SO BIG K0 UNDERFLOWS', 1, 1) 1533 IF (X.GT.XMAX) THEN 1534 WRITE(ICOUT,2) 1535 CALL DPWRST('XXX','BUG ') 1536 DBESK0 = 0.0 1537 RETURN 1538 ENDIF 1539 2 FORMAT('***** ERORR FROM DBESK0, UNDERFLOWS BECAUSE THE ', 1540 1 'VALUE OF X IS TOO BIG.') 1541 IF (X.GT.XMAX) RETURN 1542C 1543 DBESK0 = EXP(-X) * DBSK0E(X) 1544C 1545 RETURN 1546 END 1547 DOUBLE PRECISION FUNCTION DBESK1 (X) 1548C***BEGIN PROLOGUE DBESK1 1549C***PURPOSE Compute the modified (hyperbolic) Bessel function of the 1550C third kind of order one. 1551C***LIBRARY SLATEC (FNLIB) 1552C***CATEGORY C10B1 1553C***TYPE DOUBLE PRECISION (BESK1-S, DBESK1-D) 1554C***KEYWORDS FNLIB, HYPERBOLIC BESSEL FUNCTION, 1555C MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS, 1556C THIRD KIND 1557C***AUTHOR Fullerton, W., (LANL) 1558C***DESCRIPTION 1559C 1560C DBESK1(X) calculates the double precision modified (hyperbolic) 1561C Bessel function of the third kind of order one for double precision 1562C argument X. The argument must be large enough that the result does 1563C not overflow and small enough that the result does not underflow. 1564C 1565C Series for BK1 on the interval 0. to 4.00000E+00 1566C with weighted error 9.16E-32 1567C log weighted error 31.04 1568C significant figures required 30.61 1569C decimal places required 31.64 1570C 1571C***REFERENCES (NONE) 1572C***ROUTINES CALLED D1MACH, DBESI1, DBSK1E, DCSEVL, INITDS, XERMSG 1573C***REVISION HISTORY (YYMMDD) 1574C 770701 DATE WRITTEN 1575C 890531 Changed all specific intrinsics to generic. (WRB) 1576C 890531 REVISION DATE from Version 3.2 1577C 891214 Prologue converted to Version 4.0 format. (BAB) 1578C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 1579C***END PROLOGUE DBESK1 1580C 1581C-----COMMON---------------------------------------------------------- 1582C 1583 INCLUDE 'DPCOMC.INC' 1584 INCLUDE 'DPCOP2.INC' 1585C 1586 DOUBLE PRECISION X, BK1CS(16), XMAX, XMAXT, XMIN, XSML, Y, 1587 1 DCSEVL, DBESI1, DBSK1E 1588 LOGICAL FIRST 1589 SAVE BK1CS, NTK1, XMIN, XSML, XMAX, FIRST 1590 DATA BK1CS( 1) / +.2530022733 8947770532 5311208685 33 D-1 / 1591 DATA BK1CS( 2) / -.3531559607 7654487566 7238316918 01 D+0 / 1592 DATA BK1CS( 3) / -.1226111808 2265714823 4790679300 42 D+0 / 1593 DATA BK1CS( 4) / -.6975723859 6398643501 8129202960 83 D-2 / 1594 DATA BK1CS( 5) / -.1730288957 5130520630 1765073689 79 D-3 / 1595 DATA BK1CS( 6) / -.2433406141 5659682349 6007350301 64 D-5 / 1596 DATA BK1CS( 7) / -.2213387630 7347258558 3152525451 26 D-7 / 1597 DATA BK1CS( 8) / -.1411488392 6335277610 9583302126 08 D-9 / 1598 DATA BK1CS( 9) / -.6666901694 1993290060 8537512643 73 D-12 / 1599 DATA BK1CS( 10) / -.2427449850 5193659339 2631968648 53 D-14 / 1600 DATA BK1CS( 11) / -.7023863479 3862875971 7837971200 00 D-17 / 1601 DATA BK1CS( 12) / -.1654327515 5100994675 4910293333 33 D-19 / 1602 DATA BK1CS( 13) / -.3233834745 9944491991 8933333333 33 D-22 / 1603 DATA BK1CS( 14) / -.5331275052 9265274999 4666666666 66 D-25 / 1604 DATA BK1CS( 15) / -.7513040716 2157226666 6666666666 66 D-28 / 1605 DATA BK1CS( 16) / -.9155085717 6541866666 6666666666 66 D-31 / 1606 DATA FIRST /.TRUE./ 1607C***FIRST EXECUTABLE STATEMENT DBESK1 1608 IF (FIRST) THEN 1609 NTK1 = INITDS (BK1CS, 16, 0.1*REAL(D1MACH(3))) 1610 XMIN = EXP(MAX(LOG(D1MACH(1)), -LOG(D1MACH(2))) + 0.01D0) 1611 XSML = SQRT(4.0D0*D1MACH(3)) 1612 XMAXT = -LOG(D1MACH(1)) 1613 XMAX = XMAXT - 0.5D0*XMAXT*LOG(XMAXT)/(XMAXT+0.5D0) 1614 ENDIF 1615 FIRST = .FALSE. 1616C 1617CCCCC IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'DBESK1', 1618CCCCC+ 'X IS ZERO OR NEGATIVE', 2, 2) 1619 IF (X .LE. 0.D0) THEN 1620 WRITE(ICOUT,1) 1621 1 FORMAT('***** ERORR FROM DBESK1, X ZERO OR NEGATIVE.') 1622 CALL DPWRST('XXX','BUG ') 1623 DBESK1=0.0D0 1624 RETURN 1625 ENDIF 1626 IF (X.GT.2.0D0) GO TO 20 1627C 1628CCCCC IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'DBESK1', 1629CCCCC+ 'X SO SMALL K1 OVERFLOWS', 3, 2) 1630 IF (X .LE. XMIN) THEN 1631 WRITE(ICOUT,2) 1632 CALL DPWRST('XXX','BUG ') 1633 ENDIF 1634 2 FORMAT('***** WARNING FROM DBESK1, UNDERFLOW BECAUSE THE ', 1635 1 'VALUE OF X IS SO SMALL.') 1636 Y = 0.D0 1637 IF (X.GT.XSML) Y = X*X 1638 DBESK1 = LOG(0.5D0*X)*DBESI1(X) + (0.75D0 + DCSEVL (.5D0*Y-1.D0, 1639 1 BK1CS, NTK1))/X 1640 RETURN 1641C 1642 20 DBESK1 = 0.D0 1643CCCCC IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'DBESK1', 1644CCCCC+ 'X SO BIG K1 UNDERFLOWS', 1, 1) 1645 IF (X.GT.XMAX) THEN 1646 WRITE(ICOUT,3) 1647 CALL DPWRST('XXX','BUG ') 1648 DBESK1 = 0.0D0 1649 RETURN 1650 ENDIF 1651 3 FORMAT('***** ERORR FROM DBESK1, UNDERFLOW BECAUSE THE ', 1652 1 'VALUE OF X IS TOO BIG.') 1653 IF (X.GT.XMAX) RETURN 1654C 1655 DBESK1 = EXP(-X) * DBSK1E(X) 1656C 1657 RETURN 1658 END 1659 DOUBLE PRECISION FUNCTION DBINOM(N,M) 1660C***BEGIN PROLOGUE DBINOM 1661C***DATE WRITTEN 770601 (YYMMDD) 1662C***REVISION DATE 820801 (YYMMDD) 1663C***CATEGORY NO. C1 1664C***KEYWORDS BINOMIAL COEFFICIENTS,DOUBLE PRECISION,SPECIAL FUNCTION 1665C***AUTHOR FULLERTON, W., (LANL) 1666C***PURPOSE Computes the d.p. binomial coefficients. 1667C***DESCRIPTION 1668C 1669C DBINOM(N,M) calculates the double precision binomial coefficient 1670C for integer arguments N and M. The result is (N!)/((M!)(N-M)!). 1671C***REFERENCES (NONE) 1672C***ROUTINES CALLED D1MACH,D9LGMC,DINT,DLNREL,XERROR 1673C***END PROLOGUE DBINOM 1674 DOUBLE PRECISION CORR, FINTMX, SQ2PIL, XK, XN, XNK, DINT, D9LGMC, 1675 1 DLNREL 1676 REAL BILNMX 1677 INCLUDE 'DPCOMC.INC' 1678 INCLUDE 'DPCOP2.INC' 1679C 1680 DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / 1681 DATA BILNMX, FINTMX / 0.0, 0.0D0 / 1682C***FIRST EXECUTABLE STATEMENT DBINOM 1683C 1684 DBINOM = 0.0D0 1685C 1686 IF (BILNMX.NE.0.0) GO TO 10 1687 BILNMX = DLOG(D1MACH(2)) - 0.0001D0 1688 FINTMX = 0.9D0/D1MACH(3) 1689C 1690 10 CONTINUE 1691 IF(N.LT.0)THEN 1692 WRITE(ICOUT,1) 1693 1 FORMAT('***** ERROR: FIRST ARGUMENT TO BINOM IS NEGATIVE.') 1694 CALL DPWRST('XXX','BUG ') 1695 GOTO9000 1696 ENDIF 1697 IF(M.LT.0)THEN 1698 WRITE(ICOUT,2) 1699 2 FORMAT('***** ERROR: SECOND ARGUMENT TO BINOM IS NEGATIVE.') 1700 CALL DPWRST('XXX','BUG ') 1701 GOTO9000 1702 ENDIF 1703C 1704 K = MIN0 (M, N-M) 1705 IF (K.GT.20) GO TO 30 1706CCCCC IF (FLOAT(K)*LOG(AMAX0(N,1)).GT.BILNMX) GO TO 30 1707 IF (FLOAT(K)*LOG(AMAX0(N,1)).GT.BILNMX) GO TO 30 1708C 1709 DBINOM = 1.0D0 1710 IF (K.EQ.0) GOTO9000 1711 DO 20 I=1,K 1712 XN = N - I + 1 1713 XK = I 1714 DBINOM = DBINOM * (XN/XK) 1715 20 CONTINUE 1716C 1717 IF (DBINOM.LT.FINTMX) DBINOM = DINT (DBINOM+0.5D0) 1718 GOTO9000 1719C 1720C IF K.LT.9, APPROX IS NOT VALID AND ANSWER IS CLOSE TO THE OVERFLOW LIM 1721 30 CONTINUE 1722 IF (K.LT.9) THEN 1723 WRITE(ICOUT,31) 1724 31 FORMAT('***** ERROR: BINOM OVERFLOWS BECAUSE ONE (OR BOTH) OF ', 1725 1 'THE ARGUMENTS IS TOO LARGE.') 1726 CALL DPWRST('XXX','BUG ') 1727 GOTO9000 1728 ENDIF 1729C 1730 XN = N + 1 1731 XK = K + 1 1732 XNK = N - K + 1 1733C 1734 CORR = D9LGMC(XN) - D9LGMC(XK) - D9LGMC(XNK) 1735 DBINOM = XK*DLOG(XNK/XK) - XN*DLNREL(-(XK-1.0D0)/XN) 1736 1 -0.5D0*DLOG(XN*XNK/XK) + 1.0D0 - SQ2PIL + CORR 1737C 1738 IF (DBINOM.GT.DBLE(BILNMX)) THEN 1739C 1740 WRITE(ICOUT,41) 1741 41 FORMAT('***** ERROR: BINOM OVERFLOWS BECAUSE ONE (OR BOTH) OF ', 1742 1 'THE ARGUMENTS IS TOO LARGE.') 1743 CALL DPWRST('XXX','BUG ') 1744 GOTO9000 1745 ENDIF 1746C 1747 DBINOM = DEXP (DBINOM) 1748 IF (DBINOM.LT.FINTMX) DBINOM = DINT (DBINOM+0.5D0) 1749C 1750 9000 CONTINUE 1751 RETURN 1752 END 1753 DOUBLE PRECISION FUNCTION DBINLN(N,M) 1754C***BEGIN PROLOGUE DBINOM 1755C***DATE WRITTEN 770601 (YYMMDD) 1756C***REVISION DATE 820801 (YYMMDD) 1757C***REVISION HISTORY (YYMMDD) 1758C 000601 Changed DINT to generic AINT (RFB) 1759C***CATEGORY NO. C1 1760C***KEYWORDS BINOMIAL COEFFICIENTS,DOUBLE PRECISION,SPECIAL FUNCTION 1761C***AUTHOR FULLERTON, W., (LANL) 1762C***PURPOSE Computes the d.p. binomial coefficients. 1763C***DESCRIPTION 1764C 1765C DBINOM(N,M) calculates the double precision binomial coefficient 1766C for integer arguments N and M. The result is (N!)/((M!)(N-M)!). 1767C***REFERENCES (NONE) 1768C***ROUTINES CALLED D1MACH,D9LGMC,AINT,DLNREL,XERROR 1769C***END PROLOGUE DBINOM 1770C 1771C NOTE: THIS IS THE BBINOM ROUTINE MODIFIED TO RETURN THE 1772C LOG OF THE BINOMIAL COEFFICIENT. 1773C 1774C THIS IS USED INTERNALLY FOR SOME DISCRETE PROBABILITY 1775C DISTRIBUTIONS. 1776C 1777 DOUBLE PRECISION CORR, FINTMX, SQ2PIL, XK, XN, XNK, D9LGMC, 1778 1 DLNREL 1779 REAL BILNMX 1780C 1781 INCLUDE 'DPCOMC.INC' 1782 INCLUDE 'DPCOP2.INC' 1783C 1784 DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / 1785 DATA BILNMX, FINTMX / 0.0, 0.0D0 / 1786C***FIRST EXECUTABLE STATEMENT DBINOM 1787C 1788 DBINLN = 0.0D0 1789C 1790 IF (BILNMX.NE.0.0) GO TO 10 1791 BILNMX = DLOG(D1MACH(2)) - 0.0001D0 1792 FINTMX = 0.9D0/D1MACH(3) 1793C 1794 10 CONTINUE 1795 IF(N.LT.0)THEN 1796 WRITE(ICOUT,1) 1797 1 FORMAT('***** ERROR: FIRST ARGUMENT TO DBINOM IS NEGATIVE.') 1798 CALL DPWRST('XXX','BUG ') 1799 GOTO9000 1800 ENDIF 1801 IF(M.LT.0)THEN 1802 WRITE(ICOUT,2) 1803 2 FORMAT('***** ERROR: SECOND ARGUMENT TO DBINOM IS NEGATIVE.') 1804 CALL DPWRST('XXX','BUG ') 1805 GOTO9000 1806 ENDIF 1807 IF (N.LT.M) THEN 1808 WRITE(ICOUT,3) 1809 3 FORMAT('***** ERROR: FIRST ARGUMENT TO DBINOM IS LESS THAN ', 1810 1 'SECOND ARGUMENT.') 1811 CALL DPWRST('XXX','BUG ') 1812 GOTO9000 1813 ENDIF 1814C 1815C10 IF (N.LT.0 .OR. M.LT.0) CALL XERROR ( 'DBINOM N OR M LT ZERO', 22 1816CCCCC1, 1, 2) 1817CCCCC IF (N.LT.M) CALL XERROR ( 'DBINOM N LT M', 14, 2, 2) 1818C 1819 K = MIN0 (M, N-M) 1820 IF (K.GT.20) GO TO 30 1821 IF (FLOAT(K)*LOG(AMAX0(N,1)).GT.BILNMX) GO TO 30 1822C 1823 DBINLN = DLOG(1.0D0) 1824 IF (K.EQ.0) RETURN 1825 DO 20 I=1,K 1826 XN = N - I + 1 1827 XK = I 1828 DBINLN = DBINLN + DLOG((XN/XK)) 1829 20 CONTINUE 1830C 1831CCCCC IF (DBINLN.LT.FINTMX) DBINLN = AINT (DBINLN+0.5D0) 1832 RETURN 1833C 1834C IF K.LT.9, APPROX IS NOT VALID AND ANSWER IS CLOSE TO THE OVERFLOW LIM 1835 30 CONTINUE 1836 IF (K.LT.9) THEN 1837 WRITE(ICOUT,31) 1838 31 FORMAT('***** ERROR: BINOM OVERFLOWS BECAUSE ONE (OR BOTH) OF ', 1839 1 'THE ARGUMENTS IS TOO LARGE.') 1840 CALL DPWRST('XXX','BUG ') 1841 GOTO9000 1842 ENDIF 1843C 1844C30 IF (K.LT.9) CALL XERROR( 'DBINOM RESULT OVERFLOWS BECAUSE N AND/O 1845CCCCC1R M TOO BIG', 51, 3, 2) 1846C 1847 XN = N + 1 1848 XK = K + 1 1849 XNK = N - K + 1 1850C 1851 CORR = D9LGMC(XN) - D9LGMC(XK) - D9LGMC(XNK) 1852 DBINLN = XK*DLOG(XNK/XK) - XN*DLNREL(-(XK-1.0D0)/XN) 1853 1 -0.5D0*DLOG(XN*XNK/XK) + 1.0D0 - SQ2PIL + CORR 1854C 1855CCCCC IF (DBINOM.GT.DBLE(BILNMX)) CALL XERROR ( 'DBINOM RESULT OVERFLOW 1856CCCCC1S BECAUSE N AND/OR M TOO BIG', 51, 3,2) 1857CCCCC IF (DBINOM.GT.BILNMX) THEN 1858C 1859CCCCC WRITE(ICOUT,41) 1860C41 FORMAT('***** ERROR: DBINOM OVERFLOWS BECAUSE ONE (OR BOTH) ', 1861CCCCC1 'OF THE ARGUMENTS IS TOO LARGE.') 1862CCCCC CALL DPWRST('XXX','BUG ') 1863CCCCC GOTO9000 1864CCCCC ENDIF 1865C 1866CCCCC DBINOM = DEXP (DBINLN) 1867CCCCC IF (DBINOM.LT.FINTMX) DBINOM = AINT (DBINOM+0.5D0) 1868C 1869 9000 CONTINUE 1870 RETURN 1871 END 1872 DOUBLE PRECISION FUNCTION DBSI0E (X) 1873C***BEGIN PROLOGUE DBSI0E 1874C***PURPOSE Compute the exponentially scaled modified (hyperbolic) 1875C Bessel function of the first kind of order zero. 1876C***LIBRARY SLATEC (FNLIB) 1877C***CATEGORY C10B1 1878C***TYPE DOUBLE PRECISION (BESI0E-S, DBSI0E-D) 1879C***KEYWORDS EXPONENTIALLY SCALED, FIRST KIND, FNLIB, 1880C HYPERBOLIC BESSEL FUNCTION, MODIFIED BESSEL FUNCTION, 1881C ORDER ZERO, SPECIAL FUNCTIONS 1882C***AUTHOR Fullerton, W., (LANL) 1883C***DESCRIPTION 1884C 1885C DBSI0E(X) calculates the double precision exponentially scaled 1886C modified (hyperbolic) Bessel function of the first kind of order 1887C zero for double precision argument X. The result is the Bessel 1888C function I0(X) multiplied by EXP(-ABS(X)). 1889C 1890C Series for BI0 on the interval 0. to 9.00000E+00 1891C with weighted error 9.51E-34 1892C log weighted error 33.02 1893C significant figures required 33.31 1894C decimal places required 33.65 1895C 1896C Series for AI0 on the interval 1.25000E-01 to 3.33333E-01 1897C with weighted error 2.74E-32 1898C log weighted error 31.56 1899C significant figures required 30.15 1900C decimal places required 32.39 1901C 1902C Series for AI02 on the interval 0. to 1.25000E-01 1903C with weighted error 1.97E-32 1904C log weighted error 31.71 1905C significant figures required 30.15 1906C decimal places required 32.63 1907C 1908C***REFERENCES (NONE) 1909C***ROUTINES CALLED D1MACH, DCSEVL, INITDS 1910C***REVISION HISTORY (YYMMDD) 1911C 770701 DATE WRITTEN 1912C 890531 Changed all specific intrinsics to generic. (WRB) 1913C 890531 REVISION DATE from Version 3.2 1914C 891214 Prologue converted to Version 4.0 format. (BAB) 1915C***END PROLOGUE DBSI0E 1916C 1917C-----COMMON---------------------------------------------------------- 1918C 1919 INCLUDE 'DPCOMC.INC' 1920 INCLUDE 'DPCOP2.INC' 1921C 1922 DOUBLE PRECISION X, BI0CS(18), AI0CS(46), AI02CS(69), 1923 1 XSML, Y, DCSEVL 1924 LOGICAL FIRST 1925 SAVE BI0CS, AI0CS, AI02CS, NTI0, NTAI0, NTAI02, XSML, FIRST 1926 DATA BI0CS( 1) / -.7660547252 8391449510 8189497624 3285 D-1 / 1927 DATA BI0CS( 2) / +.1927337953 9938082699 5240875088 1196 D+1 / 1928 DATA BI0CS( 3) / +.2282644586 9203013389 3702929233 0415 D+0 / 1929 DATA BI0CS( 4) / +.1304891466 7072904280 7933421069 1888 D-1 / 1930 DATA BI0CS( 5) / +.4344270900 8164874513 7868268102 6107 D-3 / 1931 DATA BI0CS( 6) / +.9422657686 0019346639 2317174411 8766 D-5 / 1932 DATA BI0CS( 7) / +.1434006289 5106910799 6209187817 9957 D-6 / 1933 DATA BI0CS( 8) / +.1613849069 6617490699 1541971999 4611 D-8 / 1934 DATA BI0CS( 9) / +.1396650044 5356696994 9509270814 2522 D-10 / 1935 DATA BI0CS( 10) / +.9579451725 5054453446 2752317189 3333 D-13 / 1936 DATA BI0CS( 11) / +.5333981859 8625021310 1510774400 0000 D-15 / 1937 DATA BI0CS( 12) / +.2458716088 4374707746 9678591999 9999 D-17 / 1938 DATA BI0CS( 13) / +.9535680890 2487700269 4434133333 3333 D-20 / 1939 DATA BI0CS( 14) / +.3154382039 7214273367 8933333333 3333 D-22 / 1940 DATA BI0CS( 15) / +.9004564101 0946374314 6666666666 6666 D-25 / 1941 DATA BI0CS( 16) / +.2240647369 1236700160 0000000000 0000 D-27 / 1942 DATA BI0CS( 17) / +.4903034603 2428373333 3333333333 3333 D-30 / 1943 DATA BI0CS( 18) / +.9508172606 1226666666 6666666666 6666 D-33 / 1944 DATA AI0CS( 1) / +.7575994494 0237959427 2987203743 8 D-1 / 1945 DATA AI0CS( 2) / +.7591380810 8233455072 9297873320 4 D-2 / 1946 DATA AI0CS( 3) / +.4153131338 9237505018 6319749138 2 D-3 / 1947 DATA AI0CS( 4) / +.1070076463 4390730735 8242970217 0 D-4 / 1948 DATA AI0CS( 5) / -.7901179979 2128946607 5031948573 0 D-5 / 1949 DATA AI0CS( 6) / -.7826143501 4387522697 8898980690 9 D-6 / 1950 DATA AI0CS( 7) / +.2783849942 9488708063 8118538985 7 D-6 / 1951 DATA AI0CS( 8) / +.8252472600 6120271919 6682913319 8 D-8 / 1952 DATA AI0CS( 9) / -.1204463945 5201991790 5496089110 3 D-7 / 1953 DATA AI0CS( 10) / +.1559648598 5060764436 1228752792 8 D-8 / 1954 DATA AI0CS( 11) / +.2292556367 1033165434 7725480285 7 D-9 / 1955 DATA AI0CS( 12) / -.1191622884 2790646036 7777423447 8 D-9 / 1956 DATA AI0CS( 13) / +.1757854916 0324098302 1833124774 3 D-10 / 1957 DATA AI0CS( 14) / +.1128224463 2189005171 4441135682 4 D-11 / 1958 DATA AI0CS( 15) / -.1146848625 9272988777 2963387698 2 D-11 / 1959 DATA AI0CS( 16) / +.2715592054 8036628726 4365192160 6 D-12 / 1960 DATA AI0CS( 17) / -.2415874666 5626878384 4247572028 1 D-13 / 1961 DATA AI0CS( 18) / -.6084469888 2551250646 0609963922 4 D-14 / 1962 DATA AI0CS( 19) / +.3145705077 1754772937 0836026730 3 D-14 / 1963 DATA AI0CS( 20) / -.7172212924 8711877179 6217505917 6 D-15 / 1964 DATA AI0CS( 21) / +.7874493403 4541033960 8390960332 7 D-16 / 1965 DATA AI0CS( 22) / +.1004802753 0094624023 4524457183 9 D-16 / 1966 DATA AI0CS( 23) / -.7566895365 3505348534 2843588881 0 D-17 / 1967 DATA AI0CS( 24) / +.2150380106 8761198878 1205128784 5 D-17 / 1968 DATA AI0CS( 25) / -.3754858341 8308744291 5158445260 8 D-18 / 1969 DATA AI0CS( 26) / +.2354065842 2269925769 0075710532 2 D-19 / 1970 DATA AI0CS( 27) / +.1114667612 0479285302 2637335511 0 D-19 / 1971 DATA AI0CS( 28) / -.5398891884 3969903786 9677932270 9 D-20 / 1972 DATA AI0CS( 29) / +.1439598792 2407526770 4285840452 2 D-20 / 1973 DATA AI0CS( 30) / -.2591916360 1110934064 6081840196 2 D-21 / 1974 DATA AI0CS( 31) / +.2238133183 9985839074 3409229824 0 D-22 / 1975 DATA AI0CS( 32) / +.5250672575 3647711727 7221683199 9 D-23 / 1976 DATA AI0CS( 33) / -.3249904138 5332307841 7343228586 6 D-23 / 1977 DATA AI0CS( 34) / +.9924214103 2050379278 5728471040 0 D-24 / 1978 DATA AI0CS( 35) / -.2164992254 2446695231 4655429973 3 D-24 / 1979 DATA AI0CS( 36) / +.3233609471 9435940839 7333299199 9 D-25 / 1980 DATA AI0CS( 37) / -.1184620207 3967424898 2473386666 6 D-26 / 1981 DATA AI0CS( 38) / -.1281671853 9504986505 4833868799 9 D-26 / 1982 DATA AI0CS( 39) / +.5827015182 2793905116 0556885333 3 D-27 / 1983 DATA AI0CS( 40) / -.1668222326 0261097193 6450150399 9 D-27 / 1984 DATA AI0CS( 41) / +.3625309510 5415699757 0068480000 0 D-28 / 1985 DATA AI0CS( 42) / -.5733627999 0557135899 4595839999 9 D-29 / 1986 DATA AI0CS( 43) / +.3736796722 0630982296 4258133333 3 D-30 / 1987 DATA AI0CS( 44) / +.1602073983 1568519633 6551253333 3 D-30 / 1988 DATA AI0CS( 45) / -.8700424864 0572298845 2249599999 9 D-31 / 1989 DATA AI0CS( 46) / +.2741320937 9374811456 0341333333 3 D-31 / 1990 DATA AI02CS( 1) / +.5449041101 4108831607 8960962268 0 D-1 / 1991 DATA AI02CS( 2) / +.3369116478 2556940898 9785662979 9 D-2 / 1992 DATA AI02CS( 3) / +.6889758346 9168239842 6263914301 1 D-4 / 1993 DATA AI02CS( 4) / +.2891370520 8347564829 6692402323 2 D-5 / 1994 DATA AI02CS( 5) / +.2048918589 4690637418 2760534093 1 D-6 / 1995 DATA AI02CS( 6) / +.2266668990 4981780645 9327743136 1 D-7 / 1996 DATA AI02CS( 7) / +.3396232025 7083863451 5084396952 3 D-8 / 1997 DATA AI02CS( 8) / +.4940602388 2249695891 0482449783 5 D-9 / 1998 DATA AI02CS( 9) / +.1188914710 7846438342 4084525196 3 D-10 / 1999 DATA AI02CS( 10) / -.3149916527 9632413645 3864862961 9 D-10 / 2000 DATA AI02CS( 11) / -.1321581184 0447713118 7540739926 7 D-10 / 2001 DATA AI02CS( 12) / -.1794178531 5068061177 7943574026 9 D-11 / 2002 DATA AI02CS( 13) / +.7180124451 3836662336 7106429346 9 D-12 / 2003 DATA AI02CS( 14) / +.3852778382 7421427011 4089801777 6 D-12 / 2004 DATA AI02CS( 15) / +.1540086217 5214098269 1325823339 7 D-13 / 2005 DATA AI02CS( 16) / -.4150569347 2872220866 2689972015 6 D-13 / 2006 DATA AI02CS( 17) / -.9554846698 8283076487 0214494312 5 D-14 / 2007 DATA AI02CS( 18) / +.3811680669 3526224207 4605535511 8 D-14 / 2008 DATA AI02CS( 19) / +.1772560133 0565263836 0493266675 8 D-14 / 2009 DATA AI02CS( 20) / -.3425485619 6772191346 1924790328 2 D-15 / 2010 DATA AI02CS( 21) / -.2827623980 5165834849 4205593759 4 D-15 / 2011 DATA AI02CS( 22) / +.3461222867 6974610930 9706250813 4 D-16 / 2012 DATA AI02CS( 23) / +.4465621420 2967599990 1042054284 3 D-16 / 2013 DATA AI02CS( 24) / -.4830504485 9441820712 5525403795 4 D-17 / 2014 DATA AI02CS( 25) / -.7233180487 8747539545 6227240924 5 D-17 / 2015 DATA AI02CS( 26) / +.9921475412 1736985988 8046093981 0 D-18 / 2016 DATA AI02CS( 27) / +.1193650890 8459820855 0439949924 2 D-17 / 2017 DATA AI02CS( 28) / -.2488709837 1508072357 2054491660 2 D-18 / 2018 DATA AI02CS( 29) / -.1938426454 1609059289 8469781132 6 D-18 / 2019 DATA AI02CS( 30) / +.6444656697 3734438687 8301949394 9 D-19 / 2020 DATA AI02CS( 31) / +.2886051596 2892243264 8171383073 4 D-19 / 2021 DATA AI02CS( 32) / -.1601954907 1749718070 6167156200 7 D-19 / 2022 DATA AI02CS( 33) / -.3270815010 5923147208 9193567485 9 D-20 / 2023 DATA AI02CS( 34) / +.3686932283 8264091811 4600723939 3 D-20 / 2024 DATA AI02CS( 35) / +.1268297648 0309501530 1359529710 9 D-22 / 2025 DATA AI02CS( 36) / -.7549825019 3772739076 9636664410 1 D-21 / 2026 DATA AI02CS( 37) / +.1502133571 3778353496 3712789053 4 D-21 / 2027 DATA AI02CS( 38) / +.1265195883 5096485349 3208799248 3 D-21 / 2028 DATA AI02CS( 39) / -.6100998370 0836807086 2940891600 2 D-22 / 2029 DATA AI02CS( 40) / -.1268809629 2601282643 6872095924 2 D-22 / 2030 DATA AI02CS( 41) / +.1661016099 8907414578 4038487490 5 D-22 / 2031 DATA AI02CS( 42) / -.1585194335 7658855793 7970504881 4 D-23 / 2032 DATA AI02CS( 43) / -.3302645405 9682178009 5381766755 6 D-23 / 2033 DATA AI02CS( 44) / +.1313580902 8392397817 4039623117 4 D-23 / 2034 DATA AI02CS( 45) / +.3689040246 6711567933 1425637280 4 D-24 / 2035 DATA AI02CS( 46) / -.4210141910 4616891492 1978247249 9 D-24 / 2036 DATA AI02CS( 47) / +.4791954591 0828657806 3171401373 0 D-25 / 2037 DATA AI02CS( 48) / +.8459470390 2218217952 9971707412 4 D-25 / 2038 DATA AI02CS( 49) / -.4039800940 8728324931 4607937181 0 D-25 / 2039 DATA AI02CS( 50) / -.6434714653 6504313473 0100850469 5 D-26 / 2040 DATA AI02CS( 51) / +.1225743398 8756659903 4464736990 5 D-25 / 2041 DATA AI02CS( 52) / -.2934391316 0257089231 9879821175 4 D-26 / 2042 DATA AI02CS( 53) / -.1961311309 1949829262 0371205728 9 D-26 / 2043 DATA AI02CS( 54) / +.1503520374 8221934241 6229900309 8 D-26 / 2044 DATA AI02CS( 55) / -.9588720515 7448265520 3386388206 9 D-28 / 2045 DATA AI02CS( 56) / -.3483339380 8170454863 9441108511 4 D-27 / 2046 DATA AI02CS( 57) / +.1690903610 2630436730 6244960725 6 D-27 / 2047 DATA AI02CS( 58) / +.1982866538 7356030438 9400115718 8 D-28 / 2048 DATA AI02CS( 59) / -.5317498081 4918162145 7583002528 4 D-28 / 2049 DATA AI02CS( 60) / +.1803306629 8883929462 3501450390 1 D-28 / 2050 DATA AI02CS( 61) / +.6213093341 4548931758 8405311242 2 D-29 / 2051 DATA AI02CS( 62) / -.7692189292 7721618632 0072806673 0 D-29 / 2052 DATA AI02CS( 63) / +.1858252826 1117025426 2556016596 3 D-29 / 2053 DATA AI02CS( 64) / +.1237585142 2813957248 9927154554 1 D-29 / 2054 DATA AI02CS( 65) / -.1102259120 4092238032 1779478779 2 D-29 / 2055 DATA AI02CS( 66) / +.1886287118 0397044900 7787447943 1 D-30 / 2056 DATA AI02CS( 67) / +.2160196872 2436589131 4903141406 0 D-30 / 2057 DATA AI02CS( 68) / -.1605454124 9197432005 8446594965 5 D-30 / 2058 DATA AI02CS( 69) / +.1965352984 5942906039 3884807331 8 D-31 / 2059 DATA FIRST /.TRUE./ 2060C 2061 DBSI0E = 0.0D0 2062C 2063C***FIRST EXECUTABLE STATEMENT DBSI0E 2064 IF (FIRST) THEN 2065 ETA = 0.1*REAL(D1MACH(3)) 2066 NTI0 = INITDS (BI0CS, 18, ETA) 2067 NTAI0 = INITDS (AI0CS, 46, ETA) 2068 NTAI02 = INITDS (AI02CS, 69, ETA) 2069 XSML = SQRT(4.5D0*D1MACH(3)) 2070 ENDIF 2071 FIRST = .FALSE. 2072C 2073 Y = ABS(X) 2074 IF (Y.GT.3.0D0) GO TO 20 2075C 2076 DBSI0E = 1.0D0 - X 2077 IF (Y.GT.XSML) DBSI0E = EXP(-Y) * (2.75D0 + 2078 1 DCSEVL (Y*Y/4.5D0-1.D0, BI0CS, NTI0) ) 2079 RETURN 2080C 2081 20 IF (Y.LE.8.D0) DBSI0E = (0.375D0 + DCSEVL ((48.D0/Y-11.D0)/5.D0, 2082 1 AI0CS, NTAI0))/SQRT(Y) 2083 IF (Y.GT.8.D0) DBSI0E = (0.375D0 + DCSEVL (16.D0/Y-1.D0, AI02CS, 2084 1 NTAI02))/SQRT(Y) 2085C 2086 RETURN 2087 END 2088 DOUBLE PRECISION FUNCTION DBSI1E (X) 2089C***BEGIN PROLOGUE DBSI1E 2090C***PURPOSE Compute the exponentially scaled modified (hyperbolic) 2091C Bessel function of the first kind of order one. 2092C***LIBRARY SLATEC (FNLIB) 2093C***CATEGORY C10B1 2094C***TYPE DOUBLE PRECISION (BESI1E-S, DBSI1E-D) 2095C***KEYWORDS EXPONENTIALLY SCALED, FIRST KIND, FNLIB, 2096C HYPERBOLIC BESSEL FUNCTION, MODIFIED BESSEL FUNCTION, 2097C ORDER ONE, SPECIAL FUNCTIONS 2098C***AUTHOR Fullerton, W., (LANL) 2099C***DESCRIPTION 2100C 2101C DBSI1E(X) calculates the double precision exponentially scaled 2102C modified (hyperbolic) Bessel function of the first kind of order 2103C one for double precision argument X. The result is I1(X) 2104C multiplied by EXP(-ABS(X)). 2105C 2106C Series for BI1 on the interval 0. to 9.00000E+00 2107C with weighted error 1.44E-32 2108C log weighted error 31.84 2109C significant figures required 31.45 2110C decimal places required 32.46 2111C 2112C Series for AI1 on the interval 1.25000E-01 to 3.33333E-01 2113C with weighted error 2.81E-32 2114C log weighted error 31.55 2115C significant figures required 29.93 2116C decimal places required 32.38 2117C 2118C Series for AI12 on the interval 0. to 1.25000E-01 2119C with weighted error 1.83E-32 2120C log weighted error 31.74 2121C significant figures required 29.97 2122C decimal places required 32.66 2123C 2124C***REFERENCES (NONE) 2125C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG 2126C***REVISION HISTORY (YYMMDD) 2127C 770701 DATE WRITTEN 2128C 890531 Changed all specific intrinsics to generic. (WRB) 2129C 890531 REVISION DATE from Version 3.2 2130C 891214 Prologue converted to Version 4.0 format. (BAB) 2131C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 2132C***END PROLOGUE DBSI1E 2133C 2134C-----COMMON---------------------------------------------------------- 2135C 2136 INCLUDE 'DPCOMC.INC' 2137 INCLUDE 'DPCOP2.INC' 2138C 2139 DOUBLE PRECISION X, BI1CS(17), AI1CS(46), AI12CS(69), XMIN, 2140 1 XSML, Y, DCSEVL 2141 LOGICAL FIRST 2142 SAVE BI1CS, AI1CS, AI12CS, NTI1, NTAI1, NTAI12, XMIN, XSML, 2143 1 FIRST 2144 DATA BI1CS( 1) / -.1971713261 0998597316 1385032181 49 D-2 / 2145 DATA BI1CS( 2) / +.4073488766 7546480608 1553936520 14 D+0 / 2146 DATA BI1CS( 3) / +.3483899429 9959455866 2450377837 87 D-1 / 2147 DATA BI1CS( 4) / +.1545394556 3001236038 5984010584 89 D-2 / 2148 DATA BI1CS( 5) / +.4188852109 8377784129 4588320041 20 D-4 / 2149 DATA BI1CS( 6) / +.7649026764 8362114741 9597039660 69 D-6 / 2150 DATA BI1CS( 7) / +.1004249392 4741178689 1798080372 38 D-7 / 2151 DATA BI1CS( 8) / +.9932207791 9238106481 3712980548 63 D-10 / 2152 DATA BI1CS( 9) / +.7663801791 8447637275 2001716813 49 D-12 / 2153 DATA BI1CS( 10) / +.4741418923 8167394980 3880919481 60 D-14 / 2154 DATA BI1CS( 11) / +.2404114404 0745181799 8631720320 00 D-16 / 2155 DATA BI1CS( 12) / +.1017150500 7093713649 1211007999 99 D-18 / 2156 DATA BI1CS( 13) / +.3645093565 7866949458 4917333333 33 D-21 / 2157 DATA BI1CS( 14) / +.1120574950 2562039344 8106666666 66 D-23 / 2158 DATA BI1CS( 15) / +.2987544193 4468088832 0000000000 00 D-26 / 2159 DATA BI1CS( 16) / +.6973231093 9194709333 3333333333 33 D-29 / 2160 DATA BI1CS( 17) / +.1436794822 0620800000 0000000000 00 D-31 / 2161 DATA AI1CS( 1) / -.2846744181 8814786741 0037246830 7 D-1 / 2162 DATA AI1CS( 2) / -.1922953231 4432206510 4444877497 9 D-1 / 2163 DATA AI1CS( 3) / -.6115185857 9437889822 5624991778 5 D-3 / 2164 DATA AI1CS( 4) / -.2069971253 3502277088 8282377797 9 D-4 / 2165 DATA AI1CS( 5) / +.8585619145 8107255655 3694467313 8 D-5 / 2166 DATA AI1CS( 6) / +.1049498246 7115908625 1745399786 0 D-5 / 2167 DATA AI1CS( 7) / -.2918338918 4479022020 9343232669 7 D-6 / 2168 DATA AI1CS( 8) / -.1559378146 6317390001 6068096907 7 D-7 / 2169 DATA AI1CS( 9) / +.1318012367 1449447055 2530287390 9 D-7 / 2170 DATA AI1CS( 10) / -.1448423418 1830783176 3913446781 5 D-8 / 2171 DATA AI1CS( 11) / -.2908512243 9931420948 2504099301 0 D-9 / 2172 DATA AI1CS( 12) / +.1266388917 8753823873 1115969040 3 D-9 / 2173 DATA AI1CS( 13) / -.1664947772 9192206706 2417839858 0 D-10 / 2174 DATA AI1CS( 14) / -.1666653644 6094329760 9593715499 9 D-11 / 2175 DATA AI1CS( 15) / +.1242602414 2907682652 3216847201 7 D-11 / 2176 DATA AI1CS( 16) / -.2731549379 6724323972 5146142863 3 D-12 / 2177 DATA AI1CS( 17) / +.2023947881 6458037807 0026268898 1 D-13 / 2178 DATA AI1CS( 18) / +.7307950018 1168836361 9869812612 3 D-14 / 2179 DATA AI1CS( 19) / -.3332905634 4046749438 1377861713 3 D-14 / 2180 DATA AI1CS( 20) / +.7175346558 5129537435 4225466567 0 D-15 / 2181 DATA AI1CS( 21) / -.6982530324 7962563558 5062922365 6 D-16 / 2182 DATA AI1CS( 22) / -.1299944201 5627607600 6044608058 7 D-16 / 2183 DATA AI1CS( 23) / +.8120942864 2427988920 5467834286 0 D-17 / 2184 DATA AI1CS( 24) / -.2194016207 4107368981 5626664378 3 D-17 / 2185 DATA AI1CS( 25) / +.3630516170 0296548482 7986093233 4 D-18 / 2186 DATA AI1CS( 26) / -.1695139772 4391041663 0686679039 9 D-19 / 2187 DATA AI1CS( 27) / -.1288184829 8979078071 1688253822 2 D-19 / 2188 DATA AI1CS( 28) / +.5694428604 9670527801 0999107310 9 D-20 / 2189 DATA AI1CS( 29) / -.1459597009 0904800565 4550990028 7 D-20 / 2190 DATA AI1CS( 30) / +.2514546010 6757173140 8469133448 5 D-21 / 2191 DATA AI1CS( 31) / -.1844758883 1391248181 6040002901 3 D-22 / 2192 DATA AI1CS( 32) / -.6339760596 2279486419 2860979199 9 D-23 / 2193 DATA AI1CS( 33) / +.3461441102 0310111111 0814662656 0 D-23 / 2194 DATA AI1CS( 34) / -.1017062335 3713935475 9654102357 3 D-23 / 2195 DATA AI1CS( 35) / +.2149877147 0904314459 6250077866 6 D-24 / 2196 DATA AI1CS( 36) / -.3045252425 2386764017 4620617386 6 D-25 / 2197 DATA AI1CS( 37) / +.5238082144 7212859821 7763498666 6 D-27 / 2198 DATA AI1CS( 38) / +.1443583107 0893824464 1678950399 9 D-26 / 2199 DATA AI1CS( 39) / -.6121302074 8900427332 0067071999 9 D-27 / 2200 DATA AI1CS( 40) / +.1700011117 4678184183 4918980266 6 D-27 / 2201 DATA AI1CS( 41) / -.3596589107 9842441585 3521578666 6 D-28 / 2202 DATA AI1CS( 42) / +.5448178578 9484185766 5051306666 6 D-29 / 2203 DATA AI1CS( 43) / -.2731831789 6890849891 6256426666 6 D-30 / 2204 DATA AI1CS( 44) / -.1858905021 7086007157 7190399999 9 D-30 / 2205 DATA AI1CS( 45) / +.9212682974 5139334411 2776533333 3 D-31 / 2206 DATA AI1CS( 46) / -.2813835155 6535611063 7083306666 6 D-31 / 2207 DATA AI12CS( 1) / +.2857623501 8280120474 4984594846 9 D-1 / 2208 DATA AI12CS( 2) / -.9761097491 3614684077 6516445730 2 D-2 / 2209 DATA AI12CS( 3) / -.1105889387 6262371629 1256921277 5 D-3 / 2210 DATA AI12CS( 4) / -.3882564808 8776903934 5654477627 4 D-5 / 2211 DATA AI12CS( 5) / -.2512236237 8702089252 9452002212 1 D-6 / 2212 DATA AI12CS( 6) / -.2631468846 8895195068 3705236523 2 D-7 / 2213 DATA AI12CS( 7) / -.3835380385 9642370220 4500678796 8 D-8 / 2214 DATA AI12CS( 8) / -.5589743462 1965838068 6811252222 9 D-9 / 2215 DATA AI12CS( 9) / -.1897495812 3505412344 9892503323 8 D-10 / 2216 DATA AI12CS( 10) / +.3252603583 0154882385 5508067994 9 D-10 / 2217 DATA AI12CS( 11) / +.1412580743 6613781331 6336633284 6 D-10 / 2218 DATA AI12CS( 12) / +.2035628544 1470895072 2452613684 0 D-11 / 2219 DATA AI12CS( 13) / -.7198551776 2459085120 9258989044 6 D-12 / 2220 DATA AI12CS( 14) / -.4083551111 0921973182 2849963969 1 D-12 / 2221 DATA AI12CS( 15) / -.2101541842 7726643130 1984572746 2 D-13 / 2222 DATA AI12CS( 16) / +.4272440016 7119513542 9778833699 7 D-13 / 2223 DATA AI12CS( 17) / +.1042027698 4128802764 1741449994 8 D-13 / 2224 DATA AI12CS( 18) / -.3814403072 4370078047 6707253539 6 D-14 / 2225 DATA AI12CS( 19) / -.1880354775 5107824485 1273453396 3 D-14 / 2226 DATA AI12CS( 20) / +.3308202310 9209282827 3190335240 5 D-15 / 2227 DATA AI12CS( 21) / +.2962628997 6459501390 6854654205 2 D-15 / 2228 DATA AI12CS( 22) / -.3209525921 9934239587 7837353288 7 D-16 / 2229 DATA AI12CS( 23) / -.4650305368 4893583255 7128281897 9 D-16 / 2230 DATA AI12CS( 24) / +.4414348323 0717079499 4611375964 1 D-17 / 2231 DATA AI12CS( 25) / +.7517296310 8421048054 2545808029 5 D-17 / 2232 DATA AI12CS( 26) / -.9314178867 3268833756 8484784515 7 D-18 / 2233 DATA AI12CS( 27) / -.1242193275 1948909561 1678448869 7 D-17 / 2234 DATA AI12CS( 28) / +.2414276719 4548484690 0515390217 6 D-18 / 2235 DATA AI12CS( 29) / +.2026944384 0532851789 7192286069 2 D-18 / 2236 DATA AI12CS( 30) / -.6394267188 2690977870 4391988681 1 D-19 / 2237 DATA AI12CS( 31) / -.3049812452 3730958960 8488450357 1 D-19 / 2238 DATA AI12CS( 32) / +.1612841851 6514802251 3462230769 1 D-19 / 2239 DATA AI12CS( 33) / +.3560913964 3099250545 1027090462 0 D-20 / 2240 DATA AI12CS( 34) / -.3752017947 9364390796 6682800324 6 D-20 / 2241 DATA AI12CS( 35) / -.5787037427 0747993459 5198231074 1 D-22 / 2242 DATA AI12CS( 36) / +.7759997511 6481619619 8236963209 2 D-21 / 2243 DATA AI12CS( 37) / -.1452790897 2022333940 6445987408 5 D-21 / 2244 DATA AI12CS( 38) / -.1318225286 7390367021 2192275337 4 D-21 / 2245 DATA AI12CS( 39) / +.6116654862 9030707018 7999133171 7 D-22 / 2246 DATA AI12CS( 40) / +.1376279762 4271264277 3024338363 4 D-22 / 2247 DATA AI12CS( 41) / -.1690837689 9593478849 1983938230 6 D-22 / 2248 DATA AI12CS( 42) / +.1430596088 5954331539 8720108538 5 D-23 / 2249 DATA AI12CS( 43) / +.3409557828 0905940204 0536772990 2 D-23 / 2250 DATA AI12CS( 44) / -.1309457666 2707602278 4573872642 4 D-23 / 2251 DATA AI12CS( 45) / -.3940706411 2402574360 9352141755 7 D-24 / 2252 DATA AI12CS( 46) / +.4277137426 9808765808 0616679735 2 D-24 / 2253 DATA AI12CS( 47) / -.4424634830 9826068819 0028312302 9 D-25 / 2254 DATA AI12CS( 48) / -.8734113196 2307149721 1530978874 7 D-25 / 2255 DATA AI12CS( 49) / +.4045401335 6835333921 4340414242 8 D-25 / 2256 DATA AI12CS( 50) / +.7067100658 0946894656 5160771780 6 D-26 / 2257 DATA AI12CS( 51) / -.1249463344 5651052230 0286451860 5 D-25 / 2258 DATA AI12CS( 52) / +.2867392244 4034370329 7948339142 6 D-26 / 2259 DATA AI12CS( 53) / +.2044292892 5042926702 8177957421 0 D-26 / 2260 DATA AI12CS( 54) / -.1518636633 8204625683 7134680291 1 D-26 / 2261 DATA AI12CS( 55) / +.8110181098 1875758861 3227910703 7 D-28 / 2262 DATA AI12CS( 56) / +.3580379354 7735860911 2717370327 0 D-27 / 2263 DATA AI12CS( 57) / -.1692929018 9279025095 9305717544 8 D-27 / 2264 DATA AI12CS( 58) / -.2222902499 7024276390 6775852777 4 D-28 / 2265 DATA AI12CS( 59) / +.5424535127 1459696550 4860040112 8 D-28 / 2266 DATA AI12CS( 60) / -.1787068401 5780186887 6491299330 4 D-28 / 2267 DATA AI12CS( 61) / -.6565479068 7228149388 2392943788 0 D-29 / 2268 DATA AI12CS( 62) / +.7807013165 0611452809 2206770683 9 D-29 / 2269 DATA AI12CS( 63) / -.1816595260 6689797173 7933315222 1 D-29 / 2270 DATA AI12CS( 64) / -.1287704952 6600848203 7687559895 9 D-29 / 2271 DATA AI12CS( 65) / +.1114548172 9881645474 1370927369 4 D-29 / 2272 DATA AI12CS( 66) / -.1808343145 0393369391 5936887668 7 D-30 / 2273 DATA AI12CS( 67) / -.2231677718 2037719522 3244822893 9 D-30 / 2274 DATA AI12CS( 68) / +.1619029596 0803415106 1790980361 4 D-30 / 2275 DATA AI12CS( 69) / -.1834079908 8049414139 0130843921 0 D-31 / 2276 DATA FIRST /.TRUE./ 2277C 2278 DBSI1E = 0.0D0 2279C 2280C***FIRST EXECUTABLE STATEMENT DBSI1E 2281 IF (FIRST) THEN 2282 ETA = 0.1*REAL(D1MACH(3)) 2283 NTI1 = INITDS (BI1CS, 17, ETA) 2284 NTAI1 = INITDS (AI1CS, 46, ETA) 2285 NTAI12 = INITDS (AI12CS, 69, ETA) 2286C 2287 XMIN = 2.0D0*D1MACH(1) 2288 XSML = SQRT(4.5D0*D1MACH(3)) 2289 ENDIF 2290 FIRST = .FALSE. 2291C 2292 Y = ABS(X) 2293 IF (Y.GT.3.0D0) GO TO 20 2294C 2295 DBSI1E = 0.0D0 2296 IF (Y.EQ.0.D0) RETURN 2297C 2298 IF (Y .LE. XMIN) THEN 2299 WRITE(ICOUT,1) 2300 CALL DPWRST('XXX','BUG ') 2301 ENDIF 2302 1 FORMAT('***** WARNING FROM DBSI1E, UNDERFLOW BECAUSE THE ', 2303 1 'ABSOLUTE VALUE OF X IS SO SMALL. ****') 2304 IF (Y.GT.XMIN) DBSI1E = 0.5D0*X 2305 IF (Y.GT.XSML) DBSI1E = X*(0.875D0 + DCSEVL (Y*Y/4.5D0-1.D0, 2306 1 BI1CS, NTI1) ) 2307 DBSI1E = EXP(-Y) * DBSI1E 2308 RETURN 2309C 2310 20 IF (Y.LE.8.D0) DBSI1E = (0.375D0 + DCSEVL ((48.D0/Y-11.D0)/5.D0, 2311 1 AI1CS, NTAI1))/SQRT(Y) 2312 IF (Y.GT.8.D0) DBSI1E = (0.375D0 + DCSEVL (16.D0/Y-1.D0, AI12CS, 2313 1 NTAI12))/SQRT(Y) 2314 DBSI1E = SIGN (DBSI1E, X) 2315C 2316 RETURN 2317 END 2318 DOUBLE PRECISION FUNCTION DBSK0E (X) 2319C***BEGIN PROLOGUE DBSK0E 2320C***PURPOSE Compute the exponentially scaled modified (hyperbolic) 2321C Bessel function of the third kind of order zero. 2322C***LIBRARY SLATEC (FNLIB) 2323C***CATEGORY C10B1 2324C***TYPE DOUBLE PRECISION (BESK0E-S, DBSK0E-D) 2325C***KEYWORDS EXPONENTIALLY SCALED, FNLIB, HYPERBOLIC BESSEL FUNCTION, 2326C MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS, 2327C THIRD KIND 2328C***AUTHOR Fullerton, W., (LANL) 2329C***DESCRIPTION 2330C 2331C DBSK0E(X) computes the double precision exponentially scaled 2332C modified (hyperbolic) Bessel function of the third kind of 2333C order zero for positive double precision argument X. 2334C 2335C Series for BK0 on the interval 0. to 4.00000E+00 2336C with weighted error 3.08E-33 2337C log weighted error 32.51 2338C significant figures required 32.05 2339C decimal places required 33.11 2340C 2341C Series for AK0 on the interval 1.25000E-01 to 5.00000E-01 2342C with weighted error 2.85E-32 2343C log weighted error 31.54 2344C significant figures required 30.19 2345C decimal places required 32.33 2346C 2347C Series for AK02 on the interval 0. to 1.25000E-01 2348C with weighted error 2.30E-32 2349C log weighted error 31.64 2350C significant figures required 29.68 2351C decimal places required 32.40 2352C 2353C***REFERENCES (NONE) 2354C***ROUTINES CALLED D1MACH, DBESI0, DCSEVL, INITDS, XERMSG 2355C***REVISION HISTORY (YYMMDD) 2356C 770701 DATE WRITTEN 2357C 890531 Changed all specific intrinsics to generic. (WRB) 2358C 890531 REVISION DATE from Version 3.2 2359C 891214 Prologue converted to Version 4.0 format. (BAB) 2360C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 2361C***END PROLOGUE DBSK0E 2362C 2363C-----COMMON---------------------------------------------------------- 2364C 2365 INCLUDE 'DPCOMC.INC' 2366 INCLUDE 'DPCOP2.INC' 2367C 2368 DOUBLE PRECISION X, BK0CS(16), AK0CS(38), AK02CS(33), 2369 1 XSML, Y, DCSEVL, DBESI0 2370 LOGICAL FIRST 2371 SAVE BK0CS, AK0CS, AK02CS, NTK0, NTAK0, NTAK02, XSML, FIRST 2372 DATA BK0CS( 1) / -.3532739323 3902768720 1140060063 153 D-1 / 2373 DATA BK0CS( 2) / +.3442898999 2462848688 6344927529 213 D+0 / 2374 DATA BK0CS( 3) / +.3597993651 5361501626 5721303687 231 D-1 / 2375 DATA BK0CS( 4) / +.1264615411 4469259233 8479508673 447 D-2 / 2376 DATA BK0CS( 5) / +.2286212103 1194517860 8269830297 585 D-4 / 2377 DATA BK0CS( 6) / +.2534791079 0261494573 0790013428 354 D-6 / 2378 DATA BK0CS( 7) / +.1904516377 2202088589 7214059381 366 D-8 / 2379 DATA BK0CS( 8) / +.1034969525 7633624585 1008317853 089 D-10 / 2380 DATA BK0CS( 9) / +.4259816142 7910825765 2445327170 133 D-13 / 2381 DATA BK0CS( 10) / +.1374465435 8807508969 4238325440 000 D-15 / 2382 DATA BK0CS( 11) / +.3570896528 5083735909 9688597333 333 D-18 / 2383 DATA BK0CS( 12) / +.7631643660 1164373766 7498666666 666 D-21 / 2384 DATA BK0CS( 13) / +.1365424988 4407818590 8053333333 333 D-23 / 2385 DATA BK0CS( 14) / +.2075275266 9066680831 9999999999 999 D-26 / 2386 DATA BK0CS( 15) / +.2712814218 0729856000 0000000000 000 D-29 / 2387 DATA BK0CS( 16) / +.3082593887 9146666666 6666666666 666 D-32 / 2388 DATA AK0CS( 1) / -.7643947903 3279414240 8297827008 8 D-1 / 2389 DATA AK0CS( 2) / -.2235652605 6998190520 2309555079 1 D-1 / 2390 DATA AK0CS( 3) / +.7734181154 6938582353 0061817404 7 D-3 / 2391 DATA AK0CS( 4) / -.4281006688 8860994644 5214643541 6 D-4 / 2392 DATA AK0CS( 5) / +.3081700173 8629747436 5001482666 0 D-5 / 2393 DATA AK0CS( 6) / -.2639367222 0096649740 6744889272 3 D-6 / 2394 DATA AK0CS( 7) / +.2563713036 4034692062 9408826574 2 D-7 / 2395 DATA AK0CS( 8) / -.2742705549 9002012638 5721191524 4 D-8 / 2396 DATA AK0CS( 9) / +.3169429658 0974995920 8083287340 3 D-9 / 2397 DATA AK0CS( 10) / -.3902353286 9621841416 0106571796 2 D-10 / 2398 DATA AK0CS( 11) / +.5068040698 1885754020 5009212728 6 D-11 / 2399 DATA AK0CS( 12) / -.6889574741 0078706795 4171355798 4 D-12 / 2400 DATA AK0CS( 13) / +.9744978497 8259176913 8820133683 1 D-13 / 2401 DATA AK0CS( 14) / -.1427332841 8845485053 8985534012 2 D-13 / 2402 DATA AK0CS( 15) / +.2156412571 0214630395 5806297652 7 D-14 / 2403 DATA AK0CS( 16) / -.3349654255 1495627721 8878205853 0 D-15 / 2404 DATA AK0CS( 17) / +.5335260216 9529116921 4528039260 1 D-16 / 2405 DATA AK0CS( 18) / -.8693669980 8907538076 3962237883 7 D-17 / 2406 DATA AK0CS( 19) / +.1446404347 8622122278 8776344234 6 D-17 / 2407 DATA AK0CS( 20) / -.2452889825 5001296824 0467875157 3 D-18 / 2408 DATA AK0CS( 21) / +.4233754526 2321715728 2170634240 0 D-19 / 2409 DATA AK0CS( 22) / -.7427946526 4544641956 9534129493 3 D-20 / 2410 DATA AK0CS( 23) / +.1323150529 3926668662 7796746240 0 D-20 / 2411 DATA AK0CS( 24) / -.2390587164 7396494513 3598146559 9 D-21 / 2412 DATA AK0CS( 25) / +.4376827585 9232261401 6571255466 6 D-22 / 2413 DATA AK0CS( 26) / -.8113700607 3451180593 3901141333 3 D-23 / 2414 DATA AK0CS( 27) / +.1521819913 8321729583 1037815466 6 D-23 / 2415 DATA AK0CS( 28) / -.2886041941 4833977702 3595861333 3 D-24 / 2416 DATA AK0CS( 29) / +.5530620667 0547179799 9261013333 3 D-25 / 2417 DATA AK0CS( 30) / -.1070377329 2498987285 9163306666 6 D-25 / 2418 DATA AK0CS( 31) / +.2091086893 1423843002 9632853333 3 D-26 / 2419 DATA AK0CS( 32) / -.4121713723 6462038274 1026133333 3 D-27 / 2420 DATA AK0CS( 33) / +.8193483971 1213076401 3568000000 0 D-28 / 2421 DATA AK0CS( 34) / -.1642000275 4592977267 8075733333 3 D-28 / 2422 DATA AK0CS( 35) / +.3316143281 4802271958 9034666666 6 D-29 / 2423 DATA AK0CS( 36) / -.6746863644 1452959410 8586666666 6 D-30 / 2424 DATA AK0CS( 37) / +.1382429146 3184246776 3541333333 3 D-30 / 2425 DATA AK0CS( 38) / -.2851874167 3598325708 1173333333 3 D-31 / 2426 DATA AK02CS( 1) / -.1201869826 3075922398 3934621245 2 D-1 / 2427 DATA AK02CS( 2) / -.9174852691 0256953106 5256107571 3 D-2 / 2428 DATA AK02CS( 3) / +.1444550931 7750058210 4884387805 7 D-3 / 2429 DATA AK02CS( 4) / -.4013614175 4357097286 7102107787 9 D-5 / 2430 DATA AK02CS( 5) / +.1567831810 8523106725 9034899033 3 D-6 / 2431 DATA AK02CS( 6) / -.7770110438 5217377103 1579975446 0 D-8 / 2432 DATA AK02CS( 7) / +.4611182576 1797178825 3313052958 6 D-9 / 2433 DATA AK02CS( 8) / -.3158592997 8605657705 2666580330 9 D-10 / 2434 DATA AK02CS( 9) / +.2435018039 3650411278 3588781432 9 D-11 / 2435 DATA AK02CS( 10) / -.2074331387 3983478977 0985337350 6 D-12 / 2436 DATA AK02CS( 11) / +.1925787280 5899170847 4273650469 3 D-13 / 2437 DATA AK02CS( 12) / -.1927554805 8389561036 0034718221 8 D-14 / 2438 DATA AK02CS( 13) / +.2062198029 1978182782 8523786964 4 D-15 / 2439 DATA AK02CS( 14) / -.2341685117 5792424026 0364019507 1 D-16 / 2440 DATA AK02CS( 15) / +.2805902810 6430422468 1517882845 8 D-17 / 2441 DATA AK02CS( 16) / -.3530507631 1618079458 1548246357 3 D-18 / 2442 DATA AK02CS( 17) / +.4645295422 9351082674 2421633706 6 D-19 / 2443 DATA AK02CS( 18) / -.6368625941 3442664739 2205346133 3 D-20 / 2444 DATA AK02CS( 19) / +.9069521310 9865155676 2234880000 0 D-21 / 2445 DATA AK02CS( 20) / -.1337974785 4236907398 4500531199 9 D-21 / 2446 DATA AK02CS( 21) / +.2039836021 8599523155 2208896000 0 D-22 / 2447 DATA AK02CS( 22) / -.3207027481 3678405000 6086997333 3 D-23 / 2448 DATA AK02CS( 23) / +.5189744413 6623099636 2635946666 6 D-24 / 2449 DATA AK02CS( 24) / -.8629501497 5405721929 6460799999 9 D-25 / 2450 DATA AK02CS( 25) / +.1472161183 1025598552 0803840000 0 D-25 / 2451 DATA AK02CS( 26) / -.2573069023 8670112838 1235199999 9 D-26 / 2452 DATA AK02CS( 27) / +.4601774086 6435165873 7664000000 0 D-27 / 2453 DATA AK02CS( 28) / -.8411555324 2010937371 3066666666 6 D-28 / 2454 DATA AK02CS( 29) / +.1569806306 6353689393 0154666666 6 D-28 / 2455 DATA AK02CS( 30) / -.2988226453 0057577889 7919999999 9 D-29 / 2456 DATA AK02CS( 31) / +.5796831375 2168365206 1866666666 6 D-30 / 2457 DATA AK02CS( 32) / -.1145035994 3476813321 5573333333 3 D-30 / 2458 DATA AK02CS( 33) / +.2301266594 2496828020 0533333333 3 D-31 / 2459 DATA FIRST /.TRUE./ 2460C***FIRST EXECUTABLE STATEMENT DBSK0E 2461C 2462 DBSK0E=0.0D0 2463C 2464 IF (FIRST) THEN 2465 ETA = 0.1*REAL(D1MACH(3)) 2466 NTK0 = INITDS (BK0CS, 16, ETA) 2467 NTAK0 = INITDS (AK0CS, 38, ETA) 2468 NTAK02 = INITDS (AK02CS, 33, ETA) 2469 XSML = SQRT(4.0D0*D1MACH(3)) 2470 ENDIF 2471 FIRST = .FALSE. 2472C 2473CCCCC IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'DBSK0E', 2474CCCCC+ 'X IS ZERO OR NEGATIVE', 2, 2) 2475 IF (X .LE. 0.D0) THEN 2476 WRITE(ICOUT,1) 2477 1 FORMAT('***** ERORR FROM DBSK0E, X ZERO OR NEGATIVE.') 2478 CALL DPWRST('XXX','BUG ') 2479 DBSK0E=0.0D0 2480 RETURN 2481 ENDIF 2482 IF (X.GT.2.0D0) GO TO 20 2483C 2484 Y = 0.D0 2485 IF (X.GT.XSML) Y = X*X 2486 DBSK0E = EXP(X)*(-LOG(0.5D0*X)*DBESI0(X) - 0.25D0 + 2487 1 DCSEVL (.5D0*Y-1.D0, BK0CS, NTK0)) 2488 RETURN 2489C 2490 20 IF (X.LE.8.D0) DBSK0E = (1.25D0 + DCSEVL ((16.D0/X-5.D0)/3.D0, 2491 1 AK0CS, NTAK0))/SQRT(X) 2492 IF (X.GT.8.D0) DBSK0E = (1.25D0 + 2493 1 DCSEVL (16.D0/X-1.D0, AK02CS, NTAK02))/SQRT(X) 2494C 2495 RETURN 2496 END 2497 DOUBLE PRECISION FUNCTION DBSK1E (X) 2498C***BEGIN PROLOGUE DBSK1E 2499C***PURPOSE Compute the exponentially scaled modified (hyperbolic) 2500C Bessel function of the third kind of order one. 2501C***LIBRARY SLATEC (FNLIB) 2502C***CATEGORY C10B1 2503C***TYPE DOUBLE PRECISION (BESK1E-S, DBSK1E-D) 2504C***KEYWORDS EXPONENTIALLY SCALED, FNLIB, HYPERBOLIC BESSEL FUNCTION, 2505C MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS, 2506C THIRD KIND 2507C***AUTHOR Fullerton, W., (LANL) 2508C***DESCRIPTION 2509C 2510C DBSK1E(S) computes the double precision exponentially scaled 2511C modified (hyperbolic) Bessel function of the third kind of order 2512C one for positive double precision argument X. 2513C 2514C Series for BK1 on the interval 0. to 4.00000E+00 2515C with weighted error 9.16E-32 2516C log weighted error 31.04 2517C significant figures required 30.61 2518C decimal places required 31.64 2519C 2520C Series for AK1 on the interval 1.25000E-01 to 5.00000E-01 2521C with weighted error 3.07E-32 2522C log weighted error 31.51 2523C significant figures required 30.71 2524C decimal places required 32.30 2525C 2526C Series for AK12 on the interval 0. to 1.25000E-01 2527C with weighted error 2.41E-32 2528C log weighted error 31.62 2529C significant figures required 30.25 2530C decimal places required 32.38 2531C 2532C***REFERENCES (NONE) 2533C***ROUTINES CALLED D1MACH, DBESI1, DCSEVL, INITDS, XERMSG 2534C***REVISION HISTORY (YYMMDD) 2535C 770701 DATE WRITTEN 2536C 890531 Changed all specific intrinsics to generic. (WRB) 2537C 890531 REVISION DATE from Version 3.2 2538C 891214 Prologue converted to Version 4.0 format. (BAB) 2539C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 2540C***END PROLOGUE DBSK1E 2541C 2542C-----COMMON---------------------------------------------------------- 2543C 2544 INCLUDE 'DPCOMC.INC' 2545 INCLUDE 'DPCOP2.INC' 2546C 2547 DOUBLE PRECISION X, BK1CS(16), AK1CS(38), AK12CS(33), XMIN, 2548 1 XSML, Y, DCSEVL, DBESI1 2549 LOGICAL FIRST 2550 SAVE BK1CS, AK1CS, AK12CS, NTK1, NTAK1, NTAK12, XMIN, XSML, 2551 1 FIRST 2552 DATA BK1CS( 1) / +.2530022733 8947770532 5311208685 33 D-1 / 2553 DATA BK1CS( 2) / -.3531559607 7654487566 7238316918 01 D+0 / 2554 DATA BK1CS( 3) / -.1226111808 2265714823 4790679300 42 D+0 / 2555 DATA BK1CS( 4) / -.6975723859 6398643501 8129202960 83 D-2 / 2556 DATA BK1CS( 5) / -.1730288957 5130520630 1765073689 79 D-3 / 2557 DATA BK1CS( 6) / -.2433406141 5659682349 6007350301 64 D-5 / 2558 DATA BK1CS( 7) / -.2213387630 7347258558 3152525451 26 D-7 / 2559 DATA BK1CS( 8) / -.1411488392 6335277610 9583302126 08 D-9 / 2560 DATA BK1CS( 9) / -.6666901694 1993290060 8537512643 73 D-12 / 2561 DATA BK1CS( 10) / -.2427449850 5193659339 2631968648 53 D-14 / 2562 DATA BK1CS( 11) / -.7023863479 3862875971 7837971200 00 D-17 / 2563 DATA BK1CS( 12) / -.1654327515 5100994675 4910293333 33 D-19 / 2564 DATA BK1CS( 13) / -.3233834745 9944491991 8933333333 33 D-22 / 2565 DATA BK1CS( 14) / -.5331275052 9265274999 4666666666 66 D-25 / 2566 DATA BK1CS( 15) / -.7513040716 2157226666 6666666666 66 D-28 / 2567 DATA BK1CS( 16) / -.9155085717 6541866666 6666666666 66 D-31 / 2568 DATA AK1CS( 1) / +.2744313406 9738829695 2576662272 66 D+0 / 2569 DATA AK1CS( 2) / +.7571989953 1993678170 8923781492 90 D-1 / 2570 DATA AK1CS( 3) / -.1441051556 4754061229 8531161756 25 D-2 / 2571 DATA AK1CS( 4) / +.6650116955 1257479394 2513854770 36 D-4 / 2572 DATA AK1CS( 5) / -.4369984709 5201407660 5808450891 67 D-5 / 2573 DATA AK1CS( 6) / +.3540277499 7630526799 4171390085 34 D-6 / 2574 DATA AK1CS( 7) / -.3311163779 2932920208 9826882457 04 D-7 / 2575 DATA AK1CS( 8) / +.3445977581 9010534532 3114997709 92 D-8 / 2576 DATA AK1CS( 9) / -.3898932347 4754271048 9819374927 58 D-9 / 2577 DATA AK1CS( 10) / +.4720819750 4658356400 9474493390 05 D-10 / 2578 DATA AK1CS( 11) / -.6047835662 8753562345 3735915628 90 D-11 / 2579 DATA AK1CS( 12) / +.8128494874 8658747888 1938379856 63 D-12 / 2580 DATA AK1CS( 13) / -.1138694574 7147891428 9239159510 42 D-12 / 2581 DATA AK1CS( 14) / +.1654035840 8462282325 9729482050 90 D-13 / 2582 DATA AK1CS( 15) / -.2480902567 7068848221 5160104405 33 D-14 / 2583 DATA AK1CS( 16) / +.3829237890 7024096948 4292272991 57 D-15 / 2584 DATA AK1CS( 17) / -.6064734104 0012418187 7682103773 86 D-16 / 2585 DATA AK1CS( 18) / +.9832425623 2648616038 1940046506 66 D-17 / 2586 DATA AK1CS( 19) / -.1628416873 8284380035 6666201156 26 D-17 / 2587 DATA AK1CS( 20) / +.2750153649 6752623718 2841203370 66 D-18 / 2588 DATA AK1CS( 21) / -.4728966646 3953250924 2810695680 00 D-19 / 2589 DATA AK1CS( 22) / +.8268150002 8109932722 3920503466 66 D-20 / 2590 DATA AK1CS( 23) / -.1468140513 6624956337 1939648853 33 D-20 / 2591 DATA AK1CS( 24) / +.2644763926 9208245978 0858948266 66 D-21 / 2592 DATA AK1CS( 25) / -.4829015756 4856387897 9698688000 00 D-22 / 2593 DATA AK1CS( 26) / +.8929302074 3610130180 6563327999 99 D-23 / 2594 DATA AK1CS( 27) / -.1670839716 8972517176 9977514666 66 D-23 / 2595 DATA AK1CS( 28) / +.3161645603 4040694931 3686186666 66 D-24 / 2596 DATA AK1CS( 29) / -.6046205531 2274989106 5064106666 66 D-25 / 2597 DATA AK1CS( 30) / +.1167879894 2042732700 7184213333 33 D-25 / 2598 DATA AK1CS( 31) / -.2277374158 2653996232 8678400000 00 D-26 / 2599 DATA AK1CS( 32) / +.4481109730 0773675795 3058133333 33 D-27 / 2600 DATA AK1CS( 33) / -.8893288476 9020194062 3360000000 00 D-28 / 2601 DATA AK1CS( 34) / +.1779468001 8850275131 3920000000 00 D-28 / 2602 DATA AK1CS( 35) / -.3588455596 7329095821 9946666666 66 D-29 / 2603 DATA AK1CS( 36) / +.7290629049 2694257991 6799999999 99 D-30 / 2604 DATA AK1CS( 37) / -.1491844984 5546227073 0240000000 00 D-30 / 2605 DATA AK1CS( 38) / +.3073657387 2934276300 7999999999 99 D-31 / 2606 DATA AK12CS( 1) / +.6379308343 7390010366 0048853410 2 D-1 / 2607 DATA AK12CS( 2) / +.2832887813 0497209358 3503028470 8 D-1 / 2608 DATA AK12CS( 3) / -.2475370673 9052503454 1454556673 2 D-3 / 2609 DATA AK12CS( 4) / +.5771972451 6072488204 7097662576 3 D-5 / 2610 DATA AK12CS( 5) / -.2068939219 5365483027 4553319655 2 D-6 / 2611 DATA AK12CS( 6) / +.9739983441 3818041803 0921309788 7 D-8 / 2612 DATA AK12CS( 7) / -.5585336140 3806249846 8889551112 9 D-9 / 2613 DATA AK12CS( 8) / +.3732996634 0461852402 2121285473 1 D-10 / 2614 DATA AK12CS( 9) / -.2825051961 0232254451 3506575492 8 D-11 / 2615 DATA AK12CS( 10) / +.2372019002 4841441736 4349695548 6 D-12 / 2616 DATA AK12CS( 11) / -.2176677387 9917539792 6830166793 8 D-13 / 2617 DATA AK12CS( 12) / +.2157914161 6160324539 3956268970 6 D-14 / 2618 DATA AK12CS( 13) / -.2290196930 7182692759 9155133815 4 D-15 / 2619 DATA AK12CS( 14) / +.2582885729 8232749619 1993956522 6 D-16 / 2620 DATA AK12CS( 15) / -.3076752641 2684631876 2109817344 0 D-17 / 2621 DATA AK12CS( 16) / +.3851487721 2804915970 9489684479 9 D-18 / 2622 DATA AK12CS( 17) / -.5044794897 6415289771 1728250880 0 D-19 / 2623 DATA AK12CS( 18) / +.6888673850 4185442370 1829222399 9 D-20 / 2624 DATA AK12CS( 19) / -.9775041541 9501183030 0213248000 0 D-21 / 2625 DATA AK12CS( 20) / +.1437416218 5238364610 0165973333 3 D-21 / 2626 DATA AK12CS( 21) / -.2185059497 3443473734 9973333333 3 D-22 / 2627 DATA AK12CS( 22) / +.3426245621 8092206316 4538880000 0 D-23 / 2628 DATA AK12CS( 23) / -.5531064394 2464082325 0124800000 0 D-24 / 2629 DATA AK12CS( 24) / +.9176601505 6859954037 8282666666 6 D-25 / 2630 DATA AK12CS( 25) / -.1562287203 6180249114 4874666666 6 D-25 / 2631 DATA AK12CS( 26) / +.2725419375 4843331323 4943999999 9 D-26 / 2632 DATA AK12CS( 27) / -.4865674910 0748279923 7802666666 6 D-27 / 2633 DATA AK12CS( 28) / +.8879388552 7235025873 5786666666 6 D-28 / 2634 DATA AK12CS( 29) / -.1654585918 0392575489 3653333333 3 D-28 / 2635 DATA AK12CS( 30) / +.3145111321 3578486743 0399999999 9 D-29 / 2636 DATA AK12CS( 31) / -.6092998312 1931276124 1600000000 0 D-30 / 2637 DATA AK12CS( 32) / +.1202021939 3698158346 2399999999 9 D-30 / 2638 DATA AK12CS( 33) / -.2412930801 4594088413 8666666666 6 D-31 / 2639 DATA FIRST /.TRUE./ 2640C***FIRST EXECUTABLE STATEMENT DBSK1E 2641C 2642 DBSK1E=0.0D0 2643C 2644 IF (FIRST) THEN 2645 ETA = 0.1*REAL(D1MACH(3)) 2646 NTK1 = INITDS (BK1CS, 16, ETA) 2647 NTAK1 = INITDS (AK1CS, 38, ETA) 2648 NTAK12 = INITDS (AK12CS, 33, ETA) 2649C 2650 XMIN = EXP (MAX(LOG(D1MACH(1)), -LOG(D1MACH(2))) + 0.01D0) 2651 XSML = SQRT(4.0D0*D1MACH(3)) 2652 ENDIF 2653 FIRST = .FALSE. 2654C 2655CCCCC IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'DBSK1E', 2656CCCCC+ 'X IS ZERO OR NEGATIVE', 2, 2) 2657 IF (X .LE. 0.D0) THEN 2658 WRITE(ICOUT,1) 2659 1 FORMAT('***** ERORR FROM DBSK1E, X ZERO OR NEGATIVE.') 2660 CALL DPWRST('XXX','BUG ') 2661 DBSK1E=0.0D0 2662 RETURN 2663 ENDIF 2664 IF (X.GT.2.0D0) GO TO 20 2665C 2666CCCCC IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'DBSK1E', 2667CCCCC+ 'X SO SMALL K1 OVERFLOWS', 3, 2) 2668 IF (X .LT. XMIN) THEN 2669 WRITE(ICOUT,2) 2670 CALL DPWRST('XXX','BUG ') 2671 DBSK1E = 0.0D0 2672 RETURN 2673 ENDIF 2674 2 FORMAT('***** ERROR FROM DBSK1E, OVERRFLOW BECAUSE THE ', 2675 1 'VALUE OF X IS SO SMALL.') 2676 Y = 0.D0 2677 IF (X.GT.XSML) Y = X*X 2678 DBSK1E = EXP(X)*(LOG(0.5D0*X)*DBESI1(X) + (0.75D0 + 2679 1 DCSEVL (0.5D0*Y-1.D0, BK1CS, NTK1))/X ) 2680 RETURN 2681C 2682 20 IF (X.LE.8.D0) DBSK1E = (1.25D0 + DCSEVL ((16.D0/X-5.D0)/3.D0, 2683 1 AK1CS, NTAK1))/SQRT(X) 2684 IF (X.GT.8.D0) DBSK1E = (1.25D0 + 2685 1 DCSEVL (16.D0/X-1.D0, AK12CS, NTAK12))/SQRT(X) 2686C 2687 RETURN 2688 END 2689 SUBROUTINE DBSKNU (X, FNU, KODE, N, Y, NZ) 2690C***BEGIN PROLOGUE DBSKNU 2691C***SUBSIDIARY 2692C***PURPOSE Subsidiary to DBESK 2693C***LIBRARY SLATEC 2694C***TYPE DOUBLE PRECISION (BESKNU-S, DBSKNU-D) 2695C***AUTHOR Amos, D. E., (SNLA) 2696C***DESCRIPTION 2697C 2698C Abstract **** A DOUBLE PRECISION routine **** 2699C DBSKNU computes N member sequences of K Bessel functions 2700C K/SUB(FNU+I-1)/(X), I=1,N for non-negative orders FNU and 2701C positive X. Equations of the references are implemented on 2702C small orders DNU for K/SUB(DNU)/(X) and K/SUB(DNU+1)/(X). 2703C Forward recursion with the three term recursion relation 2704C generates higher orders FNU+I-1, I=1,...,N. The parameter 2705C KODE permits K/SUB(FNU+I-1)/(X) values or scaled values 2706C EXP(X)*K/SUB(FNU+I-1)/(X), I=1,N to be returned. 2707C 2708C To start the recursion FNU is normalized to the interval 2709C -0.5.LE.DNU.LT.0.5. A special form of the power series is 2710C implemented on 0.LT.X.LE.X1 while the Miller algorithm for the 2711C K Bessel function in terms of the confluent hypergeometric 2712C function U(FNU+0.5,2*FNU+1,X) is implemented on X1.LT.X.LE.X2. 2713C For X.GT.X2, the asymptotic expansion for large X is used. 2714C When FNU is a half odd integer, a special formula for 2715C DNU=-0.5 and DNU+1.0=0.5 is used to start the recursion. 2716C 2717C The maximum number of significant digits obtainable 2718C is the smaller of 14 and the number of digits carried in 2719C DOUBLE PRECISION arithmetic. 2720C 2721C DBSKNU assumes that a significant digit SINH function is 2722C available. 2723C 2724C Description of Arguments 2725C 2726C INPUT X,FNU are DOUBLE PRECISION 2727C X - X.GT.0.0D0 2728C FNU - Order of initial K function, FNU.GE.0.0D0 2729C N - Number of members of the sequence, N.GE.1 2730C KODE - A parameter to indicate the scaling option 2731C KODE= 1 returns 2732C Y(I)= K/SUB(FNU+I-1)/(X) 2733C I=1,...,N 2734C = 2 returns 2735C Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X) 2736C I=1,...,N 2737C 2738C OUTPUT Y is DOUBLE PRECISION 2739C Y - A vector whose first N components contain values 2740C for the sequence 2741C Y(I)= K/SUB(FNU+I-1)/(X), I=1,...,N or 2742C Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N 2743C depending on KODE 2744C NZ - Number of components set to zero due to 2745C underflow, 2746C NZ= 0 , normal return 2747C NZ.NE.0 , first NZ components of Y set to zero 2748C due to underflow, Y(I)=0.0D0,I=1,...,NZ 2749C 2750C Error Conditions 2751C Improper input arguments - a fatal error 2752C Overflow - a fatal error 2753C Underflow with KODE=1 - a non-fatal error (NZ.NE.0) 2754C 2755C***SEE ALSO DBESK 2756C***REFERENCES N. M. Temme, On the numerical evaluation of the modified 2757C Bessel function of the third kind, Journal of 2758C Computational Physics 19, (1975), pp. 324-337. 2759C***ROUTINES CALLED D1MACH, DGAMMA, I1MACH, XERMSG 2760C***REVISION HISTORY (YYMMDD) 2761C 790201 DATE WRITTEN 2762C 890531 Changed all specific intrinsics to generic. (WRB) 2763C 890911 Removed unnecessary intrinsics. (WRB) 2764C 891214 Prologue converted to Version 4.0 format. (BAB) 2765C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 2766C 900326 Removed duplicate information from DESCRIPTION section. 2767C (WRB) 2768C 900328 Added TYPE section. (WRB) 2769C 900727 Added EXTERNAL statement. (WRB) 2770C 910408 Updated the AUTHOR and REFERENCES sections. (WRB) 2771C 920501 Reformatted the REFERENCES section. (WRB) 2772C***END PROLOGUE DBSKNU 2773C 2774C 2775C-----COMMON---------------------------------------------------------- 2776C 2777 INCLUDE 'DPCOMC.INC' 2778 INCLUDE 'DPCOP2.INC' 2779C 2780 INTEGER I, IFLAG, INU, J, K, KK, KODE, KODED, N, NN, NZ 2781 DOUBLE PRECISION A,AK,A1,A2,B,BK,CC,CK,COEF,CX,DK,DNU,DNU2,ELIM, 2782 1 ETEST, EX, F, FC, FHS, FK, FKS, FLRX, FMU, FNU, G1, G2, P, PI, 2783 2 PT, P1, P2, Q, RTHPI, RX, S, SMU, SQK, ST, S1, S2, TM, TOL, T1, 2784 3 T2, X, X1, X2, Y 2785 DIMENSION A(160), B(160), Y(*), CC(8) 2786 DOUBLE PRECISION DGAMMA 2787 EXTERNAL DGAMMA 2788 SAVE X1, X2, PI, RTHPI, CC 2789 DATA X1, X2 / 2.0D0, 17.0D0 / 2790 DATA PI,RTHPI / 3.14159265358979D+00, 1.25331413731550D+00/ 2791 DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8) 2792 1 / 5.77215664901533D-01,-4.20026350340952D-02, 2793 2-4.21977345555443D-02, 7.21894324666300D-03,-2.15241674114900D-04, 2794 3-2.01348547807000D-05, 1.13302723200000D-06, 6.11609500000000D-09/ 2795C***FIRST EXECUTABLE STATEMENT DBSKNU 2796C 2797 S2 = 0.0D0 2798 DNU2 = 0.0D0 2799 KK = -I1MACH(15) 2800 ELIM = 2.303D0*(KK*D1MACH(5)-3.0D0) 2801 AK = D1MACH(3) 2802 TOL = MAX(AK,1.0D-15) 2803 IF (X.LE.0.0D0) GO TO 350 2804 IF (FNU.LT.0.0D0) GO TO 360 2805 IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 370 2806 IF (N.LT.1) GO TO 380 2807 NZ = 0 2808 IFLAG = 0 2809 KODED = KODE 2810 RX = 2.0D0/X 2811 INU = INT(FNU+0.5D0) 2812 DNU = FNU - INU 2813 IF (ABS(DNU).EQ.0.5D0) GO TO 120 2814 DNU2 = 0.0D0 2815 IF (ABS(DNU).LT.TOL) GO TO 10 2816 DNU2 = DNU*DNU 2817 10 CONTINUE 2818 IF (X.GT.X1) GO TO 120 2819C 2820C SERIES FOR X.LE.X1 2821C 2822 A1 = 1.0D0 - DNU 2823 A2 = 1.0D0 + DNU 2824 T1 = 1.0D0/DGAMMA(A1) 2825 T2 = 1.0D0/DGAMMA(A2) 2826 IF (ABS(DNU).GT.0.1D0) GO TO 40 2827C SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) 2828 S = CC(1) 2829 AK = 1.0D0 2830 DO 20 K=2,8 2831 AK = AK*DNU2 2832 TM = CC(K)*AK 2833 S = S + TM 2834 IF (ABS(TM).LT.TOL) GO TO 30 2835 20 CONTINUE 2836 30 G1 = -S 2837 GO TO 50 2838 40 CONTINUE 2839 G1 = (T1-T2)/(DNU+DNU) 2840 50 CONTINUE 2841 G2 = (T1+T2)*0.5D0 2842 SMU = 1.0D0 2843 FC = 1.0D0 2844 FLRX = LOG(RX) 2845 FMU = DNU*FLRX 2846 IF (DNU.EQ.0.0D0) GO TO 60 2847 FC = DNU*PI 2848 FC = FC/SIN(FC) 2849 IF (FMU.NE.0.0D0) SMU = SINH(FMU)/FMU 2850 60 CONTINUE 2851 F = FC*(G1*COSH(FMU)+G2*FLRX*SMU) 2852 FC = EXP(FMU) 2853 P = 0.5D0*FC/T2 2854 Q = 0.5D0/(FC*T1) 2855 AK = 1.0D0 2856 CK = 1.0D0 2857 BK = 1.0D0 2858 S1 = F 2859 S2 = P 2860 IF (INU.GT.0 .OR. N.GT.1) GO TO 90 2861 IF (X.LT.TOL) GO TO 80 2862 CX = X*X*0.25D0 2863 70 CONTINUE 2864 F = (AK*F+P+Q)/(BK-DNU2) 2865 P = P/(AK-DNU) 2866 Q = Q/(AK+DNU) 2867 CK = CK*CX/AK 2868 T1 = CK*F 2869 S1 = S1 + T1 2870 BK = BK + AK + AK + 1.0D0 2871 AK = AK + 1.0D0 2872 S = ABS(T1)/(1.0D0+ABS(S1)) 2873 IF (S.GT.TOL) GO TO 70 2874 80 CONTINUE 2875 Y(1) = S1 2876 IF (KODED.EQ.1) RETURN 2877 Y(1) = S1*EXP(X) 2878 RETURN 2879 90 CONTINUE 2880 IF (X.LT.TOL) GO TO 110 2881 CX = X*X*0.25D0 2882 100 CONTINUE 2883 F = (AK*F+P+Q)/(BK-DNU2) 2884 P = P/(AK-DNU) 2885 Q = Q/(AK+DNU) 2886 CK = CK*CX/AK 2887 T1 = CK*F 2888 S1 = S1 + T1 2889 T2 = CK*(P-AK*F) 2890 S2 = S2 + T2 2891 BK = BK + AK + AK + 1.0D0 2892 AK = AK + 1.0D0 2893 S = ABS(T1)/(1.0D0+ABS(S1)) + ABS(T2)/(1.0D0+ABS(S2)) 2894 IF (S.GT.TOL) GO TO 100 2895 110 CONTINUE 2896 S2 = S2*RX 2897 IF (KODED.EQ.1) GO TO 170 2898 F = EXP(X) 2899 S1 = S1*F 2900 S2 = S2*F 2901 GO TO 170 2902 120 CONTINUE 2903 COEF = RTHPI/SQRT(X) 2904 IF (KODED.EQ.2) GO TO 130 2905 IF (X.GT.ELIM) GO TO 330 2906 COEF = COEF*EXP(-X) 2907 130 CONTINUE 2908 IF (ABS(DNU).EQ.0.5D0) GO TO 340 2909 IF (X.GT.X2) GO TO 280 2910C 2911C MILLER ALGORITHM FOR X1.LT.X.LE.X2 2912C 2913 ETEST = COS(PI*DNU)/(PI*X*TOL) 2914 FKS = 1.0D0 2915 FHS = 0.25D0 2916 FK = 0.0D0 2917 CK = X + X + 2.0D0 2918 P1 = 0.0D0 2919 P2 = 1.0D0 2920 K = 0 2921 140 CONTINUE 2922 K = K + 1 2923 FK = FK + 1.0D0 2924 AK = (FHS-DNU2)/(FKS+FK) 2925 BK = CK/(FK+1.0D0) 2926 PT = P2 2927 P2 = BK*P2 - AK*P1 2928 P1 = PT 2929 A(K) = AK 2930 B(K) = BK 2931 CK = CK + 2.0D0 2932 FKS = FKS + FK + FK + 1.0D0 2933 FHS = FHS + FK + FK 2934 IF (ETEST.GT.FK*P1) GO TO 140 2935 KK = K 2936 S = 1.0D0 2937 P1 = 0.0D0 2938 P2 = 1.0D0 2939 DO 150 I=1,K 2940 PT = P2 2941 P2 = (B(KK)*P2-P1)/A(KK) 2942 P1 = PT 2943 S = S + P2 2944 KK = KK - 1 2945 150 CONTINUE 2946 S1 = COEF*(P2/S) 2947 IF (INU.GT.0 .OR. N.GT.1) GO TO 160 2948 GO TO 200 2949 160 CONTINUE 2950 S2 = S1*(X+DNU+0.5D0-P1/P2)/X 2951C 2952C FORWARD RECURSION ON THE THREE TERM RECURSION RELATION 2953C 2954 170 CONTINUE 2955 CK = (DNU+DNU+2.0D0)/X 2956 IF (N.EQ.1) INU = INU - 1 2957 IF (INU.GT.0) GO TO 180 2958 IF (N.GT.1) GO TO 200 2959 S1 = S2 2960 GO TO 200 2961 180 CONTINUE 2962 DO 190 I=1,INU 2963 ST = S2 2964 S2 = CK*S2 + S1 2965 S1 = ST 2966 CK = CK + RX 2967 190 CONTINUE 2968 IF (N.EQ.1) S1 = S2 2969 200 CONTINUE 2970 IF (IFLAG.EQ.1) GO TO 220 2971 Y(1) = S1 2972 IF (N.EQ.1) RETURN 2973 Y(2) = S2 2974 IF (N.EQ.2) RETURN 2975 DO 210 I=3,N 2976 Y(I) = CK*Y(I-1) + Y(I-2) 2977 CK = CK + RX 2978 210 CONTINUE 2979 RETURN 2980C IFLAG=1 CASES 2981 220 CONTINUE 2982 S = -X + LOG(S1) 2983 Y(1) = 0.0D0 2984 NZ = 1 2985 IF (S.LT.-ELIM) GO TO 230 2986 Y(1) = EXP(S) 2987 NZ = 0 2988 230 CONTINUE 2989 IF (N.EQ.1) RETURN 2990 S = -X + LOG(S2) 2991 Y(2) = 0.0D0 2992 NZ = NZ + 1 2993 IF (S.LT.-ELIM) GO TO 240 2994 NZ = NZ - 1 2995 Y(2) = EXP(S) 2996 240 CONTINUE 2997 IF (N.EQ.2) RETURN 2998 KK = 2 2999 IF (NZ.LT.2) GO TO 260 3000 DO 250 I=3,N 3001 KK = I 3002 ST = S2 3003 S2 = CK*S2 + S1 3004 S1 = ST 3005 CK = CK + RX 3006 S = -X + LOG(S2) 3007 NZ = NZ + 1 3008 Y(I) = 0.0D0 3009 IF (S.LT.-ELIM) GO TO 250 3010 Y(I) = EXP(S) 3011 NZ = NZ - 1 3012 GO TO 260 3013 250 CONTINUE 3014 RETURN 3015 260 CONTINUE 3016 IF (KK.EQ.N) RETURN 3017 S2 = S2*CK + S1 3018 CK = CK + RX 3019 KK = KK + 1 3020 Y(KK) = EXP(-X+LOG(S2)) 3021 IF (KK.EQ.N) RETURN 3022 KK = KK + 1 3023 DO 270 I=KK,N 3024 Y(I) = CK*Y(I-1) + Y(I-2) 3025 CK = CK + RX 3026 270 CONTINUE 3027 RETURN 3028C 3029C ASYMPTOTIC EXPANSION FOR LARGE X, X.GT.X2 3030C 3031C IFLAG=0 MEANS NO UNDERFLOW OCCURRED 3032C IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH 3033C KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD 3034C RECURSION 3035 280 CONTINUE 3036 NN = 2 3037 IF (INU.EQ.0 .AND. N.EQ.1) NN = 1 3038 DNU2 = DNU + DNU 3039 FMU = 0.0D0 3040 IF (ABS(DNU2).LT.TOL) GO TO 290 3041 FMU = DNU2*DNU2 3042 290 CONTINUE 3043 EX = X*8.0D0 3044 S2 = 0.0D0 3045 DO 320 K=1,NN 3046 S1 = S2 3047 S = 1.0D0 3048 AK = 0.0D0 3049 CK = 1.0D0 3050 SQK = 1.0D0 3051 DK = EX 3052 DO 300 J=1,30 3053 CK = CK*(FMU-SQK)/DK 3054 S = S + CK 3055 DK = DK + EX 3056 AK = AK + 8.0D0 3057 SQK = SQK + AK 3058 IF (ABS(CK).LT.TOL) GO TO 310 3059 300 CONTINUE 3060 310 S2 = S*COEF 3061 FMU = FMU + 8.0D0*DNU + 4.0D0 3062 320 CONTINUE 3063 IF (NN.GT.1) GO TO 170 3064 S1 = S2 3065 GO TO 200 3066 330 CONTINUE 3067 KODED = 2 3068 IFLAG = 1 3069 GO TO 120 3070C 3071C FNU=HALF ODD INTEGER CASE 3072C 3073 340 CONTINUE 3074 S1 = COEF 3075 S2 = COEF 3076 GO TO 170 3077C 3078C 3079CC350 CALL XERMSG ('SLATEC', 'DBSKNU', 'X NOT GREATER THAN ZERO', 2, 1) 3080CCCCC RETURN 3081CC360 CALL XERMSG ('SLATEC', 'DBSKNU', 'FNU NOT ZERO OR POSITIVE', 2, 3082CCCCC+ 1) 3083CCCCC RETURN 3084CC370 CALL XERMSG ('SLATEC', 'DBSKNU', 'KODE NOT 1 OR 2', 2, 1) 3085CCCCC RETURN 3086CC380 CALL XERMSG ('SLATEC', 'DBSKNU', 'N NOT GREATER THAN 0', 2, 1) 3087CCCCC RETURN 3088 350 CONTINUE 3089 WRITE(ICOUT,351) 3090 351 FORMAT('** ERROR FROM DBSKNU, X IS LESS THAN OR EQUAL TO ZERO. ') 3091 CALL DPWRST('XXX','BUG ') 3092 RETURN 3093 360 CONTINUE 3094 WRITE(ICOUT,361) 3095 361 FORMAT('***** ERROR FROM DBSKNU, THE ORDER FNU IS NEGATIVE.') 3096 CALL DPWRST('XXX','BUG ') 3097 RETURN 3098 370 CONTINUE 3099 WRITE(ICOUT,371) 3100 371 FORMAT('***** ERROR FROM DBSKNU, KODE IS NOT 1 OR 2.') 3101 CALL DPWRST('XXX','BUG ') 3102 RETURN 3103 380 CONTINUE 3104 WRITE(ICOUT,381) 3105 381 FORMAT('***** ERROR FROM DBSKNU, N IS LESS THAN ONE.. ***') 3106 CALL DPWRST('XXX','BUG ') 3107 RETURN 3108 END 3109 DOUBLE PRECISION FUNCTION D9CHU (A, B, Z) 3110C***BEGIN PROLOGUE D9CHU 3111C***SUBSIDIARY 3112C***PURPOSE Evaluate for large Z Z**A * U(A,B,Z) where U is the 3113C logarithmic confluent hypergeometric function. 3114C***LIBRARY SLATEC (FNLIB) 3115C***CATEGORY C11 3116C***TYPE DOUBLE PRECISION (R9CHU-S, D9CHU-D) 3117C***KEYWORDS FNLIB, LOGARITHMIC CONFLUENT HYPERGEOMETRIC FUNCTION, 3118C SPECIAL FUNCTIONS 3119C***AUTHOR Fullerton, W., (LANL) 3120C***DESCRIPTION 3121C 3122C Evaluate for large Z Z**A * U(A,B,Z) where U is the logarithmic 3123C confluent hypergeometric function. A rational approximation due to Y. 3124C L. Luke is used. When U is not in the asymptotic region, i.e., when A 3125C or B is large compared with Z, considerable significance loss occurs. 3126C A warning is provided when the computed result is less than half 3127C precision. 3128C 3129C***REFERENCES (NONE) 3130C***ROUTINES CALLED D1MACH, XERMSG 3131C***REVISION HISTORY (YYMMDD) 3132C 770801 DATE WRITTEN 3133C 890531 Changed all specific intrinsics to generic. (WRB) 3134C 890531 REVISION DATE from Version 3.2 3135C 891214 Prologue converted to Version 4.0 format. (BAB) 3136C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 3137C 900720 Routine changed from user-callable to subsidiary. (WRB) 3138C***END PROLOGUE D9CHU 3139C 3140C-----COMMON---------------------------------------------------------- 3141C 3142 INCLUDE 'DPCOMC.INC' 3143 INCLUDE 'DPCOP2.INC' 3144C 3145 DOUBLE PRECISION A, B, Z, AA(4), BB(4), AB, ANBN, BP, CT1, CT2, 3146 1 CT3, C2, D1Z, EPS, G1, G2, G3, SAB, SQEPS, X2I1 3147 LOGICAL FIRST 3148 SAVE EPS, SQEPS, FIRST 3149 DATA FIRST /.TRUE./ 3150C***FIRST EXECUTABLE STATEMENT D9CHU 3151C 3152 D9CHU = 0.0D0 3153C 3154 IF (FIRST) THEN 3155 EPS = 4.0D0*D1MACH(4) 3156 SQEPS = SQRT(D1MACH(4)) 3157 ENDIF 3158 FIRST = .FALSE. 3159C 3160 BP = 1.0D0 + A - B 3161 AB = A*BP 3162 CT2 = 2.0D0 * (Z - AB) 3163 SAB = A + BP 3164C 3165 BB(1) = 1.0D0 3166 AA(1) = 1.0D0 3167C 3168 CT3 = SAB + 1.0D0 + AB 3169 BB(2) = 1.0D0 + 2.0D0*Z/CT3 3170 AA(2) = 1.0D0 + CT2/CT3 3171C 3172 ANBN = CT3 + SAB + 3.0D0 3173 CT1 = 1.0D0 + 2.0D0*Z/ANBN 3174 BB(3) = 1.0D0 + 6.0D0*CT1*Z/CT3 3175 AA(3) = 1.0D0 + 6.0D0*AB/ANBN + 3.0D0*CT1*CT2/CT3 3176C 3177 DO 30 I=4,300 3178 X2I1 = 2*I - 3 3179 CT1 = X2I1/(X2I1-2.0D0) 3180 ANBN = ANBN + X2I1 + SAB 3181 CT2 = (X2I1 - 1.0D0)/ANBN 3182 C2 = X2I1*CT2 - 1.0D0 3183 D1Z = X2I1*2.0D0*Z/ANBN 3184C 3185 CT3 = SAB*CT2 3186 G1 = D1Z + CT1*(C2+CT3) 3187 G2 = D1Z - C2 3188 G3 = CT1*(1.0D0 - CT3 - 2.0D0*CT2) 3189C 3190 BB(4) = G1*BB(3) + G2*BB(2) + G3*BB(1) 3191 AA(4) = G1*AA(3) + G2*AA(2) + G3*AA(1) 3192 IF (ABS(AA(4)*BB(1)-AA(1)*BB(4)).LT.EPS*ABS(BB(4)*BB(1))) 3193 1 GO TO 40 3194C 3195C IF OVERFLOWS OR UNDERFLOWS PROVE TO BE A PROBLEM, THE STATEMENTS 3196C BELOW COULD BE ALTERED TO INCORPORATE A DYNAMICALLY ADJUSTED SCALE 3197C FACTOR. 3198C 3199 DO 20 J=1,3 3200 AA(J) = AA(J+1) 3201 BB(J) = BB(J+1) 3202 20 CONTINUE 3203 30 CONTINUE 3204 WRITE(ICOUT,101) 3205 CALL DPWRST('XXX','BUG ') 3206 101 FORMAT('***** ERROR FROM D9CHU, NO CONVERGENCE IN 300 TERMS. ***') 3207 RETURN 3208C 3209 40 D9CHU = AA(4)/BB(4) 3210C 3211 IF (D9CHU .LT. SQEPS .OR. D9CHU .GT. 1.0D0/SQEPS) THEN 3212 WRITE(ICOUT,111) 3213 CALL DPWRST('XXX','BUG ') 3214 ENDIF 3215 111 FORMAT('***** WARNING FROM D9CHU, THE ANSWER IS LESS THAN HALF ', 3216 1 'PRECISION FOR CHU FUNCTION. *****.') 3217C 3218 RETURN 3219 END 3220 DOUBLE PRECISION FUNCTION D9GMIT (A, X, ALGAP1, SGNGAM, ALX) 3221C***BEGIN PROLOGUE D9GMIT 3222C***SUBSIDIARY 3223C***PURPOSE Compute Tricomi's incomplete Gamma function for small 3224C arguments. 3225C***LIBRARY SLATEC (FNLIB) 3226C***CATEGORY C7E 3227C***TYPE DOUBLE PRECISION (R9GMIT-S, D9GMIT-D) 3228C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, SMALL X, 3229C SPECIAL FUNCTIONS, TRICOMI 3230C***AUTHOR Fullerton, W., (LANL) 3231C***DESCRIPTION 3232C 3233C Compute Tricomi's incomplete gamma function for small X. 3234C 3235C***REFERENCES (NONE) 3236C***ROUTINES CALLED D1MACH, DLNGAM, XERMSG 3237C***REVISION HISTORY (YYMMDD) 3238C 770701 DATE WRITTEN 3239C 890531 Changed all specific intrinsics to generic. (WRB) 3240C 890911 Removed unnecessary intrinsics. (WRB) 3241C 890911 REVISION DATE from Version 3.2 3242C 891214 Prologue converted to Version 4.0 format. (BAB) 3243C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 3244C 900720 Routine changed from user-callable to subsidiary. (WRB) 3245C***END PROLOGUE D9GMIT 3246 DOUBLE PRECISION A, X, ALGAP1, SGNGAM, ALX, AE, AEPS, ALGS, ALG2, 3247 1 BOT, EPS, FK, S, SGNG2, T, TE, DLNGAM 3248 LOGICAL FIRST 3249 SAVE EPS, BOT, FIRST 3250C 3251C--------------------------------------------------------------------- 3252C 3253C 3254C-----COMMON---------------------------------------------------------- 3255C 3256 INCLUDE 'DPCOBE.INC' 3257 INCLUDE 'DPCOMC.INC' 3258 INCLUDE 'DPCOP2.INC' 3259C 3260 DATA FIRST /.TRUE./ 3261C 3262 ALGS=0.0D0 3263C 3264C***FIRST EXECUTABLE STATEMENT D9GMIT 3265 IF(ISUBG4.EQ.'GMIT')THEN 3266 WRITE(ICOUT,91)A,X,ALGAP1,SGNGAM,ALX 3267 91 FORMAT('FROM D9GMIT: A,X,ALGAP1,SGNGAM,ALX = ',5G15.7) 3268 CALL DPWRST('XXX','BUG ') 3269 ENDIF 3270C 3271 IF (FIRST) THEN 3272 EPS = 0.5D0*D1MACH(3) 3273 BOT = LOG (D1MACH(1)) 3274 ENDIF 3275 FIRST = .FALSE. 3276C 3277 IF (X .LE. 0.D0) THEN 3278 WRITE(ICOUT,1) 3279 1 FORMAT('***** ERORR FROM D9GMIT, X MUST BE POSITIVE. *******') 3280 CALL DPWRST('XXX','BUG ') 3281 D9GMIT=0.D0 3282 RETURN 3283 ENDIF 3284C 3285 MA = INT(A + 0.5D0) 3286 IF (A.LT.0.D0) MA = INT(A - 0.5D0) 3287 AEPS = A - REAL(MA) 3288C 3289 AE = A 3290 IF (A.LT.(-0.5D0)) AE = AEPS 3291C 3292 T = 1.D0 3293 TE = AE 3294 S = T 3295 DO 20 K=1,200 3296 FK = K 3297 TE = -X*TE/FK 3298 T = TE/(AE+FK) 3299 S = S + T 3300 IF (ABS(T).LT.EPS*ABS(S)) GO TO 30 3301 20 CONTINUE 3302C 3303 WRITE(ICOUT,21) 3304 21 FORMAT('***** ERROR FROM D9GMIT. NO CONVERGENCE IN 200') 3305 CALL DPWRST('XXX','BUG ') 3306 WRITE(ICOUT,22) 3307 22 FORMAT(' TERMS OF TAYLOR-S SERIES. ******') 3308 CALL DPWRST('XXX','BUG ') 3309 D9GMIT=0.D0 3310 RETURN 3311C 3312 30 IF (A.GE.(-0.5D0)) ALGS = -ALGAP1 + LOG(S) 3313 IF (A.GE.(-0.5D0)) GO TO 60 3314C 3315 ALGS = -DLNGAM(1.D0+AEPS) + LOG(S) 3316 S = 1.0D0 3317 M = -MA - 1 3318 IF (M.EQ.0) GO TO 50 3319 T = 1.0D0 3320 DO 40 K=1,M 3321 T = X*T/(AEPS-(M+1-K)) 3322 S = S + T 3323 IF (ABS(T).LT.EPS*ABS(S)) GO TO 50 3324 40 CONTINUE 3325C 3326 50 D9GMIT = 0.0D0 3327 ALGS = -MA*LOG(X) + ALGS 3328 IF (S.EQ.0.D0 .OR. AEPS.EQ.0.D0) GO TO 60 3329C 3330 SGNG2 = SGNGAM * SIGN (1.0D0, S) 3331 ALG2 = -X - ALGAP1 + LOG(ABS(S)) 3332C 3333 IF (ALG2.GT.BOT) D9GMIT = SGNG2 * EXP(ALG2) 3334 IF (ALGS.GT.BOT) D9GMIT = D9GMIT + EXP(ALGS) 3335 RETURN 3336C 3337 60 D9GMIT = EXP (ALGS) 3338 RETURN 3339C 3340 END 3341 DOUBLE PRECISION FUNCTION D9GMIC (A, X, ALX) 3342C***BEGIN PROLOGUE D9GMIC 3343C***SUBSIDIARY 3344C***PURPOSE Compute the complementary incomplete Gamma function for A 3345C near a negative integer and X small. 3346C***LIBRARY SLATEC (FNLIB) 3347C***CATEGORY C7E 3348C***TYPE DOUBLE PRECISION (R9GMIC-S, D9GMIC-D) 3349C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, SMALL X, 3350C SPECIAL FUNCTIONS 3351C***AUTHOR Fullerton, W., (LANL) 3352C***DESCRIPTION 3353C 3354C Compute the complementary incomplete gamma function for A near 3355C a negative integer and for small X. 3356C 3357C***REFERENCES (NONE) 3358C***ROUTINES CALLED D1MACH, DLNGAM, XERMSG 3359C***REVISION HISTORY (YYMMDD) 3360C 770701 DATE WRITTEN 3361C 890531 Changed all specific intrinsics to generic. (WRB) 3362C 890911 Removed unnecessary intrinsics. (WRB) 3363C 890911 REVISION DATE from Version 3.2 3364C 891214 Prologue converted to Version 4.0 format. (BAB) 3365C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 3366C 900720 Routine changed from user-callable to subsidiary. (WRB) 3367C***END PROLOGUE D9GMIC 3368C 3369C-----COMMON---------------------------------------------------------- 3370C 3371 INCLUDE 'DPCOMC.INC' 3372 INCLUDE 'DPCOP2.INC' 3373C 3374 DOUBLE PRECISION A, X, ALX, ALNG, BOT, EPS, EULER, FK, FKP1, FM, 3375 1 S, SGNG, T, TE, DLNGAM 3376 LOGICAL FIRST 3377 SAVE EULER, EPS, BOT, FIRST 3378 DATA EULER / 0.5772156649 0153286060 6512090082 40 D0 / 3379 DATA FIRST /.TRUE./ 3380C***FIRST EXECUTABLE STATEMENT D9GMIC 3381 IF (FIRST) THEN 3382 EPS = 0.5D0*D1MACH(3) 3383 BOT = LOG (D1MACH(1)) 3384 ENDIF 3385 FIRST = .FALSE. 3386C 3387 IF (A .GT. 0.D0) THEN 3388 WRITE(ICOUT,2) 3389 2 FORMAT('***** ERORR FROM D9GMIC, SECOND ARGUMENT MUST BE ', 3390 1 'NEAR A NEGATIVE INTEGER. *******') 3391 CALL DPWRST('XXX','BUG ') 3392 D9GMIC=0.D0 3393 RETURN 3394 ENDIF 3395 IF (X .LE. 0.D0) THEN 3396 WRITE(ICOUT,1) 3397 1 FORMAT('***** ERORR FROM D9GMIC, X MUST BE POSITIVE. *******') 3398 CALL DPWRST('XXX','BUG ') 3399 D9GMIC=0.D0 3400 RETURN 3401 ENDIF 3402C 3403 M = INT(-(A - 0.5D0)) 3404 FM = REAL(M) 3405C 3406 TE = 1.0D0 3407 T = 1.0D0 3408 S = T 3409 DO 20 K=1,200 3410 FKP1 = K + 1 3411 TE = -X*TE/(FM+FKP1) 3412 T = TE/FKP1 3413 S = S + T 3414 IF (ABS(T).LT.EPS*S) GO TO 30 3415 20 CONTINUE 3416 WRITE(ICOUT,21) 3417 21 FORMAT('***** ERROR FROM D9GMIC. NO CONVERGENCE IN 200') 3418 CALL DPWRST('XXX','BUG ') 3419 WRITE(ICOUT,22) 3420 22 FORMAT(' TERMS OF TAYLOR-S SERIES. ******') 3421 CALL DPWRST('XXX','BUG ') 3422 D9GMIC=0.D0 3423 RETURN 3424C 3425 30 D9GMIC = -ALX - EULER + X*S/(FM+1.0D0) 3426 IF (M.EQ.0) RETURN 3427C 3428 IF (M.EQ.1) D9GMIC = -D9GMIC - 1.D0 + 1.D0/X 3429 IF (M.EQ.1) RETURN 3430C 3431 TE = FM 3432 T = 1.D0 3433 S = T 3434 MM1 = M - 1 3435 DO 40 K=1,MM1 3436 FK = K 3437 TE = -X*TE/FK 3438 T = TE/(FM-FK) 3439 S = S + T 3440 IF (ABS(T).LT.EPS*ABS(S)) GO TO 50 3441 40 CONTINUE 3442C 3443 50 DO 60 K=1,M 3444 D9GMIC = D9GMIC + 1.0D0/K 3445 60 CONTINUE 3446C 3447 SGNG = 1.0D0 3448 IF (MOD(M,2).EQ.1) SGNG = -1.0D0 3449 ALNG = LOG(D9GMIC) - DLNGAM(FM+1.D0) 3450C 3451 D9GMIC = 0.D0 3452 IF (ALNG.GT.BOT) D9GMIC = SGNG * EXP(ALNG) 3453 IF (S.NE.0.D0) D9GMIC = D9GMIC + 3454 1 SIGN (EXP(-FM*ALX+LOG(ABS(S)/FM)), S) 3455C 3456 IF (D9GMIC .EQ. 0.D0 .AND. S .EQ. 0.D0) THEN 3457 WRITE(ICOUT,31) 3458 31 FORMAT('***** ERROR FROM D9GMIC. RESULT UNDERFLOWS.') 3459 CALL DPWRST('XXX','BUG ') 3460 ENDIF 3461 RETURN 3462C 3463 END 3464 DOUBLE PRECISION FUNCTION D9LGIC (A, X, ALX) 3465C***BEGIN PROLOGUE D9LGIC 3466C***SUBSIDIARY 3467C***PURPOSE Compute the log complementary incomplete Gamma function 3468C for large X and for A .LE. X. 3469C***LIBRARY SLATEC (FNLIB) 3470C***CATEGORY C7E 3471C***TYPE DOUBLE PRECISION (R9LGIC-S, D9LGIC-D) 3472C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, LARGE X, 3473C LOGARITHM, SPECIAL FUNCTIONS 3474C***AUTHOR Fullerton, W., (LANL) 3475C***DESCRIPTION 3476C 3477C Compute the log complementary incomplete gamma function for large X 3478C and for A .LE. X. 3479C 3480C***REFERENCES (NONE) 3481C***ROUTINES CALLED D1MACH, XERMSG 3482C***REVISION HISTORY (YYMMDD) 3483C 770701 DATE WRITTEN 3484C 890531 Changed all specific intrinsics to generic. (WRB) 3485C 890531 REVISION DATE from Version 3.2 3486C 891214 Prologue converted to Version 4.0 format. (BAB) 3487C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 3488C 900720 Routine changed from user-callable to subsidiary. (WRB) 3489C***END PROLOGUE D9LGIC 3490 DOUBLE PRECISION A, X, ALX, EPS, FK, P, R, S, T, XMA, XPA 3491 SAVE EPS 3492C 3493C-----COMMON---------------------------------------------------------- 3494C 3495 INCLUDE 'DPCOMC.INC' 3496 INCLUDE 'DPCOP2.INC' 3497C 3498 DATA EPS / 0.D0 / 3499C***FIRST EXECUTABLE STATEMENT D9LGIC 3500 IF (EPS.EQ.0.D0) EPS = 0.5D0*D1MACH(3) 3501C 3502 XPA = X + 1.0D0 - A 3503 XMA = X - 1.D0 - A 3504C 3505 R = 0.D0 3506 P = 1.D0 3507 S = P 3508 DO 10 K=1,300 3509 FK = K 3510 T = FK*(A-FK)*(1.D0+R) 3511 R = -T/((XMA+2.D0*FK)*(XPA+2.D0*FK)+T) 3512 P = R*P 3513 S = S + P 3514 IF (ABS(P).LT.EPS*S) GO TO 20 3515 10 CONTINUE 3516 WRITE(ICOUT,98) 3517 98 FORMAT('***** ERROR FROM D9LGIC. NO CONVERGENCE IN 300 ') 3518 CALL DPWRST('XXX','BUG ') 3519 WRITE(ICOUT,99) 3520 99 FORMAT(' TERMS OF CONTINUED FRACTION. ******') 3521 CALL DPWRST('XXX','BUG ') 3522 D9LGIC = 0.D0 3523 RETURN 3524C 3525 20 D9LGIC = A*ALX - X + LOG(S/XPA) 3526C 3527 RETURN 3528 END 3529 DOUBLE PRECISION FUNCTION D9LGIT (A, X, ALGAP1) 3530C***BEGIN PROLOGUE D9LGIT 3531C***SUBSIDIARY 3532C***PURPOSE Compute the logarithm of Tricomi's incomplete Gamma 3533C function with Perron's continued fraction for large X and 3534C A .GE. X. 3535C***LIBRARY SLATEC (FNLIB) 3536C***CATEGORY C7E 3537C***TYPE DOUBLE PRECISION (R9LGIT-S, D9LGIT-D) 3538C***KEYWORDS FNLIB, INCOMPLETE GAMMA FUNCTION, LOGARITHM, 3539C PERRON'S CONTINUED FRACTION, SPECIAL FUNCTIONS, TRICOMI 3540C***AUTHOR Fullerton, W., (LANL) 3541C***DESCRIPTION 3542C 3543C Compute the log of Tricomi's incomplete gamma function with Perron's 3544C continued fraction for large X and for A .GE. X. 3545C 3546C***REFERENCES (NONE) 3547C***ROUTINES CALLED D1MACH, XERMSG 3548C***REVISION HISTORY (YYMMDD) 3549C 770701 DATE WRITTEN 3550C 890531 Changed all specific intrinsics to generic. (WRB) 3551C 890531 REVISION DATE from Version 3.2 3552C 891214 Prologue converted to Version 4.0 format. (BAB) 3553C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 3554C 900720 Routine changed from user-callable to subsidiary. (WRB) 3555C***END PROLOGUE D9LGIT 3556 DOUBLE PRECISION A, X, ALGAP1, AX, A1X, EPS, FK, HSTAR, P, R, S, 3557 1 SQEPS, T 3558 LOGICAL FIRST 3559 SAVE EPS, SQEPS, FIRST 3560C 3561C-----COMMON---------------------------------------------------------- 3562C 3563 INCLUDE 'DPCOMC.INC' 3564 INCLUDE 'DPCOP2.INC' 3565C 3566 DATA FIRST /.TRUE./ 3567C***FIRST EXECUTABLE STATEMENT D9LGIT 3568 IF (FIRST) THEN 3569 EPS = 0.5D0*D1MACH(3) 3570 SQEPS = SQRT(D1MACH(4)) 3571 ENDIF 3572 FIRST = .FALSE. 3573C 3574 IF (X .LE. 0.D0 .OR. A .LT. X) THEN 3575 WRITE(ICOUT,11) 3576 CALL DPWRST('XXX','BUG ') 3577 WRITE(ICOUT,12) 3578 CALL DPWRST('XXX','BUG ') 3579 D9LGIT = 0.D0 3580 RETURN 3581 ENDIF 3582 11 FORMAT('***** ERROR FROM D9LGIT. X SHOULD BE POSITIVE ') 3583 12 FORMAT(' AND LESS THAN OR EQUAL TO A. ******') 3584C 3585 AX = A + X 3586 A1X = AX + 1.0D0 3587 R = 0.D0 3588 P = 1.D0 3589 S = P 3590 DO 20 K=1,200 3591 FK = K 3592 T = (A+FK)*X*(1.D0+R) 3593 R = T/((AX+FK)*(A1X+FK)-T) 3594 P = R*P 3595 S = S + P 3596 IF (ABS(P).LT.EPS*S) GO TO 30 3597 20 CONTINUE 3598 WRITE(ICOUT,21) 3599 21 FORMAT('***** ERROR FROM D9LGIT. NO CONVERGENCE IN 200 ') 3600 CALL DPWRST('XXX','BUG ') 3601 WRITE(ICOUT,22) 3602 22 FORMAT(' TERMS OF CONTINUED FRACTION. *****') 3603 CALL DPWRST('XXX','BUG ') 3604 D9LGIT = 0.D0 3605 RETURN 3606C 3607 30 HSTAR = 1.0D0 - X*S/A1X 3608 IF (HSTAR .LT. SQEPS)THEN 3609 WRITE(ICOUT,31) 3610 CALL DPWRST('XXX','BUG ') 3611 WRITE(ICOUT,32) 3612 CALL DPWRST('XXX','BUG ') 3613 ENDIF 3614 31 FORMAT('***** WARNING FROM D9LGIT. RESULT LESS THAN HALF ') 3615 32 FORMAT(' PRECISION. *****') 3616C 3617 D9LGIT = -X - ALGAP1 - LOG(HSTAR) 3618 RETURN 3619C 3620 END 3621 DOUBLE PRECISION FUNCTION D9LGMC (X) 3622C***BEGIN PROLOGUE D9LGMC 3623C***SUBSIDIARY 3624C***PURPOSE Compute the log Gamma correction factor so that 3625C LOG(DGAMMA(X)) = LOG(SQRT(2*PI)) + (X-5.)*LOG(X) - X 3626C + D9LGMC(X). 3627C***LIBRARY SLATEC (FNLIB) 3628C***CATEGORY C7E 3629C***TYPE DOUBLE PRECISION (R9LGMC-S, D9LGMC-D, C9LGMC-C) 3630C***KEYWORDS COMPLETE GAMMA FUNCTION, CORRECTION TERM, FNLIB, 3631C LOG GAMMA, LOGARITHM, SPECIAL FUNCTIONS 3632C***AUTHOR Fullerton, W., (LANL) 3633C***DESCRIPTION 3634C 3635C Compute the log gamma correction factor for X .GE. 10. so that 3636C LOG (DGAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X + D9lGMC(X) 3637C 3638C Series for ALGM on the interval 0. to 1.00000E-02 3639C with weighted error 1.28E-31 3640C log weighted error 30.89 3641C significant figures required 29.81 3642C decimal places required 31.48 3643C 3644C***REFERENCES (NONE) 3645C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG 3646C***REVISION HISTORY (YYMMDD) 3647C 770601 DATE WRITTEN 3648C 890531 Changed all specific intrinsics to generic. (WRB) 3649C 890531 REVISION DATE from Version 3.2 3650C 891214 Prologue converted to Version 4.0 format. (BAB) 3651C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 3652C 900720 Routine changed from user-callable to subsidiary. (WRB) 3653C***END PROLOGUE D9LGMC 3654 DOUBLE PRECISION X, ALGMCS(15), XBIG, XMAX, DCSEVL 3655 LOGICAL FIRST 3656 SAVE ALGMCS, NALGM, XBIG, XMAX, FIRST 3657C 3658C-----COMMON---------------------------------------------------------- 3659C 3660 INCLUDE 'DPCOMC.INC' 3661 INCLUDE 'DPCOP2.INC' 3662C 3663 DATA ALGMCS( 1) / +.1666389480 4518632472 0572965082 2 D+0 / 3664 DATA ALGMCS( 2) / -.1384948176 0675638407 3298605913 5 D-4 / 3665 DATA ALGMCS( 3) / +.9810825646 9247294261 5717154748 7 D-8 / 3666 DATA ALGMCS( 4) / -.1809129475 5724941942 6330626671 9 D-10 / 3667 DATA ALGMCS( 5) / +.6221098041 8926052271 2601554341 6 D-13 / 3668 DATA ALGMCS( 6) / -.3399615005 4177219443 0333059966 6 D-15 / 3669 DATA ALGMCS( 7) / +.2683181998 4826987489 5753884666 6 D-17 / 3670 DATA ALGMCS( 8) / -.2868042435 3346432841 4462239999 9 D-19 / 3671 DATA ALGMCS( 9) / +.3962837061 0464348036 7930666666 6 D-21 / 3672 DATA ALGMCS( 10) / -.6831888753 9857668701 1199999999 9 D-23 / 3673 DATA ALGMCS( 11) / +.1429227355 9424981475 7333333333 3 D-24 / 3674 DATA ALGMCS( 12) / -.3547598158 1010705471 9999999999 9 D-26 / 3675 DATA ALGMCS( 13) / +.1025680058 0104709120 0000000000 0 D-27 / 3676 DATA ALGMCS( 14) / -.3401102254 3167487999 9999999999 9 D-29 / 3677 DATA ALGMCS( 15) / +.1276642195 6300629333 3333333333 3 D-30 / 3678 DATA FIRST /.TRUE./ 3679C***FIRST EXECUTABLE STATEMENT D9LGMC 3680 IF (FIRST) THEN 3681 NALGM = INITDS (ALGMCS, 15, REAL(D1MACH(3)) ) 3682 XBIG = 1.0D0/SQRT(D1MACH(3)) 3683 XMAX = EXP (MIN(LOG(D1MACH(2)/12.D0), -LOG(12.D0*D1MACH(1)))) 3684 ENDIF 3685 FIRST = .FALSE. 3686C 3687 IF (X .LT. 10.D0) THEN 3688 WRITE(ICOUT,11) 3689 CALL DPWRST('XXX','BUG ') 3690 WRITE(ICOUT,12) 3691 CALL DPWRST('XXX','BUG ') 3692 D9LGMC = 0.D0 3693 RETURN 3694 ENDIF 3695 11 FORMAT('***** ERROR FROM D9LGMC. X MUST BE GREATER THAN ') 3696 12 FORMAT(' OR EQUAL TO 10. ******') 3697 IF (X.GE.XMAX) GO TO 20 3698C 3699 D9LGMC = 1.D0/(12.D0*X) 3700 IF (X.LT.XBIG) D9LGMC = DCSEVL (2.0D0*(10.D0/X)**2-1.D0, ALGMCS, 3701 1 NALGM) / X 3702 RETURN 3703C 3704 20 D9LGMC = 0.D0 3705 WRITE(ICOUT,21) 3706 21 FORMAT('***** WARNING FROM D9LGMC. X SO BIG D9LCMC UNDERFLOWS.') 3707 CALL DPWRST('XXX','BUG ') 3708 RETURN 3709C 3710 END 3711 DOUBLE PRECISION FUNCTION DBETA (A, B) 3712C***BEGIN PROLOGUE DBETA 3713C***PURPOSE Compute the complete Beta function. 3714C***LIBRARY SLATEC (FNLIB) 3715C***CATEGORY C7B 3716C***TYPE DOUBLE PRECISION (BETA-S, DBETA-D, CBETA-C) 3717C***KEYWORDS COMPLETE BETA FUNCTION, FNLIB, SPECIAL FUNCTIONS 3718C***AUTHOR Fullerton, W., (LANL) 3719C***DESCRIPTION 3720C 3721C DBETA(A,B) calculates the double precision complete beta function 3722C for double precision arguments A and B. 3723C 3724C***REFERENCES (NONE) 3725C***ROUTINES CALLED D1MACH, DGAMLM, DGAMMA, DLBETA, XERMSG 3726C***REVISION HISTORY (YYMMDD) 3727C 770601 DATE WRITTEN 3728C 890531 Changed all specific intrinsics to generic. (WRB) 3729C 890531 REVISION DATE from Version 3.2 3730C 891214 Prologue converted to Version 4.0 format. (BAB) 3731C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 3732C 900727 Added EXTERNAL statement. (WRB) 3733C***END PROLOGUE DBETA 3734 DOUBLE PRECISION A, B, ALNSML, XMAX, XMIN, DLBETA, DGAMMA 3735 LOGICAL FIRST 3736 EXTERNAL DGAMMA 3737 SAVE XMAX, ALNSML, FIRST 3738C 3739C-----COMMON---------------------------------------------------------- 3740C 3741 INCLUDE 'DPCOMC.INC' 3742 INCLUDE 'DPCOP2.INC' 3743C 3744 DATA FIRST /.TRUE./ 3745C***FIRST EXECUTABLE STATEMENT DBETA 3746C 3747 DBETA = 0.0D0 3748C 3749 IF (FIRST) THEN 3750 CALL DGAMLM (XMIN, XMAX) 3751 ALNSML = LOG (D1MACH(1)) 3752 ENDIF 3753 FIRST = .FALSE. 3754C 3755 IF (A .LE. 0.D0 .OR. B .LE. 0.D0) THEN 3756 WRITE(ICOUT,11) 3757 CALL DPWRST('XXX','BUG ') 3758 WRITE(ICOUT,12) 3759 CALL DPWRST('XXX','BUG ') 3760 DBETA = 0.D0 3761 RETURN 3762 ENDIF 3763 11 FORMAT('***** ERROR FROM DBETA. BOTH THE ARGUMENTS MUST ') 3764 12 FORMAT(' BE POSITIVE. ****') 3765C 3766 IF (A+B.LT.XMAX) DBETA = DGAMMA(A)*DGAMMA(B)/DGAMMA(A+B) 3767 IF (A+B.LT.XMAX) RETURN 3768C 3769 DBETA = DLBETA (A, B) 3770 IF (DBETA.LT.ALNSML) GO TO 20 3771 DBETA = EXP (DBETA) 3772 RETURN 3773C 3774 20 DBETA = 0.D0 3775 WRITE(ICOUT,21) 3776 CALL DPWRST('XXX','BUG ') 3777 WRITE(ICOUT,22) 3778 CALL DPWRST('XXX','BUG ') 3779 21 FORMAT('***** ERROR FROM DBETA. ALPHA AND BETA ARE SO ') 3780 22 FORMAT(' LARGE THAT THE BETA FUNCTION OVERFLOWS. *****') 3781 RETURN 3782C 3783 END 3784 DOUBLE PRECISION FUNCTION DBETAI (X, PIN, QIN) 3785C***BEGIN PROLOGUE DBETAI 3786C***PURPOSE Calculate the incomplete Beta function. 3787C***LIBRARY SLATEC (FNLIB) 3788C***CATEGORY C7F 3789C***TYPE DOUBLE PRECISION (BETAI-S, DBETAI-D) 3790C***KEYWORDS FNLIB, INCOMPLETE BETA FUNCTION, SPECIAL FUNCTIONS 3791C***AUTHOR Fullerton, W., (LANL) 3792C***DESCRIPTION 3793C 3794C DBETAI calculates the DOUBLE PRECISION incomplete beta function. 3795C 3796C The incomplete beta function ratio is the probability that a 3797C random variable from a beta distribution having parameters PIN and 3798C QIN will be less than or equal to X. 3799C 3800C -- Input Arguments -- All arguments are DOUBLE PRECISION. 3801C X upper limit of integration. X must be in (0,1) inclusive. 3802C PIN first beta distribution parameter. PIN must be .GT. 0.0. 3803C QIN second beta distribution parameter. QIN must be .GT. 0.0. 3804C 3805C***REFERENCES Nancy E. Bosten and E. L. Battiste, Remark on Algorithm 3806C 179, Communications of the ACM 17, 3 (March 1974), 3807C pp. 156. 3808C***ROUTINES CALLED D1MACH, DLBETA, XERMSG 3809C***REVISION HISTORY (YYMMDD) 3810C 770701 DATE WRITTEN 3811C 890531 Changed all specific intrinsics to generic. (WRB) 3812C 890911 Removed unnecessary intrinsics. (WRB) 3813C 890911 REVISION DATE from Version 3.2 3814C 891214 Prologue converted to Version 4.0 format. (BAB) 3815C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 3816C 920528 DESCRIPTION and REFERENCES sections revised. (WRB) 3817C***END PROLOGUE DBETAI 3818 DOUBLE PRECISION X, PIN, QIN, ALNEPS, ALNSML, C, EPS, FINSUM, P, 3819 1 PS, Q, SML, TERM, XB, XI, Y, DLBETA, P1 3820 LOGICAL FIRST 3821 SAVE EPS, ALNEPS, SML, ALNSML, FIRST 3822C 3823C-----COMMON---------------------------------------------------------- 3824C 3825 INCLUDE 'DPCOMC.INC' 3826 INCLUDE 'DPCOP2.INC' 3827C 3828 DATA FIRST /.TRUE./ 3829C***FIRST EXECUTABLE STATEMENT DBETAI 3830 IF (FIRST) THEN 3831 EPS = D1MACH(3) 3832 ALNEPS = LOG (EPS) 3833 SML = D1MACH(1) 3834 ALNSML = LOG (SML) 3835 ENDIF 3836 FIRST = .FALSE. 3837C 3838 IF (X .LT. 0.D0 .OR. X .GT. 1.D0) THEN 3839 WRITE(ICOUT,11) 3840 CALL DPWRST('XXX','BUG ') 3841 WRITE(ICOUT,12) 3842 CALL DPWRST('XXX','BUG ') 3843 DBETAI = 0.D0 3844 RETURN 3845 ENDIF 3846 11 FORMAT('***** ERROR FROM DBETAI. X IS NOT IN THE RANGE ') 3847 12 FORMAT(' (0,1). *****') 3848 IF (PIN .LE. 0.D0 .OR. QIN .LE. 0.D0) THEN 3849 WRITE(ICOUT,16) 3850 CALL DPWRST('XXX','BUG ') 3851 WRITE(ICOUT,17) 3852 CALL DPWRST('XXX','BUG ') 3853 DBETAI = 0.D0 3854 RETURN 3855 ENDIF 3856 16 FORMAT('***** ERROR FROM DBETAI. P AND/OR Q IS LESS THAN ') 3857 17 FORMAT(' OR EQUAL TO ZERO. *****') 3858C 3859 Y = X 3860 P = PIN 3861 Q = QIN 3862 IF (Q.LE.P .AND. X.LT.0.8D0) GO TO 20 3863 IF (X.LT.0.2D0) GO TO 20 3864 Y = 1.0D0 - Y 3865 P = QIN 3866 Q = PIN 3867C 3868 20 IF ((P+Q)*Y/(P+1.D0).LT.EPS) GO TO 80 3869C 3870C EVALUATE THE INFINITE SUM FIRST. TERM WILL EQUAL 3871C Y**P/BETA(PS,P) * (1.-PS)-SUB-I * Y**I / FAC(I) . 3872C 3873 PS = Q - AINT(Q) 3874 IF (PS.EQ.0.D0) PS = 1.0D0 3875 XB = P*LOG(Y) - DLBETA(PS,P) - LOG(P) 3876 DBETAI = 0.0D0 3877 IF (XB.LT.ALNSML) GO TO 40 3878C 3879 DBETAI = EXP (XB) 3880 TERM = DBETAI*P 3881 IF (PS.EQ.1.0D0) GO TO 40 3882 N = INT(MAX (ALNEPS/LOG(Y), 4.0D0)) 3883 DO 30 I=1,N 3884 XI = REAL(I) 3885 TERM = TERM * (XI-PS)*Y/XI 3886 DBETAI = DBETAI + TERM/(P+XI) 3887 30 CONTINUE 3888C 3889C NOW EVALUATE THE FINITE SUM, MAYBE. 3890C 3891 40 IF (Q.LE.1.0D0) GO TO 70 3892C 3893 XB = P*LOG(Y) + Q*LOG(1.0D0-Y) - DLBETA(P,Q) - LOG(Q) 3894 IB = INT(MAX (XB/ALNSML, 0.0D0)) 3895 TERM = EXP(XB - IB*ALNSML) 3896 C = 1.0D0/(1.D0-Y) 3897 P1 = Q*C/(P+Q-1.D0) 3898C 3899 FINSUM = 0.0D0 3900 N = INT(Q) 3901 IF (Q.EQ.DBLE(N)) N = N - 1 3902 DO 50 I=1,N 3903 IF (P1.LE.1.0D0 .AND. TERM/EPS.LE.FINSUM) GO TO 60 3904 XI = I 3905 TERM = (Q-XI+1.0D0)*C*TERM/(P+Q-XI) 3906C 3907 IF (TERM.GT.1.0D0) IB = IB - 1 3908 IF (TERM.GT.1.0D0) TERM = TERM*SML 3909C 3910 IF (IB.EQ.0) FINSUM = FINSUM + TERM 3911 50 CONTINUE 3912C 3913 60 DBETAI = DBETAI + FINSUM 3914 70 IF (Y.NE.X .OR. P.NE.PIN) DBETAI = 1.0D0 - DBETAI 3915 DBETAI = MAX (MIN (DBETAI, 1.0D0), 0.0D0) 3916 RETURN 3917C 3918 80 DBETAI = 0.0D0 3919 XB = P*LOG(MAX(Y,SML)) - LOG(P) - DLBETA(P,Q) 3920 IF (XB.GT.ALNSML .AND. Y.NE.0.0D0) DBETAI = EXP(XB) 3921 IF (Y.NE.X .OR. P.NE.PIN) DBETAI = 1.0D0 - DBETAI 3922C 3923 RETURN 3924 END 3925 DOUBLE PRECISION FUNCTION DEBYE1(XVALUE) 3926C 3927C 3928C DEFINITION: 3929C 3930C This program calculates the Debye function of order 1, defined as 3931C 3932C DEBYE1(x) = [Integral {0 to x} t/(exp(t)-1) dt] / x 3933C 3934C The code uses Chebyshev series whose coefficients 3935C are given to 20 decimal places. 3936C 3937C 3938C ERROR RETURNS: 3939C 3940C If XVALUE < 0.0 an error message is printed and the 3941C function returns the value 0.0 3942C 3943C 3944C MACHINE-DEPENDENT PARAMETERS: 3945C 3946C NTERMS - INTEGER - The no. of elements of the array ADEB1. 3947C The recommended value is such that 3948C ABS(ADEB1(NTERMS)) < EPS/100 , with 3949C 1 <= NTERMS <= 18 3950C 3951C XLOW - DOUBLE PRECISION - The value below which 3952C DEBYE1 = 1 - x/4 + x*x/36 to machine precision. 3953C The recommended value is 3954C SQRT(8*EPSNEG) 3955C 3956C XUPPER - DOUBLE PRECISION - The value above which 3957C DEBYE1 = (pi*pi/(6*x)) - exp(-x)(x+1)/x. 3958C The recommended value is 3959C -LOG(2*EPS) 3960C 3961C XLIM - DOUBLE PRECISION - The value above which DEBYE1 = pi*pi/(6*x) 3962C The recommended value is 3963C -LOG(XMIN) 3964C 3965C For values of EPS, EPSNEG, and XMIN see the file MACHCON.TXT 3966C 3967C The machine-dependent constants are computed internally by 3968C using the D1MACH subroutine. 3969C 3970C 3971C INTRINSIC FUNCTIONS USED: 3972C 3973C AINT , EXP , INT , LOG , SQRT 3974C 3975C 3976C OTHER MISCFUN SUBROUTINES USED: 3977C 3978C CHEVAL , ERRPRN, D1MACH 3979C 3980C 3981C AUTHOR: 3982C Dr. Allan J. MacLeod, 3983C Dept. of Mathematics and Statistics, 3984C University of Paisley 3985C High St. 3986C PAISLEY 3987C SCOTLAND 3988C PA1 2BE 3989C 3990C (e-mail: macl_ms0@paisley.ac.uk ) 3991C 3992C 3993C LATEST UPDATE: 23 january, 1996 3994C 3995 INTEGER I,NEXP,NTERMS 3996 DOUBLE PRECISION ADEB1(0:18),CHEVAL,DEBINF,EIGHT,EXPMX,FOUR,HALF, 3997 & NINE,ONE,ONEHUN,QUART,RK,SUM,T,THIRT6,X,XK,XLIM,XLOW, 3998 & XUPPER,XVALUE,ZERO 3999CCCCC CHARACTER FNNAME*6,ERRMSG*17 4000C 4001C-----COMMON---------------------------------------------------------- 4002C 4003 INCLUDE 'DPCOMC.INC' 4004 INCLUDE 'DPCOP2.INC' 4005C 4006CCCCC DATA FNNAME/'DEBYE1'/ 4007CCCCC DATA ERRMSG/'ARGUMENT NEGATIVE'/ 4008 DATA ZERO,QUART/0.0 D 0 , 0.25 D 0/ 4009 DATA HALF,ONE/0.5 D 0 , 1.0 D 0/ 4010 DATA FOUR,EIGHT/4.0 D 0 , 8.0 D 0/ 4011 DATA NINE,THIRT6,ONEHUN/9.0 D 0 , 36.0 D 0 , 100.0 D 0/ 4012 DATA DEBINF/0.60792 71018 54026 62866 D 0/ 4013 DATA ADEB1/2.40065 97190 38141 01941 D 0, 4014 1 0.19372 13042 18936 00885 D 0, 4015 2 -0.62329 12455 48957 703 D -2, 4016 3 0.35111 74770 20648 00 D -3, 4017 4 -0.22822 24667 01231 0 D -4, 4018 5 0.15805 46787 50300 D -5, 4019 6 -0.11353 78197 0719 D -6, 4020 7 0.83583 36118 75 D -8, 4021 8 -0.62644 24787 2 D -9, 4022 9 0.47603 34890 D -10, 4023 X -0.36574 1540 D -11, 4024 1 0.28354 310 D -12, 4025 2 -0.22147 29 D -13, 4026 3 0.17409 2 D -14, 4027 4 -0.13759 D -15, 4028 5 0.1093 D -16, 4029 6 -0.87 D -18, 4030 7 0.7 D -19, 4031 8 -0.1 D -19/ 4032C 4033C Start computation 4034C 4035 X = XVALUE 4036C 4037C Check XVALUE >= 0.0 4038C 4039 IF ( X .LT. ZERO ) THEN 4040CCCCC CALL ERRPRN(FNNAME,ERRMSG) 4041 WRITE(ICOUT,999) 4042 CALL DPWRST('XXX','BUG ') 4043 WRITE(ICOUT,101)X 4044 CALL DPWRST('XXX','BUG ') 4045 DEBYE1 = ZERO 4046 RETURN 4047 ENDIF 4048 999 FORMAT(1X) 4049 101 FORMAT('***** ERROR FROM DEBYE1--ARGUMENT MUST BE ', 4050 1 'NON-NEGATIVE, ARGUMENT = ',G15.7) 4051C 4052C Compute the machine-dependent constants. 4053C 4054 T = D1MACH(3) 4055 XLOW = SQRT ( T * EIGHT ) 4056 XUPPER = - LOG( T + T ) 4057 XLIM = - LOG( D1MACH(1) ) 4058 T = T / ONEHUN 4059 DO 10 NTERMS = 18 , 0 , -1 4060 IF ( ABS(ADEB1(NTERMS)) .GT. T ) GOTO 19 4061 10 CONTINUE 4062C 4063C Code for x <= 4.0 4064C 4065 19 IF ( X .LE. FOUR ) THEN 4066 IF ( X .LT. XLOW ) THEN 4067 DEBYE1 = ( ( X - NINE ) * X + THIRT6 ) / THIRT6 4068 ELSE 4069 T = ( ( X * X / EIGHT ) - HALF ) - HALF 4070 DEBYE1 = CHEVAL( NTERMS , ADEB1 , T ) - QUART * X 4071 ENDIF 4072 ELSE 4073C 4074C Code for x > 4.0 4075C 4076 DEBYE1 = ONE / ( X * DEBINF ) 4077 IF ( X .LT. XLIM ) THEN 4078 EXPMX = EXP( -X ) 4079 IF ( X .GT. XUPPER ) THEN 4080 DEBYE1 = DEBYE1 - EXPMX * ( ONE + ONE / X ) 4081 ELSE 4082 SUM = ZERO 4083 RK = AINT( XLIM / X ) 4084 NEXP = INT( RK ) 4085 XK = RK * X 4086 DO 100 I = NEXP,1,-1 4087 T = ( ONE + ONE / XK ) / RK 4088 SUM = SUM * EXPMX + T 4089 RK = RK - ONE 4090 XK = XK - X 4091 100 CONTINUE 4092 DEBYE1 = DEBYE1 - SUM * EXPMX 4093 ENDIF 4094 ENDIF 4095 ENDIF 4096 RETURN 4097 END 4098 DOUBLE PRECISION FUNCTION DEBYE2(XVALUE) 4099C 4100C 4101C DEFINITION: 4102C 4103C This program calculates the Debye function of order 1, defined as 4104C 4105C DEBYE2(x) = 2*[Integral {0 to x} t*t/(exp(t)-1) dt] / (x*x) 4106C 4107C The code uses Chebyshev series whose coefficients 4108C are given to 20 decimal places. 4109C 4110C 4111C ERROR RETURNS: 4112C 4113C If XVALUE < 0.0 an error message is printed and the 4114C function returns the value 0.0 4115C 4116C 4117C MACHINE-DEPENDENT PARAMETERS: 4118C 4119C NTERMS - INTEGER - The no. of elements of the array ADEB2. 4120C The recommended value is such that 4121C ABS(ADEB2(NTERMS)) < EPS/100, 4122C subject to 1 <= NTERMS <= 18. 4123C 4124C XLOW - DOUBLE PRECISION - The value below which 4125C DEBYE2 = 1 - x/3 + x*x/24 to machine precision. 4126C The recommended value is 4127C SQRT(8*EPSNEG) 4128C 4129C XUPPER - DOUBLE PRECISION - The value above which 4130C DEBYE2 = (4*zeta(3)/x^2) - 2*exp(-x)(x^2+2x+1)/x^2. 4131C The recommended value is 4132C -LOG(2*EPS) 4133C 4134C XLIM1 - DOUBLE PRECISION - The value above which DEBYE2 = 4*zeta(3)/x^2 4135C The recommended value is 4136C -LOG(XMIN) 4137C 4138C XLIM2 - DOUBLE PRECISION - The value above which DEBYE2 = 0.0 to machine 4139C precision. The recommended value is 4140C SQRT(4.8/XMIN) 4141C 4142C For values of EPS, EPSNEG, and XMIN see the file MACHCON.TXT 4143C 4144C 4145C The machine-dependent constants are computed internally by 4146C using the D1MACH subroutine. 4147C 4148C 4149C INTRINSIC FUNCTIONS USED: 4150C 4151C AINT , EXP , INT , LOG , SQRT 4152C 4153C 4154C OTHER MISCFUN SUBROUTINES USED: 4155C 4156C CHEVAL , ERRPRN, D1MACH 4157C 4158C 4159C AUTHOR: 4160C Dr. Allan J. MacLeod, 4161C Dept. of Mathematics and Statistics, 4162C University of Paisley 4163C High St. 4164C PAISLEY 4165C SCOTLAND 4166C PA1 2BE 4167C 4168C (e-mail: macl_ms0@paisley.ac.uk ) 4169C 4170C 4171C LATEST UPDATE: 23 January, 1996 4172C 4173 INTEGER I,NEXP,NTERMS 4174 DOUBLE PRECISION ADEB2(0:18),CHEVAL,DEBINF,EIGHT,EXPMX,FOUR, 4175 & HALF,ONE,ONEHUN,RK,SUM,T,THREE,TWENT4,TWO,X,XK,XLIM1, 4176 & XLIM2,XLOW,XUPPER,XVALUE,ZERO 4177CCCCC CHARACTER FNNAME*6,ERRMSG*17 4178C 4179C-----COMMON---------------------------------------------------------- 4180C 4181 INCLUDE 'DPCOMC.INC' 4182 INCLUDE 'DPCOP2.INC' 4183C 4184CCCCC DATA FNNAME/'DEBYE2'/ 4185CCCCC DATA ERRMSG/'ARGUMENT NEGATIVE'/ 4186 DATA ZERO,HALF/0.0 D 0 , 0.5 D 0/ 4187 DATA ONE,TWO,THREE/1.0 D 0 , 2.0 D 0 , 3.0 D 0/ 4188 DATA FOUR,EIGHT,TWENT4/4.0 D 0 , 8.0 D 0 , 24.0 D 0/ 4189 DATA ONEHUN/100.0 D 0/ 4190 DATA DEBINF/4.80822 76126 38377 14160 D 0/ 4191 DATA ADEB2/2.59438 10232 57077 02826 D 0, 4192 1 0.28633 57204 53071 98337 D 0, 4193 2 -0.10206 26561 58046 7129 D -1, 4194 3 0.60491 09775 34684 35 D -3, 4195 4 -0.40525 76589 50210 4 D -4, 4196 5 0.28633 82632 88107 D -5, 4197 6 -0.20863 94303 0651 D -6, 4198 7 0.15523 78758 264 D -7, 4199 8 -0.11731 28008 66 D -8, 4200 9 0.89735 85888 D -10, 4201 X -0.69317 6137 D -11, 4202 1 0.53980 568 D -12, 4203 2 -0.42324 05 D -13, 4204 3 0.33377 8 D -14, 4205 4 -0.26455 D -15, 4206 5 0.2106 D -16, 4207 6 -0.168 D -17, 4208 7 0.13 D -18, 4209 8 -0.1 D -19/ 4210C 4211C Start computation 4212C 4213 X = XVALUE 4214C 4215C Check XVALUE >= 0.0 4216C 4217 IF ( X .LT. ZERO ) THEN 4218CCCCC CALL ERRPRN(FNNAME,ERRMSG) 4219 WRITE(ICOUT,999) 4220 CALL DPWRST('XXX','BUG ') 4221 WRITE(ICOUT,101)X 4222 CALL DPWRST('XXX','BUG ') 4223 DEBYE2 = ZERO 4224 RETURN 4225 ENDIF 4226 999 FORMAT(1X) 4227 101 FORMAT('***** ERROR FROM DEBYE2--ARGUMENT MUST BE ', 4228 1 'NON-NEGATIVE, ARGUMENT = ',G15.7) 4229C 4230C Compute the machine-dependent constants. 4231C 4232 T = D1MACH(1) 4233 XLIM1 = - LOG( T ) 4234 XLIM2 = SQRT( DEBINF ) / SQRT( T ) 4235 T = D1MACH(3) 4236 XLOW = SQRT ( T * EIGHT ) 4237 XUPPER = - LOG( T + T ) 4238 T = T / ONEHUN 4239 DO 10 NTERMS = 18 , 0 , -1 4240 IF ( ABS(ADEB2(NTERMS)) .GT. T ) GOTO 19 4241 10 CONTINUE 4242C 4243C Code for x <= 4.0 4244C 4245 19 IF ( X .LE. FOUR ) THEN 4246 IF ( X .LT. XLOW ) THEN 4247 DEBYE2 = ( ( X - EIGHT ) * X + TWENT4 ) / TWENT4 4248 ELSE 4249 T = ( ( X * X / EIGHT ) - HALF ) - HALF 4250 DEBYE2 = CHEVAL ( NTERMS , ADEB2 , T ) - X / THREE 4251 ENDIF 4252 ELSE 4253C 4254C Code for x > 4.0 4255C 4256 IF ( X .GT. XLIM2 ) THEN 4257 DEBYE2 = ZERO 4258 ELSE 4259 DEBYE2 = DEBINF / ( X * X ) 4260 IF ( X .LT. XLIM1 ) THEN 4261 EXPMX = EXP ( -X ) 4262 IF ( X .GT. XUPPER ) THEN 4263 SUM = ( ( X + TWO ) * X + TWO ) / ( X * X ) 4264 ELSE 4265 SUM = ZERO 4266 RK = AINT ( XLIM1 / X ) 4267 NEXP = INT ( RK ) 4268 XK = RK * X 4269 DO 100 I = NEXP,1,-1 4270 T = ( ONE + TWO / XK + TWO / ( XK*XK ) ) / RK 4271 SUM = SUM * EXPMX + T 4272 RK = RK - ONE 4273 XK = XK - X 4274 100 CONTINUE 4275 ENDIF 4276 DEBYE2 = DEBYE2 - TWO * SUM * EXPMX 4277 ENDIF 4278 ENDIF 4279 ENDIF 4280 RETURN 4281 END 4282 DOUBLE PRECISION FUNCTION DEBYE3(XVALUE) 4283C 4284C 4285C DEFINITION: 4286C 4287C This program calculates the Debye function of order 3, defined as 4288C 4289C DEBYE3(x) = 3*[Integral {0 to x} t^3/(exp(t)-1) dt] / (x^3) 4290C 4291C The code uses Chebyshev series whose coefficients 4292C are given to 20 decimal places. 4293C 4294C 4295C ERROR RETURNS: 4296C 4297C If XVALUE < 0.0 an error message is printed and the 4298C function returns the value 0.0 4299C 4300C 4301C MACHINE-DEPENDENT PARAMETERS: 4302C 4303C NTERMS - INTEGER - The no. of elements of the array ADEB3. 4304C The recommended value is such that 4305C ABS(ADEB3(NTERMS)) < EPS/100, 4306C subject to 1 <= NTERMS <= 18 4307C 4308C XLOW - DOUBLE PRECISION - The value below which 4309C DEBYE3 = 1 - 3x/8 + x*x/20 to machine precision. 4310C The recommended value is 4311C SQRT(8*EPSNEG) 4312C 4313C XUPPER - DOUBLE PRECISION - The value above which 4314C DEBYE3 = (18*zeta(4)/x^3) - 3*exp(-x)(x^3+3x^2+6x+6)/x^3. 4315C The recommended value is 4316C -LOG(2*EPS) 4317C 4318C XLIM1 - DOUBLE PRECISION - The value above which DEBYE3 = 18*zeta(4)/x^3 4319C The recommended value is 4320C -LOG(XMIN) 4321C 4322C XLIM2 - DOUBLE PRECISION - The value above which DEBYE3 = 0.0 to machine 4323C precision. The recommended value is 4324C CUBE ROOT(19/XMIN) 4325C 4326C For values of EPS, EPSNEG, and XMIN see the file MACHCON.TXT 4327C 4328C The machine-dependent constants are computed internally by 4329C using the D1MACH subroutine. 4330C 4331C 4332C OTHER MISCFUN SUBROUTINES USED: 4333C 4334C CHEVAL , ERRPRN, D1MACH 4335C 4336C 4337C INTRINSIC FUNCTIONS USED: 4338C 4339C AINT , EXP , INT , LOG , SQRT 4340C 4341C 4342C AUTHOR: 4343C Dr. Allan J. MacLeod, 4344C Dept. of Mathematics and Statistics, 4345C University of Paisley 4346C High St. 4347C PAISLEY 4348C SCOTLAND 4349C PA1 2BE 4350C 4351C (e-mail: macl_ms0@paisley.ac.uk ) 4352C 4353C 4354C LATEST UPDATE: 23 January, 1996 4355C 4356 INTEGER I,NEXP,NTERMS 4357 DOUBLE PRECISION ADEB3(0:18),CHEVAL,DEBINF,EIGHT,EXPMX,FOUR, 4358 & HALF,ONE,ONEHUN,PT375,RK,SEVP5,SIX,SUM,T,THREE,TWENTY,X, 4359 & XK,XKI,XLIM1,XLIM2,XLOW,XUPPER,XVALUE,ZERO 4360CCCCC CHARACTER FNNAME*6,ERRMSG*17 4361C 4362C-----COMMON---------------------------------------------------------- 4363C 4364 INCLUDE 'DPCOMC.INC' 4365 INCLUDE 'DPCOP2.INC' 4366C 4367CCCCC DATA FNNAME/'DEBYE3'/ 4368CCCCC DATA ERRMSG/'ARGUMENT NEGATIVE'/ 4369 DATA ZERO,PT375/0.0 D 0 , 0.375 D 0/ 4370 DATA HALF,ONE/0.5 D 0 , 1.0 D 0/ 4371 DATA THREE,FOUR,SIX/3.0 D 0 , 4.0 D 0 , 6.0 D 0/ 4372 DATA SEVP5,EIGHT,TWENTY/7.5 D 0 , 8.0 D 0 , 20.0 D 0/ 4373 DATA ONEHUN/100.0 D 0/ 4374 DATA DEBINF/0.51329 91127 34216 75946 D -1/ 4375 DATA ADEB3/2.70773 70683 27440 94526 D 0, 4376 1 0.34006 81352 11091 75100 D 0, 4377 2 -0.12945 15018 44408 6863 D -1, 4378 3 0.79637 55380 17381 64 D -3, 4379 4 -0.54636 00095 90823 8 D -4, 4380 5 0.39243 01959 88049 D -5, 4381 6 -0.28940 32823 5386 D -6, 4382 7 0.21731 76139 625 D -7, 4383 8 -0.16542 09994 98 D -8, 4384 9 0.12727 96189 2 D -9, 4385 X -0.98796 3459 D -11, 4386 1 0.77250 740 D -12, 4387 2 -0.60779 72 D -13, 4388 3 0.48075 9 D -14, 4389 4 -0.38204 D -15, 4390 5 0.3048 D -16, 4391 6 -0.244 D -17, 4392 7 0.20 D -18, 4393 8 -0.2 D -19/ 4394C 4395C Start computation 4396C 4397 X = XVALUE 4398C 4399C Error test 4400C 4401 IF ( X .LT. ZERO ) THEN 4402CCCCC CALL ERRPRN(FNNAME,ERRMSG) 4403 WRITE(ICOUT,999) 4404 CALL DPWRST('XXX','BUG ') 4405 WRITE(ICOUT,101)X 4406 CALL DPWRST('XXX','BUG ') 4407 DEBYE3 = ZERO 4408 RETURN 4409 ENDIF 4410 999 FORMAT(1X) 4411 101 FORMAT('***** ERROR FROM DEBYE3--ARGUMENT MUST BE ', 4412 1 'NON-NEGATIVE, ARGUMENT = ',G15.7) 4413C 4414C Compute the machine-dependent constants. 4415C 4416 T = D1MACH(1) 4417 XLIM1 = - LOG( T ) 4418 XK = ONE / THREE 4419 XKI = (ONE/DEBINF) ** XK 4420 RK = T ** XK 4421 XLIM2 = XKI / RK 4422 T = D1MACH(3) 4423 XLOW = SQRT ( T * EIGHT ) 4424 XUPPER = - LOG( T + T ) 4425 T = T / ONEHUN 4426 DO 10 NTERMS = 18 , 0 , -1 4427 IF ( ABS(ADEB3(NTERMS)) .GT. T ) GOTO 19 4428 10 CONTINUE 4429C 4430C Code for x <= 4.0 4431C 4432 19 IF ( X .LE. FOUR ) THEN 4433 IF ( X .LT. XLOW ) THEN 4434 DEBYE3 = ( ( X - SEVP5 ) * X + TWENTY ) / TWENTY 4435 ELSE 4436 T = ( ( X * X / EIGHT ) - HALF ) - HALF 4437 DEBYE3 = CHEVAL ( NTERMS , ADEB3 , T ) - PT375 * X 4438 ENDIF 4439 ELSE 4440C 4441C Code for x > 4.0 4442C 4443 IF ( X .GT. XLIM2 ) THEN 4444 DEBYE3 = ZERO 4445 ELSE 4446 DEBYE3 = ONE / ( DEBINF * X * X * X ) 4447 IF ( X .LT. XLIM1 ) THEN 4448 EXPMX = EXP ( -X ) 4449 IF ( X .GT. XUPPER ) THEN 4450 SUM = (((X+THREE)*X+SIX)*X+SIX) / (X*X*X) 4451 ELSE 4452 SUM = ZERO 4453 RK = AINT ( XLIM1 / X ) 4454 NEXP = INT ( RK ) 4455 XK = RK * X 4456 DO 100 I = NEXP,1,-1 4457 XKI = ONE / XK 4458 T = (((SIX*XKI+SIX)*XKI+THREE)*XKI+ONE) / RK 4459 SUM = SUM * EXPMX + T 4460 RK = RK - ONE 4461 XK = XK - X 4462 100 CONTINUE 4463 ENDIF 4464 DEBYE3 = DEBYE3 - THREE * SUM * EXPMX 4465 ENDIF 4466 ENDIF 4467 ENDIF 4468 RETURN 4469 END 4470 DOUBLE PRECISION FUNCTION DEBYE4(XVALUE) 4471C 4472C 4473C DEFINITION: 4474C 4475C This program calculates the Debye function of order 4, defined as 4476C 4477C DEBYE4(x) = 4*[Integral {0 to x} t^4/(exp(t)-1) dt] / (x^4) 4478C 4479C The code uses Chebyshev series whose coefficients 4480C are given to 20 decimal places. 4481C 4482C 4483C ERROR RETURNS: 4484C 4485C If XVALUE < 0.0 an error message is printed and the 4486C function returns the value 0.0 4487C 4488C 4489C MACHINE-DEPENDENT PARAMETERS: 4490C 4491C NTERMS - INTEGER - The no. of elements of the array ADEB4. 4492C The recommended value is such that 4493C ABS(ADEB4(NTERMS)) < EPS/100, 4494C subject to 1 <= NTERMS <= 18 4495C 4496C XLOW - DOUBLE PRECISION - The value below which 4497C DEBYE4 = 1 - 4x/10 + x*x/18 to machine precision. 4498C The recommended value is 4499C SQRT(8*EPSNEG) 4500C 4501C XUPPER - DOUBLE PRECISION - The value above which 4502C DEBYE4=(96*zeta(5)/x^4)-4*exp(-x)(x^4+4x^2+12x^2+24x+24)/x^4. 4503C The recommended value is 4504C -LOG(2*EPS) 4505C 4506C XLIM1 - DOUBLE PRECISION - The value above which DEBYE4 = 96*zeta(5)/x^4 4507C The recommended value is 4508C -LOG(XMIN) 4509C 4510C XLIM2 - DOUBLE PRECISION - The value above which DEBYE4 = 0.0 to machine 4511C precision. The recommended value is 4512C FOURTH ROOT(99/XMIN) 4513C 4514C For values of EPS, EPSNEG, and XMIN see the file MACHCON.TXT 4515C 4516C 4517C The machine-dependent constants are computed internally by 4518C using the D1MACH subroutine. 4519C 4520C 4521C INTRINSIC FUNCTIONS USED: 4522C 4523C AINT , EXP , INT , LOG , SQRT 4524C 4525C 4526C OTHER MISCFUN SUBROUTINES USED: 4527C 4528C CHEVAL , ERRPRN, D1MACH 4529C 4530C 4531C AUTHOR: 4532C Dr. Allan J. MacLeod, 4533C Dept. of Mathematics and Statistics, 4534C University of Paisley 4535C High St. 4536C PAISLEY 4537C SCOTLAND 4538C PA1 2BE 4539C 4540C (e-mail: macl_ms0@paisley.ac.uk ) 4541C 4542C 4543C LATEST UPDATE: 23 January, 1996 4544C 4545 INTEGER I,NEXP,NTERMS 4546 DOUBLE PRECISION ADEB4(0:18),CHEVAL,DEBINF,EIGHT,EIGHTN,EXPMX, 4547 1 FIVE,FOUR,FORTY5,HALF,ONE,ONEHUN,RK,SUM,T,TWELVE,TWENT4, 4548 2 TWOPT5,X,XK,XKI,XLIM1,XLIM2,XLOW,XUPPER,XVALUE,ZERO 4549CCCCC CHARACTER FNNAME*6,ERRMSG*17 4550C 4551C-----COMMON---------------------------------------------------------- 4552C 4553 INCLUDE 'DPCOMC.INC' 4554 INCLUDE 'DPCOP2.INC' 4555C 4556CCCCC DATA FNNAME/'DEBYE4'/ 4557CCCCC DATA ERRMSG/'ARGUMENT NEGATIVE'/ 4558 DATA ZERO,HALF,ONE/0.0 D 0 , 0.5 D 0 , 1.0 D 0/ 4559 DATA TWOPT5,FOUR,FIVE/2.5 D 0 , 4.0 D 0 , 5.0 D 0/ 4560 DATA EIGHT,TWELVE,EIGHTN/8.0 D 0 , 12.0 D 0 , 18.0 D 0/ 4561 DATA TWENT4,FORTY5,ONEHUN/24.0 D 0 , 45.0 D 0 , 100.0 D 0/ 4562 DATA DEBINF/99.54506 44937 63512 92781 D 0/ 4563 DATA ADEB4/2.78186 94150 20523 46008 D 0, 4564 1 0.37497 67835 26892 86364 D 0, 4565 2 -0.14940 90739 90315 8326 D -1, 4566 3 0.94567 98114 37042 74 D -3, 4567 4 -0.66132 91613 89325 5 D -4, 4568 5 0.48156 32982 14449 D -5, 4569 6 -0.35880 83958 7593 D -6, 4570 7 0.27160 11874 160 D -7, 4571 8 -0.20807 09912 23 D -8, 4572 9 0.16093 83869 2 D -9, 4573 X -0.12547 09791 D -10, 4574 1 0.98472 647 D -12, 4575 2 -0.77723 69 D -13, 4576 3 0.61648 3 D -14, 4577 4 -0.49107 D -15, 4578 5 0.3927 D -16, 4579 6 -0.315 D -17, 4580 7 0.25 D -18, 4581 8 -0.2 D -19/ 4582C 4583C Start computation 4584C 4585 X = XVALUE 4586C 4587C Check XVALUE >= 0.0 4588C 4589 IF ( X .LT. ZERO ) THEN 4590CCCCC CALL ERRPRN(FNNAME,ERRMSG) 4591 WRITE(ICOUT,999) 4592 CALL DPWRST('XXX','BUG ') 4593 WRITE(ICOUT,101)X 4594 CALL DPWRST('XXX','BUG ') 4595 DEBYE4 = ZERO 4596 RETURN 4597 ENDIF 4598 999 FORMAT(1X) 4599 101 FORMAT('***** ERROR FROM DEBYE4--ARGUMENT MUST BE ', 4600 1 'NON-NEGATIVE, ARGUMENT = ',G15.7) 4601C 4602C Compute the machine-dependent constants. 4603C 4604 T = D1MACH(1) 4605 XLIM1 = - LOG( T ) 4606 RK = ONE / FOUR 4607 XK = DEBINF ** RK 4608 XKI = T ** RK 4609 XLIM2 = XK / XKI 4610 T = D1MACH(3) 4611 XLOW = SQRT ( T * EIGHT ) 4612 XUPPER = - LOG( T + T ) 4613 T = T / ONEHUN 4614 DO 10 NTERMS = 18 , 0 , -1 4615 IF ( ABS(ADEB4(NTERMS)) .GT. T ) GOTO 19 4616 10 CONTINUE 4617C 4618C Code for x <= 4.0 4619C 4620 19 IF ( X .LE. FOUR ) THEN 4621 IF ( X .LT. XLOW ) THEN 4622 DEBYE4 = ( ( TWOPT5 * X - EIGHTN ) * X + FORTY5 ) / FORTY5 4623 ELSE 4624 T = ( ( X * X / EIGHT ) - HALF ) - HALF 4625 DEBYE4 = CHEVAL ( NTERMS , ADEB4 , T ) - ( X + X ) / FIVE 4626 ENDIF 4627 ELSE 4628C 4629C Code for x > 4.0 4630C 4631 IF ( X .GT. XLIM2 ) THEN 4632 DEBYE4 = ZERO 4633 ELSE 4634 T = X * X 4635 DEBYE4 = ( DEBINF / T ) / T 4636 IF ( X .LT. XLIM1 ) THEN 4637 EXPMX = EXP ( -X ) 4638 IF ( X .GT. XUPPER ) THEN 4639 SUM = ( ( ( ( X + FOUR ) * X + TWELVE ) * X + 4640 & TWENT4 ) * X + TWENT4 ) / ( X * X * X * X ) 4641 ELSE 4642 SUM = ZERO 4643 RK = AINT ( XLIM1 / X ) 4644 NEXP = INT ( RK ) 4645 XK = RK * X 4646 DO 100 I = NEXP,1,-1 4647 XKI = ONE / XK 4648 T = ( ( ( ( TWENT4 * XKI + TWENT4 ) * XKI + 4649 & TWELVE ) * XKI + FOUR ) * XKI + ONE ) / RK 4650 SUM = SUM * EXPMX + T 4651 RK = RK - ONE 4652 XK = XK - X 4653 100 CONTINUE 4654 ENDIF 4655 DEBYE4 = DEBYE4 - FOUR * SUM * EXPMX 4656 ENDIF 4657 ENDIF 4658 ENDIF 4659 RETURN 4660 END 4661 SUBROUTINE DCHEX(R,LDR,P,K,L,Z,LDZ,NZ,C,S,JOB) 4662C***BEGIN PROLOGUE DCHEX 4663C***DATE WRITTEN 780814 (YYMMDD) 4664C***REVISION DATE 820801 (YYMMDD) 4665C***REVISION HISTORY (YYMMDD) 4666C 000330 Modified array declarations. (JEC) 4667C***CATEGORY NO. D7B 4668C***KEYWORDS CHOLESKY DECOMPOSITION,DOUBLE PRECISION,EXCHANGE, 4669C LINEAR ALGEBRA,LINPACK,MATRIX,POSITIVE DEFINITE 4670C***AUTHOR STEWART, G. W., (U. OF MARYLAND) 4671C***PURPOSE Updates the Cholesky factorization A=TRANS(R)*R of a 4672C POSITIVE DEFINITE matrix A of order P under diagonal 4673C permutations of the form TRANS(E)*A*E where E is a 4674C permutation matrix. 4675C***DESCRIPTION 4676C 4677C DCHEX updates the Cholesky factorization 4678C 4679C A = TRANS(R)*R 4680C 4681C of a positive definite matrix A of order P under diagonal 4682C permutations of the form 4683C 4684C TRANS(E)*A*E 4685C 4686C where E is a permutation matrix. Specifically, given 4687C an upper triangular matrix R and a permutation matrix 4688C E (which is specified by K, L, and JOB), DCHEX determines 4689C an orthogonal matrix U such that 4690C 4691C U*R*E = RR, 4692C 4693C where RR is upper triangular. At the users option, the 4694C transformation U will be multiplied into the array Z. 4695C If A = TRANS(X)*X, so that R is the triangular part of the 4696C QR factorization of X, then RR is the triangular part of the 4697C QR factorization of X*E, i.e. X with its columns permuted. 4698C For a less terse description of what DCHEX does and how 4699C it may be applied, see the LINPACK guide. 4700C 4701C The matrix Q is determined as the product U(L-K)*...*U(1) 4702C of plane rotations of the form 4703C 4704C ( C(I) S(I) ) 4705C ( ) , 4706C ( -S(I) C(I) ) 4707C 4708C where C(I) is double precision. The rows these rotations operate 4709C on are described below. 4710C 4711C There are two types of permutations, which are determined 4712C by the value of JOB. 4713C 4714C 1. Right circular shift (JOB = 1). 4715C 4716C The columns are rearranged in the following order. 4717C 4718C 1,...,K-1,L,K,K+1,...,L-1,L+1,...,P. 4719C 4720C U is the product of L-K rotations U(I), where U(I) 4721C acts in the (L-I,L-I+1)-plane. 4722C 4723C 2. Left circular shift (JOB = 2). 4724C The columns are rearranged in the following order 4725C 4726C 1,...,K-1,K+1,K+2,...,L,K,L+1,...,P. 4727C 4728C U is the product of L-K rotations U(I), where U(I) 4729C acts in the (K+I-1,K+I)-plane. 4730C 4731C On Entry 4732C 4733C R DOUBLE PRECISION(LDR,P), where LDR .GE. P. 4734C R contains the upper triangular factor 4735C that is to be updated. Elements of R 4736C below the diagonal are not referenced. 4737C 4738C LDR INTEGER. 4739C LDR is the leading dimension of the array R. 4740C 4741C P INTEGER. 4742C P is the order of the matrix R. 4743C 4744C K INTEGER. 4745C K is the first column to be permuted. 4746C 4747C L INTEGER. 4748C L is the last column to be permuted. 4749C L must be strictly greater than K. 4750C 4751C Z DOUBLE PRECISION(LDZ,N)Z), where LDZ .GE. P. 4752C Z is an array of NZ P-vectors into which the 4753C transformation U is multiplied. Z is 4754C not referenced if NZ = 0. 4755C 4756C LDZ INTEGER. 4757C LDZ is the leading dimension of the array Z. 4758C 4759C NZ INTEGER. 4760C NZ is the number of columns of the matrix Z. 4761C 4762C JOB INTEGER. 4763C JOB determines the type of permutation. 4764C JOB = 1 right circular shift. 4765C JOB = 2 left circular shift. 4766C 4767C On Return 4768C 4769C R contains the updated factor. 4770C 4771C Z contains the updated matrix Z. 4772C 4773C C DOUBLE PRECISION(P). 4774C C contains the cosines of the transforming rotations. 4775C 4776C S DOUBLE PRECISION(P). 4777C S contains the sines of the transforming rotations. 4778C 4779C LINPACK. This version dated 08/14/78 . 4780C G. W. Stewart, University of Maryland, Argonne National Lab. 4781C 4782C DCHEX uses the following functions and subroutines. 4783C 4784C BLAS DROTG 4785C Fortran MIN0 4786C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., 4787C *LINPACK USERS GUIDE*, SIAM, 1979. 4788C***ROUTINES CALLED DROTG 4789C***END PROLOGUE DCHEX 4790 INTEGER LDR,P,K,L,LDZ,NZ,JOB 4791 DOUBLE PRECISION R(LDR,*),Z(LDZ,*),S(*) 4792 DOUBLE PRECISION C(*) 4793C 4794 INTEGER I,II,IL,IU,J,JJ,KM1,KP1,LMK,LM1 4795CCCCC DOUBLE PRECISION RJP1J,T 4796 DOUBLE PRECISION T 4797C 4798C INITIALIZE 4799C 4800C***FIRST EXECUTABLE STATEMENT DCHEX 4801 KM1 = K - 1 4802 KP1 = K + 1 4803 LMK = L - K 4804 LM1 = L - 1 4805C 4806C PERFORM THE APPROPRIATE TASK. 4807C 4808 GO TO (10,130), JOB 4809C 4810C RIGHT CIRCULAR SHIFT. 4811C 4812 10 CONTINUE 4813C 4814C REORDER THE COLUMNS. 4815C 4816 DO 20 I = 1, L 4817 II = L - I + 1 4818 S(I) = R(II,L) 4819 20 CONTINUE 4820 DO 40 JJ = K, LM1 4821 J = LM1 - JJ + K 4822 DO 30 I = 1, J 4823 R(I,J+1) = R(I,J) 4824 30 CONTINUE 4825 R(J+1,J+1) = 0.0D0 4826 40 CONTINUE 4827 IF (K .EQ. 1) GO TO 60 4828 DO 50 I = 1, KM1 4829 II = L - I + 1 4830 R(I,K) = S(II) 4831 50 CONTINUE 4832 60 CONTINUE 4833C 4834C CALCULATE THE ROTATIONS. 4835C 4836 T = S(1) 4837 DO 70 I = 1, LMK 4838 CALL DROTG(S(I+1),T,C(I),S(I)) 4839 T = S(I+1) 4840 70 CONTINUE 4841 R(K,K) = T 4842 DO 90 J = KP1, P 4843 IL = MAX0(1,L-J+1) 4844 DO 80 II = IL, LMK 4845 I = L - II 4846 T = C(II)*R(I,J) + S(II)*R(I+1,J) 4847 R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) 4848 R(I,J) = T 4849 80 CONTINUE 4850 90 CONTINUE 4851C 4852C IF REQUIRED, APPLY THE TRANSFORMATIONS TO Z. 4853C 4854 IF (NZ .LT. 1) GO TO 120 4855 DO 110 J = 1, NZ 4856 DO 100 II = 1, LMK 4857 I = L - II 4858 T = C(II)*Z(I,J) + S(II)*Z(I+1,J) 4859 Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) 4860 Z(I,J) = T 4861 100 CONTINUE 4862 110 CONTINUE 4863 120 CONTINUE 4864 GO TO 260 4865C 4866C LEFT CIRCULAR SHIFT 4867C 4868 130 CONTINUE 4869C 4870C REORDER THE COLUMNS 4871C 4872 DO 140 I = 1, K 4873 II = LMK + I 4874 S(II) = R(I,K) 4875 140 CONTINUE 4876 DO 160 J = K, LM1 4877 DO 150 I = 1, J 4878 R(I,J) = R(I,J+1) 4879 150 CONTINUE 4880 JJ = J - KM1 4881 S(JJ) = R(J+1,J+1) 4882 160 CONTINUE 4883 DO 170 I = 1, K 4884 II = LMK + I 4885 R(I,L) = S(II) 4886 170 CONTINUE 4887 DO 180 I = KP1, L 4888 R(I,L) = 0.0D0 4889 180 CONTINUE 4890C 4891C REDUCTION LOOP. 4892C 4893 DO 220 J = K, P 4894 IF (J .EQ. K) GO TO 200 4895C 4896C APPLY THE ROTATIONS. 4897C 4898 IU = MIN0(J-1,L-1) 4899 DO 190 I = K, IU 4900 II = I - K + 1 4901 T = C(II)*R(I,J) + S(II)*R(I+1,J) 4902 R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) 4903 R(I,J) = T 4904 190 CONTINUE 4905 200 CONTINUE 4906 IF (J .GE. L) GO TO 210 4907 JJ = J - K + 1 4908 T = S(JJ) 4909 CALL DROTG(R(J,J),T,C(JJ),S(JJ)) 4910 210 CONTINUE 4911 220 CONTINUE 4912C 4913C APPLY THE ROTATIONS TO Z. 4914C 4915 IF (NZ .LT. 1) GO TO 250 4916 DO 240 J = 1, NZ 4917 DO 230 I = K, LM1 4918 II = I - KM1 4919 T = C(II)*Z(I,J) + S(II)*Z(I+1,J) 4920 Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) 4921 Z(I,J) = T 4922 230 CONTINUE 4923 240 CONTINUE 4924 250 CONTINUE 4925 260 CONTINUE 4926 RETURN 4927 END 4928 DOUBLE PRECISION FUNCTION DCHU (A, B, X) 4929C***BEGIN PROLOGUE DCHU 4930C***PURPOSE Compute the logarithmic confluent hypergeometric function. 4931C***LIBRARY SLATEC (FNLIB) 4932C***CATEGORY C11 4933C***TYPE DOUBLE PRECISION (CHU-S, DCHU-D) 4934C***KEYWORDS FNLIB, LOGARITHMIC CONFLUENT HYPERGEOMETRIC FUNCTION, 4935C SPECIAL FUNCTIONS 4936C***AUTHOR Fullerton, W., (LANL) 4937C***DESCRIPTION 4938C 4939C DCHU(A,B,X) calculates the double precision logarithmic confluent 4940C hypergeometric function U(A,B,X) for double precision arguments 4941C A, B, and X. 4942C 4943C This routine is not valid when 1+A-B is close to zero if X is small. 4944C 4945C***REFERENCES (NONE) 4946C***ROUTINES CALLED D1MACH, D9CHU, DEXPRL, DGAMMA, DGAMR, DPOCH, 4947C DPOCH1, XERMSG 4948C***REVISION HISTORY (YYMMDD) 4949C 770801 DATE WRITTEN 4950C 890531 Changed all specific intrinsics to generic. (WRB) 4951C 890531 REVISION DATE from Version 3.2 4952C 891214 Prologue converted to Version 4.0 format. (BAB) 4953C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 4954C 900727 Added EXTERNAL statement. (WRB) 4955C***END PROLOGUE DCHU 4956C 4957C-----COMMON---------------------------------------------------------- 4958C 4959 INCLUDE 'DPCOMC.INC' 4960 INCLUDE 'DPCOP2.INC' 4961C 4962 DOUBLE PRECISION A, B, X, AINTB, ALNX, A0, BEPS, B0, C0, EPS, 4963 1 FACTOR, GAMRI1, GAMRNI, PCH1AI, PCH1I, PI, POCHAI, SUM, T, 4964 2 XEPS1, XI, XI1, XN, XTOEPS, DPOCH, DGAMMA, DGAMR, 4965 3 DPOCH1, DEXPRL, D9CHU 4966 EXTERNAL DGAMMA 4967 SAVE PI, EPS 4968 DATA PI / 3.1415926535 8979323846 2643383279 503 D0 / 4969 DATA EPS / 0.0D0 / 4970C***FIRST EXECUTABLE STATEMENT DCHU 4971C 4972 DCHU = 0.0D0 4973C 4974 IF (EPS.EQ.0.0D0) EPS = D1MACH(3) 4975C 4976 IF (X .EQ. 0.0D0) THEN 4977 WRITE(ICOUT,2) 4978 2 FORMAT('***** ERORR FROM DCHU, X IS ZERO, SO CHU IS ', 4979 1 'INFINITE. *******') 4980 CALL DPWRST('XXX','BUG ') 4981 RETURN 4982 ENDIF 4983 IF (X .LT. 0.0D0) THEN 4984 WRITE(ICOUT,1) 4985 1 FORMAT('***** ERORR FROM DCHU, X IS NEGATIVE. *******') 4986 CALL DPWRST('XXX','BUG ') 4987 RETURN 4988 ENDIF 4989C 4990 IF (MAX(ABS(A),1.0D0)*MAX(ABS(1.0D0+A-B),1.0D0).LT. 4991 1 0.99D0*ABS(X)) GO TO 120 4992C 4993C THE ASCENDING SERIES WILL BE USED, BECAUSE THE DESCENDING RATIONAL 4994C APPROXIMATION (WHICH IS BASED ON THE ASYMPTOTIC SERIES) IS UNSTABLE. 4995C 4996 IF (ABS(1.0D0+A-B) .LT. SQRT(EPS)) THEN 4997 WRITE(ICOUT,3) 4998 3 FORMAT('***** ERORR FROM DCHU, ALGORITHM IS BAD WHEN 1+A-B ', 4999 1 'IS NEAR ZERO FOR SMALL X. *****') 5000 CALL DPWRST('XXX','BUG ') 5001 RETURN 5002 ENDIF 5003C 5004 AINTB=0.0 5005 IF (B.GE.0.0D0) AINTB = AINT(B+0.5D0) 5006 IF (B.LT.0.0D0) AINTB = AINT(B-0.5D0) 5007 BEPS = B - AINTB 5008 N = INT(AINTB) 5009C 5010 ALNX = LOG(X) 5011 XTOEPS = EXP (-BEPS*ALNX) 5012C 5013C EVALUATE THE FINITE SUM. ----------------------------------------- 5014C 5015 IF (N.GE.1) GO TO 40 5016C 5017C CONSIDER THE CASE B .LT. 1.0 FIRST. 5018C 5019 SUM = 1.0D0 5020 IF (N.EQ.0) GO TO 30 5021C 5022 T = 1.0D0 5023 M = -N 5024 DO 20 I=1,M 5025 XI1 = I - 1 5026 T = T*(A+XI1)*X/((B+XI1)*(XI1+1.0D0)) 5027 SUM = SUM + T 5028 20 CONTINUE 5029C 5030 30 SUM = DPOCH(1.0D0+A-B, -A)*SUM 5031 GO TO 70 5032C 5033C NOW CONSIDER THE CASE B .GE. 1.0. 5034C 5035 40 SUM = 0.0D0 5036 M = N - 2 5037 IF (M.LT.0) GO TO 70 5038 T = 1.0D0 5039 SUM = 1.0D0 5040 IF (M.EQ.0) GO TO 60 5041C 5042 DO 50 I=1,M 5043 XI = I 5044 T = T * (A-B+XI)*X/((1.0D0-B+XI)*XI) 5045 SUM = SUM + T 5046 50 CONTINUE 5047C 5048 60 SUM = DGAMMA(B-1.0D0) * DGAMR(A) * X**(1-N) * XTOEPS * SUM 5049C 5050C NEXT EVALUATE THE INFINITE SUM. ---------------------------------- 5051C 5052 70 ISTRT = 0 5053 IF (N.LT.1) ISTRT = 1 - N 5054 XI = ISTRT 5055C 5056 FACTOR = (-1.0D0)**N * DGAMR(1.0D0+A-B) * X**ISTRT 5057 IF (BEPS.NE.0.0D0) FACTOR = FACTOR * BEPS*PI/SIN(BEPS*PI) 5058C 5059 POCHAI = DPOCH (A, XI) 5060 GAMRI1 = DGAMR (XI+1.0D0) 5061 GAMRNI = DGAMR (AINTB+XI) 5062 B0 = FACTOR * DPOCH(A,XI-BEPS) * GAMRNI * DGAMR(XI+1.0D0-BEPS) 5063C 5064 IF (ABS(XTOEPS-1.0D0).GT.0.5D0) GO TO 90 5065C 5066C X**(-BEPS) IS CLOSE TO 1.0D0, SO WE MUST BE CAREFUL IN EVALUATING THE 5067C DIFFERENCES. 5068C 5069 PCH1AI = DPOCH1 (A+XI, -BEPS) 5070 PCH1I = DPOCH1 (XI+1.0D0-BEPS, BEPS) 5071 C0 = FACTOR * POCHAI * GAMRNI * GAMRI1 * ( 5072 1 -DPOCH1(B+XI,-BEPS) + PCH1AI - PCH1I + BEPS*PCH1AI*PCH1I) 5073C 5074C XEPS1 = (1.0 - X**(-BEPS))/BEPS = (X**(-BEPS) - 1.0)/(-BEPS) 5075 XEPS1 = ALNX*DEXPRL(-BEPS*ALNX) 5076C 5077 DCHU = SUM + C0 + XEPS1*B0 5078 XN = N 5079 DO 80 I=1,1000 5080 XI = ISTRT + I 5081 XI1 = ISTRT + I - 1 5082 B0 = (A+XI1-BEPS)*B0*X/((XN+XI1)*(XI-BEPS)) 5083 C0 = (A+XI1)*C0*X/((B+XI1)*XI) 5084 1 - ((A-1.0D0)*(XN+2.D0*XI-1.0D0) + XI*(XI-BEPS)) * B0 5085 2 / (XI*(B+XI1)*(A+XI1-BEPS)) 5086 T = C0 + XEPS1*B0 5087 DCHU = DCHU + T 5088 IF (ABS(T).LT.EPS*ABS(DCHU)) GO TO 130 5089 80 CONTINUE 5090 WRITE(ICOUT,4) 5091 4 FORMAT('***** ERORR FROM DCHU, NO CONVERGENCE IN 1000 TERMS OF ', 5092 1 'THE ASCENDING SERIES. *****') 5093 CALL DPWRST('XXX','BUG ') 5094 RETURN 5095C 5096C X**(-BEPS) IS VERY DIFFERENT FROM 1.0, SO THE STRAIGHTFORWARD 5097C FORMULATION IS STABLE. 5098C 5099 90 A0 = FACTOR * POCHAI * DGAMR(B+XI) * GAMRI1 / BEPS 5100 B0 = XTOEPS * B0 / BEPS 5101C 5102 DCHU = SUM + A0 - B0 5103 DO 100 I=1,1000 5104 XI = ISTRT + I 5105 XI1 = ISTRT + I - 1 5106 A0 = (A+XI1)*A0*X/((B+XI1)*XI) 5107 B0 = (A+XI1-BEPS)*B0*X/((AINTB+XI1)*(XI-BEPS)) 5108 T = A0 - B0 5109 DCHU = DCHU + T 5110 IF (ABS(T).LT.EPS*ABS(DCHU)) GO TO 130 5111 100 CONTINUE 5112 WRITE(ICOUT,4) 5113 CALL DPWRST('XXX','BUG ') 5114 RETURN 5115C 5116C USE LUKE-S RATIONAL APPROXIMATION IN THE ASYMPTOTIC REGION. 5117C 5118 120 DCHU = X**(-A) * D9CHU(A,B,X) 5119C 5120 130 RETURN 5121 END 5122 SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) 5123C 5124C COPIES A VECTOR, X, TO A VECTOR, Y. 5125C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. 5126C JACK DONGARRA, LINPACK, 3/11/78. 5127C 5128 DOUBLE PRECISION DX(1),DY(1) 5129 INTEGER I,INCX,INCY,IX,IY,M,MP1,N 5130C 5131 IF(N.LE.0)RETURN 5132 IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 5133C 5134C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS 5135C NOT EQUAL TO 1 5136C 5137 IX = 1 5138 IY = 1 5139 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 5140 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 5141 DO 10 I = 1,N 5142 DY(IY) = DX(IX) 5143 IX = IX + INCX 5144 IY = IY + INCY 5145 10 CONTINUE 5146 RETURN 5147C 5148C CODE FOR BOTH INCREMENTS EQUAL TO 1 5149C 5150C 5151C CLEAN-UP LOOP 5152C 5153 20 M = MOD(N,7) 5154 IF( M .EQ. 0 ) GO TO 40 5155 DO 30 I = 1,M 5156 DY(I) = DX(I) 5157 30 CONTINUE 5158 IF( N .LT. 7 ) RETURN 5159 40 MP1 = M + 1 5160 DO 50 I = MP1,N,7 5161 DY(I) = DX(I) 5162 DY(I + 1) = DX(I + 1) 5163 DY(I + 2) = DX(I + 2) 5164 DY(I + 3) = DX(I + 3) 5165 DY(I + 4) = DX(I + 4) 5166 DY(I + 5) = DX(I + 5) 5167 DY(I + 6) = DX(I + 6) 5168 50 CONTINUE 5169 RETURN 5170 END 5171 DOUBLE PRECISION FUNCTION DCOT (X) 5172C***BEGIN PROLOGUE DCOT 5173C***PURPOSE Compute the cotangent. 5174C***LIBRARY SLATEC (FNLIB) 5175C***CATEGORY C4A 5176C***TYPE DOUBLE PRECISION (COT-S, DCOT-D, CCOT-C) 5177C***KEYWORDS COTANGENT, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC 5178C***AUTHOR Fullerton, W., (LANL) 5179C***DESCRIPTION 5180C 5181C DCOT(X) calculates the double precision trigonometric cotangent 5182C for double precision argument X. X is in units of radians. 5183C 5184C Series for COT on the interval 0. to 6.25000E-02 5185C with weighted error 5.52E-34 5186C log weighted error 33.26 5187C significant figures required 32.34 5188C decimal places required 33.85 5189C 5190C***REFERENCES (NONE) 5191C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG 5192C***REVISION HISTORY (YYMMDD) 5193C 770601 DATE WRITTEN 5194C 890531 Changed all specific intrinsics to generic. (WRB) 5195C 890531 REVISION DATE from Version 3.2 5196C 891214 Prologue converted to Version 4.0 format. (BAB) 5197C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 5198C 920618 Removed space from variable names. (RWC, WRB) 5199C***END PROLOGUE DCOT 5200C 5201C-----COMMON---------------------------------------------------------- 5202C 5203 INCLUDE 'DPCOMC.INC' 5204 INCLUDE 'DPCOP2.INC' 5205C 5206 DOUBLE PRECISION X, COTCS(15), AINTY, AINTY2, PI2REC, SQEPS, 5207 1 XMAX, XMIN, XSML, Y, YREM, PRODBG, DCSEVL 5208 LOGICAL FIRST 5209 SAVE COTCS, PI2REC, NTERMS, XMAX, XSML, XMIN, SQEPS, FIRST 5210 DATA COTCS( 1) / +.2402591609 8295630250 9553617744 970 D+0 / 5211 DATA COTCS( 2) / -.1653303160 1500227845 4746025255 758 D-1 / 5212 DATA COTCS( 3) / -.4299839193 1724018935 6476228239 895 D-4 / 5213 DATA COTCS( 4) / -.1592832233 2754104602 3490851122 445 D-6 / 5214 DATA COTCS( 5) / -.6191093135 1293487258 8620579343 187 D-9 / 5215 DATA COTCS( 6) / -.2430197415 0726460433 1702590579 575 D-11 / 5216 DATA COTCS( 7) / -.9560936758 8000809842 7062083100 000 D-14 / 5217 DATA COTCS( 8) / -.3763537981 9458058041 6291539706 666 D-16 / 5218 DATA COTCS( 9) / -.1481665746 4674657885 2176794666 666 D-18 / 5219 DATA COTCS( 10) / -.5833356589 0366657947 7984000000 000 D-21 / 5220 DATA COTCS( 11) / -.2296626469 6464577392 8533333333 333 D-23 / 5221 DATA COTCS( 12) / -.9041970573 0748332671 9999999999 999 D-26 / 5222 DATA COTCS( 13) / -.3559885519 2060006400 0000000000 000 D-28 / 5223 DATA COTCS( 14) / -.1401551398 2429866666 6666666666 666 D-30 / 5224 DATA COTCS( 15) / -.5518004368 7253333333 3333333333 333 D-33 / 5225 DATA PI2REC / .01161977236 7581343075 5350534900 57 D0 / 5226 DATA FIRST /.TRUE./ 5227C***FIRST EXECUTABLE STATEMENT DCOT 5228C 5229 DCOT=DBLE(CPUMIN) 5230C 5231 IF (FIRST) THEN 5232 NTERMS = INITDS (COTCS, 15, 0.1*REAL(D1MACH(3)) ) 5233 XMAX = 1.0D0/D1MACH(4) 5234 XSML = SQRT(3.0D0*D1MACH(3)) 5235 XMIN = EXP (MAX(LOG(D1MACH(1)), -LOG(D1MACH(2))) + 0.01D0) 5236 SQEPS = SQRT(D1MACH(4)) 5237 ENDIF 5238 FIRST = .FALSE. 5239C 5240 Y = ABS(X) 5241 IF (Y .LT. XMIN) THEN 5242 WRITE(ICOUT,1) 5243 1 FORMAT('***** ERORR FROM DCOT, ABS(X) IS ZERO OR SO SMALL ', 5244 1 'THAT DCOT OVERFLOWS. ****') 5245 CALL DPWRST('XXX','BUG ') 5246 RETURN 5247 ENDIF 5248 IF (Y .GT. XMAX) THEN 5249 WRITE(ICOUT,2) 5250 2 FORMAT('***** ERORR FROM DCOT, NO PRECISION BECAUSE ABS(X) ', 5251 1 'IS SO BIG. ****') 5252 CALL DPWRST('XXX','BUG ') 5253 RETURN 5254 ENDIF 5255C 5256C CAREFULLY COMPUTE Y * (2/PI) = (AINT(Y) + REM(Y)) * (.625 + PI2REC) 5257C = AINT(.625*Y) + REM(.625*Y) + Y*PI2REC = AINT(.625*Y) + Z 5258C = AINT(.625*Y) + AINT(Z) + REM(Z) 5259C 5260 AINTY = AINT (Y) 5261 YREM = Y - AINTY 5262 PRODBG = 0.625D0*AINTY 5263 AINTY = AINT (PRODBG) 5264 Y = (PRODBG-AINTY) + 0.625D0*YREM + PI2REC*Y 5265 AINTY2 = AINT (Y) 5266 AINTY = AINTY + AINTY2 5267 Y = Y - AINTY2 5268C 5269 IFN = INT(MOD (AINTY, 2.0D0)) 5270 IF (IFN.EQ.1) Y = 1.0D0 - Y 5271C 5272 IF (ABS(X) .GT. 0.5D0 .AND. Y .LT. ABS(X)*SQEPS) THEN 5273 WRITE(ICOUT,3) 5274 3 FORMAT('***** WARNING FROM DCOT, ANSWER IS LESS THAN HALF ', 5275 1 'PRECISION BECAUSE ABS(X) IS TOO BIG OR X IS NEAR PI.') 5276 CALL DPWRST('XXX','BUG ') 5277 ENDIF 5278C 5279 IF (Y.GT.0.25D0) GO TO 20 5280 DCOT = 1.0D0/X 5281 IF (Y.GT.XSML) DCOT = (0.5D0 + DCSEVL (32.0D0*Y*Y-1.D0, COTCS, 5282 1 NTERMS)) / Y 5283 GO TO 40 5284C 5285 20 IF (Y.GT.0.5D0) GO TO 30 5286 DCOT = (0.5D0 + DCSEVL (8.D0*Y*Y-1.D0, COTCS, NTERMS))/(0.5D0*Y) 5287 DCOT = (DCOT*DCOT-1.D0)*0.5D0/DCOT 5288 GO TO 40 5289C 5290 30 DCOT = (0.5D0 + DCSEVL (2.D0*Y*Y-1.D0, COTCS, NTERMS))/(.25D0*Y) 5291 DCOT = (DCOT*DCOT-1.D0)*0.5D0/DCOT 5292 DCOT = (DCOT*DCOT-1.D0)*0.5D0/DCOT 5293C 5294 40 IF (X.NE.0.D0) DCOT = SIGN (DCOT, X) 5295 IF (IFN.EQ.1) DCOT = -DCOT 5296C 5297 RETURN 5298 END 5299 DOUBLE PRECISION FUNCTION DCSEVL (X, CS, N) 5300C***BEGIN PROLOGUE DCSEVL 5301C***PURPOSE Evaluate a Chebyshev series. 5302C***LIBRARY SLATEC (FNLIB) 5303C***CATEGORY C3A2 5304C***TYPE DOUBLE PRECISION (CSEVL-S, DCSEVL-D) 5305C***KEYWORDS CHEBYSHEV SERIES, FNLIB, SPECIAL FUNCTIONS 5306C***AUTHOR Fullerton, W., (LANL) 5307C***DESCRIPTION 5308C 5309C Evaluate the N-term Chebyshev series CS at X. Adapted from 5310C a method presented in the paper by Broucke referenced below. 5311C 5312C Input Arguments -- 5313C X value at which the series is to be evaluated. 5314C CS array of N terms of a Chebyshev series. In evaluating 5315C CS, only half the first coefficient is summed. 5316C N number of terms in array CS. 5317C 5318C***REFERENCES R. Broucke, Ten subroutines for the manipulation of 5319C Chebyshev series, Algorithm 446, Communications of 5320C the A.C.M. 16, (1973) pp. 254-256. 5321C L. Fox and I. B. Parker, Chebyshev Polynomials in 5322C Numerical Analysis, Oxford University Press, 1968, 5323C page 56. 5324C***ROUTINES CALLED D1MACH, XERMSG 5325C***REVISION HISTORY (YYMMDD) 5326C 770401 DATE WRITTEN 5327C 890831 Modified array declarations. (WRB) 5328C 890831 REVISION DATE from Version 3.2 5329C 891214 Prologue converted to Version 4.0 format. (BAB) 5330C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 5331C 900329 Prologued revised extensively and code rewritten to allow 5332C X to be slightly outside interval (-1,+1). (WRB) 5333C 920501 Reformatted the REFERENCES section. (WRB) 5334C***END PROLOGUE DCSEVL 5335 DOUBLE PRECISION B0, B1, B2, CS(*), ONEPL, TWOX, X 5336 LOGICAL FIRST 5337 SAVE FIRST, ONEPL 5338C 5339C-----COMMON---------------------------------------------------------- 5340C 5341 INCLUDE 'DPCOMC.INC' 5342 INCLUDE 'DPCOP2.INC' 5343C 5344 DATA FIRST /.TRUE./ 5345C***FIRST EXECUTABLE STATEMENT DCSEVL 5346 IF (FIRST) ONEPL = 1.0D0 + D1MACH(4) 5347 FIRST = .FALSE. 5348 IF (N .LT. 1) THEN 5349 WRITE(ICOUT,11) 5350 CALL DPWRST('XXX','BUG ') 5351 WRITE(ICOUT,12) 5352 CALL DPWRST('XXX','BUG ') 5353 DCSEVL = 0.D0 5354 RETURN 5355 ENDIF 5356 11 FORMAT('***** ERROR FROM DCSEVL. THE NUMBER OF TERMS IS ') 5357 12 FORMAT(' LESS THAN OR EQUAL TO ZERO. *****') 5358 IF (N .GT. 1000) THEN 5359 WRITE(ICOUT,21) 5360 CALL DPWRST('XXX','BUG ') 5361 WRITE(ICOUT,22) 5362 CALL DPWRST('XXX','BUG ') 5363 DCSEVL = 0.D0 5364 RETURN 5365 ENDIF 5366 21 FORMAT('***** ERROR FROM DCSEVL. THE NUMBER OF TERMS IS ') 5367 22 FORMAT(' GREATER THAN 1000. *****') 5368 IF (ABS(X) .GT. ONEPL) THEN 5369 WRITE(ICOUT,31) 5370 CALL DPWRST('XXX','BUG ') 5371 WRITE(ICOUT,32) 5372 CALL DPWRST('XXX','BUG ') 5373 ENDIF 5374 31 FORMAT('***** WARNING FROM DCSEVL. X IS OUTSIDE THE ') 5375 32 FORMAT(' INTERVAL (-1,+1). *****') 5376C 5377 B1 = 0.0D0 5378 B2 = 0.0D0 5379 B0 = 0.0D0 5380 TWOX = 2.0D0*X 5381 DO 10 I = 1,N 5382 B2 = B1 5383 B1 = B0 5384 NI = N + 1 - I 5385 B0 = TWOX*B1 - B2 + CS(NI) 5386 10 CONTINUE 5387C 5388 DCSEVL = 0.5D0*(B0-B2) 5389C 5390 RETURN 5391 END 5392 DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) 5393C***BEGIN PROLOGUE DDOT 5394C***DATE WRITTEN 791001 (YYMMDD) 5395C***REVISION DATE 820801 (YYMMDD) 5396C***CATEGORY NO. D1A4 5397C***KEYWORDS BLAS,DOUBLE PRECISION,INNER PRODUCT,LINEAR ALGEBRA,VECTOR 5398C***AUTHOR LAWSON, C. L., (JPL) 5399C HANSON, R. J., (SNLA) 5400C KINCAID, D. R., (U. OF TEXAS) 5401C KROGH, F. T., (JPL) 5402C***PURPOSE D.P. inner product of d.p. vectors 5403C***DESCRIPTION 5404C 5405C B L A S Subprogram 5406C Description of Parameters 5407C 5408C --Input-- 5409C N number of elements in input vector(s) 5410C DX double precision vector with N elements 5411C INCX storage spacing between elements of DX 5412C DY double precision vector with N elements 5413C INCY storage spacing between elements of DY 5414C 5415C --Output-- 5416C DDOT double precision dot product (zero if N .LE. 0) 5417C 5418C Returns the dot product of double precision DX and DY. 5419C DDOT = sum for I = 0 to N-1 of DX(LX+I*INCX) * DY(LY+I*INCY) 5420C where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is 5421C defined in a similar way using INCY. 5422C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., 5423C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, 5424C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL 5425C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 5426C***ROUTINES CALLED (NONE) 5427C***END PROLOGUE DDOT 5428C 5429 DOUBLE PRECISION DX(*),DY(*) 5430C***FIRST EXECUTABLE STATEMENT DDOT 5431 DDOT = 0.D0 5432 IF(N.LE.0)RETURN 5433CCCCC IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 5434 IF(INCX.EQ.INCY) THEN 5435 IF(INCX-1.LT.0)THEN 5436 GOTO5 5437 ELSEIF(INCX-1.EQ.0)THEN 5438 GOTO20 5439 ELSE 5440 GOTO60 5441 ENDIF 5442 ENDIF 5443 5 CONTINUE 5444C 5445C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. 5446C 5447 IX = 1 5448 IY = 1 5449 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 5450 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 5451 DO 10 I = 1,N 5452 DDOT = DDOT + DX(IX)*DY(IY) 5453 IX = IX + INCX 5454 IY = IY + INCY 5455 10 CONTINUE 5456 RETURN 5457C 5458C CODE FOR BOTH INCREMENTS EQUAL TO 1. 5459C 5460C 5461C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. 5462C 5463 20 M = MOD(N,5) 5464 IF( M .EQ. 0 ) GO TO 40 5465 DO 30 I = 1,M 5466 DDOT = DDOT + DX(I)*DY(I) 5467 30 CONTINUE 5468 IF( N .LT. 5 ) RETURN 5469 40 MP1 = M + 1 5470 DO 50 I = MP1,N,5 5471 DDOT = DDOT + DX(I)*DY(I) + DX(I+1)*DY(I+1) + 5472 1 DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) 5473 50 CONTINUE 5474 RETURN 5475C 5476C CODE FOR POSITIVE EQUAL INCREMENTS .NE.1. 5477C 5478 60 CONTINUE 5479 NS = N*INCX 5480 DO 70 I=1,NS,INCX 5481 DDOT = DDOT + DX(I)*DY(I) 5482 70 CONTINUE 5483 RETURN 5484 END 5485 SUBROUTINE DECHE2(IX,IA,IBUGA3,IERROR) 5486C 5487C PURPOSE--THIS SUBROUTINE CONVERTS AN INTEGER IN THE 5488C RANGE 0 - 65535 (2**16 - 1) TO A TWO CHARACTER 5489C HEXADECIMAL NUMBER. 5490C 5491C THIS IS A UTILITY ROUTINE USED BY SOME DEVICES 5492C (E.G., POSTSCRIPT) TO CONVERT RGB COMPONENTS TO 5493C HEXADECIMAL NUMBERS. 5494C INPUT ARGUMENTS--IX = THE INTEGER TO BE CONVERTED. 5495C OUTPUT ARGUMENTS--IA = THE CHARACTER*2 STRING THAT WILL 5496C CONTAIN THE HEX NUMBER. 5497C OUTPUT--THE STRING CONTAINING THE NUMBER IN HEXADECIMAL FORMAT. 5498C RESTRICTIONS--THE MAXIMUM VALUE OF IX IS 2**16-1. 5499C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 5500C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 5501C MODE OF INTERNAL OPERATIONS--INTEGER. 5502C LANGUAGE--ANSI FORTRAN (1977) 5503C WRITTEN BY--JAMES J. FILLIBEN 5504C STATISTICAL ENGINEERING DIVISION 5505C INFORMATION TECHNOLOGY LABORATORY 5506C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5507C GAITHERSBURG, MD 20899-8980 5508C PHONE--301-975-2855 5509C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5510C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 5511C LANGUAGE--ANSI FORTRAN (1977) 5512C VERSION NUMBER--2008.3 5513C ORIGINAL VERSION--MARCH 2008. 5514C 5515C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5516C 5517 CHARACTER*4 IBUGA3 5518 CHARACTER*4 IERROR 5519C 5520 CHARACTER*4 ISUBN1 5521 CHARACTER*4 ISUBN2 5522C 5523C--------------------------------------------------------------------- 5524C 5525 CHARACTER*2 IA 5526C 5527C--------------------------------------------------------------------- 5528C 5529 INCLUDE 'DPCOP2.INC' 5530C 5531C-----START POINT----------------------------------------------------- 5532C 5533 ISUBN1='DECH' 5534 ISUBN2='E2 ' 5535 IERROR='NO' 5536C 5537 IF(IBUGA3.EQ.'ON')THEN 5538 WRITE(ICOUT,999) 5539 999 FORMAT(1X) 5540 CALL DPWRST('XXX','BUG ') 5541 WRITE(ICOUT,51) 5542 51 FORMAT('***** AT THE BEGINNING OF DECHE2--') 5543 CALL DPWRST('XXX','BUG ') 5544 WRITE(ICOUT,53)IX 5545 53 FORMAT('IX = ',I8) 5546 CALL DPWRST('XXX','BUG ') 5547 ENDIF 5548C 5549C ******************************************** 5550C ** STEP 1-- ** 5551C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 5552C ******************************************** 5553C 5554 IMAX=(2**16) - 1 5555 IA=' ' 5556C 5557 IF(IX.GT.IMAX)THEN 5558 IERROR='YES' 5559 WRITE(ICOUT,999) 5560 CALL DPWRST('XXX','BUG ') 5561 WRITE(ICOUT,111) 5562 111 FORMAT('***** ERROR IN DECHE2--') 5563 CALL DPWRST('XXX','BUG ') 5564 WRITE(ICOUT,112) 5565 112 FORMAT(' THE INPUT DECIMAL NUMBER, ',I10,' IS GREATER') 5566 CALL DPWRST('XXX','BUG ') 5567 WRITE(ICOUT,113)IMAX 5568 113 FORMAT(' THAN THE ALLOWED MAXIMUM ',I8) 5569 CALL DPWRST('XXX','BUG ') 5570 GOTO9000 5571 ENDIF 5572C 5573C ****************************** 5574C ** STEP 2-- ** 5575C ** PERFORM THE CONVERSION. ** 5576C ****************************** 5577C 5578 IVAL=IX/16 5579 IREM=IX - (16*IVAL) 5580C 5581 IF(IREM.LE.9)THEN 5582 WRITE(IA(2:2),'(I1)')IREM 5583 ELSEIF(IREM.EQ.10)THEN 5584 IA(2:2)='A' 5585 ELSEIF(IREM.EQ.11)THEN 5586 IA(2:2)='B' 5587 ELSEIF(IREM.EQ.12)THEN 5588 IA(2:2)='C' 5589 ELSEIF(IREM.EQ.13)THEN 5590 IA(2:2)='D' 5591 ELSEIF(IREM.EQ.14)THEN 5592 IA(2:2)='E' 5593 ELSEIF(IREM.EQ.15)THEN 5594 IA(2:2)='F' 5595 ENDIF 5596C 5597 IF(IVAL.LE.9)THEN 5598 WRITE(IA(1:1),'(I1)')IVAL 5599 ELSEIF(IVAL.EQ.10)THEN 5600 IA(1:1)='A' 5601 ELSEIF(IVAL.EQ.11)THEN 5602 IA(1:1)='B' 5603 ELSEIF(IVAL.EQ.12)THEN 5604 IA(1:1)='C' 5605 ELSEIF(IVAL.EQ.13)THEN 5606 IA(1:1)='D' 5607 ELSEIF(IVAL.EQ.14)THEN 5608 IA(1:1)='E' 5609 ELSEIF(IVAL.EQ.15)THEN 5610 IA(1:1)='F' 5611 ENDIF 5612C 5613C ***************** 5614C ** STEP 90-- ** 5615C ** EXIT. ** 5616C ***************** 5617C 5618 9000 CONTINUE 5619 IF(IBUGA3.EQ.'ON')THEN 5620 WRITE(ICOUT,999) 5621 CALL DPWRST('XXX','BUG ') 5622 WRITE(ICOUT,9011) 5623 9011 FORMAT('***** AT THE END OF BINHE2--') 5624 CALL DPWRST('XXX','BUG ') 5625 WRITE(ICOUT,9015)IA 5626 9015 FORMAT('IA = ',A2) 5627 CALL DPWRST('XXX','BUG ') 5628 ENDIF 5629C 5630 RETURN 5631 END 5632 SUBROUTINE DECRAT(X,N,IWRITE,XQNUM,XQDEN, 5633 1 RATIO, 5634 1 IBUGA3,ISUBRO,IERROR) 5635C 5636C PURPOSE--IF XQNUM = 0.9 AND XQDEN = 0.4, THIS STATISTIC 5637C COMPUTES THE RATIO OF THE TOP 10% OF THE DATA 5638C TO THE BOTTOM 40% OF THE DATA. 5639C 5640C THIS HAS BEEN PROPOSED AS AN ALTERNATIVE MEASURE OF 5641C "INCOME EQUALITY". SPECIFICALLY, THE PALMA SPECIFICATION 5642C USES QNUM = 0.9 AND QDEN = 0.4). THAT IS, THIS IS THE 5643C RATIO OF THE INCOME OF THE BOTTOM 40% RELATIVE TO THE 5644C TOP 10%. 5645C 5646C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF 5647C OBSERVATIONS FOR WHICH THE PERCENTAGE 5648C RANKS WILL BE COMPUTED. 5649C --N = THE INTEGER NUMBER OF OBSERVATIONS 5650C IN THE VECTOR X. 5651C --XQNUM = SCALAR THAT SPECIFIES QUANTILE FOR THE 5652C NUMERATOR 5653C --XQDEN = SCALAR THAT SPECIFIES QUANTILE FOR THE 5654C DENOMINATOR 5655C OUTPUT ARGUMENTS--RATIO = THE SINGLE PRECISION SCALAR WHERE THE 5656C INTERDECILE RATIO IS SAVED 5657C OUTPUT--THE SINGLE PRECISION SCALAR RATIO CONTAINING THE 5658C INTERDECILE RATIO. 5659C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 5660C OTHER DATAPAC SUBROUTINES NEEDED--QUANT, SORT. 5661C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 5662C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 5663C LANGUAGE--ANSI FORTRAN (1977) 5664C REFERENCES--COBHAM AND SUMNER (2014), "IS INEQUALITY ALL ABOUT THE 5665C TAILS", SIGNIFICANCE, PP. 10-13. 5666C WRITTEN BY--ALAN HECKERT 5667C STATISTICAL ENGINEERING DIVISION 5668C INFORMATION TECHNOLOGY LABORATORY 5669C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 5670C GAITHERSBURG, MD 20899-8980 5671C PHONE--301-975-2899 5672C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 5673C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. 5674C LANGUAGE--ANSI FORTRAN (1977) 5675C VERSION NUMBER--2015.2 5676C ORIGINAL VERSION--FEBRUARY 2015. 5677C 5678C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 5679C 5680 CHARACTER*4 IWRITE 5681 CHARACTER*4 IBUGA3 5682 CHARACTER*4 ISUBRO 5683 CHARACTER*4 IERROR 5684C 5685 CHARACTER*4 ISUBN1 5686 CHARACTER*4 ISUBN2 5687C 5688C--------------------------------------------------------------------- 5689C 5690 DIMENSION X(*) 5691C 5692 DOUBLE PRECISION DSUM1 5693 DOUBLE PRECISION DSUM2 5694 DOUBLE PRECISION DRATIO 5695 DOUBLE PRECISION DDEN 5696C 5697C--------------------------------------------------------------------- 5698C 5699 INCLUDE 'DPCOP2.INC' 5700C 5701C-----START POINT----------------------------------------------------- 5702C 5703 ISUBN1='DECR' 5704 ISUBN2='AT ' 5705C 5706 IERROR='NO' 5707 RATIO=CPUMIN 5708C 5709 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CRAT')THEN 5710 WRITE(ICOUT,999) 5711 999 FORMAT(1X) 5712 CALL DPWRST('XXX','BUG ') 5713 WRITE(ICOUT,51) 5714 51 FORMAT('***** AT THE BEGINNING OF DECRAT--') 5715 CALL DPWRST('XXX','BUG ') 5716 WRITE(ICOUT,52)IBUGA3,ISUBRO,N,XQNUM,XQDEN 5717 52 FORMAT('IBUGA3,ISUBRO,N,XQNUM,XQDEN = ',2(A4,2X),I8,2G15.7) 5718 CALL DPWRST('XXX','BUG ') 5719 DO55I=1,N 5720 WRITE(ICOUT,56)I,X(I) 5721 56 FORMAT('I,X(I) = ',I8,G15.7) 5722 CALL DPWRST('XXX','BUG ') 5723 55 CONTINUE 5724 ENDIF 5725C 5726C ******************************************* 5727C ** COMPUTE THE INTERDECILE RATIO ** 5728C ******************************************* 5729C 5730C ******************************************** 5731C ** STEP 1-- ** 5732C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 5733C ******************************************** 5734C 5735 AN=N 5736C 5737 IF(N.LT.1)THEN 5738 WRITE(ICOUT,999) 5739 CALL DPWRST('XXX','BUG ') 5740 WRITE(ICOUT,111) 5741 111 FORMAT('***** ERROR IN DECILE RATIO--') 5742 CALL DPWRST('XXX','BUG ') 5743 WRITE(ICOUT,113) 5744 113 FORMAT(' THE NUMBER OF OBSERVATIONS IS LESS THAN ONE.') 5745 CALL DPWRST('XXX','BUG ') 5746 WRITE(ICOUT,118)N 5747 118 FORMAT(' THE NUMBER OF OBSERVATIONS IS ',I8) 5748 CALL DPWRST('XXX','BUG ') 5749 IERROR='YES' 5750 GOTO9000 5751 ELSEIF(XQNUM.LT.0.0 .OR. XQNUM.GT.1.0)THEN 5752 WRITE(ICOUT,999) 5753 CALL DPWRST('XXX','BUG ') 5754 WRITE(ICOUT,111) 5755 CALL DPWRST('XXX','BUG ') 5756 WRITE(ICOUT,123) 5757 123 FORMAT(' THE SPECIFIED QUANTILE FOR THE NUMERATOR IS ', 5758 1 'OUTSIDE THE (0,1) INTERVAL.') 5759 CALL DPWRST('XXX','BUG ') 5760 WRITE(ICOUT,125)XQNUM 5761 125 FORMAT(' THE VALUE OF THE NUMERATOR QUANTILE = ',G15.7) 5762 CALL DPWRST('XXX','BUG ') 5763 IERROR='YES' 5764 GOTO9000 5765 ELSEIF(XQDEN.LT.0.0 .OR. XQDEN.GT.1.0)THEN 5766 WRITE(ICOUT,999) 5767 CALL DPWRST('XXX','BUG ') 5768 WRITE(ICOUT,111) 5769 CALL DPWRST('XXX','BUG ') 5770 WRITE(ICOUT,133) 5771 133 FORMAT(' THE SPECIFIED QUANTILE FOR THE DENOMINATOR IS ', 5772 1 'OUTSIDE THE (0,1) INTERVAL.') 5773 CALL DPWRST('XXX','BUG ') 5774 WRITE(ICOUT,135)XQDEN 5775 135 FORMAT(' THE VALUE OF THE DENOMINATOR QUANTILE = ',G15.7) 5776 CALL DPWRST('XXX','BUG ') 5777 IERROR='YES' 5778 GOTO9000 5779 ELSEIF(N.EQ.1)THEN 5780 RATIO=1.0 5781 GOTO8000 5782 ENDIF 5783C 5784 IF(XQDEN.GT.XQNUM)THEN 5785 AVAL=XQNUM 5786 XQNUM=XQDEN 5787 XQDEN=AVAL 5788 ENDIF 5789C 5790C *************************************************** 5791C ** STEP 2-- ** 5792C ** SORT THE DATA. ** 5793C *************************************************** 5794C 5795 CALL SORT(X,N,X) 5796C 5797 IF(X(1).LT.0.0)THEN 5798 WRITE(ICOUT,999) 5799 CALL DPWRST('XXX','BUG ') 5800 WRITE(ICOUT,111) 5801 CALL DPWRST('XXX','BUG ') 5802 WRITE(ICOUT,203) 5803 203 FORMAT(' THE RESPONSE VARIABLE CONTAINS NEGATIVE ', 5804 1 'NUMBERS AND THE') 5805 CALL DPWRST('XXX','BUG ') 5806 WRITE(ICOUT,205) 5807 205 FORMAT(' DECILE RATIO IS NOT CURRENTLY SUPPORTED FOR ', 5808 1 'NEGATIVE NUMBERS.') 5809 CALL DPWRST('XXX','BUG ') 5810 IERROR='YES' 5811 GOTO9000 5812 ENDIF 5813C 5814C *************************************************** 5815C ** STEP 3-- ** 5816C ** COMPUTE THE QUANTILES FOR THE NUMERATOR AND ** 5817C ** DENOMINATOR. ** 5818C *************************************************** 5819C 5820 NI=0 5821 NIP1=0 5822 ANI=0.0 5823 A2NI=0.0 5824 REM=0.0 5825 AN=REAL(N) 5826 P=XQDEN 5827 ANI=P*(AN+1.0) 5828 NI=INT(ANI+0.1) 5829 A2NI=REAL(NI) 5830 REM=ANI-A2NI 5831 NIP1=NI+1 5832 IF(NI.LE.1)NI=1 5833 IF(NI.GE.N)NI=N 5834 IF(NIP1.LE.1)NIP1=1 5835 IF(NIP1.GE.N)NIP1=N 5836 DSUM1=0.0D0 5837 DO310I=1,NI 5838 DSUM1=DSUM1 + DBLE(X(I)) 5839 310 CONTINUE 5840 DSUM1=DSUM1 + DBLE(REM*X(NIP1)) 5841 NIDEN=NI 5842 NIP1DN=NIP1 5843 REMDEN=REM 5844C 5845 NI=0 5846 NIP1=0 5847 ANI=0.0 5848 A2NI=0.0 5849 REM=0.0 5850 P=XQNUM 5851 ANI=P*(AN+1.0) 5852 NI=INT(ANI+0.1) 5853 A2NI=REAL(NI) 5854 REM=ANI-A2NI 5855 NIP1=NI+1 5856 IF(NI.LE.1)NI=1 5857 IF(NI.GE.N)NI=N 5858 IF(NIP1.LE.1)NIP1=1 5859 IF(NIP1.GE.N)NIP1=N 5860 DSUM2=0.0D0 5861 DO320I=NI,N 5862 DSUM2=DSUM2 + DBLE(X(I)) 5863 320 CONTINUE 5864 DSUM2=DSUM2 - DBLE(REM*X(NIP1)) 5865 NINUM=NI 5866 NIP1NU=NIP1 5867 REMNUM=REM 5868C 5869 DRATIO=DSUM2/DSUM1 5870 RATIO=REAL(DRATIO) 5871C 5872C ****************************** 5873C ** STEP 4-- ** 5874C ** WRITE OUT A FEW LINES ** 5875C ** OF SUMMARY INFORMATION ** 5876C ** ABOUT THE CODING. ** 5877C ****************************** 5878C 5879 8000 CONTINUE 5880C 5881 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 5882 WRITE(ICOUT,999) 5883 CALL DPWRST('XXX','BUG ') 5884 WRITE(ICOUT,912)RATIO 5885 912 FORMAT('THE INTERDECILE RATIO IS ',G15.7) 5886 CALL DPWRST('XXX','BUG ') 5887 ENDIF 5888C 5889C ***************** 5890C ** STEP 90-- ** 5891C ** EXIT. ** 5892C ***************** 5893C 5894 9000 CONTINUE 5895C 5896 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'CRAT')THEN 5897 WRITE(ICOUT,999) 5898 CALL DPWRST('XXX','BUG ') 5899 WRITE(ICOUT,9011) 5900 9011 FORMAT('***** AT THE END OF DECRAT--') 5901 CALL DPWRST('XXX','BUG ') 5902 WRITE(ICOUT,9012)NINUM,NIP1NU,REMNUM 5903 9012 FORMAT('NINUM,NIP1NU,REMNUM = ',2I8,G15.7) 5904 CALL DPWRST('XXX','BUG ') 5905 WRITE(ICOUT,9013)NIDEN,NIP1DN,REMDEN 5906 9013 FORMAT('NIDEN,NIP1DN,REMDEN = ',2I8,G15.7) 5907 CALL DPWRST('XXX','BUG ') 5908 WRITE(ICOUT,9015)DSUM1,DSUM2,DDEN,DRATIO 5909 9015 FORMAT('DSUM1,DSUM2,DDEN,DRATIO = ',4G15.7) 5910 CALL DPWRST('XXX','BUG ') 5911 ENDIF 5912C 5913 RETURN 5914 END 5915 SUBROUTINE DENEST(DT, NDT, DLO, DHI, WINDOW, FT, SMOOTH, 5916 * NFT, ICAL, IERROR) 5917 IMPLICIT DOUBLE PRECISION (A-H, O-Z) 5918 DOUBLE PRECISION DT(NDT), FT(NFT), SMOOTH(NFT) 5919C 5920 CHARACTER*4 IERROR 5921C 5922 INCLUDE 'DPCOP2.INC' 5923C 5924C ALGORITHM AS 176 APPL. STATIST. (1982) VOL.31, NO.1 5925C Modified using AS R50 (Appl. Statist. (1984)) 5926C 5927C Find density estimate by kernel method using Gaussian kernel. 5928C The interval on which the estimate is evaluated has end points 5929C DLO and DHI. If ICAL is not zero then it is assumed that the 5930C routine has been called before with the same data and end points 5931C and that the array FT has not been altered. 5932C 5933C Auxiliary routines called: FORRT & REVRT from AS 97 5934C 5935C NOTE: MODIFIED JULY 2001 FOR INCLUSION INTO DATAPLOT: 5936C 1) MAKE DOUBLE PRECISION 5937C 2) ADD SOME DATAPLOT I/O, ERROR FLAG 5938C 3) MAKE A FEW STYLISTIC CHANGES 5939C 5940 DATA ZERO/0.0D0/, HALF/0.5D0/, ONE/1.0D0/, SIX/6.0D0/ 5941 DATA THIR2/32.0D0/ 5942 DATA BIG/30.0/, KFTLO/5/, KFTHI/11/ 5943C 5944C The constant BIG is set so that exp(-BIG) can be calculated 5945C without causing underflow problems and can be considered = 0. 5946C 5947C Initialize and check for valid parameter values. 5948C 5949 999 FORMAT(1X) 5950C 5951 IERROR='NO' 5952 IF (WINDOW .LE. ZERO) THEN 5953 WRITE(ICOUT,999) 5954 CALL DPWRST('XXX','BUG ') 5955 WRITE(ICOUT,9011) 5956 9011 FORMAT('***** ERROR IN KERNEL DENSITY--') 5957 CALL DPWRST('XXX','BUG ') 5958 WRITE(ICOUT,9012) 5959 9012 FORMAT(' THE WINDOW MUST BE POSITIVE.') 5960 CALL DPWRST('XXX','BUG ') 5961 WRITE(ICOUT,9013)WINDOW 5962 9013 FORMAT(' VALUE OF WINDOW = ',G15.7) 5963 CALL DPWRST('XXX','BUG ') 5964 IERROR='YES' 5965 GOTO9999 5966 ENDIF 5967C 5968 IF (DLO .GE. DHI) THEN 5969 WRITE(ICOUT,999) 5970 CALL DPWRST('XXX','BUG ') 5971 WRITE(ICOUT,9021) 5972 9021 FORMAT('***** ERROR IN KERNEL DENSITY--') 5973 CALL DPWRST('XXX','BUG ') 5974 WRITE(ICOUT,9023) 5975 9023 FORMAT(' THE LOWER BOUNDARY IS GREATER THAN THE UPPER ', 5976 1 'BOUNDARY.') 5977 CALL DPWRST('XXX','BUG ') 5978 IERROR='YES' 5979 GOTO9999 5980 ENDIF 5981C 5982C CHECK FOR VALID NUMBER OF POINTS FOR DENSITY TRACE 5983C (MUST BE A POWER OF 2 IN RANGE 2**KFTLO TO 2**KFTHI), 5984C CURRENTLY VALUES BETWEEN 2**5 = 32 AND 2**11 = 2,048. 5985C 5986 II = 2**KFTLO 5987 DO 1 K = KFTLO, KFTHI 5988 IF (II .EQ. NFT) GO TO 2 5989 II = II + II 5990 1 CONTINUE 5991 WRITE(ICOUT,999) 5992 CALL DPWRST('XXX','BUG ') 5993 WRITE(ICOUT,9031) 5994 9031 FORMAT('***** ERROR IN KERNEL DENSITY. INVALID VALUE FOR') 5995 CALL DPWRST('XXX','BUG ') 5996 WRITE(ICOUT,9033) 5997 9033 FORMAT(' NUMBER OF POINTS IN THE DENSITY TRACE.') 5998 CALL DPWRST('XXX','BUG ') 5999 WRITE(ICOUT,9035)NFT 6000 9035 FORMAT(' NUMBER OF POINTS = ',I8) 6001 CALL DPWRST('XXX','BUG ') 6002 IERROR='YES' 6003 GOTO9999 6004C 6005 2 CONTINUE 6006 STEP = (DHI - DLO) / DBLE(NFT) 6007 AINC = ONE / (NDT * STEP) 6008 NFT2 = NFT / 2 6009 HW = WINDOW / STEP 6010 FAC1 = THIR2 * (ATAN(ONE) * HW / NFT) ** 2 6011 IF (ICAL .NE. 0) GO TO 10 6012C 6013C Discretize the data 6014C 6015 DLO1 = DLO - STEP * HALF 6016 DO 3 J = 1, NFT 6017 FT(J) = ZERO 6018 3 CONTINUE 6019C 6020 DO 4 I = 1, NDT 6021 WT = (DT(I) - DLO1) / STEP 6022 JJ = INT(WT) 6023 IF (JJ .LT. 1 .OR. JJ .GT. NFT) GO TO 4 6024 WT = WT - JJ 6025 WINC = WT * AINC 6026 KK = JJ + 1 6027 IF (JJ .EQ. NFT) KK = 1 6028 FT(JJ) = FT(JJ) + AINC - WINC 6029 FT(KK) = FT(KK) + WINC 6030 4 CONTINUE 6031C 6032C Transform to find FT. 6033C 6034 CALL FORRT(FT, NFT) 6035C 6036C Find transform of density estimate. 6037C 6038 10 CONTINUE 6039 JHI = INT(SQRT(BIG / FAC1) + 0.1) 6040 JMAX = MIN(NFT2 - 1, JHI) 6041 SMOOTH(1) = FT(1) 6042 RJ = ZERO 6043 DO 11 J = 1, JMAX 6044 RJ = RJ + ONE 6045 RJFAC = RJ * RJ * FAC1 6046 BC = ONE - RJFAC / (HW * HW * SIX) 6047 FAC = EXP(-RJFAC) / BC 6048 J1 = J + 1 6049 J2 = J1 + NFT2 6050 SMOOTH(J1) = FAC * FT(J1) 6051 SMOOTH(J2) = FAC * FT(J2) 6052 11 CONTINUE 6053C 6054C Cope with underflow by setting tail of transform to zero. 6055C 6056 IF (JHI + 1 - NFT2 .GT. 0) THEN 6057 SMOOTH(NFT2 + 1) = EXP(-FAC1 * FLOAT(NFT2)**2) * FT(NFT2 + 1) 6058 ELSEIF (JHI + 1 - NFT2 .LT. 0) THEN 6059 J2LO = JHI + 2 6060 DO 22 J1 = J2LO, NFT2 6061 J2 = J1 + NFT2 6062 SMOOTH(J1) = ZERO 6063 SMOOTH(J2) = ZERO 6064 22 CONTINUE 6065 SMOOTH(NFT2 + 1) = ZERO 6066 ELSE 6067 SMOOTH(NFT2 + 1) = ZERO 6068 ENDIF 6069C 6070C Invert Fourier transform of SMOOTH to get estimate and eliminate 6071C negative density values. 6072C 6073 CALL REVRT(SMOOTH, NFT) 6074 DO 25 J = 1, NFT 6075 IF (SMOOTH(J) .LT. ZERO) SMOOTH(J) = ZERO 6076 25 CONTINUE 6077C 6078 9999 CONTINUE 6079 RETURN 6080 END 6081 DOUBLE PRECISION FUNCTION DNRM2(N,DX,INCX) 6082C***BEGIN PROLOGUE DNRM2 6083C***DATE WRITTEN 791001 (YYMMDD) 6084C***REVISION DATE 820801 (YYMMDD) 6085C***CATEGORY NO. D1A3B 6086C***KEYWORDS BLAS,DOUBLE PRECISION,EUCLIDEAN,L2,LENGTH,LINEAR ALGEBRA, 6087C NORM,VECTOR 6088C***AUTHOR LAWSON, C. L., (JPL) 6089C HANSON, R. J., (SNLA) 6090C KINCAID, D. R., (U. OF TEXAS) 6091C KROGH, F. T., (JPL) 6092C***PURPOSE Euclidean length (L2 norm) of d.p. vector 6093C***DESCRIPTION 6094C 6095C B L A S Subprogram 6096C Description of parameters 6097C 6098C --Input-- 6099C N number of elements in input vector(s) 6100C DX double precision vector with N elements 6101C INCX storage spacing between elements of DX 6102C 6103C --Output-- 6104C DNRM2 double precision result (zero if N .LE. 0) 6105C 6106C Euclidean norm of the N-vector stored in DX() with storage 6107C increment INCX . 6108C If N .LE. 0 return with result = 0. 6109C If N .GE. 1 then INCX must be .GE. 1 6110C 6111C C.L. Lawson, 1978 Jan 08 6112C 6113C Four phase method using two built-in constants that are 6114C hopefully applicable to all machines. 6115C CUTLO = maximum of DSQRT(U/EPS) over all known machines. 6116C CUTHI = minimum of DSQRT(V) over all known machines. 6117C where 6118C EPS = smallest no. such that EPS + 1. .GT. 1. 6119C U = smallest positive no. (underflow limit) 6120C V = largest no. (overflow limit) 6121C 6122C Brief outline of algorithm.. 6123C 6124C Phase 1 scans zero components. 6125C move to phase 2 when a component is nonzero and .LE. CUTLO 6126C move to phase 3 when a component is .GT. CUTLO 6127C move to phase 4 when a component is .GE. CUTHI/M 6128C where M = N for X() real and M = 2*N for complex. 6129C 6130C Values for CUTLO and CUTHI.. 6131C From the environmental parameters listed in the IMSL converter 6132C document the limiting values are as followS.. 6133C CUTLO, S.P. U/EPS = 2**(-102) for Honeywell. Close seconds are 6134C Univac and DEC at 2**(-103) 6135C Thus CUTLO = 2**(-51) = 4.44089E-16 6136C CUTHI, S.P. V = 2**127 for Univac, Honeywell, and DEC. 6137C Thus CUTHI = 2**(63.5) = 1.30438E19 6138C CUTLO, D.P. U/EPS = 2**(-67) for Honeywell and DEC. 6139C Thus CUTLO = 2**(-33.5) = 8.23181D-11 6140C CUTHI, D.P. same as S.P. CUTHI = 1.30438D19 6141C DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / 6142C DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / 6143C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., 6144C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, 6145C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL 6146C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 6147C***ROUTINES CALLED (NONE) 6148C***END PROLOGUE DNRM2 6149 INTEGER NEXT 6150 DOUBLE PRECISION DX(1), CUTLO, CUTHI, HITEST, SUM, XMAX,ZERO,ONE 6151 DATA ZERO, ONE /0.0D0, 1.0D0/ 6152C 6153 DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / 6154C***FIRST EXECUTABLE STATEMENT DNRM2 6155 IF(N .GT. 0) GO TO 10 6156 DNRM2 = ZERO 6157 GO TO 300 6158C 6159CCC10 ASSIGN 30 TO NEXT 6160 10 CONTINUE 6161 NEXT=30 6162 SUM = ZERO 6163 NN = N * INCX 6164C BEGIN MAIN LOOP 6165 I = 1 6166CCC20 GO TO NEXT,(30, 50, 70, 110) 6167 20 CONTINUE 6168 IF(NEXT.EQ.30)THEN 6169 GOTO30 6170 ELSEIF(NEXT.EQ.50)THEN 6171 GOTO50 6172 ELSEIF(NEXT.EQ.70)THEN 6173 GOTO70 6174 ELSEIF(NEXT.EQ.110)THEN 6175 GOTO110 6176 ENDIF 6177C 6178 30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 6179CCCCC ASSIGN 50 TO NEXT 6180 NEXT=50 6181 XMAX = ZERO 6182C 6183C PHASE 1. SUM IS ZERO 6184C 6185 50 IF( DX(I) .EQ. ZERO) GO TO 200 6186 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 6187C 6188C PREPARE FOR PHASE 2. 6189CCCCC ASSIGN 70 TO NEXT 6190 NEXT=70 6191 GO TO 105 6192C 6193C PREPARE FOR PHASE 4. 6194C 6195 100 I = J 6196CCCCC ASSIGN 110 TO NEXT 6197 NEXT=110 6198 SUM = (SUM / DX(I)) / DX(I) 6199 105 XMAX = DABS(DX(I)) 6200 GO TO 115 6201C 6202C PHASE 2. SUM IS SMALL. 6203C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. 6204C 6205 70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75 6206C 6207C COMMON CODE FOR PHASES 2 AND 4. 6208C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. 6209C 6210 110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115 6211 SUM = ONE + SUM * (XMAX / DX(I))**2 6212 XMAX = DABS(DX(I)) 6213 GO TO 200 6214C 6215 115 SUM = SUM + (DX(I)/XMAX)**2 6216 GO TO 200 6217C 6218C 6219C PREPARE FOR PHASE 3. 6220C 6221 75 SUM = (SUM * XMAX) * XMAX 6222C 6223C 6224C FOR REAL OR D.P. SET HITEST = CUTHI/N 6225C FOR COMPLEX SET HITEST = CUTHI/(2*N) 6226C 6227 85 CONTINUE 6228 HITEST = CUTHI/FLOAT( N ) 6229C 6230C PHASE 3. SUM IS MID-RANGE. NO SCALING. 6231C 6232 DO 95 J =I,NN,INCX 6233 IF(DABS(DX(J)) .GE. HITEST) GO TO 100 6234 SUM = SUM + DX(J)**2 6235 95 CONTINUE 6236 DNRM2 = DSQRT( SUM ) 6237 GO TO 300 6238C 6239 200 CONTINUE 6240 I = I + INCX 6241 IF ( I .LE. NN ) GO TO 20 6242C 6243C END OF MAIN LOOP. 6244C 6245C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. 6246C 6247 DNRM2 = XMAX * DSQRT(SUM) 6248 300 CONTINUE 6249 RETURN 6250 END 6251 SUBROUTINE DECONV(Y1,N1,Y2,N2,NUMVAR,IWRITE, 6252 1 Y3,N3,IBUGA3,IERROR) 6253C 6254C PURPOSE--COMPUTE DECONVOLUTION OF 2 VARIABLES. 6255C NOTE--IF THE FIRST VARIABLE IS Y1(.) 6256C AND THE SECOND VARIABLE IS Y2(.), 6257C THEN THE OUTPUT VARIABLE CONTAINING THE 6258C DECONVOLUTION 6259C WILL BE COMPUTED AS FOLLOWS (IF N1 EQUALS OR EXCEEDS N2)-- 6260C Y3(1)=Y2(1)/Y1(1) 6261C Y3(2)=(Y2(2)-Y1(2)*Y3(1)) / Y1(1) 6262C Y3(3)=(Y2(3) - Y1(3)*Y3(1) - Y1(2)*Y3(2)) / Y1(1) 6263C ETC. 6264C AND CONVERSELY IF N1 IS LESS THAN N2. 6265C NOTE--IT IS NOT PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y3(.) 6266C BEING IDENTICAL WITH (OVERLAYED ONTO) THE INPUT VECTORS Y1(.) 6267C OR Y2(.). 6268C NOTE--Y1 AND Y2 NEED NOT BE THE SAME LENGTH. 6269C WRITTEN BY--JAMES J. FILLIBEN 6270C STATISTICAL ENGINEERING DIVISION 6271C INFORMATION TECHNOLOGY LABORATORY 6272C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 6273C GAITHERSBURG, MD 20899-8980 6274C PHONE--301-921-3651 6275C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 6276C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 6277C LANGUAGE--ANSI FORTRAN (1977) 6278C VERSION NUMBER--82/7 6279C ORIGINAL VERSION--NOVEMBER 1981. 6280C UPDATED --MAY 1982. 6281C 6282C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 6283C 6284 CHARACTER*4 IWRITE 6285 CHARACTER*4 IBUGA3 6286 CHARACTER*4 IERROR 6287C 6288 CHARACTER*4 ISUBN1 6289 CHARACTER*4 ISUBN2 6290 CHARACTER*4 ISTEPN 6291C 6292C--------------------------------------------------------------------- 6293C 6294 DIMENSION Y1(*) 6295 DIMENSION Y2(*) 6296 DIMENSION Y3(*) 6297C 6298C--------------------------------------------------------------------- 6299C 6300 INCLUDE 'DPCOP2.INC' 6301C 6302C-----START POINT----------------------------------------------------- 6303C 6304 ISUBN1='DECO' 6305 ISUBN2='NV ' 6306 IERROR='NO' 6307C 6308 IF(IBUGA3.EQ.'ON')THEN 6309 WRITE(ICOUT,999) 6310 999 FORMAT(1X) 6311 CALL DPWRST('XXX','BUG ') 6312 WRITE(ICOUT,51) 6313 51 FORMAT('***** AT THE BEGINNING OF DECONV--') 6314 CALL DPWRST('XXX','BUG ') 6315 WRITE(ICOUT,52)IBUGA3,IWRITE 6316 52 FORMAT('IBUGA3,IWRITE = ',A4,2X,A4) 6317 CALL DPWRST('XXX','BUG ') 6318 WRITE(ICOUT,53)N1,N2,NUMVAR 6319 53 FORMAT('N1,N2,NUMVAR = ',3I8) 6320 CALL DPWRST('XXX','BUG ') 6321 DO55I=1,N1 6322 WRITE(ICOUT,56)I,Y1(I) 6323 56 FORMAT('I,Y1(I) = ',I8,G15.7) 6324 CALL DPWRST('XXX','BUG ') 6325 55 CONTINUE 6326 DO57I=1,N2 6327 WRITE(ICOUT,58)I,Y2(I) 6328 58 FORMAT('I,Y2(I) = ',I8,G15.7) 6329 CALL DPWRST('XXX','BUG ') 6330 57 CONTINUE 6331 ENDIF 6332C 6333C ********************************* 6334C ** COMPUTE THE DECONVOLUTION ** 6335C ********************************* 6336C 6337 ISTEPN='1' 6338 IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6339C 6340 IF(N1.LE.0)GOTO150 6341 IF(N2.LE.0)GOTO150 6342C 6343 IF(N1.LE.N2)N3=N2-N1+1 6344 IF(N1.GT.N2)N3=N1-N2+1 6345 IF(N3.LE.0)GOTO170 6346C 6347 DO100I3=1,N3 6348 Y3(I3)=0.0 6349 100 CONTINUE 6350C 6351 DO500I3=1,N3 6352 SUM=0.0 6353 J3MAX=I3-1 6354 IF(J3MAX.LE.0)GOTO550 6355 DO600J3=1,J3MAX 6356 J1ARG=I3-J3+1 6357 IF(N1.LE.N2)SUM=SUM+Y1(J1ARG)*Y3(J3) 6358 IF(N1.GT.N2)SUM=SUM+Y2(J1ARG)*Y3(J3) 6359 600 CONTINUE 6360 550 CONTINUE 6361 IF(N1.LE.N2)Y3(I3)=(Y2(I3)-SUM)/Y1(1) 6362 IF(N1.GT.N2)Y3(I3)=(Y1(I3)-SUM)/Y2(1) 6363 500 CONTINUE 6364 GOTO190 6365C 6366 150 CONTINUE 6367 IERROR='YES' 6368 WRITE(ICOUT,999) 6369 CALL DPWRST('XXX','BUG ') 6370 WRITE(ICOUT,151) 6371 151 FORMAT('***** ERROR IN DECONV--') 6372 CALL DPWRST('XXX','BUG ') 6373 WRITE(ICOUT,152) 6374 152 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') 6375 CALL DPWRST('XXX','BUG ') 6376 WRITE(ICOUT,153) 6377 153 FORMAT(' IN THE VARIABLES FOR WHICH') 6378 CALL DPWRST('XXX','BUG ') 6379 WRITE(ICOUT,154) 6380 154 FORMAT(' THE DECONVOLUTION IS TO BE COMPUTED') 6381 CALL DPWRST('XXX','BUG ') 6382 WRITE(ICOUT,155) 6383 155 FORMAT(' MUST BE 1 OR LARGER.') 6384 CALL DPWRST('XXX','BUG ') 6385 WRITE(ICOUT,156) 6386 156 FORMAT(' SUCH WAS NOT THE CASE HERE.') 6387 CALL DPWRST('XXX','BUG ') 6388 WRITE(ICOUT,157)N1,N2 6389 157 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',2I8, 6390 1'.') 6391 CALL DPWRST('XXX','BUG ') 6392 GOTO190 6393C 6394 170 CONTINUE 6395 IERROR='YES' 6396 WRITE(ICOUT,999) 6397 CALL DPWRST('XXX','BUG ') 6398 WRITE(ICOUT,171) 6399 171 FORMAT('***** ERROR IN DECONV--') 6400 CALL DPWRST('XXX','BUG ') 6401 WRITE(ICOUT,172) 6402 172 FORMAT(' THE NUMBER OF OBSERVATIONS') 6403 CALL DPWRST('XXX','BUG ') 6404 WRITE(ICOUT,173) 6405 173 FORMAT(' IN THE RESULTING DECONVOLUTION VARIABLE ') 6406 CALL DPWRST('XXX','BUG ') 6407 WRITE(ICOUT,175) 6408 175 FORMAT(' MUST BE 1 OR LARGER.') 6409 CALL DPWRST('XXX','BUG ') 6410 WRITE(ICOUT,176) 6411 176 FORMAT(' SUCH WAS NOT THE CASE HERE.') 6412 CALL DPWRST('XXX','BUG ') 6413 WRITE(ICOUT,177)N3 6414 177 FORMAT(' THE OUTPUT NUMBER OF OBSERVATIONS HERE = ',I8, 6415 1'.') 6416 CALL DPWRST('XXX','BUG ') 6417 GOTO190 6418C 6419 190 CONTINUE 6420C 6421C ***************** 6422C ** STEP 90-- ** 6423C ** EXIT. ** 6424C ***************** 6425C 6426 IF(IBUGA3.EQ.'ON')THEN 6427 WRITE(ICOUT,999) 6428 CALL DPWRST('XXX','BUG ') 6429 WRITE(ICOUT,9011) 6430 9011 FORMAT('***** AT THE END OF DECONV--') 6431 CALL DPWRST('XXX','BUG ') 6432 WRITE(ICOUT,9012)IBUGA3,IERROR 6433 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 6434 CALL DPWRST('XXX','BUG ') 6435 WRITE(ICOUT,9013)N1,N2,NUMVAR,N3 6436 9013 FORMAT('N1,N2,NUMVAR,N3 = ',4I8) 6437 CALL DPWRST('XXX','BUG ') 6438 N12=N1 6439 IF(N2.GT.N1)N12=N2 6440 DO9015I=1,N12 6441 WRITE(ICOUT,9016)I,Y1(I),Y2(I),Y3(I) 6442 9016 FORMAT('I,Y1(I),Y2(I),Y3(I) = ',I8,3G15.7) 6443 CALL DPWRST('XXX','BUG ') 6444 9015 CONTINUE 6445 ENDIF 6446C 6447 RETURN 6448 END 6449 SUBROUTINE DEHAAN(X,N,THRESH,GAMMA,SD,KK,ANM1) 6450CC 6451CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 6452C SUBROUTINE IMPLEMENTING THE DEHAAN- C 6453C DEKKER MOMENT-BASED EXTREME VALUE C 6454C INDEX ESTIMATOR AS DOCUMENTED IN C 6455C "EXTREME VALUE THEORY AND APPLICATIONS", C 6456C EDITED BY GALAMBOS, LECHNER, AND SIMIU, PP. 93-122, C 6457C KLUWER ACADEMIC PUBLISHERS, BOSTON, 1994. C 6458CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 6459CC 6460CC NOTE: DEHAAN NORMALLY DONE AS A PLOT. WE ARE PICKING A SINGLE 6461CC "SAMPLE" VALUE, ALGORITHM WAS MODIFIED ACCORDINGLY. 6462CC 6463CC UPDATED 10/2010: SLIGHT TWEAK TO ALGORITHM. PASS IN VALUE 6464CC OF THRESHOLD AND USE THIS AS VALUE FOR DX2. THE X ARRAY SHOULD 6465CC CONTAIN POINTS ABOVE THE THRESHOLD ONLY. 6466CC 6467 DOUBLE PRECISION GAMNUM,GAMDEN, DGAMMA 6468 DOUBLE PRECISION DTERM1, DX1, DX2 6469 REAL GAMMA 6470 REAL X(*) 6471CC 6472CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 6473C THE MAIN LOOP C 6474C COMPUTE THE DEHAAN-DEKKER C 6475C INDEX "GAMMA" FOR THE K C 6476C HIGHEST ORDER STATISTICS, C 6477C ITERATING ON K. C 6478CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 6479CC 6480 NI=N 6481C 6482 AN=REAL(NI) 6483 ATEMP=SQRT(AN) 6484 KK = NI 6485CC 6486C GAMNUM AND GAMDEN ARE MN(1) AND MN(2) ON PAGE 100 6487C OF THE REFERENCE CITED ABOVE. 6488C 6489 GAMNUM=0.D0 6490 GAMDEN=0.D0 6491CC 6492 DO 50 J=1,KK 6493CCCCC DO 50 J=1,NI 6494CC 6495 JM1=J-1 6496 DX1=DBLE(X(NI-JM1)) 6497CCCCC DX2=DBLE(X(NI-KK)) 6498 DX2=THRESH 6499 DTERM1=DLOG(DX1)-DLOG(DX2) 6500 GAMNUM=GAMNUM+DTERM1 6501 GAMDEN=GAMDEN+DTERM1*DTERM1 6502CC 650350 CONTINUE 6504CC 6505 GAMNUM=GAMNUM/DBLE(KK) 6506 GAMDEN=GAMDEN/DBLE(KK) 6507 ANM1=REAL(GAMNUM) 6508 ANM2=REAL(GAMDEN) 6509CC 6510 DTERM1=GAMNUM**2/GAMDEN 6511 DGAMMA=GAMNUM + 1.0D0 - 0.5D0*(1.0D0/(1.0D0 - DTERM1)) 6512 GAMMA=REAL(DGAMMA) 6513C 6514C COMPUTE THE STANDARD DEVIATION OF C 6515C 6516 IF(GAMMA.GE.0.0)THEN 6517 SD=SQRT((1.0+GAMMA*GAMMA)/REAL(KK)) 6518 ELSE 6519 DTERM1=(1.0D0-DGAMMA)*(1.0D0-DGAMMA)*(1.0D0-2.0D0*DGAMMA) 6520 DTERM2=4.0D0-8.0D0*(1.0D0-2.0D0*DGAMMA)/(1.0D0-3.0D0*DGAMMA) 6521 DTERM3=(5.0D0-11.0D0*DGAMMA)*(1.0D0-2.0D0*DGAMMA)/ 6522 1 ((1.0D0-3.0D0*DGAMMA)*(1.0D0-4.0D0*DGAMMA)) 6523 SD=REAL(DSQRT(DTERM1*(DTERM2+DTERM3)/DBLE(KK))) 6524 ENDIF 6525CC 6526 RETURN 6527 END 6528 SUBROUTINE DEQUOT(IA,NCIN,IB,NCOUT2,IBUGSU,ISUBRO) 6529C 6530C PURPOSE--CHECK A STRING FOR LEADING/TRAILING QUOTES AND 6531C REMOVE IF FOUND. USED FOR FILE NAME ARGUMENTS THAT 6532C MAY BE QUOTED IF THEY CONTAIN SPACES OR HYPHENS. 6533C INPUT ARGUMENTS--IA = INPUT CHARACTER STRING 6534C NCIN = INTEGER NUMBER OF CHARACTERS TO CHECK 6535C IBUGSU = HOLLERITH BUG (= TRACE) VARIABLE 6536C OUTPUT ARGUMENTS--IB = OUTPUT CHARACTER STRING 6537C NCOUT2 = INTEGER NUMBER OF CHARACTERS ON OUTPUT 6538C 6539C WRITTEN BY--ALAN HECKERT 6540C STATISTICAL ENGINEERING DIVISION 6541C INFORMATION TECHNOLOGY LABORATORY 6542C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 6543C GAITHERSBURG, MD 20899-8980 6544C PHONE--301-975-2899 6545C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 6546C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 6547C LANGUAGE--ANSI FORTRAN (1977) 6548C VERSION NUMBER--2004/8 6549C ORIGINAL VERSION--OCTOBER 2004 6550C 6551C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 6552C 6553 CHARACTER*(*) IA 6554 CHARACTER*(*) IB 6555C 6556 CHARACTER*1 IQUOTE 6557 CHARACTER*1 IQUOT2 6558C 6559 CHARACTER*4 IBUGSU 6560 CHARACTER*4 ISUBRO 6561C 6562C--------------------------------------------------------------------- 6563C 6564C--------------------------------------------------------------------- 6565C 6566 INCLUDE 'DPCOP2.INC' 6567C 6568C-----START POINT----------------------------------------------------- 6569C 6570 IF(IBUGSU.EQ.'ON' .OR. ISUBRO.EQ.'QUOT')THEN 6571 WRITE(ICOUT,999) 6572 999 FORMAT(1X) 6573 CALL DPWRST('XXX','BUG ') 6574 WRITE(ICOUT,51) 6575 51 FORMAT('***** AT THE BEGINNING OF DEQUOT--') 6576 CALL DPWRST('XXX','BUG ') 6577 WRITE(ICOUT,52)NCIN,IBUGSU 6578 52 FORMAT('NCIN,IBUGSU = ',I8,2X,A4) 6579 CALL DPWRST('XXX','BUG ') 6580 WRITE(ICOUT,53)IA(1:MIN(80,NCIN)) 6581 53 FORMAT('(IA(1:NCIN) = ',80A1) 6582 CALL DPWRST('XXX','BUG ') 6583 ENDIF 6584C 6585C ****************************************************** 6586C ** CHECK FOR LEADING/TRAILING QUOTES. ** 6587C ****************************************************** 6588C 6589C 6590 CALL DPCONA(39,IQUOTE) 6591 IQUOT2='"' 6592 NCOUT2=0 6593C 6594 IF(NCIN.GT.0)THEN 6595 IF(IA(1:1).EQ.IQUOT2)THEN 6596 DO100I=2,NCIN 6597 IF(IA(I:I).EQ.IQUOT2)GOTO109 6598 NCOUT2=NCOUT2+1 6599 IB(NCOUT2:NCOUT2)=IA(I:I) 6600 100 CONTINUE 6601 109 CONTINUE 6602 ELSEIF(IA(1:1).EQ.'"')THEN 6603 DO200I=2,NCIN 6604 IF(IA(I:I).EQ.IQUOTE)GOTO209 6605 NCOUT2=NCOUT2+1 6606 IB(NCOUT2:NCOUT2)=IA(I:I) 6607 200 CONTINUE 6608 209 CONTINUE 6609 ELSE 6610 IB(1:NCIN)=IA(1:NCIN) 6611 NCOUT2=NCIN 6612 ENDIF 6613 ENDIF 6614C 6615C ***************** 6616C ** STEP 90-- ** 6617C ** EXIT. ** 6618C ***************** 6619C 6620 IF(IBUGSU.EQ.'ON' .OR. ISUBRO.EQ.'QUOT')THEN 6621 WRITE(ICOUT,999) 6622 CALL DPWRST('XXX','BUG ') 6623 WRITE(ICOUT,9011) 6624 9011 FORMAT('***** AT THE END OF DEQUOT--') 6625 CALL DPWRST('XXX','BUG ') 6626 WRITE(ICOUT,9012)NCOUT2 6627 9012 FORMAT('NCOUT2 = ',I8) 6628 CALL DPWRST('XXX','BUG ') 6629 IF(NCOUT2.GT.0)THEN 6630 WRITE(ICOUT,9013)IB(1:MIN(80,NCOUT2)) 6631 9013 FORMAT('(IB(1:NCOUT2) = ',80A1) 6632 CALL DPWRST('XXX','BUG ') 6633 ENDIF 6634 ENDIF 6635C 6636 RETURN 6637 END 6638C===================================================== DERF.FOR 6639 DOUBLE PRECISION FUNCTION DERFDP(X) 6640CCCCC 2020/03: RENAME TO AVOID CONFLICT WITH INTRNISIC FUNCTION 6641CCCCC DOUBLE PRECISION FUNCTION DERF(X) 6642C*********************************************************************** 6643C* * 6644C* FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, * 6645C* 'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' * 6646C* * 6647C* J. R. M. HOSKING * 6648C* IBM RESEARCH DIVISION * 6649C* T. J. WATSON RESEARCH CENTER * 6650C* YORKTOWN HEIGHTS * 6651C* NEW YORK 10598, U.S.A. * 6652C* * 6653C* VERSION 3 AUGUST 1996 * 6654C* * 6655C*********************************************************************** 6656C 6657C ERROR FUNCTION 6658C 6659C BASED ON ALGORITHM 5666, J.F.HART ET AL. (1968) 'COMPUTER 6660C APPROXIMATIONS' 6661C 6662C ACCURATE TO 15 DECIMAL PLACES 6663C 6664 IMPLICIT DOUBLE PRECISION (A-H, O-Z) 6665 DATA ZERO/0D0/,ONE/1D0/,TWO/2D0/,THREE/3D0/,FOUR/4D0/,P65/0.65D0/ 6666C 6667C COEFFICIENTS OF RATIONAL-FUNCTION APPROXIMATION 6668C 6669 DATA P0,P1,P2,P3,P4,P5,P6/ 6670 * 0.22020 68679 12376 1D3, 0.22121 35961 69931 1D3, 6671 * 0.11207 92914 97870 9D3, 0.33912 86607 83830 0D2, 6672 * 0.63739 62203 53165 0D1, 0.70038 30644 43688 1D0, 6673 * 0.35262 49659 98910 9D-1/ 6674 DATA Q0,Q1,Q2,Q3,Q4,Q5,Q6,Q7/ 6675 * 0.44041 37358 24752 2D3, 0.79382 65125 19948 4D3, 6676 * 0.63733 36333 78831 1D3, 0.29656 42487 79673 7D3, 6677 * 0.86780 73220 29460 8D2, 0.16064 17757 92069 5D2, 6678 * 0.17556 67163 18264 2D1, 0.88388 34764 83184 4D-1/ 6679C 6680C C1 IS SQRT(2), C2 IS SQRT(2/PI) 6681C BIG IS THE POINT AT WHICH DERF=1 TO MACHINE PRECISION 6682C 6683 DATA C1/1.4142 13562 37309 5D0/ 6684 DATA C2/7.9788 45608 02865 4D-1/ 6685 DATA BIG/6.25D0/,CRIT/5D0/ 6686C 6687 DERFDP=ZERO 6688 IF(X.EQ.ZERO)RETURN 6689 XX=DABS(X) 6690 IF(XX.GT.BIG)GOTO 20 6691 EXPNTL=DEXP(-X*X) 6692 ZZ=DABS(X*C1) 6693 IF(XX.GT.CRIT)GOTO 10 6694 DERFDP=EXPNTL*((((((P6*ZZ+P5)*ZZ+P4)*ZZ+P3)*ZZ+P2)*ZZ+P1)*ZZ+P0)/ 6695 * (((((((Q7*ZZ+Q6)*ZZ+Q5)*ZZ+Q4)*ZZ+Q3)*ZZ+Q2)*ZZ+Q1)*ZZ+Q0) 6696 IF(X.GT.ZERO)DERFDP=ONE-TWO*DERFDP 6697 IF(X.LT.ZERO)DERFDP=TWO*DERFDP-ONE 6698 RETURN 6699C 6700 10 DERFDP=EXPNTL*C2/(ZZ+ONE/(ZZ+TWO/(ZZ+THREE/(ZZ+FOUR/(ZZ+P65))))) 6701 IF(X.GT.ZERO)DERFDP=ONE-DERFDP 6702 IF(X.LT.ZERO)DERFDP=DERFDP-ONE 6703 RETURN 6704C 6705 20 DERFDP=ONE 6706 IF(X.LT.ZERO)DERFDP=-ONE 6707 RETURN 6708 END 6709 SUBROUTINE DERIV0(IW21,IW22,ITYPE,NW, 6710 1IPARN1,IPARN2,NUMPAR,IVARN1,IVARN2,NUMVAR, 6711 1ICON,ICON1,ICON2,NCON,ID1,ID2,NWD, 6712 1IBUGA3,ISUBRO,IFOUND,IERROR) 6713C 6714C NOTE--THE ARRAY ICONN (DEFINED BELOW AND USED 6715C IN SUBSEQUENT SUBROUTINES) IS PROBABLY 6716C SUPERFLUOUS AND PROBABLY NO LONGER SERVES ANY PURPOSE 6717C (CHECK THIS). 6718C THE NECESSITY OF IEXPN IS ALSO IN QUESTION. 6719C 6720C--------------------------------------------------------------------- 6721C 6722 CHARACTER*4 IW21 6723 CHARACTER*4 IW22 6724 CHARACTER*4 ITYPE 6725 CHARACTER*4 IPARN1 6726 CHARACTER*4 IPARN2 6727 CHARACTER*4 IVARN1 6728 CHARACTER*4 IVARN2 6729 CHARACTER*4 ICON 6730 CHARACTER*4 ID1 6731 CHARACTER*4 ID2 6732 CHARACTER*4 IBUGA3 6733 CHARACTER*4 ISUBRO 6734 CHARACTER*4 IFOUND 6735 CHARACTER*4 IERROR 6736C 6737 CHARACTER*4 ILF 6738 CHARACTER*4 IHOLD1 6739 CHARACTER*4 IHOLD2 6740 CHARACTER*4 IFUN01 6741 CHARACTER*4 IFUN02 6742 CHARACTER*4 IDER01 6743 CHARACTER*4 IDER02 6744 CHARACTER*4 ICONN 6745 CHARACTER*4 IEXPN 6746C 6747 CHARACTER*4 IHOLW1 6748 CHARACTER*4 IHOLW2 6749 CHARACTER*4 IHOLDT 6750 CHARACTER*4 ITER01 6751 CHARACTER*4 ITER02 6752C 6753 CHARACTER*4 ISTEPN 6754 CHARACTER*4 ISUBN1 6755 CHARACTER*4 ISUBN2 6756C 6757CCCCC CHARACTER*4 IBUG1 6758 CHARACTER*4 IBUG2 6759CCCCC CHARACTER*4 IBUG3 6760CCCCC CHARACTER*4 IBUG41 6761CCCCC CHARACTER*4 IBUG5 6762CCCCC CHARACTER*4 IBUG51 6763C 6764 DIMENSION IW21(*) 6765 DIMENSION IW22(*) 6766 DIMENSION ITYPE(*) 6767 DIMENSION IPARN1(*) 6768 DIMENSION IPARN2(*) 6769 DIMENSION IVARN1(*) 6770 DIMENSION IVARN2(*) 6771 DIMENSION ICON(*) 6772 DIMENSION ICON1(*) 6773 DIMENSION ICON2(*) 6774 DIMENSION ID1(*) 6775 DIMENSION ID2(*) 6776C 6777 DIMENSION IHOLD1(200) 6778 DIMENSION IHOLD2(200) 6779 DIMENSION IFUN01(200) 6780 DIMENSION IFUN02(200) 6781 DIMENSION IDER01(200) 6782 DIMENSION IDER02(200) 6783 DIMENSION ICONN(200) 6784 DIMENSION IEXPN(200) 6785C 6786 DIMENSION IHOLW1(200) 6787 DIMENSION IHOLW2(200) 6788 DIMENSION IHOLDT(200) 6789 DIMENSION ITER01(1000) 6790 DIMENSION ITER02(1000) 6791 DIMENSION ITERM1(100) 6792 DIMENSION ITERM2(100) 6793C 6794C-----COMMON VARIABLES (GENERAL)----------------------------------------------- 6795C 6796 INCLUDE 'DPCOP2.INC' 6797C 6798C-----DATA STATEMENTS----------------------------------------------------- 6799CCCCC DATA IBUG1/'OFF '/ 6800 DATA IBUG2/'OFF '/ 6801CCCCC DATA IBUG3/'OFF '/ 6802CCCCC DATA IBUG41/'OFF '/ 6803CCCCC DATA IBUG5/'OFF '/ 6804CCCCC DATA IBUG51/'OFF '/ 6805C 6806C-----START POINT----------------------------------------------------- 6807C 6808 ISUBN1='DERI' 6809 ISUBN2='V0 ' 6810C 6811 IMIN=1 6812 IMAX=1 6813C 6814 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'RIV0')GOTO90 6815 WRITE(ICOUT,999) 6816 CALL DPWRST('XXX','BUG ') 6817 WRITE(ICOUT,51) 6818 51 FORMAT('AT THE BEGINNING OF DERIV0--') 6819 CALL DPWRST('XXX','BUG ') 6820 WRITE(ICOUT,52)NW 6821 52 FORMAT('NW = ',I8) 6822 CALL DPWRST('XXX','BUG ') 6823 DO55I=1,NW 6824 WRITE(ICOUT,56)I,ITYPE(I),IW21(I),IW22(I) 6825 56 FORMAT('I,ITYPE(I),IW21(I),IW22(I) = ',I8,2X,A4,2X,A4,2X,A4) 6826 CALL DPWRST('XXX','BUG ') 6827 55 CONTINUE 6828 WRITE(ICOUT,61)NCON 6829 61 FORMAT('NCON = ',I8) 6830 CALL DPWRST('XXX','BUG ') 6831 DO65I=1,NCON 6832 WRITE(ICOUT,66)I,ICON1(I),ICON2(I),ICON(I) 6833 66 FORMAT('I,ICON1(I),ICON2(I),ICON(I) = ',3I8,2X,A4) 6834 CALL DPWRST('XXX','BUG ') 6835 65 CONTINUE 6836 90 CONTINUE 6837C 6838C *********************************** 6839C ** STEP 0-- ** 6840C ** REDUCE THE FULL EXPRESSION ** 6841C ** INTO NAMED SUB-EXPRESSIONS. ** 6842C *********************************** 6843C 6844 IT2=0 6845C 6846C ***************************************** 6847C ** STEP 1-- ** 6848C ** REPLACE THE CONSTANTS ** 6849C ** BY THE CONSTANT DESIGNATIONS. ** 6850C ***************************************** 6851C 6852 ILOOP=1 6853 2350 CONTINUE 6854C 6855 ISTEPN='1' 6856 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 6857 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6858C 6859 DO2400I=1,NW 6860 I2=I 6861 IF(ITYPE(I).EQ.'N ')GOTO2450 6862 2400 CONTINUE 6863 ISTOP=NW+1 6864 ISTART=0 6865 GOTO2790 6866 2450 CONTINUE 6867C 6868 ISTART=I2 6869 ISTOP=ISTART 6870 CALL DPC4HI(IW21(ISTOP),IC,IBUGA3,IERROR) 6871C 6872C *************************************************** 6873C ** STEP 1.4-- ** 6874C ** TEMPORARILY COPY THE STRING WHICH IS BEYOND ** 6875C ** THE CONSTANT NUMBER ** 6876C ** INTO IHOLD1(.). ** 6877C *************************************************** 6878C 6879 ISTEPN='1.4' 6880 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 6881 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6882C 6883 J=0 6884 ISTOP1=ISTOP+1 6885 IF(ISTOP1.GT.NW)GOTO2249 6886 DO2240I=ISTOP1,NW 6887 J=J+1 6888 IHOLW1(J)=IW21(I) 6889 IHOLW2(J)=IW22(I) 6890 IHOLDT(J)=ITYPE(I) 6891 2240 CONTINUE 6892 2249 CONTINUE 6893 NREST=J 6894C 6895C **************************** 6896C ** STEP 1.5-- ** 6897C ** REPLACE THE CONSTANT ** 6898C ** BY A & AND A NUMBER. ** 6899C **************************** 6900C 6901 ISTEPN='1.5' 6902 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 6903 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6904C 6905 J=ISTART 6906 IW21(J)='& ' 6907 IW22(J)=' ' 6908 ITYPE(J)='C ' 6909 J=J+1 6910 CALL DPC4IH(IC,IW21(J),IBUGA3,IERROR) 6911 IW22(J)=' ' 6912 ITYPE(J)='C ' 6913C 6914 IF(NREST.LE.0)GOTO2290 6915 DO2280I=1,NREST 6916 J=J+1 6917 IW21(J)=IHOLW1(I) 6918 IW22(J)=IHOLW2(I) 6919 ITYPE(J)=IHOLDT(I) 6920 2280 CONTINUE 6921 2290 CONTINUE 6922 NW=J 6923C 6924 IF(ISTART.LE.0)GOTO2790 6925 ILOOP=ILOOP+1 6926 IF(ILOOP.LE.10000)GOTO2350 6927 2790 CONTINUE 6928C 6929 ILOOP=1 6930 5310 CONTINUE 6931 DO5400I=1,NW 6932 I2=I 6933 IF(ITYPE(I).EQ.'RP ')GOTO5450 6934 5400 CONTINUE 6935 ISTOP=NW+1 6936 ISTART=0 6937 GOTO5690 6938 5450 CONTINUE 6939C 6940 ISTOP=I2 6941 DO5600I=1,ISTOP 6942 IREV=ISTOP-I+1 6943 IF(ITYPE(IREV).EQ.'LP ')GOTO5650 6944 5600 CONTINUE 6945 WRITE(ICOUT,5605) 6946 5605 FORMAT('***** ERROR IN COMPID--ITYPE(IREV) NOT LP') 6947 CALL DPWRST('XXX','BUG ') 6948 IERROR='YES' 6949 RETURN 6950 5650 CONTINUE 6951 ISTART=IREV 6952 5690 CONTINUE 6953C 6954 ISTAP1=ISTART+1 6955 ISTOM1=ISTOP-1 6956C 6957C ******************************************************* 6958C ** STEP 1.6-- ** 6959C ** CHECK THE INTERNAL STRING TO SEE ** 6960C ** IF IT IS EXACTLY 2 POSITIONS WIDE, AND ** 6961C ** ALSO THAT IT IS OF THE FORM ** 6962C ** $ FOLLOWED BY A NUMBER. ** 6963C ** IF SO, THEN THIS IMPLIES ** 6964C ** THAT THE INTERNAL ORIGINAL STRING ** 6965C ** HAS ALREADY BEEN FULLY REDUCED. ** 6966C ** IF NOT SO, THEN THIS IMPLIES ** 6967C ** THAT THE INTERNAL ORIGINAL ** 6968C ** STRING HAS NOT YET BEEN FULLY REDUCED, ** 6969C ** AND THAT THE OPERATION PRELIMINARY ** 6970C ** TO THE ( MUST BE CHECKED TO ** 6971C ** DETERMINE IF THE PARENTHESES ** 6972C ** ARE TO BE KEPT OR DELETED ** 6973C ** (KEEP IF A PRELIMINARY LIBRARY FUNCTION; ** 6974C ** DELETE IF A PRELIMINARY OPERATION--+,-,*,/,**). ** 6975C ** DELETE IF ANYTHING ELSE). ** 6976C ******************************************************* 6977C 6978 ISTEPN='1' 6979 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 6980 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 6981C 6982 ISTOM2=ISTOP-2 6983 IWIDIS=ISTOM1-ISTAP1+1 6984 IF(IWIDIS.EQ.2.AND.IW21(ISTOM2).EQ.'$ ')GOTO6300 6985 GOTO6200 6986C 6987C ****************************** 6988C ****************************** 6989C ** STEP 2-- ** 6990C ** TREAT THE NO-$ CASE. ************************************ 6991C ** THIS WILL BE THE ** 6992C ** NOT-FULLY-REDUCED CASE. ** 6993C ****************************** 6994C 6995C ************************************************* 6996C ** STEP 2.1-- ** 6997C ** CHECK FOR A PRELIMINARY LIBRARY FUNCTION. ** 6998C ************************************************* 6999C 7000 6200 CONTINUE 7001 ISTEPN='2.1' 7002 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7003 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7004C 7005 ILF='NO ' 7006 ISTAM1=ISTART-1 7007 IF(ISTAM1.LE.0)GOTO6219 7008 IF(ITYPE(ISTAM1).EQ.'LF ')ILF='YES' 7009 6219 CONTINUE 7010C 7011C ******************************* 7012C ** STEP 2.2-- ** 7013C ** COPY THE STRING BETWEEN ** 7014C ** (BUT NOT INCLUDING) THE ** 7015C ** PARENTHESES. ** 7016C ******************************* 7017C 7018 ISTEPN='2.2' 7019 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7020 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7021C 7022 J=0 7023 ITERM1(ILOOP)=IT2+1 7024 DO6220I=ISTAP1,ISTOM1 7025 J=J+1 7026 IT2=IT2+1 7027 ITER01(IT2)=IW21(I) 7028 ITER02(IT2)=IW22(I) 7029 6220 CONTINUE 7030 ITERM2(ILOOP)=IT2 7031C 7032C *************************************************** 7033C ** STEP 2.3-- ** 7034C ** TEMPORARILY COPY THE STRING WHICH IS BEYOND ** 7035C ** THE RIGHT PARENTHESIS ** 7036C ** INTO IHOLD1(.). ** 7037C *************************************************** 7038C 7039 ISTEPN='2.3' 7040 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7041 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7042 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7043 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7044C 7045 J=0 7046 ISTOP1=ISTOP+1 7047 IF(ISTOP1.GT.NW)GOTO6249 7048 DO6240I=ISTOP1,NW 7049 J=J+1 7050 IHOLD1(J)=IW21(I) 7051 IHOLD2(J)=IW22(I) 7052 IHOLDT(J)=ITYPE(I) 7053 6240 CONTINUE 7054 6249 CONTINUE 7055 NREST=J 7056C 7057C ******************************************** 7058C ** STEP 2.4-- ** 7059C ** REPLACE THE EXTRACTED STRING BY ** 7060C ** A $ AND THE LOOP NUMBER. ** 7061C ** RETAIN OR DELETE PARENTHESES ** 7062C ** DEPENDING ON WHETHER THE PRELIMINARY ** 7063C ** OPERATION IS A LIBRARY FUNCTION ** 7064C ** OR AN ARITHMETIC OPERATION. ** 7065C ******************************************** 7066C 7067 ISTEPN='2.4' 7068 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7069 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7070C 7071 IF(ILF.EQ.'YES')J=ISTART 7072 IF(ILF.EQ.'NO ')J=ISTART-1 7073 J=J+1 7074 IW21(J)='$ ' 7075 IW22(J)=' ' 7076 ITYPE(J)='E ' 7077 J=J+1 7078 CALL DPC4IH(ILOOP,IW21(J),IBUGA3,IERROR) 7079 IW22(J)=' ' 7080 ITYPE(J)='E ' 7081 IF(ILF.EQ.'YES')J=J+1 7082 IF(ILF.EQ.'YES')IW21(J)=') ' 7083 IF(ILF.EQ.'YES')IW22(J)=' ' 7084 IF(ILF.EQ.'YES')ITYPE(J)='RP ' 7085 IF(NREST.LE.0)GOTO6290 7086 DO6260I=1,NREST 7087 J=J+1 7088 IW21(J)=IHOLD1(I) 7089 IW22(J)=IHOLD2(I) 7090 ITYPE(J)=IHOLDT(I) 7091 6260 CONTINUE 7092 6290 CONTINUE 7093 NW=J 7094 GOTO6900 7095C 7096C **************************** 7097C ** STEP 3-- ** 7098C ** TREAT THE $ CASE. ** 7099C ** THIS WILL BE THE ** 7100C ** FULLY-REDUCED CASE. ** 7101C **************************** 7102C 7103C ************************************************* 7104C ** STEP 3.1-- ** 7105C ** CHECK FOR A PRELIMINARY LIBRARY FUNCTION. ** 7106C ************************************************* 7107C 7108 6300 CONTINUE 7109 ISTEPN='3.1' 7110 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7111 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7112C 7113 ILF='NO ' 7114 ISTAM1=ISTART-1 7115 IF(ISTAM1.LE.0)GOTO6319 7116 IF(ITYPE(ISTAM1).EQ.'LF ')ILF='YES' 7117 6319 CONTINUE 7118C 7119C ******************************************* 7120C ** STEP 3.2-- ** 7121C ** IF NO PRELIMINARY LIBRARY FUNCTION, ** 7122C ** THEN COPY THE STRING BETWEEN ** 7123C ** (BUT NOT INCLUDING) THE ** 7124C ** PARENTHESES. ** 7125C ** IF A PRELIMINARY LIBRARY FUNCTION, ** 7126C ** THEN COPY THE STRING ** 7127C ** STARTING WITH (AND INCLUDING) ** 7128C ** THE PRELIMINARY LIBRARY FUNCTION ** 7129C ** AND STOPPING WITH (AND INCLUDING) ** 7130C ** THE RIGHT PARENTHESIS. ** 7131C ******************************************* 7132C 7133 ISTEPN='3.2' 7134 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7135 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7136C 7137 IF(ILF.EQ.'YES')IMIN=ISTART-1 7138 IF(ILF.EQ.'YES')IMAX=ISTOP 7139 IF(ILF.EQ.'NO ')IMIN=ISTART+1 7140 IF(ILF.EQ.'NO ')IMAX=ISTOP-1 7141 J=0 7142 ITERM1(ILOOP)=IT2+1 7143 DO6320I=IMIN,IMAX 7144 J=J+1 7145 IT2=IT2+1 7146 ITER01(IT2)=IW21(I) 7147 ITER02(IT2)=IW22(I) 7148 6320 CONTINUE 7149 ITERM2(ILOOP)=IT2 7150C 7151C *************************************************** 7152C ** STEP 3.3-- ** 7153C ** TEMPORARILY COPY THE STRING WHICH IS BEYOND ** 7154C ** THE RIGHT PARENTHESIS ** 7155C ** INTO IHOLD1(.). ** 7156C *************************************************** 7157C 7158 ISTEPN='3.3' 7159 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7160 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7161C 7162 J=0 7163 ISTOP1=ISTOP+1 7164 IF(ISTOP1.GT.NW)GOTO6349 7165 DO6340I=ISTOP1,NW 7166 J=J+1 7167 IHOLD1(J)=IW21(I) 7168 IHOLD2(J)=IW22(I) 7169 IHOLDT(J)=ITYPE(I) 7170 6340 CONTINUE 7171 6349 CONTINUE 7172 NREST=J 7173C 7174C ******************************************** 7175C ** STEP 3.4-- ** 7176C ** REPLACE THE EXTRACTED STRING BY ** 7177C ** A $ AND THE LOOP NUMBER. ** 7178C ** RETAIN OR DELETE PARENTHESES ** 7179C ** DEPENDING ON WHETHER THE PRELIMINARY ** 7180C ** OPERATION IS A LIBRARY FUNCTION ** 7181C ** OR AN ARITHMETIC OPERATION. ** 7182C ******************************************** 7183C 7184 ISTEPN='3.4' 7185 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7186 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7187C 7188CCCCC J=IMIN-1 7189CCCCC J=J+1 7190 IF(ILF.EQ.'YES')J=ISTART-1 7191 IF(ILF.EQ.'NO ')J=ISTART 7192 IW21(J)='$ ' 7193 IW22(J)=' ' 7194 ITYPE(J)='E ' 7195 J=J+1 7196 CALL DPC4IH(ILOOP,IW21(J),IBUGA3,IERROR) 7197 IW22(J)=' ' 7198 ITYPE(J)='E ' 7199 IF(NREST.LE.0)GOTO6390 7200 DO6360I=1,NREST 7201 J=J+1 7202 IW21(J)=IHOLD1(I) 7203 IW22(J)=IHOLD2(I) 7204 ITYPE(J)=IHOLDT(I) 7205 6360 CONTINUE 7206 6390 CONTINUE 7207 NW=J 7208 GOTO6900 7209C 7210 6900 CONTINUE 7211C 7212 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'RIV0')GOTO6719 7213 WRITE(ICOUT,999) 7214 999 FORMAT(1X) 7215 CALL DPWRST('XXX','BUG ') 7216 WRITE(ICOUT,6701)ILOOP 7217 6701 FORMAT('AFTER LOOP ',I8,'-- ') 7218 CALL DPWRST('XXX','BUG ') 7219 WRITE(ICOUT,6709)NW 7220 6709 FORMAT('NW = ',I8) 7221 CALL DPWRST('XXX','BUG ') 7222 DO6700I=1,NW 7223 WRITE(ICOUT,6710)I,IW21(I),IW22(I),ITYPE(I) 7224 6710 FORMAT('I,IW21(I),IW22(I),ITYPE(I) = ',I8,2X,A4,2X,A4,2X,A4) 7225 CALL DPWRST('XXX','BUG ') 7226 6700 CONTINUE 7227 6719 CONTINUE 7228 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'RIV0')GOTO6799 7229 WRITE(ICOUT,999) 7230 CALL DPWRST('XXX','BUG ') 7231 WRITE(ICOUT,6791)ILOOP 7232 6791 FORMAT('AFTER LOOP ',I8,'-- ') 7233 CALL DPWRST('XXX','BUG ') 7234 IMIN=ITERM1(ILOOP) 7235 IMAX=ITERM2(ILOOP) 7236 NT=IMAX-IMIN+1 7237 WRITE(ICOUT,6792)ITERM1(ILOOP),ITERM2(ILOOP),NT 7238 6792 FORMAT('ITERM1(ILOOP),ITERM2(ILOOP),NT = ',3I8) 7239 CALL DPWRST('XXX','BUG ') 7240 DO6795I=IMIN,IMAX 7241 WRITE(ICOUT,6796)I,ITER01(I),ITER02(I) 7242 6796 FORMAT('I,ITER01(I),ITER02(I) = ',I8,2X,A4,2X,A4) 7243 CALL DPWRST('XXX','BUG ') 7244 6795 CONTINUE 7245 6799 CONTINUE 7246 IF(ISTART.LE.0)GOTO5900 7247 ILOOP=ILOOP+1 7248 IF(ILOOP.LE.10000)GOTO5310 7249C 7250 5900 CONTINUE 7251 NLOOP=ILOOP 7252C 7253C ************************ 7254C ** STEP 4-- ** 7255C ** TAKE DERIVATIVES ** 7256C ************************ 7257C 7258 ISTEPN='4' 7259 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7260 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7261C 7262 NWD=2 7263 ID1(1)='% ' 7264 ID2(1)=' ' 7265CCCCC ID1(2)=NLOOP 7266 CALL DPC4IH(NLOOP,ID1(2),IBUGA3,IERROR) 7267 ID2(2)=' ' 7268 IF(IBUG2.EQ.'ON')WRITE(ICOUT,710)NLOOP 7269 710 FORMAT('NLOOP = ',I8) 7270 IF(IBUG2.EQ.'ON')CALL DPWRST('XXX','BUG ') 7271C 7272 ILOOP=1 7273 7350 CONTINUE 7274 ISTEPN='7350' 7275 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7276 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7277 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7278 1WRITE(ICOUT,881)ILOOP,NWD 7279 881 FORMAT('ILOOP,NWD = ',2I8) 7280 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7281 1CALL DPWRST('XXX','BUG ') 7282 DO7400I=1,NWD 7283 I2=I 7284 IF(ID1(I).EQ.'% '.AND.ID2(I).EQ.' ')GOTO7450 7285 7400 CONTINUE 7286 ISTOP=NWD+1 7287 ISTART=0 7288 GOTO7790 7289 7450 CONTINUE 7290 ISTEPN='7450' 7291 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7292 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7293C 7294 ISTART=I2 7295 ISTOP=ISTART+1 7296CCCCC IF=ID1(ISTOP) 7297 CALL DPC4HI(ID1(ISTOP),IF,IBUGA3,IERROR) 7298 IF(IBUG2.EQ.'ON')WRITE(ICOUT,720)IF 7299 720 FORMAT('IF = ',I8) 7300 IF(IBUG2.EQ.'ON')CALL DPWRST('XXX','BUG ') 7301C 7302C ****************************************** 7303C ** STEP 4.2-- ** 7304C ** COPY OUT THE FUNCTION IN QUESTION ** 7305C ** INTO A VECTOR FROM WHICH ** 7306C ** THE DERIVATIVE WILL BE DETERMINED. ** 7307C ****************************************** 7308C 7309 ISTEPN='4.2' 7310 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7311 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7312C 7313 J=0 7314 IMIN=ITERM1(IF) 7315 IMAX=ITERM2(IF) 7316 DO740I=IMIN,IMAX 7317 J=J+1 7318 IFUN01(J)=ITER01(I) 7319 IFUN02(J)=ITER02(I) 7320 740 CONTINUE 7321 NCF0=J 7322C 7323 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'RIV0')GOTO779 7324 WRITE(ICOUT,771) 7325 771 FORMAT('***** IN THE MIDDLE OF DERIV0 (IN STEP 4.2)--') 7326 CALL DPWRST('XXX','BUG ') 7327 WRITE(ICOUT,772)ILOOP 7328 772 FORMAT(' AT THE BEGINNING OF LOOP ',I8) 7329 CALL DPWRST('XXX','BUG ') 7330 WRITE(ICOUT,773) 7331 773 FORMAT(' IMMEDIATELY PRIOR TO CALLING DERIV1--') 7332 CALL DPWRST('XXX','BUG ') 7333 WRITE(ICOUT,774)NCF0 7334 774 FORMAT('NCF0 = ',I8) 7335 CALL DPWRST('XXX','BUG ') 7336 DO775I=1,NCF0 7337 WRITE(ICOUT,776)IFUN01(I),IFUN02(I) 7338 776 FORMAT('IFUN01(I),IFUN02(I) = ',A4,2X,A4) 7339 CALL DPWRST('XXX','BUG ') 7340 775 CONTINUE 7341 779 CONTINUE 7342C 7343C ************************************ 7344C ** STEP 4.3-- ** 7345C ** DETERMINE THE DERIVATIVE ** 7346C ** OF THE FUNCTION UNDER STUDY. ** 7347C ************************************ 7348C 7349 ISTEPN='4.3' 7350 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7351 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7352C 7353 CALL DERIV1(IFUN01,IFUN02,NCF0, 7354 1IPARN1,IPARN2,NUMPAR,IVARN1,IVARN2,NUMVAR, 7355 1ICONN,NUMCON,IEXPN,NUMEXP, 7356 1IDER01,IDER02,NCD0, 7357 1IBUGA3,ISUBRO,IFOUND,IERROR) 7358C 7359 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'RIV0')GOTO789 7360 WRITE(ICOUT,783) 7361 783 FORMAT(' IMMEDIATELY AFTER CALLING DERIV1--') 7362 CALL DPWRST('XXX','BUG ') 7363 WRITE(ICOUT,784)NCD0 7364 784 FORMAT('NCD0 = ',I8) 7365 CALL DPWRST('XXX','BUG ') 7366 DO785I=1,NCD0 7367 WRITE(ICOUT,786)I,IDER01(I),IDER02(I) 7368 786 FORMAT('I,IDER01(I),IDER02(I) = ',I8,2X,A4,2X,A4) 7369 CALL DPWRST('XXX','BUG ') 7370 785 CONTINUE 7371 789 CONTINUE 7372C 7373C *************************************************** 7374C ** STEP 4.4-- ** 7375C ** TEMPORARILY COPY THE STRING WHICH IS BEYOND ** 7376C ** THE FUNCTION NUMBER ** 7377C ** INTO IHOLD1(.). ** 7378C *************************************************** 7379C 7380 ISTEPN='4.4' 7381 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7382 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7383C 7384 J=0 7385 ISTOP1=ISTOP+1 7386 IF(ISTOP1.GT.NWD)GOTO7249 7387 DO7240I=ISTOP1,NWD 7388 J=J+1 7389 IHOLD1(J)=ID1(I) 7390 IHOLD2(J)=ID2(I) 7391 7240 CONTINUE 7392 7249 CONTINUE 7393 NREST=J 7394C 7395C ***************************************************** 7396C ** STEP 4.5-- ** 7397C ** REPLACE THE % AND THE FUNCTION NUMBER ** 7398C ** (A SHORT-HAND DESIGNATION FOR THE DERIVATIVE) ** 7399C ** BY THE FUNCTION'S DERIVATIVE. ** 7400C ***************************************************** 7401C 7402 ISTEPN='4.5' 7403 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7404 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7405C 7406 J=ISTART-1 7407 J=J+1 7408 ID1(J)='( ' 7409 ID2(J)=' ' 7410 DO7270I=1,NCD0 7411 J=J+1 7412 ID1(J)=IDER01(I) 7413 ID2(J)=IDER02(I) 7414 7270 CONTINUE 7415 J=J+1 7416 ID1(J)=') ' 7417 ID2(J)=' ' 7418 IF(NREST.LE.0)GOTO7290 7419 DO7280I=1,NREST 7420 J=J+1 7421 ID1(J)=IHOLD1(I) 7422 ID2(J)=IHOLD2(I) 7423 7280 CONTINUE 7424 7290 CONTINUE 7425 NWD=J 7426C 7427 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'RIV0')GOTO799 7428 WRITE(ICOUT,792)ILOOP 7429 792 FORMAT(' AT THE END OF LOOP ',I8) 7430 CALL DPWRST('XXX','BUG ') 7431 WRITE(ICOUT,794)NWD,ISTART,ILOOP 7432 794 FORMAT('NWD,ISTART,ILOOP = ',3I8) 7433 CALL DPWRST('XXX','BUG ') 7434 DO795I=1,NWD 7435 WRITE(ICOUT,796)I,ID1(I),ID2(I) 7436 796 FORMAT('I,ID1(I),ID2(I) = ',I8,2X,A4,2X,A4) 7437 CALL DPWRST('XXX','BUG ') 7438 795 CONTINUE 7439 799 CONTINUE 7440C 7441 IF(ISTART.LE.0)GOTO7790 7442 ILOOP=ILOOP+1 7443 IF(ILOOP.LE.10000)GOTO7350 7444 7790 CONTINUE 7445 ISTEPN='7790' 7446 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7447 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7448C 7449 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'RIV0')GOTO7799 7450 WRITE(ICOUT,7792) 7451 7792 FORMAT(' AT THE END OF STEP 4 (AND 4.5)') 7452 CALL DPWRST('XXX','BUG ') 7453 WRITE(ICOUT,7794)ILOOP,NWD 7454 7794 FORMAT('ILOOP,NWD = ',2I8) 7455 CALL DPWRST('XXX','BUG ') 7456 DO7795I=1,NWD 7457 WRITE(ICOUT,7796)I,ID1(I),ID2(I) 7458 7796 FORMAT('I,ID1(I),ID2(I) = ',I8,2X,A4,2X,A4) 7459 CALL DPWRST('XXX','BUG ') 7460 7795 CONTINUE 7461 7799 CONTINUE 7462C 7463C ***************************************** 7464C ** STEP 5-- ** 7465C ** REPLACE THE FUNCTION DESIGNATIONS ** 7466C ** BY THE FUNCTIONS ** 7467C ***************************************** 7468C 7469 ILOOP=1 7470 8350 CONTINUE 7471C 7472 ISTEPN='5' 7473 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7474 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7475C 7476 DO8400I=1,NWD 7477 I2=I 7478 IF(ID1(I).EQ.'$ '.AND.ID2(I).EQ.' ')GOTO8450 7479 8400 CONTINUE 7480 ISTOP=NWD+1 7481 ISTART=0 7482 GOTO8790 7483 8450 CONTINUE 7484C 7485 ISTART=I2 7486 ISTOP=ISTART+1 7487CCCCC IF=ID1(ISTOP) 7488 CALL DPC4HI(ID1(ISTOP),IF,IBUGA3,IERROR) 7489C 7490C *************************************************** 7491C ** STEP 5.4-- ** 7492C ** TEMPORARILY COPY THE STRING WHICH IS BEYOND ** 7493C ** THE FUNCTION NUMBER ** 7494C ** INTO IHOLD1(.). ** 7495C *************************************************** 7496C 7497 ISTEPN='5.4' 7498 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7499 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7500C 7501 J=0 7502 ISTOP1=ISTOP+1 7503 IF(ISTOP1.GT.NWD)GOTO8249 7504 DO8240I=ISTOP1,NWD 7505 J=J+1 7506 IHOLD1(J)=ID1(I) 7507 IHOLD2(J)=ID2(I) 7508 8240 CONTINUE 7509 8249 CONTINUE 7510 NREST=J 7511C 7512C ************************************************* 7513C ** STEP 5.5-- ** 7514C ** REPLACE THE $ AND FUNCTION NUMBER ** 7515C ** (A SHORT-HAND DESIGNATION FOR A FUNCTION) ** 7516C ** BY THE FUNCTION. ** 7517C ************************************************* 7518C 7519 ISTEPN='5.5' 7520 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7521 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7522C 7523 J=ISTART-1 7524 J=J+1 7525 ID1(J)='( ' 7526 ID2(J)=' ' 7527 IMIN=ITERM1(IF) 7528 IMAX=ITERM2(IF) 7529 DO8270I=IMIN,IMAX 7530 J=J+1 7531 ID1(J)=ITER01(I) 7532 ID2(J)=ITER02(I) 7533 8270 CONTINUE 7534 J=J+1 7535 ID1(J)=') ' 7536 ID2(J)=' ' 7537 IF(NREST.LE.0)GOTO8290 7538 DO8280I=1,NREST 7539 J=J+1 7540 ID1(J)=IHOLD1(I) 7541 ID2(J)=IHOLD2(I) 7542 8280 CONTINUE 7543 8290 CONTINUE 7544 NWD=J 7545C 7546 IF(ISTART.LE.0)GOTO8790 7547 ILOOP=ILOOP+1 7548 IF(ILOOP.LE.10000)GOTO8350 7549C 7550 8790 CONTINUE 7551C 7552CCCCC IF(IBUG51.EQ.'OFF')GOTO8799 7553 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'RIV0')GOTO8799 7554 WRITE(ICOUT,8792) 7555 8792 FORMAT(' AT THE END OF STEP 5 (AND 5.5)') 7556 CALL DPWRST('XXX','BUG ') 7557 WRITE(ICOUT,8794)NWD 7558 8794 FORMAT('NWD = ',I8) 7559 CALL DPWRST('XXX','BUG ') 7560 DO8795I=1,NWD 7561 WRITE(ICOUT,8796)I,ID1(I),ID2(I) 7562 8796 FORMAT('I,ID1(I),ID2(I) = ',I8,2X,A4,2X,A4) 7563 CALL DPWRST('XXX','BUG ') 7564 8795 CONTINUE 7565 8799 CONTINUE 7566C 7567C ***************************************** 7568C ** STEP 6-- ** 7569C ** REPLACE THE CONSTANT DESIGNATIONS ** 7570C ** BY THE CONSTANTS ** 7571C ***************************************** 7572C 7573 ILOOP=1 7574 9350 CONTINUE 7575C 7576 ISTEPN='6' 7577 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7578 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7579C 7580 DO9400I=1,NWD 7581 I2=I 7582 IF(ID1(I).EQ.'& '.AND.ID2(I).EQ.' ')GOTO9450 7583 9400 CONTINUE 7584 ISTOP=NWD+1 7585 ISTART=0 7586 GOTO9790 7587 9450 CONTINUE 7588C 7589 ISTART=I2 7590 ISTOP=ISTART+1 7591 CALL DPC4HI(ID1(ISTOP),IC,IBUGA3,IERROR) 7592C 7593C *************************************************** 7594C ** STEP 6.4-- ** 7595C ** TEMPORARILY COPY THE STRING WHICH IS BEYOND ** 7596C ** THE CONSTANT NUMBER ** 7597C ** INTO IHOLD1(.). ** 7598C *************************************************** 7599C 7600 ISTEPN='6.4' 7601 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7602 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7603C 7604 J=0 7605 ISTOP1=ISTOP+1 7606 IF(ISTOP1.GT.NWD)GOTO9249 7607 DO9240I=ISTOP1,NWD 7608 J=J+1 7609 IHOLD1(J)=ID1(I) 7610 IHOLD2(J)=ID2(I) 7611 9240 CONTINUE 7612 9249 CONTINUE 7613 NREST=J 7614C 7615C ************************************************* 7616C ** STEP 6.5-- ** 7617C ** REPLACE THE & AND CONSTANT NUMBER ** 7618C ** (A SHORT-HAND DESIGNATION FOR A CONSTANT) ** 7619C ** BY THE CONSTANT. ** 7620C ************************************************* 7621C 7622 ISTEPN='6.5' 7623 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7624 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7625 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7626 1WRITE(ICOUT,9261)IC,ICON1(IC),ICON2(IC) 7627 9261 FORMAT('IC,ICON1(IC),ICON2(IC) = ',3I8) 7628 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV0') 7629 1CALL DPWRST('XXX','BUG ') 7630C 7631 J=ISTART-1 7632 IMIN=ICON1(IC) 7633 IMAX=ICON2(IC) 7634 DO9270I=IMIN,IMAX 7635 J=J+1 7636 ID1(J)=ICON(I) 7637 ID2(J)=' ' 7638 9270 CONTINUE 7639 IF(NREST.LE.0)GOTO9290 7640 DO9280I=1,NREST 7641 J=J+1 7642 ID1(J)=IHOLD1(I) 7643 ID2(J)=IHOLD2(I) 7644 9280 CONTINUE 7645 9290 CONTINUE 7646 NWD=J 7647C 7648 IF(ISTART.LE.0)GOTO9790 7649 ILOOP=ILOOP+1 7650 IF(ILOOP.LE.10000)GOTO9350 7651 9790 CONTINUE 7652C 7653C **************** 7654C ** STEP 90-- ** 7655C ** EXIT. ** 7656C **************** 7657C 7658 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RIV0')THEN 7659 WRITE(ICOUT,999) 7660 CALL DPWRST('XXX','BUG ') 7661 WRITE(ICOUT,9011) 7662 9011 FORMAT('***** AT THE END OF DERIV0--') 7663 CALL DPWRST('XXX','BUG ') 7664 WRITE(ICOUT,9012)NWD 7665 9012 FORMAT('NWD = ',I8) 7666 CALL DPWRST('XXX','BUG ') 7667 DO9015I=1,NWD 7668 WRITE(ICOUT,9016)I,ID1(I),ID2(I) 7669 9016 FORMAT('I,ID1(I),ID2(I) = ',I8,2X,A4,2X,A4) 7670 CALL DPWRST('XXX','BUG ') 7671 9015 CONTINUE 7672 ENDIF 7673C 7674 RETURN 7675 END 7676 SUBROUTINE DERIV1(IFUN01,IFUN02,NCF0, 7677 1 IPARN1,IPARN2,NUMPAR,IVARN1,IVARN2,NUMVAR, 7678 1 ICONN,NUMCON,IEXPN,NEXP, 7679 1 IDER01,IDER02,NCD0, 7680 1 IBUGA3,ISUBRO,IFOUND,IERROR) 7681C 7682C PURPOSE--DETERMINE THE DERIVATIVE OF AN 7683C EXPRESSION WHICH HAS NO PARENTHESES 7684C UNLESS THEY ARE AFTER A 7685C LIBRARY FUNCTION, AND WHICH 7686C MAY HAVE +, -, *, /, **). 7687C 7688C THE INPUT EXPRESSION IS IN THE 7689C VECTOR IFUN01(.) (FOR FIRST 4 CHARACTERS) AND 7690C VECTOR IFUN02(.) (FOR NEXT 4 CHARACTERS)--IT HAS 7691C LENGTH (= NUMBER OF CHARACTERS) NCF. 7692C 7693C THE OUTPUT EXPRESSION WILL BE IN 7694C VECTOR IDER01(.) (FOR FIRST 4 CHARACTERS) AND 7695C VECTOR IDER02(.) (FOR NEXT 4 CHARACTERS)--IT HAS 7696C HAVE LENGTH (= NUMBER OF CHARACTERS) NCD. 7697C 7698C INPUT ARGUMENTS--IFUN01 = THE VECTOR 7699C WHICH CONTAINS THE EXPRESSION 7700C OF INTEREST 7701C (FIRST 4 CHARACTERS). 7702C --IFUN02 = THE VECTOR 7703C WHICH CONTAINS THE EXPRESSION 7704C OF INTEREST 7705C (NEXT 4 CHARACTERS). 7706C --NCF0 = AN INTEGER NUMBER 7707C OF CHARACTERS IN IFUN01. 7708C OUTPUT ARGUMENTS--IDER01 = THE VECTOR 7709C WHICH CONTAINS THE DERIVATIVE 7710C OF THE EXPRESSION OF INTEREST 7711C (FIRST 4 CHARACTERS). 7712C --IDER02 = THE VECTOR 7713C WHICH CONTAINS THE DERIVATIVE 7714C OF THE EXPRESSION OF INTEREST 7715C (NEXT 4 CHARACTERS). 7716C --NCD0 = AN INTEGER NUMBER 7717C OF CHARACTERS IN IDER01. 7718C 7719C ORIGINAL VERSION--DECEMBER 8, 1978 7720C UPDATED --DECEMBER 1981. 7721C 7722C--------------------------------------------------------------------- 7723C 7724 CHARACTER*4 IFUN01 7725 CHARACTER*4 IFUN02 7726 CHARACTER*4 IPARN1 7727 CHARACTER*4 IPARN2 7728 CHARACTER*4 IVARN1 7729 CHARACTER*4 IVARN2 7730 CHARACTER*4 ICONN 7731 CHARACTER*4 IEXPN 7732 CHARACTER*4 IDER01 7733 CHARACTER*4 IDER02 7734 CHARACTER*4 IBUGA3 7735 CHARACTER*4 ISUBRO 7736 CHARACTER*4 IFOUND 7737 CHARACTER*4 IERROR 7738C 7739CCCCC CHARACTER*4 IBUG1 7740CCCCC CHARACTER*4 IBUG2 7741CCCCC CHARACTER*4 IBUG3 7742C 7743 CHARACTER*4 ISTEPN 7744 CHARACTER*4 ISUBN1 7745 CHARACTER*4 ISUBN2 7746C 7747 CHARACTER*4 IFUN11 7748 CHARACTER*4 IFUN12 7749 CHARACTER*4 IDER11 7750 CHARACTER*4 IDER12 7751C 7752 DIMENSION IFUN01(*) 7753 DIMENSION IFUN02(*) 7754 DIMENSION IDER01(*) 7755 DIMENSION IDER02(*) 7756C 7757 DIMENSION IPARN1(*) 7758 DIMENSION IPARN2(*) 7759 DIMENSION IVARN1(*) 7760 DIMENSION IVARN2(*) 7761 DIMENSION ICONN(*) 7762 DIMENSION IEXPN(*) 7763 DIMENSION IFUN11(20,80) 7764 DIMENSION IFUN12(20,80) 7765 DIMENSION NCF1(20) 7766 DIMENSION IDER11(20,80) 7767 DIMENSION IDER12(20,80) 7768 DIMENSION NCD1(20) 7769C 7770C-----COMMON VARIABLES (GENERAL)----------------------------------------------- 7771C 7772 INCLUDE 'DPCOP2.INC' 7773C 7774C-----DATA STATEMENTS----------------------------------------------------- 7775C 7776CCCCC DATA IBUG1/'OFF'/ 7777CCCCC DATA IBUG2/'OFF'/ 7778CCCCC DATA IBUG3/'OFF'/ 7779C 7780C-----START POINT----------------------------------------------------- 7781C 7782 ISUBN1='DERI' 7783 ISUBN2='V1 ' 7784C 7785 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RIV1')THEN 7786 WRITE(ICOUT,999) 7787 999 FORMAT(1X) 7788 CALL DPWRST('XXX','BUG ') 7789 WRITE(ICOUT,51) 7790 51 FORMAT('AT THE BEGINNING OF DERIV1--') 7791 CALL DPWRST('XXX','BUG ') 7792 WRITE(ICOUT,52)NCF0,NEXP 7793 52 FORMAT('NCF0,NEXP = ',2I8) 7794 CALL DPWRST('XXX','BUG ') 7795 DO55I=1,NCF0 7796 WRITE(ICOUT,56)I,IFUN01(I),IFUN02(I) 7797 56 FORMAT('I,IFUN01(I),IFUN02(I) = ',I8,2(2X,A4)) 7798 CALL DPWRST('XXX','BUG ') 7799 55 CONTINUE 7800 ENDIF 7801C 7802C ******************************************************** 7803C ** STEP 2-- ** 7804C ** EXTRACT EACH ADDITIVE SUBSTRING FROM IFUN01(.). ** 7805C ** A SUBSTRING IS ADDITIVE IF SEPARATED ** 7806C ** FROM OTHER SUBSTRINGS BY A + OR - . ** 7807C ** PLACE THE I-TH SUBSTRING IN ROW I OF IFUN11(.,.). ** 7808C ** DETERMINE THE NUMBER OF CHARACTERS IN ** 7809C ** EACH SUBSTRING. THE NUMBER OF CHARACTERS ** 7810C ** IN THE I-TH SUBSTRING WILL BE PLACED ** 7811C ** IN NCF1(I). ** 7812C ** DETERMINE THE TOTAL NUMBER OF SUBSTRINGS. ** 7813C ** THIS NUMBER WILL BE PLACED IN NFUN1. ** 7814C ******************************************************** 7815C 7816 ISTEPN='2' 7817 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV1') 7818 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7819C 7820 NFUN1=0 7821 JMIN=1 7822 DO400I=1,NCF0 7823 I2=I 7824 IF(IFUN01(I).EQ.'+ '.AND.IFUN02(I).EQ.' ')GOTO420 7825 IF(IFUN01(I).EQ.'- '.AND.IFUN02(I).EQ.' ')GOTO420 7826 GOTO400 7827 420 CONTINUE 7828C 7829 JMAX=I2-1 7830 IF(JMAX.LT.JMIN)GOTO400 7831C 7832 NFUN1=NFUN1+1 7833 K=0 7834 IF(IFUN01(JMIN).EQ.'+ '.AND.IFUN02(JMIN).EQ.' ')GOTO440 7835 IF(IFUN01(JMIN).EQ.'- '.AND.IFUN02(JMIN).EQ.' ')GOTO440 7836 K=K+1 7837 IFUN11(NFUN1,K)='+ ' 7838 IFUN12(NFUN1,K)=' ' 7839 440 CONTINUE 7840C 7841 DO450J=JMIN,JMAX 7842 K=K+1 7843 IFUN11(NFUN1,K)=IFUN01(J) 7844 IFUN12(NFUN1,K)=IFUN02(J) 7845 450 CONTINUE 7846 NCF1(NFUN1)=K 7847 JMIN=I 7848 400 CONTINUE 7849C 7850 JMAX=NCF0 7851 NFUN1=NFUN1+1 7852 K=0 7853 IF(IFUN01(JMIN).EQ.'+ '.AND.IFUN02(JMIN).EQ.' ')GOTO540 7854 IF(IFUN01(JMIN).EQ.'- '.AND.IFUN02(JMIN).EQ.' ')GOTO540 7855 K=K+1 7856 IFUN11(NFUN1,K)='+ ' 7857 IFUN12(NFUN1,K)=' ' 7858 540 CONTINUE 7859C 7860 DO550J=JMIN,JMAX 7861 K=K+1 7862 IFUN11(NFUN1,K)=IFUN01(J) 7863 IFUN12(NFUN1,K)=IFUN02(J) 7864 550 CONTINUE 7865 NCF1(NFUN1)=K 7866C 7867 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'RIV1')GOTO790 7868 WRITE(ICOUT,999) 7869 CALL DPWRST('XXX','BUG ') 7870 WRITE(ICOUT,701) 7871 701 FORMAT('IN THE MIDDLE OF DERIV1--') 7872 CALL DPWRST('XXX','BUG ') 7873 WRITE(ICOUT,702)NCD0 7874 702 FORMAT('NCD0 = ',I8) 7875 CALL DPWRST('XXX','BUG ') 7876 DO705I=1,NCD0 7877 WRITE(ICOUT,706)I,IDER01(I),IDER02(I) 7878 706 FORMAT('I,IDER01(I),IDER02(I) = ',I8,2X,A4,2X,A4) 7879 CALL DPWRST('XXX','BUG ') 7880 705 CONTINUE 7881 WRITE(ICOUT,999) 7882 CALL DPWRST('XXX','BUG ') 7883 WRITE(ICOUT,709)NFUN1 7884 709 FORMAT('NFUN1 = ',I8) 7885 CALL DPWRST('XXX','BUG ') 7886 DO710IF1=1,NFUN1 7887 WRITE(ICOUT,999) 7888 CALL DPWRST('XXX','BUG ') 7889 WRITE(ICOUT,712)IF1 7890 712 FORMAT('IF1 = ',I8) 7891 CALL DPWRST('XXX','BUG ') 7892 WRITE(ICOUT,713)NCD1(IF1) 7893 713 FORMAT('NCD1(IF1) = ',I8) 7894 CALL DPWRST('XXX','BUG ') 7895 JMAX=NCD1(IF1) 7896 DO715J=1,JMAX 7897 WRITE(ICOUT,716)J,IDER11(IF1,J),IDER12(IF1,J) 7898 716 FORMAT('J,IDER11(IF1,J),IDER12(IF1,J) = ',I8,2X,A4,2X,A4) 7899 CALL DPWRST('XXX','BUG ') 7900 715 CONTINUE 7901 710 CONTINUE 7902 790 CONTINUE 7903C 7904C ************************************************* 7905C ** STEP 3-- ** 7906C ** OPERATE ON EACH ADDITIVE COMPONENT ** 7907C ** DETERMINE THE DERIVATIVE OF EACH ADDITIVE ** 7908C ** COMPONENT. ** 7909C ************************************************* 7910C 7911 DO1000IROW1=1,NFUN1 7912C 7913 ISTEPN='3' 7914 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV1') 7915 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7916C 7917 CALL DERIV2(IFUN11,IFUN12,NCF1,IROW1, 7918 1IPARN1,IPARN2,NUMPAR,IVARN1,IVARN2,NUMVAR, 7919 1ICONN,NUMCON,IEXPN,NUMEXP,IDER11,IDER12,NCD1, 7920 1IBUGA3,ISUBRO,IFOUND,IERROR) 7921 1000 CONTINUE 7922C 7923C *************************************** 7924C ** STEP 4-- ** 7925C ** COMBINE EACH ADDITIVE COMPONENT ** 7926C ** INTO ONE LONG STRING ** 7927C ** SO AS TO FORM THE DERIVATIVE ** 7928C ** FOR THE ENTIRE EXPRESSION. ** 7929C *************************************** 7930C 7931 ISTEPN='4' 7932 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV1') 7933 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 7934C 7935 K=0 7936 DO2000IROW1=1,NFUN1 7937 JMAX=NCD1(IROW1) 7938 IF(JMAX.LE.0)GOTO2000 7939 IF(JMAX.EQ.1.AND. 7940 1IDER11(IROW1,1).EQ.'0 '.AND.IDER12(IROW1,1).EQ.' ')GOTO2000 7941 DO2100J=1,JMAX 7942 K=K+1 7943 IDER01(K)=IDER11(IROW1,J) 7944 IDER02(K)=IDER12(IROW1,J) 7945 2100 CONTINUE 7946 IF(IROW1.EQ.NFUN1)GOTO2000 7947 K=K+1 7948 IDER01(K)='+ ' 7949 IDER02(K)=' ' 7950 2000 CONTINUE 7951 IF(K.GE.1.AND. 7952 1IDER01(K).EQ.'+ '.AND.IDER02(K).EQ.' ')K=K-1 7953 IF(K.LE.0)GOTO2150 7954 GOTO2190 7955 2150 CONTINUE 7956 K=1 7957 IDER01(K)='0 ' 7958 IDER02(K)=' ' 7959 2190 CONTINUE 7960 NCD0=K 7961C 7962C ***************** 7963C ** STEP 90-- ** 7964C ** EXIT. ** 7965C ***************** 7966C 7967 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RIV1')THEN 7968 WRITE(ICOUT,999) 7969 CALL DPWRST('XXX','BUG ') 7970 WRITE(ICOUT,9011) 7971 9011 FORMAT('AT THE END OF DERIV1--') 7972 CALL DPWRST('XXX','BUG ') 7973 WRITE(ICOUT,9012)NFUN1,IF1,NCD1(IF1),NCD0 7974 9012 FORMAT('NFUN1,IF1,NCD1(IF1),NCD0 = ',4I8) 7975 CALL DPWRST('XXX','BUG ') 7976 DO9015IF1=1,NFUN1 7977 WRITE(ICOUT,999) 7978 CALL DPWRST('XXX','BUG ') 7979 JMAX=NCD1(IF1) 7980 DO9020J=1,JMAX 7981 WRITE(ICOUT,9021)J,IDER11(IF1,J),IDER12(IF1,J) 7982 9021 FORMAT('J,IDER11(IF1,J),IDER12(IF1,J) = ',I8,2(2X,A4)) 7983 CALL DPWRST('XXX','BUG ') 7984 9020 CONTINUE 7985 9015 CONTINUE 7986 WRITE(ICOUT,999) 7987 CALL DPWRST('XXX','BUG ') 7988 DO9035I=1,NCD0 7989 WRITE(ICOUT,9036)I,IDER01(I),IDER02(I) 7990 9036 FORMAT('I,IDER01(I),IDER02(I) = ',I8,2(2X,A4)) 7991 CALL DPWRST('XXX','BUG ') 7992 9035 CONTINUE 7993 ENDIF 7994C 7995 RETURN 7996 END 7997 SUBROUTINE DERIV2(IFUN11,IFUN12,NCF1,IROW1, 7998 1IPARN1,IPARN2,NUMPAR,IVARN1,IVARN2,NUMVAR, 7999 1ICONN,NUMCON,IEXPN,NUMEXP,IDER11,IDER12,NCD1, 8000 1IBUGA3,ISUBRO,IFOUND,IERROR) 8001C 8002C PURPOSE--DETERMINE THE DERIVATIVE OF 8003C A MULTIPLICATIVE EXPRESSION 8004C (= 1 FULL ADDITIVE COMPONENT) 8005C (EXAMPLE, A*X/C*D**E*X) 8006C 8007C THE ENTIRE INPUT EXPRESSION IS LOCATED 8008C IN ROW IROW1 OF IFUN11-- 8009C IT HAS LENGTH NF1 8010C 8011C THE OUTPUT DERIVATIVE IS LOCATED 8012C IN ROW IROW1 OF IFUN11-- 8013C IT HAS LENGTH NCD1. 8014C 8015C INPUT ARGUMENTS--IFUN11 = THE ARRAY WHOSE IROW1-TH ROW 8016C IS THE IROW1-TH ADDITIVE COMPONENT 8017C OF INTEREST 8018C (FIRST 4 CHARACTERS). 8019C --IFUN12 = THE ARRAY WHOSE IROW1-TH ROW 8020C IS THE IROW1-TH ADDITIVE COMPONENT 8021C OF INTEREST 8022C (NEXT 4 CHARACTERS). 8023C --NCF1 = AN INTEGER VECTOR 8024C WHOSE IROW1-TH ELEMENT 8025C IS THE LENGTH OF THE IROW1-TH 8026C STRING IN IFUN11(.,.); 8027C THAT IS, NCF1(IROW1) = THE LENGTH OF THE 8028C ADDITIVE COMPONENT OF INTEREST. 8029C --IROW1 = THE ROW NUMBER (IN IFUN11(.,.)) OF 8030C THE PARTICULAR 8031C ADDITIVE COMPONENT OF INTEREST. 8032C --IPARN1 = THE HOLLARITH VECTOR 8033C OF PARAMETER NAMES 8034C (FIRST 4 CHARACTERS). 8035C --IPARN2 = THE HOLLARITH VECTOR 8036C OF PARAMETER NAMES 8037C (NEXT 4 CHARACTERS). 8038C --NUMPAR = THE INTEGER NUMBER 8039C OF PARAMETERS. 8040C --IVARN1 = THE HOLLARITH VECTOR 8041C OF VARIABLE NAMES 8042C (FIRST 4 CHARACTERS). 8043C --IVARN2 = THE HOLLARITH VECTOR 8044C OF VARIABLE NAMES 8045C (NEXT 4 CHARACTERS). 8046C --NUMVAR = THE INTEGER NUMBER 8047C OF VARIABLE NAMES. 8048C --ICONN = THE HOLLARITH VECTOR 8049C OF CONSTANT NAMES. 8050C --NUMCON = THE INTEGER NUMBER 8051C OF CONSTANTS. 8052C --IEXPN = THE HOLLARITH VECTOR 8053C OF EXPRESSION NAMES. 8054C --NUMEXP = THE INTEGER NUMBER 8055C OF EXPRESSION NAMES. 8056C OUTPUT ARGUMENTS--IDER11 = THE ARRAY WHOSE IROW1-TH R 8057C WILL BE THE DERIVATIVE OF THE 8058C IROW1-TH ADDITIVE STRING 8059C (FIRST 4 CHARACTERS). 8060C --IDER12 = THE ARRAY WHOSE IROW1-TH R 8061C WILL BE THE DERIVATIVE OF THE 8062C IROW1-TH ADDITIVE STRING 8063C (NEXT 4 CHARACTERS). 8064C NCD1 = AN INTEGER VECTOR 8065C WHOSE IROW1-TH ELEMENT 8066C WILL BE THE LENGTH OF THE IROW1-TH 8067C DERIVATIVE IN IDER1(.,.); 8068C THAT IS, NCD1(IROW1) = THE LENGTH OF THE 8069C DERIVATIVE OF INTEREST. 8070C INTERNAL ARRAYS-- 8071C --IFUN21 = THE ARRAY WHOSE I-TH 8072C ROW WILL BE THE I-TH MULTIPLICATIVE 8073C SUBSTRING OF THE IROW1-TH 8074C ADDITIVE COMPONENT 8075C (FIRST 4 CHARACTERS). 8076C --IFUN22 = THE ARRAY WHOSE I-TH 8077C ROW WILL BE THE I-TH MULTIPLICATIVE 8078C SUBSTRING OF THE IROW1-TH 8079C ADDITIVE COMPONENT 8080C (NEXT 4 CHARACTERS). 8081C NCF2 = AN INTEGER VECTOR 8082C WHOSE I-TH ELEMENT 8083C WILL BE THE LENGTH OF THE I-TH 8084C MULTIPLICATIVE SUBSTRING 8085C OF THE IROW1-TH ADDITIVE COMPONENT. 8086C NFUN2 = THE NUMBER OF ROWS 8087C (= THE NUMBER OF MULTIPLICATIVE 8088C SUBSTRINGS OF THE IROW1-TH 8089C ADDITIVE COMPONENT) 8090C THAT WILL BE 8091C IN THE ARRAY IFUN21(.,.) 8092C IOP2 = A VECTOR 8093C WHOSE I-TH ELEMENT 8094C WILL BE THE (TRAILING) OPERATION (* OR /) 8095C OF THE I-TH MULTIPLICATIVE SUBSTRING 8096C OF THE IROW1-TH ADDITIVE COMPONENT. 8097C 8098C ORIGINAL VERSION--DECEMBER 2, 1978 8099C UPDATED --DECEMBER 1981. 8100C 8101C--------------------------------------------------------------------- 8102C 8103 CHARACTER*4 IFUN11 8104 CHARACTER*4 IFUN12 8105 CHARACTER*4 IPARN1 8106 CHARACTER*4 IPARN2 8107 CHARACTER*4 IVARN1 8108 CHARACTER*4 IVARN2 8109 CHARACTER*4 ICONN 8110 CHARACTER*4 IEXPN 8111 CHARACTER*4 IDER11 8112 CHARACTER*4 IDER12 8113 CHARACTER*4 IBUGA3 8114 CHARACTER*4 ISUBRO 8115 CHARACTER*4 IFOUND 8116 CHARACTER*4 IERROR 8117C 8118 CHARACTER*4 ISTEPN 8119 CHARACTER*4 ISUBN1 8120 CHARACTER*4 ISUBN2 8121C 8122 CHARACTER*4 IFUN21 8123 CHARACTER*4 IFUN22 8124 CHARACTER*4 IDER21 8125 CHARACTER*4 IDER22 8126 CHARACTER*4 IOP2 8127C 8128CCCCC CHARACTER*4 IBUG1 8129CCCCC CHARACTER*4 IBUG2 8130CCCCC CHARACTER*4 IBUG3 8131C 8132 DIMENSION IFUN11(20,80) 8133 DIMENSION IFUN12(20,80) 8134 DIMENSION NCF1(*) 8135 DIMENSION IPARN1(*) 8136 DIMENSION IPARN2(*) 8137 DIMENSION IVARN1(*) 8138 DIMENSION IVARN2(*) 8139 DIMENSION ICONN(*) 8140 DIMENSION IEXPN(*) 8141 DIMENSION IDER11(20,80) 8142 DIMENSION IDER12(20,80) 8143 DIMENSION NCD1(*) 8144C 8145 DIMENSION IFUN21(20,80) 8146 DIMENSION IFUN22(20,80) 8147 DIMENSION NCF2(20) 8148 DIMENSION IDER21(20,80) 8149 DIMENSION IDER22(20,80) 8150 DIMENSION NCD2(20) 8151 DIMENSION IOP2(20) 8152C 8153C-----COMMON VARIABLES (GENERAL)----------------------------------------------- 8154C 8155 INCLUDE 'DPCOP2.INC' 8156C 8157C-----DATA STATEMENTS----------------------------------------------------- 8158C 8159CCCCC DATA IBUG1/'OFF'/ 8160CCCCC DATA IBUG2/'OFF'/ 8161CCCCC DATA IBUG3/'OFF'/ 8162C 8163C-----START POINT----------------------------------------------------- 8164C 8165 ISUBN1='DERI' 8166 ISUBN2='V2 ' 8167 IERROR='NO' 8168C 8169 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'RIV2')GOTO90 8170 WRITE(ICOUT,999) 8171 999 FORMAT(1X) 8172 CALL DPWRST('XXX','BUG ') 8173 WRITE(ICOUT,51) 8174 51 FORMAT('AT THE BEGINNING OF DERIV2--') 8175 CALL DPWRST('XXX','BUG ') 8176 WRITE(ICOUT,52)IBUGA3,IFOUND,IERROR 8177 52 FORMAT('IBUGA3,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 8178 CALL DPWRST('XXX','BUG ') 8179 WRITE(ICOUT,53)IROW1 8180 53 FORMAT('IROW1 = ',I8) 8181 CALL DPWRST('XXX','BUG ') 8182 WRITE(ICOUT,54)NCF1(IROW1) 8183 54 FORMAT('NCF1(IROW1) = ',I8) 8184 CALL DPWRST('XXX','BUG ') 8185 ITEMP=NCF1(IROW1) 8186 DO61J=1,ITEMP 8187 WRITE(ICOUT,62)J,IFUN11(IROW1,J),IFUN12(IROW1,J) 8188 62 FORMAT('J,IFUN11(IROW1,J),IFUN12(IROW1,J) = ',I8,2X,A4,2X,A4) 8189 CALL DPWRST('XXX','BUG ') 8190 61 CONTINUE 8191 90 CONTINUE 8192C 8193C ******************************************************** 8194C ** STEP 1-- ** 8195C ** EXTRACT EACH MULTIPLICATIVE SUBSTRING. ** 8196C ** A SUBSTRING IS MULTIPLICATIVE IF SEPARATED ** 8197C ** FROM OTHER SUBSTRINGS BY A * OR / . ** 8198C ** PLACE THE I-TH SUBSTRING IN ROW I OF IFUN21(.,.). ** 8199C ** DETERMINE THE NUMBER OF CHARACTERS IN ** 8200C ** EACH SUBSTRING. THE NUMBER OF CHARACTERS ** 8201C ** IN THE I-TH SUBSTRING WILL BE PLACED ** 8202C ** IN NCF2(I). ** 8203C ** DETERMINE THE TOTAL NUMBER OF SUBSTRINGS. ** 8204C ** THIS NUMBER WILL BE PLACED IN NFUN2. ** 8205C ******************************************************** 8206C 8207 ISTEPN='1' 8208 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV2') 8209 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8210C 8211 NFUN2=0 8212 JMIN=1 8213 IMIN=1 8214 IMAX=NCF1(IROW1) 8215 DO400I=IMIN,IMAX 8216 IF(IFUN11(IROW1,I).EQ.'* '.AND.IFUN12(IROW1,I).EQ.' ')GOTO420 8217 IF(IFUN11(IROW1,I).EQ.'/ '.AND.IFUN12(IROW1,I).EQ.' ')GOTO420 8218 GOTO400 8219 420 CONTINUE 8220C 8221 JMAX=I-1 8222 IF(JMAX.LT.JMIN)GOTO430 8223 GOTO440 8224 430 CONTINUE 8225C 8226 WRITE(ICOUT,431) 8227 431 FORMAT('*****ERROR IN DERIV2--') 8228 CALL DPWRST('XXX','BUG ') 8229 WRITE(ICOUT,432) 8230 432 FORMAT('JMAX GREATER THAN JMIN') 8231 CALL DPWRST('XXX','BUG ') 8232 WRITE(ICOUT,433)JMIN,JMAX 8233 433 FORMAT('JMIN,JMAX = ',2I8) 8234 CALL DPWRST('XXX','BUG ') 8235 IERROR='YES' 8236 GOTO9000 8237 440 CONTINUE 8238C 8239 NFUN2=NFUN2+1 8240 K=0 8241 DO450J=JMIN,JMAX 8242 K=K+1 8243 IFUN21(NFUN2,K)=IFUN11(IROW1,J) 8244 IFUN22(NFUN2,K)=IFUN12(IROW1,J) 8245 450 CONTINUE 8246 NCF2(NFUN2)=K 8247 IOP2(NFUN2)=IFUN11(IROW1,I) 8248 JMIN=I+1 8249 400 CONTINUE 8250C 8251 JMAX=IMAX 8252 IF(JMAX.LT.JMIN)GOTO530 8253 GOTO540 8254 530 CONTINUE 8255C 8256 WRITE(ICOUT,531) 8257 531 FORMAT('*****ERROR IN DERIV2--') 8258 CALL DPWRST('XXX','BUG ') 8259 WRITE(ICOUT,532) 8260 532 FORMAT('JMAX GREATER THAN JMIN') 8261 CALL DPWRST('XXX','BUG ') 8262 WRITE(ICOUT,533)JMIN,JMAX 8263 533 FORMAT('JMIN,JMAX = ',2I8) 8264 CALL DPWRST('XXX','BUG ') 8265 IERROR='YES' 8266 GOTO9000 8267 540 CONTINUE 8268C 8269 NFUN2=NFUN2+1 8270 K=0 8271 DO550J=JMIN,JMAX 8272 K=K+1 8273 IFUN21(NFUN2,K)=IFUN11(IROW1,J) 8274 IFUN22(NFUN2,K)=IFUN12(IROW1,J) 8275 550 CONTINUE 8276 NCF2(NFUN2)=K 8277C 8278 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'RIV2')GOTO690 8279 WRITE(ICOUT,999) 8280 CALL DPWRST('XXX','BUG ') 8281 WRITE(ICOUT,601) 8282 601 FORMAT('AFTER STEP 1 OF DERIV2--') 8283 CALL DPWRST('XXX','BUG ') 8284 WRITE(ICOUT,610)NFUN2 8285 610 FORMAT('NFUN2 = ',I8) 8286 CALL DPWRST('XXX','BUG ') 8287 DO615I=1,NFUN2 8288 WRITE(ICOUT,999) 8289 CALL DPWRST('XXX','BUG ') 8290 WRITE(ICOUT,616)I 8291 616 FORMAT('I = ',I8) 8292 CALL DPWRST('XXX','BUG ') 8293 WRITE(ICOUT,617)NCF2(I) 8294 617 FORMAT('NCF2(I) = ',I8) 8295 CALL DPWRST('XXX','BUG ') 8296 ITEMP=NCF2(I) 8297 DO620J=1,ITEMP 8298 WRITE(ICOUT,621)I,J,IFUN21(I,J),IFUN22(I,J) 8299 621 FORMAT('I,J,IFUN21(I,J),IFUN22(I,J) = ',I8,I8,2X,A4,2X,A4) 8300 CALL DPWRST('XXX','BUG ') 8301 620 CONTINUE 8302 615 CONTINUE 8303 690 CONTINUE 8304C 8305C ******************************************************* 8306C ** STEP 2-- ** 8307C ** OPERATE ON EACH MULTIPLICATIVE COMPONENT. ** 8308C ** DETERMINE THE DERIVATIVE OF EACH MULTIPLICATIVE ** 8309C ** COMPONENT. ** 8310C ******************************************************* 8311C 8312 DO700IROW2=1,NFUN2 8313C 8314 ISTEPN='2' 8315 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV2') 8316 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8317C 8318 CALL DERIV3(IFUN21,IFUN22,NCF2,IROW2, 8319 1IPARN1,IPARN2,NUMPAR,IVARN1,IVARN2,NUMVAR, 8320 1ICONN,NUMCON,IEXPN,NUMEXP,IDER21,IDER22,NCD2, 8321 1IBUGA3,ISUBRO,IFOUND,IERROR) 8322 700 CONTINUE 8323C 8324C **************************************** 8325C ** STEP 3-- ** 8326C ** COMBINE MULTIPLICATIVE COMPONENT ** 8327C ** DERIVATIVES TO DETERMINE THE ** 8328C ** DERIVATIVE OF THE IROW1-TH ** 8329C ** (IROW1 FIXED) ADDITIVE COMPONENT. ** 8330C **************************************** 8331C 8332 ISTEPN='4' 8333 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV2') 8334 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8335C 8336 CALL DERIV4(IFUN21,IFUN22,NCF2,NFUN2, 8337 1IDER21,IDER22,NCD2,IOP2,IROW1, 8338 1IDER11,IDER12,NCD1, 8339 1IBUGA3,ISUBRO,IFOUND,IERROR) 8340C 8341C ***************** 8342C ** STEP 90-- ** 8343C ** EXIT. ** 8344C ***************** 8345C 8346 9000 CONTINUE 8347 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'RIV2')GOTO9090 8348 WRITE(ICOUT,999) 8349 CALL DPWRST('XXX','BUG ') 8350 WRITE(ICOUT,9011) 8351 9011 FORMAT('AT THE END OF DERIV2--') 8352 CALL DPWRST('XXX','BUG ') 8353 WRITE(ICOUT,9012)IBUGA3,IFOUND,IERROR 8354 9012 FORMAT('IBUGA3,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 8355 CALL DPWRST('XXX','BUG ') 8356 WRITE(ICOUT,9013)IROW1 8357 9013 FORMAT('IROW1 = ',I8) 8358 CALL DPWRST('XXX','BUG ') 8359 WRITE(ICOUT,9014)NCD1(IROW1) 8360 9014 FORMAT('NCD1(IROW1) = ',I8) 8361 CALL DPWRST('XXX','BUG ') 8362 ITEMP=NCD1(IROW1) 8363 DO9021J=1,ITEMP 8364 WRITE(ICOUT,9022)J,IDER11(IROW1,J),IDER12(IROW1,J) 8365 9022 FORMAT('J,IDER11(IROW1,J),IDER12(IROW1,J) = ',I8,2X,A4,2X,A4) 8366 CALL DPWRST('XXX','BUG ') 8367 9021 CONTINUE 8368 9090 CONTINUE 8369C 8370 RETURN 8371 END 8372 SUBROUTINE DERIV3(IFUN21,IFUN22,NCF2,IROW2, 8373 1 IPARN1,IPARN2,NUMPAR,IVARN1,IVARN2,NUMVAR, 8374 1 ICONN,NUMCON,IEXPN,NUMEXP,IDER21,IDER22,NCD2, 8375 1 IBUGA3,ISUBRO,IFOUND,IERROR) 8376C 8377C PURPOSE--DETERMINE THE DERIVATIVE OF 8378C AN ELEMENTAL COMPONENT 8379C (EXAMPLE, X, OR X**B, OR -X, OR -X**X) 8380C WHICH IS A COMPONENT THAT HAS 8381C NO +, -, *, OR /. 8382C IT MAY HAVE ** (AS IN A**B). 8383C IT MAY HAVE A SIGN (OR NO SIGN). 8384C IT MAY BE ONLY A SINGLE ELEMENT. 8385C 8386C THE INPUT ELEMENT IS LOCATED 8387C IN ROW IROW2 OF IFUN21-- 8388C IT HAS LENGTH NF2. 8389C 8390C THE OUTPUT DERIVATIVE IS LOCATED 8391C IN ROW IROW2 OF IFUN21-- 8392C IT HAS LENGTH NCD2. 8393C 8394C INPUT ARGUMENTS--IFUN21 = THE ARRAY WHOSE IROW2-TH ROW 8395C IS THE IROW2-TH ELEMENTAL COMPONENT 8396C OF INTEREST 8397C (FIRST 4 CHARACTERS). 8398C --IFUN22 = THE ARRAY WHOSE IROW2-TH ROW 8399C IS THE IROW2-TH ELEMENTAL COMPONENT 8400C OF INTEREST 8401C (NEXT 4 CHARACTERS). 8402C --NCF2 = AN INTEGER VECTOR 8403C WHOSE IROW2-TH ELEMENT 8404C IS THE LENGTH OF THE IROW2-TH 8405C STRING IN IFUN21(.,.); 8406C THAT IS, NCF2(IROW2) = THE LENGTH OF THE 8407C ELEMENTAL COMPONENT OF INTEREST. 8408C --IROW2 = THE ROW NUMBER (IN IFUN21(.,.)) OF 8409C THE PARTICULAR 8410C ELEMENTAL COMPONENT OF INTEREST. 8411C --IPARN1 = THE HOLLARITH VECTOR 8412C OF PARAMETER NAMES 8413C (FIRST 4 CHARACTERS). 8414C --IPARN2 = THE HOLLARITH VECTOR 8415C OF PARAMETER NAMES 8416C (NEXT 4 CHARACTERS). 8417C --NUMPAR = THE INTEGER NUMBER 8418C OF PARAMETERS. 8419C --IVARN1 = THE HOLLARITH VECTOR 8420C OF VARIABLE NAMES 8421C (FIRST 4 CHARACTERS). 8422C --IVARN2 = THE HOLLARITH VECTOR 8423C OF VARIABLE NAMES 8424C (NEXT 4 CHARACTERS). 8425C --NUMVAR = THE INTEGER NUMBER 8426C OF VARIABLE NAMES. 8427C --ICONN = THE HOLLARITH VECTOR 8428C OF CONSTANT NAMES. 8429C --NUMCON = THE INTEGER NUMBER 8430C OF CONSTANTS. 8431C --IEXPN = THE HOLLARITH VECTOR 8432C OF EXPRESSION NAMES. 8433C --NUMEXP = THE INTEGER NUMBER 8434C OF EXPRESSION NAMES. 8435C OUTPUT ARGUMENTS--IDER21 = THE ARRAY WHOSE IROW2-TH ROW 8436C WILL BE THE DERIVATIVE OF THE 8437C IROW2-TH ELEMENTAL STRING 8438C (FIRST 4 CHARACTERS). 8439C --IDER22 = THE ARRAY WHOSE IROW2-TH ROW 8440C WILL BE THE DERIVATIVE OF THE 8441C IROW2-TH ELEMENTAL STRING 8442C (NEXT 4 CHARACTERS). 8443C --NCD2 = AN INTEGER VECTOR 8444C WHOSE IROW2-TH ELEMENT 8445C WILL BE THE LENGTH OF THE IROW2-TH 8446C DERIVATIVE IN IDER21(.,.); 8447C THAT IS, NCD2(IROW2) = THE LENGTH OF THE 8448C DERIVATIVE OF INTEREST. 8449C 8450C DATE--DECEMBER 9, 1978 8451C 8452C--------------------------------------------------------------------- 8453C 8454 CHARACTER*4 IFUN21 8455 CHARACTER*4 IFUN22 8456 CHARACTER*4 IPARN1 8457 CHARACTER*4 IPARN2 8458 CHARACTER*4 IVARN1 8459 CHARACTER*4 IVARN2 8460 CHARACTER*4 ICONN 8461 CHARACTER*4 IEXPN 8462 CHARACTER*4 IDER21 8463 CHARACTER*4 IDER22 8464 CHARACTER*4 IBUGA3 8465 CHARACTER*4 ISUBRO 8466 CHARACTER*4 IFOUND 8467 CHARACTER*4 IERROR 8468C 8469 CHARACTER*4 IFUNZ1 8470 CHARACTER*4 IFUNZ2 8471 CHARACTER*4 IDERZ1 8472 CHARACTER*4 IDERZ2 8473C 8474CCCCC CHARACTER*4 IBUG1 8475CCCCC CHARACTER*4 IBUG2 8476CCCCC CHARACTER*4 IBUG3 8477C 8478 CHARACTER*4 ISTEPN 8479 CHARACTER*4 ISUBN1 8480 CHARACTER*4 ISUBN2 8481 CHARACTER*4 ITYPE 8482 CHARACTER*4 IMANTT 8483 CHARACTER*4 IEXPT 8484 CHARACTER*4 ISIGN1 8485 CHARACTER*4 ISIGN2 8486 CHARACTER*4 IH1 8487 CHARACTER*4 IH2 8488 CHARACTER*4 IHLF1 8489 CHARACTER*4 IHLF2 8490 CHARACTER*4 IMAN11 8491 CHARACTER*4 IMAN12 8492 CHARACTER*4 IMAN21 8493 CHARACTER*4 IMAN22 8494 CHARACTER*4 IEXP11 8495 CHARACTER*4 IEXP12 8496 CHARACTER*4 IEXP21 8497 CHARACTER*4 IEXP22 8498C 8499 CHARACTER*4 IHOL11 8500 CHARACTER*4 IHOL12 8501 CHARACTER*4 IHOL21 8502 CHARACTER*4 IHOL22 8503C 8504 DIMENSION IFUN21(20,80) 8505 DIMENSION IFUN22(20,80) 8506 DIMENSION NCF2(*) 8507 DIMENSION IPARN1(*) 8508 DIMENSION IPARN2(*) 8509 DIMENSION IVARN1(*) 8510 DIMENSION IVARN2(*) 8511 DIMENSION ICONN(*) 8512 DIMENSION IEXPN(*) 8513 DIMENSION IDER21(20,80) 8514 DIMENSION IDER22(20,80) 8515 DIMENSION NCD2(*) 8516C 8517 DIMENSION IFUNZ1(300) 8518 DIMENSION IFUNZ2(300) 8519 DIMENSION IDERZ1(300) 8520 DIMENSION IDERZ2(300) 8521C 8522C 8523C-----COMMON VARIABLES (GENERAL)----------------------------------------------- 8524C 8525 INCLUDE 'DPCOP2.INC' 8526C 8527C-----START POINT----------------------------------------------------- 8528C 8529 ISUBN1='DERI' 8530 ISUBN2='V3 ' 8531C 8532 IERROR='NO' 8533 ITYPE='NULL' 8534 IMANTT='NULL' 8535 IEXPT='NULL' 8536 ISIGN1='NULL' 8537 ISIGN2=' ' 8538 IFOUND='YES' 8539 IEXP11=' ' 8540 IEXP12=' ' 8541 IEXP21=' ' 8542 IEXP22=' ' 8543 IMAN21=' ' 8544 IMAN22=' ' 8545C 8546 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RIV3')THEN 8547 WRITE(ICOUT,999) 8548 999 FORMAT(1X) 8549 CALL DPWRST('XXX','BUG ') 8550 WRITE(ICOUT,51) 8551 51 FORMAT('AT THE BEGINNING OF DERIV3--') 8552 CALL DPWRST('XXX','BUG ') 8553 WRITE(ICOUT,52)ICONN(1),IEXPN(1),NUMCON,IROW2,NCF2(IROW2) 8554 52 FORMAT('ICONN(1),IEXPN(1),NUMCON,IROW2,NCF2(IROW2) = ', 8555 1 2(A4,2X),3I8) 8556 CALL DPWRST('XXX','BUG ') 8557 DO55J=1,NCF2(IROW2) 8558 WRITE(ICOUT,56)J,IFUN21(IROW2,J),IFUN22(IROW2,J) 8559 56 FORMAT('J,IFUN21(IROW2,J),IFUN22(IROW2,J) = ',I8,2(2X,A4)) 8560 CALL DPWRST('XXX','BUG ') 8561 55 CONTINUE 8562 WRITE(ICOUT,71)NUMPAR,NUMVAR,NUMEXP 8563 71 FORMAT('NUMPAR,NUMVAR,NUMEXP = ',3I8) 8564 CALL DPWRST('XXX','BUG ') 8565 DO62I=1,NUMPAR 8566 WRITE(ICOUT,63)I,IPARN1(I),IPARN2(I) 8567 63 FORMAT('I,IPARN1(I),IPARN2(I) = ',I8,2(2X,A4)) 8568 CALL DPWRST('XXX','BUG ') 8569 62 CONTINUE 8570 DO72I=1,NUMVAR 8571 WRITE(ICOUT,73)I,IVARN1(I),IVARN2(I) 8572 73 FORMAT('I,IVARN1(I),IVARN2(I) = ',I8,2(2X,A4)) 8573 CALL DPWRST('XXX','BUG ') 8574 72 CONTINUE 8575 ENDIF 8576C 8577C ********************************** 8578C ** STEP 1-- ** 8579C ** COPY THE EXPRESSION ** 8580C ** IN ROW IROW2 OF IFUN21(.,.) ** 8581C ** INTO THE VECTOR IFUNZ1(.). ** 8582C ********************************** 8583C 8584 ISTEPN='1' 8585 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV3') 8586 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8587C 8588 NCFZ=NCF2(IROW2) 8589 DO300I=1,NCFZ 8590 IFUNZ1(I)=IFUN21(IROW2,I) 8591 IFUNZ2(I)=IFUN22(IROW2,I) 8592 IDERZ1(I)='OOOO' 8593 IDERZ2(I)='OOOO' 8594 IDER21(IROW2,I)='OOOO' 8595 IDER22(IROW2,I)='OOOO' 8596 300 CONTINUE 8597C 8598C *************************************** 8599C ** STEP 2-- ** 8600C ** SEARCH FOR A LEFT PARENTHESIS-- ** 8601C ** THIS WILL INDICATE A PRECEDING ** 8602C ** LIBRARY FUNCTION. ** 8603C *************************************** 8604C 8605 ISTEPN='2' 8606 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV3') 8607 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8608C 8609 DO310I=1,NCFZ 8610 I1=I 8611 IF(IFUNZ1(I).EQ.'( '.AND.IFUNZ2(I).EQ.' ')GOTO320 8612 310 CONTINUE 8613 GOTO3000 8614 320 CONTINUE 8615 I1M1=I1-1 8616 I1P1=I1+1 8617 I1P2=I1+2 8618 I1P3=I1+3 8619 IHLF1=IFUNZ1(I1M1) 8620 IHLF2=IFUNZ2(I1M1) 8621 IH1=IFUNZ1(I1P1) 8622 IH2=IFUNZ2(I1P1) 8623C 8624 IF(IH1.EQ.'$ '.AND.IH2.EQ.' ')GOTO330 8625 GOTO339 8626 330 CONTINUE 8627 ITYPE='EXP ' 8628 GOTO380 8629 339 CONTINUE 8630C 8631 IF(IH1.EQ.'& '.AND.IH2.EQ.' ')GOTO340 8632 GOTO349 8633 340 CONTINUE 8634 I2=1 8635 IDERZ1(1)='0 ' 8636 IDERZ2(1)=' ' 8637 GOTO985 8638 349 CONTINUE 8639C 8640 IF(NUMPAR.LE.0)GOTO359 8641 DO350I=1,NUMPAR 8642 IF(IH1.EQ.IPARN1(I).AND.IH2.EQ.IPARN2(I))GOTO355 8643 350 CONTINUE 8644 GOTO359 8645 355 CONTINUE 8646 I2=1 8647 IDERZ1(1)='0 ' 8648 IDERZ2(1)=' ' 8649 GOTO985 8650 359 CONTINUE 8651C 8652 IF(NUMVAR.LE.0)GOTO369 8653 DO360I=1,NUMVAR 8654 IF(IH1.EQ.IVARN1(I).AND.IH2.EQ.IVARN2(I))GOTO380 8655 360 CONTINUE 8656 369 CONTINUE 8657C 8658 WRITE(ICOUT,999) 8659 CALL DPWRST('XXX','BUG ') 8660 WRITE(ICOUT,371) 8661 371 FORMAT('******ERROR IN DERIV3--') 8662 CALL DPWRST('XXX','BUG ') 8663 WRITE(ICOUT,372) 8664 372 FORMAT(' CHARACTER AFTER ( NOT A ') 8665 CALL DPWRST('XXX','BUG ') 8666 WRITE(ICOUT,373) 8667 373 FORMAT(' $ (FOR EXPRESSION), & (FOR NUMBER),') 8668 CALL DPWRST('XXX','BUG ') 8669 WRITE(ICOUT,374) 8670 374 FORMAT(' A PARAMETER, OR A VARIABLE.') 8671 CALL DPWRST('XXX','BUG ') 8672 WRITE(ICOUT,375)NCFZ 8673 375 FORMAT('NCFZ = ',I8) 8674 CALL DPWRST('XXX','BUG ') 8675 DO376I=1,NCFZ 8676 WRITE(ICOUT,377)I,IFUNZ1(I),IFUNZ2(I) 8677 377 FORMAT('I,IFUNZ1(I),IFUNZ2(I) = ',I8,2X,A4,2X,A4) 8678 CALL DPWRST('XXX','BUG ') 8679 376 CONTINUE 8680 IERROR='YES' 8681 GOTO9000 8682C 8683 380 CONTINUE 8684 I2=0 8685 IF(IFUNZ1(1).EQ.'- '.AND.IFUNZ2(I).EQ.' ')GOTO385 8686 GOTO390 8687 385 CONTINUE 8688 I2=I2+1 8689 IDERZ1(I2)='- ' 8690 IDERZ2(I2)=' ' 8691 390 CONTINUE 8692C 8693C ***************************************** 8694C ** STEP 3-- ** 8695C ** TREAT THE LIBRARY FUNCTIONS CASE. ** 8696C ***************************************** 8697C 8698 ISTEPN='3' 8699 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV3') 8700 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8701C 8702 IF(IHLF1.EQ.'SQRT'.AND.IHLF2.EQ.' ')GOTO510 8703 IF(IHLF1.EQ.'EXP '.AND.IHLF2.EQ.' ')GOTO510 8704 IF(IHLF1.EQ.'ALOG'.AND.IHLF2.EQ.' ')GOTO510 8705 IF(IHLF1.EQ.'ALOG'.AND.IHLF2.EQ.'E ')GOTO510 8706 IF(IHLF1.EQ.'ALOG'.AND.IHLF2.EQ.'10 ')GOTO510 8707 IF(IHLF1.EQ.'LOG '.AND.IHLF2.EQ.' ')GOTO510 8708 IF(IHLF1.EQ.'LOGE'.AND.IHLF2.EQ.' ')GOTO510 8709 IF(IHLF1.EQ.'LOG1'.AND.IHLF2.EQ.'0 ')GOTO510 8710C 8711 IF(IHLF1.EQ.'SIN '.AND.IHLF2.EQ.' ')GOTO610 8712 IF(IHLF1.EQ.'COS '.AND.IHLF2.EQ.' ')GOTO610 8713 IF(IHLF1.EQ.'TAN '.AND.IHLF2.EQ.' ')GOTO610 8714 IF(IHLF1.EQ.'COT '.AND.IHLF2.EQ.' ')GOTO610 8715 IF(IHLF1.EQ.'SEC '.AND.IHLF2.EQ.' ')GOTO610 8716 IF(IHLF1.EQ.'CSC '.AND.IHLF2.EQ.' ')GOTO610 8717C 8718 IF(IHLF1.EQ.'ARCS'.AND.IHLF2.EQ.'IN ')GOTO620 8719 IF(IHLF1.EQ.'ARCC'.AND.IHLF2.EQ.'OS ')GOTO620 8720 IF(IHLF1.EQ.'ARCT'.AND.IHLF2.EQ.'AN ')GOTO620 8721 IF(IHLF1.EQ.'ARCC'.AND.IHLF2.EQ.'OT ')GOTO620 8722 IF(IHLF1.EQ.'ARCS'.AND.IHLF2.EQ.'EC ')GOTO620 8723 IF(IHLF1.EQ.'ARCC'.AND.IHLF2.EQ.'SC ')GOTO620 8724C 8725 IF(IHLF1.EQ.'SINH'.AND.IHLF2.EQ.' ')GOTO630 8726 IF(IHLF1.EQ.'COSH'.AND.IHLF2.EQ.' ')GOTO630 8727 IF(IHLF1.EQ.'TANH'.AND.IHLF2.EQ.' ')GOTO630 8728 IF(IHLF1.EQ.'COTH'.AND.IHLF2.EQ.' ')GOTO630 8729 IF(IHLF1.EQ.'SECH'.AND.IHLF2.EQ.' ')GOTO630 8730 IF(IHLF1.EQ.'CSCH'.AND.IHLF2.EQ.' ')GOTO630 8731C 8732 IF(IHLF1.EQ.'ARCS'.AND.IHLF2.EQ.'INH ')GOTO640 8733 IF(IHLF1.EQ.'ARCC'.AND.IHLF2.EQ.'OSH ')GOTO640 8734 IF(IHLF1.EQ.'ARCT'.AND.IHLF2.EQ.'ANH ')GOTO640 8735 IF(IHLF1.EQ.'ARCC'.AND.IHLF2.EQ.'OTH ')GOTO640 8736 IF(IHLF1.EQ.'ARCS'.AND.IHLF2.EQ.'ECH ')GOTO640 8737 IF(IHLF1.EQ.'ARCC'.AND.IHLF2.EQ.'SCH ')GOTO640 8738C 8739 IFOUND='NO' 8740 GOTO8000 8741C 8742 510 CONTINUE 8743 CALL LIBFD1(IHLF1,IHLF2,I1,I2,ITYPE, 8744 1IFUNZ1,IFUNZ2,IDERZ1,IDERZ2) 8745 GOTO970 8746C 8747 610 CONTINUE 8748 CALL TRIGD1(IHLF1,IHLF2,I1,I2,ITYPE, 8749 1IFUNZ1,IFUNZ2,IDERZ1,IDERZ2) 8750 GOTO970 8751C 8752 620 CONTINUE 8753 CALL TRIGD2(IHLF1,IHLF2,I1,I2,ITYPE, 8754 1IFUNZ1,IFUNZ2,IDERZ1,IDERZ2) 8755 GOTO970 8756C 8757 630 CONTINUE 8758 CALL TRIGD3(IHLF1,IHLF2,I1,I2,ITYPE, 8759 1IFUNZ1,IFUNZ2,IDERZ1,IDERZ2) 8760 GOTO970 8761C 8762 640 CONTINUE 8763 CALL TRIGD4(IHLF1,IHLF2,I1,I2,ITYPE, 8764 1IFUNZ1,IFUNZ2,IDERZ1,IDERZ2) 8765 GOTO970 8766C 8767 970 CONTINUE 8768 IF(ITYPE.EQ.'EXP ')GOTO980 8769 GOTO985 8770C 8771 980 CONTINUE 8772 I2=I2+1 8773 IDERZ1(I2)='* ' 8774 IDERZ2(I2)=' ' 8775 I2=I2+1 8776 IDERZ1(I2)='% ' 8777 IDERZ2(I2)=' ' 8778 I2=I2+1 8779 IDERZ1(I2)=IFUNZ1(I1P2) 8780 IDERZ2(I2)=IFUNZ2(I1P2) 8781C 8782 985 CONTINUE 8783 NCDZ=I2 8784 IF(NCDZ.LE.2)GOTO990 8785 IF(IDERZ1(1).EQ.'- '.AND.IDERZ2(1).EQ.' '.AND. 8786 1 IDERZ1(2).EQ.'- '.AND.IDERZ2(2).EQ.' ')GOTO986 8787 IF(IDERZ1(1).EQ.'+ '.AND.IDERZ2(1).EQ.' '.AND. 8788 1 IDERZ1(2).EQ.'+ '.AND.IDERZ2(2).EQ.' ')GOTO986 8789 IF(IDERZ1(1).EQ.'- '.AND.IDERZ2(1).EQ.' '.AND. 8790 1 IDERZ1(2).EQ.'+ '.AND.IDERZ2(2).EQ.' ')GOTO988 8791 IF(IDERZ1(1).EQ.'+ '.AND.IDERZ2(1).EQ.' '.AND. 8792 1 IDERZ1(2).EQ.'- '.AND.IDERZ2(2).EQ.' ')GOTO988 8793 GOTO990 8794 986 CONTINUE 8795 I2=0 8796 DO987I=3,NCDZ 8797 I2=I2+1 8798 IDERZ1(I2)=IDERZ1(I) 8799 IDERZ2(I2)=IDERZ2(I) 8800 987 CONTINUE 8801 GOTO990 8802 988 CONTINUE 8803 I2=1 8804 IDERZ1(I2)='- ' 8805 IDERZ2(I2)=' ' 8806 DO989I=3,NCDZ 8807 I2=I2+1 8808 IDERZ1(I2)=IDERZ1(I) 8809 IDERZ2(I2)=IDERZ2(I) 8810 989 CONTINUE 8811 990 CONTINUE 8812 NCDZ=I2 8813C 8814 GOTO8000 8815C 8816C ********************************* 8817C ** STEP 4-- ** 8818C ** SEARCH FOR ** -- ** 8819C ** THIS WILL INDICATE AN ** 8820C ** EXPONENTIATION OPERATION. ** 8821C ********************************* 8822C 8823 3000 CONTINUE 8824C 8825 ISTEPN='4' 8826 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV3') 8827 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8828C 8829 DO3300I=1,NCFZ 8830 I2=I 8831 IF(IFUNZ1(I).EQ.'** '.AND.IFUNZ2(I).EQ.' ')GOTO5000 8832 3300 CONTINUE 8833C 8834C ******************************************** 8835C ** STEP 5-- ** 8836C ** TREAT THE LONE VARIABLE (ETC.) CASE. ** 8837C ******************************************** 8838C 8839 ISTEPN='5' 8840 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV3') 8841 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8842C 8843 I1=0 8844 I2=0 8845 I1=I1+1 8846 IF(IFUNZ1(I1).EQ.'- '.AND.IFUNZ2(I1).EQ.' ')GOTO4100 8847 IF(IFUNZ1(I1).EQ.'+ '.AND.IFUNZ2(I1).EQ.' ')GOTO4150 8848 GOTO4200 8849C 8850 4100 CONTINUE 8851 I2=I2+1 8852 IDERZ1(I2)=IFUNZ1(I1) 8853 IDERZ2(I2)=IFUNZ2(I1) 8854 4150 CONTINUE 8855 I1=I1+1 8856 GOTO4200 8857C 8858 4200 CONTINUE 8859 IF(IFUNZ1(I1).EQ.'$ '.AND.IFUNZ2(I1).EQ.' ')GOTO4300 8860 GOTO4400 8861C 8862 4300 CONTINUE 8863 I2=I2+1 8864 IDERZ1(I2)='% ' 8865 IDERZ2(I2)=' ' 8866 I1=I1+1 8867 I2=I2+1 8868 IDERZ1(I2)=IFUNZ1(I1) 8869 IDERZ2(I2)=IFUNZ2(I1) 8870 GOTO4900 8871C 8872 4400 CONTINUE 8873 IF(IFUNZ1(I1).EQ.'& '.AND.IFUNZ2(I1).EQ.' ')GOTO4500 8874 GOTO4600 8875C 8876 4500 CONTINUE 8877 I2=1 8878 IDERZ1(I2)='0 ' 8879 IDERZ2(I2)=' ' 8880 GOTO4900 8881C 8882 4600 CONTINUE 8883CCCCC IH1=IFUNZ1(I1) 8884CCCCC IH2=IFUNZ2(I1) 8885CCCCC IF(NUMPAR.LE.0)GOTO4690 8886CCCCC DO4610I=1,NUMPAR 8887CCCCC IF(IH1.EQ.IPARN1(I).AND.IH2.EQ.IPARN2(I))GOTO4620 8888C4610 CONTINUE 8889CCCCC GOTO4690 8890C4620 CONTINUE 8891CCCCC I2=1 8892CCCCC IDERZ1(I2)='0 ' 8893CCCCC IDERZ2(I2)=' ' 8894CCCCC GOTO4900 8895C4690 CONTINUE 8896C 8897 IH1=IFUNZ1(I1) 8898 IH2=IFUNZ2(I1) 8899 IF(NUMVAR.LE.0)GOTO4790 8900 DO4710I=1,NUMVAR 8901 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV3') 8902 1WRITE(ICOUT,4711)IH1,IH2,IVARN1(I),IVARN2(I) 8903 4711 FORMAT('IH1,IH2,IVARN1(I),IVARN2(I) = ',A4,2X,A4,2X,A4,2X,A4) 8904 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV3') 8905 1CALL DPWRST('XXX','BUG ') 8906 IF(IH1.EQ.IVARN1(I).AND.IH2.EQ.IVARN2(I))GOTO4720 8907 4710 CONTINUE 8908 GOTO4780 8909 4720 CONTINUE 8910 I2=I2+1 8911 IDERZ1(I2)='1 ' 8912 IDERZ2(I2)=' ' 8913 GOTO4900 8914 4780 CONTINUE 8915 I2=I2+1 8916 IDERZ1(I2)='0 ' 8917 IDERZ2(I2)=' ' 8918 GOTO4900 8919 4790 CONTINUE 8920C 8921 WRITE(6,4801) 8922 4801 FORMAT('*****ERROR IN DERIV3--') 8923 WRITE(6,4802) 8924 4802 FORMAT(' ILLEGAL ELEMENT TYPE') 8925 WRITE(ICOUT,4803)NCFZ 8926 4803 FORMAT('NCFZ = ',I6) 8927 CALL DPWRST('XXX','BUG ') 8928 DO4806I=1,NCFZ 8929 WRITE(ICOUT,4807)I,IFUNZ1(I),IFUNZ2(I) 8930 4807 FORMAT('I,IFUNZ1(I),IFUNZ2(I) = ',I8,2X,A4,2X,A4) 8931 CALL DPWRST('XXX','BUG ') 8932 4806 CONTINUE 8933 WRITE(ICOUT,4815)NCDZ 8934 4815 FORMAT('NCDZ = ',I6) 8935 CALL DPWRST('XXX','BUG ') 8936 DO4816I=1,NCDZ 8937 WRITE(ICOUT,4817)I,IDERZ1(I),IDERZ2(I) 8938 4817 FORMAT('I,IDERZ1(I),IDERZ2(I) = ',I8,2X,A4,2X,A4) 8939 CALL DPWRST('XXX','BUG ') 8940 4816 CONTINUE 8941 WRITE(ICOUT,4821)NUMPAR 8942 4821 FORMAT('NUMPAR = ',I8) 8943 CALL DPWRST('XXX','BUG ') 8944 DO4822I=1,NUMPAR 8945 WRITE(ICOUT,4823)I,IPARN1(I),IPARN2(I) 8946 4823 FORMAT('I,IPARN1(I),IPARN2(I) = ',I8,2X,A4,2X,A4) 8947 CALL DPWRST('XXX','BUG ') 8948 4822 CONTINUE 8949 WRITE(ICOUT,4831)NUMVAR 8950 4831 FORMAT('NUMVAR = ',I8) 8951 CALL DPWRST('XXX','BUG ') 8952 DO4832I=1,NUMVAR 8953 WRITE(ICOUT,4833)I,IVARN1(I),IVARN2(I) 8954 4833 FORMAT('I,IVARN1(I),IVARN2(I) = ',I8,2X,A4,2X,A4) 8955 CALL DPWRST('XXX','BUG ') 8956 4832 CONTINUE 8957 IERROR='YES' 8958 GOTO9000 8959C 8960 4900 CONTINUE 8961 NCDZ=I2 8962 GOTO8000 8963C 8964C *********************************** 8965C ** STEP 6-- ** 8966C ** TREAT THE EXPONENTIAL CASE. ** 8967C *********************************** 8968C 8969 5000 CONTINUE 8970C 8971 ISTEPN='6' 8972 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV3') 8973 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 8974C 8975 I1=0 8976 I1=I1+1 8977 IF(IFUNZ1(I1).EQ.'+ '.AND.IFUNZ2(I1).EQ.' ')GOTO5100 8978 IF(IFUNZ1(I1).EQ.'- '.AND.IFUNZ2(I1).EQ.' ')GOTO5100 8979 GOTO5150 8980C 8981 5100 CONTINUE 8982 ISIGN1=IFUNZ1(I1) 8983 ISIGN2=IFUNZ2(I1) 8984 I1=I1+1 8985 GOTO5200 8986C 8987 5150 CONTINUE 8988 ISIGN1='+ ' 8989 ISIGN2=' ' 8990 GOTO5200 8991C 8992 5200 CONTINUE 8993 IF(IFUNZ1(I1).EQ.'$ '.AND.IFUNZ2(I1).EQ.' ')GOTO5300 8994 GOTO5400 8995C 8996 5300 CONTINUE 8997 IMAN11=IFUNZ1(I1) 8998 IMAN12=IFUNZ2(I1) 8999 I1=I1+1 9000 IMAN21=IFUNZ1(I1) 9001 IMAN22=IFUNZ2(I1) 9002 IMANTT='EXP ' 9003 GOTO5900 9004C 9005 5400 CONTINUE 9006 IF(IFUNZ1(I1).EQ.'& '.AND.IFUNZ2(I1).EQ.' ')GOTO5500 9007 GOTO5600 9008C 9009 5500 CONTINUE 9010 IMAN11=IFUNZ1(I1) 9011 IMAN12=IFUNZ2(I1) 9012 I1=I1+1 9013 IMAN21=IFUNZ1(I1) 9014 IMAN22=IFUNZ2(I1) 9015 IMANTT='CON ' 9016 GOTO5900 9017C 9018 5600 CONTINUE 9019 IH1=IFUNZ1(I1) 9020 IH2=IFUNZ2(I1) 9021 IF(NUMPAR.LE.0)GOTO5690 9022 DO5610I=1,NUMPAR 9023 IF(IH1.EQ.IPARN1(I).AND.IH2.EQ.IPARN2(I))GOTO5620 9024 5610 CONTINUE 9025 GOTO5690 9026 5620 CONTINUE 9027 IMAN11=IFUNZ1(I1) 9028 IMAN12=IFUNZ2(I1) 9029 IMANTT='PAR ' 9030 GOTO5900 9031 5690 CONTINUE 9032C 9033 IH1=IFUNZ1(I1) 9034 IH2=IFUNZ2(I1) 9035 IF(NUMVAR.LE.0)GOTO5790 9036 DO5710I=1,NUMVAR 9037 IF(IH1.EQ.IVARN1(I).AND.IH2.EQ.IVARN2(I))GOTO5720 9038 5710 CONTINUE 9039 GOTO5790 9040 5720 CONTINUE 9041 IDERZ1(I2)='1 ' 9042 IDERZ2(I2)=' ' 9043 IMAN11=IFUNZ1(I1) 9044 IMAN12=IFUNZ2(I1) 9045 IMANTT='VAR ' 9046 GOTO5900 9047 5790 CONTINUE 9048C 9049 WRITE(6,5801) 9050 5801 FORMAT('*****ERROR IN DERIV3--') 9051 WRITE(6,5802) 9052 5802 FORMAT(' ILLEGAL MANTISSA TYPE') 9053 DO5806I=1,NCFZ 9054 WRITE(ICOUT,5807)I,IFUNZ1(I),IFUNZ2(I) 9055 5807 FORMAT('I,IFUNZ1(I),IFUNZ2(I) = ',I8,2X,A4,2X,A4) 9056 CALL DPWRST('XXX','BUG ') 9057 5806 CONTINUE 9058 WRITE(ICOUT,5815)NCDZ 9059 5815 FORMAT('NCDZ = ',I6) 9060 CALL DPWRST('XXX','BUG ') 9061 DO5816I=1,NCDZ 9062 WRITE(ICOUT,5817)I,IDERZ1(I),IDERZ2(I) 9063 5817 FORMAT('I,IDERZ1(I),IDERZ2(I) = ',I8,2X,A4,2X,A4) 9064 CALL DPWRST('XXX','BUG ') 9065 5816 CONTINUE 9066 IERROR='YES' 9067 GOTO9000 9068C 9069 5900 CONTINUE 9070C 9071 I1=I1+1 9072 IF(IFUNZ1(I1).EQ.'** '.AND.IFUNZ2(I1).EQ.' ')GOTO6100 9073C 9074 WRITE(6,6001) 9075 6001 FORMAT('*****ERROR IN DERIV3--') 9076 WRITE(6,6002) 9077 6002 FORMAT(' ** NOT ENCOUNTERED,') 9078 WRITE(ICOUT,6003) 9079 6003 FORMAT(' WHERE IT SHOULD HAVE BEEN.') 9080 CALL DPWRST('XXX','BUG ') 9081 DO6006I=1,NCFZ 9082 WRITE(ICOUT,6007)I,IFUNZ1(I),IFUNZ2(I) 9083 6007 FORMAT('I,IFUNZ1(I),IFUNZ2(I) = ',I8,2X,A4,2X,A4) 9084 CALL DPWRST('XXX','BUG ') 9085 6006 CONTINUE 9086 IERROR='YES' 9087 WRITE(ICOUT,6015)NCDZ 9088 6015 FORMAT('NCDZ = ',I6) 9089 CALL DPWRST('XXX','BUG ') 9090 DO6016I=1,NCDZ 9091 WRITE(ICOUT,6017)I,IDERZ1(I),IDERZ2(I) 9092 6017 FORMAT('I,IDERZ1(I),IDERZ2(I) = ',I8,2X,A4,2X,A4) 9093 CALL DPWRST('XXX','BUG ') 9094 6016 CONTINUE 9095 GOTO9000 9096C 9097 6100 CONTINUE 9098 I1=I1+1 9099 GOTO6200 9100C 9101 6200 CONTINUE 9102 IF(IFUNZ1(I1).EQ.'$ '.AND.IFUNZ2(I1).EQ.' ')GOTO6300 9103 GOTO6400 9104C 9105 6300 CONTINUE 9106 IEXP11=IFUNZ1(I1) 9107 IEXP12=IFUNZ2(I1) 9108 I1=I1+1 9109 IEXP21=IFUNZ1(I1) 9110 IEXP22=IFUNZ2(I1) 9111 IEXPT='EXP ' 9112 GOTO6900 9113C 9114 6400 CONTINUE 9115 IF(IFUNZ1(I1).EQ.'& '.AND.IFUNZ2(I1).EQ.' ')GOTO6500 9116 GOTO6600 9117C 9118 6500 CONTINUE 9119 IEXP11=IFUNZ1(I1) 9120 IEXP12=IFUNZ2(I1) 9121 I1=I1+1 9122 IEXP21=IFUNZ1(I1) 9123 IEXP22=IFUNZ2(I1) 9124 IEXPT='CON ' 9125 GOTO6900 9126C 9127 6600 CONTINUE 9128 IH1=IFUNZ1(I1) 9129 IH2=IFUNZ2(I1) 9130 IF(NUMPAR.LE.0)GOTO6690 9131 DO6610I=1,NUMPAR 9132 IF(IH1.EQ.IPARN1(I).AND.IH2.EQ.IPARN2(I))GOTO6620 9133 6610 CONTINUE 9134 GOTO6690 9135 6620 CONTINUE 9136 IEXP11=IFUNZ1(I1) 9137 IEXP12=IFUNZ2(I1) 9138 IEXPT='PAR ' 9139 GOTO6900 9140 6690 CONTINUE 9141C 9142 IH1=IFUNZ1(I1) 9143 IH2=IFUNZ2(I1) 9144 IF(NUMVAR.LE.0)GOTO6790 9145 DO6710I=1,NUMVAR 9146 IF(IH1.EQ.IVARN1(I).AND.IH2.EQ.IVARN2(I))GOTO6720 9147 6710 CONTINUE 9148 GOTO6790 9149 6720 CONTINUE 9150 IDERZ1(I2)='1 ' 9151 IDERZ2(I2)=' ' 9152 IEXP11=IFUNZ1(I1) 9153 IEXP12=IFUNZ2(I1) 9154 IEXPT='VAR ' 9155 GOTO6900 9156 6790 CONTINUE 9157C 9158 WRITE(6,6801) 9159 6801 FORMAT('*****ERROR IN DERIV3--') 9160 WRITE(6,6802) 9161 6802 FORMAT(' ILLEGAL EXPONENT TYPE') 9162 DO6805I=1,NCDZ 9163 WRITE(ICOUT,6806)I,IFUNZ1(I),IFUNZ2(I) 9164 6806 FORMAT('I,IFUNZ1(I),IFUNZ2(I) = ',I8,2X,A4,2X,A4) 9165 CALL DPWRST('XXX','BUG ') 9166 6805 CONTINUE 9167 IERROR='YES' 9168 GOTO9000 9169C 9170 6900 CONTINUE 9171C 9172 IF((IMANTT.EQ.'CON '.OR.IMANTT.EQ.'PAR ').AND. 9173 1 (IEXPT.EQ.'CON '.OR.IEXPT.EQ.'PAR '))GOTO7010 9174 IF((IMANTT.EQ.'VAR '.OR.IMANTT.EQ.'EXP ').AND. 9175 1 (IEXPT.EQ.'CON '.OR.IEXPT.EQ.'PAR '))GOTO7020 9176 IF((IMANTT.EQ.'CON '.OR.IMANTT.EQ.'PAR ').AND. 9177 1 (IEXPT.EQ.'VAR '.OR.IEXPT.EQ.'EXP '))GOTO7030 9178 IF((IMANTT.EQ.'VAR '.OR.IMANTT.EQ.'EXP ').AND. 9179 1 (IEXPT.EQ.'VAR '.OR.IEXPT.EQ.'EXP '))GOTO7040 9180C 9181 WRITE(ICOUT,7071) 9182 7071 FORMAT('***** ERROR IN DERIV3--') 9183 CALL DPWRST('XXX','BUG ') 9184 WRITE(ICOUT,7072) 9185 7072 FORMAT(' A MANTISSA OR EXPONENT TYPE') 9186 CALL DPWRST('XXX','BUG ') 9187 WRITE(ICOUT,7073) 9188 7073 FORMAT(' IS NOT CON PAR VAR EXP') 9189 CALL DPWRST('XXX','BUG ') 9190 WRITE(ICOUT,7074)IMANTT,IEXPT 9191 7074 FORMAT('IMANTT, IEXPT = ',A6,2X,A6) 9192 CALL DPWRST('XXX','BUG ') 9193 DO7075I=1,NCDZ 9194 WRITE(ICOUT,7076)I,IFUNZ1(I),IFUNZ2(I) 9195 7076 FORMAT('I,IFUNZ1(I),IFUNZ2(I) = ',I8,2X,A4,2X,A4) 9196 CALL DPWRST('XXX','BUG ') 9197 7075 CONTINUE 9198 IERROR='YES' 9199 GOTO9000 9200C 9201C **************************** 9202C ** STEP 7.1-- ** 9203C ** TREAT THE A**B CASE. ** 9204C **************************** 9205 7010 CONTINUE 9206C 9207 ISTEPN='7.1' 9208 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV3') 9209 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9210C 9211 I2=1 9212 IDERZ1(I2)='0 ' 9213 IDERZ2(I2)=' ' 9214 GOTO7900 9215C 9216C **************************** 9217C ** STEP 7.2-- ** 9218C ** TREAT THE X**A CASE. ** 9219C **************************** 9220C 9221 7020 CONTINUE 9222C 9223 ISTEPN='7.2' 9224 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV3') 9225 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9226C 9227 I2=0 9228 IF(ISIGN1.EQ.'- '.AND.ISIGN2.EQ.' ')I2=I2+1 9229 IF(ISIGN1.EQ.'- '.AND.ISIGN2.EQ.' ')IDERZ1(I2)='- ' 9230 IF(ISIGN1.EQ.'- '.AND.ISIGN2.EQ.' ')IDERZ2(I2)=' ' 9231 I2=I2+1 9232 IDERZ1(I2)=IEXP11 9233 IDERZ2(I2)=IEXP12 9234 IF(IEXPT.EQ.'CON ')I2=I2+1 9235 IF(IEXPT.EQ.'CON ')IDERZ1(I2)=IEXP21 9236 IF(IEXPT.EQ.'CON ')IDERZ2(I2)=IEXP22 9237 I2=I2+1 9238 IDERZ1(I2)='* ' 9239 IDERZ2(I2)=' ' 9240 I2=I2+1 9241 IDERZ1(I2)=IMAN11 9242 IDERZ2(I2)=IMAN12 9243 IF(IMANTT.EQ.'EXP ')I2=I2+1 9244 IF(IMANTT.EQ.'EXP ')IDERZ1(I2)=IMAN21 9245 IF(IMANTT.EQ.'EXP ')IDERZ2(I2)=IMAN22 9246 I2=I2+1 9247 IDERZ1(I2)='** ' 9248 IDERZ2(I2)=' ' 9249 I2=I2+1 9250 IDERZ1(I2)='( ' 9251 IDERZ2(I2)=' ' 9252 I2=I2+1 9253 IDERZ1(I2)=IEXP11 9254 IDERZ2(I2)=IEXP12 9255 IF(IEXPT.EQ.'CON ')I2=I2+1 9256 IF(IEXPT.EQ.'CON ')IDERZ1(I2)=IEXP21 9257 IF(IEXPT.EQ.'CON ')IDERZ2(I2)=IEXP22 9258 I2=I2+1 9259 IDERZ1(I2)='- ' 9260 IDERZ2(I2)=' ' 9261 I2=I2+1 9262 IDERZ1(I2)='1 ' 9263 IDERZ2(I2)=' ' 9264 I2=I2+1 9265 IDERZ1(I2)=') ' 9266 IDERZ2(I2)=' ' 9267 IF(IMANTT.EQ.'EXP ')GOTO7025 9268 GOTO7029 9269 7025 CONTINUE 9270 I2=I2+1 9271 IDERZ1(I2)='* ' 9272 IDERZ2(I2)=' ' 9273 I2=I2+1 9274 IDERZ1(I2)='% ' 9275 IDERZ2(I2)=' ' 9276 I2=I2+1 9277 IDERZ1(I2)=IMAN21 9278 IDERZ2(I2)=IMAN22 9279 7029 CONTINUE 9280 GOTO7900 9281C 9282C **************************** 9283C ** STEP 7.3-- ** 9284C ** TREAT THE A**X CASE. ** 9285C **************************** 9286C 9287 7030 CONTINUE 9288C 9289 ISTEPN='7.3' 9290 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV3') 9291 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9292C 9293 I2=0 9294 IF(ISIGN1.EQ.'- '.AND.ISIGN2.EQ.' ')I2=I2+1 9295 IF(ISIGN1.EQ.'- '.AND.ISIGN2.EQ.' ')IDERZ1(I2)='- ' 9296 IF(ISIGN1.EQ.'- '.AND.ISIGN2.EQ.' ')IDERZ2(I2)=' ' 9297 I2=I2+1 9298 IDERZ1(I2)='( ' 9299 IDERZ2(I2)=' ' 9300 I2=I2+1 9301 IDERZ1(I2)=IMAN11 9302 IDERZ2(I2)=IMAN12 9303 IF(IMANTT.EQ.'CON ')I2=I2+1 9304 IF(IMANTT.EQ.'CON ')IDERZ1(I2)=IMAN21 9305 IF(IMANTT.EQ.'CON ')IDERZ2(I2)=IMAN22 9306 I2=I2+1 9307 IDERZ1(I2)='** ' 9308 IDERZ2(I2)=' ' 9309 I2=I2+1 9310 IDERZ1(I2)=IEXP11 9311 IDERZ2(I2)=IEXP12 9312 IF(IEXPT.EQ.'EXP ')I2=I2+1 9313 IF(IEXPT.EQ.'EXP ')IDERZ1(I2)=IEXP21 9314 IF(IEXPT.EQ.'EXP ')IDERZ2(I2)=IEXP22 9315 I2=I2+1 9316 IDERZ1(I2)=') ' 9317 IDERZ2(I2)=' ' 9318 I2=I2+1 9319 IDERZ1(I2)='* ' 9320 IDERZ2(I2)=' ' 9321 I2=I2+1 9322 IDERZ1(I2)='ALOG' 9323 IDERZ2(I2)=' ' 9324 I2=I2+1 9325 IDERZ1(I2)='( ' 9326 IDERZ2(I2)=' ' 9327 I2=I2+1 9328 IDERZ1(I2)=IMAN11 9329 IDERZ2(I2)=IMAN12 9330 IF(IMANTT.EQ.'CON ')I2=I2+1 9331 IF(IMANTT.EQ.'CON ')IDERZ1(I2)=IMAN21 9332 IF(IMANTT.EQ.'CON ')IDERZ2(I2)=IMAN22 9333 I2=I2+1 9334 IDERZ1(I2)=') ' 9335 IDERZ2(I2)=' ' 9336 IF(IEXPT.EQ.'EXP ')GOTO7035 9337 GOTO7039 9338 7035 CONTINUE 9339 I2=I2+1 9340 IDERZ1(I2)='* ' 9341 IDERZ2(I2)=' ' 9342 I2=I2+1 9343 IDERZ1(I2)='% ' 9344 IDERZ2(I2)=' ' 9345 I2=I2+1 9346 IDERZ1(I2)=IEXP21 9347 IDERZ2(I2)=IEXP22 9348 7039 CONTINUE 9349 GOTO7900 9350C 9351C **************************** 9352C ** STEP 7.4-- ** 9353C ** TREAT THE U**V CASE. ** 9354C **************************** 9355C 9356 7040 CONTINUE 9357C 9358 ISTEPN='7.4' 9359 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV3') 9360 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9361C 9362 I2=0 9363 IF(ISIGN1.EQ.'- '.AND.ISIGN2.EQ.' ')I2=I2+1 9364 IF(ISIGN1.EQ.'- '.AND.ISIGN2.EQ.' ')IDERZ1(I2)='- ' 9365 IF(ISIGN1.EQ.'- '.AND.ISIGN2.EQ.' ')IDERZ2(I2)=' ' 9366 I2=I2+1 9367 IDERZ1(I2)='( ' 9368 IDERZ2(I2)=' ' 9369 I2=I2+1 9370 IDERZ1(I2)='( ' 9371 IDERZ2(I2)=' ' 9372 I2=I2+1 9373 IDERZ1(I2)=IEXP11 9374 IDERZ2(I2)=IEXP12 9375 IF(IEXPT.EQ.'EXP ')I2=I2+1 9376 IF(IEXPT.EQ.'EXP ')IDERZ1(I2)=IEXP21 9377 IF(IEXPT.EQ.'EXP ')IDERZ2(I2)=IEXP22 9378 I2=I2+1 9379 IDERZ1(I2)='* ' 9380 IDERZ2(I2)=' ' 9381 I2=I2+1 9382 IDERZ1(I2)=IMAN11 9383 IDERZ2(I2)=IMAN12 9384 IF(IMANTT.EQ.'EXP ')I2=I2+1 9385 IF(IMANTT.EQ.'EXP ')IDERZ1(I2)=IMAN21 9386 IF(IMANTT.EQ.'EXP ')IDERZ2(I2)=IMAN22 9387 I2=I2+1 9388 IDERZ1(I2)='** ' 9389 IDERZ2(I2)=' ' 9390 I2=I2+1 9391 IDERZ1(I2)='( ' 9392 IDERZ2(I2)=' ' 9393 I2=I2+1 9394 IDERZ1(I2)=IEXP11 9395 IDERZ2(I2)=IEXP12 9396 IF(IEXPT.EQ.'EXP ')I2=I2+1 9397 IF(IEXPT.EQ.'EXP ')IDERZ1(I2)=IEXP21 9398 IF(IEXPT.EQ.'EXP ')IDERZ2(I2)=IEXP22 9399 I2=I2+1 9400 IDERZ1(I2)='- ' 9401 IDERZ2(I2)=' ' 9402 I2=I2+1 9403 IDERZ1(I2)='1 ' 9404 IDERZ2(I2)=' ' 9405 I2=I2+1 9406 IDERZ1(I2)=') ' 9407 IDERZ2(I2)=' ' 9408 I2=I2+1 9409 IDERZ1(I2)=') ' 9410 IDERZ2(I2)=' ' 9411 IF(IMANTT.EQ.'EXP ')GOTO7041 9412 GOTO7042 9413 7041 CONTINUE 9414 I2=I2+1 9415 IDERZ1(I2)='* ' 9416 IDERZ2(I2)=' ' 9417 I2=I2+1 9418 IDERZ1(I2)='% ' 9419 IDERZ2(I2)=' ' 9420 I2=I2+1 9421 IDERZ1(I2)=IMAN21 9422 IDERZ2(I2)=IMAN22 9423 7042 CONTINUE 9424C 9425 I2=I2+1 9426 IDERZ1(I2)='+ ' 9427 IDERZ2(I2)=' ' 9428 I2=I2+1 9429 IDERZ1(I2)='( ' 9430 IDERZ2(I2)=' ' 9431 I2=I2+1 9432 IDERZ1(I2)='ALOG' 9433 IDERZ2(I2)=' ' 9434 I2=I2+1 9435 IDERZ1(I2)='( ' 9436 IDERZ2(I2)=' ' 9437 I2=I2+1 9438 IDERZ1(I2)=IMAN11 9439 IDERZ2(I2)=IMAN12 9440 IF(IMANTT.EQ.'EXP ')I2=I2+1 9441 IF(IMANTT.EQ.'EXP ')IDERZ1(I2)=IMAN21 9442 IF(IMANTT.EQ.'EXP ')IDERZ2(I2)=IMAN22 9443 I2=I2+1 9444 IDERZ1(I2)=') ' 9445 IDERZ2(I2)=' ' 9446 I2=I2+1 9447 IDERZ1(I2)='* ' 9448 IDERZ2(I2)=' ' 9449 I2=I2+1 9450 IDERZ1(I2)=IMAN11 9451 IDERZ2(I2)=IMAN12 9452 IF(IMANTT.EQ.'EXP ')I2=I2+1 9453 IF(IMANTT.EQ.'EXP ')IDERZ1(I2)=IMAN21 9454 IF(IMANTT.EQ.'EXP ')IDERZ2(I2)=IMAN22 9455 I2=I2+1 9456 IDERZ1(I2)='** ' 9457 IDERZ2(I2)=' ' 9458 I2=I2+1 9459 IDERZ1(I2)=IEXP11 9460 IDERZ2(I2)=IEXP12 9461 IF(IEXPT.EQ.'EXP ')I2=I2+1 9462 IF(IEXPT.EQ.'EXP ')IDERZ1(I2)=IEXP21 9463 IF(IEXPT.EQ.'EXP ')IDERZ2(I2)=IEXP22 9464 I2=I2+1 9465 IDERZ1(I2)=') ' 9466 IDERZ2(I2)=' ' 9467 IF(IEXPT.EQ.'EXP ')GOTO7043 9468 GOTO7044 9469 7043 CONTINUE 9470 I2=I2+1 9471 IDERZ1(I2)='* ' 9472 IDERZ2(I2)=' ' 9473 I2=I2+1 9474 IDERZ1(I2)='% ' 9475 IDERZ2(I2)=' ' 9476 I2=I2+1 9477 IDERZ1(I2)=IEXP21 9478 IDERZ2(I2)=IEXP22 9479 7044 CONTINUE 9480 I2=I2+1 9481 IDERZ1(I2)=') ' 9482 IDERZ2(I2)=' ' 9483 GOTO7900 9484C 9485 7900 CONTINUE 9486 NCDZ=I2 9487 GOTO8000 9488C 9489C ************************************ 9490C ** STEP 8-- ** 9491C ** COPY THE EXPRESSION ** 9492C ** IN THE VECTOR IDERZ1(.) ** 9493C ** INTO ROW IROW2 OF IDER21(.,.) ** 9494C ************************************ 9495C 9496 8000 CONTINUE 9497C 9498 ISTEPN='8' 9499 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV3') 9500 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9501C 9502 IF(IDERZ1(1).EQ.'+ '.AND.IDERZ2(1).EQ.' ')GOTO8010 9503 IF(IDERZ1(1).EQ.'- '.AND.IDERZ2(1).EQ.' ')GOTO8010 9504 GOTO8090 9505 8010 CONTINUE 9506 IHOL11='( ' 9507 IHOL12=' ' 9508 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV3') 9509 1WRITE(ICOUT,8011)NCDZ 9510 8011 FORMAT('NCDZ = ',I8) 9511 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV3') 9512 1CALL DPWRST('XXX','BUG ') 9513 DO8020I=1,NCDZ 9514 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV3') 9515 1WRITE(ICOUT,8021)I,IDERZ1(I),IDERZ2(I) 9516 8021 FORMAT('I,IDERZ1(I),IDERZ2(I) = ',I8,2X,A4,2X,A4) 9517 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV3') 9518 1CALL DPWRST('XXX','BUG ') 9519 IHOL21=IDERZ1(I) 9520 IHOL22=IDERZ2(I) 9521 IDERZ1(I)=IHOL11 9522 IDERZ2(I)=IHOL12 9523 IHOL11=IHOL21 9524 IHOL12=IHOL22 9525 8020 CONTINUE 9526 I2=NCDZ 9527 I2=I2+1 9528 IDERZ1(I2)=IHOL11 9529 IDERZ2(I2)=IHOL12 9530 I2=I2+1 9531 IDERZ1(I2)=') ' 9532 IDERZ2(I2)=' ' 9533 NCDZ=I2 9534 8090 CONTINUE 9535C 9536 NCD2(IROW2)=NCDZ 9537 DO8100I=1,NCDZ 9538 IDER21(IROW2,I)=IDERZ1(I) 9539 IDER22(IROW2,I)=IDERZ2(I) 9540 8100 CONTINUE 9541C 9542 GOTO9000 9543C 9544C ***************** 9545C ** STEP 90-- ** 9546C ** EXIT. ** 9547C ***************** 9548C 9549 9000 CONTINUE 9550 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'RIV3')GOTO9090 9551 WRITE(ICOUT,999) 9552 CALL DPWRST('XXX','BUG ') 9553 WRITE(ICOUT,9011) 9554 9011 FORMAT('AT THE END OF DERIV3--') 9555 CALL DPWRST('XXX','BUG ') 9556 WRITE(ICOUT,9013)NCD2(IROW2) 9557 9013 FORMAT('NCD2(IROW2) = ',I8) 9558 CALL DPWRST('XXX','BUG ') 9559 IMAX=NCD2(IROW2) 9560 DO9015I=1,IMAX 9561 WRITE(ICOUT,9016)I,IDER21(IROW2,I),IDER22(IROW2,I) 9562 9016 FORMAT('I,IDER21(IROW2,I),IDER22(IROW2,I) = ',I8,2X,A4,2X,A4) 9563 CALL DPWRST('XXX','BUG ') 9564 9015 CONTINUE 9565 WRITE(ICOUT,9021)NUMPAR 9566 9021 FORMAT('NUMPAR = ',I8) 9567 CALL DPWRST('XXX','BUG ') 9568 DO9022I=1,NUMPAR 9569 WRITE(ICOUT,9023)I,IPARN1(I),IPARN2(I) 9570 9023 FORMAT('I,IPARN1(I),IPARN2(I) = ',I8,2X,A4,2X,A4) 9571 CALL DPWRST('XXX','BUG ') 9572 9022 CONTINUE 9573 WRITE(ICOUT,9031)NUMVAR 9574 9031 FORMAT('NUMVAR = ',I8) 9575 CALL DPWRST('XXX','BUG ') 9576 DO9032I=1,NUMVAR 9577 WRITE(ICOUT,9033)I,IVARN1(I),IVARN2(I) 9578 9033 FORMAT('I,IVARN1(I),IVARN2(I) = ',I8,2X,A4,2X,A4) 9579 CALL DPWRST('XXX','BUG ') 9580 9032 CONTINUE 9581 9090 CONTINUE 9582C 9583 RETURN 9584 END 9585 SUBROUTINE DERIV4(IFUN21,IFUN22,NCF2,NFUN2, 9586 1 IDER21,IDER22,NCD2,IOP2,IROW1, 9587 1 IDER11,IDER12,NCD1,IBUGA3,ISUBRO,IFOUND,IERROR) 9588C 9589C PURPOSE--DETERMINE THE DERIVATIVE OF 9590C A MULTIPLICATIVE EXPRESSION 9591C (= 1 FULL ADDITIVE COMPONENT) 9592C (EXAMPLE, A*X/C*D**E*X) 9593C BY COMBINING DERIVATIVES OF EACH 9594C ELEMENTAL COMPONENT. 9595C 9596C THE ENTIRE INPUT EXPRESSION IS LOCATED 9597C IN ROW IROW1 OF IFUN11-- 9598C IT HAS LENGTH NF1 9599C (THIS SUBROUTINE NEED NEVER SEE 9600C THIS ENTIRE EXPRESSION.) 9601C 9602C THE INPUT ELEMENTS OF THE 9603C INPUT EXPRESSION ARE LOCATED 9604C IN VARIOUS ROWS OF IFUN21. 9605C 9606C THE INPUT DERIVATIVES OF THE 9607C INPUT ELEMENTS ARE LOCATED 9608C IN VARIOUS ROWS OF IDER21. 9609C 9610C THE OUTPUT DERIVATIVE IS LOCATED 9611C IN ROW IROW1 OF IFUN1-- 9612C IT HAS LENGTH NCD1. 9613C 9614C INPUT ARGUMENTS--IFUN21 = THE ARRAY WHOSE I-TH ROW 9615C IS THE I-TH 9616C MULTIPLICATIVE COMPONENT 9617C OF THE IROW1-TH (IROW1 FIXED) 9618C ADDITIVE COMPONENT 9619C (FIRST 4 CHARACTERS). 9620C --IFUN22 = THE ARRAY WHOSE I-TH ROW 9621C IS THE I-TH 9622C MULTIPLICATIVE COMPONENT 9623C OF THE IROW1-TH (IROW1 FIXED) 9624C ADDITIVE COMPONENT 9625C (NEXT 4 CHARACTERS). 9626C --NCF2 = AN INTEGER VECTOR 9627C WHOSE IROW1-TH ELEMENT 9628C IS THE LENGTH 9629C OF THE I-TH 9630C MULTIPLICATIVE COMPONENT 9631C OF THE IROW1-TH (IROW1 FIXED) 9632C ADDITIVE COMPONENT. 9633C --NFUN2 = THE NUMBER OF ROWS 9634C (= THE NUMBER OF MULTIPLICATIVE 9635C SUBSTRINGS OF THE IROW1-TH 9636C ADDITIVE COMPONENT) 9637C THAT IS 9638C IN THE ARRAY IFUN21(.,.) 9639C --IOP2 = A VECTOR OF OPERATIONS 9640C (BETWEEN ELEMENTS--* OR /. 9641C --IDER21 = THE ARRAY WHOSE I-TH ROW 9642C IS THE DERIVATIVE OF THE I-TH 9643C MULTIPLICATIVE COMPONENT 9644C OF THE IROW1-TH (IROW1 FIXED) 9645C (FIRST 4 CHARACTERS). 9646C --IDER22 = THE ARRAY WHOSE I-TH ROW 9647C IS THE DERIVATIVE OF THE I-TH 9648C MULTIPLICATIVE COMPONENT 9649C OF THE IROW1-TH (IROW1 FIXED) 9650C (NEXT 4 CHARACTERS). 9651C --NCD2 = AN INTEGER VECTOR 9652C WHOSE IROW1-TH ELEMENT 9653C IS THE LENGTH 9654C OF THE DERIVATIVE OF THE I-TH 9655C MULTIPLICATIVE COMPONENT 9656C OF THE IROW1-TH (IROW1 FIXED) 9657C ADDITIVE COMPONENT. 9658C WHOSE I-TH ELEMENT 9659C IS THE (TRAILING) OPERATION (* OR /) 9660C OF THE I-TH MULTIPLICATIVE SUBSTRING 9661C OF THE IROW1-TH ADDITIVE COMPONENT. 9662C --IROW1 = THE ROW NUMBER (IN IFUN1(.,.)) OF 9663C THE PARTICULAR 9664C ADDITIVE COMPONENT OF INTEREST. 9665C OUTPUT ARGUMENTS--IDER11 = THE ARRAY WHOSE IROW1-TH ROW 9666C WILL BE THE DERIVATIVE OF THE 9667C IROW1-TH ADDITIVE STRING 9668C (FIRST 4 CHARACTERS). 9669C --IDER12 = THE ARRAY WHOSE IROW1-TH ROW 9670C WILL BE THE DERIVATIVE OF THE 9671C IROW1-TH ADDITIVE STRING 9672C (NEXT 4 CHARACTERS). 9673C NCD1 = AN INTEGER VECTOR 9674C WHOSE IROW1-TH ELEMENT 9675C WILL BE THE LENGTH OF THE IROW1-TH 9676C DERIVATIVE IN IDER11(.,.); 9677C THAT IS, NCD1(IROW1) = THE LENGTH OF THE 9678C DERIVATIVE OF INTEREST. 9679C INTERNAL ARRAYS-- 9680C IFUN21 = THE ARRAY WHOSE I-TH 9681C ROW WILL BE THE I-TH MULTIPLICATIVE 9682C SUBSTRING OF THE IROW1-TH 9683C ADDITIVE COMPONENT. 9684C NCF2 = AN INTEGER VECTOR 9685C WHOSE I-TH ELEMENT 9686C WILL BE THE LENGTH OF THE I-TH 9687C MULTIPLICATIVE SUBSTRING 9688C OF THE IROW1-TH ADDITIVE COMPONENT. 9689C 9690C ORIGINAL VERSION--DECEMBER 2, 1978 9691C UPDATED --DECEMBER 1981. 9692C 9693C--------------------------------------------------------------------- 9694C 9695 CHARACTER*4 IFUN21 9696 CHARACTER*4 IFUN22 9697 CHARACTER*4 IDER21 9698 CHARACTER*4 IDER22 9699 CHARACTER*4 IDER11 9700 CHARACTER*4 IDER12 9701 CHARACTER*4 IBUGA3 9702 CHARACTER*4 ISUBRO 9703 CHARACTER*4 IFOUND 9704 CHARACTER*4 IERROR 9705C 9706 CHARACTER*4 ISTEPN 9707 CHARACTER*4 ISUBN1 9708 CHARACTER*4 ISUBN2 9709C 9710CCCCC CHARACTER*4 IBUG1 9711CCCCC CHARACTER*4 IBUG2 9712CCCCC CHARACTER*4 IBUG3 9713C 9714 CHARACTER*4 IDER31 9715 CHARACTER*4 IDER32 9716C 9717 CHARACTER*4 IFUN31 9718 CHARACTER*4 IFUN32 9719C 9720 CHARACTER*4 IOP2 9721C 9722 DIMENSION IFUN21(20,80) 9723 DIMENSION IFUN22(20,80) 9724 DIMENSION NCF2(1) 9725 DIMENSION IDER21(20,80) 9726 DIMENSION IDER22(20,80) 9727 DIMENSION NCD2(1) 9728 DIMENSION IOP2(1) 9729C 9730 DIMENSION IDER11(20,80) 9731 DIMENSION IDER12(20,80) 9732 DIMENSION NCD1(1) 9733C 9734 DIMENSION IFUN31(2,80) 9735 DIMENSION IFUN32(2,80) 9736 DIMENSION NCF3(2) 9737 DIMENSION IDER31(2,80) 9738 DIMENSION IDER32(2,80) 9739 DIMENSION NCD3(2) 9740C 9741C 9742C-----COMMON VARIABLES (GENERAL)----------------------------------------------- 9743C 9744 INCLUDE 'DPCOP2.INC' 9745C 9746C-----DATA STATEMENTS----------------------------------------------------- 9747C 9748CCCCC DATA IBUG1/'OFF'/ 9749CCCCC DATA IBUG2/'OFF'/ 9750CCCCC DATA IBUG3/'OFF'/ 9751C 9752C-----START POINT----------------------------------------------------- 9753C 9754 ISUBN1='DERI' 9755 ISUBN2='V4 ' 9756 IERROR='NO' 9757C 9758 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'RIV4')THEN 9759 WRITE(ICOUT,999) 9760 999 FORMAT(1X) 9761 CALL DPWRST('XXX','BUG ') 9762 WRITE(ICOUT,51) 9763 51 FORMAT('AT THE BEGINNING OF DERIV4--') 9764 CALL DPWRST('XXX','BUG ') 9765 WRITE(ICOUT,52)IFOUND,IROW1,NFUN2 9766 52 FORMAT('IFOUND,IROW1,NFUN2 = ',A4,2X,2I8) 9767 CALL DPWRST('XXX','BUG ') 9768 ITEMP=80 9769 DO60I=1,NFUN2 9770 WRITE(ICOUT,999) 9771 CALL DPWRST('XXX','BUG ') 9772 WRITE(ICOUT,61)I,NCF2(I),IOP2(I) 9773 61 FORMAT('I,NCF2(I) = ',2I8,2X,A4) 9774 CALL DPWRST('XXX','BUG ') 9775 DO65J=1,ITEMP 9776 WRITE(ICOUT,66)J,IFUN21(I,J),IFUN22(I,J) 9777 66 FORMAT('J,IFUN21(I,J),IFUN22(I,J) = ',I8,2(2X,A4)) 9778 CALL DPWRST('XXX','BUG ') 9779 65 CONTINUE 9780 60 CONTINUE 9781C 9782 DO70I=1,NFUN2 9783 WRITE(ICOUT,999) 9784 CALL DPWRST('XXX','BUG ') 9785 WRITE(ICOUT,71)I,NCD2(I) 9786 71 FORMAT('I,NCD2(I) = ',2I8) 9787 CALL DPWRST('XXX','BUG ') 9788 DO75J=1,ITEMP 9789 WRITE(ICOUT,76)J,IDER21(I,J),IDER22(I,J) 9790 76 FORMAT('J,IDER21(I,J),IDER22(I,J) = ',I8,2(2X,A4)) 9791 CALL DPWRST('XXX','BUG ') 9792 75 CONTINUE 9793 70 CONTINUE 9794 ENDIF 9795C 9796C *********************************** 9797C ** STEP 1.1-- ** 9798C ** FORM THE FIRST 2 FUNCTIONS. ** 9799C *********************************** 9800C 9801 ISTEPN='1' 9802 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV4') 9803 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9804C 9805 NFUN3=NFUN2 9806 IF(NFUN2.GE.1)GOTO1020 9807C 9808 WRITE(ICOUT,1011) 9809 1011 FORMAT('***** ERROR IN DERIV4--') 9810 CALL DPWRST('XXX','BUG ') 9811 WRITE(ICOUT,1012)NFUN2 9812 1012 FORMAT('NFUN2 NON-POSITIVE. NFUN2 = ',I8) 9813 CALL DPWRST('XXX','BUG ') 9814 IERROR='YES' 9815 GOTO9000 9816C 9817 1020 CONTINUE 9818 IROW3=1 9819 JMAX=NCF2(IROW3) 9820 K=0 9821 DO1050J=1,JMAX 9822 K=K+1 9823 IFUN31(1,K)=IFUN21(IROW3,J) 9824 IFUN32(1,K)=IFUN22(IROW3,J) 9825 IFUN31(2,K)=IFUN21(IROW3,J) 9826 IFUN32(2,K)=IFUN22(IROW3,J) 9827 1050 CONTINUE 9828 NCF3(1)=K 9829 NCF3(2)=K 9830C 9831C ************************************* 9832C ** STEP 1.2-- ** 9833C ** FORM THE FIRST 2 DERIVATIVES. ** 9834C ************************************* 9835C 9836 ISTEPN='1.2' 9837 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV4') 9838 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9839C 9840 IF(NFUN2.GE.1)GOTO2020 9841C 9842 WRITE(ICOUT,2001) 9843 2001 FORMAT('***** ERROR IN DERIV4--') 9844 CALL DPWRST('XXX','BUG ') 9845 WRITE(ICOUT,2002)NFUN2 9846 2002 FORMAT('NFUN2 NON-POSITIVE. NFUN2 = ',I8) 9847 CALL DPWRST('XXX','BUG ') 9848 IERROR='YES' 9849 GOTO9000 9850C 9851 2020 CONTINUE 9852 IROW3=1 9853 JMAX=NCD2(IROW3) 9854 K=0 9855 DO2030J=1,JMAX 9856 K=K+1 9857 IDER31(1,K)=IDER21(IROW3,J) 9858 IDER32(1,K)=IDER22(IROW3,J) 9859 IDER31(2,K)=IDER21(IROW3,J) 9860 IDER32(2,K)=IDER22(IROW3,J) 9861 2030 CONTINUE 9862 NCD3(1)=K 9863 NCD3(2)=K 9864C 9865 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'RIV4')GOTO2090 9866 WRITE(ICOUT,2006) 9867 2006 FORMAT('***** IN THE MIDDLE OF DERIV4--') 9868 CALL DPWRST('XXX','BUG ') 9869 WRITE(ICOUT,2007)IROW3,NCF2(IROW3),NCD2(IROW3) 9870 2007 FORMAT('IROW3, NCF2(IROW3), NCD2(IROW3) = ',3I6) 9871 CALL DPWRST('XXX','BUG ') 9872 WRITE(ICOUT,2008)IROW3,NCF3(2),NCD3(2) 9873 2008 FORMAT('IROW3, NCF3(2), NCD3(2) = ',3I6) 9874 CALL DPWRST('XXX','BUG ') 9875C 9876 WRITE(ICOUT,999) 9877 CALL DPWRST('XXX','BUG ') 9878 IMAX=NCF2(IROW3) 9879 DO2040I=1,IMAX 9880 WRITE(ICOUT,2045)I,IFUN21(IROW3,I),IFUN22(IROW3,I) 9881 2045 FORMAT('I,IFUN21(IROW3,I),IFUN22(IROW3,I) = ',I8,2X,A4,2X,A4) 9882 CALL DPWRST('XXX','BUG ') 9883 2040 CONTINUE 9884C 9885 WRITE(ICOUT,999) 9886 CALL DPWRST('XXX','BUG ') 9887 IMAX=NCD2(IROW3) 9888 DO2050I=1,IMAX 9889 WRITE(ICOUT,2055)I,IDER21(IROW3,I),IDER22(IROW3,I) 9890 2055 FORMAT('I,IDER21(IROW3,I),IDER22(IROW3,I) = ',I8,2X,A4,2X,A4) 9891 CALL DPWRST('XXX','BUG ') 9892 2050 CONTINUE 9893C 9894 WRITE(ICOUT,999) 9895 CALL DPWRST('XXX','BUG ') 9896 IMAX=NCF3(2) 9897 DO2060I=1,IMAX 9898 WRITE(ICOUT,2065)I,IFUN31(IROW3,I),IFUN32(IROW3,I) 9899 2065 FORMAT('I,IFUN31(IROW3,I),IFUN32(IROW3,I) = ',I8,2X,A4,2X,A4) 9900 CALL DPWRST('XXX','BUG ') 9901 2060 CONTINUE 9902C 9903 WRITE(ICOUT,999) 9904 CALL DPWRST('XXX','BUG ') 9905 IMAX=NCD3(2) 9906 DO2070I=1,IMAX 9907 WRITE(ICOUT,2075)I,IDER31(IROW3,I),IDER32(IROW3,I) 9908 2075 FORMAT('I,IDER31(IROW3,I),IDER32(IROW3,I) = ',I8,2X,A4,2X,A4) 9909 CALL DPWRST('XXX','BUG ') 9910 2070 CONTINUE 9911C 9912 2090 CONTINUE 9913 IF(NFUN2.EQ.1)GOTO5000 9914C 9915 IF(NFUN3.LT.2)GOTO2900 9916 DO2100IROW3=2,NFUN3 9917C 9918C *********************************************** 9919C ** STEP 2.1-- ** 9920C ** MOVE THE CUMULATIVE FUNCTION ** 9921C ** IN THE SECOND ROW OF IFUN31(.) ** 9922C ** TO THE FIRST ROW OF IFUN31(.). ** 9923C ** MOVE THE CUMULATIVE FUNCTION DERIVATIVE ** 9924C ** IN THE SECOND ROW OF OF IDER31(.) ** 9925C ** TO THE FIRST ROW OF IDER31(.). ** 9926C *********************************************** 9927C 9928 ISTEPN='2.1' 9929 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV4') 9930 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9931C 9932 JMAX=NCF3(2) 9933 DO1110J=1,JMAX 9934 IFUN31(1,J)=IFUN31(2,J) 9935 IFUN32(1,J)=IFUN32(2,J) 9936 1110 CONTINUE 9937 NCF3(1)=NCF3(2) 9938C 9939 JMAX=NCD3(2) 9940 DO1120J=1,JMAX 9941 IDER31(1,J)=IDER31(2,J) 9942 IDER32(1,J)=IDER32(2,J) 9943 1120 CONTINUE 9944 NCD3(1)=NCD3(2) 9945C 9946C ****************************************************** 9947C ** STEP 2.2-- ** 9948C ** DEFINE THE FUNCTIONS (IN IFUN31(.,.)) ** 9949C ** WHICH COMBINE ITERATIVELY AND SEQUENTIALLY ** 9950C ** EACH OF THE INDIVIDUAL MULTIPLICATIVE ** 9951C ** COMPONENTS. ** 9952C ****************************************************** 9953C 9954 ISTEPN='2.2' 9955 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV4') 9956 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 9957C 9958 IROW3M=IROW3-1 9959 IF(IOP2(IROW3M).EQ.'*')GOTO1200 9960 IF(IOP2(IROW3M).EQ.'/')GOTO1200 9961C 9962 WRITE(ICOUT,1061) 9963 1061 FORMAT('***** ERROR IN DERIV4--') 9964 CALL DPWRST('XXX','BUG ') 9965 WRITE(ICOUT,1062) 9966 1062 FORMAT('OPERATION NOT * OR /') 9967 CALL DPWRST('XXX','BUG ') 9968 WRITE(ICOUT,1063)IROW3M 9969 1063 FORMAT('IROW3M = ',I8) 9970 CALL DPWRST('XXX','BUG ') 9971 WRITE(ICOUT,1064)IOP2(IROW3M) 9972 1064 FORMAT('IOP2(IROW3M) = ',A6) 9973 CALL DPWRST('XXX','BUG ') 9974 IERROR='YES' 9975 GOTO9000 9976C 9977C TREAT EITHER THE * CASE OR THE / CASE. 9978C 9979 1200 CONTINUE 9980C 9981 K=0 9982 JMAX=NCF3(1) 9983 DO1210J=1,JMAX 9984 K=K+1 9985 IFUN31(2,K)=IFUN31(1,J) 9986 IFUN32(2,K)=IFUN32(1,J) 9987 1210 CONTINUE 9988C 9989 K=K+1 9990 IFUN31(2,K)=IOP2(IROW3M) 9991 IFUN32(2,K)=' ' 9992C 9993 JMAX=NCF2(IROW3) 9994 DO1215J=1,JMAX 9995 K=K+1 9996 IFUN31(2,K)=IFUN21(IROW3,J) 9997 IFUN32(2,K)=IFUN22(IROW3,J) 9998 1215 CONTINUE 9999C 10000 NCF3(2)=K 10001 NFUN3=NFUN2 10002C 10003C ******************************************************** 10004C ** STEP 2.3-- ** 10005C ** ITERATIVELY COMBINE IN SEQUENCE DERIVATIVES ** 10006C ** FOR THE MULTIPLICATIVE SUBSTRINGS. ** 10007C ******************************************************** 10008C 10009 ISTEPN='2.3' 10010 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV4') 10011 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10012C 10013 IROW3M=IROW3-1 10014 IF(IOP2(IROW3M).EQ.'*')GOTO2200 10015 IF(IOP2(IROW3M).EQ.'/')GOTO2300 10016C 10017 WRITE(ICOUT,2061) 10018 2061 FORMAT('***** ERROR IN DERIV4--') 10019 CALL DPWRST('XXX','BUG ') 10020 WRITE(ICOUT,2062) 10021 2062 FORMAT('OPERATION NOT * OR /') 10022 CALL DPWRST('XXX','BUG ') 10023 WRITE(ICOUT,2063)IROW3M 10024 2063 FORMAT('IROW3M = ',I8) 10025 CALL DPWRST('XXX','BUG ') 10026 WRITE(ICOUT,2064)IOP2(IROW3M) 10027 2064 FORMAT('IOP2(IROW3M) = ',A6) 10028 CALL DPWRST('XXX','BUG ') 10029 IERROR='YES' 10030 GOTO9000 10031C 10032C ******************************* 10033C ** STEP 2.4-- ** 10034C ** TREAT THE PRODUCT CASE. ** 10035C ******************************* 10036C 10037 2200 CONTINUE 10038C 10039 ISTEPN='2.4' 10040 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV4') 10041 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10042C 10043 IF(NCD3(1).EQ.1.AND. 10044 1IDER31(1,1).EQ.'0'.AND.IDER32(1,1).EQ.' '.AND. 10045 1NCD2(IROW3).EQ.1.AND. 10046 1IDER21(IROW3,1).EQ.'0'.AND.IDER22(IROW3,1).EQ.' ')GOTO2202 10047 GOTO2209 10048 2202 CONTINUE 10049 K=1 10050 IDER31(2,K)='0' 10051 IDER32(2,K)=' ' 10052 GOTO2249 10053 2209 CONTINUE 10054C 10055 K=0 10056 K=K+1 10057 IDER31(2,K)='(' 10058 IDER32(2,K)=' ' 10059C 10060 IF(NCD2(IROW3).EQ.1.AND. 10061 1IDER21(IROW3,1).EQ.'0'.AND.IDER22(IROW3,1).EQ.' ')GOTO2222 10062C 10063 JMAX=NCF3(1) 10064 DO2210J=1,JMAX 10065 K=K+1 10066 IDER31(2,K)=IFUN31(1,J) 10067 IDER32(2,K)=IFUN32(1,J) 10068 2210 CONTINUE 10069C 10070 IF(NCD2(IROW3).EQ.1.AND. 10071 1IDER21(IROW3,1).EQ.'0'.AND.IDER22(IROW3,1).EQ.' ')GOTO2222 10072C 10073 K=K+1 10074 IDER31(2,K)='*' 10075 IDER32(2,K)=' ' 10076C 10077 JMAX=NCD2(IROW3) 10078 DO2220J=1,JMAX 10079 K=K+1 10080 IDER31(2,K)=IDER21(IROW3,J) 10081 IDER32(2,K)=IDER22(IROW3,J) 10082 2220 CONTINUE 10083 2222 CONTINUE 10084C 10085 IF(NCD3(1).EQ.1.AND. 10086 1IDER31(1,1).EQ.'0'.AND.IDER32(1,1).EQ.' ')GOTO2242 10087C 10088 K=K+1 10089 IDER31(2,K)='+' 10090 IDER32(2,K)=' ' 10091C 10092 JMAX=NCF2(IROW3) 10093 DO2230J=1,JMAX 10094 K=K+1 10095 IDER31(2,K)=IFUN21(IROW3,J) 10096 IDER32(2,K)=IFUN22(IROW3,J) 10097 2230 CONTINUE 10098C 10099 IF(NCD3(1).EQ.1.AND. 10100 1IDER31(1,1).EQ.'1'.AND.IDER32(1,1).EQ.' ')GOTO2242 10101C 10102 K=K+1 10103 IDER31(2,K)='*' 10104 IDER32(2,K)=' ' 10105C 10106 JMAX=NCD3(1) 10107 DO2240J=1,JMAX 10108 K=K+1 10109 IDER31(2,K)=IDER31(1,J) 10110 IDER32(2,K)=IDER32(1,J) 10111 2240 CONTINUE 10112 2242 CONTINUE 10113C 10114 K=K+1 10115 IDER31(2,K)=')' 10116 IDER32(2,K)=' ' 10117C 10118 2249 CONTINUE 10119 NCD3(2)=K 10120 GOTO2400 10121C 10122C ******************************** 10123C ** STEP 2.5-- ** 10124C ** TREAT THE DIVISION CASE. ** 10125C ******************************** 10126C 10127 2300 CONTINUE 10128C 10129 ISTEPN='2.5' 10130 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV4') 10131 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10132C 10133 IF(NCD3(1).EQ.1.AND. 10134 1IDER31(1,1).EQ.'0'.AND.IDER32(1,1).EQ.' '.AND. 10135 1NCD2(IROW3).EQ.1.AND. 10136 1IDER21(IROW3,1).EQ.'0'.AND.IDER22(IROW3,1).EQ.' ')GOTO2302 10137 GOTO2309 10138 2302 CONTINUE 10139 K=1 10140 IDER31(2,K)='0' 10141 IDER32(2,K)=' ' 10142 GOTO2349 10143 2309 CONTINUE 10144C 10145 K=0 10146 K=K+1 10147 IDER31(2,K)='(' 10148 IDER32(2,K)=' ' 10149C 10150 K=K+1 10151 IDER31(2,K)='(' 10152 IDER32(2,K)=' ' 10153C 10154 IF(NCD3(1).EQ.1.AND. 10155 1IDER31(1,1).EQ.'0'.AND.IDER32(1,1).EQ.' ')GOTO2322 10156C 10157 JMAX=NCF2(IROW3) 10158 DO2310J=1,JMAX 10159 K=K+1 10160 IDER31(2,K)=IFUN21(IROW3,J) 10161 IDER32(2,K)=IFUN22(IROW3,J) 10162 2310 CONTINUE 10163C 10164 IF(NCD3(1).EQ.1.AND. 10165 1IDER31(1,1).EQ.'1'.AND.IDER32(1,1).EQ.' ')GOTO2322 10166C 10167 K=K+1 10168 IDER31(2,K)='*' 10169 IDER32(2,K)=' ' 10170C 10171 JMAX=NCD3(1) 10172 DO2320J=1,JMAX 10173 K=K+1 10174 IDER31(2,K)=IDER31(1,J) 10175 IDER32(2,K)=IDER32(1,J) 10176 2320 CONTINUE 10177 2322 CONTINUE 10178C 10179 IF(NCD2(IROW3).EQ.1.AND. 10180 1IDER21(IROW3,1).EQ.'0'.AND.IDER22 (IROW3,1).EQ.' ')GOTO2342 10181C 10182 K=K+1 10183 IDER31(2,K)='-' 10184 IDER32(2,K)=' ' 10185C 10186 JMAX=NCF3(1) 10187 DO2330J=1,JMAX 10188 K=K+1 10189 IDER31(2,K)=IFUN31(1,J) 10190 IDER32(2,K)=IFUN32(1,J) 10191 2330 CONTINUE 10192C 10193 IF(NCD2(IROW3).EQ.1.AND. 10194 1IDER21(IROW3,1).EQ.'1'.AND.IDER22 (IROW3,1).EQ.' ')GOTO2342 10195C 10196 K=K+1 10197 IDER31(2,K)='*' 10198 IDER32(2,K)=' ' 10199C 10200 JMAX=NCD2(IROW3) 10201 DO2340J=1,JMAX 10202 K=K+1 10203 IDER31(2,K)=IDER21(IROW3,J) 10204 IDER32(2,K)=IDER22(IROW3,J) 10205 2340 CONTINUE 10206 2342 CONTINUE 10207C 10208 K=K+1 10209 IDER31(2,K)=')' 10210 IDER32(2,K)=' ' 10211C 10212 K=K+1 10213 IDER31(2,K)='/' 10214 IDER32(2,K)=' ' 10215C 10216 K=K+1 10217 IDER31(2,K)='(' 10218 IDER32(2,K)=' ' 10219C 10220 JMAX=NCF2(IROW3) 10221 DO2350J=1,JMAX 10222 K=K+1 10223 IDER31(2,K)=IFUN21(IROW3,J) 10224 IDER32(2,K)=IFUN22(IROW3,J) 10225 2350 CONTINUE 10226C 10227 K=K+1 10228 IDER31(2,K)='**' 10229 IDER32(2,K)=' ' 10230 K=K+1 10231 IDER31(2,K)='2' 10232 IDER32(2,K)=' ' 10233 K=K+1 10234 IDER31(2,K)=')' 10235 IDER32(2,K)=' ' 10236C 10237 K=K+1 10238 IDER31(2,K)=')' 10239 IDER32(2,K)=' ' 10240C 10241 2349 CONTINUE 10242 NCD3(2)=K 10243 GOTO2400 10244C 10245 2400 CONTINUE 10246C 10247 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'RIV4')GOTO2100 10248 WRITE(ICOUT,2401) 10249 2401 FORMAT('***** IN THE MIDDLE OF DERIV4--') 10250 CALL DPWRST('XXX','BUG ') 10251 WRITE(ICOUT,2407)IROW3,NCF2(IROW3),NCD2(IROW3) 10252 2407 FORMAT('IROW3, NCF2(IROW3), NCD2(IROW3) = ',3I6) 10253 CALL DPWRST('XXX','BUG ') 10254 WRITE(ICOUT,2408)IROW3,NCF3(2),NCD3(2) 10255 2408 FORMAT('IROW3, NCF3(2), NCD3(2) = ',3I6) 10256 CALL DPWRST('XXX','BUG ') 10257C 10258 WRITE(ICOUT,999) 10259 CALL DPWRST('XXX','BUG ') 10260 IMAX=NCF2(IROW3) 10261 DO2440I=1,IMAX 10262 WRITE(ICOUT,2445)I,IFUN21(IROW3,I),IFUN22(IROW3,I) 10263 2445 FORMAT('I,IFUN21(IROW3,I),IFUN22(IROW3,I) = ',I8,2X,A4,2X,A4) 10264 CALL DPWRST('XXX','BUG ') 10265 2440 CONTINUE 10266C 10267 WRITE(ICOUT,999) 10268 CALL DPWRST('XXX','BUG ') 10269 IMAX=NCD2(IROW3) 10270 DO2450I=1,IMAX 10271 WRITE(ICOUT,2455)I,IDER21(IROW3,I),IDER22(IROW3,I) 10272 2455 FORMAT('I,IDER21(IROW3,I),IDER22(IROW3,I) = ',I8,2X,A4,2X,A4) 10273 CALL DPWRST('XXX','BUG ') 10274 2450 CONTINUE 10275C 10276 WRITE(ICOUT,999) 10277 CALL DPWRST('XXX','BUG ') 10278 IMAX=NCF3(2) 10279 DO2460I=1,IMAX 10280 WRITE(ICOUT,2465)I,IFUN31(IROW3,I),IFUN32(IROW3,I) 10281 2465 FORMAT('I,IFUN31(IROW3,I),IFUN32(IROW3,I) = ',I8,2X,A4,2X,A4) 10282 CALL DPWRST('XXX','BUG ') 10283 2460 CONTINUE 10284C 10285 WRITE(ICOUT,999) 10286 CALL DPWRST('XXX','BUG ') 10287 IMAX=NCD3(2) 10288 DO2470I=1,IMAX 10289 WRITE(ICOUT,2475)I,IDER31(IROW3,I),IDER32(IROW3,I) 10290 2475 FORMAT('I,IDER31(IROW3,I),IDER32(IROW3,I) = ',I8,2X,A4,2X,A4) 10291 CALL DPWRST('XXX','BUG ') 10292 2470 CONTINUE 10293C 10294 2100 CONTINUE 10295 2900 CONTINUE 10296C 10297C **************************************** 10298C ** STEP 3-- ** 10299C ** EXAMINE ROW 2 OF IDER31(.,.). ** 10300C ** CHANGE ALL (+ TO ( ** 10301C **************************************** 10302C 10303 ISTEPN='3' 10304 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV4') 10305 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10306C 10307 JMAX=NCD3(2) 10308 IF(JMAX.LE.0)GOTO3190 10309 K=0 10310 DO3100J=1,JMAX 10311 IF(J.EQ.1)GOTO3110 10312 JM1=J-1 10313 IF(IDER31(2,JM1).EQ.'('.AND.IDER32(2,JM1).EQ.' '.AND. 10314 1IDER31(2,J).EQ.'+'.AND.IDER32(2,J).EQ.' ')GOTO3100 10315 3110 CONTINUE 10316 K=K+1 10317 IDER31(2,K)=IDER31(2,J) 10318 IDER32(2,K)=IDER32(2,J) 10319 3100 CONTINUE 10320 NCD3(2)=K 10321 3190 CONTINUE 10322C 10323C ******************************************* 10324C ** STEP 4-- ** 10325C ** COPY OVER THE DERIVATIVE ** 10326C ** FROM ROW 2 OF IFUN31(.,.) ** 10327C ** TO ROW IROW1 (FIXED) OF IFUN1(.,.). ** 10328C ******************************************* 10329 5000 CONTINUE 10330C 10331 ISTEPN='4' 10332 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'RIV4') 10333 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10334C 10335 JMAX=NCD3(2) 10336 DO5100J=1,JMAX 10337 IDER11(IROW1,J)=IDER31(2,J) 10338 IDER12(IROW1,J)=IDER32(2,J) 10339 5100 CONTINUE 10340 NCD1(IROW1)=NCD3(2) 10341C 10342C ***************** 10343C ** STEP 90-- ** 10344C ** EXIT. ** 10345C ***************** 10346C 10347 9000 CONTINUE 10348 IF(IBUGA3.EQ.'OFF'.AND.ISUBRO.NE.'RIV4')GOTO9090 10349 WRITE(ICOUT,999) 10350 CALL DPWRST('XXX','BUG ') 10351 WRITE(ICOUT,9011) 10352 9011 FORMAT('AT THE END OF DERIV4--') 10353 CALL DPWRST('XXX','BUG ') 10354 WRITE(ICOUT,9012)IROW1 10355 9012 FORMAT('IROW1 = ',I8) 10356 CALL DPWRST('XXX','BUG ') 10357 WRITE(ICOUT,9013)NCD1(IROW1) 10358 9013 FORMAT('NCD1(IROW1) = ',I8) 10359 CALL DPWRST('XXX','BUG ') 10360 ITEMP=NCD1(IROW1) 10361 DO9020J=1,ITEMP 10362 WRITE(ICOUT,9021)J,IDER11(IROW1,J),IDER12(IROW1,J) 10363 9021 FORMAT('J,IDER11(IROW1,J),IDER12(IROW1,J) = ',I8,2X,A4,2X,A4) 10364 CALL DPWRST('XXX','BUG ') 10365 9020 CONTINUE 10366 9090 CONTINUE 10367C 10368 RETURN 10369 END 10370 SUBROUTINE DERIVC(MODEL,NUMCHA,PARAM,IPARN,IPARN2,NUMPV, 10371 1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 10372 1IVARN,IVARN2,NUMVAR,X0,XDER,IBUGA3,IBUGCO,IBUGEV,IERROR) 10373C 10374C PURPOSE--COMPUTE THE DERIVATIVE OF A FUNCTION 10375C AT THE POINT X0. 10376C ORIGINAL VERSION--NOVEMBER 1978. 10377C UPDATED --FEBRUARY 1979. 10378C UPDATED --JANUARY 1982. 10379C 10380C--------------------------------------------------------------------- 10381C 10382 CHARACTER*4 MODEL 10383 CHARACTER*4 IPARN 10384 CHARACTER*4 IPARN2 10385 CHARACTER*4 IVARN 10386 CHARACTER*4 IVARN2 10387 CHARACTER*4 IANGLU 10388 CHARACTER*4 ITYPEH 10389 CHARACTER*4 IW21HO 10390 CHARACTER*4 IW22HO 10391 CHARACTER*4 IBUGA3 10392 CHARACTER*4 IBUGCO 10393 CHARACTER*4 IBUGEV 10394 CHARACTER*4 IERROR 10395C 10396 CHARACTER*4 IH 10397 CHARACTER*4 IH2 10398C 10399 DIMENSION MODEL(*) 10400 DIMENSION PARAM(*) 10401 DIMENSION IPARN(*) 10402 DIMENSION IPARN2(*) 10403 DIMENSION IVARN(*) 10404 DIMENSION IVARN2(*) 10405 DIMENSION ILOCV(10) 10406C 10407 DIMENSION ITYPEH(*) 10408 DIMENSION IW21HO(*) 10409 DIMENSION IW22HO(*) 10410 DIMENSION W2HOLD(*) 10411C 10412C-----COMMON VARIABLES (GENERAL)----------------------------------------------- 10413C 10414 INCLUDE 'DPCOP2.INC' 10415C 10416C-----START POINT----------------------------------------------------- 10417C 10418 CUTOFF=0.001 10419 ACCUR=0.0000001 10420 MAXIT=10 10421 IPASS=2 10422C 10423 J2=0 10424 H=0.0 10425 X0MH=0.0 10426 X0PH=0.0 10427 WIDTH=0.0 10428 XDER2=0.0 10429 RATIO2=0.0 10430C 10431 IF(IBUGA3.EQ.'OFF')GOTO90 10432 WRITE(ICOUT,999) 10433 999 FORMAT(1X) 10434 CALL DPWRST('XXX','BUG ') 10435 WRITE(ICOUT,51) 10436 51 FORMAT('AT THE BEGINNING OF DERIVC--') 10437 CALL DPWRST('XXX','BUG ') 10438 WRITE(ICOUT,52)NUMCHA,NUMPV,NUMVAR,IBUGA3 10439 52 FORMAT('NUMCHA,NUMPV,NUMVAR,IBUGA3 = ',4I8) 10440 CALL DPWRST('XXX','BUG ') 10441 WRITE(ICOUT,54)(MODEL(J),J=1,NUMCHA) 10442 54 FORMAT('MODEL(I) = ',100A1) 10443 CALL DPWRST('XXX','BUG ') 10444 DO55I=1,NUMPV 10445 WRITE(ICOUT,56)I,IPARN(I),IPARN2(I),PARAM(I) 10446 56 FORMAT('I,IPARN(I),IPARN2(I),PARAM(I) = ', 10447 1I8,2X,A4,2X,A4,E15.7) 10448 CALL DPWRST('XXX','BUG ') 10449 55 CONTINUE 10450 WRITE(ICOUT,57)IANGLU 10451 57 FORMAT('IANGLU = ',A4) 10452 CALL DPWRST('XXX','BUG ') 10453 DO65I=1,NUMVAR 10454 WRITE(ICOUT,66)I,IVARN(I),IVARN2(I) 10455 66 FORMAT('I,IVARN(I),IVARN2(I) = ',I8,2X,A4,2X,A4) 10456 CALL DPWRST('XXX','BUG ') 10457 65 CONTINUE 10458 WRITE(ICOUT,68)X0 10459 68 FORMAT('X0 = ',E15.8) 10460 CALL DPWRST('XXX','BUG ') 10461 90 CONTINUE 10462C 10463C *************************************************** 10464C ** STEP 1-- ** 10465C ** DETERMINE THE LOCATIONS (IN THE LIST IPARN) ** 10466C ** OF THE VARIABLES OF DIFFERENTIATION. ** 10467C *************************************************** 10468C 10469 DO100I=1,NUMVAR 10470 IH=IVARN(I) 10471 IH2=IVARN2(I) 10472 DO200J=1,NUMPV 10473 J2=J 10474 IF(IH.EQ.IPARN(J).AND.IH2.EQ.IPARN2(J))GOTO210 10475 200 CONTINUE 10476 210 CONTINUE 10477 ILOCV(I)=J2 10478 100 CONTINUE 10479C 10480C ************************************************ 10481C ** STEP 3-- ** 10482C ** STEP THROUGH DIFFERENT WIDTHS ** 10483C ** (HALVING THE WIDTHS FOR EACH ITERATION). ** 10484C ************************************************ 10485C 10486 IF(X0.LE.CUTOFF)H=CUTOFF 10487 IF(X0.GT.CUTOFF)H=X0*1.01 10488 DO3100NUMIT=1,MAXIT 10489C 10490C ******************************************************** 10491C ** STEP 4-- ** 10492C ** FOR A GIVEN WIDTH (= 2*H), COMPUTE THE DIFFERENCE ** 10493C ** FORMULA D = (Y(X0+H) - Y(X0-H))/(2*H) ** 10494C ******************************************************** 10495C 10496 IF(NUMIT.GE.2)H=H/2.0 10497 X0MH=X0-H 10498 X0PH=X0+H 10499C 10500 X=X0MH 10501 DO3410K=1,NUMVAR 10502 JLOC=ILOCV(K) 10503 PARAM(JLOC)=X 10504 3410 CONTINUE 10505 CALL COMPIM(MODEL,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPV, 10506 1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,Y0MH, 10507 1IBUGCO,IBUGEV,IERROR) 10508C 10509 X=X0PH 10510 DO3420K=1,NUMVAR 10511 JLOC=ILOCV(K) 10512 PARAM(JLOC)=X 10513 3420 CONTINUE 10514 CALL COMPIM(MODEL,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPV, 10515 1IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,Y0PH, 10516 1IBUGCO,IBUGEV,IERROR) 10517C 10518 IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3402)X,Y0MH,Y0PH 10519 3402 FORMAT('X,Y0MH,Y0PH = ',3E15.8) 10520 IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ') 10521C 10522 WIDTH=2.0*H 10523 XDER=(Y0PH-Y0MH)/WIDTH 10524C 10525C ************************************** 10526C ** STEP 5-- ** 10527C ** WRITE OUT THE DERIVATIVE VALUE ** 10528C ************************************** 10529C 10530 WRITE(ICOUT,3103)WIDTH,XDER 10531 3103 FORMAT(E15.8,'* ',E15.8) 10532 CALL DPWRST('XXX','BUG ') 10533C 10534 IF(NUMIT.EQ.1)GOTO3195 10535 ABSXDE=ABS(XDER) 10536C 10537 DIFF2=ABS(XDER-XDER2) 10538 IF(ABSXDE.LE.CUTOFF.AND.DIFF2.LE.ACCUR)GOTO3170 10539 IF(ABSXDE.LE.CUTOFF.AND.DIFF2.GT.ACCUR)GOTO3190 10540 RATIO2=ABS(DIFF2/XDER) 10541 IF(ABSXDE.GT.CUTOFF.AND.RATIO2.LE.ACCUR)GOTO3170 10542 IF(ABSXDE.GT.CUTOFF.AND.RATIO2.GT.ACCUR)GOTO3190 10543C 10544 3170 CONTINUE 10545 GOTO3500 10546 3190 CONTINUE 10547 IF(IBUGA3.EQ.'ON')WRITE(ICOUT,3191)DIFF2,RATIO2,ABSXDE 10548 3191 FORMAT('DIFF2,RATIO2,ABSXDE = ',3E15.8) 10549 IF(IBUGA3.EQ.'ON')CALL DPWRST('XXX','BUG ') 10550CCCCC XDER3=XDER2 10551 3195 CONTINUE 10552 XDER2=XDER 10553C 10554 3100 CONTINUE 10555C 10556 3500 CONTINUE 10557 WRITE(ICOUT,999) 10558 CALL DPWRST('XXX','BUG ') 10559 WRITE(ICOUT,3511)XDER 10560 3511 FORMAT('DERIVATIVE VALUE = ',E15.8) 10561 CALL DPWRST('XXX','BUG ') 10562C 10563C ***************** 10564C ** STEP 90-- ** 10565C ** EXIT. ** 10566C ***************** 10567C 10568 IF(IBUGA3.EQ.'ON')THEN 10569 WRITE(ICOUT,999) 10570 CALL DPWRST('XXX','BUG ') 10571 WRITE(ICOUT,9011) 10572 9011 FORMAT('AT THE END OF DERIVC--') 10573 CALL DPWRST('XXX','BUG ') 10574 WRITE(ICOUT,9012)NUMCHA,NUMPV,NUMVAR,IBUGA3 10575 9012 FORMAT('NUMCHA,NUMPV,NUMVAR,IBUGA3 = ',4I8) 10576 CALL DPWRST('XXX','BUG ') 10577 WRITE(ICOUT,9014)(MODEL(J),J=1,MIN(100,NUMCHA)) 10578 9014 FORMAT('MODEL(I) = ',100A1) 10579 CALL DPWRST('XXX','BUG ') 10580 DO9015I=1,NUMPV 10581 WRITE(ICOUT,9016)I,IPARN(I),IPARN2(I),PARAM(I) 10582 9016 FORMAT('I,IPARN(I),IPARN2(I),PARAM(I) = ', 10583 1 I8,2(2X,A4),G15.7) 10584 CALL DPWRST('XXX','BUG ') 10585 9015 CONTINUE 10586 WRITE(ICOUT,9028)X0 10587 9028 FORMAT('X0 = ',E15.8) 10588 CALL DPWRST('XXX','BUG ') 10589 WRITE(ICOUT,9031)H,WIDTH,X0MH,X0PH 10590 9031 FORMAT('H,WIDTH,X0MH,X0PH = ',4E15.7) 10591 CALL DPWRST('XXX','BUG ') 10592 WRITE(ICOUT,9032)Y0MH,Y0PH,XDER,XDER2 10593 9032 FORMAT('Y0MH,Y0PH,XDER,XDER2 = ',4E15.7) 10594 CALL DPWRST('XXX','BUG ') 10595 ENDIF 10596C 10597 RETURN 10598 END 10599 SUBROUTINE DEXCDF(X,CDF) 10600C 10601C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION 10602C FUNCTION VALUE FOR THE DOUBLE EXPONENTIAL 10603C (LAPLACE) DISTRIBUTION WITH MEAN = 0 AND 10604C STANDARD DEVIATION = SQRT(2). 10605C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS 10606C THE PROBABILITY DENSITY FUNCTION 10607C F(X) = 0.5*EXP(-ABS(X)). 10608C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT 10609C WHICH THE CUMULATIVE DISTRIBUTION 10610C FUNCTION IS TO BE EVALUATED. 10611C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE 10612C DISTRIBUTION FUNCTION VALUE. 10613C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION 10614C FUNCTION VALUE CDF. 10615C PRINTING--NONE. 10616C RESTRICTIONS--NONE. 10617C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 10618C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. 10619C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 10620C LANGUAGE--ANSI FORTRAN. 10621C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE 10622C DISTRIBUTIONS--2, 1970, PAGES 22-36. 10623C WRITTEN BY--JAMES J. FILLIBEN 10624C STATISTICAL ENGINEERING LABORATORY (205.03) 10625C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10626C GAITHERSBURG, MD 20899-8980 10627C PHONE: 301-921-2315 10628C ORIGINAL VERSION--APRIL 1994. 10629C 10630C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 10631C 10632C--------------------------------------------------------------------- 10633C 10634 INCLUDE 'DPCOP2.INC' 10635C 10636C--------------------------------------------------------------------- 10637C 10638C CHECK THE INPUT ARGUMENTS FOR ERRORS. 10639C NO INPUT ARGUMENT ERRORS POSSIBLE 10640C FOR THIS DISTRIBUTION. 10641C 10642C-----START POINT----------------------------------------------------- 10643C 10644 IF(X.LE.0.0)CDF=0.5*EXP(X) 10645 IF(X.GT.0.0)CDF=1.0-(0.5*EXP(-X)) 10646C 10647 RETURN 10648 END 10649 SUBROUTINE DEXLI1(Y,N,ALOC,SCALE, 10650 1 ALIK,AIC,AICC,BIC, 10651 1 ISUBRO,IBUGA3,IERROR) 10652C 10653C PURPOSE--THIS ROUTINE COMPUTES THE LIKELIHOOD FUNCTION FOR 10654C THE DOUBLE EXPONENTIAL (LAPLACE) DISTRIBUTION. THIS 10655C IS FOR THE RAW DATA CASE (I.E., NO GROUPING AND NO 10656C CENSORING). 10657C 10658C IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN 10659C PERFORMED. 10660C 10661C REEFERENCE--NORTON, "THE DOUBLE EXPONENTIAL DISTRIBUTION: USING 10662C CALCULUS TO FIND A MAXIMUM LIKELIHOOD ESTIMATOR", 10663C THE AMERICAN STATISTICIAN, VOL. 28, NO. 2, 1984, 10664C PP. 135-136. 10665C WRITTEN BY--JAMES J. FILLIBEN 10666C STATISTICAL ENGINEERING DIVISION 10667C INFORMATION TECHNOLOGY LABORATORY 10668C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10669C GAITHERSBURG, MD 20899-8980 10670C PHONE--301-975-2855 10671C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 10672C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 10673C LANGUAGE--ANSI FORTRAN (1977) 10674C VERSION NUMBER--2010/6 10675C ORIGINAL VERSION--JUNE 2010. 10676C 10677C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 10678C 10679 CHARACTER*4 ISUBRO 10680 CHARACTER*4 IBUGA3 10681 CHARACTER*4 IERROR 10682C 10683 CHARACTER*4 IWRITE 10684C 10685 CHARACTER*4 ISUBN1 10686 CHARACTER*4 ISUBN2 10687 CHARACTER*4 ISTEPN 10688C 10689 DOUBLE PRECISION DX 10690 DOUBLE PRECISION DS 10691 DOUBLE PRECISION DU 10692 DOUBLE PRECISION DN 10693 DOUBLE PRECISION DNP 10694 DOUBLE PRECISION DLIK 10695 DOUBLE PRECISION DSUM1 10696 DOUBLE PRECISION DTERM1 10697 DOUBLE PRECISION DTERM2 10698 DOUBLE PRECISION DTERM3 10699C 10700C--------------------------------------------------------------------- 10701C 10702 DIMENSION Y(*) 10703C 10704C--------------------------------------------------------------------- 10705C 10706 INCLUDE 'DPCOP2.INC' 10707C 10708C-----START POINT----------------------------------------------------- 10709C 10710 ISUBN1='DEXL' 10711 ISUBN2='I1 ' 10712C 10713 IERROR='NO' 10714C 10715 ALIK=-99.0 10716 AIC=-99.0 10717 AICC=-99.0 10718 BIC=-99.0 10719C 10720 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'XLI1')THEN 10721 WRITE(ICOUT,999) 10722 999 FORMAT(1X) 10723 CALL DPWRST('XXX','WRIT') 10724 WRITE(ICOUT,51) 10725 51 FORMAT('**** AT THE BEGINNING OF DEXLI1--') 10726 CALL DPWRST('XXX','WRIT') 10727 WRITE(ICOUT,52)IBUGA3,ISUBRO 10728 52 FORMAT('IBUGA3,ISUBRO = ',A4,2X,A4) 10729 CALL DPWRST('XXX','WRIT') 10730 WRITE(ICOUT,55)N,ALOC,SCALE 10731 55 FORMAT('N,ALOC,SCALE = ',I8,2G15.7) 10732 CALL DPWRST('XXX','WRIT') 10733 DO56I=1,MIN(N,100) 10734 WRITE(ICOUT,57)I,Y(I) 10735 57 FORMAT('I,Y(I) = ',I8,G15.7) 10736 CALL DPWRST('XXX','WRIT') 10737 56 CONTINUE 10738 ENDIF 10739C 10740C ****************************************** 10741C ** STEP 1-- ** 10742C ** COMPUTE LIKELIHOOD FUNCTION ** 10743C ****************************************** 10744C 10745 ISTEPN='1' 10746 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'XLI1') 10747 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10748C 10749 IERFLG=0 10750 IERROR='NO' 10751 IWRITE='OFF' 10752C 10753C DOUBLE EXPONENTIAL LOG-LIKELIHOOD FUNCTION IS: 10754C 10755C -N*LOG(2) - SUM[i=1 TO N][ABS(X(i) - LOC)/SCALE] 10756C 10757 DN=DBLE(N) 10758 DS=DBLE(SCALE) 10759 DU=DBLE(ALOC) 10760 DTERM1=-DN*DLOG(2.0D0) 10761 DSUM1=0.0D0 10762 DO1000I=1,N 10763 DX=DBLE(Y(I)) 10764 DTERM2=DABS(DX - DU)/DS 10765 DSUM1=DSUM1 + DTERM2 10766 1000 CONTINUE 10767C 10768 DLIK=DTERM1 - DSUM1 10769 ALIK=REAL(DLIK) 10770 DNP=2.0D0 10771 AIC=REAL(-2.0D0*DLIK + 2.0D0*DNP) 10772 DTERM3=(2.0D0*DNP*(DNP+1.0D0))/(DN-DNP-1.0D0) 10773 AICC=REAL(-2.0D0*DLIK + 2.0D0*DNP + DTERM3) 10774 BIC=REAL(-2.0D0*DLIK + DNP*LOG(DN)) 10775C 10776 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'XLI1')THEN 10777 WRITE(ICOUT,999) 10778 CALL DPWRST('XXX','WRIT') 10779 WRITE(ICOUT,9011) 10780 9011 FORMAT('**** AT THE END OF DEXLI1--') 10781 CALL DPWRST('XXX','WRIT') 10782 WRITE(ICOUT,9013)DSUM1,DTERM1,DTERM3 10783 9013 FORMAT('DSUM1,DTERM1,DTERM3 = ',3G15.7) 10784 CALL DPWRST('XXX','WRIT') 10785 WRITE(ICOUT,9014)ALIK,AIC,AICC,BIC 10786 9014 FORMAT('ALIK,AIC,AICC,BIC = ',4G15.7) 10787 CALL DPWRST('XXX','WRIT') 10788 ENDIF 10789C 10790 RETURN 10791 END 10792 SUBROUTINE DEXML1(Y,N,XTEMP,ICASE,MAXNXT, 10793 1 ALOWLO,AUPPLO,ALOWSC,AUPPSC, 10794 1 ALPHA,NUMALP,NUMOUT, 10795 1 XMEAN,XMED,XSD,XMIN,XMAX, 10796 1 ALOC,ASCALE, 10797 1 ISUBRO,IBUGA3,IERROR) 10798C 10799C PURPOSE--THIS ROUTINE COMPUTES THE MAXIMUM LIKELIHOOD ESTIMATES 10800C FOR THE DOUBLE EXPONENTIAL (LAPLACE) DISTRIBUTION FOR 10801C THE RAW DATA CASE (I.E., NO CENSORING AND NO GROUPING). 10802C IT WILL OPTIONALLY RETURN THE CONFIDENCE INTERVALS FOR 10803C THE LOCATION AND SCALE PARAMETERS. 10804C 10805C IT IS ASSUMED THAT BASIC ERROR CHECKING HAS ALREADY BEEN 10806C PERFORMED. 10807C 10808C PUT THIS IN A SEPARATE ROUTINE AS IT MAY BE CALLED 10809C FROM MULTIPLE PLACES (DPMLDE WILL GENERATE THE OUTPUT 10810C FOR THE DOUBLE EXPONENTIAL MLE COMMAND). 10811C 10812C WRITTEN BY--ALAN HECKERT 10813C STATISTICAL ENGINEERING DIVISION 10814C INFORMATION TECHNOLOGY LABORATORY 10815C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10816C GAITHERSBURG, MD 20899-8980 10817C PHONE--301-975-2899 10818C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 10819C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 10820C LANGUAGE--ANSI FORTRAN (1977) 10821C VERSION NUMBER--2009/10 10822C ORIGINAL VERSION--OCTOBER 2009. EXTRACTED AS A SEPARATE 10823C SUBROUTINE (FROM DPMLDE) 10824C 10825C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 10826C 10827 DIMENSION ALOWLO(*) 10828 DIMENSION AUPPLO(*) 10829 DIMENSION ALOWSC(*) 10830 DIMENSION AUPPSC(*) 10831 DIMENSION ALPHA(*) 10832C 10833 CHARACTER*4 ISUBRO 10834 CHARACTER*4 IBUGA3 10835 CHARACTER*4 IERROR 10836C 10837 CHARACTER*4 IWRITE 10838 CHARACTER*40 IDIST 10839 CHARACTER*4 ISUBN1 10840 CHARACTER*4 ISUBN2 10841 CHARACTER*4 ISTEPN 10842C 10843 INTEGER IFLAG 10844 INTEGER ICASE 10845C 10846 DOUBLE PRECISION DN 10847 DOUBLE PRECISION DSUM 10848C 10849C--------------------------------------------------------------------- 10850C 10851 DIMENSION Y(*) 10852 DIMENSION XTEMP(*) 10853C 10854C--------------------------------------------------------------------- 10855C 10856 INCLUDE 'DPCOP2.INC' 10857C 10858C-----START POINT----------------------------------------------------- 10859C 10860 ISUBN1='DEXM' 10861 ISUBN2='L1 ' 10862 IWRITE='OFF' 10863 IERROR='NO' 10864C 10865 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'XML1')THEN 10866 WRITE(ICOUT,999) 10867 999 FORMAT(1X) 10868 CALL DPWRST('XXX','WRIT') 10869 WRITE(ICOUT,51) 10870 51 FORMAT('**** AT THE BEGINNING OF DEXML1--') 10871 CALL DPWRST('XXX','WRIT') 10872 WRITE(ICOUT,52)IBUGA3,ISUBRO,N,MAXNXT,ICASE 10873 52 FORMAT('IBUGA3,ISUBRO,N,MAXNXT,ICASE = ',2(A4,2X),3I8) 10874 CALL DPWRST('XXX','WRIT') 10875 DO56I=1,MIN(N,100) 10876 WRITE(ICOUT,57)I,Y(I) 10877 57 FORMAT('I,Y(I) = ',I8,G15.7) 10878 CALL DPWRST('XXX','WRIT') 10879 56 CONTINUE 10880 ENDIF 10881C 10882C ****************************************** 10883C ** STEP 1-- ** 10884C ** CARRY OUT CALCULATIONS ** 10885C ** FOR DOUBLE EXPONENTIAL MLE ESTIMATE ** 10886C ****************************************** 10887C 10888 ISTEPN='1' 10889 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'XML1') 10890 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) 10891C 10892 IDIST='DOUBLE EXPONENTIAL' 10893 IFLAG=0 10894 CALL SUMRAW(Y,N,IDIST,IFLAG, 10895 1 XMEAN,XVAR,XSD,XMIN,XMAX, 10896 1 ISUBRO,IBUGA3,IERROR) 10897 CALL MEDIAN(Y,N,IWRITE,XTEMP,MAXNXT,XMED,IBUGA3,IERROR) 10898 ALOC=XMED 10899C 10900 DN=DBLE(N) 10901 DSUM=0.0D0 10902 DO4110I=1,N 10903 DSUM=DSUM + DBLE(ABS(Y(I) - XMED)) 10904 4110 CONTINUE 10905 ASCALE=REAL(DSUM/DN) 10906C 10907 IF(ICASE.EQ.0)GOTO9000 10908C 10909 AN=REAL(N) 10910 IDF=2*N-1 10911 DO4120I=1,NUMALP 10912C 10913 ALP=ALPHA(I) 10914 P1=ALP/2.0 10915 P2=1.0-(ALP/2.0) 10916C 10917 CALL CHSPPF(P1,IDF,AUPP) 10918 CALL CHSPPF(P2,IDF,ALOW) 10919 ALOWSC(I)=XMEAN + 2.0*REAL(DSUM)/ALOW 10920 AUPPSC(I)=XMEAN + 2.0*REAL(DSUM)/AUPP 10921C 10922 CALL NORPPF(P2,APPF2) 10923 ALOWLO(I)=ALOC - APPF2*REAL(DSUM)/(AN*SQRT(AN-APPF2**2)) 10924 AUPPLO(I)=ALOC + APPF2*REAL(DSUM)/(AN*SQRT(AN-APPF2**2)) 10925C 10926 4120 CONTINUE 10927 NUMOUT=NUMALP 10928C 10929 9000 CONTINUE 10930 IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'XML1')THEN 10931 WRITE(ICOUT,999) 10932 CALL DPWRST('XXX','WRIT') 10933 WRITE(ICOUT,9011) 10934 9011 FORMAT('**** AT THE END OF DEXML1--') 10935 CALL DPWRST('XXX','WRIT') 10936 WRITE(ICOUT,9055)N,XMEAN,XMED,XSD,XMIN,XMAX 10937 9055 FORMAT('N,XMEAN,XMED,XSD,XMIN,XMAX = ',I8,5G15.7) 10938 CALL DPWRST('XXX','WRIT') 10939 DO9060I=1,NUMALP 10940 WRITE(ICOUT,9065)I,ALPHA(I),ALOWLO(I),AUPPLO(I),ALOWSC(I), 10941 1 AUPPSC(I) 10942 9065 FORMAT('I,ALPHA(I),ALOWLO(I),AUPPLO(I),ALOWSC(I),AUPPSC(I)=', 10943 1 I8,5G15.7) 10944 CALL DPWRST('XXX','WRIT') 10945 9060 CONTINUE 10946 ENDIF 10947C 10948 RETURN 10949 END 10950 SUBROUTINE DEXPDF(X,PDF) 10951C 10952C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY 10953C FUNCTION VALUE FOR THE DOUBLE EXPONENTIAL 10954C (LAPLACE) DISTRIBUTION WITH MEAN = 0 AND 10955C STANDARD DEVIAITON = SQRT(2). 10956C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS 10957C THE PROBABILITY DENSITY FUNCTION 10958C F(X) = 0.5*EXP(-ABS(X)). 10959C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT 10960C WHICH THE PROBABILITY DENSITY 10961C FUNCTION IS TO BE EVALUATED. 10962C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY 10963C DENSITY FUNCTION VALUE. 10964C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY 10965C FUNCTION VALUE PDF. 10966C PRINTING--NONE. 10967C RESTRICTIONS--NONE. 10968C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 10969C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. 10970C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 10971C LANGUAGE--ANSI FORTRAN. 10972C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE 10973C DISTRIBUTIONS--2, 1970, PAGES 22-36. 10974C WRITTEN BY--JAMES J. FILLIBEN 10975C STATISTICAL ENGINEERING LABORATORY (205.03) 10976C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 10977C GAITHERSBURG, MD 20899-8980 10978C PHONE: 301-921-2315 10979C ORIGINAL VERSION--APRIL 1994. 10980C 10981C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 10982C 10983C--------------------------------------------------------------------- 10984C 10985 INCLUDE 'DPCOP2.INC' 10986C 10987C--------------------------------------------------------------------- 10988C 10989C CHECK THE INPUT ARGUMENTS FOR ERRORS. 10990C NO INPUT ARGUMENT ERRORS POSSIBLE 10991C FOR THIS DISTRIBUTION. 10992C 10993C-----START POINT----------------------------------------------------- 10994C 10995 ARG=X 10996 IF(X.LT.0.0)ARG=-X 10997 PDF=0.5*EXP(-ARG) 10998C 10999 RETURN 11000 END 11001 SUBROUTINE DEXPPF(P,PPF) 11002C 11003C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT 11004C FUNCTION VALUE FOR THE DOUBLE EXPONENTIAL 11005C (LAPLACE) DISTRIBUTION WITH MEAN = 0 AND 11006C STANDARD DEVIATION = SQRT(2). 11007C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS 11008C THE PROBABILITY DENSITY FUNCTION 11009C F(X) = 0.5*EXP(-ABS(X)). 11010C NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION 11011C IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE 11012C DISTRIBUTION FUNCTION OF THE DISTRIBUTION. 11013C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE 11014C (BETWEEN 0.0 AND 1.0) 11015C AT WHICH THE PERCENT POINT 11016C FUNCTION IS TO BE EVALUATED. 11017C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT 11018C POINT FUNCTION VALUE. 11019C OUTPUT--THE SINGLE PRECISION PERCENT POINT 11020C FUNCTION VALUE PPF. 11021C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 11022C RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY. 11023C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 11024C FORTRAN LIBRARY SUBROUTINES NEEDED--LOG. 11025C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 11026C LANGUAGE--ANSI FORTRAN (1977) 11027C REFERENCES--FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION 11028C OF THE LOCATION PARAMETER OF A SYMMETRIC 11029C DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION, 11030C PRINCETON UNIVERSITY), 1969, PAGES 21-44, 229-231. 11031C --FILLIBEN, 'THE PERCENT POINT FUNCTION', 11032C (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31. 11033C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE 11034C DISTRIBUTIONS--2, 1970, PAGES 22-36. 11035C WRITTEN BY--JAMES J. FILLIBEN 11036C STATISTICAL ENGINEERING DIVISION 11037C INFORMATION TECHNOLOGY LABORATORY 11038C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11039C GAITHERSBURG, MD 20899-8980 11040C PHONE--301-921-3651 11041C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11042C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11043C LANGUAGE--ANSI FORTRAN (1966) 11044C EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS 11045C DENOTED BY QUOTES RATHER THAN NH. 11046C VERSION NUMBER--82/7 11047C ORIGINAL VERSION--JUNE 1972. 11048C UPDATED --SEPTEMBER 1975. 11049C UPDATED --NOVEMBER 1975. 11050C UPDATED --DECEMBER 1981. 11051C UPDATED --MAY 1982. 11052C 11053C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 11054C 11055C--------------------------------------------------------------------- 11056C 11057 INCLUDE 'DPCOP2.INC' 11058C 11059C-----START POINT----------------------------------------------------- 11060C 11061C CHECK THE INPUT ARGUMENTS FOR ERRORS 11062C 11063 IF(P.LE.0.0.OR.P.GE.1.0)GOTO50 11064 GOTO90 11065 50 WRITE(ICOUT,1) 11066 CALL DPWRST('XXX','BUG ') 11067 WRITE(ICOUT,46)P 11068 CALL DPWRST('XXX','BUG ') 11069 RETURN 11070 90 CONTINUE 11071 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 11072 1'DEXPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 11073 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 11074C 11075 PHOLD=P 11076CCCCC IF(PHOLD.LE.0.5)PPF=LOG(2.0*PHOLD) 11077CCCCC IF(PHOLD.GT.0.5)PPF=-LOG(2.0*(1.0-PHOLD)) 11078 IF(PHOLD.LE.0.5)PPF=LOG(2.0*PHOLD) 11079 IF(PHOLD.GT.0.5)PPF=-LOG(2.0*(1.0-PHOLD)) 11080C 11081 RETURN 11082 END 11083 DOUBLE PRECISION FUNCTION DEXPRL (X) 11084C***BEGIN PROLOGUE DEXPRL 11085C***PURPOSE Calculate the relative error exponential (EXP(X)-1)/X. 11086C***LIBRARY SLATEC (FNLIB) 11087C***CATEGORY C4B 11088C***TYPE DOUBLE PRECISION (EXPREL-S, DEXPRL-D, CEXPRL-C) 11089C***KEYWORDS ELEMENTARY FUNCTIONS, EXPONENTIAL, FIRST ORDER, FNLIB 11090C***AUTHOR Fullerton, W., (LANL) 11091C***DESCRIPTION 11092C 11093C Evaluate EXPREL(X) = (EXP(X) - 1.0) / X. For small ABS(X) the 11094C Taylor series is used. If X is negative the reflection formula 11095C EXPREL(X) = EXP(X) * EXPREL(ABS(X)) 11096C may be used. This reflection formula will be of use when the 11097C evaluation for small ABS(X) is done by Chebyshev series rather than 11098C Taylor series. 11099C 11100C***REFERENCES (NONE) 11101C***ROUTINES CALLED D1MACH 11102C***REVISION HISTORY (YYMMDD) 11103C 770801 DATE WRITTEN 11104C 890531 Changed all specific intrinsics to generic. (WRB) 11105C 890911 Removed unnecessary intrinsics. (WRB) 11106C 890911 REVISION DATE from Version 3.2 11107C 891214 Prologue converted to Version 4.0 format. (BAB) 11108C***END PROLOGUE DEXPRL 11109C 11110C-----COMMON---------------------------------------------------------- 11111C 11112 INCLUDE 'DPCOMC.INC' 11113 INCLUDE 'DPCOP2.INC' 11114C 11115 DOUBLE PRECISION X, ABSX, ALNEPS, XBND, XLN, XN 11116 LOGICAL FIRST 11117 SAVE NTERMS, XBND, FIRST 11118 DATA FIRST /.TRUE./ 11119C 11120 DEXPRL = 0.0D0 11121C 11122C***FIRST EXECUTABLE STATEMENT DEXPRL 11123 IF (FIRST) THEN 11124 ALNEPS = LOG(D1MACH(3)) 11125 XN = 3.72D0 - 0.3D0*ALNEPS 11126 XLN = LOG((XN+1.0D0)/1.36D0) 11127 NTERMS = INT(XN - (XN*XLN+ALNEPS)/(XLN+1.36D0) + 1.5D0) 11128 XBND = D1MACH(3) 11129 ENDIF 11130 FIRST = .FALSE. 11131C 11132 ABSX = ABS(X) 11133 IF (ABSX.GT.0.5D0) DEXPRL = (EXP(X)-1.0D0)/X 11134 IF (ABSX.GT.0.5D0) RETURN 11135C 11136 DEXPRL = 1.0D0 11137 IF (ABSX.LT.XBND) RETURN 11138C 11139 DEXPRL = 0.0D0 11140 DO 20 I=1,NTERMS 11141 DEXPRL = 1.0D0 + DEXPRL*X/(NTERMS+2-I) 11142 20 CONTINUE 11143C 11144 RETURN 11145 END 11146 SUBROUTINE DEXRAN(N,ISEED,X) 11147C 11148C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N 11149C FROM THE DOUBLE EXPONENTIAL 11150C (LAPLACE) DISTRIBUTION WITH MEAN = 0 AND 11151C STANDARD DEVIATION = SQRT(2). 11152C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS 11153C THE PROBABILITY DENSITY FUNCTION 11154C F(X) = 0.5*EXP(-ABS(X)). 11155C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER 11156C OF RANDOM NUMBERS TO BE 11157C GENERATED. 11158C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR 11159C (OF DIMENSION AT LEAST N) 11160C INTO WHICH THE GENERATED 11161C RANDOM SAMPLE WILL BE PLACED. 11162C OUTPUT--A RANDOM SAMPLE OF SIZE N 11163C FROM THE DOUBLE EXPONENTIAL 11164C (LAPLACE) DISTRIBUTION WITH MEAN = 0 AND 11165C STANDARD DEVIATION = SQRT(2). 11166C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 11167C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 11168C OF N FOR THIS SUBROUTINE. 11169C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. 11170C FORTRAN LIBRARY SUBROUTINES NEEDED--LOG. 11171C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 11172C LANGUAGE--ANSI FORTRAN (1977) 11173C REFERENCES--TOCHER, THE ART OF SIMULATION, 11174C 1963, PAGES 14-15. 11175C --HAMMERSLEY AND HANDSCOMB, MONTE CARLO METHODS, 11176C 1964, PAGE 36. 11177C --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION 11178C OF THE LOCATION PARAMETER OF A SYMMETRIC 11179C DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION, 11180C PRINCETON UNIVERSITY), 1969, PAGE 231. 11181C --FILLIBEN, 'THE PERCENT POINT FUNCTION', 11182C (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31. 11183C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE 11184C DISTRIBUTIONS--2, 1970, PAGES 22-36. 11185C WRITTEN BY--JAMES J. FILLIBEN 11186C STATISTICAL ENGINEERING DIVISION 11187C INFORMATION TECHNOLOGY LABORATORY 11188C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11189C GAITHERSBURG, MD 20899-8980 11190C PHONE--301-921-3651 11191C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 11192C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 11193C LANGUAGE--ANSI FORTRAN (1966) 11194C VERSION NUMBER--82/7 11195C ORIGINAL VERSION--JUNE 1972. 11196C UPDATED --SEPTEMBER 1975. 11197C UPDATED --NOVEMBER 1975. 11198C UPDATED --DECEMBER 1981. 11199C UPDATED --MAY 1982. 11200C 11201C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 11202C 11203C--------------------------------------------------------------------- 11204C 11205 DIMENSION X(*) 11206C 11207C--------------------------------------------------------------------- 11208C 11209 INCLUDE 'DPCOP2.INC' 11210C 11211C-----START POINT----------------------------------------------------- 11212C 11213C CHECK THE INPUT ARGUMENTS FOR ERRORS 11214C 11215 IF(N.LT.1)GOTO50 11216 GOTO90 11217 50 WRITE(ICOUT, 5) 11218 CALL DPWRST('XXX','BUG ') 11219 WRITE(ICOUT,47)N 11220 CALL DPWRST('XXX','BUG ') 11221 RETURN 11222 90 CONTINUE 11223 5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 11224 1'DEXRAN SUBROUTINE IS NON-POSITIVE *****') 11225 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') 11226C 11227C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; 11228C 11229 CALL UNIRAN(N,ISEED,X) 11230C 11231C GENERATE N DOUBLE EXPONENTIAL RANDOM NUMBERS 11232C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. 11233C 11234 DO100I=1,N 11235 Q=X(I) 11236CCCCC IF(Q.LE.0.5)X(I)=LOG(2.0*Q) 11237CCCCC IF(Q.GT.0.5)X(I)=-LOG(2.0*(1.0-Q)) 11238 IF(Q.LE.0.5)X(I)=LOG(2.0*Q) 11239 IF(Q.GT.0.5)X(I)=-LOG(2.0*(1.0-Q)) 11240 100 CONTINUE 11241C 11242 RETURN 11243 END 11244 SUBROUTINE DEXSF(P,SF) 11245C 11246C PURPOSE--THIS SUBROUTINE COMPUTES THE SPARSITY 11247C FUNCTION VALUE FOR THE DOUBLE EXPONENTIAL 11248C (LAPLACE) DISTRIBUTION WITH MEAN = 0 AND 11249C STANDARD DEVIATION = SQRT(2). 11250C THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS 11251C THE PROBABILITY DENSITY FUNCTION 11252C F(X) = 0.5*EXP(-ABS(X)). 11253C NOTE THAT THE SPARSITY FUNCTION OF A DISTRIBUTION 11254C IS THE DERIVATIVE OF THE PERCENT POINT FUNCTION, 11255C AND ALSO IS THE RECIPROCAL OF THE PROBABILITY 11256C DENSITY FUNCTION (BUT IN UNITS OF P RATHER THAN X). 11257C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE 11258C (BETWEEN 0.0 AND 1.0) 11259C AT WHICH THE SPARSITY 11260C FUNCTION IS TO BE EVALUATED. 11261C OUTPUT ARGUMENTS--SF = THE SINGLE PRECISION 11262C SPARSITY FUNCTION VALUE. 11263C OUTPUT--THE SINGLE PRECISION SPARSITY 11264C FUNCTION VALUE SF. 11265C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 11266C RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, EXCLUSIVELY. 11267C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 11268C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 11269C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 11270C LANGUAGE--ANSI FORTRAN. 11271C REFERENCES--FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION 11272C OF THE LOCATION PARAMETER OF A SYMMETRIC 11273C DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION, 11274C PRINCETON UNIVERSITY), 1969, PAGES 21-44, 229-231. 11275C --FILLIBEN, 'THE PERCENT POINT FUNCTION', 11276C (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31. 11277C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE 11278C DISTRIBUTIONS--2, 1970, PAGES 22-36. 11279C WRITTEN BY--JAMES J. FILLIBEN 11280C STATISTICAL ENGINEERING LABORATORY (205.03) 11281C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 11282C GAITHERSBURG, MD 20899-8980 11283C PHONE: 301-921-2315 11284C ORIGINAL VERSION--APRIL 1994. 11285C 11286C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 11287C 11288C--------------------------------------------------------------------- 11289C 11290 INCLUDE 'DPCOP2.INC' 11291C 11292C--------------------------------------------------------------------- 11293C 11294C CHECK THE INPUT ARGUMENTS FOR ERRORS 11295C 11296 IF(P.LE.0.0.OR.P.GE.1.0)GOTO50 11297 GOTO90 11298 50 WRITE(ICOUT,1) 11299 CALL DPWRST('XXX','BUG ') 11300 WRITE(ICOUT,46)P 11301 CALL DPWRST('XXX','BUG ') 11302 RETURN 11303 90 CONTINUE 11304 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 11305 1' DEXSF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 11306 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 11307C 11308 IF(P.LE.0.5)SF=1.0/P 11309 IF(P.GT.0.5)SF=1.0/(1.0-P) 11310C 11311 RETURN 11312 END 11313 DOUBLE PRECISION FUNCTION DFAC (N) 11314C***BEGIN PROLOGUE DFAC 11315C***PURPOSE Compute the factorial function. 11316C***LIBRARY SLATEC (FNLIB) 11317C***CATEGORY C1 11318C***TYPE DOUBLE PRECISION (FAC-S, DFAC-D) 11319C***KEYWORDS FACTORIAL, FNLIB, SPECIAL FUNCTIONS 11320C***AUTHOR Fullerton, W., (LANL) 11321C***DESCRIPTION 11322C 11323C DFAC(N) calculates the double precision factorial for integer 11324C argument N. 11325C 11326C***REFERENCES (NONE) 11327C***ROUTINES CALLED D9LGMC, DGAMLM, XERMSG 11328C***REVISION HISTORY (YYMMDD) 11329C 770601 DATE WRITTEN 11330C 890531 Changed all specific intrinsics to generic. (WRB) 11331C 890531 REVISION DATE from Version 3.2 11332C 891214 Prologue converted to Version 4.0 format. (BAB) 11333C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 11334C***END PROLOGUE DFAC 11335C 11336C-----COMMON---------------------------------------------------------- 11337C 11338 INCLUDE 'DPCOMC.INC' 11339 INCLUDE 'DPCOP2.INC' 11340C 11341 DOUBLE PRECISION FACN(31), SQ2PIL, X, XMAX, XMIN, D9LGMC 11342 SAVE FACN, SQ2PIL, NMAX 11343 DATA FACN ( 1) / +.1000000000 0000000000 0000000000 000 D+1 / 11344 DATA FACN ( 2) / +.1000000000 0000000000 0000000000 000 D+1 / 11345 DATA FACN ( 3) / +.2000000000 0000000000 0000000000 000 D+1 / 11346 DATA FACN ( 4) / +.6000000000 0000000000 0000000000 000 D+1 / 11347 DATA FACN ( 5) / +.2400000000 0000000000 0000000000 000 D+2 / 11348 DATA FACN ( 6) / +.1200000000 0000000000 0000000000 000 D+3 / 11349 DATA FACN ( 7) / +.7200000000 0000000000 0000000000 000 D+3 / 11350 DATA FACN ( 8) / +.5040000000 0000000000 0000000000 000 D+4 / 11351 DATA FACN ( 9) / +.4032000000 0000000000 0000000000 000 D+5 / 11352 DATA FACN ( 10) / +.3628800000 0000000000 0000000000 000 D+6 / 11353 DATA FACN ( 11) / +.3628800000 0000000000 0000000000 000 D+7 / 11354 DATA FACN ( 12) / +.3991680000 0000000000 0000000000 000 D+8 / 11355 DATA FACN ( 13) / +.4790016000 0000000000 0000000000 000 D+9 / 11356 DATA FACN ( 14) / +.6227020800 0000000000 0000000000 000 D+10 / 11357 DATA FACN ( 15) / +.8717829120 0000000000 0000000000 000 D+11 / 11358 DATA FACN ( 16) / +.1307674368 0000000000 0000000000 000 D+13 / 11359 DATA FACN ( 17) / +.2092278988 8000000000 0000000000 000 D+14 / 11360 DATA FACN ( 18) / +.3556874280 9600000000 0000000000 000 D+15 / 11361 DATA FACN ( 19) / +.6402373705 7280000000 0000000000 000 D+16 / 11362 DATA FACN ( 20) / +.1216451004 0883200000 0000000000 000 D+18 / 11363 DATA FACN ( 21) / +.2432902008 1766400000 0000000000 000 D+19 / 11364 DATA FACN ( 22) / +.5109094217 1709440000 0000000000 000 D+20 / 11365 DATA FACN ( 23) / +.1124000727 7776076800 0000000000 000 D+22 / 11366 DATA FACN ( 24) / +.2585201673 8884976640 0000000000 000 D+23 / 11367 DATA FACN ( 25) / +.6204484017 3323943936 0000000000 000 D+24 / 11368 DATA FACN ( 26) / +.1551121004 3330985984 0000000000 000 D+26 / 11369 DATA FACN ( 27) / +.4032914611 2660563558 4000000000 000 D+27 / 11370 DATA FACN ( 28) / +.1088886945 0418352160 7680000000 000 D+29 / 11371 DATA FACN ( 29) / +.3048883446 1171386050 1504000000 000 D+30 / 11372 DATA FACN ( 30) / +.8841761993 7397019545 4361600000 000 D+31 / 11373 DATA FACN ( 31) / +.2652528598 1219105863 6308480000 000 D+33 / 11374 DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / 11375 DATA NMAX / 0 / 11376C***FIRST EXECUTABLE STATEMENT DFAC 11377C 11378 DFAC=0.0D0 11379C 11380 IF (NMAX.NE.0) GO TO 10 11381 CALL DGAMLM (XMIN, XMAX) 11382 NMAX = INT(XMAX - 1.D0) 11383C 11384 10 IF (N .LT. 0) THEN 11385 WRITE(ICOUT,1) 11386 1 FORMAT('***** ERORR FROM DFAC, THE FACTORIAL OF A NEGATIVE', 11387 1 ' NUMBER IS UNDEFINED. *****') 11388 CALL DPWRST('XXX','BUG ') 11389 RETURN 11390 ENDIF 11391C 11392 IF (N.LE.30) DFAC = FACN(N+1) 11393 IF (N.LE.30) RETURN 11394C 11395 IF (N .GT. NMAX) THEN 11396 WRITE(ICOUT,2) 11397 2 FORMAT('***** ERORR FROM DFAC, THE ARGUMENT IS SO BIG THAT ', 11398 1 ' THE FACTORIAL OVERFLOWS. *****') 11399 CALL DPWRST('XXX','BUG ') 11400 RETURN 11401 ENDIF 11402C 11403 X = REAL(N + 1) 11404 DFAC = EXP ((X-0.5D0)*LOG(X) - X + SQ2PIL + D9LGMC(X) ) 11405C 11406 RETURN 11407 END 11408 DOUBLE PRECISION FUNCTION DFRENC (X,MODE) 11409C 11410C . COPYRIGHT (C) 1992, CALIFORNIA INSTITUTE OF TECHNOLOGY. 11411C . U. S. GOVERNMENT SPONSORSHIP UNDER 11412C . NASA CONTRACT NAS7-918 IS ACKNOWLEDGED. 11413C>> ALAN HECKERT MODIFIED FOR INCLUSION INTO DATAPLOT (BASICALLY, 11414C PASS MODE AS ARGUMENT AND ELIMINATE MULTIPLE ENTRY POINTS. 11415C ALSO, DELETED COMMENT LINES FOR COEFFICIENTS USING DIFFERENT 11416C ORDERS OF APPROXIMATION. 11417C>> 1992-09-15 DFRENL WV SNYDER SPECIALIZING INSTRUCTIONS 11418C>> 1992-04-13 DFRENL WV SNYDER DECLARE DFRENF, DFRENG, DFRENS 11419C>> 1992-03-18 DFRENL WV SNYDER MOVE DECLARATIONS FOR COEFFICIENT ARRAYS 11420C>> 1992-01-24 DFRENL WV SNYDER ORIGINAL CODE 11421C ENTRIES IN THIS SUBPROGRAM COMPUTE THE FRESNEL COSINE AND SINE 11422C INTEGRALS C(X) AND S(X), AND THE AUXILIARY FUNCTIONS F(X) AND G(X), 11423C FOR ANY X: 11424C DFRENC(X) FOR FRESNEL INTEGRAL C(X) 11425C DFRENS(X) FOR FRESNEL INTEGRAL S(X) 11426C DFRENF(X) FOR FRESNEL INTEGRAL AUXILIARY FUNCTION F(X) 11427C DFRENG(X) FOR FRESNEL INTEGRAL AUXILIARY FUNCTION G(X). 11428C 11429C DEVELOPED BY W. V. SNYDER, JET PROPULSION LABORATORY, 24 JANUARY 1992. 11430C 11431C REF: W. J. CODY, "CHEBYSHEV APPROXIMATIONS FOR THE FRESNEL INTEGRALS", 11432C MATHEMATICS OF COMPUTATION, 1968, PP 450-453 PLUS MICROFICHE SUPPL. 11433C ACCURACIES OF HIGHEST ORDER FORMULAE, WHERE E IS RELATIVE ERROR: 11434C 11435C RANGE FUNCTION -LOG10(E) FUNCTION -LOG10(E) 11436C |X|<=1.2 C(X) 16.24 S(X) 17.26 11437C 1.2<|X|<=1.6 C(X) 17.47 S(X) 18.66 11438C 1.6<|X|<=1.9 F(X) 17.13 G(X) 16.25 11439C 1.9<|X|<=2.4 F(X) 16.64 G(X) 15.65 11440C 2.4<|X| F(X) 16.89 G(X) 15.58 11441C 11442C REFER TO CODY FOR ACCURACY OF OTHER APPROXIMATIONS. 11443C 11444C----------------------------------------------------------------------- 11445C 11446 DOUBLE PRECISION X 11447C 11448C-- S VERSION USES SFRENC,SFRENC,SFRENF,SFRENG,SFRENS,R1MACH,R1MACH 11449C-- D VERSION USES DFRENC,DFRENC,DFRENF,DFRENG,DFRENS,D1MACH,D1MACH 11450C 11451C DFRENF, DFRENG, DFRENS ARE ALTERNATE ENTRIES. 11452CCCCC DOUBLE PRECISION DFRENF, DFRENG, DFRENS 11453C 11454C PID2 IS PI / 2. 11455 DOUBLE PRECISION PID2 11456 PARAMETER (PID2 = 1.570796326794896619231321691639751442099D0) 11457C RPI IS THE RECIPROCAL OF PI: 11458 DOUBLE PRECISION RPI 11459 PARAMETER (RPI = 0.3183098861837906715377675267450287240689D0) 11460C RPISQ IS THE RECIPROCAL OF PI SQUARED: 11461 DOUBLE PRECISION RPISQ 11462 PARAMETER (RPISQ = RPI * RPI) 11463C AX IS ABS(X). 11464C BIGX IS 1/SQRT(ROUND-OFF). IF X > BIGX THEN TO THE WORKING 11465C PRECISION X**2 IS AN INTEGER (WHICH WE ASSUME TO BE A MULTIPLE 11466C OF FOUR), SO COS(PI/2 * X**2) = 1, AND SIN(PI/2 * X**2) = 0. 11467C C AND S ARE VALUES OF C(X) AND S(X), RESPECTIVELY. 11468C CX AND SX ARE COS(PI/2 * AX**2) AND SIN(PI/2 * AX**2), RESPECTIVELY. 11469C F AND G ARE USED TO COMPUTE F(X) AND G(X) WHEN X > 1.6. 11470C HAVEC, HAVEF, HAVEG, HAVES ARE LOGICAL VARIABLES THAT INDICATE 11471C WHETHER THE VALUES STORED IN C, F, G AND S CORRESPOND TO THE 11472C VALUE STORED IN X. HAVEF INDICATES WE HAVE BOTH F AND G WHEN 11473C XSAVE .LE. 1.6, AND HAVEC INDICATES WE HAVE BOTH C AND S WHEN 11474C XSAVE .GT. 1.6. 11475C LARGEF IS 1/(PI * UNDERFLOW). IF X > LARGEF THEN F ~ 0. 11476C LARGEG IS CBRT(1/(PI**2 * UNDERFLOW)). IF X > LARGEG THEN G ~ 0. 11477C LARGEX IS 1/SQRT(SQRT(UNDERFLOW)). IF X > LARGEX THEN F ~ 1/(PI * X) 11478C AND G ~ 1/(PI**2 * X**3). 11479C MODE INDICATES THE FUNCTION TO BE COMPUTED: 1 = C(X), 2 = S(X), 11480C 3 = F(X), 4 = G(X). 11481C NEEDC, NEEDF, NEEDG, NEEDS ARE ARRAYS INDEXED BY MODE (MODE+4 WHEN 11482C X .GT. 1.6) THAT INDICATE WHAT FUNCTIONS ARE NEEDED. 11483C RESULT IS EQUIVALENCED TO C, F, G, AND S. 11484C WANTC INDICATES WHETHER C AND S MUST BE COMPUTED FROM F AND G. 11485C WANTF AND WANTG INDICATE WE COMPUTED F AND G ON THE PRESENT CALL. 11486C XSAVE IS THE MOST RECENTLY PROVIDED VALUE OF X. 11487C X4 IS EITHER X ** 4 OR (1.0/X) ** 4. 11488 DOUBLE PRECISION AX, BIGX, C, CX, F, G, LARGEF, LARGEG, LARGEX 11489 DOUBLE PRECISION RESULT(4), S, SX, XSAVE, X4 11490 SAVE BIGX, C, F, G, LARGEF, LARGEG, LARGEX, S, RESULT, XSAVE 11491 EQUIVALENCE (RESULT(1), C), (RESULT(2), S) 11492 EQUIVALENCE (RESULT(3), F), (RESULT(4), G) 11493 LOGICAL HAVEC, HAVEF, HAVEG, HAVES, WANTC, WANTF, WANTG 11494 SAVE HAVEC, HAVEF, HAVEG, HAVES 11495 INTEGER MODE 11496 LOGICAL NEEDC(8), NEEDF(8), NEEDG(8), NEEDS(8) 11497C 11498 INCLUDE 'DPCOMC.INC' 11499C 11500C DECLARATIONS FOR COEFFICIENT ARRAYS. IF YOU CHANGE THE ORDER OF 11501C APPROXIMATION, YOU MUST CHANGE THE DECLARATION HERE, THE DATA 11502C STATEMENTS BELOW, AND THE EXECUTABLE STATEMENTS THAT EVALUATE 11503C THE APPROXIMATIONS. 11504 DOUBLE PRECISION PC1(0:4), QC1(1:4) 11505 DOUBLE PRECISION PC2(0:5), QC2(1:5) 11506 DOUBLE PRECISION PS1(0:4), QS1(1:4) 11507 DOUBLE PRECISION PS2(0:5), QS2(1:5) 11508 DOUBLE PRECISION PF1(0:5), QF1(1:5) 11509 DOUBLE PRECISION PF2(0:5), QF2(1:5) 11510 DOUBLE PRECISION PF3(0:6), QF3(1:6) 11511 DOUBLE PRECISION PG1(0:5), QG1(1:5) 11512 DOUBLE PRECISION PG2(0:5), QG2(1:5) 11513 DOUBLE PRECISION PG3(0:6), QG3(1:6) 11514C 11515 DATA BIGX /-1.0D0/ 11516 DATA C /0.0D0/, F /0.5D0/, G /0.5D0/, S /0.0D0/, XSAVE /0.0D0/ 11517 DATA HAVEC/.TRUE./, HAVEF/.TRUE./, HAVEG/.TRUE./, HAVES/.TRUE./ 11518C C(X) S(X) F(X) G(X) C(X) S(X) F(X) G(X) 11519 DATA NEEDC 11520 1 /.TRUE., .FALSE.,.TRUE., .TRUE., .TRUE., .FALSE.,.FALSE.,.FALSE./ 11521 DATA NEEDS 11522 1 /.FALSE.,.TRUE., .TRUE., .TRUE., .FALSE.,.TRUE., .FALSE.,.FALSE./ 11523 DATA NEEDF 11524 1 /.FALSE.,.FALSE.,.TRUE., .FALSE.,.TRUE., .TRUE., .TRUE., .FALSE./ 11525 DATA NEEDG 11526 1 /.FALSE.,.FALSE.,.FALSE.,.TRUE. ,.TRUE., .TRUE., .FALSE.,.TRUE. / 11527C 11528C COEFFICIENTS FOR C(X), |X| <= 1.2 11529C 11530 DATA PC1(0) / 9.99999 99999 99999 421 D-1/ 11531 DATA PC1(1) /-1.99460 89882 61842 706 D-1/ 11532 DATA QC1(1) / 4.72792 11201 04532 689 D-2/ 11533 DATA PC1(2) / 1.76193 95254 34914 045 D-2/ 11534 DATA QC1(2) / 1.09957 21502 56418 851 D-3/ 11535 DATA PC1(3) /-5.28079 65137 26226 960 D-4/ 11536 DATA QC1(3) / 1.55237 88527 69941 331 D-5/ 11537 DATA PC1(4) / 5.47711 38568 26871 660 D-6/ 11538 DATA QC1(4) / 1.18938 90142 28757 184 D-7/ 11539C 11540C COEFFICIENTS FOR C(X), 1.2 < |X| <= 1.6 11541 DATA PC2(0) / 1.00000 00000 01110 43640 D0 / 11542 DATA PC2(1) /-2.07073 36033 53238 94245 D-1/ 11543 DATA QC2(1) / 3.96667 49695 23234 33510 D-2/ 11544 DATA PC2(2) / 1.91870 27943 17469 26505 D-2/ 11545 DATA QC2(2) / 7.88905 24505 23599 07842 D-4/ 11546 DATA PC2(3) /-6.71376 03469 49221 09230 D-4/ 11547 DATA QC2(3) / 1.01344 63086 67494 06081 D-5/ 11548 DATA PC2(4) / 1.02365 43505 61058 64908 D-5/ 11549 DATA QC2(4) / 8.77945 37789 23692 65356 D-8/ 11550 DATA PC2(5) /-5.68293 31012 18707 28343 D-8/ 11551 DATA QC2(5) / 4.41701 37406 50096 20393 D-10/ 11552C 11553C COEFFICIENTS FOR S(X), |X| <= 1.2 11554 DATA PS1(0) / 5.23598 77559 82988 7021 D-1/ 11555 DATA PS1(1) /-7.07489 91514 45230 2596 D-2/ 11556 DATA QS1(1) / 4.11223 15114 23842 2205 D-2/ 11557 DATA PS1(2) / 3.87782 12346 36828 7939 D-3/ 11558 DATA QS1(2) / 8.17091 94215 21344 7204 D-4/ 11559 DATA PS1(3) /-8.45557 28435 27768 0591 D-5/ 11560 DATA QS1(3) / 9.62690 87593 90340 3370 D-6/ 11561 DATA PS1(4) / 6.71748 46662 51408 6196 D-7/ 11562 DATA QS1(4) / 5.95281 22767 84099 8345 D-8/ 11563C 11564C COEFFICIENTS FOR S(X), 1.2 < |X| <= 1.6 11565 DATA PS2(0) / 5.23598 77559 83441 65913 D-1/ 11566 DATA PS2(1) /-7.37766 91401 01913 23867 D-2/ 11567 DATA QS2(1) / 3.53398 34276 74721 62540 D-2/ 11568 DATA PS2(2) / 4.30730 52650 43665 10217 D-3/ 11569 DATA QS2(2) / 6.18224 62019 54732 16538 D-4/ 11570 DATA PS2(3) /-1.09540 02391 14349 94566 D-4/ 11571 DATA QS2(3) / 6.87086 26571 86201 17905 D-6/ 11572 DATA PS2(4) / 1.28531 04374 27248 20610 D-6/ 11573 DATA QS2(4) / 5.03090 58124 66123 75866 D-8/ 11574 DATA PS2(5) /-5.76765 81559 30888 04567 D-9/ 11575 DATA QS2(5) / 2.05539 12445 85795 96075 D-10/ 11576C 11577C COEFFICIENTS FOR F(X), 1.6 < |X| <= 1.9 11578 DATA PF1(0) / 3.18309 75293 58098 5290 D-1/ 11579 DATA PF1(1) / 1.22260 00551 67296 1219 D1 / 11580 DATA QF1(1) / 3.87130 03365 58344 2831 D1 / 11581 DATA PF1(2) / 1.29248 86131 90165 7025 D2 / 11582 DATA QF1(2) / 4.16743 59830 70562 9745 D2 / 11583 DATA PF1(3) / 4.38863 67156 69554 7655 D2 / 11584 DATA QF1(3) / 1.47400 30733 96661 0568 D3 / 11585 DATA PF1(4) / 4.14667 22177 95896 1672 D2 / 11586 DATA QF1(4) / 1.53716 75584 89575 9916 D3 / 11587 DATA PF1(5) / 5.67714 63664 18511 6454 D1 / 11588 DATA QF1(5) / 2.91130 88788 84783 1515 D2 / 11589C 11590C COEFFICIENTS FOR F(X), 1.9 < |X| <= 2.4 11591 DATA PF2(0) / 3.18309 88182 20169 217 D-1/ 11592 DATA PF2(1) / 1.95883 94102 19691 002 D1 / 11593 DATA QF2(1) / 6.18427 13817 28873 709 D1 / 11594 DATA PF2(2) / 3.39837 13492 69842 400 D2 / 11595 DATA QF2(2) / 1.08535 06750 06501 251 D3 / 11596 DATA PF2(3) / 1.93007 64078 67157 531 D3 / 11597 DATA QF2(3) / 6.33747 15585 11437 898 D3 / 11598 DATA PF2(4) / 3.09145 16157 44296 552 D3 / 11599 DATA QF2(4) / 1.09334 24898 88087 888 D4 / 11600 DATA PF2(5) / 7.17703 24936 51399 590 D2 / 11601 DATA QF2(5) / 3.36121 69918 05511 494 D3 / 11602C 11603C COEFFICIENTS FOR F(X), 2.4 < |X| 11604 DATA PF3(0) /-9.67546 03299 52532 343 D-2/ 11605 DATA PF3(1) /-2.43127 54071 94161 683 D1 / 11606 DATA QF3(1) / 2.54828 90129 49732 752 D2 / 11607 DATA PF3(2) /-1.94762 19983 06889 176 D3 / 11608 DATA QF3(2) / 2.09976 15368 57815 105 D4 / 11609 DATA PF3(3) /-6.05985 21971 60773 639 D4 / 11610 DATA QF3(3) / 6.92412 25098 27708 985 D5 / 11611 DATA PF3(4) /-7.07680 69528 37779 823 D5 / 11612 DATA QF3(4) / 9.17882 32299 18143 780 D6 / 11613 DATA PF3(5) /-2.41765 67490 61154 155 D6 / 11614 DATA QF3(5) / 4.29273 32556 30186 679 D7 / 11615 DATA PF3(6) /-7.83491 45900 78317 336 D5 / 11616 DATA QF3(6) / 4.80329 47842 60528 342 D7 / 11617C 11618C COEFFICIENTS FOR G(X), 1.6 < |X| <= 1.9 11619 DATA PG1(0) / 1.01320 61881 02747 985 D-1/ 11620 DATA PG1(1) / 4.44533 82755 05123 778 D0 / 11621 DATA QG1(1) / 4.53925 01967 36893 605 D1 / 11622 DATA PG1(2) / 5.31122 81348 09894 481 D1 / 11623 DATA QG1(2) / 5.83590 57571 64290 666 D2 / 11624 DATA PG1(3) / 1.99182 81867 89025 318 D2 / 11625 DATA QG1(3) / 2.54473 13318 18221 034 D3 / 11626 DATA PG1(4) / 1.96232 03797 16626 191 D2 / 11627 DATA QG1(4) / 3.48112 14785 65452 837 D3 / 11628 DATA PG1(5) / 2.05421 43249 85006 303 D1 / 11629 DATA QG1(5) / 1.01379 48339 60028 555 D3 / 11630C 11631C COEFFICIENTS FOR G(X), 1.9 < |X| <= 2.4 11632 DATA PG2(0) / 1.01321 16176 18045 86 D-1/ 11633 DATA PG2(1) / 7.11205 00178 97828 23 D0 / 11634 DATA QG2(1) / 7.17128 59693 93021 98 D1 / 11635 DATA PG2(2) / 1.40959 61791 13155 24 D2 / 11636 DATA QG2(2) / 1.49051 92279 73292 29 D3 / 11637 DATA PG2(3) / 9.08311 74952 95939 38 D2 / 11638 DATA QG2(3) / 1.06729 67803 05808 97 D4 / 11639 DATA PG2(4) / 1.59268 00608 53538 64 D3 / 11640 DATA QG2(4) / 2.41315 56721 33697 42 D4 / 11641 DATA PG2(5) / 3.13330 16306 87559 50 D2 / 11642 DATA QG2(5) / 1.15149 83237 62606 04 D4 / 11643C 11644C COEFFICIENTS FOR G(X), 2.4 < |X| 11645 DATA PG3(0) /-1.53989 73381 97693 16 D-1/ 11646 DATA PG3(1) /-4.31710 15782 33575 68 D1 / 11647 DATA QG3(1) / 2.86733 19497 58994 83 D2 / 11648 DATA PG3(2) /-3.87754 14174 63784 93 D3 / 11649 DATA QG3(2) / 2.69183 18039 62425 36 D4 / 11650 DATA PG3(3) /-1.35678 86781 37563 47 D5 / 11651 DATA QG3(3) / 1.02878 69305 66875 06 D6 / 11652 DATA PG3(4) /-1.77758 95083 80296 76 D6 / 11653 DATA QG3(4) / 1.62095 60050 02316 46 D7 / 11654 DATA PG3(5) /-6.66907 06166 86364 16 D6 / 11655 DATA QG3(5) / 9.38695 86253 16351 79 D7 / 11656 DATA PG3(6) /-1.72590 22465 48368 45 D6 / 11657 DATA QG3(6) / 1.40622 44112 35800 05 D8 / 11658C 11659C MODE = 1 = FRESNEL COSINE INTEGRAL 11660C MODE = 2 = FRESNEL SINE INTEGRAL 11661C MODE = 3 = F AUXILLARY FUNCTION 11662C MODE = 4 = G AUXILLARY FUNCTION 11663C 11664C ***** EXECUTABLE STATEMENTS **************************** 11665C 11666 IF (BIGX .LT. 0.0D0) THEN 11667 BIGX = 1.0D0 / SQRT(D1MACH(4)) 11668 LARGEF = RPI / D1MACH(1) 11669 LARGEG = (RPI * LARGEF) ** (1.0D0 / 3.0D0) 11670 LARGEX = 1.0D0/SQRT(SQRT(D1MACH(1))) 11671 END IF 11672 IF (X .NE. XSAVE) THEN 11673 HAVEC = .FALSE. 11674 HAVEF = .FALSE. 11675 HAVEG = .FALSE. 11676 HAVES = .FALSE. 11677 END IF 11678 AX = ABS(X) 11679 IF (AX .LE. 1.6D0) THEN 11680 X4 = AX**4 11681 IF (NEEDC(MODE) .AND. .NOT. HAVEC) THEN 11682 IF (AX .LE. 1.2D0) THEN 11683 C = X * ((((PC1(4)*X4+PC1(3))*X4+PC1(2))*X4+PC1(1))*X4+ 11684 1 PC1(0)) 11685 2 / ((((QC1(4)*X4+QC1(3))*X4+QC1(2))*X4+QC1(1))*X4+1.0D0) 11686 ELSE 11687 C = X * (((((PC2(5)*X4+PC2(4))*X4+PC2(3))*X4+PC2(2))*X4+ 11688 1 PC2(1))*X4+PC2(0)) 11689 2 / (((((QC2(5)*X4+QC2(4))*X4+QC2(3))*X4+QC2(2))*X4+ 11690 3 QC2(1))*X4+1.0D0) 11691 END IF 11692 HAVEC = .TRUE. 11693 END IF 11694 IF (NEEDS(MODE) .AND. .NOT. HAVES) THEN 11695 IF (AX .LE. 1.2D0) THEN 11696 S = X**3*((((PS1(4)*X4+PS1(3))*X4+PS1(2))*X4+PS1(1))*X4+ 11697 1 PS1(0)) 11698 2 / ((((QS1(4)*X4+QS1(3))*X4+QS1(2))*X4+QS1(1))*X4+1.0D0) 11699 ELSE 11700 S = X**3*(((((PS2(5)*X4+PS2(4))*X4+PS2(3))*X4+PS2(2))*X4+ 11701 1 PS2(1))*X4+PS2(0)) 11702 2 / (((((QS2(5)*X4+QS2(4))*X4+QS2(3))*X4+QS2(2))*X4+ 11703 3 QS2(1))*X4+1.0D0) 11704 END IF 11705 HAVES = .TRUE. 11706 END IF 11707 IF ((NEEDF(MODE) .OR. NEEDG(MODE)) .AND. .NOT. HAVEF) THEN 11708 CX = COS(PID2 * AX*AX) 11709 SX = SIN(PID2 * AX*AX) 11710 F = (0.5D0 - S) * CX - (0.5D0 - C) * SX 11711 G = (0.5D0 - C) * CX + (0.5D0 - S) * SX 11712 HAVEF = .TRUE. 11713 END IF 11714 ELSE 11715 IF (AX .LE. LARGEX) THEN 11716 X4 = (1.0D0 / AX) ** 4 11717 WANTF = NEEDF(MODE+4) .AND. .NOT. HAVEF 11718 IF (WANTF) THEN 11719 IF (AX .LE. 1.9D0) THEN 11720 F = (((((PF1(5)*X4+PF1(4))*X4+PF1(3))*X4+PF1(2))*X4+ 11721 1 PF1(1))*X4+PF1(0)) 11722 2 / ((((((QF1(5)*X4+QF1(4))*X4+QF1(3))*X4+QF1(2))*X4+ 11723 3 QF1(1))*X4+1.0D0) * AX) 11724 ELSE IF (AX .LE. 2.4) THEN 11725 F = (((((PF2(5)*X4+PF2(4))*X4+PF2(3))*X4+PF2(2))*X4+ 11726 1 PF2(1))*X4+PF2(0)) 11727 2 / ((((((QF2(5)*X4+QF2(4))*X4+QF2(3))*X4+QF2(2))*X4+ 11728 3 QF2(1))*X4+1.0D0) * AX) 11729 ELSE 11730 F = (RPI + 11731 1 X4*((((((PF3(6)*X4+PF3(5))*X4+PF3(4))*X4+PF3(3))*X4+ 11732 2 PF3(2))*X4+PF3(1))*X4+PF3(0)) 11733 3 / ((((((QF3(6)*X4+QF3(5))*X4+QF3(4))*X4+QF3(3))*X4+ 11734 4 QF3(2))*X4+QF3(1))*X4+1.0D0)) / AX 11735 END IF 11736 HAVEF = .TRUE. 11737 END IF 11738 WANTG = NEEDG(MODE+4) .AND. .NOT. HAVEG 11739 IF (WANTG) THEN 11740 IF (X .LE. 1.9D0) THEN 11741 G = (((((PG1(5)*X4+PG1(4))*X4+PG1(3))*X4+PG1(2))*X4+ 11742 1 PG1(1))*X4+PG1(0)) 11743 2 / ((((((QG1(5)*X4+QG1(4))*X4+QG1(3))*X4+QG1(2))*X4+ 11744 3 QG1(1))*X4+1.0D0) * AX**3) 11745 ELSE IF (AX .LE. 2.4D0) THEN 11746 G = (((((PG2(5)*X4+PG2(4))*X4+PG2(3))*X4+PG2(2))*X4+ 11747 1 PG2(1))*X4+PG2(0)) 11748 2 / ((((((QG2(5)*X4+QG2(4))*X4+QG2(3))*X4+QG2(2))*X4+ 11749 3 QG2(1))*X4+1.0D0) * AX**3) 11750 ELSE 11751 G = (RPISQ + 11752 1 X4*((((((PG3(6)*X4+PG3(5))*X4+PG3(4))*X4+PG3(3))*X4+ 11753 2 PG3(2))*X4+PG3(1))*X4+PG3(0)) 11754 3 / ((((((QG3(6)*X4+QG3(5))*X4+QG3(4))*X4+QG3(3))*X4+ 11755 4 QG3(2))*X4+QG3(1))*X4+1.0D0)) / AX**3 11756 END IF 11757 HAVEG = .TRUE. 11758 END IF 11759 ELSE 11760 WANTF = NEEDF(MODE) 11761 IF (WANTF) THEN 11762 IF (X .LE. LARGEF) THEN 11763 F = RPI / AX 11764 ELSE 11765 F = 0.0D0 11766 END IF 11767 END IF 11768 WANTG = NEEDG(MODE) 11769 IF (WANTG) THEN 11770 IF (X .LE. LARGEG) THEN 11771 G = RPISQ / AX**3 11772 ELSE 11773 G = 0.0D0 11774 END IF 11775 END IF 11776 END IF 11777 WANTC = (NEEDC(MODE+4) .OR. NEEDS(MODE+4)) .AND. .NOT. HAVEC 11778 IF (WANTC .OR. X.LT.0.0D0) THEN 11779 IF (AX .LE. BIGX) THEN 11780 CX = COS(PID2 * AX*AX) 11781 SX = SIN(PID2 * AX*AX) 11782 ELSE 11783 CX = 1.0D0 11784 SX = 0.0D0 11785 END IF 11786 IF (WANTC) THEN 11787 C = 0.5D0 + F*SX - G*CX 11788 S = 0.5D0 - F*CX - G*SX 11789 IF (X .LT. 0.0) THEN 11790 C = -C 11791 S = -S 11792 END IF 11793 HAVEC = .TRUE. 11794 END IF 11795 IF (X .LT. 0.0) THEN 11796C WE COULD DO THE FOLLOWING BEFORE THE PRECEEDING, AND THEN 11797C NOT PUT IN A TEST IN THE PRECEEDING FOR X .LT. 0, BUT 11798C EVEN THOUGH THE RESULTS ARE MATHEMATICALLY IDENTICAL, WE 11799C WOULD HAVE SOME CANCELLATION ABOVE IF WE DID SO. 11800 IF (WANTG) G = CX + SX - G 11801 IF (WANTF) F = CX - SX - F 11802 END IF 11803 END IF 11804 END IF 11805 XSAVE = X 11806C 11807 DFRENC = RESULT(MODE) 11808 RETURN 11809 END 11810 SUBROUTINE DFZERO (F, B, C, R, RE, AE, IFLAG) 11811C***BEGIN PROLOGUE DFZERO 11812C***PURPOSE Search for a zero of a function F(X) in a given interval 11813C (B,C). It is designed primarily for problems where F(B) 11814C and F(C) have opposite signs. 11815C***LIBRARY SLATEC 11816C***CATEGORY F1B 11817C***TYPE DOUBLE PRECISION (FZERO-S, DFZERO-D) 11818C***KEYWORDS BISECTION, NONLINEAR, ROOTS, ZEROS 11819C***AUTHOR Shampine, L. F., (SNLA) 11820C Watts, H. A., (SNLA) 11821C***DESCRIPTION 11822C 11823C DFZERO searches for a zero of a DOUBLE PRECISION function F(X) 11824C between the given DOUBLE PRECISION values B and C until the width 11825C of the interval (B,C) has collapsed to within a tolerance 11826C specified by the stopping criterion, 11827C ABS(B-C) .LE. 2.*(RW*ABS(B)+AE). 11828C The method used is an efficient combination of bisection and the 11829C secant rule and is due to T. J. Dekker. 11830C 11831C Description Of Arguments 11832C 11833C F :EXT - Name of the DOUBLE PRECISION external function. This 11834C name must be in an EXTERNAL statement in the calling 11835C program. F must be a function of one DOUBLE 11836C PRECISION argument. 11837C 11838C B :INOUT - One end of the DOUBLE PRECISION interval (B,C). The 11839C value returned for B usually is the better 11840C approximation to a zero of F. 11841C 11842C C :INOUT - The other end of the DOUBLE PRECISION interval (B,C) 11843C 11844C R :IN - A (better) DOUBLE PRECISION guess of a zero of F 11845C which could help in speeding up convergence. If F(B) 11846C and F(R) have opposite signs, a root will be found in 11847C the interval (B,R); if not, but F(R) and F(C) have 11848C opposite signs, a root will be found in the interval 11849C (R,C); otherwise, the interval (B,C) will be 11850C searched for a possible root. When no better guess 11851C is known, it is recommended that R be set to B or C, 11852C since if R is not interior to the interval (B,C), it 11853C will be ignored. 11854C 11855C RE :IN - Relative error used for RW in the stopping criterion. 11856C If the requested RE is less than machine precision, 11857C then RW is set to approximately machine precision. 11858C 11859C AE :IN - Absolute error used in the stopping criterion. If 11860C the given interval (B,C) contains the origin, then a 11861C nonzero value should be chosen for AE. 11862C 11863C IFLAG :OUT - A status code. User must check IFLAG after each 11864C call. Control returns to the user from DFZERO in all 11865C cases. 11866C 11867C 1 B is within the requested tolerance of a zero. 11868C The interval (B,C) collapsed to the requested 11869C tolerance, the function changes sign in (B,C), and 11870C F(X) decreased in magnitude as (B,C) collapsed. 11871C 11872C 2 F(B) = 0. However, the interval (B,C) may not have 11873C collapsed to the requested tolerance. 11874C 11875C 3 B may be near a singular point of F(X). 11876C The interval (B,C) collapsed to the requested tol- 11877C erance and the function changes sign in (B,C), but 11878C F(X) increased in magnitude as (B,C) collapsed, i.e. 11879C ABS(F(B out)) .GT. MAX(ABS(F(B in)),ABS(F(C in))) 11880C 11881C 4 No change in sign of F(X) was found although the 11882C interval (B,C) collapsed to the requested tolerance. 11883C The user must examine this case and decide whether 11884C B is near a local minimum of F(X), or B is near a 11885C zero of even multiplicity, or neither of these. 11886C 11887C 5 Too many (.GT. 500) function evaluations used. 11888C 11889C***REFERENCES L. F. Shampine and H. A. Watts, FZERO, a root-solving 11890C code, Report SC-TM-70-631, Sandia Laboratories, 11891C September 1970. 11892C T. J. Dekker, Finding a zero by means of successive 11893C linear interpolation, Constructive Aspects of the 11894C Fundamental Theorem of Algebra, edited by B. Dejon 11895C and P. Henrici, Wiley-Interscience, 1969. 11896C***ROUTINES CALLED D1MACH 11897C***REVISION HISTORY (YYMMDD) 11898C 700901 DATE WRITTEN 11899C 890531 Changed all specific intrinsics to generic. (WRB) 11900C 890531 REVISION DATE from Version 3.2 11901C 891214 Prologue converted to Version 4.0 format. (BAB) 11902C 920501 Reformatted the REFERENCES section. (WRB) 11903C***END PROLOGUE DFZERO 11904CCCCC DOUBLE PRECISION A,ACBS,ACMB,AE,AW,B,C,CMB,D1MACH,ER, 11905 DOUBLE PRECISION A,ACBS,ACMB,AE,AW,B,C,CMB,ER, 11906 + F,FA,FB,FC,FX,FZ,P,Q,R,RE,RW,T,TOL,Z 11907 INTEGER IC,IFLAG,KOUNT 11908C 11909 INCLUDE 'DPCOMC.INC' 11910 INCLUDE 'DPCOP2.INC' 11911C 11912C***FIRST EXECUTABLE STATEMENT DFZERO 11913C 11914C ER is two times the computer unit roundoff value which is defined 11915C here by the function D1MACH. 11916C 11917 ER = 2.0D0 * D1MACH(4) 11918C 11919C Initialize. 11920C 11921 Z = R 11922 IF (R .LE. MIN(B,C) .OR. R .GE. MAX(B,C)) Z = C 11923 RW = MAX(RE,ER) 11924 AW = MAX(AE,0.D0) 11925 IC = 0 11926 T = Z 11927 FZ = F(T) 11928 FC = FZ 11929 T = B 11930 FB = F(T) 11931 KOUNT = 2 11932 IF (SIGN(1.0D0,FZ) .EQ. SIGN(1.0D0,FB)) GO TO 1 11933 C = Z 11934 GO TO 2 11935 1 IF (Z .EQ. C) GO TO 2 11936 T = C 11937 FC = F(T) 11938 KOUNT = 3 11939 IF (SIGN(1.0D0,FZ) .EQ. SIGN(1.0D0,FC)) GO TO 2 11940 B = Z 11941 FB = FZ 11942 2 A = C 11943 FA = FC 11944 ACBS = ABS(B-C) 11945 FX = MAX(ABS(FB),ABS(FC)) 11946C 11947 3 IF (ABS(FC) .GE. ABS(FB)) GO TO 4 11948C 11949C Perform interchange. 11950C 11951 A = B 11952 FA = FB 11953 B = C 11954 FB = FC 11955 C = A 11956 FC = FA 11957C 11958 4 CMB = 0.5D0*(C-B) 11959 ACMB = ABS(CMB) 11960 TOL = RW*ABS(B) + AW 11961C 11962C Test stopping criterion and function count. 11963C 11964 IF (ACMB .LE. TOL) GO TO 10 11965 IF (FB .EQ. 0.D0) GO TO 11 11966 IF (KOUNT .GE. 500) GO TO 14 11967C 11968C Calculate new iterate implicitly as B+P/Q, where we arrange 11969C P .GE. 0. The implicit form is used to prevent overflow. 11970C 11971 P = (B-A)*FB 11972 Q = FA - FB 11973 IF (P .GE. 0.D0) GO TO 5 11974 P = -P 11975 Q = -Q 11976C 11977C Update A and check for satisfactory reduction in the size of the 11978C bracketing interval. If not, perform bisection. 11979C 11980 5 A = B 11981 FA = FB 11982 IC = IC + 1 11983 IF (IC .LT. 4) GO TO 6 11984 IF (8.0D0*ACMB .GE. ACBS) GO TO 8 11985 IC = 0 11986 ACBS = ACMB 11987C 11988C Test for too small a change. 11989C 11990 6 IF (P .GT. ABS(Q)*TOL) GO TO 7 11991C 11992C Increment by TOLerance. 11993C 11994 B = B + SIGN(TOL,CMB) 11995 GO TO 9 11996C 11997C Root ought to be between B and (C+B)/2. 11998C 11999 7 IF (P .GE. CMB*Q) GO TO 8 12000C 12001C Use secant rule. 12002C 12003 B = B + P/Q 12004 GO TO 9 12005C 12006C Use bisection (C+B)/2. 12007C 12008 8 B = B + CMB 12009C 12010C Have completed computation for new iterate B. 12011C 12012 9 T = B 12013 FB = F(T) 12014 KOUNT = KOUNT + 1 12015C 12016C Decide whether next step is interpolation or extrapolation. 12017C 12018 IF (SIGN(1.0D0,FB) .NE. SIGN(1.0D0,FC)) GO TO 3 12019 C = A 12020 FC = FA 12021 GO TO 3 12022C 12023C Finished. Process results for proper setting of IFLAG. 12024C 12025 10 IF (SIGN(1.0D0,FB) .EQ. SIGN(1.0D0,FC)) GO TO 13 12026 IF (ABS(FB) .GT. FX) GO TO 12 12027 IFLAG = 1 12028 RETURN 12029 11 IFLAG = 2 12030 RETURN 12031 12 IFLAG = 3 12032 RETURN 12033 13 IFLAG = 4 12034 RETURN 12035 14 IFLAG = 5 12036 RETURN 12037 END 12038 SUBROUTINE DFZER2 (F, B, C, R, RE, AE, IFLAG,X) 12039C***MODIFIED VERSION OF DFZERO. PASS ALONG DATA ARRAY X 12040C***BEGIN PROLOGUE DFZERO 12041C***PURPOSE Search for a zero of a function F(X) in a given interval 12042C (B,C). It is designed primarily for problems where F(B) 12043C and F(C) have opposite signs. 12044C***LIBRARY SLATEC 12045C***CATEGORY F1B 12046C***TYPE DOUBLE PRECISION (FZERO-S, DFZERO-D) 12047C***KEYWORDS BISECTION, NONLINEAR, ROOTS, ZEROS 12048C***AUTHOR Shampine, L. F., (SNLA) 12049C Watts, H. A., (SNLA) 12050C***DESCRIPTION 12051C 12052C DFZERO searches for a zero of a DOUBLE PRECISION function F(X) 12053C between the given DOUBLE PRECISION values B and C until the width 12054C of the interval (B,C) has collapsed to within a tolerance 12055C specified by the stopping criterion, 12056C ABS(B-C) .LE. 2.*(RW*ABS(B)+AE). 12057C The method used is an efficient combination of bisection and the 12058C secant rule and is due to T. J. Dekker. 12059C 12060C Description Of Arguments 12061C 12062C F :EXT - Name of the DOUBLE PRECISION external function. This 12063C name must be in an EXTERNAL statement in the calling 12064C program. F must be a function of one DOUBLE 12065C PRECISION argument. 12066C 12067C B :INOUT - One end of the DOUBLE PRECISION interval (B,C). The 12068C value returned for B usually is the better 12069C approximation to a zero of F. 12070C 12071C C :INOUT - The other end of the DOUBLE PRECISION interval (B,C) 12072C 12073C R :IN - A (better) DOUBLE PRECISION guess of a zero of F 12074C which could help in speeding up convergence. If F(B) 12075C and F(R) have opposite signs, a root will be found in 12076C the interval (B,R); if not, but F(R) and F(C) have 12077C opposite signs, a root will be found in the interval 12078C (R,C); otherwise, the interval (B,C) will be 12079C searched for a possible root. When no better guess 12080C is known, it is recommended that R be set to B or C, 12081C since if R is not interior to the interval (B,C), it 12082C will be ignored. 12083C 12084C RE :IN - Relative error used for RW in the stopping criterion. 12085C If the requested RE is less than machine precision, 12086C then RW is set to approximately machine precision. 12087C 12088C AE :IN - Absolute error used in the stopping criterion. If 12089C the given interval (B,C) contains the origin, then a 12090C nonzero value should be chosen for AE. 12091C 12092C IFLAG :OUT - A status code. User must check IFLAG after each 12093C call. Control returns to the user from DFZERO in all 12094C cases. 12095C 12096C 1 B is within the requested tolerance of a zero. 12097C The interval (B,C) collapsed to the requested 12098C tolerance, the function changes sign in (B,C), and 12099C F(X) decreased in magnitude as (B,C) collapsed. 12100C 12101C 2 F(B) = 0. However, the interval (B,C) may not have 12102C collapsed to the requested tolerance. 12103C 12104C 3 B may be near a singular point of F(X). 12105C The interval (B,C) collapsed to the requested tol- 12106C erance and the function changes sign in (B,C), but 12107C F(X) increased in magnitude as (B,C) collapsed, i.e. 12108C ABS(F(B out)) .GT. MAX(ABS(F(B in)),ABS(F(C in))) 12109C 12110C 4 No change in sign of F(X) was found although the 12111C interval (B,C) collapsed to the requested tolerance. 12112C The user must examine this case and decide whether 12113C B is near a local minimum of F(X), or B is near a 12114C zero of even multiplicity, or neither of these. 12115C 12116C 5 Too many (.GT. 500) function evaluations used. 12117C 12118C***REFERENCES L. F. Shampine and H. A. Watts, FZERO, a root-solving 12119C code, Report SC-TM-70-631, Sandia Laboratories, 12120C September 1970. 12121C T. J. Dekker, Finding a zero by means of successive 12122C linear interpolation, Constructive Aspects of the 12123C Fundamental Theorem of Algebra, edited by B. Dejon 12124C and P. Henrici, Wiley-Interscience, 1969. 12125C***ROUTINES CALLED D1MACH 12126C***REVISION HISTORY (YYMMDD) 12127C 700901 DATE WRITTEN 12128C 890531 Changed all specific intrinsics to generic. (WRB) 12129C 890531 REVISION DATE from Version 3.2 12130C 891214 Prologue converted to Version 4.0 format. (BAB) 12131C 920501 Reformatted the REFERENCES section. (WRB) 12132C***END PROLOGUE DFZERO 12133CCCCC DOUBLE PRECISION A,ACBS,ACMB,AE,AW,B,C,CMB,D1MACH,ER, 12134 DOUBLE PRECISION A,ACBS,ACMB,AE,AW,B,C,CMB,ER, 12135 + F,FA,FB,FC,FX,FZ,P,Q,R,RE,RW,T,TOL,Z 12136 DOUBLE PRECISION X(*) 12137 INTEGER IC,IFLAG,KOUNT 12138C 12139 INCLUDE 'DPCOMC.INC' 12140 INCLUDE 'DPCOP2.INC' 12141C 12142C***FIRST EXECUTABLE STATEMENT DFZERO 12143C 12144C ER is two times the computer unit roundoff value which is defined 12145C here by the function D1MACH. 12146C 12147 ER = 2.0D0 * D1MACH(4) 12148C 12149C Initialize. 12150C 12151 Z = R 12152 IF (R .LE. MIN(B,C) .OR. R .GE. MAX(B,C)) Z = C 12153 RW = MAX(RE,ER) 12154 AW = MAX(AE,0.D0) 12155 IC = 0 12156 T = Z 12157 FZ = F(T,X) 12158 FC = FZ 12159 T = B 12160 FB = F(T,X) 12161 KOUNT = 2 12162 IF (SIGN(1.0D0,FZ) .EQ. SIGN(1.0D0,FB)) GO TO 1 12163 C = Z 12164 GO TO 2 12165 1 IF (Z .EQ. C) GO TO 2 12166 T = C 12167 FC = F(T,X) 12168 KOUNT = 3 12169 IF (SIGN(1.0D0,FZ) .EQ. SIGN(1.0D0,FC)) GO TO 2 12170 B = Z 12171 FB = FZ 12172 2 A = C 12173 FA = FC 12174 ACBS = ABS(B-C) 12175 FX = MAX(ABS(FB),ABS(FC)) 12176C 12177 3 IF (ABS(FC) .GE. ABS(FB)) GO TO 4 12178C 12179C Perform interchange. 12180C 12181 A = B 12182 FA = FB 12183 B = C 12184 FB = FC 12185 C = A 12186 FC = FA 12187C 12188 4 CMB = 0.5D0*(C-B) 12189 ACMB = ABS(CMB) 12190 TOL = RW*ABS(B) + AW 12191C 12192C Test stopping criterion and function count. 12193C 12194 IF (ACMB .LE. TOL) GO TO 10 12195 IF (FB .EQ. 0.D0) GO TO 11 12196 IF (KOUNT .GE. 500) GO TO 14 12197C 12198C Calculate new iterate implicitly as B+P/Q, where we arrange 12199C P .GE. 0. The implicit form is used to prevent overflow. 12200C 12201 P = (B-A)*FB 12202 Q = FA - FB 12203 IF (P .GE. 0.D0) GO TO 5 12204 P = -P 12205 Q = -Q 12206C 12207C Update A and check for satisfactory reduction in the size of the 12208C bracketing interval. If not, perform bisection. 12209C 12210 5 A = B 12211 FA = FB 12212 IC = IC + 1 12213 IF (IC .LT. 4) GO TO 6 12214 IF (8.0D0*ACMB .GE. ACBS) GO TO 8 12215 IC = 0 12216 ACBS = ACMB 12217C 12218C Test for too small a change. 12219C 12220 6 IF (P .GT. ABS(Q)*TOL) GO TO 7 12221C 12222C Increment by TOLerance. 12223C 12224 B = B + SIGN(TOL,CMB) 12225 GO TO 9 12226C 12227C Root ought to be between B and (C+B)/2. 12228C 12229 7 IF (P .GE. CMB*Q) GO TO 8 12230C 12231C Use secant rule. 12232C 12233 B = B + P/Q 12234 GO TO 9 12235C 12236C Use bisection (C+B)/2. 12237C 12238 8 B = B + CMB 12239C 12240C Have completed computation for new iterate B. 12241C 12242 9 T = B 12243 FB = F(T,X) 12244 KOUNT = KOUNT + 1 12245C 12246C Decide whether next step is interpolation or extrapolation. 12247C 12248 IF (SIGN(1.0D0,FB) .NE. SIGN(1.0D0,FC)) GO TO 3 12249 C = A 12250 FC = FA 12251 GO TO 3 12252C 12253C Finished. Process results for proper setting of IFLAG. 12254C 12255 10 IF (SIGN(1.0D0,FB) .EQ. SIGN(1.0D0,FC)) GO TO 13 12256 IF (ABS(FB) .GT. FX) GO TO 12 12257 IFLAG = 1 12258 RETURN 12259 11 IFLAG = 2 12260 RETURN 12261 12 IFLAG = 3 12262 RETURN 12263 13 IFLAG = 4 12264 RETURN 12265 14 IFLAG = 5 12266 RETURN 12267 END 12268 SUBROUTINE DFZER3 (F, B, C, R, RE, AE, IFLAG,X) 12269C***COPY OF DFZER2. A WEIBULL MLE PROBLEM REQUIRES THE ROOT 12270C***FUNCTION TO COMPUTE A NEEDED PARAMETER BY FINDING ANOTHER 12271C***ROOT. SINCE FORTRAN 77 DOES NOT ALLOW RECURSION, IMPLEMENT 12272C***VIA A SEPARATE ROUTINE. 12273C***MODIFIED VERSION OF DFZERO. PASS ALONG DATA ARRAY X 12274C***BEGIN PROLOGUE DFZERO 12275C***PURPOSE Search for a zero of a function F(X) in a given interval 12276C (B,C). It is designed primarily for problems where F(B) 12277C and F(C) have opposite signs. 12278C***LIBRARY SLATEC 12279C***CATEGORY F1B 12280C***TYPE DOUBLE PRECISION (FZERO-S, DFZERO-D) 12281C***KEYWORDS BISECTION, NONLINEAR, ROOTS, ZEROS 12282C***AUTHOR Shampine, L. F., (SNLA) 12283C Watts, H. A., (SNLA) 12284C***DESCRIPTION 12285C 12286C DFZERO searches for a zero of a DOUBLE PRECISION function F(X) 12287C between the given DOUBLE PRECISION values B and C until the width 12288C of the interval (B,C) has collapsed to within a tolerance 12289C specified by the stopping criterion, 12290C ABS(B-C) .LE. 2.*(RW*ABS(B)+AE). 12291C The method used is an efficient combination of bisection and the 12292C secant rule and is due to T. J. Dekker. 12293C 12294C Description Of Arguments 12295C 12296C F :EXT - Name of the DOUBLE PRECISION external function. This 12297C name must be in an EXTERNAL statement in the calling 12298C program. F must be a function of one DOUBLE 12299C PRECISION argument. 12300C 12301C B :INOUT - One end of the DOUBLE PRECISION interval (B,C). The 12302C value returned for B usually is the better 12303C approximation to a zero of F. 12304C 12305C C :INOUT - The other end of the DOUBLE PRECISION interval (B,C) 12306C 12307C R :IN - A (better) DOUBLE PRECISION guess of a zero of F 12308C which could help in speeding up convergence. If F(B) 12309C and F(R) have opposite signs, a root will be found in 12310C the interval (B,R); if not, but F(R) and F(C) have 12311C opposite signs, a root will be found in the interval 12312C (R,C); otherwise, the interval (B,C) will be 12313C searched for a possible root. When no better guess 12314C is known, it is recommended that R be set to B or C, 12315C since if R is not interior to the interval (B,C), it 12316C will be ignored. 12317C 12318C RE :IN - Relative error used for RW in the stopping criterion. 12319C If the requested RE is less than machine precision, 12320C then RW is set to approximately machine precision. 12321C 12322C AE :IN - Absolute error used in the stopping criterion. If 12323C the given interval (B,C) contains the origin, then a 12324C nonzero value should be chosen for AE. 12325C 12326C IFLAG :OUT - A status code. User must check IFLAG after each 12327C call. Control returns to the user from DFZERO in all 12328C cases. 12329C 12330C 1 B is within the requested tolerance of a zero. 12331C The interval (B,C) collapsed to the requested 12332C tolerance, the function changes sign in (B,C), and 12333C F(X) decreased in magnitude as (B,C) collapsed. 12334C 12335C 2 F(B) = 0. However, the interval (B,C) may not have 12336C collapsed to the requested tolerance. 12337C 12338C 3 B may be near a singular point of F(X). 12339C The interval (B,C) collapsed to the requested tol- 12340C erance and the function changes sign in (B,C), but 12341C F(X) increased in magnitude as (B,C) collapsed, i.e. 12342C ABS(F(B out)) .GT. MAX(ABS(F(B in)),ABS(F(C in))) 12343C 12344C 4 No change in sign of F(X) was found although the 12345C interval (B,C) collapsed to the requested tolerance. 12346C The user must examine this case and decide whether 12347C B is near a local minimum of F(X), or B is near a 12348C zero of even multiplicity, or neither of these. 12349C 12350C 5 Too many (.GT. 500) function evaluations used. 12351C 12352C***REFERENCES L. F. Shampine and H. A. Watts, FZERO, a root-solving 12353C code, Report SC-TM-70-631, Sandia Laboratories, 12354C September 1970. 12355C T. J. Dekker, Finding a zero by means of successive 12356C linear interpolation, Constructive Aspects of the 12357C Fundamental Theorem of Algebra, edited by B. Dejon 12358C and P. Henrici, Wiley-Interscience, 1969. 12359C***ROUTINES CALLED D1MACH 12360C***REVISION HISTORY (YYMMDD) 12361C 700901 DATE WRITTEN 12362C 890531 Changed all specific intrinsics to generic. (WRB) 12363C 890531 REVISION DATE from Version 3.2 12364C 891214 Prologue converted to Version 4.0 format. (BAB) 12365C 920501 Reformatted the REFERENCES section. (WRB) 12366C***END PROLOGUE DFZERO 12367CCCCC DOUBLE PRECISION A,ACBS,ACMB,AE,AW,B,C,CMB,D1MACH,ER, 12368 DOUBLE PRECISION A,ACBS,ACMB,AE,AW,B,C,CMB,ER, 12369 + F,FA,FB,FC,FX,FZ,P,Q,R,RE,RW,T,TOL,Z 12370 DOUBLE PRECISION X(*) 12371 INTEGER IC,IFLAG,KOUNT 12372C 12373 INCLUDE 'DPCOMC.INC' 12374 INCLUDE 'DPCOP2.INC' 12375C 12376C***FIRST EXECUTABLE STATEMENT DFZERO 12377C 12378C ER is two times the computer unit roundoff value which is defined 12379C here by the function D1MACH. 12380C 12381 ER = 2.0D0 * D1MACH(4) 12382C 12383C Initialize. 12384C 12385 Z = R 12386 IF (R .LE. MIN(B,C) .OR. R .GE. MAX(B,C)) Z = C 12387 RW = MAX(RE,ER) 12388 AW = MAX(AE,0.D0) 12389 IC = 0 12390 T = Z 12391 FZ = F(T,X) 12392 FC = FZ 12393 T = B 12394 FB = F(T,X) 12395 KOUNT = 2 12396 IF (SIGN(1.0D0,FZ) .EQ. SIGN(1.0D0,FB)) GO TO 1 12397 C = Z 12398 GO TO 2 12399 1 IF (Z .EQ. C) GO TO 2 12400 T = C 12401 FC = F(T,X) 12402 KOUNT = 3 12403 IF (SIGN(1.0D0,FZ) .EQ. SIGN(1.0D0,FC)) GO TO 2 12404 B = Z 12405 FB = FZ 12406 2 A = C 12407 FA = FC 12408 ACBS = ABS(B-C) 12409 FX = MAX(ABS(FB),ABS(FC)) 12410C 12411 3 IF (ABS(FC) .GE. ABS(FB)) GO TO 4 12412C 12413C Perform interchange. 12414C 12415 A = B 12416 FA = FB 12417 B = C 12418 FB = FC 12419 C = A 12420 FC = FA 12421C 12422 4 CMB = 0.5D0*(C-B) 12423 ACMB = ABS(CMB) 12424 TOL = RW*ABS(B) + AW 12425C 12426C Test stopping criterion and function count. 12427C 12428 IF (ACMB .LE. TOL) GO TO 10 12429 IF (FB .EQ. 0.D0) GO TO 11 12430 IF (KOUNT .GE. 500) GO TO 14 12431C 12432C Calculate new iterate implicitly as B+P/Q, where we arrange 12433C P .GE. 0. The implicit form is used to prevent overflow. 12434C 12435 P = (B-A)*FB 12436 Q = FA - FB 12437 IF (P .GE. 0.D0) GO TO 5 12438 P = -P 12439 Q = -Q 12440C 12441C Update A and check for satisfactory reduction in the size of the 12442C bracketing interval. If not, perform bisection. 12443C 12444 5 A = B 12445 FA = FB 12446 IC = IC + 1 12447 IF (IC .LT. 4) GO TO 6 12448 IF (8.0D0*ACMB .GE. ACBS) GO TO 8 12449 IC = 0 12450 ACBS = ACMB 12451C 12452C Test for too small a change. 12453C 12454 6 IF (P .GT. ABS(Q)*TOL) GO TO 7 12455C 12456C Increment by TOLerance. 12457C 12458 B = B + SIGN(TOL,CMB) 12459 GO TO 9 12460C 12461C Root ought to be between B and (C+B)/2. 12462C 12463 7 IF (P .GE. CMB*Q) GO TO 8 12464C 12465C Use secant rule. 12466C 12467 B = B + P/Q 12468 GO TO 9 12469C 12470C Use bisection (C+B)/2. 12471C 12472 8 B = B + CMB 12473C 12474C Have completed computation for new iterate B. 12475C 12476 9 T = B 12477 FB = F(T,X) 12478 KOUNT = KOUNT + 1 12479C 12480C Decide whether next step is interpolation or extrapolation. 12481C 12482 IF (SIGN(1.0D0,FB) .NE. SIGN(1.0D0,FC)) GO TO 3 12483 C = A 12484 FC = FA 12485 GO TO 3 12486C 12487C Finished. Process results for proper setting of IFLAG. 12488C 12489 10 IF (SIGN(1.0D0,FB) .EQ. SIGN(1.0D0,FC)) GO TO 13 12490 IF (ABS(FB) .GT. FX) GO TO 12 12491 IFLAG = 1 12492 RETURN 12493 11 IFLAG = 2 12494 RETURN 12495 12 IFLAG = 3 12496 RETURN 12497 13 IFLAG = 4 12498 RETURN 12499 14 IFLAG = 5 12500 RETURN 12501 END 12502 DOUBLE PRECISION FUNCTION DGAMI (A, X) 12503C***BEGIN PROLOGUE DGAMI 12504C***PURPOSE Evaluate the incomplete Gamma function. 12505C***LIBRARY SLATEC (FNLIB) 12506C***CATEGORY C7E 12507C***TYPE DOUBLE PRECISION (GAMI-S, DGAMI-D) 12508C***KEYWORDS FNLIB, INCOMPLETE GAMMA FUNCTION, SPECIAL FUNCTIONS 12509C***AUTHOR Fullerton, W., (LANL) 12510C***DESCRIPTION 12511C 12512C Evaluate the incomplete gamma function defined by 12513C 12514C DGAMI = integral from T = 0 to X of EXP(-T) * T**(A-1.0) . 12515C 12516C DGAMI is evaluated for positive values of A and non-negative values 12517C of X. A slight deterioration of 2 or 3 digits accuracy will occur 12518C when DGAMI is very large or very small, because logarithmic variables 12519C are used. The function and both arguments are double precision. 12520C 12521C***REFERENCES (NONE) 12522C***ROUTINES CALLED DGAMIT, DLNGAM, XERMSG 12523C***REVISION HISTORY (YYMMDD) 12524C 770701 DATE WRITTEN 12525C 890531 Changed all specific intrinsics to generic. (WRB) 12526C 890531 REVISION DATE from Version 3.2 12527C 891214 Prologue converted to Version 4.0 format. (BAB) 12528C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 12529C***END PROLOGUE DGAMI 12530 DOUBLE PRECISION A, X, FACTOR, DLNGAM, DGAMIT 12531C 12532C--------------------------------------------------------------------- 12533C 12534 INCLUDE 'DPCOP2.INC' 12535C 12536C***FIRST EXECUTABLE STATEMENT DGAMI 12537 IF (A .LE. 0.D0) THEN 12538 WRITE(ICOUT,11) 12539 CALL DPWRST('XXX','BUG ') 12540 DGAMI = 0.D0 12541 RETURN 12542 ENDIF 12543 11 FORMAT('***** ERROR FROM DGAMI. ALPHA SHOULD BE POSITIVE.') 12544 IF (X .LT. 0.D0) THEN 12545 WRITE(ICOUT,12) 12546 CALL DPWRST('XXX','BUG ') 12547 WRITE(ICOUT,13) 12548 CALL DPWRST('XXX','BUG ') 12549 DGAMI = 0.D0 12550 RETURN 12551 ENDIF 12552 12 FORMAT('***** ERROR FROM DGAMI. X MUST BE GREATER THAN OR ') 12553 13 FORMAT(' EQUAL TO ZERO. ****') 12554C 12555 DGAMI = 0.D0 12556 IF (X.EQ.0.0D0) RETURN 12557C 12558C THE ONLY ERROR POSSIBLE IN THE EXPRESSION BELOW IS A FATAL OVERFLOW. 12559C 12560 FACTOR = EXP (DLNGAM(A) + A*LOG(X)) 12561C 12562 DGAMI = FACTOR * DGAMIT (A, X) 12563C 12564 RETURN 12565 END 12566 DOUBLE PRECISION FUNCTION DGAMIP (A, X) 12567C***BEGIN PROLOGUE DGAMIP 12568C***PURPOSE Evaluate the incomplete Gamma function. 12569C***LIBRARY SLATEC (FNLIB) 12570C***CATEGORY C7E 12571C***TYPE DOUBLE PRECISION (GAMI-S, DGAMIP-D) 12572C***KEYWORDS FNLIB, INCOMPLETE GAMMA FUNCTION, SPECIAL FUNCTIONS 12573C***AUTHOR Fullerton, W., (LANL) 12574C***DESCRIPTION 12575C 12576C Evaluate the incomplete gamma function defined by 12577C 12578C DGAMIP = integral from T = 0 to X of EXP(-T) * T**(A-1.0) . 12579C 12580C DGAMIP is evaluated for positive values of A and non-negative values 12581C of X. A slight deterioration of 2 or 3 digits accuracy will occur 12582C when DGAMIP is very large or very small, because logarithmic variables 12583C are used. The function and both arguments are double precision. 12584C 12585C***REFERENCES (NONE) 12586C***ROUTINES CALLED DGAMIPT, DLNGAM, XERMSG 12587C***REVISION HISTORY (YYMMDD) 12588C 770701 DATE WRITTEN 12589C 890531 Changed all specific intrinsics to generic. (WRB) 12590C 890531 REVISION DATE from Version 3.2 12591C 891214 Prologue converted to Version 4.0 format. (BAB) 12592C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 12593C***END PROLOGUE DGAMIP 12594CCCCC DOUBLE PRECISION A, X, FACTOR, DLNGAM, DGAMIT 12595 DOUBLE PRECISION A, X, FACTOR, DGAMIT 12596C 12597C--------------------------------------------------------------------- 12598C 12599 INCLUDE 'DPCOP2.INC' 12600C 12601C***FIRST EXECUTABLE STATEMENT DGAMIP 12602 IF (A .LE. 0.D0) THEN 12603 WRITE(ICOUT,11) 12604 CALL DPWRST('XXX','BUG ') 12605 DGAMIP = 0.D0 12606 RETURN 12607 ENDIF 12608 11 FORMAT('***** ERROR FROM DGAMIP. ALPHA SHOULD BE POSITIVE.') 12609 IF (X .LT. 0.D0) THEN 12610 WRITE(ICOUT,12) 12611 CALL DPWRST('XXX','BUG ') 12612 WRITE(ICOUT,13) 12613 CALL DPWRST('XXX','BUG ') 12614 DGAMIP = 0.D0 12615 RETURN 12616 ENDIF 12617 12 FORMAT('***** ERROR FROM DGAMIP. X MUST BE GREATER THAN OR ') 12618 13 FORMAT(' EQUAL TO ZERO. ****') 12619C 12620 DGAMIP = 0.D0 12621 IF (X.EQ.0.0D0) RETURN 12622C 12623C THE ONLY ERROR POSSIBLE IN THE EXPRESSION BELOW IS A FATAL OVERFLOW. 12624CCCCC NOTE: FOR DATAPLOT, WANT FORM OF INCOMPLETE GAMMA THAT HAS 12625CCCCC DIVISION BY COMPLETE GAMMA FUNCTION INCLUDED! 12626C 12627CCCCC FACTOR = EXP (DLNGAM(A) + A*LOG(X)) 12628 FACTOR = EXP(A*LOG(X)) 12629C 12630 DGAMIP = FACTOR * DGAMIT (A, X) 12631C 12632 RETURN 12633 END 12634 DOUBLE PRECISION FUNCTION DGAMIC (A, X) 12635C***BEGIN PROLOGUE DGAMIC 12636C***PURPOSE Calculate the complementary incomplete Gamma function. 12637C***LIBRARY SLATEC (FNLIB) 12638C***CATEGORY C7E 12639C***TYPE DOUBLE PRECISION (GAMIC-S, DGAMIC-D) 12640C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, 12641C SPECIAL FUNCTIONS 12642C***AUTHOR Fullerton, W., (LANL) 12643C***DESCRIPTION 12644C 12645C Evaluate the complementary incomplete Gamma function 12646C 12647C DGAMIC = integral from X to infinity of EXP(-T) * T**(A-1.) . 12648C 12649C DGAMIC is evaluated for arbitrary real values of A and for non- 12650C negative values of X (even though DGAMIC is defined for X .LT. 12651C 0.0), except that for X = 0 and A .LE. 0.0, DGAMIC is undefined. 12652C 12653C DGAMIC, A, and X are DOUBLE PRECISION. 12654C 12655C A slight deterioration of 2 or 3 digits accuracy will occur when 12656C DGAMIC is very large or very small in absolute value, because log- 12657C arithmic variables are used. Also, if the parameter A is very close 12658C to a negative INTEGER (but not a negative integer), there is a loss 12659C of accuracy, which is reported if the result is less than half 12660C machine precision. 12661C 12662C***REFERENCES W. Gautschi, A computational procedure for incomplete 12663C gamma functions, ACM Transactions on Mathematical 12664C Software 5, 4 (December 1979), pp. 466-481. 12665C W. Gautschi, Incomplete gamma functions, Algorithm 542, 12666C ACM Transactions on Mathematical Software 5, 4 12667C (December 1979), pp. 482-489. 12668C***ROUTINES CALLED D1MACH, D9GMIC, D9GMIT, D9LGIC, D9LGIT, DLGAMS, 12669C DLNGAM, XERCLR, XERMSG 12670C***REVISION HISTORY (YYMMDD) 12671C 770701 DATE WRITTEN 12672C 890531 Changed all specific intrinsics to generic. (WRB) 12673C 890531 REVISION DATE from Version 3.2 12674C 891214 Prologue converted to Version 4.0 format. (BAB) 12675C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 12676C 920528 DESCRIPTION and REFERENCES sections revised. (WRB) 12677C***END PROLOGUE DGAMIC 12678C 12679C-----COMMON---------------------------------------------------------- 12680C 12681 INCLUDE 'DPCOMC.INC' 12682 INCLUDE 'DPCOP2.INC' 12683C 12684 DOUBLE PRECISION A, X, AEPS, AINTA, ALGAP1, ALNEPS, ALNGS, ALX, 12685 1 BOT, E, EPS, GSTAR, H, SGA, SGNG, SGNGAM, SGNGS, SQEPS, T, 12686 2 DLNGAM, D9GMIC, D9GMIT, D9LGIC, D9LGIT 12687 LOGICAL FIRST 12688 SAVE EPS, SQEPS, ALNEPS, BOT, FIRST 12689 DATA FIRST /.TRUE./ 12690C***FIRST EXECUTABLE STATEMENT DGAMIC 12691C 12692 DGAMIC = 0.D0 12693C 12694 IF (FIRST) THEN 12695 EPS = 0.5D0*D1MACH(3) 12696 SQEPS = SQRT(D1MACH(4)) 12697 ALNEPS = -LOG (D1MACH(3)) 12698 BOT = LOG (D1MACH(1)) 12699 ENDIF 12700 FIRST = .FALSE. 12701C 12702 IF (X .LT. 0.D0) THEN 12703 WRITE(ICOUT,12) 12704 CALL DPWRST('XXX','BUG ') 12705 DGAMIC = 0.D0 12706 RETURN 12707 ENDIF 12708 12 FORMAT('***** ERROR FROM DGAMIC. X MUST BE GREATER THAN OR ', 12709 1 'EQUAL TO ZERO. ****') 12710C 12711 IF (X.GT.0.D0) GO TO 20 12712 IF (A .LE. 0.D0) THEN 12713 WRITE(ICOUT,11) 12714 CALL DPWRST('XXX','BUG ') 12715 DGAMIC = 0.D0 12716 RETURN 12717 ENDIF 12718 11 FORMAT('***** ERROR FROM DGAMI. GAMMAIC IS UNDEFINED SINCE X ', 12719 1 'ZERO AND A IS NON-POSITIVE. *****') 12720C 12721 DGAMIC = EXP (DLNGAM(A+1.D0) - LOG(A)) 12722 RETURN 12723C 12724 20 ALX = LOG (X) 12725 SGA = 1.0D0 12726 IF (A.NE.0.D0) SGA = SIGN (1.0D0, A) 12727 AINTA = AINT (A + 0.5D0*SGA) 12728 AEPS = A - AINTA 12729C 12730 IZERO = 0 12731 IF (X.GE.1.0D0) GO TO 40 12732C 12733 IF (A.GT.0.5D0 .OR. ABS(AEPS).GT.0.001D0) GO TO 30 12734 E = 2.0D0 12735 IF (-AINTA.GT.1.D0) E = 2.D0*(-AINTA+2.D0)/(AINTA*AINTA-1.0D0) 12736 E = E - ALX * X**(-0.001D0) 12737 IF (E*ABS(AEPS).GT.EPS) GO TO 30 12738C 12739 DGAMIC = D9GMIC (A, X, ALX) 12740 RETURN 12741C 12742 30 CALL DLGAMS (A+1.0D0, ALGAP1, SGNGAM) 12743 GSTAR = D9GMIT (A, X, ALGAP1, SGNGAM, ALX) 12744 IF (GSTAR.EQ.0.D0) IZERO = 1 12745 IF (GSTAR.NE.0.D0) ALNGS = LOG (ABS(GSTAR)) 12746 IF (GSTAR.NE.0.D0) SGNGS = SIGN (1.0D0, GSTAR) 12747 GO TO 50 12748C 12749 40 IF (A.LT.X) DGAMIC = EXP (D9LGIC(A, X, ALX)) 12750 IF (A.LT.X) RETURN 12751C 12752 SGNGAM = 1.0D0 12753 ALGAP1 = DLNGAM (A+1.0D0) 12754 SGNGS = 1.0D0 12755 ALNGS = D9LGIT (A, X, ALGAP1) 12756C 12757C EVALUATION OF DGAMIC(A,X) IN TERMS OF TRICOMI-S INCOMPLETE GAMMA FN. 12758C 12759 50 H = 1.D0 12760 IF (IZERO.EQ.1) GO TO 60 12761C 12762 T = A*ALX + ALNGS 12763 IF (T.GT.ALNEPS) GO TO 70 12764 IF (T.GT.(-ALNEPS)) H = 1.0D0 - SGNGS*EXP(T) 12765C 12766CCCCC IF (ABS(H).LT.SQEPS) CALL XERCLR 12767 IF (ABS(H) .LT. SQEPS) THEN 12768 WRITE(ICOUT,51) 12769 CALL DPWRST('XXX','BUG ') 12770 ENDIF 12771 51 FORMAT('***** WARNING FROM DGAMIC, RESULT IS LESS THAN HALF ', 12772 1 'PRECISION. ****') 12773C 12774 60 SGNG = SIGN (1.0D0, H) * SGA * SGNGAM 12775 T = LOG(ABS(H)) + ALGAP1 - LOG(ABS(A)) 12776CCCCC IF (T.LT.BOT) CALL XERCLR 12777 DGAMIC = SGNG * EXP(T) 12778 RETURN 12779C 12780 70 SGNG = -SGNGS * SGA * SGNGAM 12781 T = T + ALGAP1 - LOG(ABS(A)) 12782CCCCC IF (T.LT.BOT) CALL XERCLR 12783 DGAMIC = SGNG * EXP(T) 12784 RETURN 12785C 12786 END 12787 DOUBLE PRECISION FUNCTION DGAMIT (A, X) 12788C***BEGIN PROLOGUE DGAMIT 12789C***PURPOSE Calculate Tricomi's form of the incomplete Gamma function. 12790C***LIBRARY SLATEC (FNLIB) 12791C***CATEGORY C7E 12792C***TYPE DOUBLE PRECISION (GAMIT-S, DGAMIT-D) 12793C***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, 12794C SPECIAL FUNCTIONS, TRICOMI 12795C***AUTHOR Fullerton, W., (LANL) 12796C***DESCRIPTION 12797C 12798C Evaluate Tricomi's incomplete Gamma function defined by 12799C 12800C DGAMIT = X**(-A)/GAMMA(A) * integral from 0 to X of EXP(-T) * 12801C T**(A-1.) 12802C 12803C for A .GT. 0.0 and by analytic continuation for A .LE. 0.0. 12804C GAMMA(X) is the complete gamma function of X. 12805C 12806C DGAMIT is evaluated for arbitrary real values of A and for non- 12807C negative values of X (even though DGAMIT is defined for X .LT. 12808C 0.0), except that for X = 0 and A .LE. 0.0, DGAMIT is infinite, 12809C which is a fatal error. 12810C 12811C The function and both arguments are DOUBLE PRECISION. 12812C 12813C A slight deterioration of 2 or 3 digits accuracy will occur when 12814C DGAMIT is very large or very small in absolute value, because log- 12815C arithmic variables are used. Also, if the parameter A is very 12816C close to a negative integer (but not a negative integer), there is 12817C a loss of accuracy, which is reported if the result is less than 12818C half machine precision. 12819C 12820C***REFERENCES W. Gautschi, A computational procedure for incomplete 12821C gamma functions, ACM Transactions on Mathematical 12822C Software 5, 4 (December 1979), pp. 466-481. 12823C W. Gautschi, Incomplete gamma functions, Algorithm 542, 12824C ACM Transactions on Mathematical Software 5, 4 12825C (December 1979), pp. 482-489. 12826C***ROUTINES CALLED D1MACH, D9GMIT, D9LGIC, D9LGIT, DGAMR, DLGAMS, 12827C DLNGAM, XERCLR, XERMSG 12828C***REVISION HISTORY (YYMMDD) 12829C 770701 DATE WRITTEN 12830C 890531 Changed all specific intrinsics to generic. (WRB) 12831C 890531 REVISION DATE from Version 3.2 12832C 891214 Prologue converted to Version 4.0 format. (BAB) 12833C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 12834C 920528 DESCRIPTION and REFERENCES sections revised. (WRB) 12835C***END PROLOGUE DGAMIT 12836 DOUBLE PRECISION A, X, AEPS, AINTA, ALGAP1, ALNEPS, ALNG, ALX, 12837 1 BOT, H, SGA, SGNGAM, SQEPS, T, DGAMR, D9GMIT, D9LGIT, 12838 2 DLNGAM, D9LGIC 12839 LOGICAL FIRST 12840 SAVE ALNEPS, SQEPS, BOT, FIRST 12841C 12842C-----COMMON---------------------------------------------------------- 12843C 12844 INCLUDE 'DPCOMC.INC' 12845 INCLUDE 'DPCOP2.INC' 12846C 12847 DATA FIRST /.TRUE./ 12848C***FIRST EXECUTABLE STATEMENT DGAMIT 12849 IF (FIRST) THEN 12850 ALNEPS = -LOG (D1MACH(3)) 12851 SQEPS = SQRT(D1MACH(4)) 12852 BOT = LOG (D1MACH(1)) 12853 ENDIF 12854 FIRST = .FALSE. 12855C 12856 IF (X .LT. 0.D0) THEN 12857 WRITE(ICOUT,11) 12858 CALL DPWRST('XXX','BUG ') 12859 DGAMIT = 0.D0 12860 RETURN 12861 ENDIF 12862 11 FORMAT('***** ERROR FROM DGAMIT. X IS NEGATIVE. *****') 12863C 12864 IF (X.NE.0.D0) ALX = LOG (X) 12865 SGA = 1.0D0 12866 IF (A.NE.0.D0) SGA = SIGN (1.0D0, A) 12867 AINTA = AINT (A + 0.5D0*SGA) 12868 AEPS = A - AINTA 12869C 12870 IF (X.GT.0.D0) GO TO 20 12871 DGAMIT = 0.0D0 12872 IF (AINTA.GT.0.D0 .OR. AEPS.NE.0.D0) DGAMIT = DGAMR(A+1.0D0) 12873 RETURN 12874C 12875 20 IF (X.GT.1.D0) GO TO 30 12876 IF (A.GE.(-0.5D0) .OR. AEPS.NE.0.D0) CALL DLGAMS (A+1.0D0, ALGAP1, 12877 1 SGNGAM) 12878 DGAMIT = D9GMIT (A, X, ALGAP1, SGNGAM, ALX) 12879 RETURN 12880C 12881 30 IF (A.LT.X) GO TO 40 12882 T = D9LGIT (A, X, DLNGAM(A+1.0D0)) 12883CCCCC IF (T.LT.BOT) CALL XERCLR 12884 DGAMIT = EXP (T) 12885 RETURN 12886C 12887 40 ALNG = D9LGIC (A, X, ALX) 12888C 12889C EVALUATE DGAMIT IN TERMS OF LOG (DGAMIC (A, X)) 12890C 12891 H = 1.0D0 12892 IF (AEPS.EQ.0.D0 .AND. AINTA.LE.0.D0) GO TO 50 12893C 12894 CALL DLGAMS (A+1.0D0, ALGAP1, SGNGAM) 12895 T = LOG (ABS(A)) + ALNG - ALGAP1 12896 IF (T.GT.ALNEPS) GO TO 60 12897C 12898 IF (T.GT.(-ALNEPS)) H = 1.0D0 - SGA * SGNGAM * EXP(T) 12899 IF (ABS(H).GT.SQEPS) GO TO 50 12900C 12901 WRITE(ICOUT,41) 12902 41 FORMAT('***** WARNING FROM DGAMIT. RESULT IS LESS THAN ') 12903 CALL DPWRST('XXX','BUG ') 12904 WRITE(ICOUT,42) 12905 42 FORMAT(' HALF PRECISION. *****') 12906 CALL DPWRST('XXX','BUG ') 12907C 12908 50 T = -A*ALX + LOG(ABS(H)) 12909CCCCC IF (T.LT.BOT) CALL XERCLR 12910 DGAMIT = SIGN (EXP(T), H) 12911 RETURN 12912C 12913 60 T = T - A*ALX 12914CCCCC IF (T.LT.BOT) CALL XERCLR 12915 DGAMIT = -SGA * SGNGAM * EXP(T) 12916 RETURN 12917C 12918 END 12919 SUBROUTINE DGAMLM (XMIN, XMAX) 12920C***BEGIN PROLOGUE DGAMLM 12921C***PURPOSE Compute the minimum and maximum bounds for the argument in 12922C the Gamma function. 12923C***LIBRARY SLATEC (FNLIB) 12924C***CATEGORY C7A, R2 12925C***TYPE DOUBLE PRECISION (GAMLIM-S, DGAMLM-D) 12926C***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, LIMITS, SPECIAL FUNCTIONS 12927C***AUTHOR Fullerton, W., (LANL) 12928C***DESCRIPTION 12929C 12930C Calculate the minimum and maximum legal bounds for X in gamma(X). 12931C XMIN and XMAX are not the only bounds, but they are the only non- 12932C trivial ones to calculate. 12933C 12934C Output Arguments -- 12935C XMIN double precision minimum legal value of X in gamma(X). Any 12936C smaller value of X might result in underflow. 12937C XMAX double precision maximum legal value of X in gamma(X). Any 12938C larger value of X might cause overflow. 12939C 12940C***REFERENCES (NONE) 12941C***ROUTINES CALLED D1MACH, XERMSG 12942C***REVISION HISTORY (YYMMDD) 12943C 770601 DATE WRITTEN 12944C 890531 Changed all specific intrinsics to generic. (WRB) 12945C 890531 REVISION DATE from Version 3.2 12946C 891214 Prologue converted to Version 4.0 format. (BAB) 12947C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 12948C***END PROLOGUE DGAMLM 12949 DOUBLE PRECISION XMIN, XMAX, ALNBIG, ALNSML, XLN, XOLD 12950C 12951C-----COMMON---------------------------------------------------------- 12952C 12953 INCLUDE 'DPCOMC.INC' 12954 INCLUDE 'DPCOP2.INC' 12955C 12956C***FIRST EXECUTABLE STATEMENT DGAMLM 12957 ALNSML = LOG(D1MACH(1)) 12958 XMIN = -ALNSML 12959 DO 10 I=1,10 12960 XOLD = XMIN 12961 XLN = LOG(XMIN) 12962 XMIN = XMIN - XMIN*((XMIN+0.5D0)*XLN - XMIN - 0.2258D0 + ALNSML) 12963 1 / (XMIN*XLN+0.5D0) 12964 IF (ABS(XMIN-XOLD).LT.0.005D0) GO TO 20 12965 10 CONTINUE 12966 WRITE(ICOUT,11) 12967 11 FORMAT('***** ERROR FROM DGAMLM. UNABLE TO FIND XMIN. ******') 12968 CALL DPWRST('XXX','BUG ') 12969 RETURN 12970C 12971 20 XMIN = -XMIN + 0.01D0 12972C 12973 ALNBIG = LOG (D1MACH(2)) 12974 XMAX = ALNBIG 12975 DO 30 I=1,10 12976 XOLD = XMAX 12977 XLN = LOG(XMAX) 12978 XMAX = XMAX - XMAX*((XMAX-0.5D0)*XLN - XMAX + 0.9189D0 - ALNBIG) 12979 1 / (XMAX*XLN-0.5D0) 12980 IF (ABS(XMAX-XOLD).LT.0.005D0) GO TO 40 12981 30 CONTINUE 12982 WRITE(ICOUT,21) 12983 21 FORMAT('***** ERROR FROM DGAMLM. UNABLE TO FIND XMAX. ******') 12984 CALL DPWRST('XXX','BUG ') 12985 RETURN 12986C 12987 40 XMAX = XMAX - 0.01D0 12988 XMIN = MAX (XMIN, -XMAX+1.D0) 12989C 12990 RETURN 12991 END 12992 DOUBLE PRECISION FUNCTION DGAMMA (X) 12993C***BEGIN PROLOGUE DGAMMA 12994C***PURPOSE Compute the complete Gamma function. 12995C***LIBRARY SLATEC (FNLIB) 12996C***CATEGORY C7A 12997C***TYPE DOUBLE PRECISION (GAMMA-S, DGAMMA-D, CGAMMA-C) 12998C***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, SPECIAL FUNCTIONS 12999C***AUTHOR Fullerton, W., (LANL) 13000C***DESCRIPTION 13001C 13002C DGAMMA(X) calculates the double precision complete Gamma function 13003C for double precision argument X. 13004C 13005C Series for GAM on the interval 0. to 1.00000E+00 13006C with weighted error 5.79E-32 13007C log weighted error 31.24 13008C significant figures required 30.00 13009C decimal places required 32.05 13010C 13011C***REFERENCES (NONE) 13012C***ROUTINES CALLED D1MACH, D9LGMC, DCSEVL, DGAMLM, INITDS, XERMSG 13013C***REVISION HISTORY (YYMMDD) 13014C 770601 DATE WRITTEN 13015C 890531 Changed all specific intrinsics to generic. (WRB) 13016C 890911 Removed unnecessary intrinsics. (WRB) 13017C 890911 REVISION DATE from Version 3.2 13018C 891214 Prologue converted to Version 4.0 format. (BAB) 13019C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 13020C 920618 Removed space from variable name. (RWC, WRB) 13021C***END PROLOGUE DGAMMA 13022 DOUBLE PRECISION X, GAMCS(42), DXREL, PI, SINPIY, SQ2PIL, XMAX, 13023 1 XMIN, Y, D9LGMC, DCSEVL 13024 LOGICAL FIRST 13025C 13026 SAVE GAMCS, PI, SQ2PIL, NGAM, XMIN, XMAX, DXREL, FIRST 13027C 13028C-----COMMON---------------------------------------------------------- 13029C 13030 INCLUDE 'DPCOMC.INC' 13031 INCLUDE 'DPCOP2.INC' 13032C 13033 DATA GAMCS( 1) / +.8571195590 9893314219 2006239994 2 D-2 / 13034 DATA GAMCS( 2) / +.4415381324 8410067571 9131577165 2 D-2 / 13035 DATA GAMCS( 3) / +.5685043681 5993633786 3266458878 9 D-1 / 13036 DATA GAMCS( 4) / -.4219835396 4185605010 1250018662 4 D-2 / 13037 DATA GAMCS( 5) / +.1326808181 2124602205 8400679635 2 D-2 / 13038 DATA GAMCS( 6) / -.1893024529 7988804325 2394702388 6 D-3 / 13039 DATA GAMCS( 7) / +.3606925327 4412452565 7808221722 5 D-4 / 13040 DATA GAMCS( 8) / -.6056761904 4608642184 8554829036 5 D-5 / 13041 DATA GAMCS( 9) / +.1055829546 3022833447 3182350909 3 D-5 / 13042 DATA GAMCS( 10) / -.1811967365 5423840482 9185589116 6 D-6 / 13043 DATA GAMCS( 11) / +.3117724964 7153222777 9025459316 9 D-7 / 13044 DATA GAMCS( 12) / -.5354219639 0196871408 7408102434 7 D-8 / 13045 DATA GAMCS( 13) / +.9193275519 8595889468 8778682594 0 D-9 / 13046 DATA GAMCS( 14) / -.1577941280 2883397617 6742327395 3 D-9 / 13047 DATA GAMCS( 15) / +.2707980622 9349545432 6654043308 9 D-10 / 13048 DATA GAMCS( 16) / -.4646818653 8257301440 8166105893 3 D-11 / 13049 DATA GAMCS( 17) / +.7973350192 0074196564 6076717535 9 D-12 / 13050 DATA GAMCS( 18) / -.1368078209 8309160257 9949917230 9 D-12 / 13051 DATA GAMCS( 19) / +.2347319486 5638006572 3347177168 8 D-13 / 13052 DATA GAMCS( 20) / -.4027432614 9490669327 6657053469 9 D-14 / 13053 DATA GAMCS( 21) / +.6910051747 3721009121 3833697525 7 D-15 / 13054 DATA GAMCS( 22) / -.1185584500 2219929070 5238712619 2 D-15 / 13055 DATA GAMCS( 23) / +.2034148542 4963739552 0102605193 2 D-16 / 13056 DATA GAMCS( 24) / -.3490054341 7174058492 7401294910 8 D-17 / 13057 DATA GAMCS( 25) / +.5987993856 4853055671 3505106602 6 D-18 / 13058 DATA GAMCS( 26) / -.1027378057 8722280744 9006977843 1 D-18 / 13059 DATA GAMCS( 27) / +.1762702816 0605298249 4275966074 8 D-19 / 13060 DATA GAMCS( 28) / -.3024320653 7353062609 5877211204 2 D-20 / 13061 DATA GAMCS( 29) / +.5188914660 2183978397 1783355050 6 D-21 / 13062 DATA GAMCS( 30) / -.8902770842 4565766924 4925160106 6 D-22 / 13063 DATA GAMCS( 31) / +.1527474068 4933426022 7459689130 6 D-22 / 13064 DATA GAMCS( 32) / -.2620731256 1873629002 5732833279 9 D-23 / 13065 DATA GAMCS( 33) / +.4496464047 8305386703 3104657066 6 D-24 / 13066 DATA GAMCS( 34) / -.7714712731 3368779117 0390152533 3 D-25 / 13067 DATA GAMCS( 35) / +.1323635453 1260440364 8657271466 6 D-25 / 13068 DATA GAMCS( 36) / -.2270999412 9429288167 0231381333 3 D-26 / 13069 DATA GAMCS( 37) / +.3896418998 0039914493 2081663999 9 D-27 / 13070 DATA GAMCS( 38) / -.6685198115 1259533277 9212799999 9 D-28 / 13071 DATA GAMCS( 39) / +.1146998663 1400243843 4761386666 6 D-28 / 13072 DATA GAMCS( 40) / -.1967938586 3451346772 9510399999 9 D-29 / 13073 DATA GAMCS( 41) / +.3376448816 5853380903 3489066666 6 D-30 / 13074 DATA GAMCS( 42) / -.5793070335 7821357846 2549333333 3 D-31 / 13075 DATA PI / 3.1415926535 8979323846 2643383279 50 D0 / 13076 DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / 13077 DATA FIRST /.TRUE./ 13078C***FIRST EXECUTABLE STATEMENT DGAMMA 13079 IF (FIRST) THEN 13080 NGAM = INITDS (GAMCS, 42, 0.1*REAL(D1MACH(3)) ) 13081C 13082 CALL DGAMLM (XMIN, XMAX) 13083 DXREL = SQRT(D1MACH(4)) 13084 ENDIF 13085 FIRST = .FALSE. 13086C 13087 Y = ABS(X) 13088 IF (Y.GT.10.D0) GO TO 50 13089C 13090C COMPUTE GAMMA(X) FOR -XBND .LE. X .LE. XBND. REDUCE INTERVAL AND FIND 13091C GAMMA(1+Y) FOR 0.0 .LE. Y .LT. 1.0 FIRST OF ALL. 13092C 13093 N = INT(X+0.1) 13094 IF (X.LT.0.D0) N = N - 1 13095 Y = X - N 13096 N = N - 1 13097 DGAMMA = 0.9375D0 + DCSEVL (2.D0*Y-1.D0, GAMCS, NGAM) 13098 IF (N.EQ.0) RETURN 13099C 13100 IF (N.GT.0) GO TO 30 13101C 13102C COMPUTE GAMMA(X) FOR X .LT. 1.0 13103C 13104 N = -N 13105 IF (X .EQ. 0.D0) THEN 13106 WRITE(ICOUT,11) 13107 CALL DPWRST('XXX','BUG ') 13108 DGAMMA = 0.D0 13109 RETURN 13110 ENDIF 13111 11 FORMAT('***** ERROR FROM DGAMMA. X IS 0. ******') 13112 IF (X .LT. 0.0 .AND. X+N-2 .EQ. 0.D0)THEN 13113 WRITE(ICOUT,16) 13114 CALL DPWRST('XXX','BUG ') 13115 DGAMMA = 0.D0 13116 RETURN 13117 ENDIF 13118 16 FORMAT('***** ERROR FROM DGAMMA. X IS A NEGATIVE INTEGER. ****') 13119 IF(X .LT. (-0.5D0) .AND. ABS((X-AINT(X-0.5D0))/X) .LT. DXREL)THEN 13120 WRITE(ICOUT,21) 13121 CALL DPWRST('XXX','BUG ') 13122 ENDIF 13123 21 FORMAT('***** WARNING FROM DGAMMA. ANSWER IS LESS THAN ') 13124CCC22 FORMAT(' HALF PRECISION BECAUSE X IS TOO NEAR A ') 13125CCC23 FORMAT(' NEGATIVE INTEGER. *****') 13126C 13127 DO 20 I=1,N 13128 DGAMMA = DGAMMA/(X+I-1 ) 13129 20 CONTINUE 13130 RETURN 13131C 13132C GAMMA(X) FOR X .GE. 2.0 AND X .LE. 10.0 13133C 13134 30 DO 40 I=1,N 13135 DGAMMA = (Y+I) * DGAMMA 13136 40 CONTINUE 13137 RETURN 13138C 13139C GAMMA(X) FOR ABS(X) .GT. 10.0. RECALL Y = ABS(X). 13140C 13141 50 IF (X .GT. XMAX) THEN 13142 WRITE(ICOUT,51) 13143 CALL DPWRST('XXX','BUG ') 13144 WRITE(ICOUT,52) 13145 CALL DPWRST('XXX','BUG ') 13146 DGAMMA = 0.D0 13147 RETURN 13148 ENDIF 13149 51 FORMAT('***** ERROR FROM DGAMMA. X IS SO BIG THAT THE ') 13150 52 FORMAT(' DGAMMA FUNCTION OVERFLOWS. *****') 13151C 13152 DGAMMA = 0.D0 13153 IF (X .LT. XMIN) THEN 13154 WRITE(ICOUT,56) 13155 CALL DPWRST('XXX','BUG ') 13156 WRITE(ICOUT,57) 13157 CALL DPWRST('XXX','BUG ') 13158 ENDIF 13159 56 FORMAT('***** WARNING FROM DGAMMA. X IS SO SMALL THAT THE ') 13160 57 FORMAT(' DGAMMA FUNCTION UNDERFLOWS. *****') 13161 IF (X.LT.XMIN) RETURN 13162C 13163 DGAMMA = EXP ((Y-0.5D0)*LOG(Y) - Y + SQ2PIL + D9LGMC(Y) ) 13164 IF (X.GT.0.D0) RETURN 13165C 13166 IF (ABS((X-AINT(X-0.5D0))/X) .LT. DXREL) THEN 13167 WRITE(ICOUT,61) 13168 CALL DPWRST('XXX','BUG ') 13169 WRITE(ICOUT,62) 13170 CALL DPWRST('XXX','BUG ') 13171 WRITE(ICOUT,63) 13172 CALL DPWRST('XXX','BUG ') 13173 ENDIF 13174 61 FORMAT('***** WARNING FROM DGAMMA. ANSWER IS LESS THAN ') 13175 62 FORMAT(' PRECISION BECAUSE X IS TOO NEAR A NEGATIVE ') 13176 63 FORMAT(' NUMBER. *****') 13177C 13178 SINPIY = SIN (PI*Y) 13179 IF (SINPIY .EQ. 0.D0) THEN 13180 WRITE(ICOUT,71) 13181 CALL DPWRST('XXX','BUG ') 13182 DGAMMA = 0.D0 13183 RETURN 13184 ENDIF 13185 71 FORMAT('***** ERROR FROM DGAMMA. X IS A NEGATIVE INTEGER. ****') 13186C 13187 DGAMMA = -PI/(Y*SINPIY*DGAMMA) 13188C 13189 RETURN 13190 END 13191 DOUBLE PRECISION FUNCTION DGAMM2 (X) 13192C***BEGIN PROLOGUE DGAMMA 13193C***PURPOSE Compute the complete Gamma function. 13194C***LIBRARY SLATEC (FNLIB) 13195C***CATEGORY C7A 13196C***TYPE DOUBLE PRECISION (GAMMA-S, DGAMMA-D, CGAMMA-C) 13197C***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, SPECIAL FUNCTIONS 13198C***AUTHOR Fullerton, W., (LANL) 13199C***DESCRIPTION 13200C 13201C DGAMMA(X) calculates the double precision complete Gamma function 13202C for double precision argument X. 13203C 13204C This same as DGAMMA, except error messages are suppressed. 13205C 13206C Series for GAM on the interval 0. to 1.00000E+00 13207C with weighted error 5.79E-32 13208C log weighted error 31.24 13209C significant figures required 30.00 13210C decimal places required 32.05 13211C 13212C***REFERENCES (NONE) 13213C***ROUTINES CALLED D1MACH, D9LGMC, DCSEVL, DGAMLM, INITDS, XERMSG 13214C***REVISION HISTORY (YYMMDD) 13215C 770601 DATE WRITTEN 13216C 890531 Changed all specific intrinsics to generic. (WRB) 13217C 890911 Removed unnecessary intrinsics. (WRB) 13218C 890911 REVISION DATE from Version 3.2 13219C 891214 Prologue converted to Version 4.0 format. (BAB) 13220C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 13221C 920618 Removed space from variable name. (RWC, WRB) 13222C***END PROLOGUE DGAMMA 13223 DOUBLE PRECISION X, GAMCS(42), DXREL, PI, SINPIY, SQ2PIL, XMAX, 13224 1 XMIN, Y, D9LGMC, DCSEVL 13225 LOGICAL FIRST 13226C 13227 SAVE GAMCS, PI, SQ2PIL, NGAM, XMIN, XMAX, DXREL, FIRST 13228C 13229C-----COMMON---------------------------------------------------------- 13230C 13231 INCLUDE 'DPCOMC.INC' 13232 INCLUDE 'DPCOP2.INC' 13233C 13234 DATA GAMCS( 1) / +.8571195590 9893314219 2006239994 2 D-2 / 13235 DATA GAMCS( 2) / +.4415381324 8410067571 9131577165 2 D-2 / 13236 DATA GAMCS( 3) / +.5685043681 5993633786 3266458878 9 D-1 / 13237 DATA GAMCS( 4) / -.4219835396 4185605010 1250018662 4 D-2 / 13238 DATA GAMCS( 5) / +.1326808181 2124602205 8400679635 2 D-2 / 13239 DATA GAMCS( 6) / -.1893024529 7988804325 2394702388 6 D-3 / 13240 DATA GAMCS( 7) / +.3606925327 4412452565 7808221722 5 D-4 / 13241 DATA GAMCS( 8) / -.6056761904 4608642184 8554829036 5 D-5 / 13242 DATA GAMCS( 9) / +.1055829546 3022833447 3182350909 3 D-5 / 13243 DATA GAMCS( 10) / -.1811967365 5423840482 9185589116 6 D-6 / 13244 DATA GAMCS( 11) / +.3117724964 7153222777 9025459316 9 D-7 / 13245 DATA GAMCS( 12) / -.5354219639 0196871408 7408102434 7 D-8 / 13246 DATA GAMCS( 13) / +.9193275519 8595889468 8778682594 0 D-9 / 13247 DATA GAMCS( 14) / -.1577941280 2883397617 6742327395 3 D-9 / 13248 DATA GAMCS( 15) / +.2707980622 9349545432 6654043308 9 D-10 / 13249 DATA GAMCS( 16) / -.4646818653 8257301440 8166105893 3 D-11 / 13250 DATA GAMCS( 17) / +.7973350192 0074196564 6076717535 9 D-12 / 13251 DATA GAMCS( 18) / -.1368078209 8309160257 9949917230 9 D-12 / 13252 DATA GAMCS( 19) / +.2347319486 5638006572 3347177168 8 D-13 / 13253 DATA GAMCS( 20) / -.4027432614 9490669327 6657053469 9 D-14 / 13254 DATA GAMCS( 21) / +.6910051747 3721009121 3833697525 7 D-15 / 13255 DATA GAMCS( 22) / -.1185584500 2219929070 5238712619 2 D-15 / 13256 DATA GAMCS( 23) / +.2034148542 4963739552 0102605193 2 D-16 / 13257 DATA GAMCS( 24) / -.3490054341 7174058492 7401294910 8 D-17 / 13258 DATA GAMCS( 25) / +.5987993856 4853055671 3505106602 6 D-18 / 13259 DATA GAMCS( 26) / -.1027378057 8722280744 9006977843 1 D-18 / 13260 DATA GAMCS( 27) / +.1762702816 0605298249 4275966074 8 D-19 / 13261 DATA GAMCS( 28) / -.3024320653 7353062609 5877211204 2 D-20 / 13262 DATA GAMCS( 29) / +.5188914660 2183978397 1783355050 6 D-21 / 13263 DATA GAMCS( 30) / -.8902770842 4565766924 4925160106 6 D-22 / 13264 DATA GAMCS( 31) / +.1527474068 4933426022 7459689130 6 D-22 / 13265 DATA GAMCS( 32) / -.2620731256 1873629002 5732833279 9 D-23 / 13266 DATA GAMCS( 33) / +.4496464047 8305386703 3104657066 6 D-24 / 13267 DATA GAMCS( 34) / -.7714712731 3368779117 0390152533 3 D-25 / 13268 DATA GAMCS( 35) / +.1323635453 1260440364 8657271466 6 D-25 / 13269 DATA GAMCS( 36) / -.2270999412 9429288167 0231381333 3 D-26 / 13270 DATA GAMCS( 37) / +.3896418998 0039914493 2081663999 9 D-27 / 13271 DATA GAMCS( 38) / -.6685198115 1259533277 9212799999 9 D-28 / 13272 DATA GAMCS( 39) / +.1146998663 1400243843 4761386666 6 D-28 / 13273 DATA GAMCS( 40) / -.1967938586 3451346772 9510399999 9 D-29 / 13274 DATA GAMCS( 41) / +.3376448816 5853380903 3489066666 6 D-30 / 13275 DATA GAMCS( 42) / -.5793070335 7821357846 2549333333 3 D-31 / 13276 DATA PI / 3.1415926535 8979323846 2643383279 50 D0 / 13277 DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / 13278 DATA FIRST /.TRUE./ 13279C***FIRST EXECUTABLE STATEMENT DGAMMA 13280 IF (FIRST) THEN 13281 NGAM = INITDS (GAMCS, 42, 0.1*REAL(D1MACH(3)) ) 13282C 13283 CALL DGAMLM (XMIN, XMAX) 13284 DXREL = SQRT(D1MACH(4)) 13285 ENDIF 13286 FIRST = .FALSE. 13287C 13288 Y = ABS(X) 13289 IF (Y.GT.10.D0) GO TO 50 13290C 13291C COMPUTE GAMMA(X) FOR -XBND .LE. X .LE. XBND. REDUCE INTERVAL AND FIND 13292C GAMMA(1+Y) FOR 0.0 .LE. Y .LT. 1.0 FIRST OF ALL. 13293C 13294 N = INT(X) 13295 IF (X.LT.0.D0) N = N - 1 13296 Y = X - REAL(N) 13297 N = N - 1 13298 DGAMM2 = 0.9375D0 + DCSEVL (2.D0*Y-1.D0, GAMCS, NGAM) 13299 IF (N.EQ.0) RETURN 13300C 13301 IF (N.GT.0) GO TO 30 13302C 13303C COMPUTE GAMMA(X) FOR X .LT. 1.0 13304C 13305 N = -N 13306 IF (X .EQ. 0.D0) THEN 13307 DGAMM2 = 0.D0 13308 RETURN 13309 ENDIF 13310 IF (X .LT. 0.0 .AND. X+N-2 .EQ. 0.D0)THEN 13311 DGAMM2 = 0.D0 13312 RETURN 13313 ENDIF 13314 IF(X .LT. (-0.5D0) .AND. ABS((X-AINT(X-0.5D0))/X) .LT. DXREL)THEN 13315 CONTINUE 13316 ENDIF 13317C 13318 DO 20 I=1,N 13319 DGAMM2 = DGAMM2/(X+I-1 ) 13320 20 CONTINUE 13321 RETURN 13322C 13323C GAMMA(X) FOR X .GE. 2.0 AND X .LE. 10.0 13324C 13325 30 DO 40 I=1,N 13326 DGAMM2 = (Y+I) * DGAMM2 13327 40 CONTINUE 13328 RETURN 13329C 13330C GAMMA(X) FOR ABS(X) .GT. 10.0. RECALL Y = ABS(X). 13331C 13332 50 IF (X .GT. XMAX) THEN 13333 DGAMM2 = 0.D0 13334 RETURN 13335 ENDIF 13336C 13337 DGAMM2 = 0.D0 13338 IF (X .LT. XMIN) THEN 13339 CONTINUE 13340 ENDIF 13341 IF (X.LT.XMIN) RETURN 13342C 13343 DGAMM2 = EXP ((Y-0.5D0)*LOG(Y) - Y + SQ2PIL + D9LGMC(Y) ) 13344 IF (X.GT.0.D0) RETURN 13345C 13346 IF (ABS((X-AINT(X-0.5D0))/X) .LT. DXREL) THEN 13347 CONTINUE 13348 ENDIF 13349C 13350 SINPIY = SIN (PI*Y) 13351 IF (SINPIY .EQ. 0.D0) THEN 13352 DGAMM2 = 0.D0 13353 RETURN 13354 ENDIF 13355C 13356 DGAMM2 = -PI/(Y*SINPIY*DGAMM2) 13357C 13358 RETURN 13359 END 13360 SUBROUTINE DGAMMF(DX,DGF) 13361C 13362C THIS PROGRAM CALCULATES THE GAMMA FUNCTION 13363C THE INPUT IS DOUBLE PRECISION DX 13364C THE OUTPUT IS DOUBLE PRECISION DGF 13365C ALL INTERNAL OPERATIONS ARE DONE IN DOUBLE PRECISION 13366C THE ALGORITHM IS TO USE THE RECURSION FORMULA G(X)=G(X+1)/X 13367C UNTIL X IS LARGE ENOUGH TO USE AN ASYMPTOTIC FORMULA FOR G(X)--THE CUT-OFF 13368C POINT USED WAS X = 10 13369C THE ASYMPTOTIC FORMULA USED IS IN AMS 55, PAGE 257, 6.1.41 (THE FIRST 9 13370C TERMS OF THE SERIES WERE USED--I.E., OUT TO X**-17) 13371C ALTHOUGH THE DATA STATEMENT DEFINES 10 COEFFICIENTS, THE PROGRAM MAKES USE 13372C OF ONLY 9 COEFFICIENTS (THE ERROR BEING BOUNDED BY THE TENTH COEFFICIENT 13373C DIVIDED BY X**19 13374C SUBROUTINES NEEDED--NONE 13375C PRINTING--NONE UNLESS AN ERROR CONDITION EXISTS 13376C WRITTEN BY--JAMES J. FILLIBEN 13377C STATISTICAL ENGINEERING DIVISION 13378C INFORMATION TECHNOLOGY LABORATORY 13379C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13380C GAITHERSBURG, MD 20899-8980 13381C PHONE--301-921-3651 13382C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13383C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 13384C LANGUAGE--ANSI FORTRAN (1977) 13385C VERSION NUMBER--82/7 13386C ORIGINAL VERSION--JUNE 1972. 13387C UPDATED --FEBRUARY 1981. 13388C UPDATED --FEBRUARY 1982. 13389C UPDATED --MAY 1982. 13390C 13391C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 13392C 13393C--------------------------------------------------------------------- 13394C 13395 DOUBLE PRECISION DX 13396 DOUBLE PRECISION DGF 13397 DOUBLE PRECISION Y,Y2,Y3,Y4,Y5,DEN,A,B,C,D 13398C 13399 DIMENSION D(10) 13400C 13401C--------------------------------------------------------------------- 13402C 13403 INCLUDE 'DPCOP2.INC' 13404C 13405C-----DATA STATEMENTS------------------------------------------------- 13406C 13407 DATA C/ .918938533204672741D0/ 13408 DATA D(1),D(2),D(3),D(4),D(5) 13409 1 /+.833333333333333333D-1,-.277777777777777778D-2, 13410 1+.793650793650793651D-3,-.595238095238095238D-3,+.8417508417508417 13411 151D-3/ 13412 DATA D(6),D(7),D(8),D(9),D(10) 13413 1 /-.191752691752691753D-2,+.641025641025641025D-2,-.2955065359 13414 147712418D-1,+.179644372368830573D0,-.139243221690590111D1/ 13415C 13416C-----START POINT----------------------------------------------------- 13417C 13418C CHECK THE INPUT ARGUMENTS FOR ERRORS 13419C 13420 IF(DX.LE.0.0D0)GOTO50 13421 GOTO90 13422 50 WRITE(ICOUT,5) 13423 CALL DPWRST('XXX','BUG ') 13424 WRITE(ICOUT,45)DX 13425 CALL DPWRST('XXX','BUG ') 13426 GOTO9000 13427 90 CONTINUE 13428 5 FORMAT('***** FATAL ERROR--THE FIRST INPUT ARGUMENT ', 13429 1'TO THE DGAMMF SUBROUTINE IS NON-POSITIVE *****') 13430 45 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',D22.15,' *****') 13431C 13432 Y=DX 13433 DEN=1.0D0 13434 100 IF(Y.GE.10.0D0)GOTO200 13435 DEN=DEN*Y 13436 Y=Y+1 13437 GOTO100 13438 200 Y2=Y*Y 13439 Y3=Y*Y2 13440 Y4=Y2*Y2 13441 Y5=Y2*Y3 13442 A=(Y-0.5D0)*DLOG(Y)-Y+C 13443 B=D(1)/Y+D(2)/Y3+D(3)/Y5+D(4)/(Y2*Y5)+D(5)/(Y4*Y5)+ 13444 1D(6)/(Y*Y5*Y5)+D(7)/(Y3*Y5*Y5)+D(8)/(Y5*Y5*Y5)+D(9)/(Y2*Y5*Y5*Y5) 13445 DGF=DEXP(A+B)/DEN 13446C 13447 9000 CONTINUE 13448 RETURN 13449 END 13450 DOUBLE PRECISION FUNCTION DGAMR (X) 13451C***BEGIN PROLOGUE DGAMR 13452C***PURPOSE Compute the reciprocal of the Gamma function. 13453C***LIBRARY SLATEC (FNLIB) 13454C***CATEGORY C7A 13455C***TYPE DOUBLE PRECISION (GAMR-S, DGAMR-D, CGAMR-C) 13456C***KEYWORDS FNLIB, RECIPROCAL GAMMA FUNCTION, SPECIAL FUNCTIONS 13457C***AUTHOR Fullerton, W., (LANL) 13458C***DESCRIPTION 13459C 13460C DGAMR(X) calculates the double precision reciprocal of the 13461C complete Gamma function for double precision argument X. 13462C 13463C***REFERENCES (NONE) 13464C***ROUTINES CALLED DGAMMA, DLGAMS, XERCLR, XGETF, XSETF 13465C***REVISION HISTORY (YYMMDD) 13466C 770701 DATE WRITTEN 13467C 890531 Changed all specific intrinsics to generic. (WRB) 13468C 890531 REVISION DATE from Version 3.2 13469C 891214 Prologue converted to Version 4.0 format. (BAB) 13470C 900727 Added EXTERNAL statement. (WRB) 13471C***END PROLOGUE DGAMR 13472 DOUBLE PRECISION X, ALNGX, SGNGX, DGAMMA 13473 EXTERNAL DGAMMA 13474C***FIRST EXECUTABLE STATEMENT DGAMR 13475 DGAMR = 0.0D0 13476 IF (X.LE.0.0D0 .AND. AINT(X).EQ.X) RETURN 13477C 13478 IF (ABS(X).GT.10.0D0) GO TO 10 13479 DGAMR = 1.0D0/DGAMMA(X) 13480 RETURN 13481C 13482 10 CALL DLGAMS (X, ALNGX, SGNGX) 13483 DGAMR = SGNGX * EXP(-ALNGX) 13484 RETURN 13485C 13486 END 13487 SUBROUTINE DGACDF(X,GAMMA,CDF) 13488C 13489C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION 13490C FUNCTION VALUE FOR THE DOUBLE GAMMA 13491C DISTRIBUTION WITH SINGLE PRECISION 13492C TAIL LENGTH PARAMETER = GAMMA. 13493C THE DOUBLE GAMMA DISTRIBUTION USED 13494C HEREIN IS DEFINED FOR ALL REAL X, 13495C AND HAS THE PROBABILITY DENSITY FUNCTION 13496C F(X) = (1/2)*ABS(X)**(GAMMA-1)*EXP(-ABS(X))/GAMMA(X) 13497C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT 13498C WHICH THE PROBABILITY DENSITY 13499C FUNCTION IS TO BE EVALUATED. 13500C --GAMMA = THE SHAPE PARAMETER 13501C GAMMA SHOULD BE POSITIVE. 13502C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION PROBABILITY 13503C DENSITY FUNCTION VALUE. 13504C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY 13505C FUNCTION VALUE CDF FOR THE DOUBLE GAMMA DISTRIBUTION 13506C WITH TAIL LENGHT PARAMETER = GAMMA. 13507C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 13508C RESTRICTIONS--GAMMA SHOULD BE POSITIVE. 13509C OTHER DATAPAC SUBROUTINES NEEDED--GAMCDF. 13510C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 13511C LANGUAGE--ANSI FORTRAN (1977) 13512C REFERENCE --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE 13513C DISTRIBUTIONS--1, 2ND. ED., 1994, PAGE 387 13514C WRITTEN BY--JAMES J. FILLIBEN 13515C STATISTICAL ENGINEERING DIVISION 13516C INFORMATION TECHNOLOGY LABORATORY 13517C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13518C GAITHERSBURG, MD 20899-8980 13519C PHONE--301-975-2899 13520C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13521C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 13522C LANGUAGE--ANSI FORTRAN (1966) 13523C VERSION NUMBER--96/1 13524C ORIGINAL VERSION--JANUARY 1996. 13525C 13526C--------------------------------------------------------------------- 13527C 13528 INCLUDE 'DPCOP2.INC' 13529C 13530C-----START POINT----------------------------------------------------- 13531C 13532C CHECK THE INPUT ARGUMENTS FOR ERRORS 13533C 13534 IF(GAMMA.LE.0)THEN 13535 WRITE(ICOUT,15) 13536 CALL DPWRST('XXX','BUG ') 13537 WRITE(ICOUT,46)GAMMA 13538 CALL DPWRST('XXX','BUG ') 13539 CDF=0.0 13540 GOTO9999 13541 ENDIF 13542 15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 13543 1'DGACDF SUBROUTINE IS NON-POSITIVE *****') 13544 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 13545C 13546 IF(X.EQ.0.0)THEN 13547 CDF=0.5 13548 ELSEIF(X.GT.0.0)THEN 13549 CALL GAMCDF(X,GAMMA,CDF2) 13550 CDF=0.5+CDF2/2.0 13551 ELSE 13552 ARG1=-X 13553 CALL GAMCDF(ARG1,GAMMA,CDF2) 13554 CDF=0.5-CDF2/2.0 13555 ENDIF 13556C 13557 9999 CONTINUE 13558 RETURN 13559 END 13560 SUBROUTINE DGAPDF(X,GAMMA,PDF) 13561C 13562C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY 13563C FUNCTION VALUE FOR THE DOUBLE GAMMA 13564C DISTRIBUTION WITH SINGLE PRECISION 13565C TAIL LENGTH PARAMETER = GAMMA. 13566C THE DOUBLE GAMMA DISTRIBUTION USED 13567C HEREIN IS DEFINED FOR ALL REAL X, 13568C AND HAS THE PROBABILITY DENSITY FUNCTION 13569C F(X) = (1/2)*ABS(X)**(GAMMA-1)*EXP(-ABS(X))/GAMMA(X) 13570C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT 13571C WHICH THE PROBABILITY DENSITY 13572C FUNCTION IS TO BE EVALUATED. 13573C --GAMMA = THE SHAPE PARAMETER 13574C GAMMA SHOULD BE POSITIVE. 13575C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY 13576C DENSITY FUNCTION VALUE. 13577C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY 13578C FUNCTION VALUE PDF FOR THE DOUBLE GAMMA DISTRIBUTION 13579C WITH TAIL LENGHT PARAMETER = GAMMA. 13580C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 13581C RESTRICTIONS--GAMMA SHOULD BE POSITIVE. 13582C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 13583C FORTRAN LIBRARY SUBROUTINES NEEDED--EXP. 13584C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 13585C LANGUAGE--ANSI FORTRAN (1977) 13586C REFERENCE --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE 13587C DISTRIBUTIONS--1, 2ND. ED., 1994, PAGE 387 13588C WRITTEN BY--JAMES J. FILLIBEN 13589C STATISTICAL ENGINEERING DIVISION 13590C INFORMATION TECHNOLOGY LABORATORY 13591C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13592C GAITHERSBURG, MD 20899-8980 13593C PHONE--301-975-2899 13594C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13595C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 13596C LANGUAGE--ANSI FORTRAN (1966) 13597C VERSION NUMBER--96/1 13598C ORIGINAL VERSION--JANUARY 1996. 13599C 13600C--------------------------------------------------------------------- 13601C 13602 INCLUDE 'DPCOP2.INC' 13603C 13604C-----START POINT----------------------------------------------------- 13605C 13606C CHECK THE INPUT ARGUMENTS FOR ERRORS 13607C 13608 IF(GAMMA.LE.0)THEN 13609 WRITE(ICOUT,15) 13610 CALL DPWRST('XXX','BUG ') 13611 WRITE(ICOUT,46)GAMMA 13612 CALL DPWRST('XXX','BUG ') 13613 PDF=0.0 13614 GOTO9999 13615 ENDIF 13616 15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 13617 1'DGAPDF SUBROUTINE IS NON-POSITIVE *****') 13618 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 13619C 13620 ARG1=ABS(X) 13621 CALL GAMPDF(ARG1,GAMMA,PDF2) 13622 PDF=PDF2/2.0 13623C 13624 9999 CONTINUE 13625 RETURN 13626 END 13627 SUBROUTINE DGAPPF(P,GAMMA,PPF) 13628C 13629C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT 13630C FUNCTION VALUE FOR THE DOUBLE GAMMA 13631C DISTRIBUTION WITH SINGLE PRECISION 13632C TAIL LENGTH PARAMETER = GAMMA. 13633C THE DOUBLE GAMMA DISTRIBUTION USED 13634C HEREIN IS DEFINED FOR ALL REAL X, 13635C AND HAS THE PROBABILITY DENSITY FUNCTION 13636C F(X) = (1/2)*ABS(X)**(GAMMA-1)*EXP(-ABS(X))/GAMMA(X) 13637C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE 13638C (BETWEEN 0.0 (INCLUSIVELY) 13639C AND 1.0 (EXCLUSIVELY)) 13640C AT WHICH THE PERCENT POINT 13641C FUNCTION IS TO BE EVALUATED. 13642C --GAMMA = THE SINGLE PRECISION VALUE 13643C OF THE TAIL LENGTH PARAMETER. 13644C GAMMA SHOULD BE POSITIVE. 13645C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT 13646C POINT FUNCTION VALUE. 13647C OUTPUT--THE SINGLE PRECISION PERCENT POINT FUNCTION . 13648C VALUE PPF FOR THE GAMMA DISTRIBUTION 13649C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. 13650C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 13651C RESTRICTIONS--GAMMA SHOULD BE POSITIVE. 13652C --P SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) 13653C AND 1.0 (EXCLUSIVELY). 13654C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 13655C FORTRAN LIBRARY SUBROUTINES NEEDED--LOG. 13656C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 13657C LANGUAGE--ANSI FORTRAN (1977) 13658C REFERENCE --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE 13659C DISTRIBUTIONS--1, 2ND. ED., 1994, PAGE 387 13660C WRITTEN BY--JAMES J. FILLIBEN 13661C STATISTICAL ENGINEERING DIVISION 13662C INFORMATION TECHNOLOGY LABORATORY 13663C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13664C GAITHERSBURG, MD 20899-8980 13665C PHONE--301-975-2855 13666C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13667C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 13668C LANGUAGE--ANSI FORTRAN (1966) 13669C VERSION NUMBER--96/1 13670C ORIGINAL VERSION--JANUARY 1996. 13671C 13672C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 13673C 13674C--------------------------------------------------------------------- 13675C 13676 INCLUDE 'DPCOP2.INC' 13677C 13678C-----START POINT----------------------------------------------------- 13679C 13680C CHECK THE INPUT ARGUMENTS FOR ERRORS 13681C 13682 IF(P.LE.0.0.OR.P.GE.1.0)THEN 13683 WRITE(ICOUT,1) 13684 CALL DPWRST('XXX','BUG ') 13685 WRITE(ICOUT,46)P 13686 CALL DPWRST('XXX','BUG ') 13687 PPF=0.0 13688 GOTO9999 13689 ENDIF 13690 IF(GAMMA.LE.0.0)THEN 13691 WRITE(ICOUT,15) 13692 CALL DPWRST('XXX','BUG ') 13693 WRITE(ICOUT,46)GAMMA 13694 CALL DPWRST('XXX','BUG ') 13695 PPF=0.0 13696 GOTO9999 13697 ENDIF 13698 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 13699 1'DGAPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 13700 15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 13701 1'DGAPPF SUBROUTINE IS NON-POSITIVE *****') 13702 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 13703C 13704 IF(P.EQ.0.5)THEN 13705 PPF=0.0 13706 ELSEIF(P.LT.0.5)THEN 13707 ARG1=2.0*(0.5-P) 13708 CALL GAMPPF(ARG1,GAMMA,PPF) 13709 PPF=-PPF 13710 ELSE 13711 ARG1=2.0*(P-0.5) 13712 CALL GAMPPF(ARG1,GAMMA,PPF) 13713 ENDIF 13714C 13715 9999 CONTINUE 13716 RETURN 13717 END 13718 SUBROUTINE DGARAN(N,GAMMA,ISEED,X) 13719C 13720C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N 13721C FROM THE DOUBLE GAMMA DISTRIBUTION 13722C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. 13723C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER 13724C OF RANDOM NUMBERS TO BE 13725C GENERATED. 13726C --GAMMA = THE SINGLE PRECISION VALUE OF THE 13727C TAIL LENGTH PARAMETER. 13728C GAMMA SHOULD BE POSITIVE. 13729C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR 13730C (OF DIMENSION AT LEAST N) 13731C INTO WHICH THE GENERATED 13732C RANDOM SAMPLE WILL BE PLACED. 13733C OUTPUT--A RANDOM SAMPLE OF SIZE N 13734C FROM THE DOUBLE GAMMA DISTRIBUTION 13735C WITH TAIL LENGTH PARAMETER VALUE = GAMMA. 13736C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 13737C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 13738C OF N FOR THIS SUBROUTINE. 13739C --GAMMA SHOULD BE POSITIVE. 13740C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. 13741C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 13742C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 13743C LANGUAGE--ANSI FORTRAN (1977) 13744C REFERENCES--XX 13745C --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE 13746C DISTRIBUTIONS--1, 2ND. ED., 1994. 13747C WRITTEN BY--JAMES J. FILLIBEN 13748C STATISTICAL ENGINEERING DIVISION 13749C INFORMATION TECHNOLOGY LABORATORY 13750C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13751C GAITHERSBURG, MD 20899-8980 13752C PHONE--301-975-2855 13753C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13754C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 13755C LANGUAGE--ANSI FORTRAN (1966) 13756C VERSION NUMBER--2001.10 13757C ORIGINAL VERSION--OCTOBER 2001. 13758C 13759C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 13760C 13761C--------------------------------------------------------------------- 13762C 13763 DIMENSION X(*) 13764C 13765C--------------------------------------------------------------------- 13766C 13767 INCLUDE 'DPCOP2.INC' 13768C 13769C-----START POINT----------------------------------------------------- 13770C 13771C CHECK THE INPUT ARGUMENTS FOR ERRORS 13772C 13773 IF(N.LT.1)THEN 13774 WRITE(ICOUT, 5) 13775 CALL DPWRST('XXX','BUG ') 13776 WRITE(ICOUT,47)N 13777 CALL DPWRST('XXX','BUG ') 13778 GOTO9000 13779 ENDIF 13780 IF(GAMMA.LE.0.0)THEN 13781 WRITE(ICOUT,15) 13782 CALL DPWRST('XXX','BUG ') 13783 WRITE(ICOUT,46)GAMMA 13784 CALL DPWRST('XXX','BUG ') 13785 GOTO9000 13786 ENDIF 13787 5 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 13788 1'DGARAN SUBROUTINE IS NON-POSITIVE *****') 13789 15 FORMAT('***** FATAL ERROR--THE 2ND INPUT ARGUMENT TO THE ', 13790 1'DGARAN SUBROUTINE IS NON-POSITIVE *****') 13791 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 13792 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') 13793C 13794C GENERATE N UNIFORM (0,1) RANDOM NUMBERS; 13795C 13796 CALL UNIRAN(N,ISEED,X) 13797C 13798C GENERATE N INVERTED WEIBULL DISTRIBUTION RANDOM NUMBERS 13799C USING THE PERCENT POINT FUNCTION TRANSFORMATION METHOD. 13800C 13801 DO100I=1,N 13802 CALL DGAPPF(X(I),GAMMA,XTEMP) 13803 X(I)=XTEMP 13804 100 CONTINUE 13805C 13806 9000 CONTINUE 13807 RETURN 13808 END 13809 SUBROUTINE DGCL1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 13810 1IBUGD2,IFOUND,IERROR) 13811C 13812C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 13813C FOR GREEK COMPLEX LOWER CASE (PART 1). 13814C WRITTEN BY--JAMES J. FILLIBEN 13815C STATISTICAL ENGINEERING DIVISION 13816C INFORMATION TECHNOLOGY LABORATORY 13817C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 13818C GAITHERSBURG, MD 20899-8980 13819C PHONE--301-921-3651 13820C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 13821C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 13822C LANGUAGE--ANSI FORTRAN (1977) 13823C VERSION NUMBER--87/4 13824C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 13825C UPDATED --MAY 1982. 13826C UPDATED --MARCH 1987. 13827C 13828C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 13829C 13830 CHARACTER*4 IOP 13831 CHARACTER*4 IBUGD2 13832 CHARACTER*4 IFOUND 13833 CHARACTER*4 IERROR 13834C 13835 CHARACTER*4 IOPERA 13836C 13837C--------------------------------------------------------------------- 13838C 13839 DIMENSION IOP(*) 13840 DIMENSION X(*) 13841 DIMENSION Y(*) 13842C 13843 DIMENSION IOPERA(300) 13844 DIMENSION IX(300) 13845 DIMENSION IY(300) 13846C 13847 DIMENSION IXMIND(30) 13848 DIMENSION IXMAXD(30) 13849 DIMENSION IXDELD(30) 13850 DIMENSION ISTARD(30) 13851 DIMENSION NUMCOO(30) 13852C 13853C--------------------------------------------------------------------- 13854C 13855 INCLUDE 'DPCOP2.INC' 13856C 13857C-----DATA STATEMENTS------------------------------------------------- 13858C 13859C DEFINE CHARACTER 2127--LOWER CASE ALPH 13860C 13861 DATA IOPERA( 1),IX( 1),IY( 1)/'MOVE', -1, 5/ 13862 DATA IOPERA( 2),IX( 2),IY( 2)/'DRAW', -4, 4/ 13863 DATA IOPERA( 3),IX( 3),IY( 3)/'DRAW', -6, 2/ 13864 DATA IOPERA( 4),IX( 4),IY( 4)/'DRAW', -7, 0/ 13865 DATA IOPERA( 5),IX( 5),IY( 5)/'DRAW', -8, -3/ 13866 DATA IOPERA( 6),IX( 6),IY( 6)/'DRAW', -8, -6/ 13867 DATA IOPERA( 7),IX( 7),IY( 7)/'DRAW', -7, -8/ 13868 DATA IOPERA( 8),IX( 8),IY( 8)/'DRAW', -4, -9/ 13869 DATA IOPERA( 9),IX( 9),IY( 9)/'DRAW', -2, -9/ 13870 DATA IOPERA( 10),IX( 10),IY( 10)/'DRAW', 0, -8/ 13871 DATA IOPERA( 11),IX( 11),IY( 11)/'DRAW', 3, -5/ 13872 DATA IOPERA( 12),IX( 12),IY( 12)/'DRAW', 5, -2/ 13873 DATA IOPERA( 13),IX( 13),IY( 13)/'DRAW', 7, 2/ 13874 DATA IOPERA( 14),IX( 14),IY( 14)/'DRAW', 8, 5/ 13875 DATA IOPERA( 15),IX( 15),IY( 15)/'MOVE', -1, 5/ 13876 DATA IOPERA( 16),IX( 16),IY( 16)/'DRAW', -3, 4/ 13877 DATA IOPERA( 17),IX( 17),IY( 17)/'DRAW', -5, 2/ 13878 DATA IOPERA( 18),IX( 18),IY( 18)/'DRAW', -6, 0/ 13879 DATA IOPERA( 19),IX( 19),IY( 19)/'DRAW', -7, -3/ 13880 DATA IOPERA( 20),IX( 20),IY( 20)/'DRAW', -7, -6/ 13881 DATA IOPERA( 21),IX( 21),IY( 21)/'DRAW', -6, -8/ 13882 DATA IOPERA( 22),IX( 22),IY( 22)/'DRAW', -4, -9/ 13883 DATA IOPERA( 23),IX( 23),IY( 23)/'MOVE', -1, 5/ 13884 DATA IOPERA( 24),IX( 24),IY( 24)/'DRAW', 1, 5/ 13885 DATA IOPERA( 25),IX( 25),IY( 25)/'DRAW', 3, 4/ 13886 DATA IOPERA( 26),IX( 26),IY( 26)/'DRAW', 4, 2/ 13887 DATA IOPERA( 27),IX( 27),IY( 27)/'DRAW', 6, -6/ 13888 DATA IOPERA( 28),IX( 28),IY( 28)/'DRAW', 7, -8/ 13889 DATA IOPERA( 29),IX( 29),IY( 29)/'DRAW', 8, -9/ 13890 DATA IOPERA( 30),IX( 30),IY( 30)/'MOVE', 1, 5/ 13891 DATA IOPERA( 31),IX( 31),IY( 31)/'DRAW', 2, 4/ 13892 DATA IOPERA( 32),IX( 32),IY( 32)/'DRAW', 3, 2/ 13893 DATA IOPERA( 33),IX( 33),IY( 33)/'DRAW', 5, -6/ 13894 DATA IOPERA( 34),IX( 34),IY( 34)/'DRAW', 6, -8/ 13895 DATA IOPERA( 35),IX( 35),IY( 35)/'DRAW', 8, -9/ 13896 DATA IOPERA( 36),IX( 36),IY( 36)/'DRAW', 9, -9/ 13897C 13898 DATA IXMIND( 1)/ -11/ 13899 DATA IXMAXD( 1)/ 12/ 13900 DATA IXDELD( 1)/ 23/ 13901 DATA ISTARD( 1)/ 1/ 13902 DATA NUMCOO( 1)/ 36/ 13903C 13904C DEFINE CHARACTER 2128--LOWER CASE BETA 13905C 13906 DATA IOPERA( 37),IX( 37),IY( 37)/'MOVE', 2, 12/ 13907 DATA IOPERA( 38),IX( 38),IY( 38)/'DRAW', -1, 11/ 13908 DATA IOPERA( 39),IX( 39),IY( 39)/'DRAW', -3, 9/ 13909 DATA IOPERA( 40),IX( 40),IY( 40)/'DRAW', -5, 5/ 13910 DATA IOPERA( 41),IX( 41),IY( 41)/'DRAW', -6, 2/ 13911 DATA IOPERA( 42),IX( 42),IY( 42)/'DRAW', -7, -2/ 13912 DATA IOPERA( 43),IX( 43),IY( 43)/'DRAW', -8, -8/ 13913 DATA IOPERA( 44),IX( 44),IY( 44)/'DRAW', -9, -16/ 13914 DATA IOPERA( 45),IX( 45),IY( 45)/'MOVE', 2, 12/ 13915 DATA IOPERA( 46),IX( 46),IY( 46)/'DRAW', 0, 11/ 13916 DATA IOPERA( 47),IX( 47),IY( 47)/'DRAW', -2, 9/ 13917 DATA IOPERA( 48),IX( 48),IY( 48)/'DRAW', -4, 5/ 13918 DATA IOPERA( 49),IX( 49),IY( 49)/'DRAW', -5, 2/ 13919 DATA IOPERA( 50),IX( 50),IY( 50)/'DRAW', -6, -2/ 13920 DATA IOPERA( 51),IX( 51),IY( 51)/'DRAW', -7, -8/ 13921 DATA IOPERA( 52),IX( 52),IY( 52)/'DRAW', -8, -16/ 13922 DATA IOPERA( 53),IX( 53),IY( 53)/'MOVE', 2, 12/ 13923 DATA IOPERA( 54),IX( 54),IY( 54)/'DRAW', 4, 12/ 13924 DATA IOPERA( 55),IX( 55),IY( 55)/'DRAW', 6, 11/ 13925 DATA IOPERA( 56),IX( 56),IY( 56)/'DRAW', 7, 10/ 13926 DATA IOPERA( 57),IX( 57),IY( 57)/'DRAW', 7, 7/ 13927 DATA IOPERA( 58),IX( 58),IY( 58)/'DRAW', 6, 5/ 13928 DATA IOPERA( 59),IX( 59),IY( 59)/'DRAW', 5, 4/ 13929 DATA IOPERA( 60),IX( 60),IY( 60)/'DRAW', 2, 3/ 13930 DATA IOPERA( 61),IX( 61),IY( 61)/'DRAW', -2, 3/ 13931 DATA IOPERA( 62),IX( 62),IY( 62)/'MOVE', 4, 12/ 13932 DATA IOPERA( 63),IX( 63),IY( 63)/'DRAW', 6, 10/ 13933 DATA IOPERA( 64),IX( 64),IY( 64)/'DRAW', 6, 7/ 13934 DATA IOPERA( 65),IX( 65),IY( 65)/'DRAW', 5, 5/ 13935 DATA IOPERA( 66),IX( 66),IY( 66)/'DRAW', 4, 4/ 13936 DATA IOPERA( 67),IX( 67),IY( 67)/'DRAW', 2, 3/ 13937 DATA IOPERA( 68),IX( 68),IY( 68)/'MOVE', -2, 3/ 13938 DATA IOPERA( 69),IX( 69),IY( 69)/'DRAW', 2, 2/ 13939 DATA IOPERA( 70),IX( 70),IY( 70)/'DRAW', 4, 0/ 13940 DATA IOPERA( 71),IX( 71),IY( 71)/'DRAW', 5, -2/ 13941 DATA IOPERA( 72),IX( 72),IY( 72)/'DRAW', 5, -5/ 13942 DATA IOPERA( 73),IX( 73),IY( 73)/'DRAW', 4, -7/ 13943 DATA IOPERA( 74),IX( 74),IY( 74)/'DRAW', 3, -8/ 13944 DATA IOPERA( 75),IX( 75),IY( 75)/'DRAW', 0, -9/ 13945 DATA IOPERA( 76),IX( 76),IY( 76)/'DRAW', -2, -9/ 13946 DATA IOPERA( 77),IX( 77),IY( 77)/'DRAW', -4, -8/ 13947 DATA IOPERA( 78),IX( 78),IY( 78)/'DRAW', -5, -7/ 13948 DATA IOPERA( 79),IX( 79),IY( 79)/'DRAW', -6, -4/ 13949 DATA IOPERA( 80),IX( 80),IY( 80)/'MOVE', -2, 3/ 13950 DATA IOPERA( 81),IX( 81),IY( 81)/'DRAW', 1, 2/ 13951 DATA IOPERA( 82),IX( 82),IY( 82)/'DRAW', 3, 0/ 13952 DATA IOPERA( 83),IX( 83),IY( 83)/'DRAW', 4, -2/ 13953 DATA IOPERA( 84),IX( 84),IY( 84)/'DRAW', 4, -5/ 13954 DATA IOPERA( 85),IX( 85),IY( 85)/'DRAW', 3, -7/ 13955 DATA IOPERA( 86),IX( 86),IY( 86)/'DRAW', 2, -8/ 13956 DATA IOPERA( 87),IX( 87),IY( 87)/'DRAW', 0, -9/ 13957C 13958 DATA IXMIND( 2)/ -11/ 13959 DATA IXMAXD( 2)/ 10/ 13960 DATA IXDELD( 2)/ 21/ 13961 DATA ISTARD( 2)/ 37/ 13962 DATA NUMCOO( 2)/ 51/ 13963C 13964C DEFINE CHARACTER 2129--LOWER CASE GAMM 13965C 13966 DATA IOPERA( 88),IX( 88),IY( 88)/'MOVE', -9, 2/ 13967 DATA IOPERA( 89),IX( 89),IY( 89)/'DRAW', -7, 4/ 13968 DATA IOPERA( 90),IX( 90),IY( 90)/'DRAW', -5, 5/ 13969 DATA IOPERA( 91),IX( 91),IY( 91)/'DRAW', -3, 5/ 13970 DATA IOPERA( 92),IX( 92),IY( 92)/'DRAW', -1, 4/ 13971 DATA IOPERA( 93),IX( 93),IY( 93)/'DRAW', 0, 3/ 13972 DATA IOPERA( 94),IX( 94),IY( 94)/'DRAW', 1, 0/ 13973 DATA IOPERA( 95),IX( 95),IY( 95)/'DRAW', 1, -4/ 13974 DATA IOPERA( 96),IX( 96),IY( 96)/'DRAW', 0, -8/ 13975 DATA IOPERA( 97),IX( 97),IY( 97)/'DRAW', -3, -16/ 13976 DATA IOPERA( 98),IX( 98),IY( 98)/'MOVE', -8, 3/ 13977 DATA IOPERA( 99),IX( 99),IY( 99)/'DRAW', -6, 4/ 13978 DATA IOPERA( 100),IX( 100),IY( 100)/'DRAW', -2, 4/ 13979 DATA IOPERA( 101),IX( 101),IY( 101)/'DRAW', 0, 3/ 13980 DATA IOPERA( 102),IX( 102),IY( 102)/'MOVE', 8, 5/ 13981 DATA IOPERA( 103),IX( 103),IY( 103)/'DRAW', 7, 2/ 13982 DATA IOPERA( 104),IX( 104),IY( 104)/'DRAW', 6, 0/ 13983 DATA IOPERA( 105),IX( 105),IY( 105)/'DRAW', 1, -7/ 13984 DATA IOPERA( 106),IX( 106),IY( 106)/'DRAW', -2, -12/ 13985 DATA IOPERA( 107),IX( 107),IY( 107)/'DRAW', -4, -16/ 13986 DATA IOPERA( 108),IX( 108),IY( 108)/'MOVE', 7, 5/ 13987 DATA IOPERA( 109),IX( 109),IY( 109)/'DRAW', 6, 2/ 13988 DATA IOPERA( 110),IX( 110),IY( 110)/'DRAW', 5, 0/ 13989 DATA IOPERA( 111),IX( 111),IY( 111)/'DRAW', 1, -7/ 13990C 13991 DATA IXMIND( 3)/ -10/ 13992 DATA IXMAXD( 3)/ 10/ 13993 DATA IXDELD( 3)/ 20/ 13994 DATA ISTARD( 3)/ 88/ 13995 DATA NUMCOO( 3)/ 24/ 13996C 13997C DEFINE CHARACTER 2130--LOWER CASE DELT 13998C 13999 DATA IOPERA( 112),IX( 112),IY( 112)/'MOVE', 4, 4/ 14000 DATA IOPERA( 113),IX( 113),IY( 113)/'DRAW', 2, 5/ 14001 DATA IOPERA( 114),IX( 114),IY( 114)/'DRAW', 0, 5/ 14002 DATA IOPERA( 115),IX( 115),IY( 115)/'DRAW', -3, 4/ 14003 DATA IOPERA( 116),IX( 116),IY( 116)/'DRAW', -5, 1/ 14004 DATA IOPERA( 117),IX( 117),IY( 117)/'DRAW', -6, -2/ 14005 DATA IOPERA( 118),IX( 118),IY( 118)/'DRAW', -6, -5/ 14006 DATA IOPERA( 119),IX( 119),IY( 119)/'DRAW', -5, -7/ 14007 DATA IOPERA( 120),IX( 120),IY( 120)/'DRAW', -4, -8/ 14008 DATA IOPERA( 121),IX( 121),IY( 121)/'DRAW', -2, -9/ 14009 DATA IOPERA( 122),IX( 122),IY( 122)/'DRAW', 0, -9/ 14010 DATA IOPERA( 123),IX( 123),IY( 123)/'DRAW', 3, -8/ 14011 DATA IOPERA( 124),IX( 124),IY( 124)/'DRAW', 5, -5/ 14012 DATA IOPERA( 125),IX( 125),IY( 125)/'DRAW', 6, -2/ 14013 DATA IOPERA( 126),IX( 126),IY( 126)/'DRAW', 6, 1/ 14014 DATA IOPERA( 127),IX( 127),IY( 127)/'DRAW', 5, 3/ 14015 DATA IOPERA( 128),IX( 128),IY( 128)/'DRAW', 1, 8/ 14016 DATA IOPERA( 129),IX( 129),IY( 129)/'DRAW', 0, 10/ 14017 DATA IOPERA( 130),IX( 130),IY( 130)/'DRAW', 0, 12/ 14018 DATA IOPERA( 131),IX( 131),IY( 131)/'DRAW', 1, 13/ 14019 DATA IOPERA( 132),IX( 132),IY( 132)/'DRAW', 3, 13/ 14020 DATA IOPERA( 133),IX( 133),IY( 133)/'DRAW', 5, 12/ 14021 DATA IOPERA( 134),IX( 134),IY( 134)/'DRAW', 7, 10/ 14022 DATA IOPERA( 135),IX( 135),IY( 135)/'MOVE', 0, 5/ 14023 DATA IOPERA( 136),IX( 136),IY( 136)/'DRAW', -2, 4/ 14024 DATA IOPERA( 137),IX( 137),IY( 137)/'DRAW', -4, 1/ 14025 DATA IOPERA( 138),IX( 138),IY( 138)/'DRAW', -5, -2/ 14026 DATA IOPERA( 139),IX( 139),IY( 139)/'DRAW', -5, -6/ 14027 DATA IOPERA( 140),IX( 140),IY( 140)/'DRAW', -4, -8/ 14028 DATA IOPERA( 141),IX( 141),IY( 141)/'MOVE', 0, -9/ 14029 DATA IOPERA( 142),IX( 142),IY( 142)/'DRAW', 2, -8/ 14030 DATA IOPERA( 143),IX( 143),IY( 143)/'DRAW', 4, -5/ 14031 DATA IOPERA( 144),IX( 144),IY( 144)/'DRAW', 5, -2/ 14032 DATA IOPERA( 145),IX( 145),IY( 145)/'DRAW', 5, 2/ 14033 DATA IOPERA( 146),IX( 146),IY( 146)/'DRAW', 4, 4/ 14034 DATA IOPERA( 147),IX( 147),IY( 147)/'DRAW', 2, 7/ 14035 DATA IOPERA( 148),IX( 148),IY( 148)/'DRAW', 1, 9/ 14036 DATA IOPERA( 149),IX( 149),IY( 149)/'DRAW', 1, 11/ 14037 DATA IOPERA( 150),IX( 150),IY( 150)/'DRAW', 2, 12/ 14038 DATA IOPERA( 151),IX( 151),IY( 151)/'DRAW', 4, 12/ 14039 DATA IOPERA( 152),IX( 152),IY( 152)/'DRAW', 7, 10/ 14040C 14041 DATA IXMIND( 4)/ -9/ 14042 DATA IXMAXD( 4)/ 10/ 14043 DATA IXDELD( 4)/ 19/ 14044 DATA ISTARD( 4)/ 112/ 14045 DATA NUMCOO( 4)/ 41/ 14046C 14047C DEFINE CHARACTER 2131--LOWER CASE EPSI 14048C 14049 DATA IOPERA( 153),IX( 153),IY( 153)/'MOVE', 6, 2/ 14050 DATA IOPERA( 154),IX( 154),IY( 154)/'DRAW', 4, 4/ 14051 DATA IOPERA( 155),IX( 155),IY( 155)/'DRAW', 2, 5/ 14052 DATA IOPERA( 156),IX( 156),IY( 156)/'DRAW', -2, 5/ 14053 DATA IOPERA( 157),IX( 157),IY( 157)/'DRAW', -4, 4/ 14054 DATA IOPERA( 158),IX( 158),IY( 158)/'DRAW', -4, 2/ 14055 DATA IOPERA( 159),IX( 159),IY( 159)/'DRAW', -2, 0/ 14056 DATA IOPERA( 160),IX( 160),IY( 160)/'DRAW', 1, -1/ 14057 DATA IOPERA( 161),IX( 161),IY( 161)/'MOVE', -2, 5/ 14058 DATA IOPERA( 162),IX( 162),IY( 162)/'DRAW', -3, 4/ 14059 DATA IOPERA( 163),IX( 163),IY( 163)/'DRAW', -3, 2/ 14060 DATA IOPERA( 164),IX( 164),IY( 164)/'DRAW', -1, 0/ 14061 DATA IOPERA( 165),IX( 165),IY( 165)/'DRAW', 1, -1/ 14062 DATA IOPERA( 166),IX( 166),IY( 166)/'MOVE', 1, -1/ 14063 DATA IOPERA( 167),IX( 167),IY( 167)/'DRAW', -4, -2/ 14064 DATA IOPERA( 168),IX( 168),IY( 168)/'DRAW', -6, -4/ 14065 DATA IOPERA( 169),IX( 169),IY( 169)/'DRAW', -6, -6/ 14066 DATA IOPERA( 170),IX( 170),IY( 170)/'DRAW', -5, -8/ 14067 DATA IOPERA( 171),IX( 171),IY( 171)/'DRAW', -2, -9/ 14068 DATA IOPERA( 172),IX( 172),IY( 172)/'DRAW', 1, -9/ 14069 DATA IOPERA( 173),IX( 173),IY( 173)/'DRAW', 3, -8/ 14070 DATA IOPERA( 174),IX( 174),IY( 174)/'DRAW', 5, -6/ 14071 DATA IOPERA( 175),IX( 175),IY( 175)/'MOVE', 1, -1/ 14072 DATA IOPERA( 176),IX( 176),IY( 176)/'DRAW', -3, -2/ 14073 DATA IOPERA( 177),IX( 177),IY( 177)/'DRAW', -5, -4/ 14074 DATA IOPERA( 178),IX( 178),IY( 178)/'DRAW', -5, -6/ 14075 DATA IOPERA( 179),IX( 179),IY( 179)/'DRAW', -4, -8/ 14076 DATA IOPERA( 180),IX( 180),IY( 180)/'DRAW', -2, -9/ 14077C 14078 DATA IXMIND( 5)/ -9/ 14079 DATA IXMAXD( 5)/ 9/ 14080 DATA IXDELD( 5)/ 18/ 14081 DATA ISTARD( 5)/ 153/ 14082 DATA NUMCOO( 5)/ 28/ 14083C 14084C DEFINE CHARACTER 2132--LOWER CASE ZETA 14085C 14086 DATA IOPERA( 181),IX( 181),IY( 181)/'MOVE', 2, 12/ 14087 DATA IOPERA( 182),IX( 182),IY( 182)/'DRAW', 0, 11/ 14088 DATA IOPERA( 183),IX( 183),IY( 183)/'DRAW', -1, 10/ 14089 DATA IOPERA( 184),IX( 184),IY( 184)/'DRAW', -1, 9/ 14090 DATA IOPERA( 185),IX( 185),IY( 185)/'DRAW', 0, 8/ 14091 DATA IOPERA( 186),IX( 186),IY( 186)/'DRAW', 3, 7/ 14092 DATA IOPERA( 187),IX( 187),IY( 187)/'DRAW', 8, 7/ 14093 DATA IOPERA( 188),IX( 188),IY( 188)/'DRAW', 8, 8/ 14094 DATA IOPERA( 189),IX( 189),IY( 189)/'DRAW', 5, 7/ 14095 DATA IOPERA( 190),IX( 190),IY( 190)/'DRAW', 1, 5/ 14096 DATA IOPERA( 191),IX( 191),IY( 191)/'DRAW', -2, 3/ 14097 DATA IOPERA( 192),IX( 192),IY( 192)/'DRAW', -5, 0/ 14098 DATA IOPERA( 193),IX( 193),IY( 193)/'DRAW', -6, -3/ 14099 DATA IOPERA( 194),IX( 194),IY( 194)/'DRAW', -6, -5/ 14100 DATA IOPERA( 195),IX( 195),IY( 195)/'DRAW', -5, -7/ 14101 DATA IOPERA( 196),IX( 196),IY( 196)/'DRAW', -2, -9/ 14102 DATA IOPERA( 197),IX( 197),IY( 197)/'DRAW', 1, -11/ 14103 DATA IOPERA( 198),IX( 198),IY( 198)/'DRAW', 2, -13/ 14104 DATA IOPERA( 199),IX( 199),IY( 199)/'DRAW', 2, -15/ 14105 DATA IOPERA( 200),IX( 200),IY( 200)/'DRAW', 1, -16/ 14106 DATA IOPERA( 201),IX( 201),IY( 201)/'DRAW', -1, -16/ 14107 DATA IOPERA( 202),IX( 202),IY( 202)/'DRAW', -2, -15/ 14108 DATA IOPERA( 203),IX( 203),IY( 203)/'MOVE', 3, 6/ 14109 DATA IOPERA( 204),IX( 204),IY( 204)/'DRAW', -1, 3/ 14110 DATA IOPERA( 205),IX( 205),IY( 205)/'DRAW', -4, 0/ 14111 DATA IOPERA( 206),IX( 206),IY( 206)/'DRAW', -5, -3/ 14112 DATA IOPERA( 207),IX( 207),IY( 207)/'DRAW', -5, -5/ 14113 DATA IOPERA( 208),IX( 208),IY( 208)/'DRAW', -4, -7/ 14114 DATA IOPERA( 209),IX( 209),IY( 209)/'DRAW', -2, -9/ 14115C 14116 DATA IXMIND( 6)/ -9/ 14117 DATA IXMAXD( 6)/ 9/ 14118 DATA IXDELD( 6)/ 18/ 14119 DATA ISTARD( 6)/ 181/ 14120 DATA NUMCOO( 6)/ 29/ 14121C 14122C DEFINE CHARACTER 2133--LOWER CASE ETA 14123C 14124 DATA IOPERA( 210),IX( 210),IY( 210)/'MOVE', -10, 1/ 14125 DATA IOPERA( 211),IX( 211),IY( 211)/'DRAW', -9, 3/ 14126 DATA IOPERA( 212),IX( 212),IY( 212)/'DRAW', -7, 5/ 14127 DATA IOPERA( 213),IX( 213),IY( 213)/'DRAW', -4, 5/ 14128 DATA IOPERA( 214),IX( 214),IY( 214)/'DRAW', -3, 4/ 14129 DATA IOPERA( 215),IX( 215),IY( 215)/'DRAW', -3, 2/ 14130 DATA IOPERA( 216),IX( 216),IY( 216)/'DRAW', -4, -2/ 14131 DATA IOPERA( 217),IX( 217),IY( 217)/'DRAW', -6, -9/ 14132 DATA IOPERA( 218),IX( 218),IY( 218)/'MOVE', -5, 5/ 14133 DATA IOPERA( 219),IX( 219),IY( 219)/'DRAW', -4, 4/ 14134 DATA IOPERA( 220),IX( 220),IY( 220)/'DRAW', -4, 2/ 14135 DATA IOPERA( 221),IX( 221),IY( 221)/'DRAW', -5, -2/ 14136 DATA IOPERA( 222),IX( 222),IY( 222)/'DRAW', -7, -9/ 14137 DATA IOPERA( 223),IX( 223),IY( 223)/'MOVE', -4, -2/ 14138 DATA IOPERA( 224),IX( 224),IY( 224)/'DRAW', -2, 2/ 14139 DATA IOPERA( 225),IX( 225),IY( 225)/'DRAW', 0, 4/ 14140 DATA IOPERA( 226),IX( 226),IY( 226)/'DRAW', 2, 5/ 14141 DATA IOPERA( 227),IX( 227),IY( 227)/'DRAW', 4, 5/ 14142 DATA IOPERA( 228),IX( 228),IY( 228)/'DRAW', 6, 4/ 14143 DATA IOPERA( 229),IX( 229),IY( 229)/'DRAW', 7, 3/ 14144 DATA IOPERA( 230),IX( 230),IY( 230)/'DRAW', 7, 0/ 14145 DATA IOPERA( 231),IX( 231),IY( 231)/'DRAW', 6, -5/ 14146 DATA IOPERA( 232),IX( 232),IY( 232)/'DRAW', 3, -16/ 14147 DATA IOPERA( 233),IX( 233),IY( 233)/'MOVE', 4, 5/ 14148 DATA IOPERA( 234),IX( 234),IY( 234)/'DRAW', 6, 3/ 14149 DATA IOPERA( 235),IX( 235),IY( 235)/'DRAW', 6, 0/ 14150 DATA IOPERA( 236),IX( 236),IY( 236)/'DRAW', 5, -5/ 14151 DATA IOPERA( 237),IX( 237),IY( 237)/'DRAW', 2, -16/ 14152C 14153 DATA IXMIND( 7)/ -11/ 14154 DATA IXMAXD( 7)/ 11/ 14155 DATA IXDELD( 7)/ 22/ 14156 DATA ISTARD( 7)/ 210/ 14157 DATA NUMCOO( 7)/ 28/ 14158C 14159C DEFINE CHARACTER 2134--LOWER CASE THET 14160C 14161 DATA IOPERA( 238),IX( 238),IY( 238)/'MOVE', -11, 1/ 14162 DATA IOPERA( 239),IX( 239),IY( 239)/'DRAW', -10, 3/ 14163 DATA IOPERA( 240),IX( 240),IY( 240)/'DRAW', -8, 5/ 14164 DATA IOPERA( 241),IX( 241),IY( 241)/'DRAW', -5, 5/ 14165 DATA IOPERA( 242),IX( 242),IY( 242)/'DRAW', -4, 4/ 14166 DATA IOPERA( 243),IX( 243),IY( 243)/'DRAW', -4, 2/ 14167 DATA IOPERA( 244),IX( 244),IY( 244)/'DRAW', -5, -3/ 14168 DATA IOPERA( 245),IX( 245),IY( 245)/'DRAW', -5, -6/ 14169 DATA IOPERA( 246),IX( 246),IY( 246)/'DRAW', -4, -8/ 14170 DATA IOPERA( 247),IX( 247),IY( 247)/'DRAW', -3, -9/ 14171 DATA IOPERA( 248),IX( 248),IY( 248)/'MOVE', -6, 5/ 14172 DATA IOPERA( 249),IX( 249),IY( 249)/'DRAW', -5, 4/ 14173 DATA IOPERA( 250),IX( 250),IY( 250)/'DRAW', -5, 2/ 14174 DATA IOPERA( 251),IX( 251),IY( 251)/'DRAW', -6, -3/ 14175 DATA IOPERA( 252),IX( 252),IY( 252)/'DRAW', -6, -6/ 14176 DATA IOPERA( 253),IX( 253),IY( 253)/'DRAW', -5, -8/ 14177 DATA IOPERA( 254),IX( 254),IY( 254)/'DRAW', -3, -9/ 14178 DATA IOPERA( 255),IX( 255),IY( 255)/'DRAW', -1, -9/ 14179 DATA IOPERA( 256),IX( 256),IY( 256)/'DRAW', 1, -8/ 14180 DATA IOPERA( 257),IX( 257),IY( 257)/'DRAW', 3, -6/ 14181 DATA IOPERA( 258),IX( 258),IY( 258)/'DRAW', 5, -3/ 14182 DATA IOPERA( 259),IX( 259),IY( 259)/'DRAW', 6, 0/ 14183 DATA IOPERA( 260),IX( 260),IY( 260)/'DRAW', 7, 5/ 14184 DATA IOPERA( 261),IX( 261),IY( 261)/'DRAW', 7, 9/ 14185 DATA IOPERA( 262),IX( 262),IY( 262)/'DRAW', 6, 11/ 14186 DATA IOPERA( 263),IX( 263),IY( 263)/'DRAW', 4, 12/ 14187 DATA IOPERA( 264),IX( 264),IY( 264)/'DRAW', 2, 12/ 14188 DATA IOPERA( 265),IX( 265),IY( 265)/'DRAW', 0, 10/ 14189 DATA IOPERA( 266),IX( 266),IY( 266)/'DRAW', 0, 8/ 14190 DATA IOPERA( 267),IX( 267),IY( 267)/'DRAW', 1, 5/ 14191 DATA IOPERA( 268),IX( 268),IY( 268)/'DRAW', 3, 2/ 14192 DATA IOPERA( 269),IX( 269),IY( 269)/'DRAW', 5, 0/ 14193 DATA IOPERA( 270),IX( 270),IY( 270)/'DRAW', 8, -2/ 14194 DATA IOPERA( 271),IX( 271),IY( 271)/'MOVE', 1, -8/ 14195 DATA IOPERA( 272),IX( 272),IY( 272)/'DRAW', 3, -5/ 14196 DATA IOPERA( 273),IX( 273),IY( 273)/'DRAW', 4, -3/ 14197 DATA IOPERA( 274),IX( 274),IY( 274)/'DRAW', 5, 0/ 14198 DATA IOPERA( 275),IX( 275),IY( 275)/'DRAW', 6, 5/ 14199 DATA IOPERA( 276),IX( 276),IY( 276)/'DRAW', 6, 9/ 14200 DATA IOPERA( 277),IX( 277),IY( 277)/'DRAW', 5, 11/ 14201 DATA IOPERA( 278),IX( 278),IY( 278)/'DRAW', 4, 12/ 14202C 14203 DATA IXMIND( 8)/ -12/ 14204 DATA IXMAXD( 8)/ 11/ 14205 DATA IXDELD( 8)/ 23/ 14206 DATA ISTARD( 8)/ 238/ 14207 DATA NUMCOO( 8)/ 41/ 14208C 14209C DEFINE CHARACTER 2135--LOWER CASE IOTA 14210C 14211 DATA IOPERA( 279),IX( 279),IY( 279)/'MOVE', 0, 5/ 14212 DATA IOPERA( 280),IX( 280),IY( 280)/'DRAW', -2, -2/ 14213 DATA IOPERA( 281),IX( 281),IY( 281)/'DRAW', -3, -6/ 14214 DATA IOPERA( 282),IX( 282),IY( 282)/'DRAW', -3, -8/ 14215 DATA IOPERA( 283),IX( 283),IY( 283)/'DRAW', -2, -9/ 14216 DATA IOPERA( 284),IX( 284),IY( 284)/'DRAW', 1, -9/ 14217 DATA IOPERA( 285),IX( 285),IY( 285)/'DRAW', 3, -7/ 14218 DATA IOPERA( 286),IX( 286),IY( 286)/'DRAW', 4, -5/ 14219 DATA IOPERA( 287),IX( 287),IY( 287)/'MOVE', 1, 5/ 14220 DATA IOPERA( 288),IX( 288),IY( 288)/'DRAW', -1, -2/ 14221 DATA IOPERA( 289),IX( 289),IY( 289)/'DRAW', -2, -6/ 14222 DATA IOPERA( 290),IX( 290),IY( 290)/'DRAW', -2, -8/ 14223 DATA IOPERA( 291),IX( 291),IY( 291)/'DRAW', -1, -9/ 14224C 14225 DATA IXMIND( 9)/ -6/ 14226 DATA IXMAXD( 9)/ 6/ 14227 DATA IXDELD( 9)/ 12/ 14228 DATA ISTARD( 9)/ 279/ 14229 DATA NUMCOO( 9)/ 13/ 14230C 14231C-----START POINT----------------------------------------------------- 14232C 14233 IFOUND='YES' 14234 IERROR='NO' 14235C 14236 NUMCO=1 14237 ISTART=1 14238 ISTOP=1 14239 NC=1 14240C 14241C ****************************************** 14242C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 14243C ** HERSHEY CHARACTER SET CASE ** 14244C ****************************************** 14245C 14246C 14247 IF(IBUGD2.EQ.'OFF')GOTO90 14248 WRITE(ICOUT,999) 14249 999 FORMAT(1X) 14250 CALL DPWRST('XXX','BUG ') 14251 WRITE(ICOUT,51) 14252 51 FORMAT('***** AT THE BEGINNING OF DGCL1--') 14253 CALL DPWRST('XXX','BUG ') 14254 WRITE(ICOUT,52)ICHARN 14255 52 FORMAT('ICHARN = ',I8) 14256 CALL DPWRST('XXX','BUG ') 14257 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 14258 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 14259 CALL DPWRST('XXX','BUG ') 14260 90 CONTINUE 14261C 14262C ************************************** 14263C ** STEP 2-- ** 14264C ** EXTRACT THE COORDINATES ** 14265C ** FOR THIS PARTICULAR CHARACTER. ** 14266C ************************************** 14267C 14268 ISTART=ISTARD(ICHARN) 14269 NC=NUMCOO(ICHARN) 14270 ISTOP=ISTART+NC-1 14271 J=0 14272 DO1100I=ISTART,ISTOP 14273 J=J+1 14274 IOP(J)=IOPERA(I) 14275 X(J)=IX(I) 14276 Y(J)=IY(I) 14277 1100 CONTINUE 14278 NUMCO=J 14279 IXMINS=IXMIND(ICHARN) 14280 IXMAXS=IXMAXD(ICHARN) 14281 IXDELS=IXDELD(ICHARN) 14282C 14283 GOTO9000 14284C 14285C ***************** 14286C ** STEP 90-- ** 14287C ** EXIT ** 14288C ***************** 14289C 14290 9000 CONTINUE 14291 IF(IBUGD2.EQ.'OFF')GOTO9090 14292 WRITE(ICOUT,999) 14293 CALL DPWRST('XXX','BUG ') 14294 WRITE(ICOUT,9011) 14295 9011 FORMAT('***** AT THE END OF DGCL1--') 14296 CALL DPWRST('XXX','BUG ') 14297 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 14298 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 14299 CALL DPWRST('XXX','BUG ') 14300 WRITE(ICOUT,9013)ICHARN 14301 9013 FORMAT('ICHARN = ',I8) 14302 CALL DPWRST('XXX','BUG ') 14303 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 14304 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 14305 CALL DPWRST('XXX','BUG ') 14306 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 14307 DO9015I=1,NUMCO 14308 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 14309 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 14310 CALL DPWRST('XXX','BUG ') 14311 9015 CONTINUE 14312 9019 CONTINUE 14313 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 14314 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 14315 CALL DPWRST('XXX','BUG ') 14316 9090 CONTINUE 14317C 14318 RETURN 14319 END 14320 SUBROUTINE DGCL2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 14321 1IBUGD2,IFOUND,IERROR) 14322C 14323C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 14324C FOR GREEK COMPLEX LOWER CASE (PART 2). 14325C WRITTEN BY--JAMES J. FILLIBEN 14326C STATISTICAL ENGINEERING DIVISION 14327C INFORMATION TECHNOLOGY LABORATORY 14328C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 14329C GAITHERSBURG, MD 20899-8980 14330C PHONE--301-921-3651 14331C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 14332C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 14333C LANGUAGE--ANSI FORTRAN (1977) 14334C VERSION NUMBER--87/4 14335C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 14336C UPDATED --MAY 1982. 14337C UPDATED --MARCH 1987. 14338C 14339C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 14340C 14341 CHARACTER*4 IOP 14342 CHARACTER*4 IBUGD2 14343 CHARACTER*4 IFOUND 14344 CHARACTER*4 IERROR 14345C 14346 CHARACTER*4 IOPERA 14347C 14348C--------------------------------------------------------------------- 14349C 14350 DIMENSION IOP(*) 14351 DIMENSION X(*) 14352 DIMENSION Y(*) 14353C 14354 DIMENSION IOPERA(300) 14355 DIMENSION IX(300) 14356 DIMENSION IY(300) 14357C 14358 DIMENSION IXMIND(30) 14359 DIMENSION IXMAXD(30) 14360 DIMENSION IXDELD(30) 14361 DIMENSION ISTARD(30) 14362 DIMENSION NUMCOO(30) 14363C 14364C--------------------------------------------------------------------- 14365C 14366 INCLUDE 'DPCOP2.INC' 14367C 14368C-----DATA STATEMENTS------------------------------------------------- 14369C 14370C DEFINE CHARACTER 2136--LOWER CASE KAPP 14371C 14372 DATA IOPERA( 1),IX( 1),IY( 1)/'MOVE', -4, 5/ 14373 DATA IOPERA( 2),IX( 2),IY( 2)/'DRAW', -8, -9/ 14374 DATA IOPERA( 3),IX( 3),IY( 3)/'MOVE', -3, 5/ 14375 DATA IOPERA( 4),IX( 4),IY( 4)/'DRAW', -7, -9/ 14376 DATA IOPERA( 5),IX( 5),IY( 5)/'MOVE', 6, 5/ 14377 DATA IOPERA( 6),IX( 6),IY( 6)/'DRAW', 7, 4/ 14378 DATA IOPERA( 7),IX( 7),IY( 7)/'DRAW', 8, 4/ 14379 DATA IOPERA( 8),IX( 8),IY( 8)/'DRAW', 7, 5/ 14380 DATA IOPERA( 9),IX( 9),IY( 9)/'DRAW', 5, 5/ 14381 DATA IOPERA( 10),IX( 10),IY( 10)/'DRAW', 3, 4/ 14382 DATA IOPERA( 11),IX( 11),IY( 11)/'DRAW', -1, 0/ 14383 DATA IOPERA( 12),IX( 12),IY( 12)/'DRAW', -3, -1/ 14384 DATA IOPERA( 13),IX( 13),IY( 13)/'DRAW', -5, -1/ 14385 DATA IOPERA( 14),IX( 14),IY( 14)/'MOVE', -3, -1/ 14386 DATA IOPERA( 15),IX( 15),IY( 15)/'DRAW', -1, -2/ 14387 DATA IOPERA( 16),IX( 16),IY( 16)/'DRAW', 1, -8/ 14388 DATA IOPERA( 17),IX( 17),IY( 17)/'DRAW', 2, -9/ 14389 DATA IOPERA( 18),IX( 18),IY( 18)/'MOVE', -3, -1/ 14390 DATA IOPERA( 19),IX( 19),IY( 19)/'DRAW', -2, -2/ 14391 DATA IOPERA( 20),IX( 20),IY( 20)/'DRAW', 0, -8/ 14392 DATA IOPERA( 21),IX( 21),IY( 21)/'DRAW', 1, -9/ 14393 DATA IOPERA( 22),IX( 22),IY( 22)/'DRAW', 3, -9/ 14394 DATA IOPERA( 23),IX( 23),IY( 23)/'DRAW', 5, -8/ 14395 DATA IOPERA( 24),IX( 24),IY( 24)/'DRAW', 7, -5/ 14396C 14397 DATA IXMIND( 10)/ -10/ 14398 DATA IXMAXD( 10)/ 10/ 14399 DATA IXDELD( 10)/ 20/ 14400 DATA ISTARD( 10)/ 1/ 14401 DATA NUMCOO( 10)/ 24/ 14402C 14403C DEFINE CHARACTER 2137--LOWER CASE LAMB 14404C 14405 DATA IOPERA( 25),IX( 25),IY( 25)/'MOVE', -7, 12/ 14406 DATA IOPERA( 26),IX( 26),IY( 26)/'DRAW', -5, 12/ 14407 DATA IOPERA( 27),IX( 27),IY( 27)/'DRAW', -3, 11/ 14408 DATA IOPERA( 28),IX( 28),IY( 28)/'DRAW', -2, 10/ 14409 DATA IOPERA( 29),IX( 29),IY( 29)/'DRAW', -1, 8/ 14410 DATA IOPERA( 30),IX( 30),IY( 30)/'DRAW', 5, -6/ 14411 DATA IOPERA( 31),IX( 31),IY( 31)/'DRAW', 6, -8/ 14412 DATA IOPERA( 32),IX( 32),IY( 32)/'DRAW', 7, -9/ 14413 DATA IOPERA( 33),IX( 33),IY( 33)/'MOVE', -5, 12/ 14414 DATA IOPERA( 34),IX( 34),IY( 34)/'DRAW', -3, 10/ 14415 DATA IOPERA( 35),IX( 35),IY( 35)/'DRAW', -2, 8/ 14416 DATA IOPERA( 36),IX( 36),IY( 36)/'DRAW', 4, -6/ 14417 DATA IOPERA( 37),IX( 37),IY( 37)/'DRAW', 5, -8/ 14418 DATA IOPERA( 38),IX( 38),IY( 38)/'DRAW', 7, -9/ 14419 DATA IOPERA( 39),IX( 39),IY( 39)/'DRAW', 8, -9/ 14420 DATA IOPERA( 40),IX( 40),IY( 40)/'MOVE', 0, 5/ 14421 DATA IOPERA( 41),IX( 41),IY( 41)/'DRAW', -8, -9/ 14422 DATA IOPERA( 42),IX( 42),IY( 42)/'MOVE', 0, 5/ 14423 DATA IOPERA( 43),IX( 43),IY( 43)/'DRAW', -7, -9/ 14424C 14425 DATA IXMIND( 11)/ -10/ 14426 DATA IXMAXD( 11)/ 10/ 14427 DATA IXDELD( 11)/ 20/ 14428 DATA ISTARD( 11)/ 25/ 14429 DATA NUMCOO( 11)/ 19/ 14430C 14431C DEFINE CHARACTER 2138--LOWER CASE MU 14432C 14433 DATA IOPERA( 44),IX( 44),IY( 44)/'MOVE', -5, 5/ 14434 DATA IOPERA( 45),IX( 45),IY( 45)/'DRAW', -11, -16/ 14435 DATA IOPERA( 46),IX( 46),IY( 46)/'MOVE', -4, 5/ 14436 DATA IOPERA( 47),IX( 47),IY( 47)/'DRAW', -10, -16/ 14437 DATA IOPERA( 48),IX( 48),IY( 48)/'MOVE', -5, 2/ 14438 DATA IOPERA( 49),IX( 49),IY( 49)/'DRAW', -6, -4/ 14439 DATA IOPERA( 50),IX( 50),IY( 50)/'DRAW', -6, -7/ 14440 DATA IOPERA( 51),IX( 51),IY( 51)/'DRAW', -4, -9/ 14441 DATA IOPERA( 52),IX( 52),IY( 52)/'DRAW', -2, -9/ 14442 DATA IOPERA( 53),IX( 53),IY( 53)/'DRAW', 0, -8/ 14443 DATA IOPERA( 54),IX( 54),IY( 54)/'DRAW', 2, -6/ 14444 DATA IOPERA( 55),IX( 55),IY( 55)/'DRAW', 4, -3/ 14445 DATA IOPERA( 56),IX( 56),IY( 56)/'MOVE', 6, 5/ 14446 DATA IOPERA( 57),IX( 57),IY( 57)/'DRAW', 3, -6/ 14447 DATA IOPERA( 58),IX( 58),IY( 58)/'DRAW', 3, -8/ 14448 DATA IOPERA( 59),IX( 59),IY( 59)/'DRAW', 4, -9/ 14449 DATA IOPERA( 60),IX( 60),IY( 60)/'DRAW', 7, -9/ 14450 DATA IOPERA( 61),IX( 61),IY( 61)/'DRAW', 9, -7/ 14451 DATA IOPERA( 62),IX( 62),IY( 62)/'DRAW', 10, -5/ 14452 DATA IOPERA( 63),IX( 63),IY( 63)/'MOVE', 7, 5/ 14453 DATA IOPERA( 64),IX( 64),IY( 64)/'DRAW', 4, -6/ 14454 DATA IOPERA( 65),IX( 65),IY( 65)/'DRAW', 4, -8/ 14455 DATA IOPERA( 66),IX( 66),IY( 66)/'DRAW', 5, -9/ 14456C 14457 DATA IXMIND( 12)/ -12/ 14458 DATA IXMAXD( 12)/ 11/ 14459 DATA IXDELD( 12)/ 23/ 14460 DATA ISTARD( 12)/ 44/ 14461 DATA NUMCOO( 12)/ 23/ 14462C 14463C DEFINE CHARACTER 2139--LOWER CASE NU 14464C 14465 DATA IOPERA( 67),IX( 67),IY( 67)/'MOVE', -4, 5/ 14466 DATA IOPERA( 68),IX( 68),IY( 68)/'DRAW', -6, -9/ 14467 DATA IOPERA( 69),IX( 69),IY( 69)/'MOVE', -3, 5/ 14468 DATA IOPERA( 70),IX( 70),IY( 70)/'DRAW', -4, -1/ 14469 DATA IOPERA( 71),IX( 71),IY( 71)/'DRAW', -5, -6/ 14470 DATA IOPERA( 72),IX( 72),IY( 72)/'DRAW', -6, -9/ 14471 DATA IOPERA( 73),IX( 73),IY( 73)/'MOVE', 7, 5/ 14472 DATA IOPERA( 74),IX( 74),IY( 74)/'DRAW', 6, 1/ 14473 DATA IOPERA( 75),IX( 75),IY( 75)/'DRAW', 4, -3/ 14474 DATA IOPERA( 76),IX( 76),IY( 76)/'MOVE', 8, 5/ 14475 DATA IOPERA( 77),IX( 77),IY( 77)/'DRAW', 7, 2/ 14476 DATA IOPERA( 78),IX( 78),IY( 78)/'DRAW', 6, 0/ 14477 DATA IOPERA( 79),IX( 79),IY( 79)/'DRAW', 4, -3/ 14478 DATA IOPERA( 80),IX( 80),IY( 80)/'DRAW', 2, -5/ 14479 DATA IOPERA( 81),IX( 81),IY( 81)/'DRAW', -1, -7/ 14480 DATA IOPERA( 82),IX( 82),IY( 82)/'DRAW', -3, -8/ 14481 DATA IOPERA( 83),IX( 83),IY( 83)/'DRAW', -6, -9/ 14482 DATA IOPERA( 84),IX( 84),IY( 84)/'MOVE', -7, 5/ 14483 DATA IOPERA( 85),IX( 85),IY( 85)/'DRAW', -3, 5/ 14484C 14485 DATA IXMIND( 13)/ -10/ 14486 DATA IXMAXD( 13)/ 10/ 14487 DATA IXDELD( 13)/ 20/ 14488 DATA ISTARD( 13)/ 67/ 14489 DATA NUMCOO( 13)/ 19/ 14490C 14491C DEFINE CHARACTER 2140--LOWER CASE XI 14492C 14493 DATA IOPERA( 86),IX( 86),IY( 86)/'MOVE', 2, 12/ 14494 DATA IOPERA( 87),IX( 87),IY( 87)/'DRAW', 0, 11/ 14495 DATA IOPERA( 88),IX( 88),IY( 88)/'DRAW', -1, 10/ 14496 DATA IOPERA( 89),IX( 89),IY( 89)/'DRAW', -1, 9/ 14497 DATA IOPERA( 90),IX( 90),IY( 90)/'DRAW', 0, 8/ 14498 DATA IOPERA( 91),IX( 91),IY( 91)/'DRAW', 3, 7/ 14499 DATA IOPERA( 92),IX( 92),IY( 92)/'DRAW', 6, 7/ 14500 DATA IOPERA( 93),IX( 93),IY( 93)/'MOVE', 3, 7/ 14501 DATA IOPERA( 94),IX( 94),IY( 94)/'DRAW', -1, 6/ 14502 DATA IOPERA( 95),IX( 95),IY( 95)/'DRAW', -3, 5/ 14503 DATA IOPERA( 96),IX( 96),IY( 96)/'DRAW', -4, 3/ 14504 DATA IOPERA( 97),IX( 97),IY( 97)/'DRAW', -4, 1/ 14505 DATA IOPERA( 98),IX( 98),IY( 98)/'DRAW', -2, -1/ 14506 DATA IOPERA( 99),IX( 99),IY( 99)/'DRAW', 1, -2/ 14507 DATA IOPERA( 100),IX( 100),IY( 100)/'DRAW', 4, -2/ 14508 DATA IOPERA( 101),IX( 101),IY( 101)/'MOVE', 3, 7/ 14509 DATA IOPERA( 102),IX( 102),IY( 102)/'DRAW', 0, 6/ 14510 DATA IOPERA( 103),IX( 103),IY( 103)/'DRAW', -2, 5/ 14511 DATA IOPERA( 104),IX( 104),IY( 104)/'DRAW', -3, 3/ 14512 DATA IOPERA( 105),IX( 105),IY( 105)/'DRAW', -3, 1/ 14513 DATA IOPERA( 106),IX( 106),IY( 106)/'DRAW', -1, -1/ 14514 DATA IOPERA( 107),IX( 107),IY( 107)/'DRAW', 1, -2/ 14515 DATA IOPERA( 108),IX( 108),IY( 108)/'MOVE', 1, -2/ 14516 DATA IOPERA( 109),IX( 109),IY( 109)/'DRAW', -3, -3/ 14517 DATA IOPERA( 110),IX( 110),IY( 110)/'DRAW', -5, -4/ 14518 DATA IOPERA( 111),IX( 111),IY( 111)/'DRAW', -6, -6/ 14519 DATA IOPERA( 112),IX( 112),IY( 112)/'DRAW', -6, -8/ 14520 DATA IOPERA( 113),IX( 113),IY( 113)/'DRAW', -4, -10/ 14521 DATA IOPERA( 114),IX( 114),IY( 114)/'DRAW', 1, -12/ 14522 DATA IOPERA( 115),IX( 115),IY( 115)/'DRAW', 2, -13/ 14523 DATA IOPERA( 116),IX( 116),IY( 116)/'DRAW', 2, -15/ 14524 DATA IOPERA( 117),IX( 117),IY( 117)/'DRAW', 0, -16/ 14525 DATA IOPERA( 118),IX( 118),IY( 118)/'DRAW', -2, -16/ 14526 DATA IOPERA( 119),IX( 119),IY( 119)/'MOVE', 1, -2/ 14527 DATA IOPERA( 120),IX( 120),IY( 120)/'DRAW', -2, -3/ 14528 DATA IOPERA( 121),IX( 121),IY( 121)/'DRAW', -4, -4/ 14529 DATA IOPERA( 122),IX( 122),IY( 122)/'DRAW', -5, -6/ 14530 DATA IOPERA( 123),IX( 123),IY( 123)/'DRAW', -5, -8/ 14531 DATA IOPERA( 124),IX( 124),IY( 124)/'DRAW', -3, -10/ 14532 DATA IOPERA( 125),IX( 125),IY( 125)/'DRAW', 1, -12/ 14533C 14534 DATA IXMIND( 14)/ -9/ 14535 DATA IXMAXD( 14)/ 8/ 14536 DATA IXDELD( 14)/ 17/ 14537 DATA ISTARD( 14)/ 86/ 14538 DATA NUMCOO( 14)/ 40/ 14539C 14540C DEFINE CHARACTER 2141--LOWER CASE OMIC 14541C 14542 DATA IOPERA( 126),IX( 126),IY( 126)/'MOVE', 0, 5/ 14543 DATA IOPERA( 127),IX( 127),IY( 127)/'DRAW', -3, 4/ 14544 DATA IOPERA( 128),IX( 128),IY( 128)/'DRAW', -5, 1/ 14545 DATA IOPERA( 129),IX( 129),IY( 129)/'DRAW', -6, -2/ 14546 DATA IOPERA( 130),IX( 130),IY( 130)/'DRAW', -6, -5/ 14547 DATA IOPERA( 131),IX( 131),IY( 131)/'DRAW', -5, -7/ 14548 DATA IOPERA( 132),IX( 132),IY( 132)/'DRAW', -4, -8/ 14549 DATA IOPERA( 133),IX( 133),IY( 133)/'DRAW', -2, -9/ 14550 DATA IOPERA( 134),IX( 134),IY( 134)/'DRAW', 0, -9/ 14551 DATA IOPERA( 135),IX( 135),IY( 135)/'DRAW', 3, -8/ 14552 DATA IOPERA( 136),IX( 136),IY( 136)/'DRAW', 5, -5/ 14553 DATA IOPERA( 137),IX( 137),IY( 137)/'DRAW', 6, -2/ 14554 DATA IOPERA( 138),IX( 138),IY( 138)/'DRAW', 6, 1/ 14555 DATA IOPERA( 139),IX( 139),IY( 139)/'DRAW', 5, 3/ 14556 DATA IOPERA( 140),IX( 140),IY( 140)/'DRAW', 4, 4/ 14557 DATA IOPERA( 141),IX( 141),IY( 141)/'DRAW', 2, 5/ 14558 DATA IOPERA( 142),IX( 142),IY( 142)/'DRAW', 0, 5/ 14559 DATA IOPERA( 143),IX( 143),IY( 143)/'MOVE', 0, 5/ 14560 DATA IOPERA( 144),IX( 144),IY( 144)/'DRAW', -2, 4/ 14561 DATA IOPERA( 145),IX( 145),IY( 145)/'DRAW', -4, 1/ 14562 DATA IOPERA( 146),IX( 146),IY( 146)/'DRAW', -5, -2/ 14563 DATA IOPERA( 147),IX( 147),IY( 147)/'DRAW', -5, -6/ 14564 DATA IOPERA( 148),IX( 148),IY( 148)/'DRAW', -4, -8/ 14565 DATA IOPERA( 149),IX( 149),IY( 149)/'MOVE', 0, -9/ 14566 DATA IOPERA( 150),IX( 150),IY( 150)/'DRAW', 2, -8/ 14567 DATA IOPERA( 151),IX( 151),IY( 151)/'DRAW', 4, -5/ 14568 DATA IOPERA( 152),IX( 152),IY( 152)/'DRAW', 5, -2/ 14569 DATA IOPERA( 153),IX( 153),IY( 153)/'DRAW', 5, 2/ 14570 DATA IOPERA( 154),IX( 154),IY( 154)/'DRAW', 4, 4/ 14571C 14572 DATA IXMIND( 15)/ -9/ 14573 DATA IXMAXD( 15)/ 9/ 14574 DATA IXDELD( 15)/ 18/ 14575 DATA ISTARD( 15)/ 126/ 14576 DATA NUMCOO( 15)/ 29/ 14577C 14578C DEFINE CHARACTER 2142--LOWER CASE PI 14579C 14580 DATA IOPERA( 155),IX( 155),IY( 155)/'MOVE', -2, 4/ 14581 DATA IOPERA( 156),IX( 156),IY( 156)/'DRAW', -6, -9/ 14582 DATA IOPERA( 157),IX( 157),IY( 157)/'MOVE', -2, 4/ 14583 DATA IOPERA( 158),IX( 158),IY( 158)/'DRAW', -5, -9/ 14584 DATA IOPERA( 159),IX( 159),IY( 159)/'MOVE', 4, 4/ 14585 DATA IOPERA( 160),IX( 160),IY( 160)/'DRAW', 4, -9/ 14586 DATA IOPERA( 161),IX( 161),IY( 161)/'MOVE', 4, 4/ 14587 DATA IOPERA( 162),IX( 162),IY( 162)/'DRAW', 5, -9/ 14588 DATA IOPERA( 163),IX( 163),IY( 163)/'MOVE', -9, 2/ 14589 DATA IOPERA( 164),IX( 164),IY( 164)/'DRAW', -7, 4/ 14590 DATA IOPERA( 165),IX( 165),IY( 165)/'DRAW', -4, 5/ 14591 DATA IOPERA( 166),IX( 166),IY( 166)/'DRAW', 9, 5/ 14592 DATA IOPERA( 167),IX( 167),IY( 167)/'MOVE', -9, 2/ 14593 DATA IOPERA( 168),IX( 168),IY( 168)/'DRAW', -7, 3/ 14594 DATA IOPERA( 169),IX( 169),IY( 169)/'DRAW', -4, 4/ 14595 DATA IOPERA( 170),IX( 170),IY( 170)/'DRAW', 9, 4/ 14596C 14597 DATA IXMIND( 16)/ -11/ 14598 DATA IXMAXD( 16)/ 11/ 14599 DATA IXDELD( 16)/ 22/ 14600 DATA ISTARD( 16)/ 155/ 14601 DATA NUMCOO( 16)/ 16/ 14602C 14603C DEFINE CHARACTER 2143--LOWER CASE RHO 14604C 14605 DATA IOPERA( 171),IX( 171),IY( 171)/'MOVE', -6, -4/ 14606 DATA IOPERA( 172),IX( 172),IY( 172)/'DRAW', -5, -7/ 14607 DATA IOPERA( 173),IX( 173),IY( 173)/'DRAW', -4, -8/ 14608 DATA IOPERA( 174),IX( 174),IY( 174)/'DRAW', -2, -9/ 14609 DATA IOPERA( 175),IX( 175),IY( 175)/'DRAW', 0, -9/ 14610 DATA IOPERA( 176),IX( 176),IY( 176)/'DRAW', 3, -8/ 14611 DATA IOPERA( 177),IX( 177),IY( 177)/'DRAW', 5, -5/ 14612 DATA IOPERA( 178),IX( 178),IY( 178)/'DRAW', 6, -2/ 14613 DATA IOPERA( 179),IX( 179),IY( 179)/'DRAW', 6, 1/ 14614 DATA IOPERA( 180),IX( 180),IY( 180)/'DRAW', 5, 3/ 14615 DATA IOPERA( 181),IX( 181),IY( 181)/'DRAW', 4, 4/ 14616 DATA IOPERA( 182),IX( 182),IY( 182)/'DRAW', 2, 5/ 14617 DATA IOPERA( 183),IX( 183),IY( 183)/'DRAW', 0, 5/ 14618 DATA IOPERA( 184),IX( 184),IY( 184)/'DRAW', -3, 4/ 14619 DATA IOPERA( 185),IX( 185),IY( 185)/'DRAW', -5, 1/ 14620 DATA IOPERA( 186),IX( 186),IY( 186)/'DRAW', -6, -2/ 14621 DATA IOPERA( 187),IX( 187),IY( 187)/'DRAW', -10, -16/ 14622 DATA IOPERA( 188),IX( 188),IY( 188)/'MOVE', 0, -9/ 14623 DATA IOPERA( 189),IX( 189),IY( 189)/'DRAW', 2, -8/ 14624 DATA IOPERA( 190),IX( 190),IY( 190)/'DRAW', 4, -5/ 14625 DATA IOPERA( 191),IX( 191),IY( 191)/'DRAW', 5, -2/ 14626 DATA IOPERA( 192),IX( 192),IY( 192)/'DRAW', 5, 2/ 14627 DATA IOPERA( 193),IX( 193),IY( 193)/'DRAW', 4, 4/ 14628 DATA IOPERA( 194),IX( 194),IY( 194)/'MOVE', 0, 5/ 14629 DATA IOPERA( 195),IX( 195),IY( 195)/'DRAW', -2, 4/ 14630 DATA IOPERA( 196),IX( 196),IY( 196)/'DRAW', -4, 1/ 14631 DATA IOPERA( 197),IX( 197),IY( 197)/'DRAW', -5, -2/ 14632 DATA IOPERA( 198),IX( 198),IY( 198)/'DRAW', -9, -16/ 14633C 14634 DATA IXMIND( 17)/ -10/ 14635 DATA IXMAXD( 17)/ 9/ 14636 DATA IXDELD( 17)/ 19/ 14637 DATA ISTARD( 17)/ 171/ 14638 DATA NUMCOO( 17)/ 28/ 14639C 14640C DEFINE CHARACTER 2144--LOWER CASE SIGM 14641C 14642 DATA IOPERA( 199),IX( 199),IY( 199)/'MOVE', 9, 5/ 14643 DATA IOPERA( 200),IX( 200),IY( 200)/'DRAW', -1, 5/ 14644 DATA IOPERA( 201),IX( 201),IY( 201)/'DRAW', -4, 4/ 14645 DATA IOPERA( 202),IX( 202),IY( 202)/'DRAW', -6, 1/ 14646 DATA IOPERA( 203),IX( 203),IY( 203)/'DRAW', -7, -2/ 14647 DATA IOPERA( 204),IX( 204),IY( 204)/'DRAW', -7, -5/ 14648 DATA IOPERA( 205),IX( 205),IY( 205)/'DRAW', -6, -7/ 14649 DATA IOPERA( 206),IX( 206),IY( 206)/'DRAW', -5, -8/ 14650 DATA IOPERA( 207),IX( 207),IY( 207)/'DRAW', -3, -9/ 14651 DATA IOPERA( 208),IX( 208),IY( 208)/'DRAW', -1, -9/ 14652 DATA IOPERA( 209),IX( 209),IY( 209)/'DRAW', 2, -8/ 14653 DATA IOPERA( 210),IX( 210),IY( 210)/'DRAW', 4, -5/ 14654 DATA IOPERA( 211),IX( 211),IY( 211)/'DRAW', 5, -2/ 14655 DATA IOPERA( 212),IX( 212),IY( 212)/'DRAW', 5, 1/ 14656 DATA IOPERA( 213),IX( 213),IY( 213)/'DRAW', 4, 3/ 14657 DATA IOPERA( 214),IX( 214),IY( 214)/'DRAW', 3, 4/ 14658 DATA IOPERA( 215),IX( 215),IY( 215)/'DRAW', 1, 5/ 14659 DATA IOPERA( 216),IX( 216),IY( 216)/'MOVE', -1, 5/ 14660 DATA IOPERA( 217),IX( 217),IY( 217)/'DRAW', -3, 4/ 14661 DATA IOPERA( 218),IX( 218),IY( 218)/'DRAW', -5, 1/ 14662 DATA IOPERA( 219),IX( 219),IY( 219)/'DRAW', -6, -2/ 14663 DATA IOPERA( 220),IX( 220),IY( 220)/'DRAW', -6, -6/ 14664 DATA IOPERA( 221),IX( 221),IY( 221)/'DRAW', -5, -8/ 14665 DATA IOPERA( 222),IX( 222),IY( 222)/'MOVE', -1, -9/ 14666 DATA IOPERA( 223),IX( 223),IY( 223)/'DRAW', 1, -8/ 14667 DATA IOPERA( 224),IX( 224),IY( 224)/'DRAW', 3, -5/ 14668 DATA IOPERA( 225),IX( 225),IY( 225)/'DRAW', 4, -2/ 14669 DATA IOPERA( 226),IX( 226),IY( 226)/'DRAW', 4, 2/ 14670 DATA IOPERA( 227),IX( 227),IY( 227)/'DRAW', 3, 4/ 14671 DATA IOPERA( 228),IX( 228),IY( 228)/'MOVE', 3, 4/ 14672 DATA IOPERA( 229),IX( 229),IY( 229)/'DRAW', 9, 4/ 14673C 14674 DATA IXMIND( 18)/ -10/ 14675 DATA IXMAXD( 18)/ 11/ 14676 DATA IXDELD( 18)/ 21/ 14677 DATA ISTARD( 18)/ 199/ 14678 DATA NUMCOO( 18)/ 31/ 14679C 14680C DEFINE CHARACTER 2145--LOWER CASE TAU 14681C 14682 DATA IOPERA( 230),IX( 230),IY( 230)/'MOVE', 1, 4/ 14683 DATA IOPERA( 231),IX( 231),IY( 231)/'DRAW', -2, -9/ 14684 DATA IOPERA( 232),IX( 232),IY( 232)/'MOVE', 1, 4/ 14685 DATA IOPERA( 233),IX( 233),IY( 233)/'DRAW', -1, -9/ 14686 DATA IOPERA( 234),IX( 234),IY( 234)/'MOVE', -8, 2/ 14687 DATA IOPERA( 235),IX( 235),IY( 235)/'DRAW', -6, 4/ 14688 DATA IOPERA( 236),IX( 236),IY( 236)/'DRAW', -3, 5/ 14689 DATA IOPERA( 237),IX( 237),IY( 237)/'DRAW', 8, 5/ 14690 DATA IOPERA( 238),IX( 238),IY( 238)/'MOVE', -8, 2/ 14691 DATA IOPERA( 239),IX( 239),IY( 239)/'DRAW', -6, 3/ 14692 DATA IOPERA( 240),IX( 240),IY( 240)/'DRAW', -3, 4/ 14693 DATA IOPERA( 241),IX( 241),IY( 241)/'DRAW', 8, 4/ 14694C 14695 DATA IXMIND( 19)/ -10/ 14696 DATA IXMAXD( 19)/ 10/ 14697 DATA IXDELD( 19)/ 20/ 14698 DATA ISTARD( 19)/ 230/ 14699 DATA NUMCOO( 19)/ 12/ 14700C 14701C DEFINE CHARACTER 2146--LOWER CASE UPSI 14702C 14703 DATA IOPERA( 242),IX( 242),IY( 242)/'MOVE', -9, 1/ 14704 DATA IOPERA( 243),IX( 243),IY( 243)/'DRAW', -8, 3/ 14705 DATA IOPERA( 244),IX( 244),IY( 244)/'DRAW', -6, 5/ 14706 DATA IOPERA( 245),IX( 245),IY( 245)/'DRAW', -3, 5/ 14707 DATA IOPERA( 246),IX( 246),IY( 246)/'DRAW', -2, 4/ 14708 DATA IOPERA( 247),IX( 247),IY( 247)/'DRAW', -2, 2/ 14709 DATA IOPERA( 248),IX( 248),IY( 248)/'DRAW', -4, -4/ 14710 DATA IOPERA( 249),IX( 249),IY( 249)/'DRAW', -4, -7/ 14711 DATA IOPERA( 250),IX( 250),IY( 250)/'DRAW', -2, -9/ 14712 DATA IOPERA( 251),IX( 251),IY( 251)/'MOVE', -4, 5/ 14713 DATA IOPERA( 252),IX( 252),IY( 252)/'DRAW', -3, 4/ 14714 DATA IOPERA( 253),IX( 253),IY( 253)/'DRAW', -3, 2/ 14715 DATA IOPERA( 254),IX( 254),IY( 254)/'DRAW', -5, -4/ 14716 DATA IOPERA( 255),IX( 255),IY( 255)/'DRAW', -5, -7/ 14717 DATA IOPERA( 256),IX( 256),IY( 256)/'DRAW', -4, -8/ 14718 DATA IOPERA( 257),IX( 257),IY( 257)/'DRAW', -2, -9/ 14719 DATA IOPERA( 258),IX( 258),IY( 258)/'DRAW', -1, -9/ 14720 DATA IOPERA( 259),IX( 259),IY( 259)/'DRAW', 2, -8/ 14721 DATA IOPERA( 260),IX( 260),IY( 260)/'DRAW', 4, -6/ 14722 DATA IOPERA( 261),IX( 261),IY( 261)/'DRAW', 6, -3/ 14723 DATA IOPERA( 262),IX( 262),IY( 262)/'DRAW', 7, 0/ 14724 DATA IOPERA( 263),IX( 263),IY( 263)/'DRAW', 7, 3/ 14725 DATA IOPERA( 264),IX( 264),IY( 264)/'DRAW', 6, 5/ 14726 DATA IOPERA( 265),IX( 265),IY( 265)/'DRAW', 5, 4/ 14727 DATA IOPERA( 266),IX( 266),IY( 266)/'DRAW', 6, 3/ 14728 DATA IOPERA( 267),IX( 267),IY( 267)/'DRAW', 7, 0/ 14729 DATA IOPERA( 268),IX( 268),IY( 268)/'MOVE', 6, -3/ 14730 DATA IOPERA( 269),IX( 269),IY( 269)/'DRAW', 7, 3/ 14731C 14732 DATA IXMIND( 20)/ -10/ 14733 DATA IXMAXD( 20)/ 10/ 14734 DATA IXDELD( 20)/ 20/ 14735 DATA ISTARD( 20)/ 242/ 14736 DATA NUMCOO( 20)/ 28/ 14737C 14738C-----START POINT----------------------------------------------------- 14739C 14740 IFOUND='YES' 14741 IERROR='NO' 14742C 14743 NUMCO=1 14744 ISTART=1 14745 ISTOP=1 14746 NC=1 14747C 14748C ****************************************** 14749C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 14750C ** HERSHEY CHARACTER SET CASE ** 14751C ****************************************** 14752C 14753C 14754 IF(IBUGD2.EQ.'OFF')GOTO90 14755 WRITE(ICOUT,999) 14756 999 FORMAT(1X) 14757 CALL DPWRST('XXX','BUG ') 14758 WRITE(ICOUT,51) 14759 51 FORMAT('***** AT THE BEGINNING OF DGCL2--') 14760 CALL DPWRST('XXX','BUG ') 14761 WRITE(ICOUT,52)ICHARN 14762 52 FORMAT('ICHARN = ',I8) 14763 CALL DPWRST('XXX','BUG ') 14764 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 14765 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 14766 CALL DPWRST('XXX','BUG ') 14767 90 CONTINUE 14768C 14769C ************************************** 14770C ** STEP 2-- ** 14771C ** EXTRACT THE COORDINATES ** 14772C ** FOR THIS PARTICULAR CHARACTER. ** 14773C ************************************** 14774C 14775 ISTART=ISTARD(ICHARN) 14776 NC=NUMCOO(ICHARN) 14777 ISTOP=ISTART+NC-1 14778 J=0 14779 DO1100I=ISTART,ISTOP 14780 J=J+1 14781 IOP(J)=IOPERA(I) 14782 X(J)=IX(I) 14783 Y(J)=IY(I) 14784 1100 CONTINUE 14785 NUMCO=J 14786 IXMINS=IXMIND(ICHARN) 14787 IXMAXS=IXMAXD(ICHARN) 14788 IXDELS=IXDELD(ICHARN) 14789C 14790 GOTO9000 14791C 14792C ***************** 14793C ** STEP 90-- ** 14794C ** EXIT ** 14795C ***************** 14796C 14797 9000 CONTINUE 14798 IF(IBUGD2.EQ.'OFF')GOTO9090 14799 WRITE(ICOUT,999) 14800 CALL DPWRST('XXX','BUG ') 14801 WRITE(ICOUT,9011) 14802 9011 FORMAT('***** AT THE END OF DGCL2--') 14803 CALL DPWRST('XXX','BUG ') 14804 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 14805 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 14806 CALL DPWRST('XXX','BUG ') 14807 WRITE(ICOUT,9013)ICHARN 14808 9013 FORMAT('ICHARN = ',I8) 14809 CALL DPWRST('XXX','BUG ') 14810 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 14811 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 14812 CALL DPWRST('XXX','BUG ') 14813 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 14814 DO9015I=1,NUMCO 14815 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 14816 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 14817 CALL DPWRST('XXX','BUG ') 14818 9015 CONTINUE 14819 9019 CONTINUE 14820 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 14821 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 14822 CALL DPWRST('XXX','BUG ') 14823 9090 CONTINUE 14824C 14825 RETURN 14826 END 14827 SUBROUTINE DGCL3(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 14828 1IBUGD2,IFOUND,IERROR) 14829C 14830C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 14831C FOR GREEK COMPLEX LOWER CASE (PART 3). 14832C WRITTEN BY--JAMES J. FILLIBEN 14833C STATISTICAL ENGINEERING DIVISION 14834C INFORMATION TECHNOLOGY LABORATORY 14835C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 14836C GAITHERSBURG, MD 20899-8980 14837C PHONE--301-921-3651 14838C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 14839C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 14840C LANGUAGE--ANSI FORTRAN (1977) 14841C VERSION NUMBER--87/4 14842C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 14843C UPDATED --MAY 1982. 14844C UPDATED --MARCH 1987. 14845C 14846C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 14847C 14848 CHARACTER*4 IOP 14849 CHARACTER*4 IBUGD2 14850 CHARACTER*4 IFOUND 14851 CHARACTER*4 IERROR 14852C 14853 CHARACTER*4 IOPERA 14854C 14855C--------------------------------------------------------------------- 14856C 14857 DIMENSION IOP(*) 14858 DIMENSION X(*) 14859 DIMENSION Y(*) 14860C 14861 DIMENSION IOPERA(300) 14862 DIMENSION IX(300) 14863 DIMENSION IY(300) 14864C 14865 DIMENSION IXMIND(30) 14866 DIMENSION IXMAXD(30) 14867 DIMENSION IXDELD(30) 14868 DIMENSION ISTARD(30) 14869 DIMENSION NUMCOO(30) 14870C 14871C--------------------------------------------------------------------- 14872C 14873 INCLUDE 'DPCOP2.INC' 14874C 14875C-----DATA STATEMENTS------------------------------------------------- 14876C 14877C DEFINE CHARACTER 2147--LOWER CASE PHI 14878C 14879 DATA IOPERA( 1),IX( 1),IY( 1)/'MOVE', -3, 4/ 14880 DATA IOPERA( 2),IX( 2),IY( 2)/'DRAW', -5, 3/ 14881 DATA IOPERA( 3),IX( 3),IY( 3)/'DRAW', -7, 1/ 14882 DATA IOPERA( 4),IX( 4),IY( 4)/'DRAW', -8, -2/ 14883 DATA IOPERA( 5),IX( 5),IY( 5)/'DRAW', -8, -5/ 14884 DATA IOPERA( 6),IX( 6),IY( 6)/'DRAW', -7, -7/ 14885 DATA IOPERA( 7),IX( 7),IY( 7)/'DRAW', -6, -8/ 14886 DATA IOPERA( 8),IX( 8),IY( 8)/'DRAW', -4, -9/ 14887 DATA IOPERA( 9),IX( 9),IY( 9)/'DRAW', -1, -9/ 14888 DATA IOPERA( 10),IX( 10),IY( 10)/'DRAW', 2, -8/ 14889 DATA IOPERA( 11),IX( 11),IY( 11)/'DRAW', 5, -6/ 14890 DATA IOPERA( 12),IX( 12),IY( 12)/'DRAW', 7, -3/ 14891 DATA IOPERA( 13),IX( 13),IY( 13)/'DRAW', 8, 0/ 14892 DATA IOPERA( 14),IX( 14),IY( 14)/'DRAW', 8, 3/ 14893 DATA IOPERA( 15),IX( 15),IY( 15)/'DRAW', 6, 5/ 14894 DATA IOPERA( 16),IX( 16),IY( 16)/'DRAW', 4, 5/ 14895 DATA IOPERA( 17),IX( 17),IY( 17)/'DRAW', 2, 3/ 14896 DATA IOPERA( 18),IX( 18),IY( 18)/'DRAW', 0, -1/ 14897 DATA IOPERA( 19),IX( 19),IY( 19)/'DRAW', -2, -6/ 14898 DATA IOPERA( 20),IX( 20),IY( 20)/'DRAW', -5, -16/ 14899 DATA IOPERA( 21),IX( 21),IY( 21)/'MOVE', -8, -5/ 14900 DATA IOPERA( 22),IX( 22),IY( 22)/'DRAW', -6, -7/ 14901 DATA IOPERA( 23),IX( 23),IY( 23)/'DRAW', -4, -8/ 14902 DATA IOPERA( 24),IX( 24),IY( 24)/'DRAW', -1, -8/ 14903 DATA IOPERA( 25),IX( 25),IY( 25)/'DRAW', 2, -7/ 14904 DATA IOPERA( 26),IX( 26),IY( 26)/'DRAW', 5, -5/ 14905 DATA IOPERA( 27),IX( 27),IY( 27)/'DRAW', 7, -3/ 14906 DATA IOPERA( 28),IX( 28),IY( 28)/'MOVE', 8, 3/ 14907 DATA IOPERA( 29),IX( 29),IY( 29)/'DRAW', 6, 4/ 14908 DATA IOPERA( 30),IX( 30),IY( 30)/'DRAW', 4, 4/ 14909 DATA IOPERA( 31),IX( 31),IY( 31)/'DRAW', 2, 2/ 14910 DATA IOPERA( 32),IX( 32),IY( 32)/'DRAW', 0, -1/ 14911 DATA IOPERA( 33),IX( 33),IY( 33)/'DRAW', -2, -7/ 14912 DATA IOPERA( 34),IX( 34),IY( 34)/'DRAW', -4, -16/ 14913C 14914 DATA IXMIND( 21)/ -11/ 14915 DATA IXMAXD( 21)/ 11/ 14916 DATA IXDELD( 21)/ 22/ 14917 DATA ISTARD( 21)/ 1/ 14918 DATA NUMCOO( 21)/ 34/ 14919C 14920C DEFINE CHARACTER 2148--LOWER CASE CHI 14921C 14922 DATA IOPERA( 35),IX( 35),IY( 35)/'MOVE', -7, 5/ 14923 DATA IOPERA( 36),IX( 36),IY( 36)/'DRAW', -5, 5/ 14924 DATA IOPERA( 37),IX( 37),IY( 37)/'DRAW', -3, 4/ 14925 DATA IOPERA( 38),IX( 38),IY( 38)/'DRAW', -2, 2/ 14926 DATA IOPERA( 39),IX( 39),IY( 39)/'DRAW', 3, -13/ 14927 DATA IOPERA( 40),IX( 40),IY( 40)/'DRAW', 4, -15/ 14928 DATA IOPERA( 41),IX( 41),IY( 41)/'DRAW', 5, -16/ 14929 DATA IOPERA( 42),IX( 42),IY( 42)/'MOVE', -5, 5/ 14930 DATA IOPERA( 43),IX( 43),IY( 43)/'DRAW', -4, 4/ 14931 DATA IOPERA( 44),IX( 44),IY( 44)/'DRAW', -3, 2/ 14932 DATA IOPERA( 45),IX( 45),IY( 45)/'DRAW', 2, -13/ 14933 DATA IOPERA( 46),IX( 46),IY( 46)/'DRAW', 3, -15/ 14934 DATA IOPERA( 47),IX( 47),IY( 47)/'DRAW', 5, -16/ 14935 DATA IOPERA( 48),IX( 48),IY( 48)/'DRAW', 7, -16/ 14936 DATA IOPERA( 49),IX( 49),IY( 49)/'MOVE', 8, 5/ 14937 DATA IOPERA( 50),IX( 50),IY( 50)/'DRAW', 7, 3/ 14938 DATA IOPERA( 51),IX( 51),IY( 51)/'DRAW', 5, 0/ 14939 DATA IOPERA( 52),IX( 52),IY( 52)/'DRAW', -5, -11/ 14940 DATA IOPERA( 53),IX( 53),IY( 53)/'DRAW', -7, -14/ 14941 DATA IOPERA( 54),IX( 54),IY( 54)/'DRAW', -8, -16/ 14942C 14943 DATA IXMIND( 22)/ -9/ 14944 DATA IXMAXD( 22)/ 9/ 14945 DATA IXDELD( 22)/ 18/ 14946 DATA ISTARD( 22)/ 35/ 14947 DATA NUMCOO( 22)/ 20/ 14948C 14949C DEFINE CHARACTER 2149--LOWER CASE PSI 14950C 14951 DATA IOPERA( 55),IX( 55),IY( 55)/'MOVE', 3, 12/ 14952 DATA IOPERA( 56),IX( 56),IY( 56)/'DRAW', -3, -16/ 14953 DATA IOPERA( 57),IX( 57),IY( 57)/'MOVE', 4, 12/ 14954 DATA IOPERA( 58),IX( 58),IY( 58)/'DRAW', -4, -16/ 14955 DATA IOPERA( 59),IX( 59),IY( 59)/'MOVE', -11, 1/ 14956 DATA IOPERA( 60),IX( 60),IY( 60)/'DRAW', -10, 3/ 14957 DATA IOPERA( 61),IX( 61),IY( 61)/'DRAW', -8, 5/ 14958 DATA IOPERA( 62),IX( 62),IY( 62)/'DRAW', -5, 5/ 14959 DATA IOPERA( 63),IX( 63),IY( 63)/'DRAW', -4, 4/ 14960 DATA IOPERA( 64),IX( 64),IY( 64)/'DRAW', -4, 2/ 14961 DATA IOPERA( 65),IX( 65),IY( 65)/'DRAW', -5, -3/ 14962 DATA IOPERA( 66),IX( 66),IY( 66)/'DRAW', -5, -6/ 14963 DATA IOPERA( 67),IX( 67),IY( 67)/'DRAW', -3, -8/ 14964 DATA IOPERA( 68),IX( 68),IY( 68)/'DRAW', 0, -8/ 14965 DATA IOPERA( 69),IX( 69),IY( 69)/'DRAW', 2, -7/ 14966 DATA IOPERA( 70),IX( 70),IY( 70)/'DRAW', 5, -4/ 14967 DATA IOPERA( 71),IX( 71),IY( 71)/'DRAW', 7, -1/ 14968 DATA IOPERA( 72),IX( 72),IY( 72)/'MOVE', -6, 5/ 14969 DATA IOPERA( 73),IX( 73),IY( 73)/'DRAW', -5, 4/ 14970 DATA IOPERA( 74),IX( 74),IY( 74)/'DRAW', -5, 2/ 14971 DATA IOPERA( 75),IX( 75),IY( 75)/'DRAW', -6, -3/ 14972 DATA IOPERA( 76),IX( 76),IY( 76)/'DRAW', -6, -6/ 14973 DATA IOPERA( 77),IX( 77),IY( 77)/'DRAW', -5, -8/ 14974 DATA IOPERA( 78),IX( 78),IY( 78)/'DRAW', -3, -9/ 14975 DATA IOPERA( 79),IX( 79),IY( 79)/'DRAW', 0, -9/ 14976 DATA IOPERA( 80),IX( 80),IY( 80)/'DRAW', 2, -8/ 14977 DATA IOPERA( 81),IX( 81),IY( 81)/'DRAW', 4, -6/ 14978 DATA IOPERA( 82),IX( 82),IY( 82)/'DRAW', 6, -3/ 14979 DATA IOPERA( 83),IX( 83),IY( 83)/'DRAW', 7, -1/ 14980 DATA IOPERA( 84),IX( 84),IY( 84)/'DRAW', 9, 5/ 14981C 14982 DATA IXMIND( 23)/ -12/ 14983 DATA IXMAXD( 23)/ 11/ 14984 DATA IXDELD( 23)/ 23/ 14985 DATA ISTARD( 23)/ 55/ 14986 DATA NUMCOO( 23)/ 30/ 14987C 14988C DEFINE CHARACTER 2150--LOWER CASE OMEG 14989C 14990 DATA IOPERA( 85),IX( 85),IY( 85)/'MOVE', -8, 1/ 14991 DATA IOPERA( 86),IX( 86),IY( 86)/'DRAW', -6, 3/ 14992 DATA IOPERA( 87),IX( 87),IY( 87)/'DRAW', -3, 4/ 14993 DATA IOPERA( 88),IX( 88),IY( 88)/'DRAW', -4, 5/ 14994 DATA IOPERA( 89),IX( 89),IY( 89)/'DRAW', -6, 4/ 14995 DATA IOPERA( 90),IX( 90),IY( 90)/'DRAW', -8, 1/ 14996 DATA IOPERA( 91),IX( 91),IY( 91)/'DRAW', -9, -2/ 14997 DATA IOPERA( 92),IX( 92),IY( 92)/'DRAW', -9, -5/ 14998 DATA IOPERA( 93),IX( 93),IY( 93)/'DRAW', -8, -8/ 14999 DATA IOPERA( 94),IX( 94),IY( 94)/'DRAW', -7, -9/ 15000 DATA IOPERA( 95),IX( 95),IY( 95)/'DRAW', -5, -9/ 15001 DATA IOPERA( 96),IX( 96),IY( 96)/'DRAW', -3, -8/ 15002 DATA IOPERA( 97),IX( 97),IY( 97)/'DRAW', -1, -5/ 15003 DATA IOPERA( 98),IX( 98),IY( 98)/'DRAW', 0, -2/ 15004 DATA IOPERA( 99),IX( 99),IY( 99)/'MOVE', -9, -5/ 15005 DATA IOPERA( 100),IX( 100),IY( 100)/'DRAW', -8, -7/ 15006 DATA IOPERA( 101),IX( 101),IY( 101)/'DRAW', -7, -8/ 15007 DATA IOPERA( 102),IX( 102),IY( 102)/'DRAW', -5, -8/ 15008 DATA IOPERA( 103),IX( 103),IY( 103)/'DRAW', -3, -7/ 15009 DATA IOPERA( 104),IX( 104),IY( 104)/'DRAW', -1, -5/ 15010 DATA IOPERA( 105),IX( 105),IY( 105)/'MOVE', -1, -2/ 15011 DATA IOPERA( 106),IX( 106),IY( 106)/'DRAW', -1, -5/ 15012 DATA IOPERA( 107),IX( 107),IY( 107)/'DRAW', 0, -8/ 15013 DATA IOPERA( 108),IX( 108),IY( 108)/'DRAW', 1, -9/ 15014 DATA IOPERA( 109),IX( 109),IY( 109)/'DRAW', 3, -9/ 15015 DATA IOPERA( 110),IX( 110),IY( 110)/'DRAW', 5, -8/ 15016 DATA IOPERA( 111),IX( 111),IY( 111)/'DRAW', 7, -5/ 15017 DATA IOPERA( 112),IX( 112),IY( 112)/'DRAW', 8, -2/ 15018 DATA IOPERA( 113),IX( 113),IY( 113)/'DRAW', 8, 1/ 15019 DATA IOPERA( 114),IX( 114),IY( 114)/'DRAW', 7, 4/ 15020 DATA IOPERA( 115),IX( 115),IY( 115)/'DRAW', 6, 5/ 15021 DATA IOPERA( 116),IX( 116),IY( 116)/'DRAW', 5, 4/ 15022 DATA IOPERA( 117),IX( 117),IY( 117)/'DRAW', 7, 3/ 15023 DATA IOPERA( 118),IX( 118),IY( 118)/'DRAW', 8, 1/ 15024 DATA IOPERA( 119),IX( 119),IY( 119)/'MOVE', -1, -5/ 15025 DATA IOPERA( 120),IX( 120),IY( 120)/'DRAW', 0, -7/ 15026 DATA IOPERA( 121),IX( 121),IY( 121)/'DRAW', 1, -8/ 15027 DATA IOPERA( 122),IX( 122),IY( 122)/'DRAW', 3, -8/ 15028 DATA IOPERA( 123),IX( 123),IY( 123)/'DRAW', 5, -7/ 15029 DATA IOPERA( 124),IX( 124),IY( 124)/'DRAW', 7, -5/ 15030C 15031 DATA IXMIND( 24)/ -12/ 15032 DATA IXMAXD( 24)/ 11/ 15033 DATA IXDELD( 24)/ 23/ 15034 DATA ISTARD( 24)/ 85/ 15035 DATA NUMCOO( 24)/ 40/ 15036C 15037C-----START POINT----------------------------------------------------- 15038C 15039 IFOUND='YES' 15040 IERROR='NO' 15041C 15042 NUMCO=1 15043 ISTART=1 15044 ISTOP=1 15045 NC=1 15046C 15047C ****************************************** 15048C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 15049C ** HERSHEY CHARACTER SET CASE ** 15050C ****************************************** 15051C 15052C 15053 IF(IBUGD2.EQ.'OFF')GOTO90 15054 WRITE(ICOUT,999) 15055 999 FORMAT(1X) 15056 CALL DPWRST('XXX','BUG ') 15057 WRITE(ICOUT,51) 15058 51 FORMAT('***** AT THE BEGINNING OF DGCL3--') 15059 CALL DPWRST('XXX','BUG ') 15060 WRITE(ICOUT,52)ICHARN 15061 52 FORMAT('ICHARN = ',I8) 15062 CALL DPWRST('XXX','BUG ') 15063 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 15064 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 15065 CALL DPWRST('XXX','BUG ') 15066 90 CONTINUE 15067C 15068C ************************************** 15069C ** STEP 2-- ** 15070C ** EXTRACT THE COORDINATES ** 15071C ** FOR THIS PARTICULAR CHARACTER. ** 15072C ************************************** 15073C 15074 ISTART=ISTARD(ICHARN) 15075 NC=NUMCOO(ICHARN) 15076 ISTOP=ISTART+NC-1 15077 J=0 15078 DO1100I=ISTART,ISTOP 15079 J=J+1 15080 IOP(J)=IOPERA(I) 15081 X(J)=IX(I) 15082 Y(J)=IY(I) 15083 1100 CONTINUE 15084 NUMCO=J 15085 IXMINS=IXMIND(ICHARN) 15086 IXMAXS=IXMAXD(ICHARN) 15087 IXDELS=IXDELD(ICHARN) 15088C 15089 GOTO9000 15090C 15091C ***************** 15092C ** STEP 90-- ** 15093C ** EXIT ** 15094C ***************** 15095C 15096 9000 CONTINUE 15097 IF(IBUGD2.EQ.'OFF')GOTO9090 15098 WRITE(ICOUT,999) 15099 CALL DPWRST('XXX','BUG ') 15100 WRITE(ICOUT,9011) 15101 9011 FORMAT('***** AT THE END OF DGCL3--') 15102 CALL DPWRST('XXX','BUG ') 15103 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 15104 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 15105 CALL DPWRST('XXX','BUG ') 15106 WRITE(ICOUT,9013)ICHARN 15107 9013 FORMAT('ICHARN = ',I8) 15108 CALL DPWRST('XXX','BUG ') 15109 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 15110 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 15111 CALL DPWRST('XXX','BUG ') 15112 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 15113 DO9015I=1,NUMCO 15114 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 15115 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 15116 CALL DPWRST('XXX','BUG ') 15117 9015 CONTINUE 15118 9019 CONTINUE 15119 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 15120 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 15121 CALL DPWRST('XXX','BUG ') 15122 9090 CONTINUE 15123C 15124 RETURN 15125 END 15126 SUBROUTINE DGCU1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 15127 1IBUGD2,IFOUND,IERROR) 15128C 15129C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 15130C FOR GREEK COMPLEX UPPER CASE (PART 1). 15131C WRITTEN BY--JAMES J. FILLIBEN 15132C STATISTICAL ENGINEERING DIVISION 15133C INFORMATION TECHNOLOGY LABORATORY 15134C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 15135C GAITHERSBURG, MD 20899-8980 15136C PHONE--301-921-3651 15137C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 15138C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 15139C LANGUAGE--ANSI FORTRAN (1977) 15140C VERSION NUMBER--87/4 15141C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 15142C UPDATED --MAY 1982. 15143C UPDATED --MARCH 1987. 15144C 15145C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 15146C 15147 CHARACTER*4 IOP 15148 CHARACTER*4 IBUGD2 15149 CHARACTER*4 IFOUND 15150 CHARACTER*4 IERROR 15151C 15152 CHARACTER*4 IOPERA 15153C 15154C--------------------------------------------------------------------- 15155C 15156 DIMENSION IOP(*) 15157 DIMENSION X(*) 15158 DIMENSION Y(*) 15159C 15160 DIMENSION IOPERA(300) 15161 DIMENSION IX(300) 15162 DIMENSION IY(300) 15163C 15164 DIMENSION IXMIND(30) 15165 DIMENSION IXMAXD(30) 15166 DIMENSION IXDELD(30) 15167 DIMENSION ISTARD(30) 15168 DIMENSION NUMCOO(30) 15169C 15170C--------------------------------------------------------------------- 15171C 15172 INCLUDE 'DPCOP2.INC' 15173C 15174C-----DATA STATEMENTS------------------------------------------------- 15175C 15176C DEFINE CHARACTER 2027--UPPER CASE ALPH 15177C 15178 DATA IOPERA( 1),IX( 1),IY( 1)/'MOVE', 0, 12/ 15179 DATA IOPERA( 2),IX( 2),IY( 2)/'DRAW', -7, -9/ 15180 DATA IOPERA( 3),IX( 3),IY( 3)/'MOVE', 0, 12/ 15181 DATA IOPERA( 4),IX( 4),IY( 4)/'DRAW', 7, -9/ 15182 DATA IOPERA( 5),IX( 5),IY( 5)/'MOVE', 0, 9/ 15183 DATA IOPERA( 6),IX( 6),IY( 6)/'DRAW', 6, -9/ 15184 DATA IOPERA( 7),IX( 7),IY( 7)/'MOVE', -5, -3/ 15185 DATA IOPERA( 8),IX( 8),IY( 8)/'DRAW', 4, -3/ 15186 DATA IOPERA( 9),IX( 9),IY( 9)/'MOVE', -9, -9/ 15187 DATA IOPERA( 10),IX( 10),IY( 10)/'DRAW', -3, -9/ 15188 DATA IOPERA( 11),IX( 11),IY( 11)/'MOVE', 3, -9/ 15189 DATA IOPERA( 12),IX( 12),IY( 12)/'DRAW', 9, -9/ 15190C 15191 DATA IXMIND( 1)/ -10/ 15192 DATA IXMAXD( 1)/ 10/ 15193 DATA IXDELD( 1)/ 20/ 15194 DATA ISTARD( 1)/ 1/ 15195 DATA NUMCOO( 1)/ 12/ 15196C 15197C DEFINE CHARACTER 2028--UPPER CASE BETA 15198C 15199 DATA IOPERA( 13),IX( 13),IY( 13)/'MOVE', -6, 12/ 15200 DATA IOPERA( 14),IX( 14),IY( 14)/'DRAW', -6, -9/ 15201 DATA IOPERA( 15),IX( 15),IY( 15)/'MOVE', -5, 12/ 15202 DATA IOPERA( 16),IX( 16),IY( 16)/'DRAW', -5, -9/ 15203 DATA IOPERA( 17),IX( 17),IY( 17)/'MOVE', -9, 12/ 15204 DATA IOPERA( 18),IX( 18),IY( 18)/'DRAW', 3, 12/ 15205 DATA IOPERA( 19),IX( 19),IY( 19)/'DRAW', 6, 11/ 15206 DATA IOPERA( 20),IX( 20),IY( 20)/'DRAW', 7, 10/ 15207 DATA IOPERA( 21),IX( 21),IY( 21)/'DRAW', 8, 8/ 15208 DATA IOPERA( 22),IX( 22),IY( 22)/'DRAW', 8, 6/ 15209 DATA IOPERA( 23),IX( 23),IY( 23)/'DRAW', 7, 4/ 15210 DATA IOPERA( 24),IX( 24),IY( 24)/'DRAW', 6, 3/ 15211 DATA IOPERA( 25),IX( 25),IY( 25)/'DRAW', 3, 2/ 15212 DATA IOPERA( 26),IX( 26),IY( 26)/'MOVE', 3, 12/ 15213 DATA IOPERA( 27),IX( 27),IY( 27)/'DRAW', 5, 11/ 15214 DATA IOPERA( 28),IX( 28),IY( 28)/'DRAW', 6, 10/ 15215 DATA IOPERA( 29),IX( 29),IY( 29)/'DRAW', 7, 8/ 15216 DATA IOPERA( 30),IX( 30),IY( 30)/'DRAW', 7, 6/ 15217 DATA IOPERA( 31),IX( 31),IY( 31)/'DRAW', 6, 4/ 15218 DATA IOPERA( 32),IX( 32),IY( 32)/'DRAW', 5, 3/ 15219 DATA IOPERA( 33),IX( 33),IY( 33)/'DRAW', 3, 2/ 15220 DATA IOPERA( 34),IX( 34),IY( 34)/'MOVE', -5, 2/ 15221 DATA IOPERA( 35),IX( 35),IY( 35)/'DRAW', 3, 2/ 15222 DATA IOPERA( 36),IX( 36),IY( 36)/'DRAW', 6, 1/ 15223 DATA IOPERA( 37),IX( 37),IY( 37)/'DRAW', 7, 0/ 15224 DATA IOPERA( 38),IX( 38),IY( 38)/'DRAW', 8, -2/ 15225 DATA IOPERA( 39),IX( 39),IY( 39)/'DRAW', 8, -5/ 15226 DATA IOPERA( 40),IX( 40),IY( 40)/'DRAW', 7, -7/ 15227 DATA IOPERA( 41),IX( 41),IY( 41)/'DRAW', 6, -8/ 15228 DATA IOPERA( 42),IX( 42),IY( 42)/'DRAW', 3, -9/ 15229 DATA IOPERA( 43),IX( 43),IY( 43)/'DRAW', -9, -9/ 15230 DATA IOPERA( 44),IX( 44),IY( 44)/'MOVE', 3, 2/ 15231 DATA IOPERA( 45),IX( 45),IY( 45)/'DRAW', 5, 1/ 15232 DATA IOPERA( 46),IX( 46),IY( 46)/'DRAW', 6, 0/ 15233 DATA IOPERA( 47),IX( 47),IY( 47)/'DRAW', 7, -2/ 15234 DATA IOPERA( 48),IX( 48),IY( 48)/'DRAW', 7, -5/ 15235 DATA IOPERA( 49),IX( 49),IY( 49)/'DRAW', 6, -7/ 15236 DATA IOPERA( 50),IX( 50),IY( 50)/'DRAW', 5, -8/ 15237 DATA IOPERA( 51),IX( 51),IY( 51)/'DRAW', 3, -9/ 15238C 15239 DATA IXMIND( 2)/ -11/ 15240 DATA IXMAXD( 2)/ 11/ 15241 DATA IXDELD( 2)/ 22/ 15242 DATA ISTARD( 2)/ 13/ 15243 DATA NUMCOO( 2)/ 39/ 15244C 15245C DEFINE CHARACTER 2029--UPPER CASE GAMM 15246C 15247 DATA IOPERA( 52),IX( 52),IY( 52)/'MOVE', -4, 12/ 15248 DATA IOPERA( 53),IX( 53),IY( 53)/'DRAW', -4, -9/ 15249 DATA IOPERA( 54),IX( 54),IY( 54)/'MOVE', -3, 12/ 15250 DATA IOPERA( 55),IX( 55),IY( 55)/'DRAW', -3, -9/ 15251 DATA IOPERA( 56),IX( 56),IY( 56)/'MOVE', -7, 12/ 15252 DATA IOPERA( 57),IX( 57),IY( 57)/'DRAW', 8, 12/ 15253 DATA IOPERA( 58),IX( 58),IY( 58)/'DRAW', 8, 6/ 15254 DATA IOPERA( 59),IX( 59),IY( 59)/'DRAW', 7, 12/ 15255 DATA IOPERA( 60),IX( 60),IY( 60)/'MOVE', -7, -9/ 15256 DATA IOPERA( 61),IX( 61),IY( 61)/'DRAW', 0, -9/ 15257C 15258 DATA IXMIND( 3)/ -9/ 15259 DATA IXMAXD( 3)/ 9/ 15260 DATA IXDELD( 3)/ 18/ 15261 DATA ISTARD( 3)/ 52/ 15262 DATA NUMCOO( 3)/ 10/ 15263C 15264C DEFINE CHARACTER 2030--UPPER CASE DELT 15265C 15266 DATA IOPERA( 62),IX( 62),IY( 62)/'MOVE', 0, 12/ 15267 DATA IOPERA( 63),IX( 63),IY( 63)/'DRAW', -8, -9/ 15268 DATA IOPERA( 64),IX( 64),IY( 64)/'MOVE', 0, 12/ 15269 DATA IOPERA( 65),IX( 65),IY( 65)/'DRAW', 8, -9/ 15270 DATA IOPERA( 66),IX( 66),IY( 66)/'MOVE', 0, 9/ 15271 DATA IOPERA( 67),IX( 67),IY( 67)/'DRAW', 7, -9/ 15272 DATA IOPERA( 68),IX( 68),IY( 68)/'MOVE', -7, -8/ 15273 DATA IOPERA( 69),IX( 69),IY( 69)/'DRAW', 7, -8/ 15274 DATA IOPERA( 70),IX( 70),IY( 70)/'MOVE', -8, -9/ 15275 DATA IOPERA( 71),IX( 71),IY( 71)/'DRAW', 8, -9/ 15276C 15277 DATA IXMIND( 4)/ -10/ 15278 DATA IXMAXD( 4)/ 10/ 15279 DATA IXDELD( 4)/ 20/ 15280 DATA ISTARD( 4)/ 62/ 15281 DATA NUMCOO( 4)/ 10/ 15282C 15283C DEFINE CHARACTER 2031--UPPER CASE EPSI 15284C 15285 DATA IOPERA( 72),IX( 72),IY( 72)/'MOVE', -6, 12/ 15286 DATA IOPERA( 73),IX( 73),IY( 73)/'DRAW', -6, -9/ 15287 DATA IOPERA( 74),IX( 74),IY( 74)/'MOVE', -5, 12/ 15288 DATA IOPERA( 75),IX( 75),IY( 75)/'DRAW', -5, -9/ 15289 DATA IOPERA( 76),IX( 76),IY( 76)/'MOVE', 1, 6/ 15290 DATA IOPERA( 77),IX( 77),IY( 77)/'DRAW', 1, -2/ 15291 DATA IOPERA( 78),IX( 78),IY( 78)/'MOVE', -9, 12/ 15292 DATA IOPERA( 79),IX( 79),IY( 79)/'DRAW', 7, 12/ 15293 DATA IOPERA( 80),IX( 80),IY( 80)/'DRAW', 7, 6/ 15294 DATA IOPERA( 81),IX( 81),IY( 81)/'DRAW', 6, 12/ 15295 DATA IOPERA( 82),IX( 82),IY( 82)/'MOVE', -5, 2/ 15296 DATA IOPERA( 83),IX( 83),IY( 83)/'DRAW', 1, 2/ 15297 DATA IOPERA( 84),IX( 84),IY( 84)/'MOVE', -9, -9/ 15298 DATA IOPERA( 85),IX( 85),IY( 85)/'DRAW', 7, -9/ 15299 DATA IOPERA( 86),IX( 86),IY( 86)/'DRAW', 7, -3/ 15300 DATA IOPERA( 87),IX( 87),IY( 87)/'DRAW', 6, -9/ 15301C 15302 DATA IXMIND( 5)/ -11/ 15303 DATA IXMAXD( 5)/ 10/ 15304 DATA IXDELD( 5)/ 21/ 15305 DATA ISTARD( 5)/ 72/ 15306 DATA NUMCOO( 5)/ 16/ 15307C 15308C DEFINE CHARACTER 2032--UPPER CASE ZETA 15309C 15310 DATA IOPERA( 88),IX( 88),IY( 88)/'MOVE', 6, 12/ 15311 DATA IOPERA( 89),IX( 89),IY( 89)/'DRAW', -7, -9/ 15312 DATA IOPERA( 90),IX( 90),IY( 90)/'MOVE', 7, 12/ 15313 DATA IOPERA( 91),IX( 91),IY( 91)/'DRAW', -6, -9/ 15314 DATA IOPERA( 92),IX( 92),IY( 92)/'MOVE', -6, 12/ 15315 DATA IOPERA( 93),IX( 93),IY( 93)/'DRAW', -7, 6/ 15316 DATA IOPERA( 94),IX( 94),IY( 94)/'DRAW', -7, 12/ 15317 DATA IOPERA( 95),IX( 95),IY( 95)/'DRAW', 7, 12/ 15318 DATA IOPERA( 96),IX( 96),IY( 96)/'MOVE', -7, -9/ 15319 DATA IOPERA( 97),IX( 97),IY( 97)/'DRAW', 7, -9/ 15320 DATA IOPERA( 98),IX( 98),IY( 98)/'DRAW', 7, -3/ 15321 DATA IOPERA( 99),IX( 99),IY( 99)/'DRAW', 6, -9/ 15322C 15323 DATA IXMIND( 6)/ -10/ 15324 DATA IXMAXD( 6)/ 10/ 15325 DATA IXDELD( 6)/ 20/ 15326 DATA ISTARD( 6)/ 88/ 15327 DATA NUMCOO( 6)/ 12/ 15328C 15329C DEFINE CHARACTER 2033--UPPER CASE ETA 15330C 15331 DATA IOPERA( 100),IX( 100),IY( 100)/'MOVE', -7, 12/ 15332 DATA IOPERA( 101),IX( 101),IY( 101)/'DRAW', -7, -9/ 15333 DATA IOPERA( 102),IX( 102),IY( 102)/'MOVE', -6, 12/ 15334 DATA IOPERA( 103),IX( 103),IY( 103)/'DRAW', -6, -9/ 15335 DATA IOPERA( 104),IX( 104),IY( 104)/'MOVE', 6, 12/ 15336 DATA IOPERA( 105),IX( 105),IY( 105)/'DRAW', 6, -9/ 15337 DATA IOPERA( 106),IX( 106),IY( 106)/'MOVE', 7, 12/ 15338 DATA IOPERA( 107),IX( 107),IY( 107)/'DRAW', 7, -9/ 15339 DATA IOPERA( 108),IX( 108),IY( 108)/'MOVE', -10, 12/ 15340 DATA IOPERA( 109),IX( 109),IY( 109)/'DRAW', -3, 12/ 15341 DATA IOPERA( 110),IX( 110),IY( 110)/'MOVE', 3, 12/ 15342 DATA IOPERA( 111),IX( 111),IY( 111)/'DRAW', 10, 12/ 15343 DATA IOPERA( 112),IX( 112),IY( 112)/'MOVE', -6, 2/ 15344 DATA IOPERA( 113),IX( 113),IY( 113)/'DRAW', 6, 2/ 15345 DATA IOPERA( 114),IX( 114),IY( 114)/'MOVE', -10, -9/ 15346 DATA IOPERA( 115),IX( 115),IY( 115)/'DRAW', -3, -9/ 15347 DATA IOPERA( 116),IX( 116),IY( 116)/'MOVE', 3, -9/ 15348 DATA IOPERA( 117),IX( 117),IY( 117)/'DRAW', 10, -9/ 15349C 15350 DATA IXMIND( 7)/ -12/ 15351 DATA IXMAXD( 7)/ 12/ 15352 DATA IXDELD( 7)/ 24/ 15353 DATA ISTARD( 7)/ 100/ 15354 DATA NUMCOO( 7)/ 18/ 15355C 15356C DEFINE CHARACTER 2034--UPPER CASE THET 15357C 15358 DATA IOPERA( 118),IX( 118),IY( 118)/'MOVE', -1, 12/ 15359 DATA IOPERA( 119),IX( 119),IY( 119)/'DRAW', -4, 11/ 15360 DATA IOPERA( 120),IX( 120),IY( 120)/'DRAW', -6, 9/ 15361 DATA IOPERA( 121),IX( 121),IY( 121)/'DRAW', -7, 7/ 15362 DATA IOPERA( 122),IX( 122),IY( 122)/'DRAW', -8, 3/ 15363 DATA IOPERA( 123),IX( 123),IY( 123)/'DRAW', -8, 0/ 15364 DATA IOPERA( 124),IX( 124),IY( 124)/'DRAW', -7, -4/ 15365 DATA IOPERA( 125),IX( 125),IY( 125)/'DRAW', -6, -6/ 15366 DATA IOPERA( 126),IX( 126),IY( 126)/'DRAW', -4, -8/ 15367 DATA IOPERA( 127),IX( 127),IY( 127)/'DRAW', -1, -9/ 15368 DATA IOPERA( 128),IX( 128),IY( 128)/'DRAW', 1, -9/ 15369 DATA IOPERA( 129),IX( 129),IY( 129)/'DRAW', 4, -8/ 15370 DATA IOPERA( 130),IX( 130),IY( 130)/'DRAW', 6, -6/ 15371 DATA IOPERA( 131),IX( 131),IY( 131)/'DRAW', 7, -4/ 15372 DATA IOPERA( 132),IX( 132),IY( 132)/'DRAW', 8, 0/ 15373 DATA IOPERA( 133),IX( 133),IY( 133)/'DRAW', 8, 3/ 15374 DATA IOPERA( 134),IX( 134),IY( 134)/'DRAW', 7, 7/ 15375 DATA IOPERA( 135),IX( 135),IY( 135)/'DRAW', 6, 9/ 15376 DATA IOPERA( 136),IX( 136),IY( 136)/'DRAW', 4, 11/ 15377 DATA IOPERA( 137),IX( 137),IY( 137)/'DRAW', 1, 12/ 15378 DATA IOPERA( 138),IX( 138),IY( 138)/'DRAW', -1, 12/ 15379 DATA IOPERA( 139),IX( 139),IY( 139)/'MOVE', -1, 12/ 15380 DATA IOPERA( 140),IX( 140),IY( 140)/'DRAW', -3, 11/ 15381 DATA IOPERA( 141),IX( 141),IY( 141)/'DRAW', -5, 9/ 15382 DATA IOPERA( 142),IX( 142),IY( 142)/'DRAW', -6, 7/ 15383 DATA IOPERA( 143),IX( 143),IY( 143)/'DRAW', -7, 3/ 15384 DATA IOPERA( 144),IX( 144),IY( 144)/'DRAW', -7, 0/ 15385 DATA IOPERA( 145),IX( 145),IY( 145)/'DRAW', -6, -4/ 15386 DATA IOPERA( 146),IX( 146),IY( 146)/'DRAW', -5, -6/ 15387 DATA IOPERA( 147),IX( 147),IY( 147)/'DRAW', -3, -8/ 15388 DATA IOPERA( 148),IX( 148),IY( 148)/'DRAW', -1, -9/ 15389 DATA IOPERA( 149),IX( 149),IY( 149)/'MOVE', 1, -9/ 15390 DATA IOPERA( 150),IX( 150),IY( 150)/'DRAW', 3, -8/ 15391 DATA IOPERA( 151),IX( 151),IY( 151)/'DRAW', 5, -6/ 15392 DATA IOPERA( 152),IX( 152),IY( 152)/'DRAW', 6, -4/ 15393 DATA IOPERA( 153),IX( 153),IY( 153)/'DRAW', 7, 0/ 15394 DATA IOPERA( 154),IX( 154),IY( 154)/'DRAW', 7, 3/ 15395 DATA IOPERA( 155),IX( 155),IY( 155)/'DRAW', 6, 7/ 15396 DATA IOPERA( 156),IX( 156),IY( 156)/'DRAW', 5, 9/ 15397 DATA IOPERA( 157),IX( 157),IY( 157)/'DRAW', 3, 11/ 15398 DATA IOPERA( 158),IX( 158),IY( 158)/'DRAW', 1, 12/ 15399 DATA IOPERA( 159),IX( 159),IY( 159)/'MOVE', -3, 5/ 15400 DATA IOPERA( 160),IX( 160),IY( 160)/'DRAW', -3, -2/ 15401 DATA IOPERA( 161),IX( 161),IY( 161)/'MOVE', 3, 5/ 15402 DATA IOPERA( 162),IX( 162),IY( 162)/'DRAW', 3, -2/ 15403 DATA IOPERA( 163),IX( 163),IY( 163)/'MOVE', -3, 2/ 15404 DATA IOPERA( 164),IX( 164),IY( 164)/'DRAW', 3, 2/ 15405 DATA IOPERA( 165),IX( 165),IY( 165)/'MOVE', -3, 1/ 15406 DATA IOPERA( 166),IX( 166),IY( 166)/'DRAW', 3, 1/ 15407C 15408 DATA IXMIND( 8)/ -11/ 15409 DATA IXMAXD( 8)/ 11/ 15410 DATA IXDELD( 8)/ 22/ 15411 DATA ISTARD( 8)/ 118/ 15412 DATA NUMCOO( 8)/ 49/ 15413C 15414C DEFINE CHARACTER 2035--UPPER CASE IOTA 15415C 15416 DATA IOPERA( 167),IX( 167),IY( 167)/'MOVE', 0, 12/ 15417 DATA IOPERA( 168),IX( 168),IY( 168)/'DRAW', 0, -9/ 15418 DATA IOPERA( 169),IX( 169),IY( 169)/'MOVE', 1, 12/ 15419 DATA IOPERA( 170),IX( 170),IY( 170)/'DRAW', 1, -9/ 15420 DATA IOPERA( 171),IX( 171),IY( 171)/'MOVE', -3, 12/ 15421 DATA IOPERA( 172),IX( 172),IY( 172)/'DRAW', 4, 12/ 15422 DATA IOPERA( 173),IX( 173),IY( 173)/'MOVE', -3, -9/ 15423 DATA IOPERA( 174),IX( 174),IY( 174)/'DRAW', 4, -9/ 15424C 15425 DATA IXMIND( 9)/ -5/ 15426 DATA IXMAXD( 9)/ 6/ 15427 DATA IXDELD( 9)/ 11/ 15428 DATA ISTARD( 9)/ 167/ 15429 DATA NUMCOO( 9)/ 8/ 15430C 15431C DEFINE CHARACTER 2036--UPPER CASE KAPP 15432C 15433 DATA IOPERA( 175),IX( 175),IY( 175)/'MOVE', -7, 12/ 15434 DATA IOPERA( 176),IX( 176),IY( 176)/'DRAW', -7, -9/ 15435 DATA IOPERA( 177),IX( 177),IY( 177)/'MOVE', -6, 12/ 15436 DATA IOPERA( 178),IX( 178),IY( 178)/'DRAW', -6, -9/ 15437 DATA IOPERA( 179),IX( 179),IY( 179)/'MOVE', 7, 12/ 15438 DATA IOPERA( 180),IX( 180),IY( 180)/'DRAW', -6, -1/ 15439 DATA IOPERA( 181),IX( 181),IY( 181)/'MOVE', -1, 3/ 15440 DATA IOPERA( 182),IX( 182),IY( 182)/'DRAW', 7, -9/ 15441 DATA IOPERA( 183),IX( 183),IY( 183)/'MOVE', -2, 3/ 15442 DATA IOPERA( 184),IX( 184),IY( 184)/'DRAW', 6, -9/ 15443 DATA IOPERA( 185),IX( 185),IY( 185)/'MOVE', -10, 12/ 15444 DATA IOPERA( 186),IX( 186),IY( 186)/'DRAW', -3, 12/ 15445 DATA IOPERA( 187),IX( 187),IY( 187)/'MOVE', 3, 12/ 15446 DATA IOPERA( 188),IX( 188),IY( 188)/'DRAW', 9, 12/ 15447 DATA IOPERA( 189),IX( 189),IY( 189)/'MOVE', -10, -9/ 15448 DATA IOPERA( 190),IX( 190),IY( 190)/'DRAW', -3, -9/ 15449 DATA IOPERA( 191),IX( 191),IY( 191)/'MOVE', 3, -9/ 15450 DATA IOPERA( 192),IX( 192),IY( 192)/'DRAW', 9, -9/ 15451C 15452 DATA IXMIND( 10)/ -12/ 15453 DATA IXMAXD( 10)/ 10/ 15454 DATA IXDELD( 10)/ 22/ 15455 DATA ISTARD( 10)/ 175/ 15456 DATA NUMCOO( 10)/ 18/ 15457C 15458C DEFINE CHARACTER 2037--UPPER CASE LAMB 15459C 15460 DATA IOPERA( 193),IX( 193),IY( 193)/'MOVE', 0, 12/ 15461 DATA IOPERA( 194),IX( 194),IY( 194)/'DRAW', -7, -9/ 15462 DATA IOPERA( 195),IX( 195),IY( 195)/'MOVE', 0, 12/ 15463 DATA IOPERA( 196),IX( 196),IY( 196)/'DRAW', 7, -9/ 15464 DATA IOPERA( 197),IX( 197),IY( 197)/'MOVE', 0, 9/ 15465 DATA IOPERA( 198),IX( 198),IY( 198)/'DRAW', 6, -9/ 15466 DATA IOPERA( 199),IX( 199),IY( 199)/'MOVE', -9, -9/ 15467 DATA IOPERA( 200),IX( 200),IY( 200)/'DRAW', -3, -9/ 15468 DATA IOPERA( 201),IX( 201),IY( 201)/'MOVE', 3, -9/ 15469 DATA IOPERA( 202),IX( 202),IY( 202)/'DRAW', 9, -9/ 15470C 15471 DATA IXMIND( 11)/ -10/ 15472 DATA IXMAXD( 11)/ 10/ 15473 DATA IXDELD( 11)/ 20/ 15474 DATA ISTARD( 11)/ 193/ 15475 DATA NUMCOO( 11)/ 10/ 15476C 15477C DEFINE CHARACTER 2038--UPPER CASE MU 15478C 15479 DATA IOPERA( 203),IX( 203),IY( 203)/'MOVE', -7, 12/ 15480 DATA IOPERA( 204),IX( 204),IY( 204)/'DRAW', -7, -9/ 15481 DATA IOPERA( 205),IX( 205),IY( 205)/'MOVE', -6, 12/ 15482 DATA IOPERA( 206),IX( 206),IY( 206)/'DRAW', 0, -6/ 15483 DATA IOPERA( 207),IX( 207),IY( 207)/'MOVE', -7, 12/ 15484 DATA IOPERA( 208),IX( 208),IY( 208)/'DRAW', 0, -9/ 15485 DATA IOPERA( 209),IX( 209),IY( 209)/'MOVE', 7, 12/ 15486 DATA IOPERA( 210),IX( 210),IY( 210)/'DRAW', 0, -9/ 15487 DATA IOPERA( 211),IX( 211),IY( 211)/'MOVE', 7, 12/ 15488 DATA IOPERA( 212),IX( 212),IY( 212)/'DRAW', 7, -9/ 15489 DATA IOPERA( 213),IX( 213),IY( 213)/'MOVE', 8, 12/ 15490 DATA IOPERA( 214),IX( 214),IY( 214)/'DRAW', 8, -9/ 15491 DATA IOPERA( 215),IX( 215),IY( 215)/'MOVE', -10, 12/ 15492 DATA IOPERA( 216),IX( 216),IY( 216)/'DRAW', -6, 12/ 15493 DATA IOPERA( 217),IX( 217),IY( 217)/'MOVE', 7, 12/ 15494 DATA IOPERA( 218),IX( 218),IY( 218)/'DRAW', 11, 12/ 15495 DATA IOPERA( 219),IX( 219),IY( 219)/'MOVE', -10, -9/ 15496 DATA IOPERA( 220),IX( 220),IY( 220)/'DRAW', -4, -9/ 15497 DATA IOPERA( 221),IX( 221),IY( 221)/'MOVE', 4, -9/ 15498 DATA IOPERA( 222),IX( 222),IY( 222)/'DRAW', 11, -9/ 15499C 15500 DATA IXMIND( 12)/ -12/ 15501 DATA IXMAXD( 12)/ 13/ 15502 DATA IXDELD( 12)/ 25/ 15503 DATA ISTARD( 12)/ 203/ 15504 DATA NUMCOO( 12)/ 20/ 15505C 15506C DEFINE CHARACTER 2039--UPPER CASE NU 15507C 15508 DATA IOPERA( 223),IX( 223),IY( 223)/'MOVE', -6, 12/ 15509 DATA IOPERA( 224),IX( 224),IY( 224)/'DRAW', -6, -9/ 15510 DATA IOPERA( 225),IX( 225),IY( 225)/'MOVE', -5, 12/ 15511 DATA IOPERA( 226),IX( 226),IY( 226)/'DRAW', 7, -7/ 15512 DATA IOPERA( 227),IX( 227),IY( 227)/'MOVE', -5, 10/ 15513 DATA IOPERA( 228),IX( 228),IY( 228)/'DRAW', 7, -9/ 15514 DATA IOPERA( 229),IX( 229),IY( 229)/'MOVE', 7, 12/ 15515 DATA IOPERA( 230),IX( 230),IY( 230)/'DRAW', 7, -9/ 15516 DATA IOPERA( 231),IX( 231),IY( 231)/'MOVE', -9, 12/ 15517 DATA IOPERA( 232),IX( 232),IY( 232)/'DRAW', -5, 12/ 15518 DATA IOPERA( 233),IX( 233),IY( 233)/'MOVE', 4, 12/ 15519 DATA IOPERA( 234),IX( 234),IY( 234)/'DRAW', 10, 12/ 15520 DATA IOPERA( 235),IX( 235),IY( 235)/'MOVE', -9, -9/ 15521 DATA IOPERA( 236),IX( 236),IY( 236)/'DRAW', -3, -9/ 15522C 15523 DATA IXMIND( 13)/ -11/ 15524 DATA IXMAXD( 13)/ 12/ 15525 DATA IXDELD( 13)/ 23/ 15526 DATA ISTARD( 13)/ 223/ 15527 DATA NUMCOO( 13)/ 14/ 15528C 15529C DEFINE CHARACTER 2040--UPPER CASE XI 15530C 15531 DATA IOPERA( 237),IX( 237),IY( 237)/'MOVE', -7, 13/ 15532 DATA IOPERA( 238),IX( 238),IY( 238)/'DRAW', -8, 8/ 15533 DATA IOPERA( 239),IX( 239),IY( 239)/'MOVE', 8, 13/ 15534 DATA IOPERA( 240),IX( 240),IY( 240)/'DRAW', 7, 8/ 15535 DATA IOPERA( 241),IX( 241),IY( 241)/'MOVE', -3, 4/ 15536 DATA IOPERA( 242),IX( 242),IY( 242)/'DRAW', -4, -1/ 15537 DATA IOPERA( 243),IX( 243),IY( 243)/'MOVE', 4, 4/ 15538 DATA IOPERA( 244),IX( 244),IY( 244)/'DRAW', 3, -1/ 15539 DATA IOPERA( 245),IX( 245),IY( 245)/'MOVE', -7, -5/ 15540 DATA IOPERA( 246),IX( 246),IY( 246)/'DRAW', -8, -10/ 15541 DATA IOPERA( 247),IX( 247),IY( 247)/'MOVE', 8, -5/ 15542 DATA IOPERA( 248),IX( 248),IY( 248)/'DRAW', 7, -10/ 15543 DATA IOPERA( 249),IX( 249),IY( 249)/'MOVE', -7, 11/ 15544 DATA IOPERA( 250),IX( 250),IY( 250)/'DRAW', 7, 11/ 15545 DATA IOPERA( 251),IX( 251),IY( 251)/'MOVE', -7, 10/ 15546 DATA IOPERA( 252),IX( 252),IY( 252)/'DRAW', 7, 10/ 15547 DATA IOPERA( 253),IX( 253),IY( 253)/'MOVE', -3, 2/ 15548 DATA IOPERA( 254),IX( 254),IY( 254)/'DRAW', 3, 2/ 15549 DATA IOPERA( 255),IX( 255),IY( 255)/'MOVE', -3, 1/ 15550 DATA IOPERA( 256),IX( 256),IY( 256)/'DRAW', 3, 1/ 15551 DATA IOPERA( 257),IX( 257),IY( 257)/'MOVE', -7, -7/ 15552 DATA IOPERA( 258),IX( 258),IY( 258)/'DRAW', 7, -7/ 15553 DATA IOPERA( 259),IX( 259),IY( 259)/'MOVE', -7, -8/ 15554 DATA IOPERA( 260),IX( 260),IY( 260)/'DRAW', 7, -8/ 15555C 15556 DATA IXMIND( 14)/ -11/ 15557 DATA IXMAXD( 14)/ 11/ 15558 DATA IXDELD( 14)/ 22/ 15559 DATA ISTARD( 14)/ 237/ 15560 DATA NUMCOO( 14)/ 24/ 15561C 15562C-----START POINT----------------------------------------------------- 15563C 15564 IFOUND='YES' 15565 IERROR='NO' 15566C 15567 NUMCO=1 15568 ISTART=1 15569 ISTOP=1 15570 NC=1 15571C 15572C ****************************************** 15573C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 15574C ** HERSHEY CHARACTER SET CASE ** 15575C ****************************************** 15576C 15577C 15578 IF(IBUGD2.EQ.'OFF')GOTO90 15579 WRITE(ICOUT,999) 15580 999 FORMAT(1X) 15581 CALL DPWRST('XXX','BUG ') 15582 WRITE(ICOUT,51) 15583 51 FORMAT('***** AT THE BEGINNING OF DGCU1--') 15584 CALL DPWRST('XXX','BUG ') 15585 WRITE(ICOUT,52)ICHARN 15586 52 FORMAT('ICHARN = ',I8) 15587 CALL DPWRST('XXX','BUG ') 15588 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 15589 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 15590 CALL DPWRST('XXX','BUG ') 15591 90 CONTINUE 15592C 15593C ************************************** 15594C ** STEP 2-- ** 15595C ** EXTRACT THE COORDINATES ** 15596C ** FOR THIS PARTICULAR CHARACTER. ** 15597C ************************************** 15598C 15599 ISTART=ISTARD(ICHARN) 15600 NC=NUMCOO(ICHARN) 15601 ISTOP=ISTART+NC-1 15602 J=0 15603 DO1100I=ISTART,ISTOP 15604 J=J+1 15605 IOP(J)=IOPERA(I) 15606 X(J)=IX(I) 15607 Y(J)=IY(I) 15608 1100 CONTINUE 15609 NUMCO=J 15610 IXMINS=IXMIND(ICHARN) 15611 IXMAXS=IXMAXD(ICHARN) 15612 IXDELS=IXDELD(ICHARN) 15613C 15614 GOTO9000 15615C 15616C ***************** 15617C ** STEP 90-- ** 15618C ** EXIT ** 15619C ***************** 15620C 15621 9000 CONTINUE 15622 IF(IBUGD2.EQ.'OFF')GOTO9090 15623 WRITE(ICOUT,999) 15624 CALL DPWRST('XXX','BUG ') 15625 WRITE(ICOUT,9011) 15626 9011 FORMAT('***** AT THE END OF DGCU1--') 15627 CALL DPWRST('XXX','BUG ') 15628 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 15629 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 15630 CALL DPWRST('XXX','BUG ') 15631 WRITE(ICOUT,9013)ICHARN 15632 9013 FORMAT('ICHARN = ',I8) 15633 CALL DPWRST('XXX','BUG ') 15634 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 15635 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 15636 CALL DPWRST('XXX','BUG ') 15637 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 15638 DO9015I=1,NUMCO 15639 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 15640 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 15641 CALL DPWRST('XXX','BUG ') 15642 9015 CONTINUE 15643 9019 CONTINUE 15644 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 15645 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 15646 CALL DPWRST('XXX','BUG ') 15647 9090 CONTINUE 15648C 15649 RETURN 15650 END 15651 SUBROUTINE DGCU2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 15652 1IBUGD2,IFOUND,IERROR) 15653C 15654C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 15655C FOR GREEK COMPLEX UPPER CASE (PART 2). 15656C WRITTEN BY--JAMES J. FILLIBEN 15657C STATISTICAL ENGINEERING DIVISION 15658C INFORMATION TECHNOLOGY LABORATORY 15659C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 15660C GAITHERSBURG, MD 20899-8980 15661C PHONE--301-921-3651 15662C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 15663C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 15664C LANGUAGE--ANSI FORTRAN (1977) 15665C VERSION NUMBER--87/4 15666C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 15667C UPDATED --MAY 1982. 15668C UPDATED --MARCH 1987. 15669C 15670C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 15671C 15672 CHARACTER*4 IOP 15673 CHARACTER*4 IBUGD2 15674 CHARACTER*4 IFOUND 15675 CHARACTER*4 IERROR 15676C 15677 CHARACTER*4 IOPERA 15678C 15679C--------------------------------------------------------------------- 15680C 15681 DIMENSION IOP(*) 15682 DIMENSION X(*) 15683 DIMENSION Y(*) 15684C 15685 DIMENSION IOPERA(300) 15686 DIMENSION IX(300) 15687 DIMENSION IY(300) 15688C 15689 DIMENSION IXMIND(30) 15690 DIMENSION IXMAXD(30) 15691 DIMENSION IXDELD(30) 15692 DIMENSION ISTARD(30) 15693 DIMENSION NUMCOO(30) 15694C 15695C--------------------------------------------------------------------- 15696C 15697 INCLUDE 'DPCOP2.INC' 15698C 15699C-----DATA STATEMENTS------------------------------------------------- 15700C 15701C DEFINE CHARACTER 2041--UPPER CASE OMIC 15702C 15703 DATA IOPERA( 1),IX( 1),IY( 1)/'MOVE', -1, 12/ 15704 DATA IOPERA( 2),IX( 2),IY( 2)/'DRAW', -4, 11/ 15705 DATA IOPERA( 3),IX( 3),IY( 3)/'DRAW', -6, 9/ 15706 DATA IOPERA( 4),IX( 4),IY( 4)/'DRAW', -7, 7/ 15707 DATA IOPERA( 5),IX( 5),IY( 5)/'DRAW', -8, 3/ 15708 DATA IOPERA( 6),IX( 6),IY( 6)/'DRAW', -8, 0/ 15709 DATA IOPERA( 7),IX( 7),IY( 7)/'DRAW', -7, -4/ 15710 DATA IOPERA( 8),IX( 8),IY( 8)/'DRAW', -6, -6/ 15711 DATA IOPERA( 9),IX( 9),IY( 9)/'DRAW', -4, -8/ 15712 DATA IOPERA( 10),IX( 10),IY( 10)/'DRAW', -1, -9/ 15713 DATA IOPERA( 11),IX( 11),IY( 11)/'DRAW', 1, -9/ 15714 DATA IOPERA( 12),IX( 12),IY( 12)/'DRAW', 4, -8/ 15715 DATA IOPERA( 13),IX( 13),IY( 13)/'DRAW', 6, -6/ 15716 DATA IOPERA( 14),IX( 14),IY( 14)/'DRAW', 7, -4/ 15717 DATA IOPERA( 15),IX( 15),IY( 15)/'DRAW', 8, 0/ 15718 DATA IOPERA( 16),IX( 16),IY( 16)/'DRAW', 8, 3/ 15719 DATA IOPERA( 17),IX( 17),IY( 17)/'DRAW', 7, 7/ 15720 DATA IOPERA( 18),IX( 18),IY( 18)/'DRAW', 6, 9/ 15721 DATA IOPERA( 19),IX( 19),IY( 19)/'DRAW', 4, 11/ 15722 DATA IOPERA( 20),IX( 20),IY( 20)/'DRAW', 1, 12/ 15723 DATA IOPERA( 21),IX( 21),IY( 21)/'DRAW', -1, 12/ 15724 DATA IOPERA( 22),IX( 22),IY( 22)/'MOVE', -1, 12/ 15725 DATA IOPERA( 23),IX( 23),IY( 23)/'DRAW', -3, 11/ 15726 DATA IOPERA( 24),IX( 24),IY( 24)/'DRAW', -5, 9/ 15727 DATA IOPERA( 25),IX( 25),IY( 25)/'DRAW', -6, 7/ 15728 DATA IOPERA( 26),IX( 26),IY( 26)/'DRAW', -7, 3/ 15729 DATA IOPERA( 27),IX( 27),IY( 27)/'DRAW', -7, 0/ 15730 DATA IOPERA( 28),IX( 28),IY( 28)/'DRAW', -6, -4/ 15731 DATA IOPERA( 29),IX( 29),IY( 29)/'DRAW', -5, -6/ 15732 DATA IOPERA( 30),IX( 30),IY( 30)/'DRAW', -3, -8/ 15733 DATA IOPERA( 31),IX( 31),IY( 31)/'DRAW', -1, -9/ 15734 DATA IOPERA( 32),IX( 32),IY( 32)/'MOVE', 1, -9/ 15735 DATA IOPERA( 33),IX( 33),IY( 33)/'DRAW', 3, -8/ 15736 DATA IOPERA( 34),IX( 34),IY( 34)/'DRAW', 5, -6/ 15737 DATA IOPERA( 35),IX( 35),IY( 35)/'DRAW', 6, -4/ 15738 DATA IOPERA( 36),IX( 36),IY( 36)/'DRAW', 7, 0/ 15739 DATA IOPERA( 37),IX( 37),IY( 37)/'DRAW', 7, 3/ 15740 DATA IOPERA( 38),IX( 38),IY( 38)/'DRAW', 6, 7/ 15741 DATA IOPERA( 39),IX( 39),IY( 39)/'DRAW', 5, 9/ 15742 DATA IOPERA( 40),IX( 40),IY( 40)/'DRAW', 3, 11/ 15743 DATA IOPERA( 41),IX( 41),IY( 41)/'DRAW', 1, 12/ 15744C 15745 DATA IXMIND( 15)/ -11/ 15746 DATA IXMAXD( 15)/ 11/ 15747 DATA IXDELD( 15)/ 22/ 15748 DATA ISTARD( 15)/ 1/ 15749 DATA NUMCOO( 15)/ 41/ 15750C 15751C DEFINE CHARACTER 2042--UPPER CASE PI 15752C 15753 DATA IOPERA( 42),IX( 42),IY( 42)/'MOVE', -7, 12/ 15754 DATA IOPERA( 43),IX( 43),IY( 43)/'DRAW', -7, -9/ 15755 DATA IOPERA( 44),IX( 44),IY( 44)/'MOVE', -6, 12/ 15756 DATA IOPERA( 45),IX( 45),IY( 45)/'DRAW', -6, -9/ 15757 DATA IOPERA( 46),IX( 46),IY( 46)/'MOVE', 6, 12/ 15758 DATA IOPERA( 47),IX( 47),IY( 47)/'DRAW', 6, -9/ 15759 DATA IOPERA( 48),IX( 48),IY( 48)/'MOVE', 7, 12/ 15760 DATA IOPERA( 49),IX( 49),IY( 49)/'DRAW', 7, -9/ 15761 DATA IOPERA( 50),IX( 50),IY( 50)/'MOVE', -10, 12/ 15762 DATA IOPERA( 51),IX( 51),IY( 51)/'DRAW', 10, 12/ 15763 DATA IOPERA( 52),IX( 52),IY( 52)/'MOVE', -10, -9/ 15764 DATA IOPERA( 53),IX( 53),IY( 53)/'DRAW', -3, -9/ 15765 DATA IOPERA( 54),IX( 54),IY( 54)/'MOVE', 3, -9/ 15766 DATA IOPERA( 55),IX( 55),IY( 55)/'DRAW', 10, -9/ 15767C 15768 DATA IXMIND( 16)/ -12/ 15769 DATA IXMAXD( 16)/ 12/ 15770 DATA IXDELD( 16)/ 24/ 15771 DATA ISTARD( 16)/ 42/ 15772 DATA NUMCOO( 16)/ 14/ 15773C 15774C DEFINE CHARACTER 2043--UPPER CASE RHO 15775C 15776 DATA IOPERA( 56),IX( 56),IY( 56)/'MOVE', -6, 12/ 15777 DATA IOPERA( 57),IX( 57),IY( 57)/'DRAW', -6, -9/ 15778 DATA IOPERA( 58),IX( 58),IY( 58)/'MOVE', -5, 12/ 15779 DATA IOPERA( 59),IX( 59),IY( 59)/'DRAW', -5, -9/ 15780 DATA IOPERA( 60),IX( 60),IY( 60)/'MOVE', -9, 12/ 15781 DATA IOPERA( 61),IX( 61),IY( 61)/'DRAW', 3, 12/ 15782 DATA IOPERA( 62),IX( 62),IY( 62)/'DRAW', 6, 11/ 15783 DATA IOPERA( 63),IX( 63),IY( 63)/'DRAW', 7, 10/ 15784 DATA IOPERA( 64),IX( 64),IY( 64)/'DRAW', 8, 8/ 15785 DATA IOPERA( 65),IX( 65),IY( 65)/'DRAW', 8, 5/ 15786 DATA IOPERA( 66),IX( 66),IY( 66)/'DRAW', 7, 3/ 15787 DATA IOPERA( 67),IX( 67),IY( 67)/'DRAW', 6, 2/ 15788 DATA IOPERA( 68),IX( 68),IY( 68)/'DRAW', 3, 1/ 15789 DATA IOPERA( 69),IX( 69),IY( 69)/'DRAW', -5, 1/ 15790 DATA IOPERA( 70),IX( 70),IY( 70)/'MOVE', 3, 12/ 15791 DATA IOPERA( 71),IX( 71),IY( 71)/'DRAW', 5, 11/ 15792 DATA IOPERA( 72),IX( 72),IY( 72)/'DRAW', 6, 10/ 15793 DATA IOPERA( 73),IX( 73),IY( 73)/'DRAW', 7, 8/ 15794 DATA IOPERA( 74),IX( 74),IY( 74)/'DRAW', 7, 5/ 15795 DATA IOPERA( 75),IX( 75),IY( 75)/'DRAW', 6, 3/ 15796 DATA IOPERA( 76),IX( 76),IY( 76)/'DRAW', 5, 2/ 15797 DATA IOPERA( 77),IX( 77),IY( 77)/'DRAW', 3, 1/ 15798 DATA IOPERA( 78),IX( 78),IY( 78)/'MOVE', -9, -9/ 15799 DATA IOPERA( 79),IX( 79),IY( 79)/'DRAW', -2, -9/ 15800C 15801 DATA IXMIND( 17)/ -11/ 15802 DATA IXMAXD( 17)/ 11/ 15803 DATA IXDELD( 17)/ 22/ 15804 DATA ISTARD( 17)/ 56/ 15805 DATA NUMCOO( 17)/ 24/ 15806C 15807C DEFINE CHARACTER 2044--UPPER CASE SIGM 15808C 15809 DATA IOPERA( 80),IX( 80),IY( 80)/'MOVE', -7, 12/ 15810 DATA IOPERA( 81),IX( 81),IY( 81)/'DRAW', 0, 2/ 15811 DATA IOPERA( 82),IX( 82),IY( 82)/'DRAW', -8, -9/ 15812 DATA IOPERA( 83),IX( 83),IY( 83)/'MOVE', -8, 12/ 15813 DATA IOPERA( 84),IX( 84),IY( 84)/'DRAW', -1, 2/ 15814 DATA IOPERA( 85),IX( 85),IY( 85)/'MOVE', -8, 12/ 15815 DATA IOPERA( 86),IX( 86),IY( 86)/'DRAW', 7, 12/ 15816 DATA IOPERA( 87),IX( 87),IY( 87)/'DRAW', 8, 6/ 15817 DATA IOPERA( 88),IX( 88),IY( 88)/'DRAW', 6, 12/ 15818 DATA IOPERA( 89),IX( 89),IY( 89)/'MOVE', -7, -8/ 15819 DATA IOPERA( 90),IX( 90),IY( 90)/'DRAW', 6, -8/ 15820 DATA IOPERA( 91),IX( 91),IY( 91)/'MOVE', -8, -9/ 15821 DATA IOPERA( 92),IX( 92),IY( 92)/'DRAW', 7, -9/ 15822 DATA IOPERA( 93),IX( 93),IY( 93)/'DRAW', 8, -3/ 15823 DATA IOPERA( 94),IX( 94),IY( 94)/'DRAW', 6, -9/ 15824C 15825 DATA IXMIND( 18)/ -10/ 15826 DATA IXMAXD( 18)/ 11/ 15827 DATA IXDELD( 18)/ 21/ 15828 DATA ISTARD( 18)/ 80/ 15829 DATA NUMCOO( 18)/ 15/ 15830C 15831C DEFINE CHARACTER 2045--UPPER CASE TAU 15832C 15833 DATA IOPERA( 95),IX( 95),IY( 95)/'MOVE', 0, 12/ 15834 DATA IOPERA( 96),IX( 96),IY( 96)/'DRAW', 0, -9/ 15835 DATA IOPERA( 97),IX( 97),IY( 97)/'MOVE', 1, 12/ 15836 DATA IOPERA( 98),IX( 98),IY( 98)/'DRAW', 1, -9/ 15837 DATA IOPERA( 99),IX( 99),IY( 99)/'MOVE', -6, 12/ 15838 DATA IOPERA( 100),IX( 100),IY( 100)/'DRAW', -7, 6/ 15839 DATA IOPERA( 101),IX( 101),IY( 101)/'DRAW', -7, 12/ 15840 DATA IOPERA( 102),IX( 102),IY( 102)/'DRAW', 8, 12/ 15841 DATA IOPERA( 103),IX( 103),IY( 103)/'DRAW', 8, 6/ 15842 DATA IOPERA( 104),IX( 104),IY( 104)/'DRAW', 7, 12/ 15843 DATA IOPERA( 105),IX( 105),IY( 105)/'MOVE', -3, -9/ 15844 DATA IOPERA( 106),IX( 106),IY( 106)/'DRAW', 4, -9/ 15845C 15846 DATA IXMIND( 19)/ -9/ 15847 DATA IXMAXD( 19)/ 10/ 15848 DATA IXDELD( 19)/ 19/ 15849 DATA ISTARD( 19)/ 95/ 15850 DATA NUMCOO( 19)/ 12/ 15851C 15852C DEFINE CHARACTER 2046--UPPER CASE UPSI 15853C 15854 DATA IOPERA( 107),IX( 107),IY( 107)/'MOVE', -7, 7/ 15855 DATA IOPERA( 108),IX( 108),IY( 108)/'DRAW', -7, 9/ 15856 DATA IOPERA( 109),IX( 109),IY( 109)/'DRAW', -6, 11/ 15857 DATA IOPERA( 110),IX( 110),IY( 110)/'DRAW', -5, 12/ 15858 DATA IOPERA( 111),IX( 111),IY( 111)/'DRAW', -3, 12/ 15859 DATA IOPERA( 112),IX( 112),IY( 112)/'DRAW', -2, 11/ 15860 DATA IOPERA( 113),IX( 113),IY( 113)/'DRAW', -1, 9/ 15861 DATA IOPERA( 114),IX( 114),IY( 114)/'DRAW', 0, 5/ 15862 DATA IOPERA( 115),IX( 115),IY( 115)/'DRAW', 0, -9/ 15863 DATA IOPERA( 116),IX( 116),IY( 116)/'MOVE', -7, 9/ 15864 DATA IOPERA( 117),IX( 117),IY( 117)/'DRAW', -5, 11/ 15865 DATA IOPERA( 118),IX( 118),IY( 118)/'DRAW', -3, 11/ 15866 DATA IOPERA( 119),IX( 119),IY( 119)/'DRAW', -1, 9/ 15867 DATA IOPERA( 120),IX( 120),IY( 120)/'MOVE', 8, 7/ 15868 DATA IOPERA( 121),IX( 121),IY( 121)/'DRAW', 8, 9/ 15869 DATA IOPERA( 122),IX( 122),IY( 122)/'DRAW', 7, 11/ 15870 DATA IOPERA( 123),IX( 123),IY( 123)/'DRAW', 6, 12/ 15871 DATA IOPERA( 124),IX( 124),IY( 124)/'DRAW', 4, 12/ 15872 DATA IOPERA( 125),IX( 125),IY( 125)/'DRAW', 3, 11/ 15873 DATA IOPERA( 126),IX( 126),IY( 126)/'DRAW', 2, 9/ 15874 DATA IOPERA( 127),IX( 127),IY( 127)/'DRAW', 1, 5/ 15875 DATA IOPERA( 128),IX( 128),IY( 128)/'DRAW', 1, -9/ 15876 DATA IOPERA( 129),IX( 129),IY( 129)/'MOVE', 8, 9/ 15877 DATA IOPERA( 130),IX( 130),IY( 130)/'DRAW', 6, 11/ 15878 DATA IOPERA( 131),IX( 131),IY( 131)/'DRAW', 4, 11/ 15879 DATA IOPERA( 132),IX( 132),IY( 132)/'DRAW', 2, 9/ 15880 DATA IOPERA( 133),IX( 133),IY( 133)/'MOVE', -3, -9/ 15881 DATA IOPERA( 134),IX( 134),IY( 134)/'DRAW', 4, -9/ 15882C 15883 DATA IXMIND( 20)/ -9/ 15884 DATA IXMAXD( 20)/ 10/ 15885 DATA IXDELD( 20)/ 19/ 15886 DATA ISTARD( 20)/ 107/ 15887 DATA NUMCOO( 20)/ 28/ 15888C 15889C DEFINE CHARACTER 2047--UPPER CASE PHI 15890C 15891 DATA IOPERA( 135),IX( 135),IY( 135)/'MOVE', 0, 12/ 15892 DATA IOPERA( 136),IX( 136),IY( 136)/'DRAW', 0, -9/ 15893 DATA IOPERA( 137),IX( 137),IY( 137)/'MOVE', 1, 12/ 15894 DATA IOPERA( 138),IX( 138),IY( 138)/'DRAW', 1, -9/ 15895 DATA IOPERA( 139),IX( 139),IY( 139)/'MOVE', -2, 7/ 15896 DATA IOPERA( 140),IX( 140),IY( 140)/'DRAW', -5, 6/ 15897 DATA IOPERA( 141),IX( 141),IY( 141)/'DRAW', -6, 5/ 15898 DATA IOPERA( 142),IX( 142),IY( 142)/'DRAW', -7, 3/ 15899 DATA IOPERA( 143),IX( 143),IY( 143)/'DRAW', -7, 0/ 15900 DATA IOPERA( 144),IX( 144),IY( 144)/'DRAW', -6, -2/ 15901 DATA IOPERA( 145),IX( 145),IY( 145)/'DRAW', -5, -3/ 15902 DATA IOPERA( 146),IX( 146),IY( 146)/'DRAW', -2, -4/ 15903 DATA IOPERA( 147),IX( 147),IY( 147)/'DRAW', 3, -4/ 15904 DATA IOPERA( 148),IX( 148),IY( 148)/'DRAW', 6, -3/ 15905 DATA IOPERA( 149),IX( 149),IY( 149)/'DRAW', 7, -2/ 15906 DATA IOPERA( 150),IX( 150),IY( 150)/'DRAW', 8, 0/ 15907 DATA IOPERA( 151),IX( 151),IY( 151)/'DRAW', 8, 3/ 15908 DATA IOPERA( 152),IX( 152),IY( 152)/'DRAW', 7, 5/ 15909 DATA IOPERA( 153),IX( 153),IY( 153)/'DRAW', 6, 6/ 15910 DATA IOPERA( 154),IX( 154),IY( 154)/'DRAW', 3, 7/ 15911 DATA IOPERA( 155),IX( 155),IY( 155)/'DRAW', -2, 7/ 15912 DATA IOPERA( 156),IX( 156),IY( 156)/'MOVE', -2, 7/ 15913 DATA IOPERA( 157),IX( 157),IY( 157)/'DRAW', -4, 6/ 15914 DATA IOPERA( 158),IX( 158),IY( 158)/'DRAW', -5, 5/ 15915 DATA IOPERA( 159),IX( 159),IY( 159)/'DRAW', -6, 3/ 15916 DATA IOPERA( 160),IX( 160),IY( 160)/'DRAW', -6, 0/ 15917 DATA IOPERA( 161),IX( 161),IY( 161)/'DRAW', -5, -2/ 15918 DATA IOPERA( 162),IX( 162),IY( 162)/'DRAW', -4, -3/ 15919 DATA IOPERA( 163),IX( 163),IY( 163)/'DRAW', -2, -4/ 15920 DATA IOPERA( 164),IX( 164),IY( 164)/'MOVE', 3, -4/ 15921 DATA IOPERA( 165),IX( 165),IY( 165)/'DRAW', 5, -3/ 15922 DATA IOPERA( 166),IX( 166),IY( 166)/'DRAW', 6, -2/ 15923 DATA IOPERA( 167),IX( 167),IY( 167)/'DRAW', 7, 0/ 15924 DATA IOPERA( 168),IX( 168),IY( 168)/'DRAW', 7, 3/ 15925 DATA IOPERA( 169),IX( 169),IY( 169)/'DRAW', 6, 5/ 15926 DATA IOPERA( 170),IX( 170),IY( 170)/'DRAW', 5, 6/ 15927 DATA IOPERA( 171),IX( 171),IY( 171)/'DRAW', 3, 7/ 15928 DATA IOPERA( 172),IX( 172),IY( 172)/'MOVE', -3, 12/ 15929 DATA IOPERA( 173),IX( 173),IY( 173)/'DRAW', 4, 12/ 15930 DATA IOPERA( 174),IX( 174),IY( 174)/'MOVE', -3, -9/ 15931 DATA IOPERA( 175),IX( 175),IY( 175)/'DRAW', 4, -9/ 15932C 15933 DATA IXMIND( 21)/ -10/ 15934 DATA IXMAXD( 21)/ 11/ 15935 DATA IXDELD( 21)/ 21/ 15936 DATA ISTARD( 21)/ 135/ 15937 DATA NUMCOO( 21)/ 41/ 15938C 15939C DEFINE CHARACTER 2048--UPPER CASE CHI 15940C 15941 DATA IOPERA( 176),IX( 176),IY( 176)/'MOVE', -7, 12/ 15942 DATA IOPERA( 177),IX( 177),IY( 177)/'DRAW', 6, -9/ 15943 DATA IOPERA( 178),IX( 178),IY( 178)/'MOVE', -6, 12/ 15944 DATA IOPERA( 179),IX( 179),IY( 179)/'DRAW', 7, -9/ 15945 DATA IOPERA( 180),IX( 180),IY( 180)/'MOVE', 7, 12/ 15946 DATA IOPERA( 181),IX( 181),IY( 181)/'DRAW', -7, -9/ 15947 DATA IOPERA( 182),IX( 182),IY( 182)/'MOVE', -9, 12/ 15948 DATA IOPERA( 183),IX( 183),IY( 183)/'DRAW', -3, 12/ 15949 DATA IOPERA( 184),IX( 184),IY( 184)/'MOVE', 3, 12/ 15950 DATA IOPERA( 185),IX( 185),IY( 185)/'DRAW', 9, 12/ 15951 DATA IOPERA( 186),IX( 186),IY( 186)/'MOVE', -9, -9/ 15952 DATA IOPERA( 187),IX( 187),IY( 187)/'DRAW', -3, -9/ 15953 DATA IOPERA( 188),IX( 188),IY( 188)/'MOVE', 3, -9/ 15954 DATA IOPERA( 189),IX( 189),IY( 189)/'DRAW', 9, -9/ 15955C 15956 DATA IXMIND( 22)/ -10/ 15957 DATA IXMAXD( 22)/ 10/ 15958 DATA IXDELD( 22)/ 20/ 15959 DATA ISTARD( 22)/ 176/ 15960 DATA NUMCOO( 22)/ 14/ 15961C 15962C DEFINE CHARACTER 2049--UPPER CASE PSI 15963C 15964 DATA IOPERA( 190),IX( 190),IY( 190)/'MOVE', 0, 12/ 15965 DATA IOPERA( 191),IX( 191),IY( 191)/'DRAW', 0, -9/ 15966 DATA IOPERA( 192),IX( 192),IY( 192)/'MOVE', 1, 12/ 15967 DATA IOPERA( 193),IX( 193),IY( 193)/'DRAW', 1, -9/ 15968 DATA IOPERA( 194),IX( 194),IY( 194)/'MOVE', -9, 5/ 15969 DATA IOPERA( 195),IX( 195),IY( 195)/'DRAW', -8, 6/ 15970 DATA IOPERA( 196),IX( 196),IY( 196)/'DRAW', -6, 5/ 15971 DATA IOPERA( 197),IX( 197),IY( 197)/'DRAW', -5, 1/ 15972 DATA IOPERA( 198),IX( 198),IY( 198)/'DRAW', -4, -1/ 15973 DATA IOPERA( 199),IX( 199),IY( 199)/'DRAW', -3, -2/ 15974 DATA IOPERA( 200),IX( 200),IY( 200)/'DRAW', -1, -3/ 15975 DATA IOPERA( 201),IX( 201),IY( 201)/'MOVE', -8, 6/ 15976 DATA IOPERA( 202),IX( 202),IY( 202)/'DRAW', -7, 5/ 15977 DATA IOPERA( 203),IX( 203),IY( 203)/'DRAW', -6, 1/ 15978 DATA IOPERA( 204),IX( 204),IY( 204)/'DRAW', -5, -1/ 15979 DATA IOPERA( 205),IX( 205),IY( 205)/'DRAW', -4, -2/ 15980 DATA IOPERA( 206),IX( 206),IY( 206)/'DRAW', -1, -3/ 15981 DATA IOPERA( 207),IX( 207),IY( 207)/'DRAW', 2, -3/ 15982 DATA IOPERA( 208),IX( 208),IY( 208)/'DRAW', 5, -2/ 15983 DATA IOPERA( 209),IX( 209),IY( 209)/'DRAW', 6, -1/ 15984 DATA IOPERA( 210),IX( 210),IY( 210)/'DRAW', 7, 1/ 15985 DATA IOPERA( 211),IX( 211),IY( 211)/'DRAW', 8, 5/ 15986 DATA IOPERA( 212),IX( 212),IY( 212)/'DRAW', 9, 6/ 15987 DATA IOPERA( 213),IX( 213),IY( 213)/'MOVE', 2, -3/ 15988 DATA IOPERA( 214),IX( 214),IY( 214)/'DRAW', 4, -2/ 15989 DATA IOPERA( 215),IX( 215),IY( 215)/'DRAW', 5, -1/ 15990 DATA IOPERA( 216),IX( 216),IY( 216)/'DRAW', 6, 1/ 15991 DATA IOPERA( 217),IX( 217),IY( 217)/'DRAW', 7, 5/ 15992 DATA IOPERA( 218),IX( 218),IY( 218)/'DRAW', 9, 6/ 15993 DATA IOPERA( 219),IX( 219),IY( 219)/'DRAW', 10, 5/ 15994 DATA IOPERA( 220),IX( 220),IY( 220)/'MOVE', -3, 12/ 15995 DATA IOPERA( 221),IX( 221),IY( 221)/'DRAW', 4, 12/ 15996 DATA IOPERA( 222),IX( 222),IY( 222)/'MOVE', -3, -9/ 15997 DATA IOPERA( 223),IX( 223),IY( 223)/'DRAW', 4, -9/ 15998C 15999 DATA IXMIND( 23)/ -11/ 16000 DATA IXMAXD( 23)/ 12/ 16001 DATA IXDELD( 23)/ 23/ 16002 DATA ISTARD( 23)/ 190/ 16003 DATA NUMCOO( 23)/ 34/ 16004C 16005C DEFINE CHARACTER 2050--UPPER CASE OMEG 16006C 16007 DATA IOPERA( 224),IX( 224),IY( 224)/'MOVE', -8, -6/ 16008 DATA IOPERA( 225),IX( 225),IY( 225)/'DRAW', -7, -9/ 16009 DATA IOPERA( 226),IX( 226),IY( 226)/'DRAW', -3, -9/ 16010 DATA IOPERA( 227),IX( 227),IY( 227)/'DRAW', -5, -5/ 16011 DATA IOPERA( 228),IX( 228),IY( 228)/'DRAW', -7, -1/ 16012 DATA IOPERA( 229),IX( 229),IY( 229)/'DRAW', -8, 2/ 16013 DATA IOPERA( 230),IX( 230),IY( 230)/'DRAW', -8, 6/ 16014 DATA IOPERA( 231),IX( 231),IY( 231)/'DRAW', -7, 9/ 16015 DATA IOPERA( 232),IX( 232),IY( 232)/'DRAW', -5, 11/ 16016 DATA IOPERA( 233),IX( 233),IY( 233)/'DRAW', -2, 12/ 16017 DATA IOPERA( 234),IX( 234),IY( 234)/'DRAW', 2, 12/ 16018 DATA IOPERA( 235),IX( 235),IY( 235)/'DRAW', 5, 11/ 16019 DATA IOPERA( 236),IX( 236),IY( 236)/'DRAW', 7, 9/ 16020 DATA IOPERA( 237),IX( 237),IY( 237)/'DRAW', 8, 6/ 16021 DATA IOPERA( 238),IX( 238),IY( 238)/'DRAW', 8, 2/ 16022 DATA IOPERA( 239),IX( 239),IY( 239)/'DRAW', 7, -1/ 16023 DATA IOPERA( 240),IX( 240),IY( 240)/'DRAW', 5, -5/ 16024 DATA IOPERA( 241),IX( 241),IY( 241)/'DRAW', 3, -9/ 16025 DATA IOPERA( 242),IX( 242),IY( 242)/'DRAW', 7, -9/ 16026 DATA IOPERA( 243),IX( 243),IY( 243)/'DRAW', 8, -6/ 16027 DATA IOPERA( 244),IX( 244),IY( 244)/'MOVE', -5, -5/ 16028 DATA IOPERA( 245),IX( 245),IY( 245)/'DRAW', -6, -2/ 16029 DATA IOPERA( 246),IX( 246),IY( 246)/'DRAW', -7, 2/ 16030 DATA IOPERA( 247),IX( 247),IY( 247)/'DRAW', -7, 6/ 16031 DATA IOPERA( 248),IX( 248),IY( 248)/'DRAW', -6, 9/ 16032 DATA IOPERA( 249),IX( 249),IY( 249)/'DRAW', -4, 11/ 16033 DATA IOPERA( 250),IX( 250),IY( 250)/'DRAW', -2, 12/ 16034 DATA IOPERA( 251),IX( 251),IY( 251)/'MOVE', 2, 12/ 16035 DATA IOPERA( 252),IX( 252),IY( 252)/'DRAW', 4, 11/ 16036 DATA IOPERA( 253),IX( 253),IY( 253)/'DRAW', 6, 9/ 16037 DATA IOPERA( 254),IX( 254),IY( 254)/'DRAW', 7, 6/ 16038 DATA IOPERA( 255),IX( 255),IY( 255)/'DRAW', 7, 2/ 16039 DATA IOPERA( 256),IX( 256),IY( 256)/'DRAW', 6, -2/ 16040 DATA IOPERA( 257),IX( 257),IY( 257)/'DRAW', 5, -5/ 16041 DATA IOPERA( 258),IX( 258),IY( 258)/'MOVE', -7, -8/ 16042 DATA IOPERA( 259),IX( 259),IY( 259)/'DRAW', -4, -8/ 16043 DATA IOPERA( 260),IX( 260),IY( 260)/'MOVE', 4, -8/ 16044 DATA IOPERA( 261),IX( 261),IY( 261)/'DRAW', 7, -8/ 16045C 16046 DATA IXMIND( 24)/ -11/ 16047 DATA IXMAXD( 24)/ 11/ 16048 DATA IXDELD( 24)/ 22/ 16049 DATA ISTARD( 24)/ 224/ 16050 DATA NUMCOO( 24)/ 38/ 16051C 16052C-----START POINT----------------------------------------------------- 16053C 16054 IFOUND='YES' 16055 IERROR='NO' 16056C 16057 NUMCO=1 16058 ISTART=1 16059 ISTOP=1 16060 NC=1 16061C 16062C ****************************************** 16063C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 16064C ** HERSHEY CHARACTER SET CASE ** 16065C ****************************************** 16066C 16067C 16068 IF(IBUGD2.EQ.'OFF')GOTO90 16069 WRITE(ICOUT,999) 16070 999 FORMAT(1X) 16071 CALL DPWRST('XXX','BUG ') 16072 WRITE(ICOUT,51) 16073 51 FORMAT('***** AT THE BEGINNING OF DGCU2--') 16074 CALL DPWRST('XXX','BUG ') 16075 WRITE(ICOUT,52)ICHARN 16076 52 FORMAT('ICHARN = ',I8) 16077 CALL DPWRST('XXX','BUG ') 16078 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 16079 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 16080 CALL DPWRST('XXX','BUG ') 16081 90 CONTINUE 16082C 16083C ************************************** 16084C ** STEP 2-- ** 16085C ** EXTRACT THE COORDINATES ** 16086C ** FOR THIS PARTICULAR CHARACTER. ** 16087C ************************************** 16088C 16089 ISTART=ISTARD(ICHARN) 16090 NC=NUMCOO(ICHARN) 16091 ISTOP=ISTART+NC-1 16092 J=0 16093 DO1100I=ISTART,ISTOP 16094 J=J+1 16095 IOP(J)=IOPERA(I) 16096 X(J)=IX(I) 16097 Y(J)=IY(I) 16098 1100 CONTINUE 16099 NUMCO=J 16100 IXMINS=IXMIND(ICHARN) 16101 IXMAXS=IXMAXD(ICHARN) 16102 IXDELS=IXDELD(ICHARN) 16103C 16104 GOTO9000 16105C 16106C ***************** 16107C ** STEP 90-- ** 16108C ** EXIT ** 16109C ***************** 16110C 16111 9000 CONTINUE 16112 IF(IBUGD2.EQ.'OFF')GOTO9090 16113 WRITE(ICOUT,999) 16114 CALL DPWRST('XXX','BUG ') 16115 WRITE(ICOUT,9011) 16116 9011 FORMAT('***** AT THE END OF DGCU2--') 16117 CALL DPWRST('XXX','BUG ') 16118 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 16119 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 16120 CALL DPWRST('XXX','BUG ') 16121 WRITE(ICOUT,9013)ICHARN 16122 9013 FORMAT('ICHARN = ',I8) 16123 CALL DPWRST('XXX','BUG ') 16124 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 16125 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 16126 CALL DPWRST('XXX','BUG ') 16127 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 16128 DO9015I=1,NUMCO 16129 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 16130 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 16131 CALL DPWRST('XXX','BUG ') 16132 9015 CONTINUE 16133 9019 CONTINUE 16134 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 16135 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 16136 CALL DPWRST('XXX','BUG ') 16137 9090 CONTINUE 16138C 16139 RETURN 16140 END 16141 SUBROUTINE DGECO(A,LDA,N,IPVT,RCOND,Z) 16142C***BEGIN PROLOGUE DGECO 16143C***DATE WRITTEN 780814 (YYMMDD) 16144C***REVISION DATE 820801 (YYMMDD) 16145C***CATEGORY NO. D2A1 16146C***KEYWORDS CONDITION,DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK, 16147C MATRIX 16148C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) 16149C***PURPOSE Factors a double precision matrix by Gaussian elimination 16150C and estimates the condition of the matrix. 16151C***DESCRIPTION 16152C 16153C DGECO factors a double precision matrix by Gaussian elimination 16154C and estimates the condition of the matrix. 16155C 16156C If RCOND is not needed, DGEFA is slightly faster. 16157C To solve A*X = B , follow DGECO by DGESL. 16158C To compute INVERSE(A)*C , follow DGECO by DGESL. 16159C To compute DETERMINANT(A) , follow DGECO by DGEDI. 16160C To compute INVERSE(A) , follow DGECO by DGEDI. 16161C 16162C On Entry 16163C 16164C A DOUBLE PRECISION(LDA, N) 16165C the matrix to be factored. 16166C 16167C LDA INTEGER 16168C the leading dimension of the array A . 16169C 16170C N INTEGER 16171C the order of the matrix A . 16172C 16173C On Return 16174C 16175C A an upper triangular matrix and the multipliers 16176C which were used to obtain it. 16177C The factorization can be written A = L*U where 16178C L is a product of permutation and unit lower 16179C triangular matrices and U is upper triangular. 16180C 16181C IPVT INTEGER(N) 16182C an INTEGER vector of pivot indices. 16183C 16184C RCOND DOUBLE PRECISION 16185C an estimate of the reciprocal condition of A . 16186C For the system A*X = B , relative perturbations 16187C in A and B of size EPSILON may cause 16188C relative perturbations in X of size EPSILON/RCOND . 16189C If RCOND is so small that the logical expression 16190C 1.0 + RCOND .EQ. 1.0 16191C is true, then A may be singular to working 16192C precision. In particular, RCOND is zero if 16193C exact singularity is detected or the estimate 16194C underflows. 16195C 16196C Z DOUBLE PRECISION(N) 16197C a work vector whose contents are usually unimportant. 16198C If A is close to a singular matrix, then Z is 16199C an approximate null vector in the sense that 16200C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . 16201C 16202C LINPACK. This version dated 08/14/78 . 16203C Cleve Moler, University of New Mexico, Argonne National Lab. 16204C 16205C Subroutines and Functions 16206C 16207C LINPACK DGEFA 16208C BLAS DAXPY,DDOT,DSCAL,DASUM 16209C Fortran DABS,DMAX1,DSIGN 16210C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., 16211C *LINPACK USERS GUIDE*, SIAM, 1979. 16212C***ROUTINES CALLED DASUM,DAXPY,DDOT,DGEFA,DSCAL 16213C***END PROLOGUE DGECO 16214 INTEGER LDA,N,IPVT(1) 16215 DOUBLE PRECISION A(LDA,1),Z(1) 16216 DOUBLE PRECISION RCOND 16217C 16218 DOUBLE PRECISION DDOT,EK,T,WK,WKM 16219 DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM 16220 INTEGER INFO,J,K,KB,KP1,L 16221C 16222C COMPUTE 1-NORM OF A 16223C 16224C***FIRST EXECUTABLE STATEMENT DGECO 16225 ANORM = 0.0D0 16226 DO 10 J = 1, N 16227 ANORM = DMAX1(ANORM,DASUM(N,A(1,J),1)) 16228 10 CONTINUE 16229C 16230C FACTOR 16231C 16232 CALL DGEFA(A,LDA,N,IPVT,INFO) 16233C 16234C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . 16235C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E . 16236C TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE 16237C CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE 16238C TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID 16239C OVERFLOW. 16240C 16241C SOLVE TRANS(U)*W = E 16242C 16243 EK = 1.0D0 16244 DO 20 J = 1, N 16245 Z(J) = 0.0D0 16246 20 CONTINUE 16247 DO 100 K = 1, N 16248 IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K)) 16249 IF (DABS(EK-Z(K)) .LE. DABS(A(K,K))) GO TO 30 16250 S = DABS(A(K,K))/DABS(EK-Z(K)) 16251 CALL DSCAL(N,S,Z,1) 16252 EK = S*EK 16253 30 CONTINUE 16254 WK = EK - Z(K) 16255 WKM = -EK - Z(K) 16256 S = DABS(WK) 16257 SM = DABS(WKM) 16258 IF (A(K,K) .EQ. 0.0D0) GO TO 40 16259 WK = WK/A(K,K) 16260 WKM = WKM/A(K,K) 16261 GO TO 50 16262 40 CONTINUE 16263 WK = 1.0D0 16264 WKM = 1.0D0 16265 50 CONTINUE 16266 KP1 = K + 1 16267 IF (KP1 .GT. N) GO TO 90 16268 DO 60 J = KP1, N 16269 SM = SM + DABS(Z(J)+WKM*A(K,J)) 16270 Z(J) = Z(J) + WK*A(K,J) 16271 S = S + DABS(Z(J)) 16272 60 CONTINUE 16273 IF (S .GE. SM) GO TO 80 16274 T = WKM - WK 16275 WK = WKM 16276 DO 70 J = KP1, N 16277 Z(J) = Z(J) + T*A(K,J) 16278 70 CONTINUE 16279 80 CONTINUE 16280 90 CONTINUE 16281 Z(K) = WK 16282 100 CONTINUE 16283 S = 1.0D0/DASUM(N,Z,1) 16284 CALL DSCAL(N,S,Z,1) 16285C 16286C SOLVE TRANS(L)*Y = W 16287C 16288 DO 120 KB = 1, N 16289 K = N + 1 - KB 16290 IF (K .LT. N) Z(K) = Z(K) + DDOT(N-K,A(K+1,K),1,Z(K+1),1) 16291 IF (DABS(Z(K)) .LE. 1.0D0) GO TO 110 16292 S = 1.0D0/DABS(Z(K)) 16293 CALL DSCAL(N,S,Z,1) 16294 110 CONTINUE 16295 L = IPVT(K) 16296 T = Z(L) 16297 Z(L) = Z(K) 16298 Z(K) = T 16299 120 CONTINUE 16300 S = 1.0D0/DASUM(N,Z,1) 16301 CALL DSCAL(N,S,Z,1) 16302C 16303 YNORM = 1.0D0 16304C 16305C SOLVE L*V = Y 16306C 16307 DO 140 K = 1, N 16308 L = IPVT(K) 16309 T = Z(L) 16310 Z(L) = Z(K) 16311 Z(K) = T 16312 IF (K .LT. N) CALL DAXPY(N-K,T,A(K+1,K),1,Z(K+1),1) 16313 IF (DABS(Z(K)) .LE. 1.0D0) GO TO 130 16314 S = 1.0D0/DABS(Z(K)) 16315 CALL DSCAL(N,S,Z,1) 16316 YNORM = S*YNORM 16317 130 CONTINUE 16318 140 CONTINUE 16319 S = 1.0D0/DASUM(N,Z,1) 16320 CALL DSCAL(N,S,Z,1) 16321 YNORM = S*YNORM 16322C 16323C SOLVE U*Z = V 16324C 16325 DO 160 KB = 1, N 16326 K = N + 1 - KB 16327 IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 150 16328 S = DABS(A(K,K))/DABS(Z(K)) 16329 CALL DSCAL(N,S,Z,1) 16330 YNORM = S*YNORM 16331 150 CONTINUE 16332 IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) 16333 IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 16334 T = -Z(K) 16335 CALL DAXPY(K-1,T,A(1,K),1,Z(1),1) 16336 160 CONTINUE 16337C MAKE ZNORM = 1.0 16338 S = 1.0D0/DASUM(N,Z,1) 16339 CALL DSCAL(N,S,Z,1) 16340 YNORM = S*YNORM 16341C 16342 IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM 16343 IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0 16344 RETURN 16345 END 16346 SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO) 16347C***BEGIN PROLOGUE DGEFA 16348C***DATE WRITTEN 780814 (YYMMDD) 16349C***REVISION DATE 820801 (YYMMDD) 16350C***CATEGORY NO. D2A1 16351C***KEYWORDS DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX 16352C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) 16353C***PURPOSE Factors a double precision matrix by Gaussian elimination. 16354C***DESCRIPTION 16355C 16356C DGEFA factors a double precision matrix by Gaussian elimination. 16357C 16358C DGEFA is usually called by DGECO, but it can be called 16359C directly with a saving in time if RCOND is not needed. 16360C (Time for DGECO) = (1 + 9/N)*(Time for DGEFA) . 16361C 16362C On Entry 16363C 16364C A DOUBLE PRECISION(LDA, N) 16365C the matrix to be factored. 16366C 16367C LDA INTEGER 16368C the leading dimension of the array A . 16369C 16370C N INTEGER 16371C the order of the matrix A . 16372C 16373C On Return 16374C 16375C A an upper triangular matrix and the multipliers 16376C which were used to obtain it. 16377C The factorization can be written A = L*U where 16378C L is a product of permutation and unit lower 16379C triangular matrices and U is upper triangular. 16380C 16381C IPVT INTEGER(N) 16382C an integer vector of pivot indices. 16383C 16384C INFO INTEGER 16385C = 0 normal value. 16386C = K if U(K,K) .EQ. 0.0 . This is not an error 16387C condition for this subroutine, but it does 16388C indicate that DGESL or DGEDI will divide by zero 16389C if called. Use RCOND in DGECO for a reliable 16390C indication of singularity. 16391C 16392C LINPACK. This version dated 08/14/78 . 16393C Cleve Moler, University of New Mexico, Argonne National Lab. 16394C 16395C Subroutines and Functions 16396C 16397C BLAS DAXPY,DSCAL,IDAMAX 16398C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., 16399C *LINPACK USERS GUIDE*, SIAM, 1979. 16400C***ROUTINES CALLED DAXPY,DSCAL,IDAMAX 16401C***END PROLOGUE DGEFA 16402 INTEGER LDA,N,IPVT(1),INFO 16403 DOUBLE PRECISION A(LDA,1) 16404C 16405 DOUBLE PRECISION T 16406 INTEGER IDAMAX,J,K,KP1,L,NM1 16407C 16408C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING 16409C 16410C***FIRST EXECUTABLE STATEMENT DGEFA 16411 INFO = 0 16412 NM1 = N - 1 16413 IF (NM1 .LT. 1) GO TO 70 16414 DO 60 K = 1, NM1 16415 KP1 = K + 1 16416C 16417C FIND L = PIVOT INDEX 16418C 16419 L = IDAMAX(N-K+1,A(K,K),1) + K - 1 16420 IPVT(K) = L 16421C 16422C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED 16423C 16424 IF (A(L,K) .EQ. 0.0D0) GO TO 40 16425C 16426C INTERCHANGE IF NECESSARY 16427C 16428 IF (L .EQ. K) GO TO 10 16429 T = A(L,K) 16430 A(L,K) = A(K,K) 16431 A(K,K) = T 16432 10 CONTINUE 16433C 16434C COMPUTE MULTIPLIERS 16435C 16436 T = -1.0D0/A(K,K) 16437 CALL DSCAL(N-K,T,A(K+1,K),1) 16438C 16439C ROW ELIMINATION WITH COLUMN INDEXING 16440C 16441 DO 30 J = KP1, N 16442 T = A(L,J) 16443 IF (L .EQ. K) GO TO 20 16444 A(L,J) = A(K,J) 16445 A(K,J) = T 16446 20 CONTINUE 16447 CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) 16448 30 CONTINUE 16449 GO TO 50 16450 40 CONTINUE 16451 INFO = K 16452 50 CONTINUE 16453 60 CONTINUE 16454 70 CONTINUE 16455 IPVT(N) = N 16456 IF (A(N,N) .EQ. 0.0D0) INFO = N 16457 RETURN 16458 END 16459 SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB) 16460C***BEGIN PROLOGUE DGESL 16461C***DATE WRITTEN 780814 (YYMMDD) 16462C***REVISION DATE 820801 (YYMMDD) 16463C***CATEGORY NO. D2A1 16464C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE 16465C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) 16466C***PURPOSE Solves the double precision system A*X=B or TRANS(A)*X=B 16467C using the factors computed by DGECO or DGEFA. 16468C***DESCRIPTION 16469C 16470C DGESL solves the double precision system 16471C A * X = B or TRANS(A) * X = B 16472C using the factors computed by DGECO or DGEFA. 16473C 16474C On Entry 16475C 16476C A DOUBLE PRECISION(LDA, N) 16477C the output from DGECO or DGEFA. 16478C 16479C LDA INTEGER 16480C the leading dimension of the array A . 16481C 16482C N INTEGER 16483C the order of the matrix A . 16484C 16485C IPVT INTEGER(N) 16486C the pivot vector from DGECO or DGEFA. 16487C 16488C B DOUBLE PRECISION(N) 16489C the right hand side vector. 16490C 16491C JOB INTEGER 16492C = 0 to solve A*X = B , 16493C = nonzero to solve TRANS(A)*X = B where 16494C TRANS(A) is the transpose. 16495C 16496C On Return 16497C 16498C B the solution vector X . 16499C 16500C Error Condition 16501C 16502C A division by zero will occur if the input factor contains a 16503C zero on the diagonal. Technically this indicates singularity 16504C but it is often caused by improper arguments or improper 16505C setting of LDA . It will not occur if the subroutines are 16506C called correctly and if DGECO has set RCOND .GT. 0.0 16507C or DGEFA has set INFO .EQ. 0 . 16508C 16509C To compute INVERSE(A) * C where C is a matrix 16510C with P columns 16511C CALL DGECO(A,LDA,N,IPVT,RCOND,Z) 16512C IF (RCOND is too small) GO TO ... 16513C DO 10 J = 1, P 16514C CALL DGESL(A,LDA,N,IPVT,C(1,J),0) 16515C 10 CONTINUE 16516C 16517C LINPACK. This version dated 08/14/78 . 16518C Cleve Moler, University of New Mexico, Argonne National Lab. 16519C 16520C Subroutines and Functions 16521C 16522C BLAS DAXPY,DDOT 16523C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., 16524C *LINPACK USERS GUIDE*, SIAM, 1979. 16525C***ROUTINES CALLED DAXPY,DDOT 16526C***END PROLOGUE DGESL 16527 INTEGER LDA,N,IPVT(1),JOB 16528 DOUBLE PRECISION A(LDA,1),B(1) 16529C 16530 DOUBLE PRECISION DDOT,T 16531 INTEGER K,KB,L,NM1 16532C***FIRST EXECUTABLE STATEMENT DGESL 16533 NM1 = N - 1 16534 IF (JOB .NE. 0) GO TO 50 16535C 16536C JOB = 0 , SOLVE A * X = B 16537C FIRST SOLVE L*Y = B 16538C 16539 IF (NM1 .LT. 1) GO TO 30 16540 DO 20 K = 1, NM1 16541 L = IPVT(K) 16542 T = B(L) 16543 IF (L .EQ. K) GO TO 10 16544 B(L) = B(K) 16545 B(K) = T 16546 10 CONTINUE 16547 CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1) 16548 20 CONTINUE 16549 30 CONTINUE 16550C 16551C NOW SOLVE U*X = Y 16552C 16553 DO 40 KB = 1, N 16554 K = N + 1 - KB 16555 B(K) = B(K)/A(K,K) 16556 T = -B(K) 16557 CALL DAXPY(K-1,T,A(1,K),1,B(1),1) 16558 40 CONTINUE 16559 GO TO 100 16560 50 CONTINUE 16561C 16562C JOB = NONZERO, SOLVE TRANS(A) * X = B 16563C FIRST SOLVE TRANS(U)*Y = B 16564C 16565 DO 60 K = 1, N 16566 T = DDOT(K-1,A(1,K),1,B(1),1) 16567 B(K) = (B(K) - T)/A(K,K) 16568 60 CONTINUE 16569C 16570C NOW SOLVE TRANS(L)*X = Y 16571C 16572 IF (NM1 .LT. 1) GO TO 90 16573 DO 80 KB = 1, NM1 16574 K = N - KB 16575 B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1) 16576 L = IPVT(K) 16577 IF (L .EQ. K) GO TO 70 16578 T = B(L) 16579 B(L) = B(K) 16580 B(K) = T 16581 70 CONTINUE 16582 80 CONTINUE 16583 90 CONTINUE 16584 100 CONTINUE 16585 RETURN 16586 END 16587 SUBROUTINE DGEDI(A,LDA,N,IPVT,DET,WORK,JOB) 16588C***BEGIN PROLOGUE DGEDI 16589C***DATE WRITTEN 780814 (YYMMDD) 16590C***REVISION DATE 820801 (YYMMDD) 16591C***REVISION HISTORY (YYMMDD) 16592C 000330 Modified array declarations. (JEC) 16593C***CATEGORY NO. D3A1,D2A1 16594C***KEYWORDS DETERMINANT,DOUBLE PRECISION,FACTOR,INVERSE, 16595C LINEAR ALGEBRA,LINPACK,MATRIX 16596C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) 16597C***PURPOSE Computes the determinant and inverse of a matrix using 16598C factors computed by DGECO or DGEFA. 16599C***DESCRIPTION 16600C 16601C DGEDI computes the determinant and inverse of a matrix 16602C using the factors computed by DGECO or DGEFA. 16603C 16604C On Entry 16605C 16606C A DOUBLE PRECISION(LDA, N) 16607C the output from DGECO or DGEFA. 16608C 16609C LDA INTEGER 16610C the leading dimension of the array A . 16611C 16612C N INTEGER 16613C the order of the matrix A . 16614C 16615C IPVT INTEGER(N) 16616C the pivot vector from DGECO or DGEFA. 16617C 16618C WORK DOUBLE PRECISION(N) 16619C work vector. Contents destroyed. 16620C 16621C JOB INTEGER 16622C = 11 both determinant and inverse. 16623C = 01 inverse only. 16624C = 10 determinant only. 16625C 16626C On Return 16627C 16628C A inverse of original matrix if requested. 16629C Otherwise unchanged. 16630C 16631C DET DOUBLE PRECISION(2) 16632C determinant of original matrix if requested. 16633C Otherwise not referenced. 16634C Determinant = DET(1) * 10.0**DET(2) 16635C with 1.0 .LE. DABS(DET(1)) .LT. 10.0 16636C or DET(1) .EQ. 0.0 . 16637C 16638C Error Condition 16639C 16640C A division by zero will occur if the input factor contains 16641C a zero on the diagonal and the inverse is requested. 16642C It will not occur if the subroutines are called correctly 16643C and if DGECO has set RCOND .GT. 0.0 or DGEFA has set 16644C INFO .EQ. 0 . 16645C 16646C LINPACK. This version dated 08/14/78 . 16647C Cleve Moler, University of New Mexico, Argonne National Lab. 16648C 16649C Subroutines and Functions 16650C 16651C BLAS DAXPY,DSCAL,DSWAP 16652C Fortran DABS,MOD 16653C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., 16654C *LINPACK USERS GUIDE*, SIAM, 1979. 16655C***ROUTINES CALLED DAXPY,DSCAL,DSWAP 16656C***END PROLOGUE DGEDI 16657 INTEGER LDA,N,IPVT(*),JOB 16658 DOUBLE PRECISION A(LDA,*),DET(2),WORK(*) 16659C 16660 DOUBLE PRECISION T 16661 DOUBLE PRECISION TEN 16662 INTEGER I,J,K,KB,KP1,L,NM1 16663C 16664C COMPUTE DETERMINANT 16665C 16666C***FIRST EXECUTABLE STATEMENT DGEDI 16667 IF (JOB/10 .EQ. 0) GO TO 70 16668 DET(1) = 1.0D0 16669 DET(2) = 0.0D0 16670 TEN = 10.0D0 16671 DO 50 I = 1, N 16672 IF (IPVT(I) .NE. I) DET(1) = -DET(1) 16673 DET(1) = A(I,I)*DET(1) 16674C ...EXIT 16675 IF (DET(1) .EQ. 0.0D0) GO TO 60 16676 10 IF (DABS(DET(1)) .GE. 1.0D0) GO TO 20 16677 DET(1) = TEN*DET(1) 16678 DET(2) = DET(2) - 1.0D0 16679 GO TO 10 16680 20 CONTINUE 16681 30 IF (DABS(DET(1)) .LT. TEN) GO TO 40 16682 DET(1) = DET(1)/TEN 16683 DET(2) = DET(2) + 1.0D0 16684 GO TO 30 16685 40 CONTINUE 16686 50 CONTINUE 16687 60 CONTINUE 16688 70 CONTINUE 16689C 16690C COMPUTE INVERSE(U) 16691C 16692 IF (MOD(JOB,10) .EQ. 0) GO TO 150 16693 DO 100 K = 1, N 16694 A(K,K) = 1.0D0/A(K,K) 16695 T = -A(K,K) 16696 CALL DSCAL(K-1,T,A(1,K),1) 16697 KP1 = K + 1 16698 IF (N .LT. KP1) GO TO 90 16699 DO 80 J = KP1, N 16700 T = A(K,J) 16701 A(K,J) = 0.0D0 16702 CALL DAXPY(K,T,A(1,K),1,A(1,J),1) 16703 80 CONTINUE 16704 90 CONTINUE 16705 100 CONTINUE 16706C 16707C FORM INVERSE(U)*INVERSE(L) 16708C 16709 NM1 = N - 1 16710 IF (NM1 .LT. 1) GO TO 140 16711 DO 130 KB = 1, NM1 16712 K = N - KB 16713 KP1 = K + 1 16714 DO 110 I = KP1, N 16715 WORK(I) = A(I,K) 16716 A(I,K) = 0.0D0 16717 110 CONTINUE 16718 DO 120 J = KP1, N 16719 T = WORK(J) 16720 CALL DAXPY(N,T,A(1,J),1,A(1,K),1) 16721 120 CONTINUE 16722 L = IPVT(K) 16723 IF (L .NE. K) CALL DSWAP(N,A(1,K),1,A(1,L),1) 16724 130 CONTINUE 16725 140 CONTINUE 16726 150 CONTINUE 16727 RETURN 16728 END 16729 SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, 16730 $ BETA, C, LDC , 16731 $ IERROR) 16732* .. Scalar Arguments .. 16733 CHARACTER*1 TRANSA, TRANSB 16734 CHARACTER*4 IERROR 16735 INTEGER M, N, K, LDA, LDB, LDC 16736 DOUBLE PRECISION ALPHA, BETA 16737* .. Array Arguments .. 16738 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) 16739* .. 16740C 16741 INCLUDE 'DPCOP2.INC' 16742C 16743* 16744* Purpose 16745* ======= 16746* 16747* DGEMM performs one of the matrix-matrix operations 16748* 16749* C := alpha*op( A )*op( B ) + beta*C, 16750* 16751* where op( X ) is one of 16752* 16753* op( X ) = X or op( X ) = X', 16754* 16755* alpha and beta are scalars, and A, B and C are matrices, with op( A ) 16756* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. 16757* 16758* Parameters 16759* ========== 16760* 16761* TRANSA - CHARACTER*1. 16762* On entry, TRANSA specifies the form of op( A ) to be used in 16763* the matrix multiplication as follows: 16764* 16765* TRANSA = 'N' or 'n', op( A ) = A. 16766* 16767* TRANSA = 'T' or 't', op( A ) = A'. 16768* 16769* TRANSA = 'C' or 'c', op( A ) = A'. 16770* 16771* Unchanged on exit. 16772* 16773* TRANSB - CHARACTER*1. 16774* On entry, TRANSB specifies the form of op( B ) to be used in 16775* the matrix multiplication as follows: 16776* 16777* TRANSB = 'N' or 'n', op( B ) = B. 16778* 16779* TRANSB = 'T' or 't', op( B ) = B'. 16780* 16781* TRANSB = 'C' or 'c', op( B ) = B'. 16782* 16783* Unchanged on exit. 16784* 16785* M - INTEGER. 16786* On entry, M specifies the number of rows of the matrix 16787* op( A ) and of the matrix C. M must be at least zero. 16788* Unchanged on exit. 16789* 16790* N - INTEGER. 16791* On entry, N specifies the number of columns of the matrix 16792* op( B ) and the number of columns of the matrix C. N must be 16793* at least zero. 16794* Unchanged on exit. 16795* 16796* K - INTEGER. 16797* On entry, K specifies the number of columns of the matrix 16798* op( A ) and the number of rows of the matrix op( B ). K must 16799* be at least zero. 16800* Unchanged on exit. 16801* 16802* ALPHA - DOUBLE PRECISION. 16803* On entry, ALPHA specifies the scalar alpha. 16804* Unchanged on exit. 16805* 16806* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is 16807* k when TRANSA = 'N' or 'n', and is m otherwise. 16808* Before entry with TRANSA = 'N' or 'n', the leading m by k 16809* part of the array A must contain the matrix A, otherwise 16810* the leading k by m part of the array A must contain the 16811* matrix A. 16812* Unchanged on exit. 16813* 16814* LDA - INTEGER. 16815* On entry, LDA specifies the first dimension of A as declared 16816* in the calling (sub) program. When TRANSA = 'N' or 'n' then 16817* LDA must be at least max( 1, m ), otherwise LDA must be at 16818* least max( 1, k ). 16819* Unchanged on exit. 16820* 16821* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is 16822* n when TRANSB = 'N' or 'n', and is k otherwise. 16823* Before entry with TRANSB = 'N' or 'n', the leading k by n 16824* part of the array B must contain the matrix B, otherwise 16825* the leading n by k part of the array B must contain the 16826* matrix B. 16827* Unchanged on exit. 16828* 16829* LDB - INTEGER. 16830* On entry, LDB specifies the first dimension of B as declared 16831* in the calling (sub) program. When TRANSB = 'N' or 'n' then 16832* LDB must be at least max( 1, k ), otherwise LDB must be at 16833* least max( 1, n ). 16834* Unchanged on exit. 16835* 16836* BETA - DOUBLE PRECISION. 16837* On entry, BETA specifies the scalar beta. When BETA is 16838* supplied as zero then C need not be set on input. 16839* Unchanged on exit. 16840* 16841* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). 16842* Before entry, the leading m by n part of the array C must 16843* contain the matrix C, except when beta is zero, in which 16844* case C need not be set on entry. 16845* On exit, the array C is overwritten by the m by n matrix 16846* ( alpha*op( A )*op( B ) + beta*C ). 16847* 16848* LDC - INTEGER. 16849* On entry, LDC specifies the first dimension of C as declared 16850* in the calling (sub) program. LDC must be at least 16851* max( 1, m ). 16852* Unchanged on exit. 16853* 16854* 16855* Level 3 Blas routine. 16856* 16857* -- Written on 8-February-1989. 16858* Jack Dongarra, Argonne National Laboratory. 16859* Iain Duff, AERE Harwell. 16860* Jeremy Du Croz, Numerical Algorithms Group Ltd. 16861* Sven Hammarling, Numerical Algorithms Group Ltd. 16862* 16863* Slight modifications made by Alan Heckert 8/97 to 16864* incorporate into Dataplot (no numerical modifications, 16865* just error handling and printing) 16866* 16867* .. External Functions .. 16868 LOGICAL LSAME 16869 EXTERNAL LSAME 16870* .. External Subroutines .. 16871CCCCC EXTERNAL XERBLA 16872* .. Intrinsic Functions .. 16873 INTRINSIC MAX 16874* .. Local Scalars .. 16875 LOGICAL NOTA, NOTB 16876 INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB 16877 DOUBLE PRECISION TEMP 16878* .. Parameters .. 16879 DOUBLE PRECISION ONE , ZERO 16880 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 16881* .. 16882* .. Executable Statements .. 16883* 16884* Set NOTA and NOTB as true if A and B respectively are not 16885* transposed and set NROWA, NCOLA and NROWB as the number of rows 16886* and columns of A and the number of rows of B respectively. 16887* 16888 IERROR='NO' 16889 NOTA = LSAME( TRANSA, 'N' ) 16890 NOTB = LSAME( TRANSB, 'N' ) 16891 IF( NOTA )THEN 16892 NROWA = M 16893 NCOLA = K 16894 ELSE 16895 NROWA = K 16896 NCOLA = M 16897 END IF 16898 IF( NOTB )THEN 16899 NROWB = K 16900 ELSE 16901 NROWB = N 16902 END IF 16903* 16904* Test the input parameters. 16905* 16906 INFO = 0 16907 IF( ( .NOT.NOTA ).AND. 16908 $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. 16909 $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN 16910 INFO = 1 16911 ELSE IF( ( .NOT.NOTB ).AND. 16912 $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. 16913 $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN 16914 INFO = 2 16915 ELSE IF( M .LT.0 )THEN 16916 INFO = 3 16917 ELSE IF( N .LT.0 )THEN 16918 INFO = 4 16919 ELSE IF( K .LT.0 )THEN 16920 INFO = 5 16921 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN 16922 INFO = 8 16923 ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN 16924 INFO = 10 16925 ELSE IF( LDC.LT.MAX( 1, M ) )THEN 16926 INFO = 13 16927 END IF 16928 IF( INFO.NE.0 )THEN 16929CCCCC CALL XERBLA( 'DGEMM ', INFO ) 16930 WRITE(ICOUT,1001) 16931 CALL DPWRST('XXX','BUG ') 16932 IERROR='YES' 16933 RETURN 16934 END IF 16935 1001 FORMAT('***** RECIPE ERROR: INTERNAL ERROR FROM DGEMM, INVALID', 16936 1' ARGUMENTS.') 16937* 16938* Quick return if possible. 16939* 16940 IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. 16941 $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) 16942 $ RETURN 16943* 16944* And if alpha.eq.zero. 16945* 16946 IF( ALPHA.EQ.ZERO )THEN 16947 IF( BETA.EQ.ZERO )THEN 16948 DO 20, J = 1, N 16949 DO 10, I = 1, M 16950 C( I, J ) = ZERO 16951 10 CONTINUE 16952 20 CONTINUE 16953 ELSE 16954 DO 40, J = 1, N 16955 DO 30, I = 1, M 16956 C( I, J ) = BETA*C( I, J ) 16957 30 CONTINUE 16958 40 CONTINUE 16959 END IF 16960 RETURN 16961 END IF 16962* 16963* Start the operations. 16964* 16965 IF( NOTB )THEN 16966 IF( NOTA )THEN 16967* 16968* Form C := alpha*A*B + beta*C. 16969* 16970 DO 90, J = 1, N 16971 IF( BETA.EQ.ZERO )THEN 16972 DO 50, I = 1, M 16973 C( I, J ) = ZERO 16974 50 CONTINUE 16975 ELSE IF( BETA.NE.ONE )THEN 16976 DO 60, I = 1, M 16977 C( I, J ) = BETA*C( I, J ) 16978 60 CONTINUE 16979 END IF 16980 DO 80, L = 1, K 16981 IF( B( L, J ).NE.ZERO )THEN 16982 TEMP = ALPHA*B( L, J ) 16983 DO 70, I = 1, M 16984 C( I, J ) = C( I, J ) + TEMP*A( I, L ) 16985 70 CONTINUE 16986 END IF 16987 80 CONTINUE 16988 90 CONTINUE 16989 ELSE 16990* 16991* Form C := alpha*A'*B + beta*C 16992* 16993 DO 120, J = 1, N 16994 DO 110, I = 1, M 16995 TEMP = ZERO 16996 DO 100, L = 1, K 16997 TEMP = TEMP + A( L, I )*B( L, J ) 16998 100 CONTINUE 16999 IF( BETA.EQ.ZERO )THEN 17000 C( I, J ) = ALPHA*TEMP 17001 ELSE 17002 C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) 17003 END IF 17004 110 CONTINUE 17005 120 CONTINUE 17006 END IF 17007 ELSE 17008 IF( NOTA )THEN 17009* 17010* Form C := alpha*A*B' + beta*C 17011* 17012 DO 170, J = 1, N 17013 IF( BETA.EQ.ZERO )THEN 17014 DO 130, I = 1, M 17015 C( I, J ) = ZERO 17016 130 CONTINUE 17017 ELSE IF( BETA.NE.ONE )THEN 17018 DO 140, I = 1, M 17019 C( I, J ) = BETA*C( I, J ) 17020 140 CONTINUE 17021 END IF 17022 DO 160, L = 1, K 17023 IF( B( J, L ).NE.ZERO )THEN 17024 TEMP = ALPHA*B( J, L ) 17025 DO 150, I = 1, M 17026 C( I, J ) = C( I, J ) + TEMP*A( I, L ) 17027 150 CONTINUE 17028 END IF 17029 160 CONTINUE 17030 170 CONTINUE 17031 ELSE 17032* 17033* Form C := alpha*A'*B' + beta*C 17034* 17035 DO 200, J = 1, N 17036 DO 190, I = 1, M 17037 TEMP = ZERO 17038 DO 180, L = 1, K 17039 TEMP = TEMP + A( L, I )*B( J, L ) 17040 180 CONTINUE 17041 IF( BETA.EQ.ZERO )THEN 17042 C( I, J ) = ALPHA*TEMP 17043 ELSE 17044 C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) 17045 END IF 17046 190 CONTINUE 17047 200 CONTINUE 17048 END IF 17049 END IF 17050* 17051 RETURN 17052* 17053* End of DGEMM . 17054* 17055 END 17056 SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, 17057 $ BETA, Y, INCY, 17058 $ IERROR ) 17059* .. Scalar Arguments .. 17060 DOUBLE PRECISION ALPHA, BETA 17061 INTEGER INCX, INCY, LDA, M, N 17062 CHARACTER*1 TRANS 17063 CHARACTER*4 IERROR 17064* .. Array Arguments .. 17065 DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) 17066* .. 17067* 17068* Purpose 17069* ======= 17070* 17071* DGEMV performs one of the matrix-vector operations 17072* 17073* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, 17074* 17075* where alpha and beta are scalars, x and y are vectors and A is an 17076* m by n matrix. 17077* 17078* Parameters 17079* ========== 17080* 17081* TRANS - CHARACTER*1. 17082* On entry, TRANS specifies the operation to be performed as 17083* follows: 17084* 17085* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. 17086* 17087* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. 17088* 17089* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. 17090* 17091* Unchanged on exit. 17092* 17093* M - INTEGER. 17094* On entry, M specifies the number of rows of the matrix A. 17095* M must be at least zero. 17096* Unchanged on exit. 17097* 17098* N - INTEGER. 17099* On entry, N specifies the number of columns of the matrix A. 17100* N must be at least zero. 17101* Unchanged on exit. 17102* 17103* ALPHA - DOUBLE PRECISION. 17104* On entry, ALPHA specifies the scalar alpha. 17105* Unchanged on exit. 17106* 17107* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). 17108* Before entry, the leading m by n part of the array A must 17109* contain the matrix of coefficients. 17110* Unchanged on exit. 17111* 17112* LDA - INTEGER. 17113* On entry, LDA specifies the first dimension of A as declared 17114* in the calling (sub) program. LDA must be at least 17115* max( 1, m ). 17116* Unchanged on exit. 17117* 17118* X - DOUBLE PRECISION array of DIMENSION at least 17119* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' 17120* and at least 17121* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. 17122* Before entry, the incremented array X must contain the 17123* vector x. 17124* Unchanged on exit. 17125* 17126* INCX - INTEGER. 17127* On entry, INCX specifies the increment for the elements of 17128* X. INCX must not be zero. 17129* Unchanged on exit. 17130* 17131* BETA - DOUBLE PRECISION. 17132* On entry, BETA specifies the scalar beta. When BETA is 17133* supplied as zero then Y need not be set on input. 17134* Unchanged on exit. 17135* 17136* Y - DOUBLE PRECISION array of DIMENSION at least 17137* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' 17138* and at least 17139* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. 17140* Before entry with BETA non-zero, the incremented array Y 17141* must contain the vector y. On exit, Y is overwritten by the 17142* updated vector y. 17143* 17144* INCY - INTEGER. 17145* On entry, INCY specifies the increment for the elements of 17146* Y. INCY must not be zero. 17147* Unchanged on exit. 17148* 17149* 17150* Level 2 Blas routine. 17151* 17152* -- Written on 22-October-1986. 17153* Jack Dongarra, Argonne National Lab. 17154* Jeremy Du Croz, Nag Central Office. 17155* Sven Hammarling, Nag Central Office. 17156* Richard Hanson, Sandia National Labs. 17157* 17158* Slight modifications 8/97 by Alan Heckert to incorporate 17159* into Dataplot. No numerical modifications, just for 17160* error handling and printing. 17161* 17162* .. Parameters .. 17163C 17164 INCLUDE 'DPCOP2.INC' 17165C 17166 DOUBLE PRECISION ONE , ZERO 17167 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 17168* .. Local Scalars .. 17169 DOUBLE PRECISION TEMP 17170 INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY 17171* .. External Functions .. 17172 LOGICAL LSAME 17173 EXTERNAL LSAME 17174* .. External Subroutines .. 17175CCCCC EXTERNAL XERBLA 17176* .. Intrinsic Functions .. 17177 INTRINSIC MAX 17178* .. 17179* .. Executable Statements .. 17180* 17181* Test the input parameters. 17182* 17183 IERROR='NO' 17184 INFO = 0 17185 IF ( .NOT.LSAME( TRANS, 'N' ).AND. 17186 $ .NOT.LSAME( TRANS, 'T' ).AND. 17187 $ .NOT.LSAME( TRANS, 'C' ) )THEN 17188 INFO = 1 17189 ELSE IF( M.LT.0 )THEN 17190 INFO = 2 17191 ELSE IF( N.LT.0 )THEN 17192 INFO = 3 17193 ELSE IF( LDA.LT.MAX( 1, M ) )THEN 17194 INFO = 6 17195 ELSE IF( INCX.EQ.0 )THEN 17196 INFO = 8 17197 ELSE IF( INCY.EQ.0 )THEN 17198 INFO = 11 17199 END IF 17200 IF( INFO.NE.0 )THEN 17201CCCCC CALL XERBLA( 'DGEMV ', INFO ) 17202 WRITE(ICOUT,1001) 17203 CALL DPWRST('XXX','BUG ') 17204 IERROR='YES' 17205 RETURN 17206 END IF 17207 1001 FORMAT('***** RECIPE ERROR: INTERNAL ERROR FROM DGEMV, INVALID', 17208 1' ARGUMENTS.') 17209* 17210* Quick return if possible. 17211* 17212 IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. 17213 $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) 17214 $ RETURN 17215* 17216* Set LENX and LENY, the lengths of the vectors x and y, and set 17217* up the start points in X and Y. 17218* 17219 IF( LSAME( TRANS, 'N' ) )THEN 17220 LENX = N 17221 LENY = M 17222 ELSE 17223 LENX = M 17224 LENY = N 17225 END IF 17226 IF( INCX.GT.0 )THEN 17227 KX = 1 17228 ELSE 17229 KX = 1 - ( LENX - 1 )*INCX 17230 END IF 17231 IF( INCY.GT.0 )THEN 17232 KY = 1 17233 ELSE 17234 KY = 1 - ( LENY - 1 )*INCY 17235 END IF 17236* 17237* Start the operations. In this version the elements of A are 17238* accessed sequentially with one pass through A. 17239* 17240* First form y := beta*y. 17241* 17242 IF( BETA.NE.ONE )THEN 17243 IF( INCY.EQ.1 )THEN 17244 IF( BETA.EQ.ZERO )THEN 17245 DO 10, I = 1, LENY 17246 Y( I ) = ZERO 17247 10 CONTINUE 17248 ELSE 17249 DO 20, I = 1, LENY 17250 Y( I ) = BETA*Y( I ) 17251 20 CONTINUE 17252 END IF 17253 ELSE 17254 IY = KY 17255 IF( BETA.EQ.ZERO )THEN 17256 DO 30, I = 1, LENY 17257 Y( IY ) = ZERO 17258 IY = IY + INCY 17259 30 CONTINUE 17260 ELSE 17261 DO 40, I = 1, LENY 17262 Y( IY ) = BETA*Y( IY ) 17263 IY = IY + INCY 17264 40 CONTINUE 17265 END IF 17266 END IF 17267 END IF 17268 IF( ALPHA.EQ.ZERO ) 17269 $ RETURN 17270 IF( LSAME( TRANS, 'N' ) )THEN 17271* 17272* Form y := alpha*A*x + y. 17273* 17274 JX = KX 17275 IF( INCY.EQ.1 )THEN 17276 DO 60, J = 1, N 17277 IF( X( JX ).NE.ZERO )THEN 17278 TEMP = ALPHA*X( JX ) 17279 DO 50, I = 1, M 17280 Y( I ) = Y( I ) + TEMP*A( I, J ) 17281 50 CONTINUE 17282 END IF 17283 JX = JX + INCX 17284 60 CONTINUE 17285 ELSE 17286 DO 80, J = 1, N 17287 IF( X( JX ).NE.ZERO )THEN 17288 TEMP = ALPHA*X( JX ) 17289 IY = KY 17290 DO 70, I = 1, M 17291 Y( IY ) = Y( IY ) + TEMP*A( I, J ) 17292 IY = IY + INCY 17293 70 CONTINUE 17294 END IF 17295 JX = JX + INCX 17296 80 CONTINUE 17297 END IF 17298 ELSE 17299* 17300* Form y := alpha*A'*x + y. 17301* 17302 JY = KY 17303 IF( INCX.EQ.1 )THEN 17304 DO 100, J = 1, N 17305 TEMP = ZERO 17306 DO 90, I = 1, M 17307 TEMP = TEMP + A( I, J )*X( I ) 17308 90 CONTINUE 17309 Y( JY ) = Y( JY ) + ALPHA*TEMP 17310 JY = JY + INCY 17311 100 CONTINUE 17312 ELSE 17313 DO 120, J = 1, N 17314 TEMP = ZERO 17315 IX = KX 17316 DO 110, I = 1, M 17317 TEMP = TEMP + A( I, J )*X( IX ) 17318 IX = IX + INCX 17319 110 CONTINUE 17320 Y( JY ) = Y( JY ) + ALPHA*TEMP 17321 JY = JY + INCY 17322 120 CONTINUE 17323 END IF 17324 END IF 17325* 17326 RETURN 17327* 17328* End of DGEMV . 17329* 17330 END 17331 SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA, IERROR ) 17332* .. Scalar Arguments .. 17333 DOUBLE PRECISION ALPHA 17334 INTEGER INCX, INCY, LDA, M, N 17335* .. Array Arguments .. 17336 DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) 17337C 17338 CHARACTER*4 IERROR 17339 INCLUDE 'DPCOP2.INC' 17340C 17341* .. 17342* 17343* Purpose 17344* ======= 17345* 17346* DGER performs the rank 1 operation 17347* 17348* A := alpha*x*y' + A, 17349* 17350* where alpha is a scalar, x is an m element vector, y is an n element 17351* vector and A is an m by n matrix. 17352* 17353* Parameters 17354* ========== 17355* 17356* M - INTEGER. 17357* On entry, M specifies the number of rows of the matrix A. 17358* M must be at least zero. 17359* Unchanged on exit. 17360* 17361* N - INTEGER. 17362* On entry, N specifies the number of columns of the matrix A. 17363* N must be at least zero. 17364* Unchanged on exit. 17365* 17366* ALPHA - DOUBLE PRECISION. 17367* On entry, ALPHA specifies the scalar alpha. 17368* Unchanged on exit. 17369* 17370* X - DOUBLE PRECISION array of dimension at least 17371* ( 1 + ( m - 1 )*abs( INCX ) ). 17372* Before entry, the incremented array X must contain the m 17373* element vector x. 17374* Unchanged on exit. 17375* 17376* INCX - INTEGER. 17377* On entry, INCX specifies the increment for the elements of 17378* X. INCX must not be zero. 17379* Unchanged on exit. 17380* 17381* Y - DOUBLE PRECISION array of dimension at least 17382* ( 1 + ( n - 1 )*abs( INCY ) ). 17383* Before entry, the incremented array Y must contain the n 17384* element vector y. 17385* Unchanged on exit. 17386* 17387* INCY - INTEGER. 17388* On entry, INCY specifies the increment for the elements of 17389* Y. INCY must not be zero. 17390* Unchanged on exit. 17391* 17392* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). 17393* Before entry, the leading m by n part of the array A must 17394* contain the matrix of coefficients. On exit, A is 17395* overwritten by the updated matrix. 17396* 17397* LDA - INTEGER. 17398* On entry, LDA specifies the first dimension of A as declared 17399* in the calling (sub) program. LDA must be at least 17400* max( 1, m ). 17401* Unchanged on exit. 17402* 17403* 17404* Level 2 Blas routine. 17405* 17406* -- Written on 22-October-1986. 17407* Jack Dongarra, Argonne National Lab. 17408* Jeremy Du Croz, Nag Central Office. 17409* Sven Hammarling, Nag Central Office. 17410* Richard Hanson, Sandia National Labs. 17411* 17412* Minor modifications 8/97 by Alan Heckert to incorporate 17413* into Dataplot. No numerical modifications. Just 17414* error handling and printing. 17415* 17416* .. Parameters .. 17417 DOUBLE PRECISION ZERO 17418 PARAMETER ( ZERO = 0.0D+0 ) 17419* .. Local Scalars .. 17420 DOUBLE PRECISION TEMP 17421 INTEGER I, INFO, IX, J, JY, KX 17422* .. External Subroutines .. 17423CCCCC EXTERNAL XERBLA 17424* .. Intrinsic Functions .. 17425 INTRINSIC MAX 17426* .. 17427* .. Executable Statements .. 17428* 17429* Test the input parameters. 17430* 17431 IERROR='NO' 17432 INFO = 0 17433 IF ( M.LT.0 )THEN 17434 INFO = 1 17435 ELSE IF( N.LT.0 )THEN 17436 INFO = 2 17437 ELSE IF( INCX.EQ.0 )THEN 17438 INFO = 5 17439 ELSE IF( INCY.EQ.0 )THEN 17440 INFO = 7 17441 ELSE IF( LDA.LT.MAX( 1, M ) )THEN 17442 INFO = 9 17443 END IF 17444 IF( INFO.NE.0 )THEN 17445CCCCC CALL XERBLA( 'DGER ', INFO ) 17446 WRITE(ICOUT,1001) 17447 CALL DPWRST('XXX','BUG ') 17448 IERROR='YES' 17449 RETURN 17450 END IF 17451 1001 FORMAT('***** RECIPE ERROR: INTERNAL ERROR FROM DGER, INVALID', 17452 1' ARGUMENTS.') 17453* 17454* Quick return if possible. 17455* 17456 IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) 17457 $ RETURN 17458* 17459* Start the operations. In this version the elements of A are 17460* accessed sequentially with one pass through A. 17461* 17462 IF( INCY.GT.0 )THEN 17463 JY = 1 17464 ELSE 17465 JY = 1 - ( N - 1 )*INCY 17466 END IF 17467 IF( INCX.EQ.1 )THEN 17468 DO 20, J = 1, N 17469 IF( Y( JY ).NE.ZERO )THEN 17470 TEMP = ALPHA*Y( JY ) 17471 DO 10, I = 1, M 17472 A( I, J ) = A( I, J ) + X( I )*TEMP 17473 10 CONTINUE 17474 END IF 17475 JY = JY + INCY 17476 20 CONTINUE 17477 ELSE 17478 IF( INCX.GT.0 )THEN 17479 KX = 1 17480 ELSE 17481 KX = 1 - ( M - 1 )*INCX 17482 END IF 17483 DO 40, J = 1, N 17484 IF( Y( JY ).NE.ZERO )THEN 17485 TEMP = ALPHA*Y( JY ) 17486 IX = KX 17487 DO 30, I = 1, M 17488 A( I, J ) = A( I, J ) + X( IX )*TEMP 17489 IX = IX + INCX 17490 30 CONTINUE 17491 END IF 17492 JY = JY + INCY 17493 40 CONTINUE 17494 END IF 17495* 17496 RETURN 17497* 17498* End of DGER . 17499* 17500 END 17501 SUBROUTINE DGSL1(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 17502 1IBUGD2,IFOUND,IERROR) 17503C 17504C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 17505C FOR GREEK SIMPLEX LOWER CASE (PART 1). 17506C WRITTEN BY--JAMES J. FILLIBEN 17507C STATISTICAL ENGINEERING DIVISION 17508C INFORMATION TECHNOLOGY LABORATORY 17509C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 17510C GAITHERSBURG, MD 20899-8980 17511C PHONE--301-921-3651 17512C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 17513C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 17514C LANGUAGE--ANSI FORTRAN (1977) 17515C VERSION NUMBER--87/4 17516C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 17517C UPDATED --MAY 1982. 17518C UPDATED --MARCH 1987. 17519C 17520C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 17521C 17522 CHARACTER*4 IOP 17523 CHARACTER*4 IBUGD2 17524 CHARACTER*4 IFOUND 17525 CHARACTER*4 IERROR 17526C 17527 CHARACTER*4 IOPERA 17528C 17529C--------------------------------------------------------------------- 17530C 17531 DIMENSION IOP(*) 17532 DIMENSION X(*) 17533 DIMENSION Y(*) 17534C 17535 DIMENSION IOPERA(300) 17536 DIMENSION IX(300) 17537 DIMENSION IY(300) 17538C 17539 DIMENSION IXMIND(30) 17540 DIMENSION IXMAXD(30) 17541 DIMENSION IXDELD(30) 17542 DIMENSION ISTARD(30) 17543 DIMENSION NUMCOO(30) 17544C 17545C--------------------------------------------------------------------- 17546C 17547 INCLUDE 'DPCOP2.INC' 17548C 17549C-----DATA STATEMENTS------------------------------------------------- 17550C 17551C DEFINE CHARACTER 627--LOWER CASE ALPH 17552C 17553 DATA IOPERA( 1),IX( 1),IY( 1)/'MOVE', -1, 5/ 17554 DATA IOPERA( 2),IX( 2),IY( 2)/'DRAW', -3, 4/ 17555 DATA IOPERA( 3),IX( 3),IY( 3)/'DRAW', -5, 2/ 17556 DATA IOPERA( 4),IX( 4),IY( 4)/'DRAW', -6, 0/ 17557 DATA IOPERA( 5),IX( 5),IY( 5)/'DRAW', -7, -3/ 17558 DATA IOPERA( 6),IX( 6),IY( 6)/'DRAW', -7, -6/ 17559 DATA IOPERA( 7),IX( 7),IY( 7)/'DRAW', -6, -8/ 17560 DATA IOPERA( 8),IX( 8),IY( 8)/'DRAW', -4, -9/ 17561 DATA IOPERA( 9),IX( 9),IY( 9)/'DRAW', -2, -9/ 17562 DATA IOPERA( 10),IX( 10),IY( 10)/'DRAW', 0, -8/ 17563 DATA IOPERA( 11),IX( 11),IY( 11)/'DRAW', 3, -5/ 17564 DATA IOPERA( 12),IX( 12),IY( 12)/'DRAW', 5, -2/ 17565 DATA IOPERA( 13),IX( 13),IY( 13)/'DRAW', 7, 2/ 17566 DATA IOPERA( 14),IX( 14),IY( 14)/'DRAW', 8, 5/ 17567 DATA IOPERA( 15),IX( 15),IY( 15)/'MOVE', -1, 5/ 17568 DATA IOPERA( 16),IX( 16),IY( 16)/'DRAW', 1, 5/ 17569 DATA IOPERA( 17),IX( 17),IY( 17)/'DRAW', 2, 4/ 17570 DATA IOPERA( 18),IX( 18),IY( 18)/'DRAW', 3, 2/ 17571 DATA IOPERA( 19),IX( 19),IY( 19)/'DRAW', 5, -6/ 17572 DATA IOPERA( 20),IX( 20),IY( 20)/'DRAW', 6, -8/ 17573 DATA IOPERA( 21),IX( 21),IY( 21)/'DRAW', 7, -9/ 17574 DATA IOPERA( 22),IX( 22),IY( 22)/'DRAW', 8, -9/ 17575C 17576 DATA IXMIND( 1)/ -10/ 17577 DATA IXMAXD( 1)/ 11/ 17578 DATA IXDELD( 1)/ 21/ 17579 DATA ISTARD( 1)/ 1/ 17580 DATA NUMCOO( 1)/ 22/ 17581C 17582C DEFINE CHARACTER 628--LOWER CASE BETA 17583C 17584 DATA IOPERA( 23),IX( 23),IY( 23)/'MOVE', 3, 12/ 17585 DATA IOPERA( 24),IX( 24),IY( 24)/'DRAW', 1, 11/ 17586 DATA IOPERA( 25),IX( 25),IY( 25)/'DRAW', -1, 9/ 17587 DATA IOPERA( 26),IX( 26),IY( 26)/'DRAW', -3, 5/ 17588 DATA IOPERA( 27),IX( 27),IY( 27)/'DRAW', -4, 2/ 17589 DATA IOPERA( 28),IX( 28),IY( 28)/'DRAW', -5, -2/ 17590 DATA IOPERA( 29),IX( 29),IY( 29)/'DRAW', -6, -8/ 17591 DATA IOPERA( 30),IX( 30),IY( 30)/'DRAW', -7, -16/ 17592 DATA IOPERA( 31),IX( 31),IY( 31)/'MOVE', 3, 12/ 17593 DATA IOPERA( 32),IX( 32),IY( 32)/'DRAW', 5, 12/ 17594 DATA IOPERA( 33),IX( 33),IY( 33)/'DRAW', 7, 10/ 17595 DATA IOPERA( 34),IX( 34),IY( 34)/'DRAW', 7, 7/ 17596 DATA IOPERA( 35),IX( 35),IY( 35)/'DRAW', 6, 5/ 17597 DATA IOPERA( 36),IX( 36),IY( 36)/'DRAW', 5, 4/ 17598 DATA IOPERA( 37),IX( 37),IY( 37)/'DRAW', 3, 3/ 17599 DATA IOPERA( 38),IX( 38),IY( 38)/'DRAW', 0, 3/ 17600 DATA IOPERA( 39),IX( 39),IY( 39)/'MOVE', 0, 3/ 17601 DATA IOPERA( 40),IX( 40),IY( 40)/'DRAW', 2, 2/ 17602 DATA IOPERA( 41),IX( 41),IY( 41)/'DRAW', 4, 0/ 17603 DATA IOPERA( 42),IX( 42),IY( 42)/'DRAW', 5, -2/ 17604 DATA IOPERA( 43),IX( 43),IY( 43)/'DRAW', 5, -5/ 17605 DATA IOPERA( 44),IX( 44),IY( 44)/'DRAW', 4, -7/ 17606 DATA IOPERA( 45),IX( 45),IY( 45)/'DRAW', 3, -8/ 17607 DATA IOPERA( 46),IX( 46),IY( 46)/'DRAW', 1, -9/ 17608 DATA IOPERA( 47),IX( 47),IY( 47)/'DRAW', -1, -9/ 17609 DATA IOPERA( 48),IX( 48),IY( 48)/'DRAW', -3, -8/ 17610 DATA IOPERA( 49),IX( 49),IY( 49)/'DRAW', -4, -7/ 17611 DATA IOPERA( 50),IX( 50),IY( 50)/'DRAW', -5, -4/ 17612C 17613 DATA IXMIND( 2)/ -9/ 17614 DATA IXMAXD( 2)/ 10/ 17615 DATA IXDELD( 2)/ 19/ 17616 DATA ISTARD( 2)/ 23/ 17617 DATA NUMCOO( 2)/ 28/ 17618C 17619C DEFINE CHARACTER 629--LOWER CASE GAMM 17620C 17621 DATA IOPERA( 51),IX( 51),IY( 51)/'MOVE', -8, 2/ 17622 DATA IOPERA( 52),IX( 52),IY( 52)/'DRAW', -6, 4/ 17623 DATA IOPERA( 53),IX( 53),IY( 53)/'DRAW', -4, 5/ 17624 DATA IOPERA( 54),IX( 54),IY( 54)/'DRAW', -3, 5/ 17625 DATA IOPERA( 55),IX( 55),IY( 55)/'DRAW', -1, 4/ 17626 DATA IOPERA( 56),IX( 56),IY( 56)/'DRAW', 0, 3/ 17627 DATA IOPERA( 57),IX( 57),IY( 57)/'DRAW', 1, 0/ 17628 DATA IOPERA( 58),IX( 58),IY( 58)/'DRAW', 1, -4/ 17629 DATA IOPERA( 59),IX( 59),IY( 59)/'DRAW', 0, -9/ 17630 DATA IOPERA( 60),IX( 60),IY( 60)/'MOVE', 8, 5/ 17631 DATA IOPERA( 61),IX( 61),IY( 61)/'DRAW', 7, 2/ 17632 DATA IOPERA( 62),IX( 62),IY( 62)/'DRAW', 6, 0/ 17633 DATA IOPERA( 63),IX( 63),IY( 63)/'DRAW', 0, -9/ 17634 DATA IOPERA( 64),IX( 64),IY( 64)/'DRAW', -2, -13/ 17635 DATA IOPERA( 65),IX( 65),IY( 65)/'DRAW', -3, -16/ 17636C 17637 DATA IXMIND( 3)/ -9/ 17638 DATA IXMAXD( 3)/ 10/ 17639 DATA IXDELD( 3)/ 19/ 17640 DATA ISTARD( 3)/ 51/ 17641 DATA NUMCOO( 3)/ 15/ 17642C 17643C DEFINE CHARACTER 630--LOWER CASE DELT 17644C 17645 DATA IOPERA( 66),IX( 66),IY( 66)/'MOVE', 2, 5/ 17646 DATA IOPERA( 67),IX( 67),IY( 67)/'DRAW', -1, 5/ 17647 DATA IOPERA( 68),IX( 68),IY( 68)/'DRAW', -3, 4/ 17648 DATA IOPERA( 69),IX( 69),IY( 69)/'DRAW', -5, 2/ 17649 DATA IOPERA( 70),IX( 70),IY( 70)/'DRAW', -6, -1/ 17650 DATA IOPERA( 71),IX( 71),IY( 71)/'DRAW', -6, -4/ 17651 DATA IOPERA( 72),IX( 72),IY( 72)/'DRAW', -5, -7/ 17652 DATA IOPERA( 73),IX( 73),IY( 73)/'DRAW', -4, -8/ 17653 DATA IOPERA( 74),IX( 74),IY( 74)/'DRAW', -2, -9/ 17654 DATA IOPERA( 75),IX( 75),IY( 75)/'DRAW', 0, -9/ 17655 DATA IOPERA( 76),IX( 76),IY( 76)/'DRAW', 2, -8/ 17656 DATA IOPERA( 77),IX( 77),IY( 77)/'DRAW', 4, -6/ 17657 DATA IOPERA( 78),IX( 78),IY( 78)/'DRAW', 5, -3/ 17658 DATA IOPERA( 79),IX( 79),IY( 79)/'DRAW', 5, 0/ 17659 DATA IOPERA( 80),IX( 80),IY( 80)/'DRAW', 4, 3/ 17660 DATA IOPERA( 81),IX( 81),IY( 81)/'DRAW', 2, 5/ 17661 DATA IOPERA( 82),IX( 82),IY( 82)/'DRAW', 0, 7/ 17662 DATA IOPERA( 83),IX( 83),IY( 83)/'DRAW', -1, 9/ 17663 DATA IOPERA( 84),IX( 84),IY( 84)/'DRAW', -1, 11/ 17664 DATA IOPERA( 85),IX( 85),IY( 85)/'DRAW', 0, 12/ 17665 DATA IOPERA( 86),IX( 86),IY( 86)/'DRAW', 2, 12/ 17666 DATA IOPERA( 87),IX( 87),IY( 87)/'DRAW', 4, 11/ 17667 DATA IOPERA( 88),IX( 88),IY( 88)/'DRAW', 6, 9/ 17668C 17669 DATA IXMIND( 4)/ -9/ 17670 DATA IXMAXD( 4)/ 9/ 17671 DATA IXDELD( 4)/ 18/ 17672 DATA ISTARD( 4)/ 66/ 17673 DATA NUMCOO( 4)/ 23/ 17674C 17675C DEFINE CHARACTER 631--LOWER CASE EPSI 17676C 17677 DATA IOPERA( 89),IX( 89),IY( 89)/'MOVE', 5, 3/ 17678 DATA IOPERA( 90),IX( 90),IY( 90)/'DRAW', 4, 4/ 17679 DATA IOPERA( 91),IX( 91),IY( 91)/'DRAW', 2, 5/ 17680 DATA IOPERA( 92),IX( 92),IY( 92)/'DRAW', -1, 5/ 17681 DATA IOPERA( 93),IX( 93),IY( 93)/'DRAW', -3, 4/ 17682 DATA IOPERA( 94),IX( 94),IY( 94)/'DRAW', -3, 2/ 17683 DATA IOPERA( 95),IX( 95),IY( 95)/'DRAW', -2, 0/ 17684 DATA IOPERA( 96),IX( 96),IY( 96)/'DRAW', 1, -1/ 17685 DATA IOPERA( 97),IX( 97),IY( 97)/'MOVE', 1, -1/ 17686 DATA IOPERA( 98),IX( 98),IY( 98)/'DRAW', -3, -2/ 17687 DATA IOPERA( 99),IX( 99),IY( 99)/'DRAW', -5, -4/ 17688 DATA IOPERA( 100),IX( 100),IY( 100)/'DRAW', -5, -6/ 17689 DATA IOPERA( 101),IX( 101),IY( 101)/'DRAW', -4, -8/ 17690 DATA IOPERA( 102),IX( 102),IY( 102)/'DRAW', -2, -9/ 17691 DATA IOPERA( 103),IX( 103),IY( 103)/'DRAW', 1, -9/ 17692 DATA IOPERA( 104),IX( 104),IY( 104)/'DRAW', 3, -8/ 17693 DATA IOPERA( 105),IX( 105),IY( 105)/'DRAW', 5, -6/ 17694C 17695 DATA IXMIND( 5)/ -8/ 17696 DATA IXMAXD( 5)/ 8/ 17697 DATA IXDELD( 5)/ 16/ 17698 DATA ISTARD( 5)/ 89/ 17699 DATA NUMCOO( 5)/ 17/ 17700C 17701C DEFINE CHARACTER 632--LOWER CASE ZETA 17702C 17703 DATA IOPERA( 106),IX( 106),IY( 106)/'MOVE', 2, 12/ 17704 DATA IOPERA( 107),IX( 107),IY( 107)/'DRAW', 0, 11/ 17705 DATA IOPERA( 108),IX( 108),IY( 108)/'DRAW', -1, 10/ 17706 DATA IOPERA( 109),IX( 109),IY( 109)/'DRAW', -1, 9/ 17707 DATA IOPERA( 110),IX( 110),IY( 110)/'DRAW', 0, 8/ 17708 DATA IOPERA( 111),IX( 111),IY( 111)/'DRAW', 3, 7/ 17709 DATA IOPERA( 112),IX( 112),IY( 112)/'DRAW', 6, 7/ 17710 DATA IOPERA( 113),IX( 113),IY( 113)/'MOVE', 6, 7/ 17711 DATA IOPERA( 114),IX( 114),IY( 114)/'DRAW', 2, 5/ 17712 DATA IOPERA( 115),IX( 115),IY( 115)/'DRAW', -1, 3/ 17713 DATA IOPERA( 116),IX( 116),IY( 116)/'DRAW', -4, 0/ 17714 DATA IOPERA( 117),IX( 117),IY( 117)/'DRAW', -5, -3/ 17715 DATA IOPERA( 118),IX( 118),IY( 118)/'DRAW', -5, -5/ 17716 DATA IOPERA( 119),IX( 119),IY( 119)/'DRAW', -4, -7/ 17717 DATA IOPERA( 120),IX( 120),IY( 120)/'DRAW', -2, -9/ 17718 DATA IOPERA( 121),IX( 121),IY( 121)/'DRAW', 1, -11/ 17719 DATA IOPERA( 122),IX( 122),IY( 122)/'DRAW', 2, -13/ 17720 DATA IOPERA( 123),IX( 123),IY( 123)/'DRAW', 2, -15/ 17721 DATA IOPERA( 124),IX( 124),IY( 124)/'DRAW', 1, -16/ 17722 DATA IOPERA( 125),IX( 125),IY( 125)/'DRAW', -1, -16/ 17723 DATA IOPERA( 126),IX( 126),IY( 126)/'DRAW', -2, -14/ 17724C 17725 DATA IXMIND( 6)/ -8/ 17726 DATA IXMAXD( 6)/ 7/ 17727 DATA IXDELD( 6)/ 15/ 17728 DATA ISTARD( 6)/ 106/ 17729 DATA NUMCOO( 6)/ 21/ 17730C 17731C DEFINE CHARACTER 633--LOWER CASE ETA 17732C 17733 DATA IOPERA( 127),IX( 127),IY( 127)/'MOVE', -9, 1/ 17734 DATA IOPERA( 128),IX( 128),IY( 128)/'DRAW', -8, 3/ 17735 DATA IOPERA( 129),IX( 129),IY( 129)/'DRAW', -6, 5/ 17736 DATA IOPERA( 130),IX( 130),IY( 130)/'DRAW', -4, 5/ 17737 DATA IOPERA( 131),IX( 131),IY( 131)/'DRAW', -3, 4/ 17738 DATA IOPERA( 132),IX( 132),IY( 132)/'DRAW', -3, 2/ 17739 DATA IOPERA( 133),IX( 133),IY( 133)/'DRAW', -4, -2/ 17740 DATA IOPERA( 134),IX( 134),IY( 134)/'DRAW', -6, -9/ 17741 DATA IOPERA( 135),IX( 135),IY( 135)/'MOVE', -4, -2/ 17742 DATA IOPERA( 136),IX( 136),IY( 136)/'DRAW', -2, 2/ 17743 DATA IOPERA( 137),IX( 137),IY( 137)/'DRAW', 0, 4/ 17744 DATA IOPERA( 138),IX( 138),IY( 138)/'DRAW', 2, 5/ 17745 DATA IOPERA( 139),IX( 139),IY( 139)/'DRAW', 4, 5/ 17746 DATA IOPERA( 140),IX( 140),IY( 140)/'DRAW', 6, 3/ 17747 DATA IOPERA( 141),IX( 141),IY( 141)/'DRAW', 6, 0/ 17748 DATA IOPERA( 142),IX( 142),IY( 142)/'DRAW', 5, -5/ 17749 DATA IOPERA( 143),IX( 143),IY( 143)/'DRAW', 2, -16/ 17750C 17751 DATA IXMIND( 7)/ -10/ 17752 DATA IXMAXD( 7)/ 10/ 17753 DATA IXDELD( 7)/ 20/ 17754 DATA ISTARD( 7)/ 127/ 17755 DATA NUMCOO( 7)/ 17/ 17756C 17757C DEFINE CHARACTER 634--LOWER CASE THET 17758C 17759 DATA IOPERA( 144),IX( 144),IY( 144)/'MOVE', -10, 1/ 17760 DATA IOPERA( 145),IX( 145),IY( 145)/'DRAW', -9, 3/ 17761 DATA IOPERA( 146),IX( 146),IY( 146)/'DRAW', -7, 5/ 17762 DATA IOPERA( 147),IX( 147),IY( 147)/'DRAW', -5, 5/ 17763 DATA IOPERA( 148),IX( 148),IY( 148)/'DRAW', -4, 4/ 17764 DATA IOPERA( 149),IX( 149),IY( 149)/'DRAW', -4, 2/ 17765 DATA IOPERA( 150),IX( 150),IY( 150)/'DRAW', -5, -3/ 17766 DATA IOPERA( 151),IX( 151),IY( 151)/'DRAW', -5, -6/ 17767 DATA IOPERA( 152),IX( 152),IY( 152)/'DRAW', -4, -8/ 17768 DATA IOPERA( 153),IX( 153),IY( 153)/'DRAW', -3, -9/ 17769 DATA IOPERA( 154),IX( 154),IY( 154)/'DRAW', -1, -9/ 17770 DATA IOPERA( 155),IX( 155),IY( 155)/'DRAW', 1, -8/ 17771 DATA IOPERA( 156),IX( 156),IY( 156)/'DRAW', 3, -5/ 17772 DATA IOPERA( 157),IX( 157),IY( 157)/'DRAW', 4, -3/ 17773 DATA IOPERA( 158),IX( 158),IY( 158)/'DRAW', 5, 0/ 17774 DATA IOPERA( 159),IX( 159),IY( 159)/'DRAW', 6, 5/ 17775 DATA IOPERA( 160),IX( 160),IY( 160)/'DRAW', 6, 8/ 17776 DATA IOPERA( 161),IX( 161),IY( 161)/'DRAW', 5, 11/ 17777 DATA IOPERA( 162),IX( 162),IY( 162)/'DRAW', 3, 12/ 17778 DATA IOPERA( 163),IX( 163),IY( 163)/'DRAW', 1, 12/ 17779 DATA IOPERA( 164),IX( 164),IY( 164)/'DRAW', 0, 10/ 17780 DATA IOPERA( 165),IX( 165),IY( 165)/'DRAW', 0, 8/ 17781 DATA IOPERA( 166),IX( 166),IY( 166)/'DRAW', 1, 5/ 17782 DATA IOPERA( 167),IX( 167),IY( 167)/'DRAW', 3, 2/ 17783 DATA IOPERA( 168),IX( 168),IY( 168)/'DRAW', 5, 0/ 17784 DATA IOPERA( 169),IX( 169),IY( 169)/'DRAW', 8, -2/ 17785C 17786 DATA IXMIND( 8)/ -11/ 17787 DATA IXMAXD( 8)/ 10/ 17788 DATA IXDELD( 8)/ 21/ 17789 DATA ISTARD( 8)/ 144/ 17790 DATA NUMCOO( 8)/ 26/ 17791C 17792C DEFINE CHARACTER 635--LOWER CASE IOTA 17793C 17794 DATA IOPERA( 170),IX( 170),IY( 170)/'MOVE', 0, 5/ 17795 DATA IOPERA( 171),IX( 171),IY( 171)/'DRAW', -2, -2/ 17796 DATA IOPERA( 172),IX( 172),IY( 172)/'DRAW', -3, -6/ 17797 DATA IOPERA( 173),IX( 173),IY( 173)/'DRAW', -3, -8/ 17798 DATA IOPERA( 174),IX( 174),IY( 174)/'DRAW', -2, -9/ 17799 DATA IOPERA( 175),IX( 175),IY( 175)/'DRAW', 0, -9/ 17800 DATA IOPERA( 176),IX( 176),IY( 176)/'DRAW', 2, -7/ 17801 DATA IOPERA( 177),IX( 177),IY( 177)/'DRAW', 3, -5/ 17802C 17803 DATA IXMIND( 9)/ -6/ 17804 DATA IXMAXD( 9)/ 5/ 17805 DATA IXDELD( 9)/ 11/ 17806 DATA ISTARD( 9)/ 170/ 17807 DATA NUMCOO( 9)/ 8/ 17808C 17809C DEFINE CHARACTER 636--LOWER CASE KAPP 17810C 17811 DATA IOPERA( 178),IX( 178),IY( 178)/'MOVE', -3, 5/ 17812 DATA IOPERA( 179),IX( 179),IY( 179)/'DRAW', -7, -9/ 17813 DATA IOPERA( 180),IX( 180),IY( 180)/'MOVE', 7, 4/ 17814 DATA IOPERA( 181),IX( 181),IY( 181)/'DRAW', 6, 5/ 17815 DATA IOPERA( 182),IX( 182),IY( 182)/'DRAW', 5, 5/ 17816 DATA IOPERA( 183),IX( 183),IY( 183)/'DRAW', 3, 4/ 17817 DATA IOPERA( 184),IX( 184),IY( 184)/'DRAW', -1, 0/ 17818 DATA IOPERA( 185),IX( 185),IY( 185)/'DRAW', -3, -1/ 17819 DATA IOPERA( 186),IX( 186),IY( 186)/'DRAW', -4, -1/ 17820 DATA IOPERA( 187),IX( 187),IY( 187)/'MOVE', -4, -1/ 17821 DATA IOPERA( 188),IX( 188),IY( 188)/'DRAW', -2, -2/ 17822 DATA IOPERA( 189),IX( 189),IY( 189)/'DRAW', -1, -3/ 17823 DATA IOPERA( 190),IX( 190),IY( 190)/'DRAW', 1, -8/ 17824 DATA IOPERA( 191),IX( 191),IY( 191)/'DRAW', 2, -9/ 17825 DATA IOPERA( 192),IX( 192),IY( 192)/'DRAW', 3, -9/ 17826 DATA IOPERA( 193),IX( 193),IY( 193)/'DRAW', 4, -8/ 17827C 17828 DATA IXMIND( 10)/ -9/ 17829 DATA IXMAXD( 10)/ 9/ 17830 DATA IXDELD( 10)/ 18/ 17831 DATA ISTARD( 10)/ 178/ 17832 DATA NUMCOO( 10)/ 16/ 17833C 17834C DEFINE CHARACTER 637--LOWER CASE LAMB 17835C 17836 DATA IOPERA( 194),IX( 194),IY( 194)/'MOVE', -7, 12/ 17837 DATA IOPERA( 195),IX( 195),IY( 195)/'DRAW', -5, 12/ 17838 DATA IOPERA( 196),IX( 196),IY( 196)/'DRAW', -3, 11/ 17839 DATA IOPERA( 197),IX( 197),IY( 197)/'DRAW', -2, 10/ 17840 DATA IOPERA( 198),IX( 198),IY( 198)/'DRAW', 6, -9/ 17841 DATA IOPERA( 199),IX( 199),IY( 199)/'MOVE', 0, 5/ 17842 DATA IOPERA( 200),IX( 200),IY( 200)/'DRAW', -6, -9/ 17843C 17844 DATA IXMIND( 11)/ -8/ 17845 DATA IXMAXD( 11)/ 8/ 17846 DATA IXDELD( 11)/ 16/ 17847 DATA ISTARD( 11)/ 194/ 17848 DATA NUMCOO( 11)/ 7/ 17849C 17850C DEFINE CHARACTER 638--LOWER CASE MU 17851C 17852 DATA IOPERA( 201),IX( 201),IY( 201)/'MOVE', -3, 5/ 17853 DATA IOPERA( 202),IX( 202),IY( 202)/'DRAW', -9, -16/ 17854 DATA IOPERA( 203),IX( 203),IY( 203)/'MOVE', -4, 1/ 17855 DATA IOPERA( 204),IX( 204),IY( 204)/'DRAW', -5, -4/ 17856 DATA IOPERA( 205),IX( 205),IY( 205)/'DRAW', -5, -7/ 17857 DATA IOPERA( 206),IX( 206),IY( 206)/'DRAW', -3, -9/ 17858 DATA IOPERA( 207),IX( 207),IY( 207)/'DRAW', -1, -9/ 17859 DATA IOPERA( 208),IX( 208),IY( 208)/'DRAW', 1, -8/ 17860 DATA IOPERA( 209),IX( 209),IY( 209)/'DRAW', 3, -6/ 17861 DATA IOPERA( 210),IX( 210),IY( 210)/'DRAW', 5, -2/ 17862 DATA IOPERA( 211),IX( 211),IY( 211)/'MOVE', 7, 5/ 17863 DATA IOPERA( 212),IX( 212),IY( 212)/'DRAW', 5, -2/ 17864 DATA IOPERA( 213),IX( 213),IY( 213)/'DRAW', 4, -6/ 17865 DATA IOPERA( 214),IX( 214),IY( 214)/'DRAW', 4, -8/ 17866 DATA IOPERA( 215),IX( 215),IY( 215)/'DRAW', 5, -9/ 17867 DATA IOPERA( 216),IX( 216),IY( 216)/'DRAW', 7, -9/ 17868 DATA IOPERA( 217),IX( 217),IY( 217)/'DRAW', 9, -7/ 17869 DATA IOPERA( 218),IX( 218),IY( 218)/'DRAW', 10, -5/ 17870C 17871 DATA IXMIND( 12)/ -10/ 17872 DATA IXMAXD( 12)/ 11/ 17873 DATA IXDELD( 12)/ 21/ 17874 DATA ISTARD( 12)/ 201/ 17875 DATA NUMCOO( 12)/ 18/ 17876C 17877C DEFINE CHARACTER 639--LOWER CASE NU 17878C 17879 DATA IOPERA( 219),IX( 219),IY( 219)/'MOVE', -6, 5/ 17880 DATA IOPERA( 220),IX( 220),IY( 220)/'DRAW', -3, 5/ 17881 DATA IOPERA( 221),IX( 221),IY( 221)/'DRAW', -4, -1/ 17882 DATA IOPERA( 222),IX( 222),IY( 222)/'DRAW', -5, -6/ 17883 DATA IOPERA( 223),IX( 223),IY( 223)/'DRAW', -6, -9/ 17884 DATA IOPERA( 224),IX( 224),IY( 224)/'MOVE', 7, 5/ 17885 DATA IOPERA( 225),IX( 225),IY( 225)/'DRAW', 6, 2/ 17886 DATA IOPERA( 226),IX( 226),IY( 226)/'DRAW', 5, 0/ 17887 DATA IOPERA( 227),IX( 227),IY( 227)/'DRAW', 3, -3/ 17888 DATA IOPERA( 228),IX( 228),IY( 228)/'DRAW', 0, -6/ 17889 DATA IOPERA( 229),IX( 229),IY( 229)/'DRAW', -3, -8/ 17890 DATA IOPERA( 230),IX( 230),IY( 230)/'DRAW', -6, -9/ 17891C 17892 DATA IXMIND( 13)/ -9/ 17893 DATA IXMAXD( 13)/ 9/ 17894 DATA IXDELD( 13)/ 18/ 17895 DATA ISTARD( 13)/ 219/ 17896 DATA NUMCOO( 13)/ 12/ 17897C 17898C DEFINE CHARACTER 640--LOWER CASE XI 17899C 17900 DATA IOPERA( 231),IX( 231),IY( 231)/'MOVE', 2, 12/ 17901 DATA IOPERA( 232),IX( 232),IY( 232)/'DRAW', 0, 11/ 17902 DATA IOPERA( 233),IX( 233),IY( 233)/'DRAW', -1, 10/ 17903 DATA IOPERA( 234),IX( 234),IY( 234)/'DRAW', -1, 9/ 17904 DATA IOPERA( 235),IX( 235),IY( 235)/'DRAW', 0, 8/ 17905 DATA IOPERA( 236),IX( 236),IY( 236)/'DRAW', 3, 7/ 17906 DATA IOPERA( 237),IX( 237),IY( 237)/'DRAW', 6, 7/ 17907 DATA IOPERA( 238),IX( 238),IY( 238)/'MOVE', 3, 7/ 17908 DATA IOPERA( 239),IX( 239),IY( 239)/'DRAW', 0, 6/ 17909 DATA IOPERA( 240),IX( 240),IY( 240)/'DRAW', -2, 5/ 17910 DATA IOPERA( 241),IX( 241),IY( 241)/'DRAW', -3, 3/ 17911 DATA IOPERA( 242),IX( 242),IY( 242)/'DRAW', -3, 1/ 17912 DATA IOPERA( 243),IX( 243),IY( 243)/'DRAW', -1, -1/ 17913 DATA IOPERA( 244),IX( 244),IY( 244)/'DRAW', 2, -2/ 17914 DATA IOPERA( 245),IX( 245),IY( 245)/'DRAW', 4, -2/ 17915 DATA IOPERA( 246),IX( 246),IY( 246)/'MOVE', 2, -2/ 17916 DATA IOPERA( 247),IX( 247),IY( 247)/'DRAW', -2, -3/ 17917 DATA IOPERA( 248),IX( 248),IY( 248)/'DRAW', -4, -4/ 17918 DATA IOPERA( 249),IX( 249),IY( 249)/'DRAW', -5, -6/ 17919 DATA IOPERA( 250),IX( 250),IY( 250)/'DRAW', -5, -8/ 17920 DATA IOPERA( 251),IX( 251),IY( 251)/'DRAW', -3, -10/ 17921 DATA IOPERA( 252),IX( 252),IY( 252)/'DRAW', 1, -12/ 17922 DATA IOPERA( 253),IX( 253),IY( 253)/'DRAW', 2, -13/ 17923 DATA IOPERA( 254),IX( 254),IY( 254)/'DRAW', 2, -15/ 17924 DATA IOPERA( 255),IX( 255),IY( 255)/'DRAW', 0, -16/ 17925 DATA IOPERA( 256),IX( 256),IY( 256)/'DRAW', -2, -16/ 17926C 17927 DATA IXMIND( 14)/ -8/ 17928 DATA IXMAXD( 14)/ 8/ 17929 DATA IXDELD( 14)/ 16/ 17930 DATA ISTARD( 14)/ 231/ 17931 DATA NUMCOO( 14)/ 26/ 17932C 17933C DEFINE CHARACTER 641--LOWER CASE OMIC 17934C 17935 DATA IOPERA( 257),IX( 257),IY( 257)/'MOVE', 0, 5/ 17936 DATA IOPERA( 258),IX( 258),IY( 258)/'DRAW', -2, 4/ 17937 DATA IOPERA( 259),IX( 259),IY( 259)/'DRAW', -4, 2/ 17938 DATA IOPERA( 260),IX( 260),IY( 260)/'DRAW', -5, -1/ 17939 DATA IOPERA( 261),IX( 261),IY( 261)/'DRAW', -5, -4/ 17940 DATA IOPERA( 262),IX( 262),IY( 262)/'DRAW', -4, -7/ 17941 DATA IOPERA( 263),IX( 263),IY( 263)/'DRAW', -3, -8/ 17942 DATA IOPERA( 264),IX( 264),IY( 264)/'DRAW', -1, -9/ 17943 DATA IOPERA( 265),IX( 265),IY( 265)/'DRAW', 1, -9/ 17944 DATA IOPERA( 266),IX( 266),IY( 266)/'DRAW', 3, -8/ 17945 DATA IOPERA( 267),IX( 267),IY( 267)/'DRAW', 5, -6/ 17946 DATA IOPERA( 268),IX( 268),IY( 268)/'DRAW', 6, -3/ 17947 DATA IOPERA( 269),IX( 269),IY( 269)/'DRAW', 6, 0/ 17948 DATA IOPERA( 270),IX( 270),IY( 270)/'DRAW', 5, 3/ 17949 DATA IOPERA( 271),IX( 271),IY( 271)/'DRAW', 4, 4/ 17950 DATA IOPERA( 272),IX( 272),IY( 272)/'DRAW', 2, 5/ 17951 DATA IOPERA( 273),IX( 273),IY( 273)/'DRAW', 0, 5/ 17952C 17953 DATA IXMIND( 15)/ -8/ 17954 DATA IXMAXD( 15)/ 9/ 17955 DATA IXDELD( 15)/ 17/ 17956 DATA ISTARD( 15)/ 257/ 17957 DATA NUMCOO( 15)/ 17/ 17958C 17959C DEFINE CHARACTER 642--LOWER CASE PI 17960C 17961 DATA IOPERA( 274),IX( 274),IY( 274)/'MOVE', -2, 5/ 17962 DATA IOPERA( 275),IX( 275),IY( 275)/'DRAW', -6, -9/ 17963 DATA IOPERA( 276),IX( 276),IY( 276)/'MOVE', 3, 5/ 17964 DATA IOPERA( 277),IX( 277),IY( 277)/'DRAW', 4, -1/ 17965 DATA IOPERA( 278),IX( 278),IY( 278)/'DRAW', 5, -6/ 17966 DATA IOPERA( 279),IX( 279),IY( 279)/'DRAW', 6, -9/ 17967 DATA IOPERA( 280),IX( 280),IY( 280)/'MOVE', -9, 2/ 17968 DATA IOPERA( 281),IX( 281),IY( 281)/'DRAW', -7, 4/ 17969 DATA IOPERA( 282),IX( 282),IY( 282)/'DRAW', -4, 5/ 17970 DATA IOPERA( 283),IX( 283),IY( 283)/'DRAW', 9, 5/ 17971C 17972 DATA IXMIND( 16)/ -11/ 17973 DATA IXMAXD( 16)/ 11/ 17974 DATA IXDELD( 16)/ 22/ 17975 DATA ISTARD( 16)/ 274/ 17976 DATA NUMCOO( 16)/ 10/ 17977C 17978C-----START POINT----------------------------------------------------- 17979C 17980 IFOUND='YES' 17981 IERROR='NO' 17982C 17983 NUMCO=1 17984 ISTART=1 17985 ISTOP=1 17986 NC=1 17987C 17988C ****************************************** 17989C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 17990C ** HERSHEY CHARACTER SET CASE ** 17991C ****************************************** 17992C 17993C 17994 IF(IBUGD2.EQ.'OFF')GOTO90 17995 WRITE(ICOUT,999) 17996 999 FORMAT(1X) 17997 CALL DPWRST('XXX','BUG ') 17998 WRITE(ICOUT,51) 17999 51 FORMAT('***** AT THE BEGINNING OF DGSL1--') 18000 CALL DPWRST('XXX','BUG ') 18001 WRITE(ICOUT,52)ICHARN 18002 52 FORMAT('ICHARN = ',I8) 18003 CALL DPWRST('XXX','BUG ') 18004 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 18005 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 18006 CALL DPWRST('XXX','BUG ') 18007 90 CONTINUE 18008C 18009C ************************************** 18010C ** STEP 2-- ** 18011C ** EXTRACT THE COORDINATES ** 18012C ** FOR THIS PARTICULAR CHARACTER. ** 18013C ************************************** 18014C 18015 ISTART=ISTARD(ICHARN) 18016 NC=NUMCOO(ICHARN) 18017 ISTOP=ISTART+NC-1 18018 J=0 18019 DO1100I=ISTART,ISTOP 18020 J=J+1 18021 IOP(J)=IOPERA(I) 18022 X(J)=IX(I) 18023 Y(J)=IY(I) 18024 1100 CONTINUE 18025 NUMCO=J 18026 IXMINS=IXMIND(ICHARN) 18027 IXMAXS=IXMAXD(ICHARN) 18028 IXDELS=IXDELD(ICHARN) 18029C 18030 GOTO9000 18031C 18032C ***************** 18033C ** STEP 90-- ** 18034C ** EXIT ** 18035C ***************** 18036C 18037 9000 CONTINUE 18038 IF(IBUGD2.EQ.'OFF')GOTO9090 18039 WRITE(ICOUT,999) 18040 CALL DPWRST('XXX','BUG ') 18041 WRITE(ICOUT,9011) 18042 9011 FORMAT('***** AT THE END OF DGSL1--') 18043 CALL DPWRST('XXX','BUG ') 18044 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 18045 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 18046 CALL DPWRST('XXX','BUG ') 18047 WRITE(ICOUT,9013)ICHARN 18048 9013 FORMAT('ICHARN = ',I8) 18049 CALL DPWRST('XXX','BUG ') 18050 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 18051 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 18052 CALL DPWRST('XXX','BUG ') 18053 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 18054 DO9015I=1,NUMCO 18055 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 18056 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 18057 CALL DPWRST('XXX','BUG ') 18058 9015 CONTINUE 18059 9019 CONTINUE 18060 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 18061 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 18062 CALL DPWRST('XXX','BUG ') 18063 9090 CONTINUE 18064C 18065 RETURN 18066 END 18067 SUBROUTINE DGSL2(ICHARN,IOP,X,Y,NUMCO,IXMINS,IXMAXS,IXDELS, 18068 1IBUGD2,IFOUND,IERROR) 18069C 18070C PURPOSE--DEFINE AND SET THE HERSHEY CHARACTER SET COORDINATES 18071C FOR GREEK SIMPLEX LOWER CASE (PART 2). 18072C WRITTEN BY--JAMES J. FILLIBEN 18073C STATISTICAL ENGINEERING DIVISION 18074C INFORMATION TECHNOLOGY LABORATORY 18075C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 18076C GAITHERSBURG, MD 20899-8980 18077C PHONE--301-921-3651 18078C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 18079C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 18080C LANGUAGE--ANSI FORTRAN (1977) 18081C VERSION NUMBER--87/4 18082C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1981. 18083C UPDATED --MAY 1982. 18084C UPDATED --MARCH 1987. 18085C UPDATED --MARCH 1987. 18086C 18087C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 18088C 18089 CHARACTER*4 IOP 18090 CHARACTER*4 IBUGD2 18091 CHARACTER*4 IFOUND 18092 CHARACTER*4 IERROR 18093C 18094 CHARACTER*4 IOPERA 18095C 18096C--------------------------------------------------------------------- 18097C 18098 DIMENSION IOP(*) 18099 DIMENSION X(*) 18100 DIMENSION Y(*) 18101C 18102 DIMENSION IOPERA(300) 18103 DIMENSION IX(300) 18104 DIMENSION IY(300) 18105C 18106 DIMENSION IXMIND(30) 18107 DIMENSION IXMAXD(30) 18108 DIMENSION IXDELD(30) 18109 DIMENSION ISTARD(30) 18110 DIMENSION NUMCOO(30) 18111C 18112C--------------------------------------------------------------------- 18113C 18114 INCLUDE 'DPCOP2.INC' 18115C 18116C-----DATA STATEMENTS------------------------------------------------- 18117C 18118C DEFINE CHARACTER 643--LOWER CASE RHO 18119C 18120 DATA IOPERA( 1),IX( 1),IY( 1)/'MOVE', -5, -1/ 18121 DATA IOPERA( 2),IX( 2),IY( 2)/'DRAW', -5, -4/ 18122 DATA IOPERA( 3),IX( 3),IY( 3)/'DRAW', -4, -7/ 18123 DATA IOPERA( 4),IX( 4),IY( 4)/'DRAW', -3, -8/ 18124 DATA IOPERA( 5),IX( 5),IY( 5)/'DRAW', -1, -9/ 18125 DATA IOPERA( 6),IX( 6),IY( 6)/'DRAW', 1, -9/ 18126 DATA IOPERA( 7),IX( 7),IY( 7)/'DRAW', 3, -8/ 18127 DATA IOPERA( 8),IX( 8),IY( 8)/'DRAW', 5, -6/ 18128 DATA IOPERA( 9),IX( 9),IY( 9)/'DRAW', 6, -3/ 18129 DATA IOPERA( 10),IX( 10),IY( 10)/'DRAW', 6, 0/ 18130 DATA IOPERA( 11),IX( 11),IY( 11)/'DRAW', 5, 3/ 18131 DATA IOPERA( 12),IX( 12),IY( 12)/'DRAW', 4, 4/ 18132 DATA IOPERA( 13),IX( 13),IY( 13)/'DRAW', 2, 5/ 18133 DATA IOPERA( 14),IX( 14),IY( 14)/'DRAW', 0, 5/ 18134 DATA IOPERA( 15),IX( 15),IY( 15)/'DRAW', -2, 4/ 18135 DATA IOPERA( 16),IX( 16),IY( 16)/'DRAW', -4, 2/ 18136 DATA IOPERA( 17),IX( 17),IY( 17)/'DRAW', -5, -1/ 18137 DATA IOPERA( 18),IX( 18),IY( 18)/'DRAW', -9, -16/ 18138C 18139 DATA IXMIND( 17)/ -9/ 18140 DATA IXMAXD( 17)/ 9/ 18141 DATA IXDELD( 17)/ 18/ 18142 DATA ISTARD( 17)/ 1/ 18143 DATA NUMCOO( 17)/ 18/ 18144C 18145C DEFINE CHARACTER 644--LOWER CASE SIGM 18146C 18147 DATA IOPERA( 19),IX( 19),IY( 19)/'MOVE', 9, 5/ 18148 DATA IOPERA( 20),IX( 20),IY( 20)/'DRAW', -1, 5/ 18149 DATA IOPERA( 21),IX( 21),IY( 21)/'DRAW', -3, 4/ 18150 DATA IOPERA( 22),IX( 22),IY( 22)/'DRAW', -5, 2/ 18151 DATA IOPERA( 23),IX( 23),IY( 23)/'DRAW', -6, -1/ 18152 DATA IOPERA( 24),IX( 24),IY( 24)/'DRAW', -6, -4/ 18153 DATA IOPERA( 25),IX( 25),IY( 25)/'DRAW', -5, -7/ 18154 DATA IOPERA( 26),IX( 26),IY( 26)/'DRAW', -4, -8/ 18155 DATA IOPERA( 27),IX( 27),IY( 27)/'DRAW', -2, -9/ 18156 DATA IOPERA( 28),IX( 28),IY( 28)/'DRAW', 0, -9/ 18157 DATA IOPERA( 29),IX( 29),IY( 29)/'DRAW', 2, -8/ 18158 DATA IOPERA( 30),IX( 30),IY( 30)/'DRAW', 4, -6/ 18159 DATA IOPERA( 31),IX( 31),IY( 31)/'DRAW', 5, -3/ 18160 DATA IOPERA( 32),IX( 32),IY( 32)/'DRAW', 5, 0/ 18161 DATA IOPERA( 33),IX( 33),IY( 33)/'DRAW', 4, 3/ 18162 DATA IOPERA( 34),IX( 34),IY( 34)/'DRAW', 3, 4/ 18163 DATA IOPERA( 35),IX( 35),IY( 35)/'DRAW', 1, 5/ 18164C 18165 DATA IXMIND( 18)/ -9/ 18166 DATA IXMAXD( 18)/ 11/ 18167 DATA IXDELD( 18)/ 20/ 18168 DATA ISTARD( 18)/ 19/ 18169 DATA NUMCOO( 18)/ 17/ 18170C 18171C DEFINE CHARACTER 645--LOWER CASE TAU 18172C 18173 DATA IOPERA( 36),IX( 36),IY( 36)/'MOVE', 1, 5/ 18174 DATA IOPERA( 37),IX( 37),IY( 37)/'DRAW', -2, -9/ 18175 DATA IOPERA( 38),IX( 38),IY( 38)/'MOVE', -8, 2/ 18176 DATA IOPERA( 39),IX( 39),IY( 39)/'DRAW', -6, 4/ 18177 DATA IOPERA( 40),IX( 40),IY( 40)/'DRAW', -3, 5/ 18178 DATA IOPERA( 41),IX( 41),IY( 41)/'DRAW', 8, 5/ 18179C 18180 DATA IXMIND( 19)/ -10/ 18181 DATA IXMAXD( 19)/ 10/ 18182 DATA IXDELD( 19)/ 20/ 18183 DATA ISTARD( 19)/ 36/ 18184 DATA NUMCOO( 19)/ 6/ 18185C 18186C DEFINE CHARACTER 646--LOWER CASE UPSI 18187C 18188 DATA IOPERA( 42),IX( 42),IY( 42)/'MOVE', -9, 1/ 18189 DATA IOPERA( 43),IX( 43),IY( 43)/'DRAW', -8, 3/ 18190 DATA IOPERA( 44),IX( 44),IY( 44)/'DRAW', -6, 5/ 18191 DATA IOPERA( 45),IX( 45),IY( 45)/'DRAW', -4, 5/ 18192 DATA IOPERA( 46),IX( 46),IY( 46)/'DRAW', -3, 4/ 18193 DATA IOPERA( 47),IX( 47),IY( 47)/'DRAW', -3, 2/ 18194 DATA IOPERA( 48),IX( 48),IY( 48)/'DRAW', -5, -4/ 18195 DATA IOPERA( 49),IX( 49),IY( 49)/'DRAW', -5, -7/ 18196 DATA IOPERA( 50),IX( 50),IY( 50)/'DRAW', -3, -9/ 18197 DATA IOPERA( 51),IX( 51),IY( 51)/'DRAW', -1, -9/ 18198 DATA IOPERA( 52),IX( 52),IY( 52)/'DRAW', 2, -8/ 18199 DATA IOPERA( 53),IX( 53),IY( 53)/'DRAW', 4, -6/ 18200 DATA IOPERA( 54),IX( 54),IY( 54)/'DRAW', 6, -2/ 18201 DATA IOPERA( 55),IX( 55),IY( 55)/'DRAW', 7, 2/ 18202 DATA IOPERA( 56),IX( 56),IY( 56)/'DRAW', 7, 5/ 18203C 18204 DATA IXMIND( 20)/ -10/ 18205 DATA IXMAXD( 20)/ 10/ 18206 DATA IXDELD( 20)/ 20/ 18207 DATA ISTARD( 20)/ 42/ 18208 DATA NUMCOO( 20)/ 15/ 18209C 18210C DEFINE CHARACTER 647--LOWER CASE PHI 18211C 18212 DATA IOPERA( 57),IX( 57),IY( 57)/'MOVE', -3, 4/ 18213 DATA IOPERA( 58),IX( 58),IY( 58)/'DRAW', -5, 3/ 18214 DATA IOPERA( 59),IX( 59),IY( 59)/'DRAW', -7, 1/ 18215 DATA IOPERA( 60),IX( 60),IY( 60)/'DRAW', -8, -2/ 18216 DATA IOPERA( 61),IX( 61),IY( 61)/'DRAW', -8, -5/ 18217 DATA IOPERA( 62),IX( 62),IY( 62)/'DRAW', -7, -7/ 18218 DATA IOPERA( 63),IX( 63),IY( 63)/'DRAW', -6, -8/ 18219 DATA IOPERA( 64),IX( 64),IY( 64)/'DRAW', -4, -9/ 18220 DATA IOPERA( 65),IX( 65),IY( 65)/'DRAW', -1, -9/ 18221 DATA IOPERA( 66),IX( 66),IY( 66)/'DRAW', 2, -8/ 18222 DATA IOPERA( 67),IX( 67),IY( 67)/'DRAW', 5, -6/ 18223 DATA IOPERA( 68),IX( 68),IY( 68)/'DRAW', 7, -3/ 18224 DATA IOPERA( 69),IX( 69),IY( 69)/'DRAW', 8, 0/ 18225 DATA IOPERA( 70),IX( 70),IY( 70)/'DRAW', 8, 3/ 18226 DATA IOPERA( 71),IX( 71),IY( 71)/'DRAW', 6, 5/ 18227 DATA IOPERA( 72),IX( 72),IY( 72)/'DRAW', 4, 5/ 18228 DATA IOPERA( 73),IX( 73),IY( 73)/'DRAW', 2, 3/ 18229 DATA IOPERA( 74),IX( 74),IY( 74)/'DRAW', 0, -1/ 18230 DATA IOPERA( 75),IX( 75),IY( 75)/'DRAW', -2, -6/ 18231 DATA IOPERA( 76),IX( 76),IY( 76)/'DRAW', -5, -16/ 18232C 18233 DATA IXMIND( 21)/ -11/ 18234 DATA IXMAXD( 21)/ 11/ 18235 DATA IXDELD( 21)/ 22/ 18236 DATA ISTARD( 21)/ 57/ 18237 DATA NUMCOO( 21)/ 20/ 18238C 18239C DEFINE CHARACTER 648--LOWER CASE CHI 18240C 18241 DATA IOPERA( 77),IX( 77),IY( 77)/'MOVE', -7, 5/ 18242 DATA IOPERA( 78),IX( 78),IY( 78)/'DRAW', -5, 5/ 18243 DATA IOPERA( 79),IX( 79),IY( 79)/'DRAW', -3, 3/ 18244 DATA IOPERA( 80),IX( 80),IY( 80)/'DRAW', 3, -14/ 18245 DATA IOPERA( 81),IX( 81),IY( 81)/'DRAW', 5, -16/ 18246 DATA IOPERA( 82),IX( 82),IY( 82)/'DRAW', 7, -16/ 18247 DATA IOPERA( 83),IX( 83),IY( 83)/'MOVE', 8, 5/ 18248 DATA IOPERA( 84),IX( 84),IY( 84)/'DRAW', 7, 3/ 18249 DATA IOPERA( 85),IX( 85),IY( 85)/'DRAW', 5, 0/ 18250 DATA IOPERA( 86),IX( 86),IY( 86)/'DRAW', -5, -11/ 18251 DATA IOPERA( 87),IX( 87),IY( 87)/'DRAW', -7, -14/ 18252 DATA IOPERA( 88),IX( 88),IY( 88)/'DRAW', -8, -16/ 18253C 18254 DATA IXMIND( 22)/ -9/ 18255 DATA IXMAXD( 22)/ 9/ 18256 DATA IXDELD( 22)/ 18/ 18257 DATA ISTARD( 22)/ 77/ 18258 DATA NUMCOO( 22)/ 12/ 18259C 18260C DEFINE CHARACTER 649--LOWER CASE PSI 18261C 18262 DATA IOPERA( 89),IX( 89),IY( 89)/'MOVE', 4, 12/ 18263 DATA IOPERA( 90),IX( 90),IY( 90)/'DRAW', -4, -16/ 18264 DATA IOPERA( 91),IX( 91),IY( 91)/'MOVE', -11, 1/ 18265 DATA IOPERA( 92),IX( 92),IY( 92)/'DRAW', -10, 3/ 18266 DATA IOPERA( 93),IX( 93),IY( 93)/'DRAW', -8, 5/ 18267 DATA IOPERA( 94),IX( 94),IY( 94)/'DRAW', -6, 5/ 18268 DATA IOPERA( 95),IX( 95),IY( 95)/'DRAW', -5, 4/ 18269 DATA IOPERA( 96),IX( 96),IY( 96)/'DRAW', -5, 2/ 18270 DATA IOPERA( 97),IX( 97),IY( 97)/'DRAW', -6, -3/ 18271 DATA IOPERA( 98),IX( 98),IY( 98)/'DRAW', -6, -6/ 18272 DATA IOPERA( 99),IX( 99),IY( 99)/'DRAW', -5, -8/ 18273 DATA IOPERA( 100),IX( 100),IY( 100)/'DRAW', -3, -9/ 18274 DATA IOPERA( 101),IX( 101),IY( 101)/'DRAW', -1, -9/ 18275 DATA IOPERA( 102),IX( 102),IY( 102)/'DRAW', 2, -8/ 18276 DATA IOPERA( 103),IX( 103),IY( 103)/'DRAW', 4, -6/ 18277 DATA IOPERA( 104),IX( 104),IY( 104)/'DRAW', 6, -3/ 18278 DATA IOPERA( 105),IX( 105),IY( 105)/'DRAW', 8, 2/ 18279 DATA IOPERA( 106),IX( 106),IY( 106)/'DRAW', 9, 5/ 18280C 18281 DATA IXMIND( 23)/ -12/ 18282 DATA IXMAXD( 23)/ 11/ 18283 DATA IXDELD( 23)/ 23/ 18284 DATA ISTARD( 23)/ 89/ 18285 DATA NUMCOO( 23)/ 18/ 18286C 18287C DEFINE CHARACTER 650--LOWER CASE OMEG 18288C 18289 DATA IOPERA( 107),IX( 107),IY( 107)/'MOVE', -4, 5/ 18290 DATA IOPERA( 108),IX( 108),IY( 108)/'DRAW', -6, 4/ 18291 DATA IOPERA( 109),IX( 109),IY( 109)/'DRAW', -8, 1/ 18292 DATA IOPERA( 110),IX( 110),IY( 110)/'DRAW', -9, -2/ 18293 DATA IOPERA( 111),IX( 111),IY( 111)/'DRAW', -9, -5/ 18294 DATA IOPERA( 112),IX( 112),IY( 112)/'DRAW', -8, -8/ 18295 DATA IOPERA( 113),IX( 113),IY( 113)/'DRAW', -7, -9/ 18296 DATA IOPERA( 114),IX( 114),IY( 114)/'DRAW', -5, -9/ 18297 DATA IOPERA( 115),IX( 115),IY( 115)/'DRAW', -3, -8/ 18298 DATA IOPERA( 116),IX( 116),IY( 116)/'DRAW', -1, -5/ 18299 DATA IOPERA( 117),IX( 117),IY( 117)/'MOVE', 0, -1/ 18300 DATA IOPERA( 118),IX( 118),IY( 118)/'DRAW', -1, -5/ 18301 DATA IOPERA( 119),IX( 119),IY( 119)/'DRAW', 0, -8/ 18302 DATA IOPERA( 120),IX( 120),IY( 120)/'DRAW', 1, -9/ 18303 DATA IOPERA( 121),IX( 121),IY( 121)/'DRAW', 3, -9/ 18304 DATA IOPERA( 122),IX( 122),IY( 122)/'DRAW', 5, -8/ 18305 DATA IOPERA( 123),IX( 123),IY( 123)/'DRAW', 7, -5/ 18306 DATA IOPERA( 124),IX( 124),IY( 124)/'DRAW', 8, -2/ 18307 DATA IOPERA( 125),IX( 125),IY( 125)/'DRAW', 8, 1/ 18308 DATA IOPERA( 126),IX( 126),IY( 126)/'DRAW', 7, 4/ 18309 DATA IOPERA( 127),IX( 127),IY( 127)/'DRAW', 6, 5/ 18310C 18311 DATA IXMIND( 24)/ -12/ 18312 DATA IXMAXD( 24)/ 11/ 18313 DATA IXDELD( 24)/ 23/ 18314 DATA ISTARD( 24)/ 107/ 18315 DATA NUMCOO( 24)/ 21/ 18316C 18317C-----START POINT----------------------------------------------------- 18318C 18319 IFOUND='YES' 18320 IERROR='NO' 18321C 18322 NUMCO=1 18323 ISTART=1 18324 ISTOP=1 18325 NC=1 18326C 18327C ****************************************** 18328C ** TREAT THE ROMAN SIMPLEX UPPER CASE ** 18329C ** HERSHEY CHARACTER SET CASE ** 18330C ****************************************** 18331C 18332C 18333 IF(IBUGD2.EQ.'OFF')GOTO90 18334 WRITE(ICOUT,999) 18335 999 FORMAT(1X) 18336 CALL DPWRST('XXX','BUG ') 18337 WRITE(ICOUT,51) 18338 51 FORMAT('***** AT THE BEGINNING OF DGSL2--') 18339 CALL DPWRST('XXX','BUG ') 18340 WRITE(ICOUT,52)ICHARN 18341 52 FORMAT('ICHARN = ',I8) 18342 CALL DPWRST('XXX','BUG ') 18343 WRITE(ICOUT,59)IBUGD2,IFOUND,IERROR 18344 59 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 18345 CALL DPWRST('XXX','BUG ') 18346 90 CONTINUE 18347C 18348C ************************************** 18349C ** STEP 2-- ** 18350C ** EXTRACT THE COORDINATES ** 18351C ** FOR THIS PARTICULAR CHARACTER. ** 18352C ************************************** 18353C 18354 ISTART=ISTARD(ICHARN) 18355 NC=NUMCOO(ICHARN) 18356 ISTOP=ISTART+NC-1 18357 J=0 18358 DO1100I=ISTART,ISTOP 18359 J=J+1 18360 IOP(J)=IOPERA(I) 18361 X(J)=IX(I) 18362 Y(J)=IY(I) 18363 1100 CONTINUE 18364 NUMCO=J 18365 IXMINS=IXMIND(ICHARN) 18366 IXMAXS=IXMAXD(ICHARN) 18367 IXDELS=IXDELD(ICHARN) 18368C 18369 GOTO9000 18370C 18371C ***************** 18372C ** STEP 90-- ** 18373C ** EXIT ** 18374C ***************** 18375C 18376 9000 CONTINUE 18377 IF(IBUGD2.EQ.'OFF')GOTO9090 18378 WRITE(ICOUT,999) 18379 CALL DPWRST('XXX','BUG ') 18380 WRITE(ICOUT,9011) 18381 9011 FORMAT('***** AT THE END OF DGSL2--') 18382 CALL DPWRST('XXX','BUG ') 18383 WRITE(ICOUT,9012)IBUGD2,IFOUND,IERROR 18384 9012 FORMAT('IBUGD2,IFOUND,IERROR = ',A4,2X,A4,2X,A4) 18385 CALL DPWRST('XXX','BUG ') 18386 WRITE(ICOUT,9013)ICHARN 18387 9013 FORMAT('ICHARN = ',I8) 18388 CALL DPWRST('XXX','BUG ') 18389 WRITE(ICOUT,9014)ISTART,ISTOP,NC,NUMCO 18390 9014 FORMAT('ISTART,ISTOP,NC,NUMCO = ',4I8) 18391 CALL DPWRST('XXX','BUG ') 18392 IF(NUMCO.GE.1.AND.NUMCO.LE.1000)GOTO9019 18393 DO9015I=1,NUMCO 18394 WRITE(ICOUT,9016)I,IOP(I),X(I),Y(I) 18395 9016 FORMAT('I,IOP(I),X(I),Y(I) = ',I8,2X,A4,2F10.2) 18396 CALL DPWRST('XXX','BUG ') 18397 9015 CONTINUE 18398 9019 CONTINUE 18399 WRITE(ICOUT,9021)IXMINS,IXMAXS,IXDELS 18400 9021 FORMAT('IXMINS,IXMAXS,IXDELS = ',3I8) 18401 CALL DPWRST('XXX','BUG ') 18402 9090 CONTINUE 18403C 18404 RETURN 18405 END 18406 SUBROUTINE DIFF(IORD,X0,XMIN,XMAX,F,EPS,ACC,DERIV,ERROR,IFAIL) 18407C 18408C NUMERICAL DIFFERENTIATION OF USER DEFINED FUNCTION 18409C 18410C DAVID KAHANER, NBS (GAITHERSBURG) 18411C 18412C THE PROCEDURE DIFFERENTIATE CALCULATES THE FIRST, SECOND OR 18413C THIRD ORDER DERIVATIVE OF A FUNCTION BY USING NEVILLE'S PROCESS TO 18414C EXTRAPOLATE FROM A SEQUENCE OF SIMPLE POLYNOMIAL APPROXIMATIONS BASED ON 18415C INTERPOLATING POINTS DISTRIBUTED SYMMETRICALLY ABOUT X0 (OR LYING ONLY ON 18416C ONE SIDE OF X0 SHOULD THIS BE NECESSARY). IF THE SPECIFIED TOLERANCE IS 18417C NON-ZERO THEN THE PROCEDURE ATTEMPTS TO SATISFY THIS ABSOLUTE OR RELATIVE 18418C ACCURACY REQUIREMENT, WHILE IF IT IS UNSUCCESSFUL OR IF THE TOLERANCE IS 18419C SET TO ZERO THEN THE RESULT HAVING THE MINIMUM ACHIEVABLE ESTIMATED ERROR 18420C IS RETURNED INSTEAD. 18421C 18422C INPUT PARAMETERS: 18423C IORD = 1, 2 OR 3 SPECIFIES THAT THE FIRST, SECOND OR THIRD ORDER 18424C DERIVATIVE,RESPECTIVELY, IS REQUIRED. 18425C X0 IS THE POINT AT WHICH THE DERIVATIVE OF THE FUNCTION IS TO BE CALCULATED. 18426C XMIN, XMAX RESTRICT THE INTERPOLATING POINTS TO LIE IN [XMIN, XMAX], WHICH 18427C SHOULD BE THE LARGEST INTERVAL INCLUDING X0 IN WHICH THE FUNCTION IS 18428C CALCULABLE AND CONTINUOUS. 18429C F, A REAL PROCEDURE SUPPLIED BY THE USER, MUST YIELD THE VALUE OF THE 18430C FUNCTION AT X FOR ANY X IN [XMIN, XMAX] WHEN CALLED BY F(X). 18431C EPS DENOTES THE TOLERANCE, EITHER ABSOLUTE OR RELATIVE. EPS=0 SPECIFIES THAT 18432C THE ERROR IS TO BE MINIMISED, WHILE EPS>0 OR EPS<0 SPECIFIES THAT THE 18433C ABSOLUTE OR RELATIVE ERROR, RESPECTIVELY, MUST NOT EXCEED ABS(EPS) IF 18434C POSSIBLE. THE ACCURACY REQUIREMENT SHOULD NOT BE MADE STRICTER THAN 18435C NECESSARY, SINCE THE AMOUNT OF COMPUTATION TENDS TO INCREASE AS 18436C THE MAGNITUDE OF EPS DECREASES, AND IS PARTICULARLY HIGH WHEN EPS=0. 18437C ACC DENOTES THAT THE ABSOLUTE (ACC>0) OR RELATIVE (ACC<0) ERRORS IN THE 18438C COMPUTED VALUES OF THE FUNCTION ARE MOST UNLIKELY TO EXCEED ABS(ACC), WHICH 18439C SHOULD BE AS SMALL AS POSSIBLE. IF THE USER CANNOT ESTIMATE ACC WITH 18440C COMPLETE CONFIDENCE, THEN IT SHOULD BE SET TO ZERO. 18441C 18442C OUTPUT PARAMETERS: 18443C DERIV IS THE CALCULATED VALUE OF THE DERIVATIVE. 18444C ERROR IS AN ESTIMATED UPPER BOUND ON THE MAGNITUDE OF THE ABSOLUTE ERROR IN 18445C THE CALCULATED RESULT. IT SHOULD ALWAYS BE EXAMINED, SINCE IN EXTREME CASE 18446C MAY INDICATE THAT THERE ARE NO CORRECT SIGNIFICANT DIGITS IN THE VALUE 18447C RETURNED FOR DERIVATIVE. 18448C IFAIL WILL HAVE ONE OF THE FOLLOWING VALUES ON EXIT: 18449C 0 THE PROCEDURE WAS SUCCESSFUL. 18450C 1 THE ESTIMATED ERROR IN THE RESULT EXCEEDS THE (NON-ZERO) REQUESTED 18451C ERROR, BUT THE MOST ACCURATE RESULT POSSIBLE HAS BEEN RETURNED. 18452C 2 INPUT DATA INCORRECT (DERIVATIVE AND ERROR WILL BE UNDEFINED). 18453C 3 THE INTERVAL [XMIN, XMAX] IS TOO SMALL (DERIVATIVE AND ERROR WILL BE 18454C UNDEFINED); 18455C 18456 EXTERNAL F 18457 REAL X0,XMIN,XMAX,ACC,DERIV,ERROR,BETA,BETA4,H,H0,H1,H2, 18458 +NEWH1,NEWH2,HEVAL,HPREV,BASEH,HACC1,HACC2,NHACC1, 18459 +NHACC2,MINH,MAXH,MAXH1,MAXH2,TDERIV,F0,TWOF0,F1,F2,F3,F4,FMAX, 18460 +MAXFUN,PMAXF,DF1,DELTAF,PDELTA,Z,ZPOWER,C0F0,C1,C2,C3,DNEW,DPREV, 18461 +RE,TE,NEWERR,TEMERR,NEWACC,PACC1,PACC2,FACC1,FACC2,ACC0, 18462 +ACC1,ACC2,RELACC,TWOINF,TWOSUP,S, 18463 +D(10),DENOM(10),E(10),MINERR(10),MAXF(0:10),SAVE(0:13), 18464 +STOREF(-45:45),FACTOR 18465C 18466 INTEGER IORD,IFAIL,ETA,INF,SUP,I,J,K,N,NMAX,METHOD,SIGNH,FCOUNT, 18467 +INIT 18468 LOGICAL IGNORE(10),CONTIN,SAVED 18469C 18470 INCLUDE 'DPCOMC.INC' 18471 INCLUDE 'DPCOP2.INC' 18472C 18473C 18474C ETA IS THE MINIMUM NUMBER OF SIGNIFICANT BINARY DIGITS (APART FROM THE 18475C SIGN DIGIT) USED TO REPRESENT THE MANTISSA OF REAL NUMBERS. IT SHOULD 18476C BE DEVREASED BY ONE IF THE COMPUTER TRUNCATES RATHER THAN ROUNDS. 18477C INF, SUP ARE THE LARGEST POSSIBLE POSITIVE INTEGERS SUBJECT TO 18478C 2**(-INF), -2**(-INF), 2**SUP, AND -2**SUP ALL BEING REPRESENTABLE REAL 18479C NUMBERS. 18480 DO 2 I=0,13 18481 SAVE(I)=0.0 18482 2 CONTINUE 18483 NEWACC=0.0 18484 PMAXF=0.0 18485 PDELTA=0.0 18486 DELTAF=0.0 18487 F2=0.0 18488 F3=0.0 18489 F4=0.0 18490 C1=0.0 18491 C2=0.0 18492 C3=0.0 18493 C0F0=0.0 18494 TEMERR=0.0 18495 TDERIV=0.0 18496 MAXH=0.0 18497 HEVAL=0.0 18498 BETA4=0.0 18499 BETA=0.0 18500 BASEH=0.0 18501 MAXFUN=0 18502 J=0 18503 SAVED=.FALSE. 18504C 18505 ETA=I1MACH(11) - 1 18506 INF=-I1MACH(12) - 2 18507 SUP=I1MACH(13)-1 18508 IF(IORD.LT.1 .OR. IORD.GT.3 .OR. XMAX.LE.XMIN .OR. 18509 + X0.GT.XMAX .OR. X0.LT.XMIN) THEN 18510 IFAIL = 2 18511 RETURN 18512 ENDIF 18513C 18514 TWOINF = 2.**(-INF) 18515 TWOSUP = 2.**SUP 18516 FACTOR = 2**(FLOAT((INF+SUP))/30.) 18517 IF(FACTOR.LT.256.)FACTOR=256. 18518 MAXH1 = XMAX - X0 18519 SIGNH = 1 18520 IF(X0-XMIN .LE. MAXH1)THEN 18521 MAXH2 = X0 - XMIN 18522 ELSE 18523 MAXH2 = MAXH1 18524 MAXH1 = X0 - XMIN 18525 SIGNH = -1 18526 ENDIF 18527 RELACC = 2.**(1-ETA) 18528 MAXH1 = (1.-RELACC)*MAXH1 18529 MAXH2 = (1.-RELACC)*MAXH2 18530 S=128.*TWOINF 18531 IF(ABS(X0).GT.128.*TWOINF*2.**ETA) S = ABS(X0)*2.**(-ETA) 18532 IF(MAXH1.LT.S)THEN 18533C INTERVAL TOO SMALL 18534 IFAIL =3 18535 RETURN 18536 ENDIF 18537 IF(ACC.LT.0.) THEN 18538 IF(-ACC.GT.RELACC)RELACC = -ACC 18539 ACC = 0. 18540 ENDIF 18541C 18542C DETERMINE THE SMALLEST SPACING AT WHICH THE CALCULATED 18543C FUNCTION VALUES ARE UNEQUAL NEAR X0. 18544C 18545 F0 = F(X0) 18546 TWOF0 = F0 + F0 18547 IF(ABS(X0) .GT. TWOINF*2.**ETA) THEN 18548 H = ABS(X0)*2.**(-ETA) 18549 Z = 2. 18550 ELSE 18551 H = TWOINF 18552 Z = 64. 18553 ENDIF 18554 DF1 = F(X0+SIGNH*H) - F0 18555 80 IF(DF1 .NE. 0. .OR. Z*H .GT. MAXH1) GOTO 100 18556 H = Z*H 18557 DF1 = F(X0+SIGNH*H) - F0 18558 IF(Z .NE.2.) THEN 18559 IF(DF1 .NE. 0.) THEN 18560 H = H/Z 18561 Z = 2. 18562 DF1 = 0. 18563 ELSE 18564 IF(Z*H .GT. MAXH1) Z = 2. 18565 ENDIF 18566 ENDIF 18567 GOTO 80 18568 100 CONTINUE 18569C 18570 IF(DF1 .EQ. 0.) THEN 18571C CONSTANT FUNCTION 18572 DERIV = 0. 18573 ERROR = 0. 18574 IFAIL = 0 18575 RETURN 18576 ENDIF 18577 IF(H .GT. MAXH1/128.) THEN 18578C MINIMUM H TOO LARGE 18579 IFAIL = 3 18580 RETURN 18581 ENDIF 18582C 18583 H = 8.*H 18584 H1 = SIGNH*H 18585 H0 = H1 18586 H2 = -H1 18587 MINH = 2.**(-MIN(INF,SUP)/IORD) 18588 IF(MINH.LT.H) MINH = H 18589 IF(IORD.EQ.1) S = 8. 18590 IF(IORD.EQ.2) S = 9.*SQRT(3.) 18591 IF(IORD.EQ.3) S = 27. 18592 IF(MINH.GT.MAXH1/S) THEN 18593 IFAIL = 3 18594 RETURN 18595 ENDIF 18596 IF(MINH.GT.MAXH2/S .OR. MAXH2.LT.128.*TWOINF) THEN 18597 METHOD = 1 18598 ELSE 18599 METHOD = 2 18600 ENDIF 18601C 18602C METHOD 1 USES 1-SIDED FORMULAE, AND METHOD 2 SYMMETRIC. 18603C NOW ESTIMATE ACCURACY OF CALCULATED FUNCTION VALUES. 18604C 18605 IF(METHOD.NE.2 .OR. IORD.EQ.2) THEN 18606 IF(X0.NE.0.) THEN 18607 CALL FACCUR(0.,-H1,ACC0,X0,F,TWOINF,F0,F1) 18608 ELSE 18609 ACC0 = 0. 18610 ENDIF 18611 ENDIF 18612C 18613 IF(ABS(H1) .GT. TWOSUP/128.) THEN 18614 HACC1 = TWOSUP 18615 ELSE 18616 HACC1 = 128.*H1 18617 ENDIF 18618C 18619 IF(ABS(HACC1)/4. .LT. MINH) THEN 18620 HACC1 = 4.*SIGNH*MINH 18621 ELSEIF(ABS(HACC1) .GT. MAXH1) THEN 18622 HACC1 = SIGNH*MAXH1 18623 ENDIF 18624 F1 = F(X0+HACC1) 18625 CALL FACCUR(HACC1,H1,ACC1,X0,F,TWOINF,F0,F1) 18626 IF(METHOD.EQ.2) THEN 18627 HACC2 = -HACC1 18628 IF(ABS(HACC2) .GT. MAXH2) HACC2 = -SIGNH * MAXH2 18629 F1 = F(X0 + HACC2) 18630 CALL FACCUR(HACC2,H2,ACC2,X0,F,TWOINF,F0,F1) 18631 ENDIF 18632 NMAX = 8 18633 IF(ETA.GT.36) NMAX = 10 18634 N = -1 18635 FCOUNT = 0 18636 DERIV = 0. 18637 ERROR = TWOSUP 18638 INIT = 3 18639 CONTIN = .TRUE. 18640C 18641 130 CONTINUE 18642 N = N+1 18643 IF(.NOT. CONTIN) GOTO 800 18644C 18645 IF(INIT.EQ.3) THEN 18646C CALCULATE COEFFICIENTS FOR DIFFERENTIATION FORMULAE 18647C AND NEVILLE EXTRAPOLATION ALGORITHM 18648 IF(IORD.EQ.1) THEN 18649 BETA=2. 18650 ELSEIF(METHOD.EQ.2)THEN 18651 BETA = SQRT(2.) 18652 ELSE 18653 BETA = SQRT(3.) 18654 ENDIF 18655 BETA4 = BETA**4. 18656 Z = BETA 18657 IF(METHOD.EQ.2) Z = Z**2 18658 ZPOWER = 1. 18659 DO 150 K = 1,NMAX 18660 ZPOWER = Z*ZPOWER 18661 DENOM(K) = ZPOWER-1 18662 150 CONTINUE 18663 IF(METHOD.EQ.2 .AND. IORD.EQ.1) THEN 18664 E(1) = 5. 18665 E(2) = 6.3 18666 DO 160 I = 3,NMAX 18667 E(I) = 6.81 18668 160 CONTINUE 18669 ELSEIF((METHOD.NE.2.AND.IORD.EQ.1) .OR. (METHOD.EQ.2.AND. 18670 + IORD.EQ.2)) THEN 18671 E(1) = 10. 18672 E(2) = 16. 18673 E(3) = 20.36 18674 E(4) = 23. 18675 E(5) = 24.46 18676 DO 165 I = 6,NMAX 18677 E(I) = 26. 18678 165 CONTINUE 18679 IF(METHOD.EQ.2.AND.IORD.EQ.2) THEN 18680 DO 170 I = 1,NMAX 18681 E(I)=2*E(I) 18682 170 CONTINUE 18683 ENDIF 18684 ELSEIF(METHOD.NE.2.AND.IORD.EQ.2) THEN 18685 E(1) = 17.78 18686 E(2) = 30.06 18687 E(3) = 39.66 18688 E(4) = 46.16 18689 E(5) = 50.26 18690 DO 175 I = 6,NMAX 18691 E(I) = 55. 18692 175 CONTINUE 18693 ELSEIF(METHOD.EQ.2.AND.IORD.EQ.3) THEN 18694 E(1) = 25.97 18695 E(2) = 41.22 18696 E(3) = 50.95 18697 E(4) = 56.4 18698 E(5) = 59.3 18699 DO 180 I = 6,NMAX 18700 E(I) = 62. 18701 180 CONTINUE 18702 ELSE 18703 E(1) = 24.5 18704 E(2) = 40.4 18705 E(3) = 52.78 18706 E(4) = 61.2 18707 E(5) = 66.55 18708 DO 185 I = 6,NMAX 18709 E(I) = 73. 18710 185 CONTINUE 18711 C0F0 = -TWOF0/(3.*BETA) 18712 C1 = 3./(3.*BETA-1.) 18713 C2 = -1./(3.*(BETA-1.)) 18714 C3 = 1./(3.*BETA*(5.-2.*BETA)) 18715 ENDIF 18716 ENDIF 18717C 18718C 18719 IF(INIT.GE.2) THEN 18720C INITIALIZATION OF STEPLENGTHS, ACCURACY AND OTHER 18721C PARAMETERS 18722C 18723 HEVAL = SIGNH*MINH 18724 H = HEVAL 18725 BASEH = HEVAL 18726 MAXH = MAXH2 18727 IF(METHOD.EQ.1)MAXH = MAXH1 18728 DO 300 K = 1,NMAX 18729 MINERR(K) = TWOSUP 18730 IGNORE(K) = .FALSE. 18731 300 CONTINUE 18732 IF(METHOD.EQ.1) NEWACC = ACC1 18733 IF(METHOD.EQ.-1) NEWACC = ACC2 18734 IF(METHOD.EQ.2) NEWACC = (ACC1+ACC2)/2. 18735 IF(NEWACC.LT.ACC) NEWACC = ACC 18736 IF((METHOD.NE.2 .OR. IORD.EQ.2) .AND. NEWACC.LT.ACC0) 18737 + NEWACC = ACC0 18738 IF(METHOD.NE.-1) THEN 18739 FACC1 = ACC1 18740 NHACC1 = HACC1 18741 NEWH1 = H1 18742 ENDIF 18743 IF(METHOD.NE.1) THEN 18744 FACC2 = ACC2 18745 NHACC2 = HACC2 18746 NEWH2 = H2 18747 ELSE 18748 FACC2 = 0. 18749 NHACC2 = 0. 18750 ENDIF 18751 INIT = 1 18752 J = 0 18753 SAVED = .FALSE. 18754 ENDIF 18755C 18756C CALCULATE NEW OR INITIAL FUNCTION VALUES 18757C 18758 IF(INIT.EQ.1 .AND. (N.EQ.0 .OR. IORD.EQ.1) .AND. 18759 + .NOT.(METHOD.EQ.2 .AND. FCOUNT.GE.45)) THEN 18760 IF(METHOD.EQ.2) THEN 18761 FCOUNT = FCOUNT + 1 18762 F1 = F(X0+HEVAL) 18763 STOREF(FCOUNT) = F1 18764 F2 = F(X0-HEVAL) 18765 STOREF(-FCOUNT) = F2 18766 ELSE 18767 J = J+1 18768 IF(J.LE.FCOUNT) THEN 18769 F1 = STOREF(J*METHOD) 18770 ELSE 18771 F1 = F(X0+HEVAL) 18772 ENDIF 18773 ENDIF 18774 ELSE 18775 F1 = F(X0+HEVAL) 18776 IF(METHOD.EQ.2) F2 = F(X0-HEVAL) 18777 ENDIF 18778 IF(N.EQ.0) THEN 18779 IF(METHOD.EQ.2 .AND. IORD.EQ.3) THEN 18780 PDELTA = F1-F2 18781 PMAXF = (ABS(F1)+ABS(F2))/2. 18782 HEVAL = BETA*HEVAL 18783 F1 = F(X0+HEVAL) 18784 F2 = F(X0-HEVAL) 18785 DELTAF = F1-F2 18786 MAXFUN = (ABS(F1)+ABS(F2))/2. 18787 HEVAL = BETA*HEVAL 18788 F1 = F(X0+HEVAL) 18789 F2 = F(X0-HEVAL) 18790 ELSEIF(METHOD.NE.2 .AND. IORD.GE.2) THEN 18791 IF(IORD.EQ.2) THEN 18792 F3 = F1 18793 ELSE 18794 F4 = F1 18795 HEVAL = BETA*HEVAL 18796 F3 = F(X0+HEVAL) 18797 ENDIF 18798 HEVAL = BETA*HEVAL 18799 F2 = F(X0+HEVAL) 18800 HEVAL = BETA*HEVAL 18801 F1 = F(X0+HEVAL) 18802 ENDIF 18803 ENDIF 18804C 18805C EVALUATE A NEW APPROXIMATION DNEW TO THE DERIVATIVE 18806C 18807 IF(N.GT.NMAX) THEN 18808 N = NMAX 18809 DO 400 I = 1,N 18810 MAXF(I-1) = MAXF(I) 18811 400 CONTINUE 18812 ENDIF 18813 IF(METHOD.EQ.2) THEN 18814 MAXF(N) = (ABS(F1)+ABS(F2))/2. 18815 IF(IORD.EQ.1) THEN 18816 DNEW = (F1-F2)/2. 18817 ELSEIF(IORD.EQ.2) THEN 18818 DNEW = F1+F2-TWOF0 18819 ELSE 18820 DNEW = -PDELTA 18821 PDELTA = DELTAF 18822 DELTAF = F1-F2 18823 DNEW = DNEW + .5*DELTAF 18824 IF(MAXF(N).LT.PMAXF) MAXF(N) = PMAXF 18825 PMAXF = MAXFUN 18826 MAXFUN = (ABS(F1)+ABS(F2))/2. 18827 ENDIF 18828 ELSE 18829 MAXF(N) = ABS(F1) 18830 IF(IORD.EQ.1) THEN 18831 DNEW = F1-F0 18832 ELSEIF(IORD.EQ.2) THEN 18833 DNEW = (TWOF0-3*F3+F1)/3. 18834 IF(MAXF(N).LT.ABS(F3)) MAXF(N) = ABS(F3) 18835 F3 = F2 18836 F2 = F1 18837 ELSE 18838 DNEW = C3*F1+C2*F2+C1*F4+C0F0 18839 IF(MAXF(N).LT.ABS(F2)) MAXF(N) = ABS(F2) 18840 IF(MAXF(N).LT.ABS(F4)) MAXF(N) = ABS(F4) 18841 F4 = F3 18842 F3 = F2 18843 F2 = F1 18844 ENDIF 18845 ENDIF 18846 IF(ABS(H).GT.1) THEN 18847 DNEW = DNEW/H**IORD 18848 ELSE 18849 IF(128.*ABS(DNEW).GT.TWOSUP*ABS(H)**IORD) THEN 18850 DNEW = TWOSUP/128. 18851 ELSE 18852 DNEW = DNEW/H**IORD 18853 ENDIF 18854 ENDIF 18855C 18856 IF(INIT.EQ.0) THEN 18857C UPDATE ESTIMATED ACCURACY OF FUNCTION VALUES 18858 NEWACC = ACC 18859 IF((METHOD.NE.2 .OR. IORD.EQ.2) .AND. NEWACC.LT.ACC0) 18860 + NEWACC = ACC0 18861 IF(METHOD.NE.-1 .AND. ABS(NHACC1).LE.1.125*ABS(HEVAL)/BETA4) 18862 + THEN 18863 NHACC1 = HEVAL 18864 PACC1 = FACC1 18865 CALL FACCUR(NHACC1,NEWH1,FACC1,X0,F,TWOINF,F0,F1) 18866 IF(FACC1.LT.PACC1) FACC1=(3*FACC1+PACC1)/4. 18867 ENDIF 18868 IF(METHOD.NE.1 .AND. ABS(NHACC2).LE.1.125*ABS(HEVAL)/BETA4) 18869 + THEN 18870 IF(METHOD.EQ.2) THEN 18871 F1 = F2 18872 NHACC2 = -HEVAL 18873 ELSE 18874 NHACC2 = HEVAL 18875 ENDIF 18876 PACC2 = FACC2 18877 CALL FACCUR(NHACC2,NEWH2,FACC2,X0,F,TWOINF,F0,F1) 18878 IF(FACC2.LT.PACC2) FACC2 = (3*FACC2+PACC2)/4. 18879 ENDIF 18880 IF(METHOD.EQ.1 .AND. NEWACC.LT.FACC1) NEWACC = FACC1 18881 IF(METHOD.EQ.-1 .AND. NEWACC.LT.FACC2) NEWACC = FACC2 18882 IF(METHOD.EQ.2 .AND. NEWACC.LT.(FACC1+FACC2)/2.) 18883 + NEWACC = (FACC1+FACC2)/2. 18884 ENDIF 18885C 18886C EVALUATE SUCCESSIVE ELEMENTS OF THE CURRENT ROW IN THE NEVILLE 18887C ARRAY, ESTIMATING AND EXAMINING THE TRUNCATION AND ROUNDING 18888C ERRORS IN EACH 18889C 18890 CONTIN = N.LT.NMAX 18891 HPREV = ABS(H) 18892 FMAX = MAXF(N) 18893 IF((METHOD.NE.2 .OR. IORD.EQ.2) .AND. FMAX.LT.ABS(F0)) 18894 + FMAX = ABS(F0) 18895C 18896 DO 500 K = 1,N 18897 DPREV = D(K) 18898 D(K) = DNEW 18899 DNEW = DPREV+(DPREV-DNEW)/DENOM(K) 18900 TE = ABS(DNEW-D(K)) 18901 IF(FMAX.LT.MAXF(N-K)) FMAX = MAXF(N-K) 18902 HPREV = HPREV/BETA 18903 IF(NEWACC.GE.RELACC*FMAX) THEN 18904 RE = NEWACC*E(K) 18905 ELSE 18906 RE = RELACC*FMAX*E(K) 18907 ENDIF 18908 IF(RE.NE.0.) THEN 18909 IF(HPREV.GT.1) THEN 18910 RE = RE/HPREV**IORD 18911 ELSEIF(2*RE.GT.TWOSUP*HPREV**IORD) THEN 18912 RE = TWOSUP/2. 18913 ELSE 18914 RE = RE/HPREV**IORD 18915 ENDIF 18916 ENDIF 18917 NEWERR = TE+RE 18918 IF(TE.GT.RE) NEWERR = 1.25*NEWERR 18919 IF(.NOT. IGNORE(K)) THEN 18920 IF((INIT.EQ.0 .OR. (K.EQ.2 .AND. .NOT.IGNORE(1))) 18921 + .AND. NEWERR.LT.ERROR) THEN 18922 DERIV = D(K) 18923 ERROR = NEWERR 18924 ENDIF 18925 IF(INIT.EQ.1 .AND. N.EQ.1) THEN 18926 TDERIV = D(1) 18927 TEMERR = NEWERR 18928 ENDIF 18929 IF(MINERR(K).LT.TWOSUP/4) THEN 18930 S = 4*MINERR(K) 18931 ELSE 18932 S = TWOSUP 18933 ENDIF 18934 IF(TE.GT.RE .OR. NEWERR.GT.S) THEN 18935 IGNORE(K) = .TRUE. 18936 ELSE 18937 CONTIN = .TRUE. 18938 ENDIF 18939 IF(NEWERR.LT.MINERR(K)) MINERR(K) = NEWERR 18940 IF(INIT.EQ.1 .AND. N.EQ.2 .AND. K.EQ.1 .AND. 18941 + .NOT.IGNORE(1)) THEN 18942 IF(NEWERR.LT.TEMERR) THEN 18943 TDERIV = D(1) 18944 TEMERR = NEWERR 18945 ENDIF 18946 IF(TEMERR.LT.ERROR) THEN 18947 DERIV = TDERIV 18948 ERROR = TEMERR 18949 ENDIF 18950 ENDIF 18951 ENDIF 18952 500 CONTINUE 18953C 18954 IF(N.LT.NMAX) D(N+1) = DNEW 18955 IF(EPS.LT.0.) THEN 18956 S = ABS(EPS*DERIV) 18957 ELSE 18958 S = EPS 18959 ENDIF 18960 IF(ERROR.LE.S) THEN 18961 CONTIN = .FALSE. 18962 ELSEIF(INIT.EQ.1 .AND. (N.EQ.2 .OR. IGNORE(1))) THEN 18963 IF((IGNORE(1) .OR. IGNORE(2)) .AND. SAVED) THEN 18964 SAVED = .FALSE. 18965 N = 2 18966 H = BETA * SAVE(0) 18967 HEVAL = BETA*SAVE(1) 18968 MAXF(0) = SAVE(2) 18969 MAXF(1) = SAVE(3) 18970 MAXF(2) = SAVE(4) 18971 D(1) = SAVE(5) 18972 D(2) = SAVE(6) 18973 D(3) = SAVE(7) 18974 MINERR(1) = SAVE(8) 18975 MINERR(2) = SAVE(9) 18976 IF(METHOD.EQ.2 .AND. IORD.EQ.3) THEN 18977 PDELTA = SAVE(10) 18978 DELTAF = SAVE(11) 18979 PMAXF = SAVE(12) 18980 MAXFUN = SAVE(13) 18981 ELSEIF(METHOD.NE.2 .AND. IORD.GE.2) THEN 18982 F2 = SAVE(10) 18983 F3 = SAVE(11) 18984 IF(IORD.EQ.3) F4 = SAVE(12) 18985 ENDIF 18986 INIT = 0 18987 IGNORE(1) = .FALSE. 18988 IGNORE(2) = .FALSE. 18989 ELSEIF(.NOT. (IGNORE(1) .OR. IGNORE(2)) .AND. N.EQ.2 18990 + .AND. BETA4*FACTOR*ABS(HEVAL).LE.MAXH) THEN 18991C SAVE ALL CURRENT VALUES IN CASE OF RETURN TO 18992C CURRENT POINT 18993 SAVED = .TRUE. 18994 SAVE(0) = H 18995 SAVE(1) = HEVAL 18996 SAVE(2) = MAXF(0) 18997 SAVE(3) = MAXF(1) 18998 SAVE(4) = MAXF(2) 18999 SAVE(5) = D(1) 19000 SAVE(6) = D(2) 19001 SAVE(7) = D(3) 19002 SAVE(8) = MINERR(1) 19003 SAVE(9) = MINERR (2) 19004 IF(METHOD.EQ.2 .AND. IORD.EQ.3) THEN 19005 SAVE(10) = PDELTA 19006 SAVE(11) = DELTAF 19007 SAVE(12) = PMAXF 19008 SAVE(13) = MAXFUN 19009 ELSEIF(METHOD.NE.2 .AND. IORD.GE.2) THEN 19010 SAVE(10) = F2 19011 SAVE(11) = F3 19012 IF(IORD.EQ.3) SAVE(12) = F4 19013 ENDIF 19014 H = FACTOR*BASEH 19015 HEVAL = H 19016 BASEH = H 19017 N = -1 19018 ELSE 19019 INIT = 0 19020 H = BETA*H 19021 HEVAL = BETA*HEVAL 19022 ENDIF 19023 ELSEIF(CONTIN .AND. BETA*ABS(HEVAL).LE.MAXH) THEN 19024 H = BETA*H 19025 HEVAL = BETA*HEVAL 19026 ELSEIF(METHOD.NE.1) THEN 19027 CONTIN = .TRUE. 19028 IF(METHOD.EQ.2) THEN 19029 INIT = 3 19030 METHOD = -1 19031 IF(IORD.NE.2) THEN 19032 IF(X0.NE.0.) THEN 19033 CALL FACCUR(0.,-H0,ACC0,X0,F,TWOINF,F0,F1) 19034 ELSE 19035 ACC0 = 0. 19036 ENDIF 19037 ENDIF 19038 ELSE 19039 INIT = 2 19040 METHOD = 1 19041 ENDIF 19042 N = -1 19043 SIGNH = -SIGNH 19044 ELSE 19045 CONTIN = .FALSE. 19046 ENDIF 19047 GOTO 130 19048 800 IF(EPS.LT.0.) THEN 19049 S = ABS(EPS*DERIV) 19050 ELSE 19051 S = EPS 19052 ENDIF 19053 IFAIL = 0 19054 IF(EPS.NE.0. .AND. ERROR.GT.S) IFAIL = 1 19055 RETURN 19056 END 19057 SUBROUTINE DIFFER(NDIM, A, B, WIDTH, Z, DIF, FUNCTN, 19058 & DIVAXN, DIFCLS) 19059* 19060* Compute fourth differences and subdivision axes 19061* 19062 EXTERNAL FUNCTN 19063 INTEGER I, NDIM, DIVAXN, DIFCLS 19064 DOUBLE PRECISION 19065 & A(NDIM), B(NDIM), WIDTH(NDIM), Z(NDIM), DIF(NDIM), FUNCTN 19066 DOUBLE PRECISION FRTHDF, FUNCEN, WIDTHI 19067 DIFCLS = 0 19068 DIVAXN = MOD( DIVAXN, NDIM ) + 1 19069 IF ( NDIM .GT. 1 ) THEN 19070 DO 100 I = 1,NDIM 19071 DIF(I) = 0 19072 Z(I) = A(I) + WIDTH(I) 19073 100 CONTINUE 19074 10 FUNCEN = FUNCTN(NDIM, Z) 19075 DO 200 I = 1,NDIM 19076 WIDTHI = WIDTH(I)/5 19077 FRTHDF = 6*FUNCEN 19078 Z(I) = Z(I) - 4*WIDTHI 19079 FRTHDF = FRTHDF + FUNCTN(NDIM,Z) 19080 Z(I) = Z(I) + 2*WIDTHI 19081 FRTHDF = FRTHDF - 4*FUNCTN(NDIM,Z) 19082 Z(I) = Z(I) + 4*WIDTHI 19083 FRTHDF = FRTHDF - 4*FUNCTN(NDIM,Z) 19084 Z(I) = Z(I) + 2*WIDTHI 19085 FRTHDF = FRTHDF + FUNCTN(NDIM,Z) 19086* Do not include differences below roundoff 19087 IF ( FUNCEN + FRTHDF/8 .NE. FUNCEN ) 19088 & DIF(I) = DIF(I) + ABS(FRTHDF)*WIDTH(I) 19089 Z(I) = Z(I) - 4*WIDTHI 19090 200 CONTINUE 19091 DIFCLS = DIFCLS + 4*NDIM + 1 19092 DO 300 I = 1,NDIM 19093 Z(I) = Z(I) + 2*WIDTH(I) 19094 IF ( Z(I) .LT. B(I) ) GO TO 10 19095 Z(I) = A(I) + WIDTH(I) 19096 300 CONTINUE 19097 DO 400 I = 1,NDIM 19098 IF ( DIF(DIVAXN) .LT. DIF(I) ) DIVAXN = I 19099 400 CONTINUE 19100 ENDIF 19101C 19102 RETURN 19103 END 19104 SUBROUTINE DIGITS(XVAL,IWRITE,XDIGI,NDIGI,ISUBRO,IBUGA3,IERROR) 19105C 19106C PURPOSE--THIS SUBROUTINE RETURNS A VECTOR CONTAINING THE 19107C DIGITS FROM THE POSITIVE INTEGER PART OF A NUMBER 19108C (I.E., FOR NEGATIVE NUMBERS TAKE THE ABSOLUTE VALUE). 19109C INPUT ARGUMENTS--XVAL = THE SINGLE PRECISION VALUE FOR WHICH 19110C THE DIGITS WILL BE EXTRACTED 19111C OUTPUT ARGUMENTS--XDIGI = THE SINGLE PRECISION VECTOR OF THE 19112C COMPUTED DIGITS 19113C --NDIGI = THE INTEGER VALUE OF THE NUMBER OF 19114C DIGITS 19115C OUTPUT--THE COMPUTED SINGLE PRECISION VECTOR OF THE 19116C DIGITS FROM THE INTEGER PART OF THE NUMBER 19117C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 19118C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 19119C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 19120C LANGUAGE--ANSI FORTRAN (1977) 19121C WRITTEN BY--ALAN HECKERT 19122C STATISTICAL ENGINEERING DIVISION 19123C INFORMATION TECHNOLOGY LABORATORY 19124C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS 19125C GAITHERSBURG, MD 20899 19126C PHONE--301-975-2899 19127C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 19128C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGYS. 19129C LANGUAGE--ANSI FORTRAN (1977) 19130C VERSION NUMBER--2015.1 19131C ORIGINAL VERSION--JANUARY 2015. 19132C 19133C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 19134C 19135 CHARACTER*4 IWRITE 19136 CHARACTER*4 ISUBRO 19137 CHARACTER*4 IBUGA3 19138 CHARACTER*4 IERROR 19139C 19140 CHARACTER*4 ISUBN1 19141 CHARACTER*4 ISUBN2 19142 CHARACTER*1 IATEMP 19143 CHARACTER*20 IA 19144C 19145C--------------------------------------------------------------------- 19146C 19147 DIMENSION XDIGI(*) 19148C 19149C--------------------------------------------------------------------- 19150C 19151 INCLUDE 'DPCOP2.INC' 19152C 19153C-----START POINT----------------------------------------------------- 19154C 19155 ISUBN1='DIGI' 19156 ISUBN2='TS ' 19157 IERROR='NO' 19158 NDIGI=0 19159C 19160 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GITS')THEN 19161 WRITE(ICOUT,999) 19162 999 FORMAT(1X) 19163 CALL DPWRST('XXX','BUG ') 19164 WRITE(ICOUT,51) 19165 51 FORMAT('***** AT THE BEGINNING OF DIGITS--') 19166 CALL DPWRST('XXX','BUG ') 19167 WRITE(ICOUT,52)IBUGA3,ISUBRO,IWRITE,XVAL 19168 52 FORMAT('IBUGA3,ISUBRO,IWRITE,XVAL = ',3(A4,2X),G15.7) 19169 CALL DPWRST('XXX','BUG ') 19170 ENDIF 19171C 19172C ******************************************** 19173C ** STEP 1-- ** 19174C ** EXTRACT INTEGER PART OF NUMBER ** 19175C ******************************************** 19176C 19177 EPS=0.0001 19178 XVALT=ABS(XVAL+EPS) 19179 IVAL=INT(XVALT) 19180C 19181C ******************************************** 19182C ** STEP 2-- ** 19183C ** EXTRACT THE DIGITS ** 19184C ******************************************** 19185C 19186C 19187 IA=' ' 19188 WRITE(IA(1:20),'(I20)')IVAL 19189C 19190 DO100I=1,20 19191 IATEMP=IA(I:I) 19192 IF(IATEMP.EQ.'1')THEN 19193 NDIGI=NDIGI+1 19194 XDIGI(NDIGI)=1.0 19195 ELSEIF(IATEMP.EQ.'2')THEN 19196 NDIGI=NDIGI+1 19197 XDIGI(NDIGI)=2.0 19198 ELSEIF(IATEMP.EQ.'3')THEN 19199 NDIGI=NDIGI+1 19200 XDIGI(NDIGI)=3.0 19201 ELSEIF(IATEMP.EQ.'4')THEN 19202 NDIGI=NDIGI+1 19203 XDIGI(NDIGI)=4.0 19204 ELSEIF(IATEMP.EQ.'5')THEN 19205 NDIGI=NDIGI+1 19206 XDIGI(NDIGI)=5.0 19207 ELSEIF(IATEMP.EQ.'6')THEN 19208 NDIGI=NDIGI+1 19209 XDIGI(NDIGI)=6.0 19210 ELSEIF(IATEMP.EQ.'7')THEN 19211 NDIGI=NDIGI+1 19212 XDIGI(NDIGI)=7.0 19213 ELSEIF(IATEMP.EQ.'8')THEN 19214 NDIGI=NDIGI+1 19215 XDIGI(NDIGI)=8.0 19216 ELSEIF(IATEMP.EQ.'9')THEN 19217 NDIGI=NDIGI+1 19218 XDIGI(NDIGI)=9.0 19219 ELSEIF(IATEMP.EQ.'0')THEN 19220 IF(NDIGI.GT.0)THEN 19221 NDIGI=NDIGI+1 19222 XDIGI(NDIGI)=0.0 19223 ENDIF 19224 ENDIF 19225 100 CONTINUE 19226C 19227 IF(NDIGI.EQ.0)THEN 19228 NDIGI=NDIGI+1 19229 XDIGI(NDIGI)=0.0 19230 ENDIF 19231C 19232C ***************** 19233C ** STEP 90-- ** 19234C ** EXIT. ** 19235C ***************** 19236C 19237 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'GITS')THEN 19238 WRITE(ICOUT,999) 19239 CALL DPWRST('XXX','BUG ') 19240 WRITE(ICOUT,9011) 19241 9011 FORMAT('***** AT THE END OF DIGITS--') 19242 CALL DPWRST('XXX','BUG ') 19243 WRITE(ICOUT,9013)NDIGI,IVAL,XVALT,IA 19244 9013 FORMAT('NDIGI,IVAL,XVALT,IA = ',2I8,G15.7,2X,A20) 19245 CALL DPWRST('XXX','BUG ') 19246 DO9014I=1,NDIGI 19247 WRITE(ICOUT,9015)I,XDIGI(I) 19248 9015 FORMAT('I,XDIGI(I) = ',I8,G15.7) 19249 CALL DPWRST('XXX','BUG ') 19250 9014 CONTINUE 19251 ENDIF 19252C 19253 RETURN 19254 END 19255 SUBROUTINE DIPERC(X,N,XPT,IWRITE,DIOUT, 19256 1 IBUGA3,ISUBRO,IERROR) 19257C 19258C PURPOSE--THIS SUBROUTINE COMPUTES THE "PERCENTAGE DIFFERENCE" 19259C STATISTIC Di% GIVEN IN ISO 13528 (P. 25): 19260C 19261C D(i)% = (X(i) - Xpt)/Xpt)*100 19262C 19263C WHERE Xpt IS A CONSENSUS OR ASSIGNED VALUE. 19264C 19265C THE D(i) = X(i) - Xpt OR D(i)% IS COMPARED TO 19266C AN "ALLOWANCE FOR MEASUREMENT ERROR" VALUE 19267C DeltaE. THAT IS 19268C 19269C -DeltaE < D(i) < DeltaE 19270C 19271C THE PERCENTAGE VERSION IS TYPICALLY COMPARED TO 19272C SOME TRANSFORMATION OF DeltaE. 19273C 19274C NOTE THAT XPT AND DELTAE ARE NOT COMPUTED FROM THE 19275C CURRENT DATA. THE XPT IS CONSIDERED THE "TRUE" VALUE 19276C (OR THE BEST GUESS OF THE TRUE VALUE). THE ISO 13528 19277C STANDARD DISCUSSES NUMEROUS WAYS OF DETERMINING THIS 19278C VALUE. THE DELTAE IS AN "ACCEPTABLE" ERROR. THERE IS 19279C NO STANDARD WAY FOR DETERMINING THIS. 19280C 19281C INPUT ARGUMENTS--X = THE SINGLE PRECISION VECTOR OF 19282C (UNSORTED OR SORTED) OBSERVATIONS. 19283C --N = THE INTEGER NUMBER OF OBSERVATIONS 19284C IN THE VECTOR X. 19285C --XPT = THE SINGLE PRECISION VALUE CONTAINING 19286C THE ASSIGNED VALUE 19287C OUTPUT ARGUMENTS--DIOUT = THE SINGLE PRECISION VECTOR OF THE 19288C COMPUTED Di% VALUES. 19289C OUTPUT--THE COMPUTED SINGLE PRECISION VECTOR OF THE SAMPLE Di% 19290C VALUES. 19291C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 19292C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 19293C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 19294C LANGUAGE--ANSI FORTRAN (1977) 19295C REFERENCE--ISO 13528, SECOND EDITION, STATISTICAL METHODS FOR USE 19296C IN PROFICIENCY TESTING BY INTERLABORATORY COMPARISONS, 19297C 2015, PP. 25. 19298C WRITTEN BY--ALAN HECKERT 19299C STATISTICAL ENGINEERING DIVISION 19300C INFORMATION TECHNOLOGY LABORATORY 19301C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 19302C GAITHERSBURG, MD 20899-8980 19303C PHONE--301-975-2899 19304C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 19305C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 19306C LANGUAGE--ANSI FORTRAN (1977) 19307C VERSION NUMBER--2016.2 19308C ORIGINAL VERSION--FEBRUARY 2016. 19309C 19310C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 19311C 19312 CHARACTER*4 IWRITE 19313 CHARACTER*4 IBUGA3 19314 CHARACTER*4 ISUBRO 19315 CHARACTER*4 IERROR 19316C 19317 CHARACTER*4 ISUBN1 19318 CHARACTER*4 ISUBN2 19319C 19320C--------------------------------------------------------------------- 19321C 19322 DIMENSION X(*) 19323 DIMENSION DIOUT(*) 19324C 19325C--------------------------------------------------------------------- 19326C 19327 INCLUDE 'DPCOP2.INC' 19328C 19329C-----START POINT----------------------------------------------------- 19330C 19331 ISUBN1='DIPE' 19332 ISUBN2='RC ' 19333C 19334 IERROR='NO' 19335C 19336 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PERC')THEN 19337 WRITE(ICOUT,999) 19338 999 FORMAT(1X) 19339 CALL DPWRST('XXX','BUG ') 19340 WRITE(ICOUT,51) 19341 51 FORMAT('***** AT THE BEGINNING OF DIPERC--') 19342 CALL DPWRST('XXX','BUG ') 19343 WRITE(ICOUT,52)IBUGA3,N,XPT 19344 52 FORMAT('IBUGA3,N,XPT = ',A4,2X,I8,G15.7) 19345 CALL DPWRST('XXX','BUG ') 19346 DO55I=1,N 19347 WRITE(ICOUT,56)I,X(I) 19348 56 FORMAT('I,X(I) = ',I8,G15.7) 19349 CALL DPWRST('XXX','BUG ') 19350 55 CONTINUE 19351 ENDIF 19352C 19353C ************************ 19354C ** COMPUTE DiPERC ** 19355C ************************ 19356C 19357C ******************************************** 19358C ** STEP 1-- ** 19359C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** 19360C ******************************************** 19361C 19362 AN=N 19363C 19364 IF(N.LT.1)THEN 19365 WRITE(ICOUT,999) 19366 CALL DPWRST('XXX','BUG ') 19367 WRITE(ICOUT,111) 19368 111 FORMAT('***** ERROR IN DIPERC--') 19369 CALL DPWRST('XXX','BUG ') 19370 WRITE(ICOUT,112) 19371 112 FORMAT(' THE NUMBER OF OBSERVATIONS IN THE RESPONSE ', 19372 1 'VARIABLE IS LESS THAN 1.') 19373 CALL DPWRST('XXX','BUG ') 19374 WRITE(ICOUT,117)N 19375 117 FORMAT(' THE NUMBER OF OBSERVATIONS = ',I8,'.') 19376 CALL DPWRST('XXX','BUG ') 19377 IERROR='YES' 19378 GOTO9000 19379 ENDIF 19380C 19381C ***************************** 19382C ** STEP 2-- ** 19383C ** COMPUTE THE DIPERC ** 19384C ***************************** 19385C 19386 DO200I=1,N 19387 DIOUT(I)=((X(I) - XPT)/XPT)*100. 19388 200 CONTINUE 19389C 19390C ******************************* 19391C ** STEP 3-- ** 19392C ** WRITE OUT A LINE ** 19393C ** OF SUMMARY INFORMATION. ** 19394C ******************************* 19395C 19396 IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN 19397 WRITE(ICOUT,999) 19398 CALL DPWRST('XXX','BUG ') 19399 WRITE(ICOUT,811)N 19400 811 FORMAT('THE NUMBER OF DI PERCENT VALUES GENERATED = ',I8) 19401 CALL DPWRST('XXX','BUG ') 19402 ENDIF 19403C 19404C ***************** 19405C ** STEP 90-- ** 19406C ** EXIT. ** 19407C ***************** 19408C 19409 9000 CONTINUE 19410 IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PERC')THEN 19411 WRITE(ICOUT,999) 19412 CALL DPWRST('XXX','BUG ') 19413 WRITE(ICOUT,9011) 19414 9011 FORMAT('***** AT THE END OF DIPERC--') 19415 CALL DPWRST('XXX','BUG ') 19416 DO9012I=1,N 19417 WRITE(ICOUT,9015)I,X(I),DIOUT(I) 19418 9015 FORMAT('I,X(I),PAOUT(I) = ',I8,2G15.7) 19419 CALL DPWRST('XXX','BUG ') 19420 9012 CONTINUE 19421 ENDIF 19422C 19423 RETURN 19424 END 19425 SUBROUTINE DISCDF(IX,N,CDF) 19426C 19427C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION 19428C FUNCTION VALUE FOR THE DISCRETE UNIFORM (RECTANGULAR) 19429C DISTRIBUTION ON THE INTERVAL (0,N). 19430C THIS DISTRIBUTION HAS MEAN = N/2 19431C AND STANDARD DEVIATION = SQRT(N(N+2)/12) 19432C THIS DISTRIBUTION HAS THE PROBABILITY 19433C DENSITY FUNCTION F(X) = 1/(N+1). 19434C IT HAS THE CUMULATIVE PROBABILITY DISTRIBUTION 19435C CDF(X) = (X+1)/(N+1) 19436C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT 19437C WHICH THE CUMULATIVE DISTRIBUTION 19438C FUNCTION IS TO BE EVALUATED. 19439C --N UPPER LIMIT OF DISTRIBUTION 19440C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE 19441C DISTRIBUTION FUNCTION VALUE. 19442C OUTPUT--THE SINGLE PRECISION CUMULATIVE DISTRIBUTION 19443C FUNCTION VALUE CDF. 19444C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 19445C RESTRICTIONS--X SHOULD BE AN INTEGER BETWEEN 0 AND N, INCLUSIVELY. 19446C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 19447C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 19448C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 19449C LANGUAGE--ANSI FORTRAN. 19450C REFERENCES--EVANS, HASTINGS, AND PEACOCK, STATISTICAL 19451C DISTRIBUTIONS, 2ND ED.--1993, CHAPTER 36 19452C WRITTEN BY--JAMES J. FILLIBEN 19453C STATISTICAL ENGINEERING LABORATORY (205.03) 19454C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 19455C GAITHERSBURG, MD 20899-8980 19456C PHONE: 301-975-2855 19457C ORIGINAL VERSION--SEPTEMBER 1994. 19458C UPDATED --DECEMBER 1994. FIX BUG 19459C 19460C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 19461C 19462C--------------------------------------------------------------------- 19463C 19464 INCLUDE 'DPCOP2.INC' 19465C 19466C--------------------------------------------------------------------- 19467C 19468C CHECK THE INPUT ARGUMENTS FOR ERRORS 19469C 19470 IF(IX.LT.0.OR.IX.GT.N)GOTO50 19471 IF(N.LT.1)GOTO60 19472 GOTO90 19473 50 CONTINUE 19474 WRITE(ICOUT,2) 19475 CALL DPWRST('XXX','BUG ') 19476 WRITE(ICOUT,3) 19477 CALL DPWRST('XXX','BUG ') 19478 WRITE(ICOUT,46)IX 19479 CALL DPWRST('XXX','BUG ') 19480 IF(IX.LT.0)CDF=0.0 19481 IF(IX.GT.N)CDF=1.0 19482 RETURN 19483 60 CONTINUE 19484 WRITE(ICOUT,12) 19485 CALL DPWRST('XXX','BUG ') 19486 WRITE(ICOUT,13) 19487 CALL DPWRST('XXX','BUG ') 19488 WRITE(ICOUT,46)N 19489 CALL DPWRST('XXX','BUG ') 19490 CDF=0.0 19491 RETURN 19492 2 FORMAT( 19493 1'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT TO THE') 19494 3 FORMAT( 19495 1' DISCDF SUBROUTINE IS OUTSIDE THE USUAL (0,N) INTERVAL ***') 19496 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') 19497 12 FORMAT( 19498 1'***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE') 19499 13 FORMAT( 19500 1' DISCDF SUBROUTINE IS LESS THAN 1. ***') 19501C 19502C-----START POINT----------------------------------------------------- 19503C 19504 90 CONTINUE 19505 AX=REAL(IX) 19506CCCCC FIX FOLLOWING LINE. DECEMBER 1994. 19507CCCCC AN=REAL(AN) 19508 AN=REAL(N) 19509 CDF=(AX+1.0)/(AN+1.0) 19510C 19511 RETURN 19512 END 19513 SUBROUTINE DISPDF(IX,N,PDF) 19514C 19515C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY 19516C FUNCTION VALUE FOR THE DISCRETE UNIFORM (RECTANGULAR) 19517C DISTRIBUTION ON THE INTERVAL (0,N). 19518C THIS DISTRIBUTION HAS MEAN = N/2 19519C AND STANDARD DEVIATION = SQRT(N(N+2)/12) 19520C THIS DISTRIBUTION HAS THE PROBABILITY 19521C DENSITY FUNCTION F(X) = 1/(N+1) 19522C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT 19523C WHICH THE PROBABILITY DENSITY 19524C FUNCTION IS TO BE EVALUATED. 19525C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION PROBABILITY 19526C DENSITY FUNCTION VALUE. 19527C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY 19528C FUNCTION VALUE PDF. 19529C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 19530C RESTRICTIONS--X SHOULD BE BETWEEN 0 AND 1, INCLUSIVELY. 19531C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 19532C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 19533C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 19534C LANGUAGE--ANSI FORTRAN. 19535C REFERENCES--JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE 19536C DISTRIBUTIONS--2, 1970, PAGES 57-74. 19537C WRITTEN BY--JAMES J. FILLIBEN 19538C STATISTICAL ENGINEERING LABORATORY (205.03) 19539C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 19540C GAITHERSBURG, MD 20899-8980 19541C PHONE: 301-975-2855 19542C ORIGINAL VERSION--SEPTEMBER 1994. 19543C 19544C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 19545C 19546C--------------------------------------------------------------------- 19547C 19548 INCLUDE 'DPCOP2.INC' 19549C 19550C--------------------------------------------------------------------- 19551C 19552C CHECK THE INPUT ARGUMENTS FOR ERRORS 19553C 19554 PDF=0.0 19555 IF(IX.LT.0.OR.IX.GT.N)GOTO50 19556 IF(N.LT.1)GOTO60 19557 GOTO90 19558 50 CONTINUE 19559 WRITE(ICOUT,2) 19560 CALL DPWRST('XXX','BUG ') 19561 WRITE(ICOUT,3) 19562 CALL DPWRST('XXX','BUG ') 19563 WRITE(ICOUT,46)IX 19564 CALL DPWRST('XXX','BUG ') 19565 RETURN 19566 60 CONTINUE 19567 WRITE(ICOUT,12) 19568 CALL DPWRST('XXX','BUG ') 19569 WRITE(ICOUT,13) 19570 CALL DPWRST('XXX','BUG ') 19571 WRITE(ICOUT,46)N 19572 CALL DPWRST('XXX','BUG ') 19573 RETURN 19574 2 FORMAT( 19575 1'***** NON-FATAL DIAGNOSTIC--THE FIRST INPUT ARGUMENT TO THE') 19576 3 FORMAT( 19577 1' DISPDF SUBROUTINE IS OUTSIDE THE USUAL (0,N) INTERVAL **') 19578 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') 19579 12 FORMAT( 19580 1'***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE') 19581 13 FORMAT( 19582 1' DISPDF SUBROUTINE IS LESS THAN 1. **') 19583C 19584C-----START POINT----------------------------------------------------- 19585C 19586 90 CONTINUE 19587 PDF=1.0/REAL(N+1) 19588C 19589 RETURN 19590 END 19591 SUBROUTINE DISPPF(P,N,PPF) 19592C 19593C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT 19594C FUNCTION VALUE FOR THE DISCRETE UNIFORM (RECTANGUALAR) 19595C DISTRIBUTION FROM 0 TO N 19596C THIS DISTRIBUTION HAS THE PROBABILITY DENSITY FUNCTION 19597C F(X)=1/(N+1) 19598C IT HAS THE PPF FUNCTION G(P)=P*(N+1)-1. 19599C NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION 19600C IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE 19601C DISTRIBUTION FUNCTION OF THE DISTRIBUTION. 19602C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE 19603C (BETWEEN 0.0 AND 1.0) 19604C AT WHICH THE PERCENT POINT 19605C FUNCTION IS TO BE EVALUATED. 19606C --N = UPPER LIMIT OF THE DISTRIBUTION 19607C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT 19608C POINT FUNCTION VALUE. 19609C OUTPUT--THE SINGLE PRECISION PERCENT POINT 19610C FUNCTION VALUE PPF. 19611C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 19612C RESTRICTIONS--P SHOULD BE BETWEEN 0.0 AND 1.0, INCLUSIVELY. 19613C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 19614C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 19615C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 19616C LANGUAGE--ANSI FORTRAN (1977) 19617C WRITTEN BY--JAMES J. FILLIBEN 19618C STATISTICAL ENGINEERING DIVISION 19619C INFORMATION TECHNOLOGY LABORATORY 19620C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 19621C GAITHERSBURG, MD 20899-8980 19622C PHONE--301-975-2855 19623C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 19624C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 19625C LANGUAGE--ANSI FORTRAN (1966) 19626C VERSION NUMBER--94.9 19627C ORIGINAL VERSION--SEPTEMBER 1994. 19628C 19629C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 19630C 19631C--------------------------------------------------------------------- 19632C 19633 INCLUDE 'DPCOP2.INC' 19634C 19635C-----START POINT----------------------------------------------------- 19636C CHECK THE INPUT ARGUMENTS FOR ERRORS 19637C 19638 IF(P.LT.0.0.OR.P.GT.1.0)GOTO50 19639 IF(N.LT.1)GOTO60 19640 GOTO90 19641 50 WRITE(ICOUT,1) 19642 CALL DPWRST('XXX','BUG ') 19643 WRITE(ICOUT,46)P 19644 CALL DPWRST('XXX','BUG ') 19645 RETURN 19646 60 CONTINUE 19647 WRITE(ICOUT,12) 19648 CALL DPWRST('XXX','BUG ') 19649 WRITE(ICOUT,13) 19650 CALL DPWRST('XXX','BUG ') 19651 WRITE(ICOUT,47)N 19652 CALL DPWRST('XXX','BUG ') 19653 PPF=0.0 19654 RETURN 19655 90 CONTINUE 19656 1 FORMAT('***** FATAL ERROR--THE 1ST INPUT ARGUMENT TO THE ', 19657 1'DISPPF SUBROUTINE IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL') 19658 12 FORMAT( 19659 1'***** FATAL DIAGNOSTIC--THE SECOND INPUT ARGUMENT TO THE') 19660 13 FORMAT( 19661 1' DISPDF SUBROUTINE IS LESS THAN 1. **') 19662 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',E15.8,' *****') 19663 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8,' *****') 19664C 19665C-----START POINT----------------------------------------------------- 19666C 19667 PPF=P*(REAL(N)+1.0)-1.0 19668 IPPF=INT(PPF) 19669 IF(IPPF.LT.0)IPPF=0 19670 IF(IPPF.GT.N)IPPF=N 19671 PPF=REAL(IPPF) 19672 RETURN 19673 END 19674 SUBROUTINE DISTIN(X,NX,IWRITE,Y,NY,IBUGA3,IERROR) 19675C 19676C PURPOSE--COMPUTE DISTINCT VALUES OF A VARIABLE-- 19677C Y(1) = X(1) 19678C Y(2) = X(2) OR X(3) OR X(4) ETC., THE FIRST ONE 19679C OF WHICH IS DIFFERENT FROM Y(1); 19680C Y(3) = X(3) OR X(4) OR X(5) ETC., THE FIRST ONE 19681C OF WHICH IS DIFFERENT FROM Y(1) AND Y(2); 19682C ETC. 19683C NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.) 19684C BEING IDENTICAL TO THE INPUT VECTOR X(.). 19685C WRITTEN BY--JAMES J. FILLIBEN 19686C STATISTICAL ENGINEERING DIVISION 19687C INFORMATION TECHNOLOGY LABORATORY 19688C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 19689C GAITHERSBURG, MD 20899-8980 19690C PHONE--301-921-3651 19691C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 19692C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 19693C LANGUAGE--ANSI FORTRAN (1977) 19694C VERSION NUMBER--82/7 19695C ORIGINAL VERSION--FEBRUARY 1979. 19696C UPDATED --APRIL 1979. 19697C UPDATED --AUGUST 1981. 19698C UPDATED --MAY 1982. 19699C 19700C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 19701C 19702 CHARACTER*4 IWRITE 19703 CHARACTER*4 IBUGA3 19704 CHARACTER*4 IERROR 19705C 19706 CHARACTER*4 ISUBN1 19707 CHARACTER*4 ISUBN2 19708C 19709C--------------------------------------------------------------------- 19710C 19711 DIMENSION X(*) 19712 DIMENSION Y(*) 19713C 19714C--------------------------------------------------------------------- 19715C 19716 INCLUDE 'DPCOP2.INC' 19717C 19718C-----START POINT----------------------------------------------------- 19719C 19720 ISUBN1='DIST' 19721 ISUBN2='IN ' 19722 IERROR='NO' 19723C 19724 IF(IBUGA3.EQ.'ON')THEN 19725 WRITE(ICOUT,999) 19726 999 FORMAT(1X) 19727 CALL DPWRST('XXX','BUG ') 19728 WRITE(ICOUT,51) 19729 51 FORMAT('***** AT THE BEGINNING OF DISTIN--') 19730 CALL DPWRST('XXX','BUG ') 19731 WRITE(ICOUT,52)IBUGA3,IWRITE,NX 19732 52 FORMAT('IBUGA3,IWRITE,NX = ',2(A4,2X),I8) 19733 CALL DPWRST('XXX','BUG ') 19734 DO55I=1,NX 19735 WRITE(ICOUT,56)I,X(I) 19736 56 FORMAT('I,X(I) = ',I8,G15.7) 19737 CALL DPWRST('XXX','BUG ') 19738 55 CONTINUE 19739 ENDIF 19740C 19741C ******************************** 19742C ** COMPUTE DISTINCT VALUES. ** 19743C ******************************** 19744C 19745 NY=0 19746 IF(NX.LT.1)THEN 19747 IERROR='YES' 19748 WRITE(ICOUT,999) 19749 CALL DPWRST('XXX','BUG ') 19750 WRITE(ICOUT,151) 19751 151 FORMAT('***** ERROR IN DISTIN (DISTINCT)--') 19752 CALL DPWRST('XXX','BUG ') 19753 WRITE(ICOUT,152) 19754 152 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE RESPONSE') 19755 CALL DPWRST('XXX','BUG ') 19756 WRITE(ICOUT,153) 19757 153 FORMAT(' VARIABLE IS LESS THAN ONE.') 19758 CALL DPWRST('XXX','BUG ') 19759 WRITE(ICOUT,157)NX 19760 157 FORMAT(' THE NUMBER OF OBSERVATIONS HERE = ',I8,'.') 19761 CALL DPWRST('XXX','BUG ') 19762 ELSE 19763 NY=1 19764 Y(NY)=X(1) 19765 IF(NX.LT.2)GOTO9000 19766 DO100I=2,NX 19767 DO120J=1,NY 19768 IF(X(I).EQ.Y(J))GOTO100 19769 120 CONTINUE 19770 NY=NY+1 19771 Y(NY)=X(I) 19772 100 CONTINUE 19773 ENDIF 19774C 19775C ***************** 19776C ** STEP 90-- ** 19777C ** EXIT. ** 19778C ***************** 19779C 19780 9000 CONTINUE 19781C 19782 IF(IBUGA3.EQ.'OFF')GOTO9090 19783 WRITE(ICOUT,999) 19784 CALL DPWRST('XXX','BUG ') 19785 WRITE(ICOUT,9011) 19786 9011 FORMAT('***** AT THE END OF DISTIN--') 19787 CALL DPWRST('XXX','BUG ') 19788 WRITE(ICOUT,9012)IBUGA3,IERROR 19789 9012 FORMAT('IBUGA3,IERROR = ',A4,2X,A4) 19790 CALL DPWRST('XXX','BUG ') 19791 WRITE(ICOUT,9013)NX,NY 19792 9013 FORMAT('NX,NY = ',2I8) 19793 CALL DPWRST('XXX','BUG ') 19794 DO9015I=1,NX 19795 WRITE(ICOUT,9016)I,X(I),Y(I) 19796 9016 FORMAT('I,X(I),Y(I) = ',I8,2E15.7) 19797 CALL DPWRST('XXX','BUG ') 19798 9015 CONTINUE 19799 9090 CONTINUE 19800C 19801 RETURN 19802 END 19803 SUBROUTINE DISTI2(X,NX,IWRITE,Y,NY,IBUGA3,IERROR) 19804C 19805C PURPOSE--COMPUTE DISTI2CT VALUES OF A VARIABLE-- 19806C Y(1) = X(1) 19807C Y(2) = X(2) OR X(3) OR X(4) ETC., THE FIRST ONE 19808C OF WHICH IS DIFFERENT FROM Y(1); 19809C Y(3) = X(3) OR X(4) OR X(5) ETC., THE FIRST ONE 19810C OF WHICH IS DIFFERENT FROM Y(1) AND Y(2); 19811C ETC. 19812C NOTE--IT IS PERMISSIBLE TO HAVE THE OUTPUT VECTOR Y(.) 19813C BEING IDENTICAL TO THE INPUT VECTOR X(.). 19814C NOTE--THIS IS IDENTICAL TO DISTIN WITH THE EXCEPTION THAT 19815C THIS VERSION WORKS ON DOUBLE PREICISION ARRAYS. 19816C WRITTEN BY--JAMES J. FILLIBEN 19817C STATISTICAL ENGINEERING DIVISION 19818C INFORMATION TECHNOLOGY LABORATORY 19819C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 19820C GAITHERSBURG, MD 20899-8980 19821C PHONE--301-921-3651 19822C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 19823C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 19824C LANGUAGE--ANSI FORTRAN (1977) 19825C VERSION NUMBER--97/8 19826C ORIGINAL VERSION--AUGUST 1997. 19827C 19828C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 19829C 19830 CHARACTER*4 IWRITE 19831 CHARACTER*4 IBUGA3 19832 CHARACTER*4 IERROR 19833C 19834 CHARACTER*4 ISUBN1 19835 CHARACTER*4 ISUBN2 19836C 19837C--------------------------------------------------------------------- 19838C 19839 DOUBLE PRECISION X(*) 19840 DOUBLE PRECISION Y(*) 19841C 19842C--------------------------------------------------------------------- 19843C 19844 INCLUDE 'DPCOP2.INC' 19845C 19846C-----START POINT----------------------------------------------------- 19847C 19848 ISUBN1='DIST' 19849 ISUBN2='IN ' 19850 IERROR='NO' 19851C 19852 IF(IBUGA3.EQ.'ON')THEN 19853 WRITE(ICOUT,999) 19854 999 FORMAT(1X) 19855 CALL DPWRST('XXX','BUG ') 19856 WRITE(ICOUT,51) 19857 51 FORMAT('***** AT THE BEGINNING OF DISTI2--') 19858 CALL DPWRST('XXX','BUG ') 19859 WRITE(ICOUT,52)IBUGA3,IWRITE,NX 19860 52 FORMAT('IBUGA3,IWRITE,NX = ',2(A4,2X),I8) 19861 CALL DPWRST('XXX','BUG ') 19862 DO55I=1,NX 19863 WRITE(ICOUT,56)I,X(I) 19864 56 FORMAT('I,X(I) = ',I8,G15.7) 19865 CALL DPWRST('XXX','BUG ') 19866 55 CONTINUE 19867 ENDIF 19868C 19869C ******************************** 19870C ** COMPUTE DISTI2CT VALUES. ** 19871C ******************************** 19872C 19873 NY=0 19874 IF(NX.LT.1)GOTO150 19875 DO100I=1,NX 19876 IF(I.EQ.1)GOTO130 19877 DO120J=1,NY 19878 IF(X(I).EQ.Y(J))GOTO100 19879 120 CONTINUE 19880 130 CONTINUE 19881 NY=NY+1 19882 Y(NY)=X(I) 19883 100 CONTINUE 19884 GOTO190 19885C 19886 150 CONTINUE 19887 IERROR='YES' 19888 WRITE(ICOUT,999) 19889 CALL DPWRST('XXX','BUG ') 19890 WRITE(ICOUT,151) 19891 151 FORMAT('***** ERROR IN DISTI2--') 19892 CALL DPWRST('XXX','BUG ') 19893 WRITE(ICOUT,152) 19894 152 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS') 19895 CALL DPWRST('XXX','BUG ') 19896 WRITE(ICOUT,153) 19897 153 FORMAT(' IN THE VARIABLE FOR WHICH') 19898 CALL DPWRST('XXX','BUG ') 19899 WRITE(ICOUT,154) 19900 154 FORMAT(' THE DISTI2CT VALUES ARE TO BE FOUND') 19901 CALL DPWRST('XXX','BUG ') 19902 WRITE(ICOUT,155) 19903 155 FORMAT(' MUST BE 1 OR LARGER.') 19904 CALL DPWRST('XXX','BUG ') 19905 WRITE(ICOUT,156) 19906 156 FORMAT(' SUCH WAS NOT THE CASE HERE.') 19907 CALL DPWRST('XXX','BUG ') 19908 WRITE(ICOUT,157)NX 19909 157 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS HERE = ',I8, 19910 1'.') 19911 CALL DPWRST('XXX','BUG ') 19912C 19913 190 CONTINUE 19914C 19915C ***************** 19916C ** STEP 90-- ** 19917C ** EXIT. ** 19918C ***************** 19919C 19920 IF(IBUGA3.EQ.'ON')THEN 19921 WRITE(ICOUT,999) 19922 CALL DPWRST('XXX','BUG ') 19923 WRITE(ICOUT,9011) 19924 9011 FORMAT('***** AT THE END OF DISTI2--') 19925 CALL DPWRST('XXX','BUG ') 19926 WRITE(ICOUT,9012)IERROR,NX,NY 19927 9012 FORMAT('IERROR,NX,NY = ',A4,2X,2I8) 19928 CALL DPWRST('XXX','BUG ') 19929 DO9015I=1,MAX(NX,NY) 19930 WRITE(ICOUT,9016)I,X(I),Y(I) 19931 9016 FORMAT('I,X(I),Y(I) = ',I8,2G15.7) 19932 CALL DPWRST('XXX','BUG ') 19933 9015 CONTINUE 19934 ENDIF 19935C 19936 RETURN 19937 END 19938 SUBROUTINE DIWCDF(X,Q,BETA,CDF) 19939C 19940C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION 19941C FUNCTION VALUE FOR THE DISCRETE WEIBULL 19942C DISTRIBUTION WITH SHAPE PARAMETERS Q AND BETA. 19943C THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER X >= 0. 19944C THE CUMULATIVE DISTRIBUTION FUNCTION IS: 19945C F(X;Q,BETA) = 1 - (Q)**((X+1)**BETA) 19946C X = 0, 1, 2, ...; 0 < Q < 1; BETA > 0 19947C INPUT ARGUMENTS--X = THE DOUBLE PRECISION VALUE AT 19948C WHICH THE CUMULATIVE DISTRIBUTION 19949C FUNCTION IS TO BE EVALUATED. 19950C X SHOULD BE A NON-NEGATIVE INTEGER. 19951C --Q = THE DOUBLE PRECISION VALUE OF THE 19952C FIRST SHAPE PARAMETER 19953C --BETA = THE DOUBLE PRECISION VALUE OF THE 19954C SECOND SHAPE PARAMETER 19955C OUTPUT ARGUMENTS--CDF = THE DOUBLE PRECISION CUMULATIVE 19956C DISTRIBUTION FUNCTION VALUE. 19957C OUTPUT--THE DOUBLE PRECISION CUMULATIVE DISTRIBUTION FUNCTION 19958C VALUE CDF FOR THE DISCRETE WEIBULL DISTRIBUTION WITH 19959C SHAPE PARAMETERS Q AND BETA 19960C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 19961C RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER 19962C --0 < Q < 1; BETA > 0 19963C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 19964C LANGUAGE--ANSI FORTRAN (1977) 19965C REFERENCES--JOHNSON, KEMP, AND KOTZ (2005), "UNIVARIATE DISCRETE 19966C DISTRIBUTIONS", THIRD EDITION, WILEY, PP. 510-511. 19967C --NAKAGAWA AND OSAKI (1975), "THE DISCRETE WEIBULL 19968C DISTRIBUTION", IEEE TRANSACTIONS ON RELIABILITY, 19969C R-24, PP. 300-301. 19970C WRITTEN BY--JAMES J. FILLIBEN 19971C STATISTICAL ENGINEERING DIVISION 19972C INFORMATION TECHNOLOGY LABORATORY 19973C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 19974C GAITHERSBURG, MD 20899-8980 19975C PHONE--301-975-2855 19976C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 19977C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 19978C LANGUAGE--ANSI FORTRAN (1977) 19979C VERSION NUMBER--2006/11 19980C ORIGINAL VERSION--NOVEMBER 2006. 19981C 19982C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 19983C 19984C--------------------------------------------------------------------- 19985C 19986 DOUBLE PRECISION X 19987 DOUBLE PRECISION Q 19988 DOUBLE PRECISION BETA 19989 DOUBLE PRECISION CDF 19990 DOUBLE PRECISION DTERM1 19991C 19992C--------------------------------------------------------------------- 19993C 19994 INCLUDE 'DPCOP2.INC' 19995C 19996C-----START POINT----------------------------------------------------- 19997C 19998C CHECK THE INPUT ARGUMENTS FOR ERRORS 19999C 20000 IX=INT(X+0.5D0) 20001 IF(IX.LT.0)THEN 20002 WRITE(ICOUT,4) 20003 CALL DPWRST('XXX','BUG ') 20004 WRITE(ICOUT,46)X 20005 CALL DPWRST('XXX','BUG ') 20006 CDF=0.0D0 20007 GOTO9000 20008 ENDIF 20009 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO DIWCDF IS LESS ', 20010 1'THAN 0') 20011C 20012 IF(Q.LE.0.0D0 .OR. Q.GE.1.0D0)THEN 20013 WRITE(ICOUT,15) 20014 CALL DPWRST('XXX','BUG ') 20015 WRITE(ICOUT,46)Q 20016 CALL DPWRST('XXX','BUG ') 20017 CDF=0.0D0 20018 GOTO9000 20019 ENDIF 20020 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO DIWCDF IS NOT IN ', 20021 1'THE INTERVAL (0,1)') 20022C 20023 IF(BETA.LE.0.0D0)THEN 20024 WRITE(ICOUT,25) 20025 CALL DPWRST('XXX','BUG ') 20026 WRITE(ICOUT,46)BETA 20027 CALL DPWRST('XXX','BUG ') 20028 CDF=0.0 20029 GOTO9000 20030 ENDIF 20031 25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO DIWCDF IS NEGATIVE') 20032C 20033 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 20034C 20035 DTERM1=((X+1.0D0)**BETA)*DLOG(Q) 20036 CDF=1.0D0 - DEXP(DTERM1) 20037C 20038 9000 CONTINUE 20039 RETURN 20040 END 20041 SUBROUTINE DIWHAZ(X,Q,BETA,HAZ) 20042C 20043C PURPOSE--THIS SUBROUTINE COMPUTES THE HAZARD 20044C FUNCTION VALUE FOR THE DISCRETE WEIBULL 20045C DISTRIBUTION WITH SHAPE PARAMETERS Q AND BETA. 20046C THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER X >= 0. 20047C THE HAZARD FUNCTION IS: 20048C h(X;Q,BETA) = 1 - (Q)**(X+1)**BETA/(Q)**(X**BETA) 20049C X = 0, 1, 2, ...; 0 < Q < 1; BETA > 0 20050C INPUT ARGUMENTS--X = THE DOUBLE PRECISION VALUE AT 20051C WHICH THE PROBABILITYU MASS 20052C FUNCTION IS TO BE EVALUATED. 20053C X SHOULD BE A NON-NEGATIVE INTEGER. 20054C --Q = THE DOUBLE PRECISION VALUE OF THE 20055C FIRST SHAPE PARAMETER 20056C --BETA = THE DOUBLE PRECISION VALUE OF THE 20057C SECOND SHAPE PARAMETER 20058C OUTPUT ARGUMENTS--HAZ = THE DOUBLE PRECISION HAZARD 20059C FUNCTION VALUE. 20060C OUTPUT--THE DOUBLE PRECISION HAZARD FUNCTION 20061C VALUE HAZ FOR THE DISCRETE WEIBULL DISTRIBUTION WITH 20062C SHAPE PARAMETERS Q AND BETA 20063C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 20064C RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER 20065C --0 < Q < 1; BETA > 0 20066C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 20067C LANGUAGE--ANSI FORTRAN (1977) 20068C REFERENCES--JOHNSON, KEMP, AND KOTZ (2005), "UNIVARIATE DISCRETE 20069C DISTRIBUTIONS", THIRD EDITION, WILEY, PP. 515-516. 20070C --NAKAGAWA AND OSAKI (1975), "THE DISCRETE WEIBULL 20071C DISTRIBUTION", IEEE TRANSACTIONS ON RELIABILITY, 20072C R-24, PP. 300-301. 20073C WRITTEN BY--JAMES J. FILLIBEN 20074C STATISTICAL ENGINEERING DIVISION 20075C INFORMATION TECHNOLOGY LABORATORY 20076C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 20077C GAITHERSBURG, MD 20899-8980 20078C PHONE--301-975-2855 20079C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 20080C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 20081C LANGUAGE--ANSI FORTRAN (1977) 20082C VERSION NUMBER--2006/11 20083C ORIGINAL VERSION--NOVEMBER 2006. 20084C 20085C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 20086C 20087C--------------------------------------------------------------------- 20088C 20089 DOUBLE PRECISION X 20090 DOUBLE PRECISION Q 20091 DOUBLE PRECISION BETA 20092 DOUBLE PRECISION HAZ 20093 DOUBLE PRECISION DTERM1 20094 DOUBLE PRECISION DTERM2 20095C 20096C--------------------------------------------------------------------- 20097C 20098 INCLUDE 'DPCOP2.INC' 20099C 20100C-----START POINT----------------------------------------------------- 20101C 20102C CHECK THE INPUT ARGUMENTS FOR ERRORS 20103C 20104 IX=INT(X+0.5D0) 20105 IF(IX.LT.0)THEN 20106 WRITE(ICOUT,4) 20107 CALL DPWRST('XXX','BUG ') 20108 WRITE(ICOUT,46)X 20109 CALL DPWRST('XXX','BUG ') 20110 HAZ=0.0D0 20111 GOTO9000 20112 ENDIF 20113 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO DIWHAZ IS LESS ', 20114 1'THAN 0') 20115C 20116 IF(Q.LE.0.0D0 .OR. Q.GE.1.0D0)THEN 20117 WRITE(ICOUT,15) 20118 CALL DPWRST('XXX','BUG ') 20119 WRITE(ICOUT,46)Q 20120 CALL DPWRST('XXX','BUG ') 20121 HAZ=0.0D0 20122 GOTO9000 20123 ENDIF 20124 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO DIWHAZ IS NOT IN ', 20125 1'THE INTERVAL (0,1)') 20126C 20127 IF(BETA.LE.0.0D0)THEN 20128 WRITE(ICOUT,25) 20129 CALL DPWRST('XXX','BUG ') 20130 WRITE(ICOUT,46)BETA 20131 CALL DPWRST('XXX','BUG ') 20132 HAZ=0.0 20133 GOTO9000 20134 ENDIF 20135 25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO DIWHAZ IS NEGATIVE') 20136C 20137 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 20138C 20139 DTERM1=((X+1.0D0)**BETA)*DLOG(Q) 20140 DTERM2=(X**BETA)*DLOG(Q) 20141 HAZ=1.0D0 - DEXP(DTERM1 - DTERM2) 20142C 20143 9000 CONTINUE 20144 RETURN 20145 END 20146 SUBROUTINE DIWPDF(X,Q,BETA,PDF) 20147C 20148C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY MASS 20149C FUNCTION VALUE FOR THE DISCRETE WEIBULL 20150C DISTRIBUTION WITH SHAPE PARAMETERS Q AND BETA. 20151C THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER X >= 0. 20152C THE PROBABILITY MASS FUNCTION IS: 20153C p(X;Q,BETA) = (Q)**(X**BETA) - (Q)**((X+1)**BETA) 20154C X = 0, 1, 2, ...; 0 < Q < 1; BETA > 0 20155C INPUT ARGUMENTS--X = THE DOUBLE PRECISION VALUE AT 20156C WHICH THE PROBABILITYU MASS 20157C FUNCTION IS TO BE EVALUATED. 20158C X SHOULD BE A NON-NEGATIVE INTEGER. 20159C --Q = THE DOUBLE PRECISION VALUE OF THE 20160C FIRST SHAPE PARAMETER 20161C --BETA = THE DOUBLE PRECISION VALUE OF THE 20162C SECOND SHAPE PARAMETER 20163C OUTPUT ARGUMENTS--PDF = THE DOUBLE PRECISION PROBABILITY MASS 20164C FUNCTION VALUE. 20165C OUTPUT--THE DOUBLE PRECISION PROBABILITY MASS FUNCTION 20166C VALUE PDF FOR THE DISCRETE WEIBULL DISTRIBUTION WITH 20167C SHAPE PARAMETERS Q AND BETA 20168C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 20169C RESTRICTIONS--X SHOULD BE A NON-NEGATIVE INTEGER 20170C --0 < Q < 1; BETA > 0 20171C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 20172C LANGUAGE--ANSI FORTRAN (1977) 20173C REFERENCES--JOHNSON, KEMP, AND KOTZ (2005), "UNIVARIATE DISCRETE 20174C DISTRIBUTIONS", THIRD EDITION, WILEY, PP. 510-511. 20175C --NAKAGAWA AND OSAKI (1975), "THE DISCRETE WEIBULL 20176C DISTRIBUTION", IEEE TRANSACTIONS ON RELIABILITY, 20177C R-24, PP. 300-301. 20178C WRITTEN BY--JAMES J. FILLIBEN 20179C STATISTICAL ENGINEERING DIVISION 20180C INFORMATION TECHNOLOGY LABORATORY 20181C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 20182C GAITHERSBURG, MD 20899-8980 20183C PHONE--301-975-2855 20184C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 20185C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 20186C LANGUAGE--ANSI FORTRAN (1977) 20187C VERSION NUMBER--2006/11 20188C ORIGINAL VERSION--NOVEMBER 2006. 20189C 20190C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 20191C 20192C--------------------------------------------------------------------- 20193C 20194 DOUBLE PRECISION X 20195 DOUBLE PRECISION Q 20196 DOUBLE PRECISION BETA 20197 DOUBLE PRECISION PDF 20198 DOUBLE PRECISION DTERM1 20199 DOUBLE PRECISION DTERM2 20200C 20201C--------------------------------------------------------------------- 20202C 20203 INCLUDE 'DPCOP2.INC' 20204C 20205C-----START POINT----------------------------------------------------- 20206C 20207C CHECK THE INPUT ARGUMENTS FOR ERRORS 20208C 20209 IX=INT(X+0.5D0) 20210 IF(IX.LT.0)THEN 20211 WRITE(ICOUT,4) 20212 CALL DPWRST('XXX','BUG ') 20213 WRITE(ICOUT,46)X 20214 CALL DPWRST('XXX','BUG ') 20215 PDF=0.0D0 20216 GOTO9000 20217 ENDIF 20218 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO DIWPDF IS LESS ', 20219 1'THAN 0') 20220C 20221 IF(Q.LE.0.0D0 .OR. Q.GE.1.0D0)THEN 20222 WRITE(ICOUT,15) 20223 CALL DPWRST('XXX','BUG ') 20224 WRITE(ICOUT,46)Q 20225 CALL DPWRST('XXX','BUG ') 20226 PDF=0.0D0 20227 GOTO9000 20228 ENDIF 20229 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO DIWPDF IS NOT IN ', 20230 1'THE INTERVAL (0,1)') 20231C 20232 IF(BETA.LE.0.0D0)THEN 20233 WRITE(ICOUT,25) 20234 CALL DPWRST('XXX','BUG ') 20235 WRITE(ICOUT,46)BETA 20236 CALL DPWRST('XXX','BUG ') 20237 PDF=0.0 20238 GOTO9000 20239 ENDIF 20240 25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO DIWPDF IS NEGATIVE') 20241C 20242 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 20243C 20244 DTERM1=(X**BETA)*DLOG(Q) 20245 DTERM2=((X+1)**BETA)*DLOG(Q) 20246 PDF=DEXP(DTERM1) - DEXP(DTERM2) 20247C 20248 9000 CONTINUE 20249 RETURN 20250 END 20251 SUBROUTINE DIWPPF(P,Q,BETA,PPF) 20252C 20253C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT 20254C FUNCTION VALUE FOR THE DISCRETE WEIBULL 20255C DISTRIBUTION WITH SHAPE PARAMETERS Q AND BETA. 20256C THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER X >= 0. 20257C THE PERCENT POINT FUNCTION IS: 20258C G(P;Q,BETA) = {LOG(1-P)/LOG(Q)]**(1/BETA) 0 <= P < 1 20259C INPUT ARGUMENTS--P = THE DOUBLE PRECISION VALUE AT 20260C WHICH THE PERCENT POINT 20261C FUNCTION IS TO BE EVALUATED. 20262C P SHOULD BE IN THE INTERVAL (0,1] 20263C --Q = THE DOUBLE PRECISION VALUE OF THE 20264C FIRST SHAPE PARAMETER 20265C --BETA = THE DOUBLE PRECISION VALUE OF THE 20266C SECOND SHAPE PARAMETER 20267C OUTPUT ARGUMENTS--PPF = THE DOUBLE PRECISION PERCENT POINT 20268C FUNCTION VALUE. 20269C OUTPUT--THE DOUBLE PRECISION PERCENT POINT FUNCTION 20270C VALUE PPF FOR THE DISCRETE WEIBULL DISTRIBUTION WITH 20271C SHAPE PARAMETERS Q AND BETA 20272C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 20273C RESTRICTIONS--0 <= P < 1; 0 < Q < 1; BETA > 0 20274C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 20275C LANGUAGE--ANSI FORTRAN (1977) 20276C REFERENCES--JOHNSON, KEMP, AND KOTZ (2005), "UNIVARIATE DISCRETE 20277C DISTRIBUTIONS", THIRD EDITION, WILEY, PP. 510-511. 20278C --NAKAGAWA AND OSAKI (1975), "THE DISCRETE WEIBULL 20279C DISTRIBUTION", IEEE TRANSACTIONS ON RELIABILITY, 20280C R-24, PP. 300-301. 20281C WRITTEN BY--JAMES J. FILLIBEN 20282C STATISTICAL ENGINEERING DIVISION 20283C INFORMATION TECHNOLOGY LABORATORY 20284C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 20285C GAITHERSBURG, MD 20899-8980 20286C PHONE--301-975-2855 20287C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 20288C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 20289C LANGUAGE--ANSI FORTRAN (1977) 20290C VERSION NUMBER--2006/11 20291C ORIGINAL VERSION--NOVEMBER 2006. 20292C 20293C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 20294C 20295C--------------------------------------------------------------------- 20296C 20297 DOUBLE PRECISION P 20298 DOUBLE PRECISION Q 20299 DOUBLE PRECISION BETA 20300 DOUBLE PRECISION PPF 20301 DOUBLE PRECISION DTERM1 20302 DOUBLE PRECISION DEPS 20303C 20304C--------------------------------------------------------------------- 20305C 20306 INCLUDE 'DPCOP2.INC' 20307C 20308 DATA DEPS/0.1D-15/ 20309C 20310C-----START POINT----------------------------------------------------- 20311C 20312C CHECK THE INPUT ARGUMENTS FOR ERRORS 20313C 20314 IF(P.LT.0.0D0 .OR. P.GE.1.0)THEN 20315 WRITE(ICOUT,4) 20316 CALL DPWRST('XXX','BUG ') 20317 WRITE(ICOUT,46)P 20318 CALL DPWRST('XXX','BUG ') 20319 PPF=0.0D0 20320 GOTO9000 20321 ENDIF 20322 4 FORMAT('***** ERROR--THE FIRST ARGUMENT TO DIWPPF IS OUTSIDE ', 20323 1'THE ALLOWABLE (0,1] INTERVAL') 20324C 20325 IF(Q.LE.0.0D0 .OR. Q.GE.1.0D0)THEN 20326 WRITE(ICOUT,15) 20327 CALL DPWRST('XXX','BUG ') 20328 WRITE(ICOUT,46)Q 20329 CALL DPWRST('XXX','BUG ') 20330 PPF=0.0D0 20331 GOTO9000 20332 ENDIF 20333 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO DIWPPF IS NOT IN ', 20334 1'THE INTERVAL (0,1)') 20335C 20336 IF(BETA.LE.0.0D0)THEN 20337 WRITE(ICOUT,25) 20338 CALL DPWRST('XXX','BUG ') 20339 WRITE(ICOUT,46)BETA 20340 CALL DPWRST('XXX','BUG ') 20341 PPF=0.0 20342 GOTO9000 20343 ENDIF 20344 25 FORMAT('***** ERROR--THE THIRD ARGUMENT TO DIWPPF IS NEGATIVE') 20345C 20346 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 20347C 20348 DTERM1=(DLOG(1.0D0 - P)/DLOG(Q))**(1.0D0/BETA) 20349 IPPF=INT(DTERM1+DEPS) 20350 PPF=DBLE(IPPF) 20351C 20352 9000 CONTINUE 20353 RETURN 20354 END 20355 SUBROUTINE DIWRAN(N,Q,BETA,ISEED,X) 20356C 20357C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N 20358C FROM THE DISCRETE WEIBULL DISTRIBUTION 20359C WITH SHAPE PARAMETERS Q AND BETA. 20360C THIS DISTRIBUTION IS DEFINED FOR ALL 20361C NON-NEGATIVE INTEGER X >= 0 AND HAS 20362C THE PROBABILITY MASS FUNCTION IS: 20363C p(X;Q,BETA) = (Q)**(X**BETA) - (Q)**((X+1)**BETA) 20364C X = 0, 1, 2, ...; 0 < Q < 1; BETA > 0 20365C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER 20366C OF RANDOM NUMBERS TO BE 20367C GENERATED. 20368C --Q = THE SINGLE PRECISION VALUE 20369C OF THE FIRST SHAPE PARAMETER. 20370C --BETA = THE SINGLE PRECISION VALUE 20371C OF THE SECOND SHAPE PARAMETER. 20372C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR 20373C (OF DIMENSION AT LEAST N) 20374C INTO WHICH THE GENERATED 20375C RANDOM SAMPLE WILL BE PLACED. 20376C OUTPUT--A RANDOM SAMPLE OF SIZE N 20377C FROM THE DISCRETE WEIBULL DISTRIBUTION 20378C WITH SHAPE PARAMETERS Q AND BETA. 20379C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 20380C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 20381C OF N FOR THIS SUBROUTINE. 20382C --0 < Q < 1, BETA > 0 20383C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN, DIWPPF 20384C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 20385C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 20386C LANGUAGE--ANSI FORTRAN (1977) 20387C REFERENCES--JOHNSON, KEMP, AND KOTZ (2005), "UNIVARIATE DISCRETE 20388C DISTRIBUTIONS", THIRD EDITION, WILEY, PP. 510-511. 20389C --NAKAGAWA AND OSAKI (1975), "THE DISCRETE WEIBULL 20390C DISTRIBUTION", IEEE TRANSACTIONS ON RELIABILITY, 20391C R-24, PP. 300-301. 20392C WRITTEN BY--JAMES J. FILLIBEN 20393C STATISTICAL ENGINEERING DIVISION 20394C INFORMATION TECHNOLOGY LABORATORY 20395C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 20396C GAITHERSBURG, MD 20899-8980 20397C PHONE--301-975-2899 20398C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 20399C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 20400C LANGUAGE--ANSI FORTRAN (1977) 20401C VERSION NUMBER--2006/11 20402C ORIGINAL VERSION--NOVEMBER 2006. 20403C 20404C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 20405C 20406C--------------------------------------------------------------------- 20407C 20408 REAL Q 20409 REAL BETA 20410 DIMENSION X(*) 20411C 20412 DOUBLE PRECISION DQ 20413 DOUBLE PRECISION DBETA 20414 DOUBLE PRECISION DPPF 20415C 20416C--------------------------------------------------------------------- 20417C 20418 INCLUDE 'DPCOP2.INC' 20419C 20420C-----DATA STATEMENTS------------------------------------------------- 20421C 20422C-----START POINT----------------------------------------------------- 20423C 20424C CHECK THE INPUT ARGUMENTS FOR ERRORS 20425C 20426 IF(N.LT.1)THEN 20427 WRITE(ICOUT,5) 20428 CALL DPWRST('XXX','BUG ') 20429 WRITE(ICOUT,6) 20430 CALL DPWRST('XXX','BUG ') 20431 WRITE(ICOUT,47)N 20432 CALL DPWRST('XXX','BUG ') 20433 GOTO9999 20434 ENDIF 20435 5 FORMAT('***** ERROR--THE REQUESTED NUMBER OF DISCRETE WEIBULL') 20436 6 FORMAT(' RANDOM NUMBERS IS NON-POSITIVE') 20437 IF(Q.LE.0.0 .OR. Q.GE.1.0)THEN 20438 WRITE(ICOUT,11) 20439 CALL DPWRST('XXX','BUG ') 20440 WRITE(ICOUT,12) 20441 CALL DPWRST('XXX','BUG ') 20442 WRITE(ICOUT,46)Q 20443 CALL DPWRST('XXX','BUG ') 20444 GOTO9999 20445 ENDIF 20446 11 FORMAT('***** ERROR--THE Q PARAMETER FOR THE ', 20447 1'DISCRETE WEIBULL') 20448 12 FORMAT(' RANDOM NUMBERS IS OUTSIDE THE (0,1) INTERVAL') 20449C 20450 IF(BETA.LE.0.0)THEN 20451 WRITE(ICOUT,21) 20452 CALL DPWRST('XXX','BUG ') 20453 WRITE(ICOUT,22) 20454 CALL DPWRST('XXX','BUG ') 20455 WRITE(ICOUT,46)BETA 20456 CALL DPWRST('XXX','BUG ') 20457 GOTO9999 20458 ENDIF 20459 21 FORMAT('***** ERROR--THE BETA PARAMETER FOR THE ', 20460 1'DISCRETE WEIBULL') 20461 22 FORMAT(' RANDOM NUMBERS IS NON-POSITIVE.') 20462C 20463 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7) 20464 47 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8) 20465C 20466C GENERATE N DISCRETE WEIBULL DISTRIBUTION 20467C RANDOM NUMBERS. 20468C 20469 DQ=DBLE(Q) 20470 DBETA=DBLE(BETA) 20471 CALL UNIRAN(N,ISEED,X) 20472C 20473 DO100I=1,N 20474 ZTEMP=X(I) 20475 CALL DIWPPF(DBLE(ZTEMP),DQ,DBETA,DPPF) 20476 X(I)=REAL(DPPF) 20477 100 CONTINUE 20478C 20479 9999 CONTINUE 20480C 20481 RETURN 20482 END 20483 DOUBLE PRECISION FUNCTION DLBETA (A, B) 20484C***BEGIN PROLOGUE DLBETA 20485C***PURPOSE Compute the natural logarithm of the complete Beta 20486C function. 20487C***LIBRARY SLATEC (FNLIB) 20488C***CATEGORY C7B 20489C***TYPE DOUBLE PRECISION (ALBETA-S, DLBETA-D, CLBETA-C) 20490C***KEYWORDS FNLIB, LOGARITHM OF THE COMPLETE BETA FUNCTION, 20491C SPECIAL FUNCTIONS 20492C***AUTHOR Fullerton, W., (LANL) 20493C***DESCRIPTION 20494C 20495C DLBETA(A,B) calculates the double precision natural logarithm of 20496C the complete beta function for double precision arguments 20497C A and B. 20498C 20499C***REFERENCES (NONE) 20500C***ROUTINES CALLED D9LGMC, DGAMMA, DLNGAM, DLNREL, XERMSG 20501C***REVISION HISTORY (YYMMDD) 20502C 770701 DATE WRITTEN 20503C 890531 Changed all specific intrinsics to generic. (WRB) 20504C 890531 REVISION DATE from Version 3.2 20505C 891214 Prologue converted to Version 4.0 format. (BAB) 20506C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 20507C 900727 Added EXTERNAL statement. (WRB) 20508C***END PROLOGUE DLBETA 20509 DOUBLE PRECISION A, B, P, Q, CORR, SQ2PIL, D9LGMC, DGAMMA, DLNGAM, 20510 1 DLNREL 20511 EXTERNAL DGAMMA 20512 SAVE SQ2PIL 20513C 20514C--------------------------------------------------------------------- 20515C 20516 INCLUDE 'DPCOP2.INC' 20517C 20518 DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / 20519C***FIRST EXECUTABLE STATEMENT DLBETA 20520 P = MIN (A, B) 20521 Q = MAX (A, B) 20522C 20523 IF (P .LE. 0.D0) THEN 20524 WRITE(ICOUT,11) 20525 CALL DPWRST('XXX','BUG ') 20526 WRITE(ICOUT,12) 20527 CALL DPWRST('XXX','BUG ') 20528 DLBETA = 0.D0 20529 RETURN 20530 ENDIF 20531 11 FORMAT('***** ERROR FROM DLBETA. BOTH INPUT ARGUMENTS ') 20532 12 FORMAT(' MUST BE GREATER THAN ZERO. ******') 20533C 20534 IF (P.GE.10.D0) GO TO 30 20535 IF (Q.GE.10.D0) GO TO 20 20536C 20537C P AND Q ARE SMALL. 20538C 20539 DLBETA = LOG (DGAMMA(P) * (DGAMMA(Q)/DGAMMA(P+Q)) ) 20540 RETURN 20541C 20542C P IS SMALL, BUT Q IS BIG. 20543C 20544 20 CORR = D9LGMC(Q) - D9LGMC(P+Q) 20545 DLBETA = DLNGAM(P) + CORR + P - P*LOG(P+Q) 20546 1 + (Q-0.5D0)*DLNREL(-P/(P+Q)) 20547 RETURN 20548C 20549C P AND Q ARE BIG. 20550C 20551 30 CORR = D9LGMC(P) + D9LGMC(Q) - D9LGMC(P+Q) 20552 DLBETA = -0.5D0*LOG(Q) + SQ2PIL + CORR + (P-0.5D0)*LOG(P/(P+Q)) 20553 1 + Q*DLNREL(-P/(P+Q)) 20554 RETURN 20555C 20556 END 20557C===================================================== DLGAMA.FOR 20558 DOUBLE PRECISION FUNCTION DLGADP(X) 20559C 20560C 2020/03: RENAME TO AVOID CONFLICT WITH INTRINSIC ROUTINE 20561C 20562CCCCC DOUBLE PRECISION FUNCTION DLGAMA(X) 20563C*********************************************************************** 20564C* * 20565C* FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, * 20566C* 'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' * 20567C* * 20568C* J. R. M. HOSKING * 20569C* IBM RESEARCH DIVISION * 20570C* T. J. WATSON RESEARCH CENTER * 20571C* YORKTOWN HEIGHTS * 20572C* NEW YORK 10598, U.S.A. * 20573C* * 20574C* VERSION 3 AUGUST 1996 * 20575C* * 20576C*********************************************************************** 20577C 20578C LOGARITHM OF GAMMA FUNCTION 20579C 20580C BASED ON ALGORITHM ACM291, COMMUN. ASSOC. COMPUT. MACH. (1966) 20581C 20582 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 20583C 20584 INCLUDE 'DPCOP2.INC' 20585C 20586 DATA SMALL,CRIT,BIG,TOOBIG/1D-7,13D0,1D9,2D36/ 20587C 20588C C0 IS 0.5*LOG(2*PI) 20589C C1...C7 ARE THE COEFFTS OF THE ASYMPTOTIC EXPANSION OF DLGAMA 20590C 20591 DATA C0,C1,C2,C3,C4,C5,C6,C7/ 20592 * 0.91893 85332 04672 742D 0, 0.83333 33333 33333 333D-1, 20593 * -0.27777 77777 77777 778D-2, 0.79365 07936 50793 651D-3, 20594 * -0.59523 80952 38095 238D-3, 0.84175 08417 50841 751D-3, 20595 * -0.19175 26917 52691 753D-2, 0.64102 56410 25641 026D-2/ 20596C 20597C S1 IS -(EULER'S CONSTANT), S2 IS PI**2/12 20598C 20599 DATA S1/-0.57721 56649 01532 861D 0/ 20600 DATA S2/ 0.82246 70334 24113 218D 0/ 20601C 20602 DATA ZERO/0D0/,HALF/0.5D0/,ONE/1D0/,TWO/2D0/ 20603C 20604CCCCC DLGAMA=ZERO 20605 DLGADP=ZERO 20606C 20607 IF(X.LE.ZERO .OR. X.GT.TOOBIG)THEN 20608 WRITE(ICOUT,7000) 20609 7000 FORMAT('****** ERROR IN DLGAMA: ARGUMENT OUT OF RANGE.') 20610 CALL DPWRST('XXX','BUG ') 20611 WRITE(ICOUT,7002)X 20612 7002 FORMAT(' VALUE OF THE ARGUMENT IS ',D24.16) 20613 CALL DPWRST('XXX','BUG ') 20614 GOTO9000 20615 ENDIF 20616C 20617C USE SMALL-X APPROXIMATION IF X IS NEAR 0, 1 OR 2 20618C 20619 IF(DABS(X-TWO).GT.SMALL)GOTO 10 20620CCCCC DLGAMA=DLOG(X-ONE) 20621 DLGADP=DLOG(X-ONE) 20622 XX=X-TWO 20623 GOTO 20 20624 10 IF(DABS(X-ONE).GT.SMALL)GOTO 30 20625 XX=X-ONE 20626CCC20 DLGAMA=DLGAMA+XX*(S1+XX*S2) 20627 20 DLGADP=DLGADP+XX*(S1+XX*S2) 20628 GOTO9000 20629 30 IF(X.GT.SMALL)GOTO 40 20630CCCCC DLGAMA=-DLOG(X)+S1*X 20631 DLGADP=-DLOG(X)+S1*X 20632 GOTO9000 20633C 20634C REDUCE TO DLGAMA(X+N) WHERE X+N.GE.CRIT 20635C 20636 40 SUM1=ZERO 20637 Y=X 20638 IF(Y.GE.CRIT)GOTO 60 20639 Z=ONE 20640 50 Z=Z*Y 20641 Y=Y+ONE 20642 IF(Y.LT.CRIT)GOTO 50 20643 SUM1=SUM1-DLOG(Z) 20644C 20645C USE ASYMPTOTIC EXPANSION IF Y.GE.CRIT 20646C 20647 60 SUM1=SUM1+(Y-HALF)*DLOG(Y)-Y+C0 20648 SUM2=ZERO 20649 IF(Y.GE.BIG)GOTO 70 20650 Z=ONE/(Y*Y) 20651 SUM2=((((((C7*Z+C6)*Z+C5)*Z+C4)*Z+C3)*Z+C2)*Z+C1)/Y 20652CCC70 DLGAMA=SUM1+SUM2 20653 70 DLGADP=SUM1+SUM2 20654 GOTO9000 20655C 20656 9000 CONTINUE 20657 RETURN 20658 END 20659 SUBROUTINE DLGAMS (X, DLGAM, SGNGAM) 20660C***BEGIN PROLOGUE DLGAMS 20661C***PURPOSE Compute the logarithm of the absolute value of the Gamma 20662C function. 20663C***LIBRARY SLATEC (FNLIB) 20664C***CATEGORY C7A 20665C***TYPE DOUBLE PRECISION (ALGAMS-S, DLGAMS-D) 20666C***KEYWORDS ABSOLUTE VALUE OF THE LOGARITHM OF THE GAMMA FUNCTION, 20667C FNLIB, SPECIAL FUNCTIONS 20668C***AUTHOR Fullerton, W., (LANL) 20669C***DESCRIPTION 20670C 20671C DLGAMS(X,DLGAM,SGNGAM) calculates the double precision natural 20672C logarithm of the absolute value of the Gamma function for 20673C double precision argument X and stores the result in double 20674C precision argument DLGAM. 20675C 20676C***REFERENCES (NONE) 20677C***ROUTINES CALLED DLNGAM 20678C***REVISION HISTORY (YYMMDD) 20679C 770701 DATE WRITTEN 20680C 890531 Changed all specific intrinsics to generic. (WRB) 20681C 890531 REVISION DATE from Version 3.2 20682C 891214 Prologue converted to Version 4.0 format. (BAB) 20683C***END PROLOGUE DLGAMS 20684 DOUBLE PRECISION X, DLGAM, SGNGAM, DLNGAM 20685C***FIRST EXECUTABLE STATEMENT DLGAMS 20686 DLGAM = DLNGAM(X) 20687 SGNGAM = 1.0D0 20688 IF (X.GT.0.D0) RETURN 20689C 20690 INTZ = INT(MOD (-AINT(X), 2.0D0) + 0.1D0) 20691 IF (INTZ.EQ.0) SGNGAM = -1.0D0 20692C 20693 RETURN 20694 END 20695 DOUBLE PRECISION FUNCTION DLNGAM (X) 20696C***BEGIN PROLOGUE DLNGAM 20697C***PURPOSE Compute the logarithm of the absolute value of the Gamma 20698C function. 20699C***LIBRARY SLATEC (FNLIB) 20700C***CATEGORY C7A 20701C***TYPE DOUBLE PRECISION (ALNGAM-S, DLNGAM-D, CLNGAM-C) 20702C***KEYWORDS ABSOLUTE VALUE, COMPLETE GAMMA FUNCTION, FNLIB, LOGARITHM, 20703C SPECIAL FUNCTIONS 20704C***AUTHOR Fullerton, W., (LANL) 20705C***DESCRIPTION 20706C 20707C DLNGAM(X) calculates the double precision logarithm of the 20708C absolute value of the Gamma function for double precision 20709C argument X. 20710C 20711C***REFERENCES (NONE) 20712C***ROUTINES CALLED D1MACH, D9LGMC, DGAMMA, XERMSG 20713C***REVISION HISTORY (YYMMDD) 20714C 770601 DATE WRITTEN 20715C 890531 Changed all specific intrinsics to generic. (WRB) 20716C 890531 REVISION DATE from Version 3.2 20717C 891214 Prologue converted to Version 4.0 format. (BAB) 20718C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 20719C 900727 Added EXTERNAL statement. (WRB) 20720C***END PROLOGUE DLNGAM 20721 DOUBLE PRECISION X, DXREL, PI, SINPIY, SQPI2L, SQ2PIL, XMAX, 20722 1 Y, DGAMMA, D9LGMC, TEMP 20723 LOGICAL FIRST 20724 EXTERNAL DGAMMA 20725 SAVE SQ2PIL, SQPI2L, PI, XMAX, DXREL, FIRST 20726C 20727C-----COMMON---------------------------------------------------------- 20728C 20729 INCLUDE 'DPCOMC.INC' 20730 INCLUDE 'DPCOP2.INC' 20731C 20732 DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / 20733 DATA SQPI2L / +.2257913526 4472743236 3097614947 441 D+0 / 20734 DATA PI / 3.1415926535 8979323846 2643383279 50 D0 / 20735 DATA FIRST /.TRUE./ 20736C***FIRST EXECUTABLE STATEMENT DLNGAM 20737C 20738 DLNGAM = 0.0D0 20739C 20740 IF (FIRST) THEN 20741 TEMP = 1.D0/LOG(D1MACH(2)) 20742 XMAX = TEMP*D1MACH(2) 20743 DXREL = SQRT(D1MACH(4)) 20744 ENDIF 20745 FIRST = .FALSE. 20746C 20747 Y = ABS (X) 20748 IF (Y.GT.10.D0) GO TO 20 20749C 20750C LOG (ABS (DGAMMA(X)) ) FOR ABS(X) .LE. 10.0 20751C 20752 DLNGAM = LOG (ABS (DGAMMA(X)) ) 20753 RETURN 20754C 20755C LOG ( ABS (DGAMMA(X)) ) FOR ABS(X) .GT. 10.0 20756C 20757 20 IF (Y .GT. XMAX) THEN 20758 WRITE(ICOUT,21) 20759 CALL DPWRST('XXX','BUG ') 20760 WRITE(ICOUT,22) 20761 CALL DPWRST('XXX','BUG ') 20762 DLNGAM = 0.D0 20763 RETURN 20764 ENDIF 20765 21 FORMAT('***** ERROR FROM DLNGAM. ABSOLUTE VALUE OF X SO ') 20766 22 FORMAT(' LARGE THAT DLNGAM OVERFLOWS. ******') 20767C 20768 IF (X.GT.0.D0) DLNGAM = SQ2PIL + (X-0.5D0)*LOG(X) - X + D9LGMC(Y) 20769 IF (X.GT.0.D0) RETURN 20770C 20771 SINPIY = ABS (SIN(PI*Y)) 20772 IF (SINPIY .EQ. 0.D0) THEN 20773 WRITE(ICOUT,31) 20774 CALL DPWRST('XXX','BUG ') 20775 DLNGAM = 0.D0 20776 RETURN 20777 ENDIF 20778 31 FORMAT('***** ERROR FROM DLNGAM. X IS A NEGATIVE INTEGER. ') 20779C 20780 IF (ABS((X-AINT(X-0.5D0))/X) .LT. DXREL)THEN 20781 WRITE(ICOUT,41) 20782 CALL DPWRST('XXX','BUG ') 20783 WRITE(ICOUT,42) 20784 CALL DPWRST('XXX','BUG ') 20785 WRITE(ICOUT,43) 20786 CALL DPWRST('XXX','BUG ') 20787 ENDIF 20788 41 FORMAT('***** WARNING FROM DLNGAM. ANSWER LESS THAN HALF ') 20789 42 FORMAT(' PRECISION BECAUSE X IS TOO NEAR A NEGATIVE ') 20790 43 FORMAT(' INTEGER. *****') 20791C 20792 DLNGAM = SQPI2L + (X-0.5D0)*LOG(Y) - X - LOG(SINPIY) - D9LGMC(Y) 20793 RETURN 20794C 20795 END 20796 SUBROUTINE DLGCDF(X,THETA,CDF) 20797C 20798C PURPOSE--THIS SUBROUTINE COMPUTES THE CUMULATIVE DISTRIBUTION 20799C FUNCTION VALUE FOR THE DISCRETE LOGARITHMIC SERIES 20800C DISTRIBUTION WITH SHAPE PARAMETER = THETA. 20801C THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER X>1. 20802C THE PROBABILITY DENSITY FUNCTION IS: 20803C F(X,THETA)=A*THETA**X/X X=1,2,3,... 20804C WHERE A = 1/LN(1-THETA), 0<THETA<1 20805C FOR CDF, USE RECURRENCE RELATION: 20806C P(X=x+1) = THETA*P(X=x)/(X+1) X=1,2,... 20807C WHERE 20808C P(X=1)=-THETA/LN(1-THETA) 20809C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT 20810C WHICH THE CUMULATIVE DISTRIBUTION 20811C FUNCTION IS TO BE EVALUATED. 20812C X SHOULD BE NON-NEGATIVE. 20813C --THETA = THE SHAPE PARAMETER 20814C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE 20815C DISTRIBUTION FUNCTION VALUE. 20816C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY 20817C FUNCTION VALUE CDF FOR THE LOGARITHMIC SERIES 20818C DISTRIBUTION WITH SHAPE PARAMETER = THETA 20819C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 20820C RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER 20821C --0 < THETA < 1 20822C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 20823C LANGUAGE--ANSI FORTRAN (1977) 20824C REFERENCES--JOHNSON AND KOTZ, DISCRETE UNIVARIATE 20825C DISTRIBUTIONS--1, 1994, CHAPTER 7 20826C --"STATISTICAL DISTRIBUTIONS", EVANS, HASTINGS, 20827C PEACOCK. WILEY, 1993. CHAPTER 23. 20828C WRITTEN BY--JAMES J. FILLIBEN 20829C STATISTICAL ENGINEERING DIVISION 20830C INFORMATION TECHNOLOGY LABORATORY 20831C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 20832C GAITHERSBURG, MD 20899-8980 20833C PHONE--301-975-2855 20834C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 20835C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 20836C LANGUAGE--ANSI FORTRAN (1966) 20837C VERSION NUMBER--95/4 20838C ORIGINAL VERSION--APRIL 1995. 20839C 20840C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 20841C 20842C--------------------------------------------------------------------- 20843C 20844 DOUBLE PRECISION DTERM1, DTERM2, DTERM3 20845 DOUBLE PRECISION DX, DTHETA, DLTHET, DSUM 20846 DOUBLE PRECISION DCURR, DPREV 20847C 20848 INCLUDE 'DPCOMC.INC' 20849 INCLUDE 'DPCOP2.INC' 20850C 20851C-----DATA STATEMENTS------------------------------------------------- 20852C 20853C-----START POINT----------------------------------------------------- 20854C 20855C CHECK THE INPUT ARGUMENTS FOR ERRORS 20856C 20857 IX=INT(X+0.5) 20858 CDF=0.0 20859 IF(THETA.LE.0.0.OR.THETA.GE.1.0)THEN 20860 WRITE(ICOUT,15) 20861 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO DLGCDF ', 20862 1 'DLGCDF IS NOT IN THE INTERVAL (0,1).') 20863 CALL DPWRST('XXX','BUG ') 20864 WRITE(ICOUT,46)THETA 20865 CALL DPWRST('XXX','BUG ') 20866 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.') 20867 GOTO9000 20868 ELSEIF(IX.LT.1)THEN 20869 WRITE(ICOUT,4) 20870 4 FORMAT('***** WARNING--THE FIRST ARGUMENT TO DLGCDF ', 20871 1 'IS LESS THAN 1.') 20872 CALL DPWRST('XXX','BUG ') 20873 WRITE(ICOUT,46)X 20874 CALL DPWRST('XXX','BUG ') 20875 GOTO9000 20876 ENDIF 20877C 20878 DX=DBLE(IX) 20879 DTHETA=DBLE(THETA) 20880 DSUM=0.0D0 20881C 20882 DTERM1=-DTHETA/DLOG(1.0D0-DTHETA) 20883 IF(IX.EQ.1)THEN 20884 CDF=REAL(DTERM1) 20885 GOTO9000 20886 ENDIF 20887C 20888 DSUM=DTERM1 20889 DPREV=DTERM1 20890 DLTHET=DLOG(DTHETA) 20891 DO100I=2,IX 20892C 20893 IF(DPREV.LE.D1MACH(1))THEN 20894 CDF=REAL(DSUM) 20895 GOTO9000 20896 ENDIF 20897C 20898 DTERM3=DBLE(I) 20899 DTERM2=DLTHET + DLOG(DTERM3-1.0D0) + DLOG(DPREV) - DLOG(DTERM3) 20900 DCURR=DEXP(DTERM2) 20901 DSUM=DSUM+DCURR 20902 DPREV=DCURR 20903 100 CONTINUE 20904C 20905 CDF=REAL(DSUM) 20906C 20907 9000 CONTINUE 20908 RETURN 20909 END 20910 REAL FUNCTION DLGFU2(X) 20911C 20912C PURPOSE--DPMLDL CALLS FZERO TO FIND A ROOT FOR THE EQUATION 20913C XBAR = THETAHAT/[-(1-THETAHAT)LN(1-THETAHAT) 20914C DLGFU2 IS THE FUNCTION FOR WHICH THE ZERO IS FOUND. 20915C IT IS: 20916C XBAR - THETAHAT/[-(1-THETAHAT)LN(1-THETAHAT) = 0 20917C WHERE THETAHAT IS THE DESIRED VALUE (I.E., X) 20918C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT 20919C WHICH THE EQUATION IS EVALUATED. 20920C OUTPUT--THE SINGLE PRECISION FUNCTION VALUE DLGFU2. 20921C PRINTING--NONE. 20922C RESTRICTIONS--NONE. 20923C OTHER DATAPAC SUBROUTINES NEEDED--NONE. 20924C FORTRAN LIBRARY SUBROUTINES NEEDED--NONE. 20925C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 20926C LANGUAGE--ANSI FORTRAN (1977) 20927C REFERENCES--JOHNSON, KOTZ, AND KEMP, "DISCRETE 20928C UNIVARIATE DISTRIBUTIONS", SECOND EDITION, 20929C JOHN WILEY, 1992, CHAPTER 7. 20930C WRITTEN BY--ALAN HECKERT 20931C STATISTICAL ENGINEERING DIVISION 20932C INFORMATION TECHNOLOGY LABORATORY 20933C NATION INSTITUTE OF STANDARDS AND TECHNOLOGY 20934C GAITHERSBURG, MD 20899-8980 20935C PHONE--301-975-2899 20936C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 20937C OF THE NATION INSTITUTE OF STANDARDS AND TECHNOLOGY. 20938C LANGUAGE--ANSI FORTRAN (1977) 20939C VERSION NUMBER--2004.3 20940C ORIGINAL VERSION--MARCH 2003. 20941C 20942C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 20943C 20944C--------------------------------------------------------------------- 20945C 20946 REAL XBAR 20947 COMMON/DLGCOM/XBAR 20948C 20949 INCLUDE 'DPCOP2.INC' 20950C 20951C-----START POINT----------------------------------------------------- 20952C 20953 DLGFU2=XBAR - X/(-(1.0-X)*LOG(1.0-X)) 20954C 20955 RETURN 20956 END 20957 SUBROUTINE DLGPDF(X,THETA,PDF) 20958C 20959C PURPOSE--THIS SUBROUTINE COMPUTES THE PROBABILITY DENSITY 20960C FUNCTION VALUE FOR THE DISCRETE LOGARITHMIC SERIES 20961C DISTRIBUTION WITH SHAPE PARAMETER = THETA. 20962C THIS DISTRIBUTION IS DEFINED FOR ALL INTEGER X>1. 20963C THE PROBABILITY DENSITY FUNCTION IS: 20964C F(X,THETA)=A*THETA**X/X X=1,2,3,... 20965C WHERE A = 1/LN(1-THETA), 0<THETA<1 20966C INPUT ARGUMENTS--X = THE SINGLE PRECISION VALUE AT 20967C WHICH THE CUMULATIVE DISTRIBUTION 20968C FUNCTION IS TO BE EVALUATED. 20969C X SHOULD BE NON-NEGATIVE. 20970C --THETA = THE SHAPE PARAMETER 20971C OUTPUT ARGUMENTS--PDF = THE SINGLE PRECISION CUMULATIVE 20972C DISTRIBUTION FUNCTION VALUE. 20973C OUTPUT--THE SINGLE PRECISION PROBABILITY DENSITY 20974C FUNCTION VALUE PDF FOR THE LOGARITHMIC SERIES 20975C DISTRIBUTION WITH SHAPE PARAMETER = THETA 20976C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 20977C RESTRICTIONS--X SHOULD BE A POSITIVE INTEGER 20978C --0 < THETA < 1 20979C MODE OF INTERNAL OPERATIONS--DOUBLE PRECISION. 20980C LANGUAGE--ANSI FORTRAN (1977) 20981C REFERENCES--JOHNSON AND KOTZ, DISCRETE UNIVARIATE 20982C DISTRIBUTIONS--1, 1994, CHAPTER 7 20983C --"STATISTICAL DISTRIBUTIONS", EVANS, HASTINGS, 20984C PEACOCK. WILEY, 1993. CHAPTER 23. 20985C WRITTEN BY--JAMES J. FILLIBEN 20986C STATISTICAL ENGINEERING DIVISION 20987C INFORMATION TECHNOLOGY LABORATORY 20988C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 20989C GAITHERSBURG, MD 20899-8980 20990C PHONE--301-975-2855 20991C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 20992C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 20993C LANGUAGE--ANSI FORTRAN (1966) 20994C VERSION NUMBER--95/4 20995C ORIGINAL VERSION--APRIL 1995. 20996C 20997C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 20998C 20999C--------------------------------------------------------------------- 21000C 21001 DOUBLE PRECISION DTERM1, DTERM2, DTERM3, DTERM4, DTERM5 21002 DOUBLE PRECISION DX, DTHETA, DCONST 21003C 21004C--------------------------------------------------------------------- 21005C 21006 INCLUDE 'DPCOP2.INC' 21007C 21008C-----START POINT----------------------------------------------------- 21009C 21010C CHECK THE INPUT ARGUMENTS FOR ERRORS 21011C 21012 IX=INT(X+0.5) 21013 PDF=0.0 21014 IF(THETA.LE.0.0 .OR. THETA.GE.1.0)THEN 21015 WRITE(ICOUT,15) 21016 15 FORMAT('***** ERROR--THE SECOND ARGUMENT TO DLGPDF ', 21017 1 'IS NOT IN THE INTERVAL (0,1).') 21018 CALL DPWRST('XXX','BUG ') 21019 WRITE(ICOUT,46)THETA 21020 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.') 21021 CALL DPWRST('XXX','BUG ') 21022 GOTO9000 21023 ELSEIF(IX.LT.1)THEN 21024 WRITE(ICOUT,4) 21025 4 FORMAT('***** WARNING--THE FIRST ARGUMENT TO DLGPDF ', 21026 1 'IS LESS THAN 1.') 21027 CALL DPWRST('XXX','BUG ') 21028 WRITE(ICOUT,46)X 21029 CALL DPWRST('XXX','BUG ') 21030 GOTO9000 21031 ENDIF 21032C 21033 DX=DBLE(IX) 21034 DTHETA=DBLE(THETA) 21035C 21036 DCONST=-1.0D0/DLOG(1.0D0-DTHETA) 21037 DTERM1=DLOG(DCONST) 21038C 21039 DTERM2=DX*DLOG(DTHETA) 21040 DTERM3=DLOG(DX) 21041 DTERM4=DTERM1+DTERM2-DTERM3 21042 DTERM5=DEXP(DTERM4) 21043 PDF=REAL(DTERM5) 21044C 21045 9000 CONTINUE 21046 RETURN 21047 END 21048 SUBROUTINE DLGPPF(P,THETA,PPF) 21049C 21050C PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT 21051C FUNCTION VALUE AT THE SINGLE PRECISION VALUE P 21052C FOR THE LOGARITMIC SERIES DISTRIBUTION 21053C INPUT ARGUMENTS--P = THE SINGLE PRECISION VALUE 21054C AT WHICH THE PERCENT POINT 21055C FUNCTION IS TO BE EVALUATED. 21056C IT SHOULD BE IN THE INTERVAL (0,1). 21057C --THETA = THE SHAPE PARAMETER 21058C OUTPUT ARGUMENTS--CDF = THE SINGLE PRECISION CUMULATIVE 21059C DISTRIBUTION FUNCTION VALUE. 21060C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 21061C RESTRICTIONS--P SHOULD BE BETWEEN 0 AND 1 (EXCLUSIVELY FOR 1). 21062C --THETA SHOULD BE IN THE INTERVAL (0,1) (EXCLUSIVELY) 21063C --NN SHOULD BE A POSITIVE INTEGER BETWEEN 1 AND MM. 21064C OUTPUT ARGUMENTS--PPF = THE SINGLE PRECISION PERCENT 21065C POINT FUNCTION VALUE. 21066C OUTPUT--THE SINGLE PRECISION PERCENT POINT . 21067C FUNCTION VALUE PPF 21068C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 21069C OTHER DATAPAC SUBROUTINES NEEDED--DLGCDF. 21070C MODE OF INTERNAL OPERATIONS--SINGLE AND DOUBLE PRECISION. 21071C LANGUAGE--ANSI FORTRAN (1977) 21072C COMMENT--NOTE THAT EVEN THOUGH THE OUTPUT 21073C FROM THIS DISCRETE DISTRIBUTION 21074C PERCENT POINT FUNCTION 21075C SUBROUTINE MUST NECESSARILY BE A 21076C DISCRETE INTEGER VALUE, 21077C THE OUTPUT VARIABLE PPF IS SINGLE 21078C PRECISION IN MODE. 21079C PPF HAS BEEN SPECIFIED AS SINGLE 21080C PRECISION SO AS TO CONFORM WITH THE DATAPAC 21081C CONVENTION THAT ALL OUTPUT VARIABLES FROM ALL 21082C DATAPAC SUBROUTINES ARE SINGLE PRECISION. 21083C THIS CONVENTION IS BASED ON THE BELIEF THAT 21084C 1) A MIXTURE OF MODES (FLOATING POINT 21085C VERSUS INTEGER) IS INCONSISTENT AND 21086C AN UNNECESSARY COMPLICATION 21087C IN A DATA ANALYSIS; AND 21088C 2) FLOATING POINT MACHINE ARITHMETIC 21089C (AS OPPOSED TO INTEGER ARITHMETIC) 21090C IS THE MORE NATURAL MODE FOR DOING 21091C DATA ANALYSIS. 21092C REFERENCES--JOHNSON AND KOTZ, DISCRETE 21093C DISTRIBUTIONS, 1994. CHAPTER 7. 21094C --EVANS, HASTINGS, PEACOCK, STATISTICAL 21095C DISTRIBUTIONS--1993, CHAPTER 23. 21096C WRITTEN BY--JAMES J. FILLIBEN 21097C STATISTICAL ENGINEERING DIVISION 21098C INFORMATION TECHNOLOGY LABORATORY 21099C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 21100C GAITHERSBURG, MD 20899-8980 21101C PHONE--301-975-2855 21102C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 21103C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 21104C LANGUAGE--ANSI FORTRAN (1966) 21105C VERSION NUMBER--95/4 21106C ORIGINAL VERSION--APRIL 1995. 21107C 21108C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 21109C 21110C--------------------------------------------------------------------- 21111C 21112 INCLUDE 'DPCOP2.INC' 21113C 21114C-----START POINT----------------------------------------------------- 21115C 21116C CHECK THE INPUT ARGUMENTS FOR ERRORS 21117C 21118 PPF=0.0 21119 IF(P.LT.0.0.OR.P.GE.1.0)THEN 21120 WRITE(ICOUT,1) 21121 1 FORMAT('***** ERROR--THE FIRST ARGUMENT TO DLGPPF ', 21122 1 'IS OUTSIDE THE ALLOWABLE (0,1) INTERVAL.') 21123 CALL DPWRST('XXX','BUG ') 21124 WRITE(ICOUT,46)P 21125 46 FORMAT('***** THE VALUE OF THE ARGUMENT IS ',G15.7,'.') 21126 CALL DPWRST('XXX','BUG ') 21127 GOTO9000 21128 ELSEIF(THETA.LE.0.0.OR.THETA.GE.1.0)THEN 21129 WRITE(ICOUT,11) 21130 11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO DLGPPF (THE ', 21131 1 'SHAPE PARAMETER) IS OUTSIDE THE (0,1) INTERVAL.') 21132 CALL DPWRST('XXX','BUG ') 21133 WRITE(ICOUT,46)THETA 21134 CALL DPWRST('XXX','BUG ') 21135 GOTO9000 21136 ENDIF 21137C 21138 PPF=1.0 21139 IX0=1 21140 IX1=1 21141 IX2=1 21142 P0=0.0 21143 P1=0.0 21144 P2=0.0 21145C 21146C TREAT CERTAIN SPECIAL CASES IMMEDIATELY-- 21147C 1) P = 0.0 21148C 21149 IF(P.EQ.0.0)THEN 21150 PPF=1.0 21151 RETURN 21152 ENDIF 21153C 21154C DETERMINE AN INITIAL APPROXIMATION TO THE LOGARITHMIC SERIES 21155C PERCENT POINT. USE MEAN VALUE = -THETA/[(1-THETA)LOG(1-THETA)] 21156C 21157 X2=-THETA/((1.0-THETA)*LOG(1.0-THETA)) 21158 IX2=INT(X2+0.5) 21159 IF(IX2.LT.5)IX2=5 21160C 21161C DETERMINE UPPER AND LOWER BOUNDS ON THE DESIRED 21162C PERCENT POINT BY ITERATING OUT (BOTH BELOW AND ABOVE) 21163C FROM THE ORIGINAL APPROXIMATION AT STEPS 21164C OF 1 STANDARD DEVIATION. 21165C THE RESULTING BOUNDS WILL BE AT MOST 21166C 1 STANDARD DEVIATION APART. 21167C 21168 IX0=1 21169 IX1=100000 21170 CONST=-1.0/LOG(1.0-THETA) 21171 SD=CONST*THETA*(1.0-CONST*THETA)/(1.0-THETA)**2 21172 IF(SD.GE.1)THEN 21173 SD=SQRT(SD) 21174 ELSE 21175 SD=1.0 21176 ENDIF 21177 ISD=INT(SD+1.0) 21178 CALL DLGCDF(REAL(IX2),THETA,P2) 21179C 21180 IF(P2.LT.P)GOTO210 21181 GOTO250 21182C 21183 210 CONTINUE 21184 IX0=IX2 21185 IF(IX0.LT.1)IX0=1 21186 I=1 21187 215 CONTINUE 21188 IX2=IX0+ISD 21189 IF(IX2.LT.1)IX2=1 21190 IF(IX2.GE.IX1)GOTO275 21191 CALL DLGCDF(REAL(IX2),THETA,P2) 21192 IF(P2.GE.P)GOTO230 21193 IX0=IX2 21194CC220 CONTINUE 21195 I=I+1 21196 IF(I.LE.1000000)GOTO215 21197 WRITE(ICOUT,249) 21198 CALL DPWRST('XXX','BUG ') 21199 WRITE(ICOUT,222) 21200 CALL DPWRST('XXX','BUG ') 21201 GOTO950 21202 230 IX1=IX2 21203 GOTO275 21204C 21205 250 CONTINUE 21206 IX1=IX2 21207 I=1 21208 255 CONTINUE 21209 IX2=IX1-ISD 21210 IF(IX2.LT.1)IX2=1 21211 IF(IX2.LE.IX0)GOTO275 21212 CALL DLGCDF(REAL(IX2),THETA,P2) 21213 IF(P2.LT.P)GOTO270 21214 IX1=IX2 21215CC260 CONTINUE 21216 I=I+1 21217 IF(I.LE.1000000)GOTO255 21218 WRITE(ICOUT,249) 21219 CALL DPWRST('XXX','BUG ') 21220 WRITE(ICOUT,262) 21221 CALL DPWRST('XXX','BUG ') 21222 GOTO950 21223 270 IX0=IX2 21224C 21225 275 IF(IX0.EQ.IX1)GOTO280 21226 GOTO295 21227 280 IF(IX0.EQ.0)GOTO285 21228CCCCC IF(IX0.EQ.N)GOTO290 21229 WRITE(ICOUT,249) 21230 CALL DPWRST('XXX','BUG ') 21231 WRITE(ICOUT,282) 21232 CALL DPWRST('XXX','BUG ') 21233 GOTO950 21234 285 IX1=IX1+1 21235 GOTO295 21236CC290 IX0=IX0-1 21237CCCCC IF(IX0.LT.1)IX0=1 21238 295 CONTINUE 21239C 21240C COMPUTE HYPERGEOMETRIC PROBABILITIES FOR THE 21241C DERIVED LOWER AND UPPER BOUNDS. 21242C 21243 CALL DLGCDF(REAL(IX0),THETA,P0) 21244 CALL DLGCDF(REAL(IX1),THETA,P1) 21245C 21246C CHECK THE PROBABILITIES FOR PROPER ORDERING 21247C 21248 IF(P0.LT.P.AND.P.LE.P1)GOTO490 21249 IF(P0.EQ.P)GOTO410 21250 IF(P1.EQ.P)GOTO420 21251 IF(P0.GT.P1)GOTO430 21252 IF(P0.GT.P)GOTO440 21253 IF(P1.LT.P)GOTO450 21254 WRITE(ICOUT,249) 21255 CALL DPWRST('XXX','BUG ') 21256 WRITE(ICOUT,401) 21257 CALL DPWRST('XXX','BUG ') 21258 GOTO950 21259 410 PPF=IX0 21260 RETURN 21261 420 PPF=IX1 21262 RETURN 21263 430 WRITE(ICOUT,249) 21264 CALL DPWRST('XXX','BUG ') 21265 WRITE(ICOUT,431) 21266 CALL DPWRST('XXX','BUG ') 21267 GOTO950 21268 440 CONTINUE 21269CCCCC WRITE(ICOUT,249) 21270CCCCC CALL DPWRST('XXX','BUG ') 21271CCCCC WRITE(ICOUT,441) 21272CCCCC CALL DPWRST('XXX','BUG ') 21273 PPF=1.0 21274 RETURN 21275CCCCC GOTO950 21276 450 WRITE(ICOUT,249) 21277 CALL DPWRST('XXX','BUG ') 21278 WRITE(ICOUT,451) 21279 CALL DPWRST('XXX','BUG ') 21280 GOTO950 21281 490 CONTINUE 21282C 21283C THE STOPPING CRITERION IS THAT THE LOWER BOUND 21284C AND UPPER BOUND ARE EXACTLY 1 UNIT APART. 21285C CHECK TO SEE IF IX1 = IX0 + 1; 21286C IF SO, THE ITERATIONS ARE COMPLETE; 21287C IF NOT, THEN BISECT, COMPUTE PROBABILIIES, 21288C CHECK PROBABILITIES, AND CONTINUE ITERATING 21289C UNTIL IX1 = IX0 + 1. 21290C 21291 300 IX0P1=IX0+1 21292 IF(IX1.EQ.IX0P1)GOTO690 21293 IX2=(IX0+IX1)/2 21294 IF(IX2.LT.1)IX2=1 21295 IF(IX2.EQ.IX0)GOTO610 21296 IF(IX2.EQ.IX1)GOTO620 21297 CALL DLGCDF(REAL(IX2),THETA,P2) 21298 IF(P0.LT.P2.AND.P2.LT.P1)GOTO630 21299 IF(P2.LE.P0)GOTO640 21300 IF(P2.GE.P1)GOTO650 21301 610 WRITE(ICOUT,249) 21302 CALL DPWRST('XXX','BUG ') 21303 WRITE(ICOUT,611) 21304 CALL DPWRST('XXX','BUG ') 21305 GOTO950 21306 620 WRITE(ICOUT,249) 21307 CALL DPWRST('XXX','BUG ') 21308 WRITE(ICOUT,611) 21309 CALL DPWRST('XXX','BUG ') 21310 GOTO950 21311 630 IF(P2.LE.P)GOTO635 21312 IX1=IX2 21313 P1=P2 21314 GOTO300 21315 635 IX0=IX2 21316 P0=P2 21317 GOTO300 21318 640 WRITE(ICOUT,249) 21319 CALL DPWRST('XXX','BUG ') 21320 WRITE(ICOUT,641) 21321 CALL DPWRST('XXX','BUG ') 21322 GOTO950 21323 650 WRITE(ICOUT,249) 21324 CALL DPWRST('XXX','BUG ') 21325 WRITE(ICOUT,651) 21326 CALL DPWRST('XXX','BUG ') 21327 GOTO950 21328 690 PPF=IX1 21329 IF(P0.EQ.P)PPF=IX0 21330 RETURN 21331C 21332 950 WRITE(ICOUT,240)IX0,P0 21333 CALL DPWRST('XXX','BUG ') 21334 WRITE(ICOUT,241)IX1,P1 21335 CALL DPWRST('XXX','BUG ') 21336 WRITE(ICOUT,242)IX2,P2 21337 CALL DPWRST('XXX','BUG ') 21338 WRITE(ICOUT,244)P 21339 CALL DPWRST('XXX','BUG ') 21340C 21341 222 FORMAT('NO UPPER BOUND FOUND AFTER 10**7 ITERATIONS') 21342 240 FORMAT('IX0 = ',I8,10X,'P0 = ',F14.7) 21343 241 FORMAT('IX1 = ',I8,10X,'P1 = ',F14.7) 21344 242 FORMAT('IX2 = ',I8,10X,'P2 = ',F14.7) 21345 244 FORMAT('P = ',F14.7) 21346 249 FORMAT('***** INTERNAL ERROR IN DLGPPF SUBROUTINE.') 21347 262 FORMAT('NO LOWER BOUND FOUND AFTER 10**7 ITERATIONS') 21348 282 FORMAT('LOWER AND UPPER BOUND IDENTICAL') 21349 401 FORMAT('IMPOSSIBLE BRANCH CONDITION ENCOUNTERED') 21350 431 FORMAT('LOWER BOUND PROBABILITY (P0) GREATER THAN ', 21351 1 'UPPER BOUND PROBABILITY (P1)') 21352CC441 FORMAT('LOWER BOUND PROBABILITY (P0) GREATER THAN ', 21353CCCCC1 'INPUT PROBABILITY (P)') 21354 451 FORMAT('UPPER BOUND PROBABILITY (P1) LESS THAN ', 21355 1 'INPUT PROBABILITY (P)') 21356 611 FORMAT('BISECTION VALUE (X2) = LOWER BOUND (X0)') 21357CC621 FORMAT('BISECTION VALUE (X2) = UPPER BOUND (X1)') 21358 641 FORMAT('BISECTION VALUE PROBABILITY (P2) ', 21359 1 'LESS THAN LOWER BOUND PROBABILITY (P0)') 21360 651 FORMAT('BISECTION VALUE PROBABILITY (P2) ', 21361 1 'GREATER THAN UPPER BOUND PROBABILITY (P1)') 21362C 21363 9000 CONTINUE 21364 RETURN 21365 END 21366 SUBROUTINE DLGRAN(N,THETA,ISEED,X) 21367C 21368C PURPOSE--THIS SUBROUTINE GENERATES A RANDOM SAMPLE OF SIZE N 21369C FROM THE LOGARITHMIC SERIES DISTRIBUTION 21370C WITH SINGLE PRECISION 'BERNOULLI PROBABILITY' 21371C PARAMETER = THETA. 21372C THE LOGARITHMIC SERIES DISTRIBUTION HAS THE 21373C PROBABILITY FUNCTION 21374C F(X) = [-1/(LOG(1-THETA)]*THETA**X/X 21375C THIS DISTRIBUTION IS DEFINED FOR 21376C ALL POSITIVE INTEGERS X--X = 1, 2, ... . 21377C ALGORITHM--METHOD OF KEMP AS DESCRIBED ON PAGE 548 OF 21378C "NON-UNIFORM RANDOM VARIATE GENERATION", 21379C LUC DEVROYE, SPRINGER-VERLAG, 1986. 21380C INPUT ARGUMENTS--N = THE DESIRED INTEGER NUMBER 21381C OF RANDOM NUMBERS TO BE 21382C GENERATED. 21383C --THETA = THE SINGLE PRECISION VALUE 21384C OF THE SHAPE PARAMETER FOR THE 21385C LOGARITHMIC SERIES DISTRIBUTION. 21386C P SHOULD BE BETWEEN 21387C 0.0 AND 1.0 (EXCLUSIVELY). 21388C OUTPUT ARGUMENTS--X = A SINGLE PRECISION VECTOR 21389C (OF DIMENSION AT LEAST N) 21390C INTO WHICH THE GENERATED 21391C RANDOM SAMPLE WILL BE PLACED. 21392C OUTPUT--A RANDOM SAMPLE OF SIZE N 21393C FROM THE LOGARITHMIC SERIES DISTRIBUTION 21394C PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS. 21395C RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE 21396C OF N FOR THIS SUBROUTINE. 21397C --THETA SHOULD BE BETWEEN 0.0 (EXCLUSIVELY) 21398C AND 1.0 (EXCLUSIVELY). 21399C OTHER DATAPAC SUBROUTINES NEEDED--UNIRAN. 21400C FORTRAN LIBRARY SUBROUTINES NEEDED--LOG. 21401C MODE OF INTERNAL OPERATIONS--SINGLE PRECISION. 21402C LANGUAGE--ANSI FORTRAN (1977) 21403C REFERENCES--LUC DEVROYE, "NIN-UNIFORM RANDOM VARIATE 21404C GENERATION", SPRINGER-VERLAG, 1986. 21405C WRITTEN BY--ALAN HECKERT 21406C STATISTICAL ENGINEERING DIVISION 21407C INFORMATION TECHNOLOGY LABORATORY 21408C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 21409C GAITHERSBURG, MD 20899-8980 21410C PHONE--301-975-2899 21411C NOTE--DATAPLOT IS A REGISTERED TRADEMARK 21412C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. 21413C LANGUAGE--ANSI FORTRAN (1977) 21414C VERSION NUMBER--2002/8 21415C ORIGINAL VERSION--AUGUST 2002. 21416C 21417C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- 21418C 21419C--------------------------------------------------------------------- 21420C 21421 DIMENSION X(*) 21422 DIMENSION XTEMP(1) 21423C 21424C--------------------------------------------------------------------- 21425C 21426 INCLUDE 'DPCOP2.INC' 21427C 21428C-----START POINT----------------------------------------------------- 21429C 21430C CHECK THE INPUT ARGUMENTS FOR ERRORS 21431C 21432 IF(N.LT.1)THEN 21433 WRITE(ICOUT,5) 21434 5 FORMAT('***** ERROR--THE FIRST ARGUMENT TO DLGRAN IS ', 21435 1 'NON-POSITIVE.') 21436 CALL DPWRST('XXX','BUG ') 21437 WRITE(ICOUT,47)N 21438 47 FORMAT(' THE VALUE OF THE ARGUMENT IS ',I8,'.') 21439 CALL DPWRST('XXX','BUG ') 21440 GOTO9999 21441 ELSEIF(THETA.LE.0.0.OR.THETA.GE.1.0)THEN 21442 WRITE(ICOUT,11) 21443 11 FORMAT('***** ERROR--THE SECOND ARGUMENT TO DLGRAN IS ', 21444 1 'OUTSIDE THE ALLOWABLE (0,1) INTERVAL.') 21445 CALL DPWRST('XXX','BUG ') 21446 WRITE(ICOUT,46)THETA 21447 46 FORMAT(' THE VALUE OF THE ARGUMENT IS ',G15.7,'.') 21448 CALL DPWRST('XXX','BUG ') 21449 GOTO9999 21450 ENDIF 21451C 21452C GENERATE N UNIFORM (0,1) RANDOM NUMBERS 21453C 21454 CALL UNIRAN(N,ISEED,X) 21455C 21456C GENERATE N LOGARITHMIC SERIES RANDOM NUMBERS 21457C USING THE KEMP ALGORITHM. 21458C 21459 NTEMP=1 21460 AR=LOG(1-THETA) 21461 DO100I=1,N 21462 AV=X(I) 21463 IF(AV.GE.THETA)THEN 21464 X(I)=1.0 21465 ELSE 21466 NTEMP=1 21467 CALL UNIRAN(NTEMP,ISEED,XTEMP) 21468 AU=XTEMP(1) 21469 AQ=1.0-EXP(AR*AU) 21470 IF(AV.LE.AQ*AQ)THEN 21471 X(I)=1.0 + LOG(AV)/LOG(AQ) 21472 X(I)=REAL(INT(X(I))) 21473 ELSEIF(AQ*AQ.LT.AV .AND. AV.LE.AQ)THEN 21474 X(I)=1.0 21475 ELSE 21476 X(I)=2.0 21477 ENDIF 21478 ENDIF 21479 100 CONTINUE 21480C 21481 9999 CONTINUE 21482 RETURN 21483 END 21484 DOUBLE PRECISION FUNCTION DLNREL (X) 21485C***BEGIN PROLOGUE DLNREL 21486C***PURPOSE Evaluate ln(1+X) accurate in the sense of relative error. 21487C***LIBRARY SLATEC (FNLIB) 21488C***CATEGORY C4B 21489C***TYPE DOUBLE PRECISION (ALNREL-S, DLNREL-D, CLNREL-C) 21490C***KEYWORDS ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM 21491C***AUTHOR Fullerton, W., (LANL) 21492C***DESCRIPTION 21493C 21494C DLNREL(X) calculates the double precision natural logarithm of 21495C (1.0+X) for double precision argument X. This routine should 21496C be used when X is small and accurate to calculate the logarithm 21497C accurately (in the relative error sense) in the neighborhood 21498C of 1.0. 21499C 21500C Series for ALNR on the interval -3.75000E-01 to 3.75000E-01 21501C with weighted error 6.35E-32 21502C log weighted error 31.20 21503C significant figures required 30.93 21504C decimal places required 32.01 21505C 21506C***REFERENCES (NONE) 21507C***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG 21508C***REVISION HISTORY (YYMMDD) 21509C 770601 DATE WRITTEN 21510C 890531 Changed all specific intrinsics to generic. (WRB) 21511C 890531 REVISION DATE from Version 3.2 21512C 891214 Prologue converted to Version 4.0 format. (BAB) 21513C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) 21514C***END PROLOGUE DLNREL 21515 DOUBLE PRECISION ALNRCS(43), X, XMIN, DCSEVL 21516 LOGICAL FIRST 21517 SAVE ALNRCS, NLNREL, XMIN, FIRST 21518C 21519C-----COMMON---------------------------------------------------------- 21520C 21521 INCLUDE 'DPCOMC.INC' 21522 INCLUDE 'DPCOP2.INC' 21523C 21524 DATA ALNRCS( 1) / +.1037869356 2743769800 6862677190 98 D+1 / 21525 DATA ALNRCS( 2) / -.1336430150 4908918098 7660415531 33 D+0 / 21526 DATA ALNRCS( 3) / +.1940824913 5520563357 9261993747 50 D-1 / 21527 DATA ALNRCS( 4) / -.3010755112 7535777690 3765377765 92 D-2 / 21528 DATA ALNRCS( 5) / +.4869461479 7154850090 4563665091 37 D-3 / 21529 DATA ALNRCS( 6) / -.8105488189 3175356066 8099430086 22 D-4 / 21530 DATA ALNRCS( 7) / +.1377884779 9559524782 9382514960 59 D-4 / 21531 DATA ALNRCS( 8) / -.2380221089 4358970251 3699929149 35 D-5 / 21532 DATA ALNRCS( 9) / +.4164041621 3865183476 3918599019 89 D-6 / 21533 DATA ALNRCS( 10) / -.7359582837 8075994984 2668370319 98 D-7 / 21534 DATA ALNRCS( 11) / +.1311761187 6241674949 1522943450 11 D-7 / 21535 DATA ALNRCS( 12) / -.2354670931 7742425136 6960923301 75 D-8 / 21536 DATA ALNRCS( 13) / +.4252277327 6034997775 6380529625 67 D-9 / 21537 DATA ALNRCS( 14) / -.7719089413 4840796826 1081074933 00 D-10 / 21538 DATA ALNRCS( 15) / +.1407574648 1359069909 2153564721 91 D-10 / 21539 DATA ALNRCS( 16) / -.2576907205 8024680627 5370786275 84 D-11 / 21540 DATA ALNRCS( 17) / +.4734240666 6294421849 1543950059 38 D-12 / 21541 DATA ALNRCS( 18) / -.8724901267 4742641745 3012632926 75 D-13 / 21542 DATA ALNRCS( 19) / +.1612461490 2740551465 7398331191 15 D-13 / 21543 DATA ALNRCS( 20) / -.2987565201 5665773006 7107924168 15 D-14 / 21544 DATA ALNRCS( 21) / +.5548070120 9082887983 0413216972 79 D-15 / 21545 DATA ALNRCS( 22) / -.1032461915 8271569595 1413339619 32 D-15 / 21546 DATA ALNRCS( 23) / +.1925023920 3049851177 8785032448 68 D-16 / 21547 DATA ALNRCS( 24) / -.3595507346 5265150011 1897078442 66 D-17 / 21548 DATA ALNRCS( 25) / +.6726454253 7876857892 1945742267 73 D-18 / 21549 DATA ALNRCS( 26) / -.1260262416 8735219252 0824256375 46 D-18 / 21550 DATA ALNRCS( 27) / +.2364488440 8606210044 9161589555 19 D-19 / 21551 DATA ALNRCS( 28) / -.4441937705 0807936898 8783891797 33 D-20 / 21552 DATA ALNRCS( 29) / +.8354659446 4034259016 2412939946 66 D-21 / 21553 DATA ALNRCS( 30) / -.1573155941 6479562574 8992535210 66 D-21 / 21554 DATA ALNRCS( 31) / +.2965312874 0247422686 1543697066 66 D-22 / 21555 DATA ALNRCS( 32) / -.5594958348 1815947292 1560132266 66 D-23 / 21556 DATA ALNRCS( 33) / +.1056635426 8835681048 1872841386 66 D-23 / 21557 DATA ALNRCS( 34) / -.1997248368 0670204548 3149994666 66 D-24 / 21558 DATA ALNRCS( 35) / +.3778297781 8839361421 0498559999 99 D-25 / 21559 DATA ALNRCS( 36) / -.7153158688 9081740345 0381653333 33 D-26 / 21560 DATA ALNRCS( 37) / +.1355248846 3674213646 5020245333 33 D-26 / 21561 DATA ALNRCS( 38) / -.2569467304 8487567430 0798293333 33 D-27 / 21562 DATA ALNRCS( 39) / +.4874775606 6216949076 4595199999 99 D-28 / 21563 DATA ALNRCS( 40) / -.9254211253 0849715321 1323733333 33 D-29 / 21564 DATA ALNRCS( 41) / +.1757859784 1760239233 2697600000 00 D-29 / 21565 DATA ALNRCS( 42) / -.3341002667 7731010351 3770666666 66 D-30 / 21566 DATA ALNRCS( 43) / +.6353393618 0236187354 1802666666 66 D-31 / 21567 DATA FIRST /.TRUE./ 21568C***FIRST EXECUTABLE STATEMENT DLNREL 21569C 21570 DLNREL = 0.0 21571C 21572 IF (FIRST) THEN 21573 NLNREL = INITDS (ALNRCS, 43, 0.1*REAL(D1MACH(3))) 21574 XMIN = -1.0D0 + SQRT(D1MACH(4)) 21575 ENDIF 21576 FIRST = .FALSE. 21577C 21578 IF (X .LE. (-1.D0)) THEN 21579 WRITE(ICOUT,11) 21580 CALL DPWRST('XXX','BUG ') 21581 WRITE(ICOUT,12) 21582 CALL DPWRST('XXX','BUG ') 21583 DLNREL = 0.0 21584 RETURN 21585 ENDIF 21586 11 FORMAT('***** ERROR FROM DLNREL. X IS LESS THAN OR ') 21587 12 FORMAT(' EQUAL TO -1. ******') 21588 IF (X .LT. XMIN) THEN 21589 WRITE(ICOUT,21) 21590 21 FORMAT('***** WARNING FROM DLNREL. ANSWER LESS THAN HALF ') 21591 CALL DPWRST('XXX','BUG ') 21592 WRITE(ICOUT,22) 21593 22 FORMAT(' PRECISION BECAUSE X IS TOO NEAR -1. *****') 21594 CALL DPWRST('XXX','BUG ') 21595 ENDIF 21596C 21597 IF (ABS(X).LE.0.375D0) DLNREL = X*(1.D0 - 21598 1 X*DCSEVL (X/.375D0, ALNRCS, NLNREL)) 21599C 21600 IF (ABS(X).GT.0.375D0) DLNREL = LOG (1.0D0+X) 21601C 21602 RETURN 21603 END 21604