Rename *ll* and *ul* to ll and ul in in-interval
[maxima.git] / share / fftpack5 / fortran / mcsqf1.f
blob0e3f6e63674ad0b8063ed6415d338bddc39dada4
1 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3 C FFTPACK 5.0
5 C Authors: Paul N. Swarztrauber and Richard A. Valent
7 C $Id$
9 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11 SUBROUTINE MCSQF1 (LOT,JUMP,N,INC,X,WSAVE,WORK,IER)
12 DIMENSION X(INC,*) ,WSAVE(*) ,WORK(LOT,*)
13 IER = 0
14 LJ = (LOT-1)*JUMP+1
15 NS2 = (N+1)/2
16 NP2 = N+2
17 DO 101 K=2,NS2
18 KC = NP2-K
19 M1 = 0
20 DO 201 M=1,LJ,JUMP
21 M1 = M1 + 1
22 WORK(M1,K) = X(M,K)+X(M,KC)
23 WORK(M1,KC) = X(M,K)-X(M,KC)
24 201 CONTINUE
25 101 CONTINUE
26 MODN = MOD(N,2)
27 IF (MODN .NE. 0) GO TO 301
28 M1 = 0
29 DO 202 M=1,LJ,JUMP
30 M1 = M1 + 1
31 WORK(M1,NS2+1) = X(M,NS2+1)+X(M,NS2+1)
32 202 CONTINUE
33 301 DO 102 K=2,NS2
34 KC = NP2-K
35 M1 = 0
36 DO 302 M=1,LJ,JUMP
37 M1 = M1 + 1
38 X(M,K) = WSAVE(K-1)*WORK(M1,KC)+WSAVE(KC-1)*WORK(M1,K)
39 X(M,KC) = WSAVE(K-1)*WORK(M1,K) -WSAVE(KC-1)*WORK(M1,KC)
40 302 CONTINUE
41 102 CONTINUE
42 IF (MODN .NE. 0) GO TO 303
43 M1 = 0
44 DO 304 M=1,LJ,JUMP
45 M1 = M1 + 1
46 X(M,NS2+1) = WSAVE(NS2)*WORK(M1,NS2+1)
47 304 CONTINUE
48 303 CONTINUE
49 LENX = (LOT-1)*JUMP + INC*(N-1) + 1
50 LNSV = N + INT(LOG(REAL(N))/LOG(2.)) + 4
51 LNWK = LOT*N
53 CALL RFFTMF(LOT,JUMP,N,INC,X,LENX,WSAVE(N+1),LNSV,WORK,LNWK,IER1)
54 IF (IER1 .NE. 0) THEN
55 IER = 20
56 CALL XERFFT ('MCSQF1',-5)
57 GO TO 400
58 ENDIF
60 DO 103 I=3,N,2
61 DO 203 M=1,LJ,JUMP
62 XIM1 = .5*(X(M,I-1)+X(M,I))
63 X(M,I) = .5*(X(M,I-1)-X(M,I))
64 X(M,I-1) = XIM1
65 203 CONTINUE
66 103 CONTINUE
67 400 CONTINUE
68 RETURN
69 END