* PACKAGE UFFTR  
*
*"  [HIS] 90/08/31(numaguti)
*
**********************************************************************
      SUBROUTINE FFT99X      
     M         ( G     ,
     M           Z     ,
     C           WTBL  , IFAC  ,
     C           INC   , JUMP  , N     , LOT  , ISIGN  )
*
*   [MODIFY] 
      ReaL*8       G ( * )                     
      ReaL*8       Z ( * )                     
*
*   [INPUT] 
      ReaL*8       WTBL  ( * )                 
      INTEGER    IFAC  ( * )                 
      INTEGER    INC                         
      INTEGER    JUMP
      INTEGER    N
      INTEGER    LOT
      INTEGER    ISIGN                       
*
*   [INTERNAL WORK] 
      INTEGER    INCN, LB, LA
      INTEGER    I, K
*
*
      IF ( JUMP .GT. INC ) THEN
         INCN = ( LOT*JUMP ) / N
      ELSE
         INCN = INC
      ENDIF
      IF ( MOD( INCN,16 ) .EQ. 0 ) INCN = INCN-1
      INCN = MAX ( INCN, LOT )
*
      IF ( ISIGN .EQ. 0 ) THEN
*
*"         < 1. 格子 → スペクトル >
*
         IF ( N .EQ. 1 ) THEN
            DO 1000 K = 1, LOT
               Z ( K ) = G ( K )
 1000       CONTINUE
            RETURN
         ENDIF
*
         DO 1100 I = 1, N
            LA = (I-1)*INC  + 1
            LB = (I-1)*INCN + 1
            DO 1110 K = 1, LOT
               Z ( LB ) = G ( LA )
               LA = LA + JUMP
               LB = LB + 1
 1110       CONTINUE
 1100    CONTINUE
*
         CALL   RFOURT
     O         ( G     ,
     M           Z     ,
     F           1     ,
     F           WTBL  ,
     D           N     , LOT   , INCN )
*
*"                            ( K,2,0 ) <= 0.
         DO 1200 K = 1, LOT
            G ( K+INCN ) = 0.D0
 1200    CONTINUE
*
         DO 1300 I = 1, N
            LA = (I-1)*INC  + 1
            LB = (I-1)*INCN + 1
            DO 1310 K = 1, LOT
               Z ( LA ) = G ( LB )
               LA = LA + JUMP
               LB = LB + 1
 1310       CONTINUE
 1300    CONTINUE
*
      ELSE
*
*"         < 2. スペクトル → 格子 >
*
         IF ( N .EQ. 1 ) THEN
            DO 2000 K = 1, LOT
               G ( K ) = Z ( K )
 2000       CONTINUE
            RETURN
         ENDIF
*
         DO 2100 I = 1, N
            LA = (I-1)*INC  + 1
            LB = (I-1)*INCN + 1
            DO 2110 K = 1, LOT
               G ( LB ) = Z ( LA )
               LA = LA + JUMP
               LB = LB + 1
 2110       CONTINUE
 2100    CONTINUE
*
          CALL   RFOURT
     O         ( Z     ,
     M           G     ,
     F           -1    ,
     F           WTBL  ,
     D           N     , LOT   , INCN )
*
         DO 2300 I = 1, N
            LA = (I-1)*INC  + 1
            LB = (I-1)*INCN + 1
            DO 2310 K = 1, LOT
               G ( LA ) = Z ( LB )
               LA = LA + JUMP
               LB = LB + 1
 2310       CONTINUE
 2300    CONTINUE
*
      ENDIF
*
      RETURN
      END
************************************************************************
      SUBROUTINE RFFTIM     
     I         ( N     ,
     O           WTBL  , IFAC  )
*
*   [PARAM] 
      INTEGER    N
*
*   [OUTPUT] 
      ReaL*8       WTBL ( 2, N )               
      INTEGER    IFAC ( * )                  
*
*   [INTERNAL WORK] 
      ReaL*8       PI, THETA
      INTEGER    L, M, MM
*
      PI    = ATAN2 ( 0. , -1. )
*
      L  = 1
      MM = 0
 1100 CONTINUE
        IF ( L .LT. N ) THEN
          THETA =  2. * PI / DBLE( 2*L )
*
          DO 1110 M = 0, L-1
             MM = MM + 1
             WTBL ( 1, MM ) =   COS( THETA*M )
             WTBL ( 2, MM ) = - SIN( THETA*M )
 1110     CONTINUE
*
          L = L * 2
          GOTO 1100
*"    Repeat
        ENDIF
*
      RETURN
      END
***********************************************************************
      SUBROUTINE RFOURT    
     O         ( DATAO ,
     M           DATAI ,
     F           ISIGN ,
     F           WTBL  ,
     D           N     , KMAX  , KDIM )
*
*   [PARAM] 
      INTEGER    N
      INTEGER    KMAX
      INTEGER    KDIM
*
*   [INPUT] 
      ReaL*8       DATAO ( KDIM, 2, 0:N/2-1 )  
      ReaL*8       DATAI ( KDIM, 2, 0:N/2-1 )  
      INTEGER    ISIGN                       
      ReaL*8       WTBL  ( 2, N )              
