RFTB2M.inc
References to this file elsewhere.
1 C***********************************************************************
2 SUBROUTINE RFTB2M (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 RFTB1M (N,INCN,LOT, WSAVE, WA,IFAC, R)
81 C
82 IF (N4 .GE. 4) THEN
83 IABASE = 1
84 IBBASE = 1+INC
85 ICBASE = 1+INC+INC
86 IDBASE = 1+INC+INC+INC
87 JABASE = 1
88 JBBASE = 1+INCN
89 JCBASE = 1+INCN+INCN
90 JDBASE = 1+INCN+INCN+INCN
91 INQ = 4*INC
92 INQN = 4*INCN
93 *VOPTION NOFVAL
94 DO 112 K=1,N4,4
95 IA = IABASE
96 IB = IBBASE
97 IC = ICBASE
98 ID = IDBASE
99 JA = JABASE
100 JB = JBBASE
101 JC = JCBASE
102 JD = JDBASE
103 *VOPTION VEC,NOFVAL
104 *vdir nodep
105 DO 111 L=1,LOT
106 R(IA) = WSAVE(JA)
107 R(IB) = WSAVE(JB)
108 R(IC) = WSAVE(JC)
109 R(ID) = WSAVE(JD)
110 IA = IA+JUMP
111 IB = IB+JUMP
112 IC = IC+JUMP
113 ID = ID+JUMP
114 JA = JA+1
115 JB = JB+1
116 JC = JC+1
117 JD = JD+1
118 111 CONTINUE
119 IABASE = IABASE+INQ
120 IBBASE = IBBASE+INQ
121 ICBASE = ICBASE+INQ
122 IDBASE = IDBASE+INQ
123 JABASE = JABASE+INQN
124 JBBASE = JBBASE+INQN
125 JCBASE = JCBASE+INQN
126 JDBASE = JDBASE+INQN
127 112 CONTINUE
128 ENDIF
129 IF (N4 .NE. N) THEN
130 IABASE = 1+N4*INC
131 JABASE = 1+N4*INCN
132 *VOPTION NOFVAL
133 DO 114 K=N4+1,N
134 IA = IABASE
135 JA = JABASE
136 *VOPTION VEC,NOFVAL
137 *vdir nodep
138 DO 113 L=1,LOT
139 R(IA) = WSAVE(JA)
140 IA = IA+JUMP
141 JA = JA+1
142 113 CONTINUE
143 IABASE = IABASE+INC
144 JABASE = JABASE+INCN
145 114 CONTINUE
146 ENDIF
147 RETURN
148 END SUBROUTINE RFTB2M
149