RFTF2M.inc
References to this file elsewhere.
1 C***********************************************************************
2 SUBROUTINE RFTF2M (N,INC,JUMP,LOT, R, WA,IFAC, WSAVE)
3 DIMENSION R(*) ,WSAVE(*) ,WA(N) ,IFAC(*)
4 C
5 IF (JUMP .GT. INC) THEN
6 INCN = (LOT*JUMP)/N
7 ELSE
8 INCN = INC
9 ENDIF
10 IF(MOD(INCN,16) .EQ. 0) INCN = INCN-1
11 INCN = MAX(INCN,LOT)
12 C
13 N4 = (N/4)*4
14 IF (N4 .GE. 4) THEN
15 IABASE = 1
16 IBBASE = 1+INC
17 ICBASE = 1+INC+INC
18 IDBASE = 1+INC+INC+INC
19 JABASE = 1
20 JBBASE = 1+INCN
21 JCBASE = 1+INCN+INCN
22 JDBASE = 1+INCN+INCN+INCN
23 INQ = 4*INC
24 INQN = 4*INCN
25 *VOPTION NOFVAL
26 DO 102 K=1,N4,4
27 IA = IABASE
28 IB = IBBASE
29 IC = ICBASE
30 ID = IDBASE
31 JA = JABASE
32 JB = JBBASE
33 JC = JCBASE
34 JD = JDBASE
35 *VOPTION VEC,NOFVAL
36 *vdir nodep
37 DO 101 L=1,LOT
38 WSAVE(JA) = R(IA)
39 WSAVE(JB) = R(IB)
40 WSAVE(JC) = R(IC)
41 WSAVE(JD) = R(ID)
42 IA = IA+JUMP
43 IB = IB+JUMP
44 IC = IC+JUMP
45 ID = ID+JUMP
46 JA = JA+1
47 JB = JB+1
48 JC = JC+1
49 JD = JD+1
50 101 CONTINUE
51 IABASE = IABASE+INQ
52 IBBASE = IBBASE+INQ
53 ICBASE = ICBASE+INQ
54 IDBASE = IDBASE+INQ
55 JABASE = JABASE+INQN
56 JBBASE = JBBASE+INQN
57 JCBASE = JCBASE+INQN
58 JDBASE = JDBASE+INQN
59 102 CONTINUE
60 ENDIF
61 IF (N4 .NE. N) THEN
62 IABASE = 1+N4*INC
63 JABASE = 1+N4*INCN
64 *VOPTION NOFVAL
65 DO 104 K=N4+1,N
66 IA = IABASE
67 JA = JABASE
68 *VOPTION VEC,NOFVAL
69 *vdir nodep
70 DO 103 L=1,LOT
71 WSAVE(JA) = R(IA)
72 IA = IA+JUMP
73 JA = JA+1
74 103 CONTINUE
75 IABASE = IABASE+INC
76 JABASE = JABASE+INCN
77 104 CONTINUE
78 ENDIF
79 C
80 CALL RFTF1M (N,INCN,LOT, WSAVE, WA,IFAC, R)
81 C
82 CF = 1.0/FLOAT(N)
83 C
84 IF (N4 .GE. 4) THEN
85 IABASE = 1
86 IBBASE = 1+INC
87 ICBASE = 1+INC+INC
88 IDBASE = 1+INC+INC+INC
89 JABASE = 1
90 JBBASE = 1+INCN
91 JCBASE = 1+INCN+INCN
92 JDBASE = 1+INCN+INCN+INCN
93 INQ = 4*INC
94 INQN = 4*INCN
95 *VOPTION NOFVAL
96 *vdir nodep
97 DO 112 K=1,N4,4
98 IA = IABASE
99 IB = IBBASE
100 IC = ICBASE
101 ID = IDBASE
102 JA = JABASE
103 JB = JBBASE
104 JC = JCBASE
105 JD = JDBASE
106 *VOPTION VEC,NOFVAL
107 *vdir nodep
108 DO 111 L=1,LOT
109 R(IA) = CF*WSAVE(JA)
110 R(IB) = CF*WSAVE(JB)
111 R(IC) = CF*WSAVE(JC)
112 R(ID) = CF*WSAVE(JD)
113 IA = IA+JUMP
114 IB = IB+JUMP
115 IC = IC+JUMP
116 ID = ID+JUMP
117 JA = JA+1
118 JB = JB+1
119 JC = JC+1
120 JD = JD+1
121 111 CONTINUE
122 IABASE = IABASE+INQ
123 IBBASE = IBBASE+INQ
124 ICBASE = ICBASE+INQ
125 IDBASE = IDBASE+INQ
126 JABASE = JABASE+INQN
127 JBBASE = JBBASE+INQN
128 JCBASE = JCBASE+INQN
129 JDBASE = JDBASE+INQN
130 112 CONTINUE
131 ENDIF
132 IF (N4 .NE. N) THEN
133 IABASE = 1+N4*INC
134 JABASE = 1+N4*INCN
135 *VOPTION NOFVAL
136 DO 114 K=N4+1,N
137 IA = IABASE
138 JA = JABASE
139 *VOPTION VEC,NOFVAL
140 *vdir nodep
141 DO 113 L=1,LOT
142 R(IA) = CF*WSAVE(JA)
143 IA = IA+JUMP
144 JA = JA+1
145 113 CONTINUE
146 IABASE = IABASE+INC
147 JABASE = JABASE+INCN
148 114 CONTINUE
149 ENDIF
150 RETURN
151 END SUBROUTINE RFTF2M
152