End of file
Contents
Index
SUBROUTINE GALE0 (IDGR, FLAG, ALPHA, ZWGH)
C
C*****************************************************************
C *
C The SUBROUTINE GALE0 determines the nodes and weights of the *
C GAUSS-quadrature formula of degree IDGR. *
C *
C *
C INPUT PARAMETERS: *
C ================= *
C IDGR : degree of the quadrature formula *
C FLAG : = .TRUE. if the the weights shall be determined *
C = .FALSE. only the nodes are to be determined *
C *
C *
C OUTPUT PARAMETERS *
C ================== *
C ALPHA : vector ALPHA(1:21); contains the nodes of the Gauss *
C quadrature formula of degree IDGR *
C ZWGH : vector ZWGH(1:21); contains the weights for the nodes *
C ALPHA *
C *
C----------------------------------------------------------------*
C *
C subroutines required : GXPOLY, GXPEGA, MACHPD *
C *
C*****************************************************************
C *
C author : Hermann-Josef Rheinbach *
C editor : Norbert Vogt *
C date : 04.10.1989 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION POLD(0:100), PMID(0:100), C(0:100)
DIMENSION ALPHA(1:IDGR), ZWGH(1:IDGR)
LOGICAL FLAG
C
C determine the coefficients of the LEGENDRE-polynomial
C
POLD(0) = 1.0D0
PMID(0) = 0.0D0
PMID(1) = 1.0D0
XK = 0.0D0
ZPDGR = DBLE(IDGR)
KPLUS = IDGR
C
DO 10 K = 1, IDGR-1
XK = XK + 1.0D0
XKPLUS = XK + 1.0D0
XKINV = 1.0D0 / XKPLUS
XFA = (XK + XKPLUS) * XKINV
DO 20 I = 0, K
C(I+1) = PMID(I) * XFA
20 CONTINUE
C(0) = 0.0D0
XFA = XK * XKINV
DO 30 I = 0, K-1
C(I) = C(I) - POLD(I) * XFA
POLD(I) = PMID(I)
30 CONTINUE
POLD(K) = PMID(K)
DO 40 I = 0, K+1
PMID(I) = C(I)
40 CONTINUE
C
10 CONTINUE
C
C determine the zeros if lying symmetrically to the
C origin with corresponding weights
C
BORDRA = 1.0D0
ZW = 3.141592654D0 / (ZPDGR - 0.5D0)
KDIV2 = INT(ZPDGR*0.5D0)
DO 50 J = 1, KDIV2
ZJ = DBLE(J)
BORDRB = 0.5D0 * DBLE((DCOS((ZJ-0.5D0)*ZW) + DCOS(ZJ*ZW)))
CALL GXPEGA (BORDRA, BORDRB, C, KPLUS, XSI)
ALPHA(J) = XSI
BORDRA = BORDRB
50 CONTINUE
DO 55 I = 1, KDIV2
ALPHA(I) = -ALPHA(I)
55 CONTINUE
IPOS = KDIV2
IF ((MOD(IDGR,2) .EQ. 1)) THEN
IPOS = KDIV2 + 1
ALPHA(IPOS) = 0.0D0
DO 60 I = 1, KDIV2
ALPHA(IPOS+I) = -ALPHA(IPOS-I)
60 CONTINUE
ELSE
DO 70 I = 1, KDIV2
ALPHA(IPOS+I) = -ALPHA(IPOS+1-I)
70 CONTINUE
ENDIF
C
C determine the weights for the nodes
C
IF (FLAG) THEN
DO 80 I = 1, IDGR
XNULL = ALPHA(I)
CALL GXPOLY (XNULL, F, IDGR-1, POLD)
XW = XKPLUS*XKPLUS * F*F
ZWGH(I) = 2.0D0 * ( 1.0D0 - XNULL*XNULL ) / XW
80 CONTINUE
ENDIF
R E T U R N
END
C
C
SUBROUTINE GXPOLY (X, F, N, C)
C
C*****************************************************************
C *
C This subroutine evaluates a polynomial of degree N at X *
C using the HORNER scheme. The value appears in F. *
C *
C----------------------------------------------------------------*
C *
C subroutines required : none *
C *
C*****************************************************************
C *
C author : Hermann-Josef Rheinbach *
C editor : Norbert Vogt *
C date : 04.10.1989 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
IMPLICIT DOUBLE PRECISION (A-H, O-Z)
DIMENSION C(0:N)
C
NDGR = N-1
F = C(N)
DO 10 K = 0, NDGR
F = F * X + C(NDGR-K)
10 CONTINUE
R E T U R N
END
C
C
SUBROUTINE GXPEGA (A, B, C, N, XSI)
C
C*****************************************************************
C *
C This subroutine determines a zero of a polynomial of degree N,*
C whose coefficients are given in the vector C(N) which lies *
C between A and B. *
C The method used is a modified version of the PEGASUS method. *
C *
C----------------------------------------------------------------*
C *
C subroutines required: GXPOLY, MACHPD *
C *
C*****************************************************************
C *
C author : Hermann-Josef Rheinbach *
C editor : Norbert Vogt *
C date : 04.10.1989 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
IMPLICIT DOUBLE PRECISION (A-H, O-Z)
DIMENSION C(0:N)
LOGICAL FDELTA
C
C determining the machine constant EPS, and using EPS * 100
C
SAVE DELTA, FDELTA
DATA FDELTA /.TRUE./
C
C FDELTA = TRUE
C
IF (FDELTA) THEN
DELTA = 1.0D0
C
C Repeat until machine constant found
C
5 DELTA = 0.5D0 * DELTA
IF (MACHPD(1.0D0+DELTA) .EQ. 1) GOTO 5
C
DELTA = 200.0D0 * DELTA
FDELTA = .FALSE.
ENDIF
C
C initialize
C
X1 = A
X2 = B
C
CALL GXPOLY (X1, F1, N, C)
CALL GXPOLY (X2, F2, N, C)
XDIFF = X2-X1
C
DO 10 I = 1, 50
S12 = XDIFF / (F2-F1)
X3 = X2 - F2 * S12
CALL GXPOLY (X3, F3, N, C)
IF ((F2*F3) .LT. 0.0D0) THEN
X1 = X2
F1 = F2
ELSE
F1 = F1 * F2 / (F2 + F3)
ENDIF
X2 = X3
F2 = F3
IF (DABS(F2) .LT. DELTA) THEN
XSI = X2
IF (DABS(F1) .LT. DABS(F2)) XSI = X1
R E T U R N
ENDIF
XDIFF = X2 - X1
IF (DABS(XDIFF) .LT. DELTA) THEN
XSI = X2
IF (DABS(F1) .LT. DABS(F2)) XSI = X1
R E T U R N
ENDIF
10 CONTINUE
R E T U R N
END
Begin of file
Contents
Index