website/archive/binaries/mac/src/disembl/Tisean_3.0.1/source_f/slatec/radbg.f

   1 *DECK RADBG
   2       SUBROUTINE RADBG (IDO, IP, L1, IDL1, CC, C1, C2, CH, CH2, WA)
   3 C***BEGIN PROLOGUE  RADBG
   4 C***SUBSIDIARY
   5 C***PURPOSE  Calculate the fast Fourier transform of subvectors of
   6 C            arbitrary length.
   7 C***LIBRARY   SLATEC (FFTPACK)
   8 C***TYPE      SINGLE PRECISION (RADBG-S)
   9 C***AUTHOR  Swarztrauber, P. N., (NCAR)
  10 C***ROUTINES CALLED  (NONE)
  11 C***REVISION HISTORY  (YYMMDD)
  12 C   790601  DATE WRITTEN
  13 C   830401  Modified to use SLATEC library source file format.
  14 C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
  15 C           (a) changing dummy array size declarations (1) to (*),
  16 C           (b) changing references to intrinsic function FLOAT
  17 C               to REAL, and
  18 C           (c) changing definition of variable TPI by using
  19 C               FORTRAN intrinsic function ATAN instead of a DATA
  20 C               statement.
  21 C   881128  Modified by Dick Valent to meet prologue standards.
  22 C   890531  Changed all specific intrinsics to generic.  (WRB)
  23 C   890831  Modified array declarations.  (WRB)
  24 C   891214  Prologue converted to Version 4.0 format.  (BAB)
  25 C   900402  Added TYPE section.  (WRB)
  26 C***END PROLOGUE  RADBG
  27       DIMENSION CH(IDO,L1,*), CC(IDO,IP,*), C1(IDO,L1,*),
  28      +          C2(IDL1,*), CH2(IDL1,*), WA(*)
  29 C***FIRST EXECUTABLE STATEMENT  RADBG
  30       TPI = 8.*ATAN(1.)
  31       ARG = TPI/IP
  32       DCP = COS(ARG)
  33       DSP = SIN(ARG)
  34       IDP2 = IDO+2
  35       NBD = (IDO-1)/2
  36       IPP2 = IP+2
  37       IPPH = (IP+1)/2
  38       IF (IDO .LT. L1) GO TO 103
  39       DO 102 K=1,L1
  40          DO 101 I=1,IDO
  41             CH(I,K,1) = CC(I,1,K)
  42   101    CONTINUE
  43   102 CONTINUE
  44       GO TO 106
  45   103 DO 105 I=1,IDO
  46          DO 104 K=1,L1
  47             CH(I,K,1) = CC(I,1,K)
  48   104    CONTINUE
  49   105 CONTINUE
  50   106 DO 108 J=2,IPPH
  51          JC = IPP2-J
  52          J2 = J+J
  53          DO 107 K=1,L1
  54             CH(1,K,J) = CC(IDO,J2-2,K)+CC(IDO,J2-2,K)
  55             CH(1,K,JC) = CC(1,J2-1,K)+CC(1,J2-1,K)
  56   107    CONTINUE
  57   108 CONTINUE
  58       IF (IDO .EQ. 1) GO TO 116
  59       IF (NBD .LT. L1) GO TO 112
  60       DO 111 J=2,IPPH
  61          JC = IPP2-J
  62          DO 110 K=1,L1
  63 CDIR$ IVDEP
  64             DO 109 I=3,IDO,2
  65                IC = IDP2-I
  66                CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K)
  67                CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K)
  68                CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K)
  69                CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K)
  70   109       CONTINUE
  71   110    CONTINUE
  72   111 CONTINUE
  73       GO TO 116
  74   112 DO 115 J=2,IPPH
  75          JC = IPP2-J
  76 CDIR$ IVDEP
  77          DO 114 I=3,IDO,2
  78             IC = IDP2-I
  79             DO 113 K=1,L1
  80                CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K)
  81                CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K)
  82                CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K)
  83                CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K)
  84   113       CONTINUE
  85   114    CONTINUE
  86   115 CONTINUE
  87   116 AR1 = 1.
  88       AI1 = 0.
  89       DO 120 L=2,IPPH
  90          LC = IPP2-L
  91          AR1H = DCP*AR1-DSP*AI1
  92          AI1 = DCP*AI1+DSP*AR1
  93          AR1 = AR1H
  94          DO 117 IK=1,IDL1
  95             C2(IK,L) = CH2(IK,1)+AR1*CH2(IK,2)
  96             C2(IK,LC) = AI1*CH2(IK,IP)
  97   117    CONTINUE
  98          DC2 = AR1
  99          DS2 = AI1
 100          AR2 = AR1
 101          AI2 = AI1
 102          DO 119 J=3,IPPH
 103             JC = IPP2-J
 104             AR2H = DC2*AR2-DS2*AI2
 105             AI2 = DC2*AI2+DS2*AR2
 106             AR2 = AR2H
 107             DO 118 IK=1,IDL1
 108                C2(IK,L) = C2(IK,L)+AR2*CH2(IK,J)
 109                C2(IK,LC) = C2(IK,LC)+AI2*CH2(IK,JC)
 110   118       CONTINUE
 111   119    CONTINUE
 112   120 CONTINUE
 113       DO 122 J=2,IPPH
 114          DO 121 IK=1,IDL1
 115             CH2(IK,1) = CH2(IK,1)+CH2(IK,J)
 116   121    CONTINUE
 117   122 CONTINUE
 118       DO 124 J=2,IPPH
 119          JC = IPP2-J
 120          DO 123 K=1,L1
 121             CH(1,K,J) = C1(1,K,J)-C1(1,K,JC)
 122             CH(1,K,JC) = C1(1,K,J)+C1(1,K,JC)
 123   123    CONTINUE
 124   124 CONTINUE
 125       IF (IDO .EQ. 1) GO TO 132
 126       IF (NBD .LT. L1) GO TO 128
 127       DO 127 J=2,IPPH
 128          JC = IPP2-J
 129          DO 126 K=1,L1
 130 CDIR$ IVDEP
 131             DO 125 I=3,IDO,2
 132                CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC)
 133                CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC)
 134                CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC)
 135                CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC)
 136   125       CONTINUE
 137   126    CONTINUE
 138   127 CONTINUE
 139       GO TO 132
 140   128 DO 131 J=2,IPPH
 141          JC = IPP2-J
 142          DO 130 I=3,IDO,2
 143             DO 129 K=1,L1
 144                CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC)
 145                CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC)
 146                CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC)
 147                CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC)
 148   129       CONTINUE
 149   130    CONTINUE
 150   131 CONTINUE
 151   132 CONTINUE
 152       IF (IDO .EQ. 1) RETURN
 153       DO 133 IK=1,IDL1
 154          C2(IK,1) = CH2(IK,1)
 155   133 CONTINUE
 156       DO 135 J=2,IP
 157          DO 134 K=1,L1
 158             C1(1,K,J) = CH(1,K,J)
 159   134    CONTINUE
 160   135 CONTINUE
 161       IF (NBD .GT. L1) GO TO 139
 162       IS = -IDO
 163       DO 138 J=2,IP
 164          IS = IS+IDO
 165          IDIJ = IS
 166          DO 137 I=3,IDO,2
 167             IDIJ = IDIJ+2
 168             DO 136 K=1,L1
 169                C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
 170                C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
 171   136       CONTINUE
 172   137    CONTINUE
 173   138 CONTINUE
 174       GO TO 143
 175   139 IS = -IDO
 176       DO 142 J=2,IP
 177          IS = IS+IDO
 178          DO 141 K=1,L1
 179             IDIJ = IS
 180 CDIR$ IVDEP
 181             DO 140 I=3,IDO,2
 182                IDIJ = IDIJ+2
 183                C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
 184                C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
 185   140       CONTINUE
 186   141    CONTINUE
 187   142 CONTINUE
 188   143 RETURN
 189       END