MINICERN/mathlib/gen/e/dchpws.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/04/01 15:02:29  mclareni
   6 * Mathlib gen
   7 *
   8 *
   9 #include "gen/pilot.h"
  10 #if defined(CERNLIB_DOUBLE)
  11       SUBROUTINE DCHPWS(N,C,A)
  12 #endif
  13 #if !defined(CERNLIB_DOUBLE)
  14       SUBROUTINE RCHPWS(N,C,A)
  15 #endif
  16 #include "gen/imp64.inc"
  17       CHARACTER NAMECP*(*),NAMEPC*(*)
  18       CHARACTER*80 ERRTXT
  19 #if defined(CERNLIB_DOUBLE)
  20       PARAMETER (NAMECP = 'DCHPWS', NAMEPC = 'DPWCHS')
  21 #endif
  22 #if !defined(CERNLIB_DOUBLE)
  23       PARAMETER (NAMECP = 'RCHPWS', NAMEPC = 'RPWCHS')
  24 #endif
  25
  26       DIMENSION C(0:*),A(0:*),QU(0:101),QV(0:101)
  27
  28       PARAMETER (R1 = 1, HF = R1/2)
  29
  30       IF(N .LT. 0 .OR. N .GT. 100) THEN
  31        WRITE(ERRTXT,101) N
  32        CALL MTLPRT(NAMECP,'E408.1',ERRTXT)
  33       ELSEIF(N .EQ. 0) THEN
  34        A(0)=C(0)
  35       ELSE
  36        QU(0)=C(N)
  37        QU(1)=0
  38        QV(0)=C(N-1)
  39        QV(1)=2*QU(0)
  40        DO 2 K = 2,N
  41        TT=C(N-K)-QU(0)
  42        QU(K)=0
  43        DO 1 J = 0,K-1
  44        T=2*QV(J)-QU(J+1)
  45        QU(J)=QV(J)
  46        QV(J)=TT
  47        TT=T
  48     1  CONTINUE
  49        QV(K)=TT
  50     2  CONTINUE
  51       ENDIF
  52       A(0)=QV(0)
  53       DO 3 J = 1,N
  54       A(J)=QV(J)-QU(J-1)
  55     3 CONTINUE
  56       RETURN
  57
  58 #if defined(CERNLIB_DOUBLE)
  59       ENTRY DPWCHS(N,A,C)
  60 #endif
  61 #if !defined(CERNLIB_DOUBLE)
  62       ENTRY RPWCHS(N,A,C)
  63 #endif
  64
  65       IF(N .LT. 0 .OR. N .GT. 100) THEN
  66        WRITE(ERRTXT,101) N
  67        CALL MTLPRT(NAMEPC,'E408.1',ERRTXT)
  68       ELSEIF(N .EQ. 0) THEN
  69        QU(0)=A(0)
  70       ELSE
  71        QU(0)=A(N-1)
  72        QU(1)=A(N)
  73        IF(N .GE. 2) QU(2)=0
  74        DO 4 K = 2,N
  75        TT=QU(0)+HF*QU(2)
  76        QU(0)=A(N-K)+HF*QU(1)
  77        DO 5 J = 2,K
  78        T=HF*QU(J-1)
  79        IF(J .LE. K-2) T=T+HF*QU(J+1)
  80        QU(J-1)=TT
  81        TT=T
  82     5  CONTINUE
  83        QU(K)=T
  84     4  CONTINUE
  85       ENDIF
  86       DO 6 J = 0,N
  87       C(J)=QU(J)
  88     6 CONTINUE
  89       RETURN
  90   101 FORMAT('NUMBER OF TERMS  N = ',I5,'  < 0  OR  > 100')
  91       END