wrfv2_fire/external/fftpack/fftpack5/msntb1.F

   1 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
   2 !
   3 !   FFTPACK 5.0
   4 !
   5 !   Authors:  Paul N. Swarztrauber and Richard A. Valent
   6 !
   7 !   $Id: msntb1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $
   8 !
   9 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  10
  11       SUBROUTINE MSNTB1(LOT,JUMP,N,INC,X,WSAVE,DSUM,XH,WORK,IER)
  12       REAL       X(INC,*)       ,WSAVE(*)   ,XH(LOT,*)
  13       DOUBLE PRECISION           DSUM(*)
  14       IER = 0
  15       LJ = (LOT-1)*JUMP+1
  16       IF (N-2) 200,102,103
  17   102 SRT3S2 = SQRT(3.)/2.
  18       DO 112 M=1,LJ,JUMP
  19          XHOLD = SRT3S2*(X(M,1)+X(M,2))
  20          X(M,2) = SRT3S2*(X(M,1)-X(M,2))
  21          X(M,1) = XHOLD
  22   112 END DO
  23       GO TO 200
  24   103 NP1 = N+1
  25       NS2 = N/2
  26       DO 104 K=1,NS2
  27          KC = NP1-K
  28          M1 = 0
  29          DO 114 M=1,LJ,JUMP
  30          M1 = M1+1
  31          T1 = X(M,K)-X(M,KC)
  32          T2 = WSAVE(K)*(X(M,K)+X(M,KC))
  33          XH(M1,K+1) = T1+T2
  34          XH(M1,KC+1) = T2-T1
  35   114    CONTINUE
  36   104 END DO
  37       MODN = MOD(N,2)
  38       IF (MODN .EQ. 0) GO TO 124
  39       M1 = 0
  40       DO 123 M=1,LJ,JUMP
  41          M1 = M1+1
  42          XH(M1,NS2+2) = 4.*X(M,NS2+1)
  43   123 END DO
  44   124 DO 127 M=1,LOT
  45          XH(M,1) = 0.
  46   127 END DO
  47       LNXH = LOT-1 + LOT*(NP1-1) + 1
  48       LNSV = NP1 + INT(LOG(REAL(NP1))) + 4
  49       LNWK = LOT*NP1
  50 !
  51       CALL RFFTMF(LOT,1,NP1,LOT,XH,LNXH,WSAVE(NS2+1),LNSV,WORK,         &
  52      &            LNWK,IER1)
  53       IF (IER1 .NE. 0) THEN
  54         IER = 20
  55         CALL XERFFT ('MSNTB1',-5)
  56         GO TO 200
  57       ENDIF
  58 !
  59       IF(MOD(NP1,2) .NE. 0) GO TO 30
  60       DO 20 M=1,LOT
  61       XH(M,NP1) = XH(M,NP1)+XH(M,NP1)
  62    20 END DO
  63    30 FNP1S4 = FLOAT(NP1)/4.
  64       M1 = 0
  65       DO 125 M=1,LJ,JUMP
  66          M1 = M1+1
  67          X(M,1) = FNP1S4*XH(M1,1)
  68          DSUM(M1) = X(M,1)
  69   125 END DO
  70       DO 105 I=3,N,2
  71          M1 = 0
  72          DO 115 M=1,LJ,JUMP
  73             M1 = M1+1
  74             X(M,I-1) = FNP1S4*XH(M1,I)
  75             DSUM(M1) = DSUM(M1)+FNP1S4*XH(M1,I-1)
  76             X(M,I) = DSUM(M1)
  77   115    CONTINUE
  78   105 END DO
  79       IF (MODN .NE. 0) GO TO 200
  80       M1 = 0
  81       DO 116 M=1,LJ,JUMP
  82          M1 = M1+1
  83          X(M,N) = FNP1S4*XH(M1,N+1)
  84   116 END DO
  85 !
  86   200 CONTINUE
  87       RETURN
  88       END