wrfv2_fire/external/fftpack/fftpack5/rfft2f.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: rfft2f.f,v 1.5 2004/07/06 00:58:41 rodney Exp $
  11 !
  12 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  13
  14       SUBROUTINE RFFT2F (LDIM, L, M, R, WSAVE, LENSAV, WORK,            &
  15      &  LENWRK, IER)
  16       INTEGER LDIM, L, M, LENSAV, LENWRK, IER
  17       REAL    R(LDIM,M), WSAVE(LENSAV), WORK(LENWRK)
  18 !
  19 !
  20 ! Initialize IER
  21 !
  22       IER = 0
  23 !
  24 ! Verify LENSAV
  25 !
  26       LWSAV =   L + INT(LOG (REAL(L))) +4
  27       MWSAV =   2*M + INT(LOG (REAL(M))) +4
  28       IF (LENSAV .LT. LWSAV+MWSAV) THEN
  29         IER = 2
  30         CALL XERFFT ('RFFT2F', 6)
  31         GO TO 100
  32       ENDIF
  33 !
  34 ! Verify LENWRK
  35 !
  36       IF (LENWRK .LT. 2*(L/2+1)*M) THEN
  37         IER = 3
  38         CALL XERFFT ('RFFT2F', 8)
  39         GO TO 100
  40       ENDIF
  41 !
  42 ! Verify LDIM is as big as L
  43 !
  44       IF (LDIM .LT. 2*(L/2+1)) THEN
  45         IER = 5
  46         CALL XERFFT ('RFFT2F', -6)
  47         GO TO 100
  48       ENDIF
  49 !
  50 ! Transform first dimension of array
  51 !
  52       CALL RFFTMF(M,LDIM,L,1,R,M*LDIM,WSAVE(1),                         &
  53      &     L+INT(LOG(REAL(L)))+4,WORK,2*(L/2+1)*M,IER1)
  54       IF(IER1.NE.0) THEN
  55          IER=20
  56          CALL XERFFT('RFFT2F',-5)
  57          GO TO 100
  58       ENDIF
  59 !
  60 ! reshuffle to add in nyquist imaginary components
  61 !
  62       DO J=1,M
  63          IF(MOD(L,2).EQ.0) R(L+2,J)=0.0
  64          DO I=L,2,-1
  65             R(I+1,J)=R(I,J)
  66          ENDDO
  67          R(2,J)=0.0
  68       ENDDO
  69 !
  70 ! transform second dimension of array
  71 !
  72       CALL CFFTMF(L/2+1,1,M,LDIM/2,R,M*LDIM/2,                          &
  73      &     WSAVE(L+INT(LOG(REAL(L)))+5),                                &
  74      &     2*M+INT(LOG(REAL(M)))+4,WORK,2*(L/2+1)*M,IER1)
  75       IF(IER1.NE.0) THEN
  76          IER=20
  77          CALL XERFFT('RFFT2F',-5)
  78          GO TO 100
  79       ENDIF
  80 !
  81   100 CONTINUE
  82 !
  83       RETURN
  84       END