wrfv2_fire/external/fftpack/fftpack5/cfft2f.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: cfft2f.f,v 1.2 2004/06/15 21:08:32 rodney Exp $
  11 !
  12 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  13
  14       SUBROUTINE CFFT2F (LDIM, L, M, C, WSAVE, LENSAV,                  &
  15      &                     WORK, LENWRK, IER)
  16       INTEGER L, M, LDIM, LENSAV, LENWRK, IER
  17       COMPLEX C(LDIM,M)
  18       REAL WSAVE(LENSAV), WORK(LENWRK)
  19 !
  20 ! Initialize error return
  21 !
  22       IER = 0
  23 !
  24       IF (L .GT. LDIM) THEN
  25         IER = 5
  26         CALL XERFFT ('CFFT2F', -2)
  27         GO TO 100
  28       ELSEIF (LENSAV .LT. 2*L + INT(LOG(REAL(L))) +                     &
  29      &                    2*M + INT(LOG(REAL(M))) +8) THEN
  30         IER = 2
  31         CALL XERFFT ('CFFT2F', 6)
  32         GO TO 100
  33       ELSEIF (LENWRK .LT. 2*L*M) THEN
  34         IER = 3
  35         CALL XERFFT ('CFFT2F', 8)
  36         GO TO 100
  37       ENDIF
  38 !
  39 ! Transform X lines of C array
  40       IW = 2*L+INT(LOG(REAL(L))*LOG(2.)) + 3
  41       CALL CFFTMF(L, 1, M, LDIM, C, (L-1) + LDIM*(M-1) +1,              &
  42      &     WSAVE(IW), 2*M + INT(LOG(REAL(M))) + 4,                      &
  43      &     WORK, 2*L*M, IER1)
  44       IF (IER1 .NE. 0) THEN
  45         IER = 20
  46         CALL XERFFT ('CFFT2F',-5)
  47         GO TO 100
  48       ENDIF
  49 !
  50 ! Transform Y lines of C array
  51       IW = 1
  52       CALL CFFTMF (M, LDIM, L, 1, C, (M-1)*LDIM + L,                    &
  53      &     WSAVE(IW), 2*L + INT(LOG(REAL(L))) + 4,                      &
  54      &     WORK, 2*M*L, IER1)
  55       IF (IER1 .NE. 0) THEN
  56         IER = 20
  57         CALL XERFFT ('CFFT2F',-5)
  58       ENDIF
  59 !
  60   100 CONTINUE
  61       RETURN
  62       END