view libcruft/villad/jcobi.f @ 7948:af10baa63915 ss-3-1-50

3.1.50 snapshot
author John W. Eaton <jwe@octave.org>
date Fri, 18 Jul 2008 17:42:48 -0400
parents 30c606bec7a8
children
line wrap: on
line source

****************************************************************
*
*     The following routines (JCOBI, DIF, DFOPR, INTRP, AND RADAU)
*     are the same as found in Villadsen, J. and M.L. Michelsen,
*     Solution of Differential Equation Models by Polynomial
*     Approximation, Prentice-Hall (1978) pages 418-420.
*
*     Cosmetic changes (elimination of arithmetic IF statements, most
*     GO TO statements, and indentation of program blocks) made by:
*
*     John W. Eaton
*     Department of Chemical Engineering
*     The University of Texas at Austin
*     Austin, Texas 78712
*
*     June 6, 1987
*
*     Some error checking additions also made on June 7, 1987
*
*     Further cosmetic changes made August 20, 1987
*
************************************************************************
*
      SUBROUTINE JCOBI
     +  (
     +  ND, N, N0, N1, ALPHA, BETA, DIF1, DIF2, DIF3, ROOT
     +  )
C
      INTEGER
     +
     +  ND, N, N0, N1
C 
      DOUBLE PRECISION
     +
     +  ALPHA, BETA, DIF1(ND), DIF2(ND), DIF3(ND), ROOT(ND)
C
C***********************************************************************
C
C     VILLADSEN AND MICHELSEN, PAGES 131-132, 418
C
C     THIS SUBROUTINE COMPUTES THE ZEROS OF THE JACOBI POLYNOMIAL
C
C        (ALPHA,BETA)
C       P  (X)
C        N
C
C     USE DIF (GIVEN BELOW) TO COMPUTE THE DERIVATIVES OF THE NODE
C     POLYNOMIAL
C
C                     N0     (ALPHA,BETA)           N1
C       P  (X)  =  (X)   *  P (X)         *  (1 - X)
C        NT                   N
C
C     AT THE INTERPOLATION POINTS.
C
C     INPUT PARAMETERS:
C
C       ND     : THE DIMENSION OF THE VECTORS DIF1, DIF2, DIF3, AND ROOT
C
C       N      : THE DEGREE OF THE JACOBI POLYNOMIAL, (i.e. THE NUMBER
C                OF INTERIOR INTERPOLATION POINTS)
C
C       N0     : DETERMINES WHETHER X = 0 IS INCLUDED AS AN
C                INTERPOLATION POINT
C
C                  N0 = 0  ==>  X = 0 IS NOT INCLUDED
C                  N0 = 1  ==>  X = 0 IS INCLUDED
C
C       N1     : DETERMINES WHETHER X = 1 IS INCLUDED AS AN
C                INTERPOLATION POINT
C
C                  N1 = 0  ==>  X = 1 IS NOT INCLUDED
C                  N1 = 1  ==>  X = 1 IS INCLUDED
C
C       ALPHA  : THE VALUE OF ALPHA IN THE DESCRIPTION OF THE JACOBI
C                POLYNOMIAL
C
C       BETA   : THE VALUE OF BETA IN THE DESCRIPTION OF THE JACOBI
C                POLYNOMIAL
C
C       FOR A MORE COMPLETE EXPLANATION OF ALPHA AN BETA, SEE VILLADSEN
C       AND MICHELSEN, PAGES 57 TO 59
C
C     OUTPUT PARAMETERS:
C
C       ROOT   : ONE DIMENSIONAL VECTOR CONTAINING ON EXIT THE
C                N + N0 + N1 ZEROS OF THE NODE POLYNOMIAL USED IN THE
C                INTERPOLATION ROUTINE
C
C       DIF1   : ONE DIMENSIONAL VECTOR CONTAINING THE FIRST DERIVATIVE
C                OF THE NODE POLYNOMIAL AT THE ZEROS
C
C       DIF2   : ONE DIMENSIONAL VECTOR CONTAINING THE SECOND DERIVATIVE
C                OF THE NODE POLYNOMIAL AT THE ZEROS
C
C       DIF3   : ONE DIMENSIONAL VECTOR CONTAINING THE THIRD DERIVATIVE
C                OF THE NODE POLYNOMIAL AT THE ZEROS
C
C     COMMON BLOCKS:      NONE
C
C     REQUIRED ROUTINES:  VILERR, DIF
C
C***********************************************************************
C
      INTEGER           I,J,NT,IER
      DOUBLE PRECISION  AB,AD,AP,Z1,Z,Y,X,XD,XN,XD1,XN1,XP,XP1,ZC
      DOUBLE PRECISION  ZERO,ONE,TWO
      LOGICAL           LSTOP
