wrfv2_fire/external/fftpack/fftpack5/sintf1.F

   1 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
   2 !
   3 !   FFTPACK 5.0
   4 !   Copyright (C) 1995-2004, Scientific Computing Division,
   5 !   University Corporation for Atmospheric Research
   6 !   Licensed under the GNU General Public License (GPL)
   7 !
   8 !   Authors:  Paul N. Swarztrauber and Richard A. Valent
   9 !
  10 !   $Id: sintf1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $
  11 !
  12 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  13
  14       SUBROUTINE SINTF1(N,INC,X,WSAVE,XH,WORK,IER)
  15       REAL       X(INC,*)       ,WSAVE(*)   ,XH(*)
  16       DOUBLE PRECISION           DSUM
  17       IER = 0
  18       IF (N-2) 200,102,103
  19   102 SSQRT3 = 1./SQRT(3.)
  20       XHOLD = SSQRT3*(X(1,1)+X(1,2))
  21       X(1,2) = SSQRT3*(X(1,1)-X(1,2))
  22       X(1,1) = XHOLD
  23       GO TO 200
  24   103 NP1 = N+1
  25       NS2 = N/2
  26       DO 104 K=1,NS2
  27          KC = NP1-K
  28          T1 = X(1,K)-X(1,KC)
  29          T2 = WSAVE(K)*(X(1,K)+X(1,KC))
  30          XH(K+1) = T1+T2
  31          XH(KC+1) = T2-T1
  32   104 END DO
  33       MODN = MOD(N,2)
  34       IF (MODN .EQ. 0) GO TO 124
  35       XH(NS2+2) = 4.*X(1,NS2+1)
  36   124 XH(1) = 0.
  37       LNXH = NP1
  38       LNSV = NP1 + INT(LOG(REAL(NP1))) + 4
  39       LNWK = NP1
  40 !
  41       CALL RFFT1F(NP1,1,XH,LNXH,WSAVE(NS2+1),LNSV,WORK,                 &
  42      &            LNWK,IER1)
  43       IF (IER1 .NE. 0) THEN
  44         IER = 20
  45         CALL XERFFT ('SINTF1',-5)
  46         GO TO 200
  47       ENDIF
  48 !
  49       IF(MOD(NP1,2) .NE. 0) GO TO 30
  50       XH(NP1) = XH(NP1)+XH(NP1)
  51    30 SFNP1 = 1./FLOAT(NP1)
  52          X(1,1) = .5*XH(1)
  53          DSUM = X(1,1)
  54       DO 105 I=3,N,2
  55             X(1,I-1) = .5*XH(I)
  56             DSUM = DSUM+.5*XH(I-1)
  57             X(1,I) = DSUM
  58   105 END DO
  59       IF (MODN .NE. 0) GO TO 200
  60       X(1,N) = .5*XH(N+1)
  61   200 RETURN
  62       END