share/fftpack5/fortran/rfftb1.f

   1 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
   2 C
   3 C   FFTPACK 5.0
   4 C
   5 C   Authors:  Paul N. Swarztrauber and Richard A. Valent
   6 C
   7 C   $Id$
   8 C
   9 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  10
  11       SUBROUTINE RFFTB1 (N,IN,C,CH,WA,FAC)
  12       REAL       CH(*), C(IN,*), WA(N) ,FAC(15)
  13 C
  14       NF = FAC(2)
  15       NA = 0
  16       DO 10 K1=1,NF
  17       IP = FAC(K1+2)
  18       NA = 1-NA
  19       IF(IP .LE. 5) GO TO 10
  20       IF(K1 .EQ. NF) GO TO 10
  21       NA = 1-NA
  22    10 CONTINUE
  23       HALF = .5
  24       HALFM = -.5
  25       MODN = MOD(N,2)
  26       NL = N-2
  27       IF(MODN .NE. 0) NL = N-1
  28       IF (NA .EQ. 0) GO TO 120
  29       CH(1) = C(1,1)
  30       CH(N) = C(1,N)
  31       DO 118 J=2,NL,2
  32          CH(J) = HALF*C(1,J)
  33          CH(J+1) = HALFM*C(1,J+1)
  34   118 CONTINUE
  35       GO TO 124
  36   120 DO 122 J=2,NL,2
  37          C(1,J) = HALF*C(1,J)
  38          C(1,J+1) = HALFM*C(1,J+1)
  39   122 CONTINUE
  40   124 L1 = 1
  41       IW = 1
  42       DO 116 K1=1,NF
  43          IP = FAC(K1+2)
  44          L2 = IP*L1
  45          IDO = N/L2
  46          IDL1 = IDO*L1
  47          IF (IP .NE. 4) GO TO 103
  48          IX2 = IW+IDO
  49          IX3 = IX2+IDO
  50          IF (NA .NE. 0) GO TO 101
  51          CALL R1F4KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2),WA(IX3))
  52          GO TO 102
  53   101    CALL R1F4KB (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2),WA(IX3))
  54   102    NA = 1-NA
  55          GO TO 115
  56   103    IF (IP .NE. 2) GO TO 106
  57          IF (NA .NE. 0) GO TO 104
  58          CALL R1F2KB (IDO,L1,C,IN,CH,1,WA(IW))
  59          GO TO 105
  60   104    CALL R1F2KB (IDO,L1,CH,1,C,IN,WA(IW))
  61   105    NA = 1-NA
  62          GO TO 115
  63   106    IF (IP .NE. 3) GO TO 109
  64          IX2 = IW+IDO
  65          IF (NA .NE. 0) GO TO 107
  66 C rav    CALL RIF3KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2))
  67          CALL R1F3KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2))
  68          GO TO 108
  69   107    CALL R1F3KB (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2))
  70   108    NA = 1-NA
  71          GO TO 115
  72   109    IF (IP .NE. 5) GO TO 112
  73          IX2 = IW+IDO
  74          IX3 = IX2+IDO
  75          IX4 = IX3+IDO
  76          IF (NA .NE. 0) GO TO 110
  77          CALL R1F5KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2),
  78      1                  WA(IX3),WA(IX4))
  79          GO TO 111
  80   110    CALL R1F5KB (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2),
  81      1                  WA(IX3),WA(IX4))
  82   111    NA = 1-NA
  83          GO TO 115
  84   112    IF (NA .NE. 0) GO TO 113
  85 C rav    CALL RIFGKB (IDO,IP,L1,IDL1,C,C,C,IN,CH,CH,1,WA(IW))
  86          CALL R1FGKB (IDO,IP,L1,IDL1,C,C,C,IN,CH,CH,1,WA(IW))
  87          GO TO 114
  88 C rav 113    CALL RIFGKB (IDO,IP,L1,IDL1,CH,CH,CH,1,C,C,IN,WA(IW))
  89   113    CALL R1FGKB (IDO,IP,L1,IDL1,CH,CH,CH,1,C,C,IN,WA(IW))
  90   114    IF (IDO .EQ. 1) NA = 1-NA
  91   115    L1 = L2
  92          IW = IW+(IP-1)*IDO
  93   116 CONTINUE
  94       RETURN
  95       END