C
      PARAMETER ( ZERO = 0.0D+00, ONE = 1.0D+00, TWO = 2.0D+00 )
C
C -- ERROR CHECKING
C
      IF ((N0 .NE. 0) .AND. (N0 .NE. 1)) THEN
        IER   = 1
        LSTOP = .TRUE.
        CALL VILERR(IER,LSTOP)
      ELSE
      END IF
C
      IF ((N1 .NE. 0) .AND. (N1 .NE. 1)) THEN
        IER   = 2
        LSTOP = .TRUE.
        CALL VILERR(IER,LSTOP)
      ELSE
      END IF
C
      IF (ND .LT. (N + N0 + N1)) THEN
        IER   = 3
        LSTOP = .TRUE.
        CALL VILERR(IER,LSTOP)
      ELSE
      END IF
C
      IF ((N + N0 + N1) .LT. 1) THEN
        IER   = 7
        LSTOP = .TRUE.
        CALL VILERR(IER,LSTOP)
      ELSE
      END IF
C
C -- FIRST EVALUATION OF COEFFICIENTS IN RECURSION FORMULAS.
C -- RECURSION COEFFICIENTS ARE STORED IN DIF1 AND DIF2.
C
      AB      = ALPHA + BETA
      AD      = BETA - ALPHA
      AP      = BETA*ALPHA
      DIF1(1) = (AD/(AB + TWO) + ONE)/TWO
      DIF2(1) = ZERO
C
      IF(N .GE. 2) THEN
        DO 10 I = 2,N
C
          Z1      = DBLE(I) - ONE
          Z       = AB + 2*Z1
          DIF1(I) = (AB*AD/Z/(Z + TWO) + ONE)/TWO
C
          IF (I .EQ. 2) THEN
            DIF2(I) = (AB + AP + Z1)/Z/Z/(Z + ONE)
          ELSE
            Z       = Z*Z
            Y       = Z1*(AB + Z1)
            Y       = Y*(AP + Y)
            DIF2(I) = Y/Z/(Z - ONE)
          END IF
C
   10   CONTINUE
      ELSE
      END IF
C
C -- ROOT DETERMINATION BY NEWTON METHOD WITH SUPPRESSION OF
C -- PREVIOUSLY DETERMINED ROOTS
C
      X = ZERO
C
      DO 20 I = 1,N
C
   25   CONTINUE
        XD  = ZERO
        XN  = ONE
        XD1 = ZERO
        XN1 = ZERO
C
        DO 30 J = 1,N
          XP  = (DIF1(J) - X)*XN  - DIF2(J)*XD
          XP1 = (DIF1(J) - X)*XN1 - DIF2(J)*XD1 - XN
          XD  = XN
          XD1 = XN1
          XN  = XP
          XN1 = XP1
   30   CONTINUE
C
        ZC  = ONE
        Z   = XN/XN1
C
        IF (I .NE. 1) THEN
          DO 22 J = 2,I
            ZC = ZC - Z/(X - ROOT(J-1))
   22     CONTINUE
        ELSE
        END IF
C
        Z  = Z/ZC
        X  = X - Z
C
        IF (DABS(Z) .GT. 1.D-09) THEN
C
C -- BACKWARD BRANCH
C
          GO TO 25
        ELSE
        END IF
C
        ROOT(I) = X
        X = X + 0.0001D0
C
   20 CONTINUE
C
C -- ADD INTERPOLATION POINTS AT X = 0 AND/OR X = 1
C
      NT = N + N0 + N1
C
      IF (N0 .NE. 0) THEN
        DO 31 I = 1,N
          J = N + 1 - I
          ROOT(J+1) = ROOT(J)
   31   CONTINUE
        ROOT(1) = ZERO
      ELSE
      END IF
C
      IF (N1 .EQ. 1) THEN
        ROOT(NT) = ONE
      ELSE
      END IF
C
      CALL DIF ( NT, ROOT, DIF1, DIF2, DIF3 )
C
      RETURN
      END