mirror of
https://git.planet-casio.com/Lephenixnoir/OpenLibm.git
synced 2025-01-01 06:23:39 +01:00
124 lines
3.3 KiB
Fortran
124 lines
3.3 KiB
Fortran
*DECK DXQNU
|
|
SUBROUTINE DXQNU (NU1, NU2, MU1, THETA, X, SX, ID, PQA, IPQA,
|
|
1 IERROR)
|
|
C***BEGIN PROLOGUE DXQNU
|
|
C***SUBSIDIARY
|
|
C***PURPOSE To compute the values of Legendre functions for DXLEGF.
|
|
C Method: backward nu-wise recurrence for Q(MU,NU,X) for
|
|
C fixed mu to obtain Q(MU1,NU1,X), Q(MU1,NU1+1,X), ...,
|
|
C Q(MU1,NU2,X).
|
|
C***LIBRARY SLATEC
|
|
C***CATEGORY C3A2, C9
|
|
C***TYPE DOUBLE PRECISION (XQNU-S, DXQNU-D)
|
|
C***KEYWORDS LEGENDRE FUNCTIONS
|
|
C***AUTHOR Smith, John M., (NBS and George Mason University)
|
|
C***ROUTINES CALLED DXADD, DXADJ, DXPQNU
|
|
C***REVISION HISTORY (YYMMDD)
|
|
C 820728 DATE WRITTEN
|
|
C 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS)
|
|
C 901019 Revisions to prologue. (DWL and WRB)
|
|
C 901106 Corrected order of sections in prologue and added TYPE
|
|
C section. (WRB)
|
|
C 920127 Revised PURPOSE section of prologue. (DWL)
|
|
C***END PROLOGUE DXQNU
|
|
DIMENSION PQA(*),IPQA(*)
|
|
DOUBLE PRECISION DMU,NU,NU1,NU2,PQ,PQA,PQ1,PQ2,SX,X,X1,X2
|
|
DOUBLE PRECISION THETA,PQL1,PQL2
|
|
C***FIRST EXECUTABLE STATEMENT DXQNU
|
|
IERROR=0
|
|
K=0
|
|
PQ2=0.0D0
|
|
IPQ2=0
|
|
PQL2=0.0D0
|
|
IPQL2=0
|
|
IF(MU1.EQ.1) GO TO 290
|
|
MU=0
|
|
C
|
|
C CALL DXPQNU TO OBTAIN Q(0.,NU2,X) AND Q(0.,NU2-1,X)
|
|
C
|
|
CALL DXPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR)
|
|
IF (IERROR.NE.0) RETURN
|
|
IF(MU1.EQ.0) RETURN
|
|
K=(NU2-NU1+1.5D0)
|
|
PQ2=PQA(K)
|
|
IPQ2=IPQA(K)
|
|
PQL2=PQA(K-1)
|
|
IPQL2=IPQA(K-1)
|
|
290 MU=1
|
|
C
|
|
C CALL DXPQNU TO OBTAIN Q(1.,NU2,X) AND Q(1.,NU2-1,X)
|
|
C
|
|
CALL DXPQNU(NU1,NU2,MU,THETA,ID,PQA,IPQA,IERROR)
|
|
IF (IERROR.NE.0) RETURN
|
|
IF(MU1.EQ.1) RETURN
|
|
NU=NU2
|
|
PQ1=PQA(K)
|
|
IPQ1=IPQA(K)
|
|
PQL1=PQA(K-1)
|
|
IPQL1=IPQA(K-1)
|
|
300 MU=1
|
|
DMU=1.D0
|
|
320 CONTINUE
|
|
C
|
|
C FORWARD RECURRENCE IN MU TO OBTAIN Q(MU1,NU2,X) AND
|
|
C Q(MU1,NU2-1,X) USING
|
|
C Q(MU+1,NU,X)=-2.*MU*X*SQRT(1./(1.-X**2))*Q(MU,NU,X)
|
|
C -(NU+MU)*(NU-MU+1.)*Q(MU-1,NU,X)
|
|
C
|
|
C FIRST FOR NU=NU2
|
|
C
|
|
X1=-2.D0*DMU*X*SX*PQ1
|
|
X2=(NU+DMU)*(NU-DMU+1.D0)*PQ2
|
|
CALL DXADD(X1,IPQ1,-X2,IPQ2,PQ,IPQ,IERROR)
|
|
IF (IERROR.NE.0) RETURN
|
|
CALL DXADJ(PQ,IPQ,IERROR)
|
|
IF (IERROR.NE.0) RETURN
|
|
PQ2=PQ1
|
|
IPQ2=IPQ1
|
|
PQ1=PQ
|
|
IPQ1=IPQ
|
|
MU=MU+1
|
|
DMU=DMU+1.D0
|
|
IF(MU.LT.MU1) GO TO 320
|
|
PQA(K)=PQ
|
|
IPQA(K)=IPQ
|
|
IF(K.EQ.1) RETURN
|
|
IF(NU.LT.NU2) GO TO 340
|
|
C
|
|
C THEN FOR NU=NU2-1
|
|
C
|
|
NU=NU-1.D0
|
|
PQ2=PQL2
|
|
IPQ2=IPQL2
|
|
PQ1=PQL1
|
|
IPQ1=IPQL1
|
|
K=K-1
|
|
GO TO 300
|
|
C
|
|
C BACKWARD RECURRENCE IN NU TO OBTAIN
|
|
C Q(MU1,NU1,X),Q(MU1,NU1+1,X),....,Q(MU1,NU2,X)
|
|
C USING
|
|
C (NU-MU+1.)*Q(MU,NU+1,X)=
|
|
C (2.*NU+1.)*X*Q(MU,NU,X)-(NU+MU)*Q(MU,NU-1,X)
|
|
C
|
|
340 PQ1=PQA(K)
|
|
IPQ1=IPQA(K)
|
|
PQ2=PQA(K+1)
|
|
IPQ2=IPQA(K+1)
|
|
350 IF(NU.LE.NU1) RETURN
|
|
K=K-1
|
|
X1=(2.D0*NU+1.D0)*X*PQ1/(NU+DMU)
|
|
X2=-(NU-DMU+1.D0)*PQ2/(NU+DMU)
|
|
CALL DXADD(X1,IPQ1,X2,IPQ2,PQ,IPQ,IERROR)
|
|
IF (IERROR.NE.0) RETURN
|
|
CALL DXADJ(PQ,IPQ,IERROR)
|
|
IF (IERROR.NE.0) RETURN
|
|
PQ2=PQ1
|
|
IPQ2=IPQ1
|
|
PQ1=PQ
|
|
IPQ1=IPQ
|
|
PQA(K)=PQ
|
|
IPQA(K)=IPQ
|
|
NU=NU-1.D0
|
|
GO TO 350
|
|
END
|