| [2759] | 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: rfft2b.f,v 1.5 2004/07/06 00:58:41 rodney Exp $ |
|---|
| 11 | ! |
|---|
| 12 | !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC |
|---|
| 13 | |
|---|
| 14 | SUBROUTINE RFFT2B (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 ('RFFT2B', 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 ('RFFT2B', 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 ('RFFT2B', -6) |
|---|
| 47 | GO TO 100 |
|---|
| 48 | ENDIF |
|---|
| 49 | ! |
|---|
| 50 | ! transform second dimension of array |
|---|
| 51 | ! |
|---|
| 52 | CALL CFFTMB(L/2+1,1,M,LDIM/2,R,M*LDIM/2, & |
|---|
| 53 | & WSAVE(L+INT(LOG(REAL(L)))+5), & |
|---|
| 54 | & 2*M+INT(LOG(REAL(M)))+4,WORK,2*(L/2+1)*M,IER1) |
|---|
| 55 | IF(IER1.NE.0) THEN |
|---|
| 56 | IER=20 |
|---|
| 57 | CALL XERFFT('RFFT2B',-5) |
|---|
| 58 | GO TO 100 |
|---|
| 59 | ENDIF |
|---|
| 60 | ! |
|---|
| 61 | ! reshuffle |
|---|
| 62 | ! |
|---|
| 63 | DO J=1,M |
|---|
| 64 | DO I=2,L |
|---|
| 65 | R(I,J)=R(I+1,J) |
|---|
| 66 | ENDDO |
|---|
| 67 | ENDDO |
|---|
| 68 | ! |
|---|
| 69 | ! Transform first dimension of array |
|---|
| 70 | ! |
|---|
| 71 | CALL RFFTMB(M,LDIM,L,1,R,M*LDIM,WSAVE(1), & |
|---|
| 72 | & L+INT(LOG(REAL(L)))+4,WORK,2*(L/2+1)*M,IER1) |
|---|
| 73 | IF(IER1.NE.0) THEN |
|---|
| 74 | IER=20 |
|---|
| 75 | CALL XERFFT('RFFT2F',-5) |
|---|
| 76 | GO TO 100 |
|---|
| 77 | ENDIF |
|---|
| 78 | ! |
|---|
| 79 | 100 CONTINUE |
|---|
| 80 | ! |
|---|
| 81 | RETURN |
|---|
| 82 | END |
|---|
