Fcalva/OpenLibm
1
0
Fork 0
mirror of https://git.planet-casio.com/Lephenixnoir/OpenLibm.git synced 2025-01-01 06:23:39 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions
OpenLibm/slatec/dyairy.f
Viral B. Shah c977aa998f Add Makefile.extras to build libopenlibm-extras. 
Replace amos with slatec
2012-12-31 16:37:05 -05:00

394 lines
16 KiB
Fortran
Raw Blame History

*DECK DYAIRY
SUBROUTINE DYAIRY (X, RX, C, BI, DBI)
C***BEGIN PROLOGUE DYAIRY
C***SUBSIDIARY
C***PURPOSE Subsidiary to DBESJ and DBESY
C***LIBRARY SLATEC
C***TYPE DOUBLE PRECISION (YAIRY-S, DYAIRY-D)
C***AUTHOR Amos, D. E., (SNLA)
C Daniel, S. L., (SNLA)
C***DESCRIPTION
C
C DYAIRY computes the Airy function BI(X)
C and its derivative DBI(X) for DASYJY
C
C INPUT
C
C X - Argument, computed by DASYJY, X unrestricted
C RX - RX=SQRT(ABS(X)), computed by DASYJY
C C - C=2.*(ABS(X)**1.5)/3., computed by DASYJY
C
C OUTPUT
C BI - Value of function BI(X)
C DBI - Value of the derivative DBI(X)
C
C***SEE ALSO DBESJ, DBESY
C***ROUTINES CALLED (NONE)
C***REVISION HISTORY (YYMMDD)
C 750101 DATE WRITTEN
C 890531 Changed all specific intrinsics to generic. (WRB)
C 891214 Prologue converted to Version 4.0 format. (BAB)
C 900328 Added TYPE section. (WRB)
C 910408 Updated the AUTHOR section. (WRB)
C***END PROLOGUE DYAIRY
C
INTEGER I, J, M1, M1D, M2, M2D, M3, M3D, M4D, N1, N1D, N2, N2D,
1 N3, N3D, N4D
DOUBLE PRECISION AA,AX,BB,BI,BJN,BJP,BK1,BK2,BK3,BK4,C,CON1,CON2,
1 CON3, CV, DAA, DBB, DBI, DBJN, DBJP, DBK1, DBK2, DBK3, DBK4, D1,
2 D2, EX, E1, E2, FPI12, F1, F2, RTRX, RX, SPI12, S1, S2, T, TC,
3 TEMP1, TEMP2, TT, X
DIMENSION BK1(20), BK2(20), BK3(20), BK4(14)
DIMENSION BJP(19), BJN(19), AA(14), BB(14)
DIMENSION DBK1(21), DBK2(20), DBK3(20), DBK4(14)
DIMENSION DBJP(19), DBJN(19), DAA(14), DBB(14)
SAVE N1, N2, N3, M1, M2, M3, N1D, N2D, N3D, N4D,
1 M1D, M2D, M3D, M4D, FPI12, SPI12, CON1, CON2, CON3,
2 BK1, BK2, BK3, BK4, BJN, BJP, AA, BB, DBK1, DBK2, DBK3, DBK4,
3 DBJP, DBJN, DAA, DBB
DATA N1,N2,N3/20,19,14/
DATA M1,M2,M3/18,17,12/
DATA N1D,N2D,N3D,N4D/21,20,19,14/
DATA M1D,M2D,M3D,M4D/19,18,17,12/
DATA FPI12,SPI12,CON1,CON2,CON3/
1 1.30899693899575D+00, 1.83259571459405D+00, 6.66666666666667D-01,
2 7.74148278841779D+00, 3.64766105490356D-01/
DATA BK1(1), BK1(2), BK1(3), BK1(4), BK1(5), BK1(6),
1 BK1(7), BK1(8), BK1(9), BK1(10), BK1(11), BK1(12),
2 BK1(13), BK1(14), BK1(15), BK1(16), BK1(17), BK1(18),
3 BK1(19), BK1(20)/ 2.43202846447449D+00, 2.57132009754685D+00,
4 1.02802341258616D+00, 3.41958178205872D-01, 8.41978629889284D-02,
5 1.93877282587962D-02, 3.92687837130335D-03, 6.83302689948043D-04,
6 1.14611403991141D-04, 1.74195138337086D-05, 2.41223620956355D-06,
7 3.24525591983273D-07, 4.03509798540183D-08, 4.70875059642296D-09,
8 5.35367432585889D-10, 5.70606721846334D-11, 5.80526363709933D-12,
9 5.76338988616388D-13, 5.42103834518071D-14, 4.91857330301677D-15/
DATA BK2(1), BK2(2), BK2(3), BK2(4), BK2(5), BK2(6),
1 BK2(7), BK2(8), BK2(9), BK2(10), BK2(11), BK2(12),
2 BK2(13), BK2(14), BK2(15), BK2(16), BK2(17), BK2(18),
3 BK2(19), BK2(20)/ 5.74830555784088D-01,-6.91648648376891D-03,
4 1.97460263052093D-03,-5.24043043868823D-04, 1.22965147239661D-04,
5-2.27059514462173D-05, 2.23575555008526D-06, 4.15174955023899D-07,
6-2.84985752198231D-07, 8.50187174775435D-08,-1.70400826891326D-08,
7 2.25479746746889D-09,-1.09524166577443D-10,-3.41063845099711D-11,
8 1.11262893886662D-11,-1.75542944241734D-12, 1.36298600401767D-13,
9 8.76342105755664D-15,-4.64063099157041D-15, 7.78772758732960D-16/
DATA BK3(1), BK3(2), BK3(3), BK3(4), BK3(5), BK3(6),
1 BK3(7), BK3(8), BK3(9), BK3(10), BK3(11), BK3(12),
2 BK3(13), BK3(14), BK3(15), BK3(16), BK3(17), BK3(18),
3 BK3(19), BK3(20)/ 5.66777053506912D-01, 2.63672828349579D-03,
4 5.12303351473130D-05, 2.10229231564492D-06, 1.42217095113890D-07,
5 1.28534295891264D-08, 7.28556219407507D-10,-3.45236157301011D-10,
6-2.11919115912724D-10,-6.56803892922376D-11,-8.14873160315074D-12,
7 3.03177845632183D-12, 1.73447220554115D-12, 1.67935548701554D-13,
8-1.49622868806719D-13,-5.15470458953407D-14, 8.75741841857830D-15,
9 7.96735553525720D-15,-1.29566137861742D-16,-1.11878794417520D-15/
DATA BK4(1), BK4(2), BK4(3), BK4(4), BK4(5), BK4(6),
1 BK4(7), BK4(8), BK4(9), BK4(10), BK4(11), BK4(12),
2 BK4(13), BK4(14)/ 4.85444386705114D-01,-3.08525088408463D-03,
3 6.98748404837928D-05,-2.82757234179768D-06, 1.59553313064138D-07,
4-1.12980692144601D-08, 9.47671515498754D-10,-9.08301736026423D-11,
5 9.70776206450724D-12,-1.13687527254574D-12, 1.43982917533415D-13,
6-1.95211019558815D-14, 2.81056379909357D-15,-4.26916444775176D-16/
DATA BJP(1), BJP(2), BJP(3), BJP(4), BJP(5), BJP(6),
1 BJP(7), BJP(8), BJP(9), BJP(10), BJP(11), BJP(12),
2 BJP(13), BJP(14), BJP(15), BJP(16), BJP(17), BJP(18),
3 BJP(19) / 1.34918611457638D-01,-3.19314588205813D-01,
4 5.22061946276114D-02, 5.28869112170312D-02,-8.58100756077350D-03,
5-2.99211002025555D-03, 4.21126741969759D-04, 8.73931830369273D-05,
6-1.06749163477533D-05,-1.56575097259349D-06, 1.68051151983999D-07,
7 1.89901103638691D-08,-1.81374004961922D-09,-1.66339134593739D-10,
8 1.42956335780810D-11, 1.10179811626595D-12,-8.60187724192263D-14,
9-5.71248177285064D-15, 4.08414552853803D-16/
DATA BJN(1), BJN(2), BJN(3), BJN(4), BJN(5), BJN(6),
1 BJN(7), BJN(8), BJN(9), BJN(10), BJN(11), BJN(12),
2 BJN(13), BJN(14), BJN(15), BJN(16), BJN(17), BJN(18),
3 BJN(19) / 6.59041673525697D-02,-4.24905910566004D-01,
4 2.87209745195830D-01, 1.29787771099606D-01,-4.56354317590358D-02,
5-1.02630175982540D-02, 2.50704671521101D-03, 3.78127183743483D-04,
6-7.11287583284084D-05,-8.08651210688923D-06, 1.23879531273285D-06,
7 1.13096815867279D-07,-1.46234283176310D-08,-1.11576315688077D-09,
8 1.24846618243897D-10, 8.18334132555274D-12,-8.07174877048484D-13,
9-4.63778618766425D-14, 4.09043399081631D-15/
DATA AA(1), AA(2), AA(3), AA(4), AA(5), AA(6),
1 AA(7), AA(8), AA(9), AA(10), AA(11), AA(12),
2 AA(13), AA(14) /-2.78593552803079D-01, 3.52915691882584D-03,
3 2.31149677384994D-05,-4.71317842263560D-06, 1.12415907931333D-07,
4 2.00100301184339D-08,-2.60948075302193D-09, 3.55098136101216D-11,
5 3.50849978423875D-11,-5.83007187954202D-12, 2.04644828753326D-13,
6 1.10529179476742D-13,-2.87724778038775D-14, 2.88205111009939D-15/
DATA BB(1), BB(2), BB(3), BB(4), BB(5), BB(6),
1 BB(7), BB(8), BB(9), BB(10), BB(11), BB(12),
2 BB(13), BB(14) /-4.90275424742791D-01,-1.57647277946204D-03,
3 9.66195963140306D-05,-1.35916080268815D-07,-2.98157342654859D-07,
4 1.86824767559979D-08, 1.03685737667141D-09,-3.28660818434328D-10,
5 2.57091410632780D-11, 2.32357655300677D-12,-9.57523279048255D-13,
6 1.20340828049719D-13, 2.90907716770715D-15,-4.55656454580149D-15/
DATA DBK1(1), DBK1(2), DBK1(3), DBK1(4), DBK1(5), DBK1(6),
1 DBK1(7), DBK1(8), DBK1(9), DBK1(10),DBK1(11),DBK1(12),
2 DBK1(13),DBK1(14),DBK1(15),DBK1(16),DBK1(17),DBK1(18),
3 DBK1(19),DBK1(20),
4 DBK1(21) / 2.95926143981893D+00, 3.86774568440103D+00,
5 1.80441072356289D+00, 5.78070764125328D-01, 1.63011468174708D-01,
6 3.92044409961855D-02, 7.90964210433812D-03, 1.50640863167338D-03,
7 2.56651976920042D-04, 3.93826605867715D-05, 5.81097771463818D-06,
8 7.86881233754659D-07, 9.93272957325739D-08, 1.21424205575107D-08,
9 1.38528332697707D-09, 1.50190067586758D-10, 1.58271945457594D-11,
1 1.57531847699042D-12, 1.50774055398181D-13, 1.40594335806564D-14,
2 1.24942698777218D-15/
DATA DBK2(1), DBK2(2), DBK2(3), DBK2(4), DBK2(5), DBK2(6),
1 DBK2(7), DBK2(8), DBK2(9), DBK2(10),DBK2(11),DBK2(12),
2 DBK2(13),DBK2(14),DBK2(15),DBK2(16),DBK2(17),DBK2(18),
3 DBK2(19),DBK2(20)/ 5.49756809432471D-01, 9.13556983276901D-03,
4-2.53635048605507D-03, 6.60423795342054D-04,-1.55217243135416D-04,
5 3.00090325448633D-05,-3.76454339467348D-06,-1.33291331611616D-07,
6 2.42587371049013D-07,-8.07861075240228D-08, 1.71092818861193D-08,
7-2.41087357570599D-09, 1.53910848162371D-10, 2.56465373190630D-11,
8-9.88581911653212D-12, 1.60877986412631D-12,-1.20952524741739D-13,
9-1.06978278410820D-14, 5.02478557067561D-15,-8.68986130935886D-16/
DATA DBK3(1), DBK3(2), DBK3(3), DBK3(4), DBK3(5), DBK3(6),
1 DBK3(7), DBK3(8), DBK3(9), DBK3(10),DBK3(11),DBK3(12),
2 DBK3(13),DBK3(14),DBK3(15),DBK3(16),DBK3(17),DBK3(18),
3 DBK3(19),DBK3(20)/ 5.60598509354302D-01,-3.64870013248135D-03,
4-5.98147152307417D-05,-2.33611595253625D-06,-1.64571516521436D-07,
5-2.06333012920569D-08,-4.27745431573110D-09,-1.08494137799276D-09,
6-2.37207188872763D-10,-2.22132920864966D-11, 1.07238008032138D-11,
7 5.71954845245808D-12, 7.51102737777835D-13,-3.81912369483793D-13,
8-1.75870057119257D-13, 6.69641694419084D-15, 2.26866724792055D-14,
9 2.69898141356743D-15,-2.67133612397359D-15,-6.54121403165269D-16/
DATA DBK4(1), DBK4(2), DBK4(3), DBK4(4), DBK4(5), DBK4(6),
1 DBK4(7), DBK4(8), DBK4(9), DBK4(10),DBK4(11),DBK4(12),
2 DBK4(13),DBK4(14)/ 4.93072999188036D-01, 4.38335419803815D-03,
3-8.37413882246205D-05, 3.20268810484632D-06,-1.75661979548270D-07,
4 1.22269906524508D-08,-1.01381314366052D-09, 9.63639784237475D-11,
5-1.02344993379648D-11, 1.19264576554355D-12,-1.50443899103287D-13,
6 2.03299052379349D-14,-2.91890652008292D-15, 4.42322081975475D-16/
DATA DBJP(1), DBJP(2), DBJP(3), DBJP(4), DBJP(5), DBJP(6),
1 DBJP(7), DBJP(8), DBJP(9), DBJP(10),DBJP(11),DBJP(12),
2 DBJP(13),DBJP(14),DBJP(15),DBJP(16),DBJP(17),DBJP(18),
3 DBJP(19) / 1.13140872390745D-01,-2.08301511416328D-01,
4 1.69396341953138D-02, 2.90895212478621D-02,-3.41467131311549D-03,
5-1.46455339197417D-03, 1.63313272898517D-04, 3.91145328922162D-05,
6-3.96757190808119D-06,-6.51846913772395D-07, 5.98707495269280D-08,
7 7.44108654536549D-09,-6.21241056522632D-10,-6.18768017313526D-11,
8 4.72323484752324D-12, 3.91652459802532D-13,-2.74985937845226D-14,
9-1.95036497762750D-15, 1.26669643809444D-16/
DATA DBJN(1), DBJN(2), DBJN(3), DBJN(4), DBJN(5), DBJN(6),
1 DBJN(7), DBJN(8), DBJN(9), DBJN(10),DBJN(11),DBJN(12),
2 DBJN(13),DBJN(14),DBJN(15),DBJN(16),DBJN(17),DBJN(18),
3 DBJN(19) /-1.88091260068850D-02,-1.47798180826140D-01,
4 5.46075900433171D-01, 1.52146932663116D-01,-9.58260412266886D-02,
5-1.63102731696130D-02, 5.75364806680105D-03, 7.12145408252655D-04,
6-1.75452116846724D-04,-1.71063171685128D-05, 3.24435580631680D-06,
7 2.61190663932884D-07,-4.03026865912779D-08,-2.76435165853895D-09,
8 3.59687929062312D-10, 2.14953308456051D-11,-2.41849311903901D-12,
9-1.28068004920751D-13, 1.26939834401773D-14/
DATA DAA(1), DAA(2), DAA(3), DAA(4), DAA(5), DAA(6),
1 DAA(7), DAA(8), DAA(9), DAA(10), DAA(11), DAA(12),
2 DAA(13), DAA(14)/ 2.77571356944231D-01,-4.44212833419920D-03,
3 8.42328522190089D-05, 2.58040318418710D-06,-3.42389720217621D-07,
4 6.24286894709776D-09, 2.36377836844577D-09,-3.16991042656673D-10,
5 4.40995691658191D-12, 5.18674221093575D-12,-9.64874015137022D-13,
6 4.90190576608710D-14, 1.77253430678112D-14,-5.55950610442662D-15/
DATA DBB(1), DBB(2), DBB(3), DBB(4), DBB(5), DBB(6),
1 DBB(7), DBB(8), DBB(9), DBB(10), DBB(11), DBB(12),
2 DBB(13), DBB(14)/ 4.91627321104601D-01, 3.11164930427489D-03,
3 8.23140762854081D-05,-4.61769776172142D-06,-6.13158880534626D-08,
4 2.87295804656520D-08,-1.81959715372117D-09,-1.44752826642035D-10,
5 4.53724043420422D-11,-3.99655065847223D-12,-3.24089119830323D-13,
6 1.62098952568741D-13,-2.40765247974057D-14, 1.69384811284491D-16/
C***FIRST EXECUTABLE STATEMENT DYAIRY
AX = ABS(X)
RX = SQRT(AX)
C = CON1*AX*RX
IF (X.LT.0.0D0) GO TO 120
IF (C.GT.8.0D0) GO TO 60
IF (X.GT.2.5D0) GO TO 30
T = (X+X-2.5D0)*0.4D0
TT = T + T
J = N1
F1 = BK1(J)
F2 = 0.0D0
DO 10 I=1,M1
J = J - 1
TEMP1 = F1
F1 = TT*F1 - F2 + BK1(J)
F2 = TEMP1
10 CONTINUE
BI = T*F1 - F2 + BK1(1)
J = N1D
F1 = DBK1(J)
F2 = 0.0D0
DO 20 I=1,M1D
J = J - 1
TEMP1 = F1
F1 = TT*F1 - F2 + DBK1(J)
F2 = TEMP1
20 CONTINUE
DBI = T*F1 - F2 + DBK1(1)
RETURN
30 CONTINUE
RTRX = SQRT(RX)
T = (X+X-CON2)*CON3
TT = T + T
J = N1
F1 = BK2(J)
F2 = 0.0D0
DO 40 I=1,M1
J = J - 1
TEMP1 = F1
F1 = TT*F1 - F2 + BK2(J)
F2 = TEMP1
40 CONTINUE
BI = (T*F1-F2+BK2(1))/RTRX
EX = EXP(C)
BI = BI*EX
J = N2D
F1 = DBK2(J)
F2 = 0.0D0
DO 50 I=1,M2D
J = J - 1
TEMP1 = F1
F1 = TT*F1 - F2 + DBK2(J)
F2 = TEMP1
50 CONTINUE
DBI = (T*F1-F2+DBK2(1))*RTRX
DBI = DBI*EX
RETURN
C
60 CONTINUE
RTRX = SQRT(RX)
T = 16.0D0/C - 1.0D0
TT = T + T
J = N1
F1 = BK3(J)
F2 = 0.0D0
DO 70 I=1,M1
J = J - 1
TEMP1 = F1
F1 = TT*F1 - F2 + BK3(J)
F2 = TEMP1
70 CONTINUE
S1 = T*F1 - F2 + BK3(1)
J = N2D
F1 = DBK3(J)
F2 = 0.0D0
DO 80 I=1,M2D
J = J - 1
TEMP1 = F1
F1 = TT*F1 - F2 + DBK3(J)
F2 = TEMP1
80 CONTINUE
D1 = T*F1 - F2 + DBK3(1)
TC = C + C
EX = EXP(C)
IF (TC.GT.35.0D0) GO TO 110
T = 10.0D0/C - 1.0D0
TT = T + T
J = N3
F1 = BK4(J)
F2 = 0.0D0
DO 90 I=1,M3
J = J - 1
TEMP1 = F1
F1 = TT*F1 - F2 + BK4(J)
F2 = TEMP1
90 CONTINUE
S2 = T*F1 - F2 + BK4(1)
BI = (S1+EXP(-TC)*S2)/RTRX
BI = BI*EX
J = N4D
F1 = DBK4(J)
F2 = 0.0D0
DO 100 I=1,M4D
J = J - 1
TEMP1 = F1
F1 = TT*F1 - F2 + DBK4(J)
F2 = TEMP1
100 CONTINUE
D2 = T*F1 - F2 + DBK4(1)
DBI = RTRX*(D1+EXP(-TC)*D2)
DBI = DBI*EX
RETURN
110 BI = EX*S1/RTRX
DBI = EX*RTRX*D1
RETURN
C
120 CONTINUE
IF (C.GT.5.0D0) GO TO 150
T = 0.4D0*C - 1.0D0
TT = T + T
J = N2
F1 = BJP(J)
E1 = BJN(J)
F2 = 0.0D0
E2 = 0.0D0
DO 130 I=1,M2
J = J - 1
TEMP1 = F1
TEMP2 = E1
F1 = TT*F1 - F2 + BJP(J)
E1 = TT*E1 - E2 + BJN(J)
F2 = TEMP1
E2 = TEMP2
130 CONTINUE
BI = (T*E1-E2+BJN(1)) - AX*(T*F1-F2+BJP(1))
J = N3D
F1 = DBJP(J)
E1 = DBJN(J)
F2 = 0.0D0
E2 = 0.0D0
DO 140 I=1,M3D
J = J - 1
TEMP1 = F1
TEMP2 = E1
F1 = TT*F1 - F2 + DBJP(J)
E1 = TT*E1 - E2 + DBJN(J)
F2 = TEMP1
E2 = TEMP2
140 CONTINUE
DBI = X*X*(T*F1-F2+DBJP(1)) + (T*E1-E2+DBJN(1))
RETURN
C
150 CONTINUE
RTRX = SQRT(RX)
T = 10.0D0/C - 1.0D0
TT = T + T
J = N3
F1 = AA(J)
E1 = BB(J)
F2 = 0.0D0
E2 = 0.0D0
DO 160 I=1,M3
J = J - 1
TEMP1 = F1
TEMP2 = E1
F1 = TT*F1 - F2 + AA(J)
E1 = TT*E1 - E2 + BB(J)
F2 = TEMP1
E2 = TEMP2
160 CONTINUE
TEMP1 = T*F1 - F2 + AA(1)
TEMP2 = T*E1 - E2 + BB(1)
CV = C - FPI12
BI = (TEMP1*COS(CV)+TEMP2*SIN(CV))/RTRX
J = N4D
F1 = DAA(J)
E1 = DBB(J)
F2 = 0.0D0
E2 = 0.0D0
DO 170 I=1,M4D
J = J - 1
TEMP1 = F1
TEMP2 = E1
F1 = TT*F1 - F2 + DAA(J)
E1 = TT*E1 - E2 + DBB(J)
F2 = TEMP1
E2 = TEMP2
170 CONTINUE
TEMP1 = T*F1 - F2 + DAA(1)
TEMP2 = T*E1 - E2 + DBB(1)
CV = C - SPI12
DBI = (TEMP1*COS(CV)-TEMP2*SIN(CV))*RTRX
RETURN
END
Reference in a new issue View git blame Copy permalink