CTITLECFFT99 -- ROUTINE TO PERFORM MULTIPLE, COMPLEX FFT'S 00010001 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA AUTHOR STU NELAN 00020001 CA DESIGNER STU NELAN 00030001 CA LANGUAGE FORTRAN 00040001 CA SYSTEM IBM (SEE CRAY BENCHLIB) 00050001 CA WRITTEN 08/25/88 00060001 C REVISED MM/DD/YY III ... 00070001 C REVISED 01/05/88 JJC MADE ESV2015 ERROR CODE A RECOVERABLE. 00071008 CA 00080001 CA THIS SUBROUTINE PERFORMS MULTIPLE COMPLEX FFT'S USING THE 00090001 CA IBM ESSL SOFTWARE. 00100001 CA 00110001 CA CALL CFFT99 (A, WORK. TRIGS, IFAX, INC, JUMP, N, LOT, ISIGN) 00120001 CA 00130001 CA IN/OUT A = COMPLEX ARRAY OF LENGTH N*LOT C8 00140001 CA INPUT WORK = COMPLEX WORK ARRAY OF LENGTH LOT*(N+1) C8 00150001 CA INPUT TRIGS = ARRAY SET UP BY CFTFAX R4 00160001 CA INPUT IFAX = ARRAY SET UP BY CFTFAX I4 00170001 CA INPUT INC = INCREMENT BETWEEN ELEMENTS OF A I4 00180001 CA INPUT JUMP = INCREMENT (IN WORD PAIRS) BETWEEN THE I4 00190001 CA FIRST ELEMENTS OF SUCCESSIVE VECTORS. 00200001 CA INPUT N = LENGTH OF EACH TRANSFORM I4 00210001 CA INPUT LOT = NUMBER OF TRANSFORMS TO BE DONE I4 00220001 CA INPUT ISIGN = FORWARD/INVERSE SWITCH I4 00230001 CA +1 = WAVE-NUMBER TO SPACE-TIME DOMAIN 00240001 CA -1 = SPACE-TIME TO WAVE-NUMBER DOMAIN 00250001 CA 00260001 SUBROUTINE CFFT99 (A, WORK, TRIGS, IFAX, INC, JUMP, N, LOT, 00270001 * ISIGN) 00280001 C 00290001 IMPLICIT INTEGER (A-Z) 00300001 CJJ 00301006 EXTERNAL ENOTRM 00302006 C 00310001 COMMON COM(1) 00320001 C 00330001 C ================================= 00340001 C INTEGER ARRAYS -- INPUT ARGUMENTS 00350001 C ================================= 00360001 C 00370001 INTEGER IFAX (1) 00380001 C 00390001 C ================================= 00400001 C COMPLEX ARRAYS -- INPUT ARGUMENTS 00410001 C ================================= 00420001 C 00430001 COMPLEX A (1) 00440001 COMPLEX TRIGS (1) 00450001 COMPLEX WORK (1) 00460001 C 00470001 C ======================= 00480001 C INTEGER ARRAYS -- LOCAL 00490001 C ======================= 00500001 C 00510001 INTEGER INCPRE(100) 00520004 INTEGER IPTRM1(100) 00530004 INTEGER IPTRP1(100) 00540001 INTEGER LENGTH(100) 00550001 INTEGER LOTPRE(100) 00560004 C 00570001 C ============== 00580001 C REAL VARIABLES 00590001 C ============== 00600001 C 00610001 REAL SCALE 00620001 C 00630001 C =============== 00640001 C DATA STATEMENTS 00650001 C =============== 00660001 C 00670001 DATA INCPRE / 100*0 / 00680004 DATA IPTRM1 / 100*0 / 00690004 DATA IPTRP1 / 100*0 / 00700001 DATA LENGTH / 100*0 / 00710001 DATA LOTPRE / 100*0 / 00720004 DATA NAUX1 / 50000 / 00730017 DATA NAUX2 / 50000 / 00740017 DATA SCALE / 1.0 / 00750001 CJJ 00751011 CJJ INITIALIZE THE ESSL ERROR OPTION TABLE 00752011 CJJ 00753011 CALL EINFO(0) 00754011 CJJ 00755011 CJJ MAKE ERROR CODE ESV2015 A RECOVERABLE ERROR 00756011 CJJ SUPPRESS PRINTING ALL ERROR MESSAGES FOR IT 00757011 CJJ 00758011 CALL ERRSET(2015,0,-1,0,ENOTRM) 00759011 C 00760001 C =========== 00770001 C PERFORM FFT 00780001 C =========== 00790001 C 00800001 IX = -ISIGN 00810005 C 00820001 DO 10 I = 1, 100 00830001 IPTR = I 00840001 IF (LENGTH(IPTR) .EQ. 0) GO TO 20 00850001 IF (LENGTH(IPTR) .EQ. N) THEN 00860004 IF (INCPRE(IPTR) .EQ. INC) THEN 00870004 IF (LOTPRE(IPTR) .EQ. LOT) THEN 00880004 GO TO 30 00890004 ENDIF 00900004 ENDIF 00910004 ENDIF 00920004 10 CONTINUE 00930001 CALL XDUMPX 00940001 C 00950001 C INITIALIZE SIN/COS ARRAYS 00960001 C 00970001 20 CONTINUE 00980001 LENGTH(IPTR) = N 00990001 INCPRE(IPTR) = INC 01000004 LOTPRE(IPTR) = LOT 01010004 LENI = 4 * (NAUX1+NAUX2) 01020001 CALL GETMN2 (COM, LENI, I, LENO) 01030001 IF (LENI .NE. LENO) CALL XDUMPX 01040001 IPTRP1(IPTR) = I + 1 01050001 IAUX1 = IPTRP1(IPTR) 01060001 IAUX2 = IAUX1 + 2*NAUX1 01070001 25 CALL SCFT (1, A, INC, JUMP, A, INC, JUMP, N, LOT, 1, SCALE, 01080015 * COM(IAUX1), NAUX1, COM(IAUX2), NAUX2, *40) 01090007 C 01100001 IPTRM1(IPTR) = IAUX2 + 2*NAUX2 01110001 IAUX1 = IPTRM1(IPTR) 01120001 IAUX2 = IAUX1 + 2*NAUX1 01130001 CALL SCFT (1, A, INC, JUMP, A, INC, JUMP, N, LOT, -1, SCALE, 01140002 * COM(IAUX1), NAUX1, COM(IAUX2), NAUX2) 01150001 C 01160001 C DO ACTUAL FFT 01170001 C 01180001 30 IF (IX .EQ. 1) THEN 01190001 IAUX1 = IPTRP1(IPTR) 01200001 ELSE 01210001 IAUX1 = IPTRM1(IPTR) 01220001 ENDIF 01230001 IAUX2 = IAUX1 + 2*NAUX1 01240001 CALL SCFT (0, A, INC, JUMP, A, INC, JUMP, N, LOT, IX, SCALE, 01250002 * COM(IAUX1), NAUX1, COM(IAUX2), NAUX2) 01260018 C 01270001 GO TO 8000 01280001 CJJ 01281007 CJJ CHECK THE RESULTING INPUT ARGUMENT VALUE 01282007 CJJ IN NAUX AND TAKE THE DESIRED ACTION 01283007 CJJ 01284007 40 CONTINUE 01284115 LENI = 4 * (NAUX1+NAUX2) 01286007 CALL GETMN2 (COM, LENI, I, LENO) 01287007 IF (LENI .NE. LENO) CALL XDUMPX 01288007 IPTRP1(IPTR) = I + 1 01289007 IAUX1 = IPTRP1(IPTR) 01289107 IAUX2 = IAUX1 + 2 * NAUX1 01289207 GO TO 25 01289307 C 01290001 C ==== 01300001 C EXIT 01310001 C ==== 01320001 C 01330001 8000 RETURN 01340001 C 01350001 END 01360001