share/fftpack5/fortran/r1f4kf.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 R1F4KF (IDO,L1,CC,IN1,CH,IN2,WA1,WA2,WA3)
  12       REAL       CC(IN1,IDO,L1,4)   ,CH(IN2,IDO,4,L1)     ,
  13      1           WA1(IDO)           ,WA2(IDO)     ,WA3(IDO)
  14 C
  15       HSQT2=SQRT(2.)/2.
  16       DO 101 K=1,L1
  17          CH(1,1,1,K) = (CC(1,1,K,2)+CC(1,1,K,4))
  18      1      +(CC(1,1,K,1)+CC(1,1,K,3))
  19          CH(1,IDO,4,K) = (CC(1,1,K,1)+CC(1,1,K,3))
  20      1      -(CC(1,1,K,2)+CC(1,1,K,4))
  21          CH(1,IDO,2,K) = CC(1,1,K,1)-CC(1,1,K,3)
  22          CH(1,1,3,K) = CC(1,1,K,4)-CC(1,1,K,2)
  23   101 CONTINUE
  24       IF (IDO-2) 107,105,102
  25   102 IDP2 = IDO+2
  26       DO 104 K=1,L1
  27          DO 103 I=3,IDO,2
  28             IC = IDP2-I
  29             CH(1,I-1,1,K) = ((WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*
  30      1       CC(1,I,K,2))+(WA3(I-2)*CC(1,I-1,K,4)+WA3(I-1)*
  31      1       CC(1,I,K,4)))+(CC(1,I-1,K,1)+(WA2(I-2)*CC(1,I-1,K,3)+
  32      1       WA2(I-1)*CC(1,I,K,3)))
  33             CH(1,IC-1,4,K) = (CC(1,I-1,K,1)+(WA2(I-2)*CC(1,I-1,K,3)+
  34      1       WA2(I-1)*CC(1,I,K,3)))-((WA1(I-2)*CC(1,I-1,K,2)+
  35      1       WA1(I-1)*CC(1,I,K,2))+(WA3(I-2)*CC(1,I-1,K,4)+
  36      1       WA3(I-1)*CC(1,I,K,4)))
  37             CH(1,I,1,K) = ((WA1(I-2)*CC(1,I,K,2)-WA1(I-1)*
  38      1       CC(1,I-1,K,2))+(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*
  39      1       CC(1,I-1,K,4)))+(CC(1,I,K,1)+(WA2(I-2)*CC(1,I,K,3)-
  40      1       WA2(I-1)*CC(1,I-1,K,3)))
  41             CH(1,IC,4,K) = ((WA1(I-2)*CC(1,I,K,2)-WA1(I-1)*
  42      1       CC(1,I-1,K,2))+(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*
  43      1       CC(1,I-1,K,4)))-(CC(1,I,K,1)+(WA2(I-2)*CC(1,I,K,3)-
  44      1       WA2(I-1)*CC(1,I-1,K,3)))
  45             CH(1,I-1,3,K) = ((WA1(I-2)*CC(1,I,K,2)-WA1(I-1)*
  46      1       CC(1,I-1,K,2))-(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*
  47      1       CC(1,I-1,K,4)))+(CC(1,I-1,K,1)-(WA2(I-2)*CC(1,I-1,K,3)+
  48      1       WA2(I-1)*CC(1,I,K,3)))
  49             CH(1,IC-1,2,K) = (CC(1,I-1,K,1)-(WA2(I-2)*CC(1,I-1,K,3)+
  50      1       WA2(I-1)*CC(1,I,K,3)))-((WA1(I-2)*CC(1,I,K,2)-WA1(I-1)*
  51      1       CC(1,I-1,K,2))-(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*
  52      1       CC(1,I-1,K,4)))
  53             CH(1,I,3,K) = ((WA3(I-2)*CC(1,I-1,K,4)+WA3(I-1)*
  54      1       CC(1,I,K,4))-(WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*
  55      1       CC(1,I,K,2)))+(CC(1,I,K,1)-(WA2(I-2)*CC(1,I,K,3)-
  56      1       WA2(I-1)*CC(1,I-1,K,3)))
  57             CH(1,IC,2,K) = ((WA3(I-2)*CC(1,I-1,K,4)+WA3(I-1)*
  58      1       CC(1,I,K,4))-(WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*
  59      1       CC(1,I,K,2)))-(CC(1,I,K,1)-(WA2(I-2)*CC(1,I,K,3)-
  60      1       WA2(I-1)*CC(1,I-1,K,3)))
  61   103    CONTINUE
  62   104 CONTINUE
  63       IF (MOD(IDO,2) .EQ. 1) RETURN
  64   105 CONTINUE
  65       DO 106 K=1,L1
  66             CH(1,IDO,1,K) = (HSQT2*(CC(1,IDO,K,2)-CC(1,IDO,K,4)))+
  67      1       CC(1,IDO,K,1)
  68             CH(1,IDO,3,K) = CC(1,IDO,K,1)-(HSQT2*(CC(1,IDO,K,2)-
  69      1       CC(1,IDO,K,4)))
  70             CH(1,1,2,K) = (-HSQT2*(CC(1,IDO,K,2)+CC(1,IDO,K,4)))-
  71      1       CC(1,IDO,K,3)
  72             CH(1,1,4,K) = (-HSQT2*(CC(1,IDO,K,2)+CC(1,IDO,K,4)))+
  73      1       CC(1,IDO,K,3)
  74   106 CONTINUE
  75   107 RETURN
  76       END