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