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

   1 *DECK RADFG
   2       SUBROUTINE RADFG (IDO, IP, L1, IDL1, CC, C1, C2, CH, CH2, WA)
   3 C***BEGIN PROLOGUE  RADFG
   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 (RADFG-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  RADFG
  27       DIMENSION CH(IDO,L1,*), CC(IDO,IP,*), C1(IDO,L1,*),
  28      +          C2(IDL1,*), CH2(IDL1,*), WA(*)
  29 C***FIRST EXECUTABLE STATEMENT  RADFG
  30       TPI = 8.*ATAN(1.)
  31       ARG = TPI/IP
  32       DCP = COS(ARG)
  33       DSP = SIN(ARG)
  34       IPPH = (IP+1)/2
  35       IPP2 = IP+2
  36       IDP2 = IDO+2
  37       NBD = (IDO-1)/2
  38       IF (IDO .EQ. 1) GO TO 119
  39       DO 101 IK=1,IDL1
  40          CH2(IK,1) = C2(IK,1)
  41   101 CONTINUE
  42       DO 103 J=2,IP
  43          DO 102 K=1,L1
  44             CH(1,K,J) = C1(1,K,J)
  45   102    CONTINUE
  46   103 CONTINUE
  47       IF (NBD .GT. L1) GO TO 107
  48       IS = -IDO
  49       DO 106 J=2,IP
  50          IS = IS+IDO
  51          IDIJ = IS
  52          DO 105 I=3,IDO,2
  53             IDIJ = IDIJ+2
  54             DO 104 K=1,L1
  55                CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)
  56                CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)
  57   104       CONTINUE
  58   105    CONTINUE
  59   106 CONTINUE
  60       GO TO 111
  61   107 IS = -IDO
  62       DO 110 J=2,IP
  63          IS = IS+IDO
  64          DO 109 K=1,L1
  65             IDIJ = IS
  66 CDIR$ IVDEP
  67             DO 108 I=3,IDO,2
  68                IDIJ = IDIJ+2
  69                CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)
  70                CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)
  71   108       CONTINUE
  72   109    CONTINUE
  73   110 CONTINUE
  74   111 IF (NBD .LT. L1) GO TO 115
  75       DO 114 J=2,IPPH
  76          JC = IPP2-J
  77          DO 113 K=1,L1
  78 CDIR$ IVDEP
  79             DO 112 I=3,IDO,2
  80                C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)
  81                C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)
  82                C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)
  83                C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)
  84   112       CONTINUE
  85   113    CONTINUE
  86   114 CONTINUE
  87       GO TO 121
  88   115 DO 118 J=2,IPPH
  89          JC = IPP2-J
  90          DO 117 I=3,IDO,2
  91             DO 116 K=1,L1
  92                C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)
  93                C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)
  94                C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)
  95                C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)
  96   116       CONTINUE
  97   117    CONTINUE
  98   118 CONTINUE
  99       GO TO 121
 100   119 DO 120 IK=1,IDL1
 101          C2(IK,1) = CH2(IK,1)
 102   120 CONTINUE
 103   121 DO 123 J=2,IPPH
 104          JC = IPP2-J
 105          DO 122 K=1,L1
 106             C1(1,K,J) = CH(1,K,J)+CH(1,K,JC)
 107             C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J)
 108   122    CONTINUE
 109   123 CONTINUE
 110 C
 111       AR1 = 1.
 112       AI1 = 0.
 113       DO 127 L=2,IPPH
 114          LC = IPP2-L
 115          AR1H = DCP*AR1-DSP*AI1
 116          AI1 = DCP*AI1+DSP*AR1
 117          AR1 = AR1H
 118          DO 124 IK=1,IDL1
 119             CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2)
 120             CH2(IK,LC) = AI1*C2(IK,IP)
 121   124    CONTINUE
 122          DC2 = AR1
 123          DS2 = AI1
 124          AR2 = AR1
 125          AI2 = AI1
 126          DO 126 J=3,IPPH
 127             JC = IPP2-J
 128             AR2H = DC2*AR2-DS2*AI2
 129             AI2 = DC2*AI2+DS2*AR2
 130             AR2 = AR2H
 131             DO 125 IK=1,IDL1
 132                CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J)
 133                CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC)
 134   125       CONTINUE
 135   126    CONTINUE
 136   127 CONTINUE
 137       DO 129 J=2,IPPH
 138          DO 128 IK=1,IDL1
 139             CH2(IK,1) = CH2(IK,1)+C2(IK,J)
 140   128    CONTINUE
 141   129 CONTINUE
 142 C
 143       IF (IDO .LT. L1) GO TO 132
 144       DO 131 K=1,L1
 145          DO 130 I=1,IDO
 146             CC(I,1,K) = CH(I,K,1)
 147   130    CONTINUE
 148   131 CONTINUE
 149       GO TO 135
 150   132 DO 134 I=1,IDO
 151          DO 133 K=1,L1
 152             CC(I,1,K) = CH(I,K,1)
 153   133    CONTINUE
 154   134 CONTINUE
 155   135 DO 137 J=2,IPPH
 156          JC = IPP2-J
 157          J2 = J+J
 158          DO 136 K=1,L1
 159             CC(IDO,J2-2,K) = CH(1,K,J)
 160             CC(1,J2-1,K) = CH(1,K,JC)
 161   136    CONTINUE
 162   137 CONTINUE
 163       IF (IDO .EQ. 1) RETURN
 164       IF (NBD .LT. L1) GO TO 141
 165       DO 140 J=2,IPPH
 166          JC = IPP2-J
 167          J2 = J+J
 168          DO 139 K=1,L1
 169 CDIR$ IVDEP
 170             DO 138 I=3,IDO,2
 171                IC = IDP2-I
 172                CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)
 173                CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)
 174                CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)
 175                CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)
 176   138       CONTINUE
 177   139    CONTINUE
 178   140 CONTINUE
 179       RETURN
 180   141 DO 144 J=2,IPPH
 181          JC = IPP2-J
 182          J2 = J+J
 183          DO 143 I=3,IDO,2
 184             IC = IDP2-I
 185             DO 142 K=1,L1
 186                CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)
 187                CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)
 188                CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)
 189                CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)
 190   142       CONTINUE
 191   143    CONTINUE
 192   144 CONTINUE
 193       RETURN
 194       END