CTITLEFFT991 -- ROUTINE TO PERFORM MULTIPLE, REAL FFT'S 00010001 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA AUTHOR JJ CHEN 00020001 CA DESIGNER JJ CHEN 00030001 CA LANGUAGE FORTRAN 00040001 CA SYSTEM IBM (SEE CRAY BENCHLIB) 00050001 CA WRITTEN 02/10/89 00060001 C REVISED MM/DD/YY III ... 00070001 C REVISED 09/24/89 JJC REINITIALIZE THE SCALE FACTOR. 00080001 C REVISED 12/07/89 LWC INCREASE ARRAY SIZE FROM 100 TO 160. 00090001 C REVISED 05/28/92 ESN MODIFY SCALE TO MATCH CRAY VALUES. 00100001 CA 00110001 CA THIS SUBROUTINE PERFORMS MULTIPLE REAL FFT'S USING THE 00120001 CA IBM ESSL SOFTWARE. 00130001 CA 00140001 CA CALL FTT991 (A, WORK. TRIGS, IFAX, INC, JUMP, N, M, ISIGN) 00150001 CA 00160001 CA IN/OUT A = ARRAY OF LENGTH M*(N+2) R4 00170001 CA INPUT WORK = WORK ARRAY OF LENGTH M*(N+1) R4 00180001 CA INPUT TRIGS = ARRAY SET UP BY FFTFAX R4 00190001 CA INPUT IFAX = ARRAY SET UP BY FFTFAX I4 00200001 CA INPUT INC = INCREMENT BETWEEN ELEMENTS OF A I4 00210001 CA INPUT JUMP = INCREMENT (IN WORD PAIRS) BETWEEN THE I4 00220001 CA FIRST ELEMENTS OF SUCCESSIVE VECTORS. 00230001 CA INPUT N = LENGTH OF EACH TRANSFORM I4 00240001 CA INPUT M = NUMBER OF TRANSFORMS TO BE DONE I4 00250001 CA INPUT ISIGN = FORWARD/INVERSE SWITCH I4 00260001 CA +1 = WAVE-NUMBER TO SPACE-TIME DOMAIN 00270001 CA -1 = SPACE-TIME TO WAVE-NUMBER DOMAIN 00280001 CA 00290001 SUBROUTINE FFT991 (A, WORK, TRIGS, IFAX, INC, JUMP, N, M, 00300001 * ISIGN) 00310001 C 00320001 IMPLICIT INTEGER (A-Z) 00330001 C 00340001 EXTERNAL ENOTRM 00350001 C 00360001 C ================================= 00370001 C INTEGER ARRAYS -- INPUT ARGUMENTS 00380001 C ================================= 00390001 C 00400001 INTEGER IFAX (1) 00410001 C 00420001 C ================================= 00430001 C COMPLEX ARRAYS -- INPUT ARGUMENTS 00440001 C ================================= 00450001 C 00460001 REAL A (1) 00470001 REAL TRIGS (1) 00480001 REAL WORK (1) 00490001 REAL B (1) 00500001 REAL BUF (1) 00510001 C 00520001 C ======================= 00530001 C INTEGER ARRAYS -- LOCAL 00540001 C ======================= 00550001 C 00560001 INTEGER INCPRE(160) 00570001 INTEGER IPTRM1(160) 00580001 INTEGER IPTRP1(160) 00590001 INTEGER LENGTH(160) 00600001 INTEGER LOTPRE(160) 00610001 C 00620001 C ============== 00630001 C REAL VARIABLES 00640001 C ============== 00650001 C 00660001 REAL SCALE 00670001 REAL SCALEF 00680001 REAL SCALEI 00690001 C 00700001 C =============== 00710001 C DATA STATEMENTS 00720001 C =============== 00730001 C 00740001 DATA INCPRE / 160*0 / 00750001 DATA IPTRM1 / 160*0 / 00760001 DATA IPTRP1 / 160*0 / 00770001 DATA LENGTH / 160*0 / 00780001 DATA LOTPRE / 160*0 / 00790001 DATA NAUX1 / 50000 / 00800001 DATA NAUX2 / 50000 / 00810001 C 00820001 C INITIALIZE THE ESSL ERROR OPTION TABLE 00830001 C 00840001 CALL EINFO(0) 00850001 C 00860001 C MAKE ERROR CODE ESV2015 A RECOVERABLE ERROR 00870001 C SUPPRESS PRINTING ALL ERROR MESSAGES FOR IT 00880001 C 00890001 CALL ERRSET(2015,0,-1,0,ENOTRM) 00900001 C 00910001 C =========== 00920001 C PERFORM FFT 00930001 C =========== 00940001 C 00950001 IX = -ISIGN 00960001 C 00970001 SCALEF = 1.0 / N 00980001 SCALEI = 1.0 00990001 C 01000001 IAUX3 = 1 01010001 NAUX3 = 0 01020001 C 01030001 LENI = 2 * JUMP 01040001 CALL GETMN2 (B, LENI, I , LENO) 01050001 IF (LENI .NE. LENO) CALL XDUMPX 01060001 IAUX4 = I + 1 01070001 C 01080001 DO 10 I = 1, 160 01090001 IPTR = I 01100001 IF (LENGTH(IPTR) .EQ. 0) GO TO 20 01110001 IF (LENGTH(IPTR) .EQ. N) THEN 01120001 IF (INCPRE(IPTR) .EQ. INC) THEN 01130001 IF (LOTPRE(IPTR) .EQ. M) THEN 01140001 GO TO 30 01150001 ENDIF 01160001 ENDIF 01170001 ENDIF 01180001 10 CONTINUE 01190001 CALL XDUMPX 01200001 C 01210001 C INITIALIZE SIN/COS ARRAYS 01220001 C 01230001 20 CONTINUE 01240001 LENGTH(IPTR) = N 01250001 INCPRE(IPTR) = INC 01260001 LOTPRE(IPTR) = M 01270001 LENI = 4 * (NAUX1+NAUX2) 01280001 CALL GETMN2 (BUF, LENI, I, LENO) 01290001 IF (LENI .NE. LENO) CALL XDUMPX 01300001 IPTRP1(IPTR) = I + 1 01310001 IAUX1 = IPTRP1(IPTR) 01320001 IAUX2 = IAUX1 + 2*NAUX1 01330001 SCALE = SCALEF 01340001 25 CALL SRCFT (1, A, JUMP, A, JUMP, N, 1, 1, SCALE, BUF(IAUX1), 01350001 * NAUX1, BUF(IAUX2), NAUX2, BUF(IAUX3), NAUX3, *40) 01360001 C 01370001 IPTRM1(IPTR) = IAUX2 + 2*NAUX2 01380001 IAUX1 = IPTRM1(IPTR) 01390001 IAUX2 = IAUX1 + 2*NAUX1 01400001 SCALE = SCALEI 01410001 CALL SCRFT (1, A, JUMP, A, JUMP, N, 1, -1, SCALE, BUF(IAUX1), 01420001 * NAUX1, BUF(IAUX2), NAUX2, BUF(IAUX3), NAUX3) 01430001 C 01440001 C DO ACTUAL FFT 01450001 C 01460001 30 IF (IX .EQ. 1) THEN 01470001 IAUX1 = IPTRP1(IPTR) 01480001 IAUX2 = IAUX1 + 2*NAUX1 01490001 SCALE = SCALEF 01500001 DO 33 JJ = 1, M 01510001 KK = (JJ-1) * JUMP + 1 01520001 CALL SCOPY(JUMP, A(KK), 1, B(IAUX4), 1) 01530001 CALL SRCFT (0, B(IAUX4), JUMP, B(IAUX4), JUMP, N, 1, IX, 01540001 * SCALE, BUF(IAUX1), NAUX1, BUF(IAUX2), NAUX2, 01550001 * BUF(IAUX3),NAUX3 ) 01560001 CALL SCOPY(JUMP, B(IAUX4), 1, A(KK), 1) 01570001 33 CONTINUE 01580001 ELSE 01590001 IAUX1 = IPTRM1(IPTR) 01600001 IAUX2 = IAUX1 + 2*NAUX1 01610001 SCALE = SCALEI 01620001 DO 35 JJ = 1, M 01630001 KK = (JJ-1) * JUMP + 1 01640001 CALL SCOPY(JUMP, A(KK), 1, B(IAUX4), 1) 01650001 CALL SCRFT (0, B(IAUX4), JUMP, B(IAUX4), JUMP, N, 1, IX, 01660001 * SCALE, BUF(IAUX1), NAUX1, BUF(IAUX2), NAUX2, 01670001 * BUF(IAUX3),NAUX3 ) 01680001 CALL SCOPY(JUMP, B(IAUX4), 1, A(KK), 1) 01690001 35 CONTINUE 01700001 ENDIF 01710001 C 01720001 GO TO 8000 01730001 C 01740001 C CHECK THE RESULTING INPUT ARGUMENT VALUE 01750001 C IN NAUX AND TAKE THE DESIRED ACTION 01760001 C (RETURN THE NECESSARY SIZE FOR NAUX1, NAUX2) 01770001 C 01780001 40 CONTINUE 01790001 LENI = 4 * (NAUX1+NAUX2) 01800001 CALL GETMN2 (BUF, LENI, I, LENO) 01810001 IF (LENI .NE. LENO) CALL XDUMPX 01820001 IPTRP1(IPTR) = I + 1 01830001 IAUX1 = IPTRP1(IPTR) 01840001 IAUX2 = IAUX1 + 2 * NAUX1 01850001 GO TO 25 01860001 C 01870001 C ==== 01880001 C EXIT 01890001 C ==== 01900001 C 01910001 8000 RETURN 01920001 C 01930001 END 01940001