share/fftpack5/fortran/rfft2b.f

   1 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
   2 C
   3 C   FFTPACK 5.0
   4 C
   5 C   Authors:  Paul N. Swarztrauber and Richard A. Valent
   6 C
   7 C   $Id$
   8 C
   9 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  10
  11       SUBROUTINE RFFT2B (LDIM, L, M, R, WSAVE, LENSAV, WORK,
  12      1  LENWRK, IER)
  13       INTEGER LDIM, L, M, LENSAV, LENWRK, IER
  14       REAL    R(LDIM,M), WSAVE(LENSAV), WORK(LENWRK)
  15 C
  16 C
  17 C Initialize IER
  18 C
  19       IER = 0
  20 C
  21 C Verify LENSAV
  22 C
  23       LWSAV =   L + INT(LOG (REAL(L))) +4
  24       MWSAV =   2*M + INT(LOG (REAL(M))) +4
  25       IF (LENSAV .LT. LWSAV+MWSAV) THEN
  26         IER = 2
  27         CALL XERFFT ('RFFT2B', 6)
  28         GO TO 100
  29       ENDIF
  30 C
  31 C Verify LENWRK
  32 C
  33       IF (LENWRK .LT. 2*(L/2+1)*M) THEN
  34         IER = 3
  35         CALL XERFFT ('RFFT2B', 8)
  36         GO TO 100
  37       ENDIF
  38 C
  39 C Verify LDIM is as big as L
  40 C
  41       IF (LDIM .LT. 2*(L/2+1)) THEN
  42         IER = 5
  43         CALL XERFFT ('RFFT2B', -6)
  44         GO TO 100
  45       ENDIF
  46 C
  47 C transform second dimension of array
  48 C
  49       CALL CFFTMB(L/2+1,1,M,LDIM/2,R,M*LDIM/2,
  50      .     WSAVE(L+INT(LOG(REAL(L)))+5),
  51      .     2*M+INT(LOG(REAL(M)))+4,WORK,2*(L/2+1)*M,IER1)
  52       IF(IER1.NE.0) THEN
  53          IER=20
  54          CALL XERFFT('RFFT2B',-5)
  55          GO TO 100
  56       ENDIF
  57 C
  58 C reshuffle
  59 C
  60       DO J=1,M
  61          DO I=2,L
  62             R(I,J)=R(I+1,J)
  63          ENDDO
  64       ENDDO
  65 C
  66 C Transform first dimension of array
  67 C
  68       CALL RFFTMB(M,LDIM,L,1,R,M*LDIM,WSAVE(1),
  69      .     L+INT(LOG(REAL(L)))+4,WORK,2*(L/2+1)*M,IER1)
  70       IF(IER1.NE.0) THEN
  71          IER=20
  72          CALL XERFFT('RFFT2F',-5)
  73          GO TO 100
  74       ENDIF
  75 C
  76   100 CONTINUE
  77 C
  78       RETURN
  79       END
  80
  81