316 lines
14 KiB
Fortran
316 lines
14 KiB
Fortran
!
|
|
!=======================================================================
|
|
!
|
|
MODULE LEGENDRE_FUNCTIONS
|
|
!
|
|
! This module provides Legendre polynomials and functions
|
|
!
|
|
!
|
|
USE ACCURACY_REAL
|
|
!
|
|
CONTAINS
|
|
!
|
|
!=======================================================================
|
|
!
|
|
SUBROUTINE POLLEG(NC,X,PL)
|
|
!
|
|
! This routine computes the Legendre polynomials up to order NC
|
|
! using the standard Bonnet recurrence:
|
|
!
|
|
! (n+1) P_(n+1)(x) = (2n+1)x P_(n)(x) - n P_(n-1)(x)
|
|
!
|
|
! starting from P_0(x) = 1
|
|
! P_1(x) = x
|
|
!
|
|
!
|
|
! Author : D. Sébilleau
|
|
!
|
|
! Last modified : 14 Aug 2020
|
|
!
|
|
USE REAL_NUMBERS, ONLY : ONE
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
REAL (WP) :: X
|
|
REAL (WP) :: XL,XL1,XL3
|
|
REAL (WP) :: PL(0:150)
|
|
!
|
|
INTEGER :: NC,L
|
|
INTEGER :: L1,L2
|
|
INTEGER :: LOGF
|
|
!
|
|
LOGF = 6 !
|
|
!
|
|
IF(NC > 150) THEN !
|
|
WRITE(LOGF,10) !
|
|
STOP !
|
|
END IF !
|
|
!
|
|
PL(0) = ONE !
|
|
PL(1) = X !
|
|
!
|
|
DO L=2,NC !
|
|
!
|
|
L1 = L - 1 !
|
|
L2 = L - 2 !
|
|
XL = DFLOAT(L) ! L
|
|
XL1 = DFLOAT(L1) ! L+1
|
|
XL3 = XL+XL+ONE ! 2L+1
|
|
PL(L) = (X*XL3*PL(L1)-XL1*PL(L2))/XL !
|
|
!
|
|
! Format:
|
|
!
|
|
10 FORMAT(5X,'<<<<< DIMENSION ERROR IN POLLEG >>>>>',/, &
|
|
5X,'<<<<< L > 150. RE-DIMENSION PL >>>>>',//)
|
|
!
|
|
END DO !
|
|
!
|
|
END SUBROUTINE POLLEG
|
|
!
|
|
!=======================================================================
|
|
!
|
|
SUBROUTINE PLM(NC,X,PLMM)
|
|
!
|
|
! This routine computes the associated Legendre functions
|
|
! of the first kind. It is a modified version of that written by
|
|
!
|
|
! W.H. Press, B.P. Flannery, S.A. Teukolsky and W.T. Vetterling
|
|
! in "Numerical Recipes : The Art of Scientific Computing"
|
|
! (Cambridge University Press 1992).
|
|
!
|
|
! It computes all values of P_l^m(x) up to l = NC
|
|
! and stores them as PLMM(L,M)
|
|
!
|
|
!
|
|
! Input variables :
|
|
!
|
|
! * NC : upper value of l
|
|
! * X : argument of P_l^m
|
|
!
|
|
! Output variables :
|
|
!
|
|
! * PLMM : P_l^m(x) for l = 0 to l = NC
|
|
!
|
|
!
|
|
! Last modified : 14 Aug 2020
|
|
!
|
|
!
|
|
USE REAL_NUMBERS, ONLY : ONE,TWO
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
REAL (WP) :: X
|
|
REAL (WP) :: PLMM(0:150,0:150)
|
|
REAL (WP) :: PMM,FACT,SOMX2,PMMP1,PLL
|
|
!
|
|
INTEGER :: NC,L,I,M
|
|
INTEGER :: LOGF
|
|
!
|
|
LOGF = 6 !
|
|
!
|
|
! Initialization with Legendre polynomials PLMM(L,0)
|
|
! (recurrence on L)
|
|
!
|
|
PLMM(0,0) = ONE !
|
|
PLMM(1,0) = X !
|
|
!
|
|
DO L=2,NC !
|
|
PLMM(L,0)=( X * DFLOAT(L+L-1) * PLMM(L-1,0) - & !
|
|
DFLOAT(L-1) * PLMM(L-2,0) & !
|
|
) / DFLOAT(L) !
|
|
END DO !
|
|
!
|
|
DO M=1,NC !
|
|
!
|
|
PMM = ONE !
|
|
FACT = ONE !
|
|
SOMX2 = DSQRT(ONE - X*X) !
|
|
FACT = ONE !
|
|
!
|
|
DO I=1,M !
|
|
PMM = -PMM * FACT * SOMX2 !
|
|
FACT = FACT+TWO !
|
|
END DO !
|
|
!
|
|
PMMP1 = X* FACT * PMM !
|
|
PLMM(M,M) = PMM !
|
|
PLMM(M+1,M) = PMMP1 !
|
|
!
|
|
IF(M < NC-1) THEN !
|
|
!
|
|
DO L=M+2,NC !
|
|
PLL=( X*DFLOAT(L+L-1) * PMMP1 - & !
|
|
DFLOAT(L+M-1) * PMM & !
|
|
) / DFLOAT(L-M) !
|
|
PMM = PMMP1 !
|
|
PMMP1 = PLL !
|
|
PLMM(L,M) = PLL !
|
|
!
|
|
END DO !
|
|
!
|
|
END IF !
|
|
!
|
|
END DO !
|
|
!
|
|
END SUBROUTINE PLM
|
|
!
|
|
!=======================================================================
|
|
!
|
|
SUBROUTINE LQMN(MM,M,N,X,QM,QD)
|
|
!
|
|
!
|
|
! ==========================================================
|
|
! Purpose: Compute the associated Legendre functions of the
|
|
! second kind, Qmn(x) and Qmn'(x)
|
|
! Input : x --- Argument of Qmn(x)
|
|
! m --- Order of Qmn(x) ( m = 0,1,2,...)
|
|
! n --- Degree of Qmn(x) ( n = 0,1,2,...)
|
|
! mm --- Physical dimension of QM and QD
|
|
! Output: QM(m,n) --- Qmn(x)
|
|
! QD(m,n) --- Qmn'(x)
|
|
! ==========================================================
|
|
!
|
|
! From the book "Computation of Special Functions"
|
|
! by Shanjie Zhang and Jianming Jin
|
|
! Copyright 1996 by John Wiley & Sons, Inc.
|
|
!
|
|
! The authors state:
|
|
! "However, we give permission to the reader who purchases this book
|
|
! to incorporate any of these programs into his or her programs
|
|
! provided that the copyright is acknowledged."
|
|
!
|
|
!
|
|
! Last modified (DS) : 14 Aug 2020
|
|
!
|
|
!
|
|
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,HALF,INF
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER :: MM,M,N
|
|
INTEGER :: LS,I,J,K,KM
|
|
!
|
|
REAL (WP) :: X
|
|
REAL (WP) :: QM(0:MM,0:N),QD(0:MM,0:N)
|
|
REAL (WP) :: XS,XQ,Q0,Q1,Q10,QF
|
|
REAL (WP) :: XI,XJ,XK
|
|
REAL (WP) :: QF0,QF1,QF2
|
|
!
|
|
! Trivial cas X = 1:
|
|
!
|
|
IF (DABS(X) == ONE) THEN !
|
|
!
|
|
DO I=0,M !
|
|
DO J=0,N
|
|
QM(I,J) = INF !
|
|
QD(I,J) = INF !
|
|
END DO !
|
|
END DO !
|
|
!
|
|
RETURN !
|
|
!
|
|
END IF !
|
|
!
|
|
LS = 1 !
|
|
IF(DABS(X) > ONE) LS = -1 !
|
|
XS = LS * (ONE - X*X) !
|
|
XQ = DSQRT(XS) !
|
|
Q0 = HALF * DLOG(DABS((X+ONE) / (X-ONE))) !
|
|
!
|
|
IF(DABS(X) < 1.0001E0_WP) THEN !
|
|
QM(0,0) = Q0 !
|
|
QM(0,1) = X * Q0 - ONE !
|
|
QM(1,0) = -ONE / XQ !
|
|
QM(1,1) = -XQ * (Q0 + X / (ONE - X*X)) !
|
|
!
|
|
DO I=0,1 !
|
|
XI = DFLOAT(I) !
|
|
DO J=2,N !
|
|
XJ = DFLOAT(J) !
|
|
QM(I,J )= ( (TWO*XJ-ONE) * X * QM(I,J-1) & !
|
|
-(XJ+XI-ONE)*QM(I,J-2) & !
|
|
) / (XJ-XI) !
|
|
END DO !
|
|
END DO !
|
|
!
|
|
DO J=0,N
|
|
XJ = DFLOAT(J) !
|
|
DO I=2,M
|
|
XI = DFLOAT(I) !
|
|
QM(I,J) = -TWO*(XI-ONE) * X / XQ * QM(I-1,J) - LS * & !
|
|
(XJ+XI-ONE) * (XJ-XI+TWO) * QM(I-2,J) !
|
|
END DO !
|
|
END DO !
|
|
!
|
|
ELSE !
|
|
!
|
|
IF(DABS(X) > 1.1E0_WP) THEN !
|
|
KM = 40 + M + N
|
|
ELSE
|
|
KM = (40 + M + N) * INT(- ONE - 1.8E0_WP * DLOG(X-ONE)) !
|
|
END IF !
|
|
!
|
|
QF2 = ZERO !
|
|
QF1 = ONE !
|
|
!
|
|
DO K=KM,0,-1 !
|
|
XK = DFLOAT(K) !
|
|
QF0 = ( (XK + XK + THREE)*X*QF1-(XK+TWO)*QF2 ) / (XK+ONE) !
|
|
IF(K <= N) QM(0,K) = QF0 !
|
|
QF2 = QF1 !
|
|
QF1 = QF0 !
|
|
END DO !
|
|
!
|
|
DO K=0,N !
|
|
QM(0,K) = Q0 * QM(0,K) / QF0 !
|
|
END DO !
|
|
!
|
|
QF2 = ZERO !
|
|
QF1 = ONE !
|
|
!
|
|
DO K=KM,0,-1
|
|
XK = DFLOAT(K) !
|
|
QF0 = ( (XK + XK + THREE)*X*QF1-(XK+ONE)*QF2 ) / (XK+TWO) !
|
|
IF(K <= N) QM(1,K) = QF0 !
|
|
QF2 = QF1 !
|
|
QF1 = QF0 !
|
|
END DO !
|
|
!
|
|
Q10 = -ONE / XQ !
|
|
!
|
|
DO K=0,N !
|
|
QM(1,K) = Q10 * QM(1,K) / QF0 !
|
|
END DO !
|
|
!
|
|
DO J=0,N !
|
|
XJ = DFLOAT(J) !
|
|
Q0 = QM(0,J) !
|
|
Q1 = QM(1,J) !
|
|
DO I=0,M-2 !
|
|
XI = DFLOAT(I) !
|
|
QF = -TWO*(XI+1)*X/XQ*Q1+(XJ-XI)*(XJ+XI+ONE)*Q0 !
|
|
QM(I+2,J) = QF !
|
|
Q0 = Q1 !
|
|
Q1 = QF !
|
|
END DO !
|
|
END DO !
|
|
!
|
|
END IF !
|
|
!
|
|
QD(0,0) = DFLOAT(LS) / XS !
|
|
DO J=1,N !
|
|
QD(0,J) = LS * J * ( QM(0,J-1) - X * QM(0,J) ) / XS !
|
|
END DO !
|
|
DO J=0,N !
|
|
XJ = DFLOAT(J) !
|
|
DO I=1,M !
|
|
XI = DFLOAT(I) !
|
|
QD(I,J) = LS*XI*X/XS*QM(I,J) + (XI+XJ)*(XJ-XI+ONE) / & !
|
|
XQ*QM(I-1,J) !
|
|
END DO !
|
|
END DO !
|
|
!
|
|
END SUBROUTINE LQMN
|
|
!
|
|
END MODULE LEGENDRE_FUNCTIONS
|