*
*   [INTERNAL WORK] 
      INTEGER    I, J, K
      ReaL*8       C1, C2, WR, WI
      ReaL*8       H1R, H2R, H3R
      ReaL*8       H1I, H2I, H3I
*
*
      IF ( ISIGN .EQ.  1 ) THEN
        C1  =  1. / N
        C2  = -1. / N
        CALL CFOURT
     M         ( DATAI ,
     F           1     ,
     I           WTBL  ,
     D           N/2   , KMAX  , KDIM )
      ELSE
        C1  = 0.5  
        C2  = 0.5  
      ENDIF
*
      DO 2100 I = 1, N/4
        J  = N/2 - I
        WR = WTBL ( 1,I+N/2 )
        WI = WTBL ( 2,I+N/2 ) * ISIGN
*
        DO 2110 K = 1, KMAX
           H1R            =  C1*( DATAI( K,1,I ) + DATAI( K,1,J ) )
           H1I            =  C1*( DATAI( K,2,I ) - DATAI( K,2,J ) )
           H2R            = -C2*( DATAI( K,2,I ) + DATAI( K,2,J ) )
           H2I            =  C2*( DATAI( K,1,I ) - DATAI( K,1,J ) )
           H3R            =  WR*H2R - WI*H2I
           H3I            =  WR*H2I + WI*H2R
           DATAO( K,1,I ) =  H1R + H3R
           DATAO( K,2,I ) =  H1I + H3I
           DATAO( K,1,J ) =  H1R - H3R
           DATAO( K,2,J ) = -H1I + H3I
 2110   CONTINUE
 2100 CONTINUE
*
      IF ( ISIGN .EQ.  1 ) THEN
        DO 3100 K = 1, KMAX
           H1R            = DATAI( K,1,0 )
           DATAO( K,1,0 ) = C1*( H1R + DATAI( K,2,0 ) )
           DATAO( K,2,0 ) = C1*( H1R - DATAI( K,2,0 ) )
 3100   CONTINUE
      ELSE
        DO 3200 K = 1, KMAX
           H1R            = DATAI( K,1,0 )
           DATAO( K,1,0 ) = H1R + DATAI( K,2,0 )
           DATAO( K,2,0 ) = H1R - DATAI( K,2,0 )
 3200   CONTINUE
*
        CALL CFOURT
     M         ( DATAO ,
     F           -1    ,
     F           WTBL  ,
     D           N/2   , KMAX  , KDIM )
      ENDIF
*
      RETURN
      END
************************************************************************
      SUBROUTINE CFOURT   
     M         ( DATA  ,
     F           ISIGN ,
     I           WTBL  ,
     D           N     , KMAX  , KDIM )
*
*   [PARAM] 
      INTEGER    N
      INTEGER    KMAX
      INTEGER    KDIM
*
*   [MODIFY] 
      ReaL*8       DATA( KDIM, 2, 0:N-1 )      
*
*   [INPUT] 
      INTEGER    ISIGN                       
      ReaL*8       WTBL  ( 2, N )              
*
*   [INTERNAL WORK] 
      INTEGER    I, J, K, L, M, MM
      ReaL*8       TEMPR, TEMPI, WR, WI
*
*
      J = 0
      DO 1100 I = 0, N-1
*
        IF ( J .GT. I )THEN
          DO 1110 K = 1, KMAX
             TEMPR         = DATA( K,1,J )
             TEMPI         = DATA( K,2,J )
             DATA( K,1,J ) = DATA( K,1,I )
             DATA( K,2,J ) = DATA( K,2,I )
             DATA( K,1,I ) = TEMPR
             DATA( K,2,I ) = TEMPI
 1110     CONTINUE
        ENDIF
*
        M = N/2
 1120   CONTINUE
           IF ( ( M .GT. 1 ) .AND. ( J .GE. M ) ) THEN
              J = J - M
              M = M / 2
              GO TO 1120
*"      Repeat
           ENDIF
*
        J = J + M
*
 1100 CONTINUE
*
      L  = 1
      MM = 0
 2100 CONTINUE
        IF ( L .LT. N ) THEN
          DO 2110 M = 0, L-1
            MM = MM + 1
            WR = WTBL ( 1,MM )
            WI = WTBL ( 2,MM ) * ISIGN
*
            DO 2120 I = M, N-L-1, L*2
              J = I + L
              DO 2130 K = 1, KMAX
                TEMPR         = WR * DATA( K,1,J )
     &                        - WI * DATA( K,2,J )
                TEMPI         = WR * DATA( K,2,J )
     &                        + WI * DATA( K,1,J )
                DATA( K,1,J ) = DATA( K,1,I ) - TEMPR
                DATA( K,2,J ) = DATA( K,2,I ) - TEMPI
                DATA( K,1,I ) = DATA( K,1,I ) + TEMPR
                DATA( K,2,I ) = DATA( K,2,I ) + TEMPI
2130          CONTINUE
2120        CONTINUE
2110      CONTINUE
*
          L = L * 2
          GO TO 2100
*"    Loop
        ENDIF
*
      RETURN
      END
