ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
pmatgeninc.f
Go to the documentation of this file.
1 * =====================================================================
2 * SUBROUTINE LADD
3 * =====================================================================
4 *
5  SUBROUTINE ladd( J, K, I )
6 *
7 * -- ScaLAPACK routine (version 1.7) --
8 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
9 * and University of California, Berkeley.
10 * May 1, 1997
11 *
12 * .. Array Arguments ..
13  INTEGER I(2), J(2), K(2)
14 * ..
15 *
16 * =====================================================================
17 *
18 * .. Parameters ..
19  INTEGER IPOW16, IPOW15
20  parameter( ipow16=2**16, ipow15=2**15 )
21 * ..
22 * .. Intrinsic Functions ..
23  INTRINSIC mod
24 * ..
25 * .. Executable Statements ..
26 *
27  i(1) = mod( k(1)+j(1), ipow16 )
28  i(2) = mod( (k(1)+j(1)) / ipow16+k(2)+j(2), ipow15 )
29 *
30  RETURN
31 *
32 * End of LADD
33 *
34  END
35 *
36 * =====================================================================
37 * SUBROUTINE LMUL
38 * =====================================================================
39 *
40  SUBROUTINE lmul( K, J, I )
41 *
42 * -- ScaLAPACK routine (version 1.7) --
43 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
44 * and University of California, Berkeley.
45 * May 1, 1997
46 *
47 * .. Array Arguments ..
48  INTEGER I(2), J(2), K(2)
49 * ..
50 *
51 * =====================================================================
52 *
53 * .. Parameters ..
54  INTEGER IPOW15, IPOW16, IPOW30
55  parameter( ipow15=2**15, ipow16=2**16, ipow30=2**30 )
56 * ..
57 * .. Local Scalars ..
58  INTEGER KT, LT
59 * ..
60 * .. Intrinsic Functions ..
61  INTRINSIC mod
62 * ..
63 * .. Executable Statements ..
64 *
65  kt = k(1)*j(1)
66  IF( kt.LT.0 ) kt = (kt+ipow30) + ipow30
67  i(1) = mod(kt,ipow16)
68  lt = k(1)*j(2) + k(2)*j(1)
69  IF( lt.LT.0 ) lt = (lt+ipow30) + ipow30
70  kt = kt/ipow16 + lt
71  IF( kt.LT.0 ) kt = (kt+ipow30) + ipow30
72  i(2) = mod( kt, ipow15 )
73 *
74  RETURN
75 *
76 * End of LMUL
77 *
78  END
79 *
80 * =====================================================================
81 * SUBROUTINE XJUMPM
82 * =====================================================================
83 *
84  SUBROUTINE xjumpm( JUMPM, MULT, IADD, IRANN, IRANM, IAM, ICM )
85 *
86 * -- ScaLAPACK routine (version 1.7) --
87 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
88 * and University of California, Berkeley.
89 * May 1, 1997
90 *
91 * .. Scalar Arguments ..
92  INTEGER JUMPM
93 * ..
94 * .. Array Arguments ..
95  INTEGER IADD(2), IAM(2), ICM(2), IRANM(2), IRANN(2)
96  INTEGER MULT(2)
97 * ..
98 *
99 * =====================================================================
100 *
101 * .. Local Scalars ..
102  INTEGER I
103 * ..
104 * .. Local Arrays ..
105  INTEGER J(2)
106 * ..
107 * .. External Subroutines ..
108  EXTERNAL ladd, lmul
109 * ..
110 * .. Executable Statements ..
111 *
112  IF( jumpm.GT.0 ) THEN
113  DO 10 i = 1, 2
114  iam(i) = mult(i)
115  icm(i) = iadd(i)
116  10 CONTINUE
117  DO 20 i = 1, jumpm-1
118  CALL lmul( iam, mult, j )
119  iam(1) = j(1)
120  iam(2) = j(2)
121  CALL lmul( icm, mult, j )
122  CALL ladd( iadd, j, icm )
123  20 CONTINUE
124  CALL lmul( irann, iam, j )
125  CALL ladd( j, icm, iranm )
126  ELSE
127  iranm(1) = irann(1)
128  iranm(2) = irann(2)
129  END IF
130 *
131  RETURN
132 *
133 * End of XJUMPM
134 *
135  END
136 *
137 * =====================================================================
138 * SUBROUTINE SETRAN
139 * =====================================================================
140 *
141  SUBROUTINE setran( IRAN, IA, IC )
142 *
143 * -- ScaLAPACK routine (version 1.7) --
144 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
145 * and University of California, Berkeley.
146 * May 1, 1997
147 *
148 * .. Array Arguments ..
149  INTEGER IA(2), IC(2), IRAN(2)
150 * ..
151 *
152 * =====================================================================
153 *
154 * .. Local Scalars ..
155  INTEGER I
156 * ..
157 * .. Local Arrays ..
158  INTEGER IAS(2), ICS(2), IRAND(2)
159 * ..
160 * .. Common Blocks ..
161  COMMON /rancom/ irand, ias, ics
162  SAVE /rancom/
163 * ..
164 * .. Executable Statements ..
165 *
166  DO 10 i = 1, 2
167  irand(i) = iran(i)
168  ias(i) = ia(i)
169  ics(i) = ic(i)
170  10 CONTINUE
171 *
172  RETURN
173 *
174 * End of SETRAN
175 *
176  END
177 *
178 * =====================================================================
179 * SUBROUTINE JUMPIT
180 * =====================================================================
181 *
182  SUBROUTINE jumpit( MULT, IADD, IRANN, IRANM )
183 *
184 * -- ScaLAPACK routine (version 1.7) --
185 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
186 * and University of California, Berkeley.
187 * May 1, 1997
188 *
189 * .. Array Arguments ..
190  INTEGER IADD(2), IRANM(2), IRANN(2), MULT(2)
191 * ..
192 *
193 * =====================================================================
194 *
195 * .. Local Arrays ..
196  INTEGER IAS(2), ICS(2), IRAND(2), J(2)
197 * ..
198 * .. External Subroutines ..
199  EXTERNAL ladd, lmul
200 * ..
201 * .. Common Blocks ..
202  COMMON /rancom/ irand, ias, ics
203  SAVE /rancom/
204 * ..
205 * .. Executable Statements ..
206 *
207  CALL lmul( irann, mult, j )
208  CALL ladd( j, iadd, iranm )
209 *
210  irand(1) = iranm(1)
211  irand(2) = iranm(2)
212 *
213  RETURN
214 *
215 * End of JUMPIT
216 *
217  END
218 *
219 * =====================================================================
220 * REAL FUNCTION PSRAND
221 * =====================================================================
222 *
223  REAL FUNCTION PSRAND( IDUMM )
224 *
225 * -- ScaLAPACK routine (version 1.7) --
226 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
227 * and University of California, Berkeley.
228 * May 1, 1997
229 *
230 * .. Scalar Arguments ..
231  INTEGER idumm
232 * ..
233 *
234 * =====================================================================
235 *
236 * .. Parameters ..
237  REAL divfac, pow16
238  parameter( divfac=2.147483648e+9, pow16=6.5536e+4 )
239 * ..
240 * .. Local Arrays ..
241  INTEGER j( 2 )
242 * ..
243 * .. External Subroutines ..
244  EXTERNAL ladd, lmul
245 * ..
246 * .. Intrinsic Functions ..
247  INTRINSIC real
248 * ..
249 * .. Common Blocks ..
250  INTEGER ias(2), ics(2), irand(2)
251  COMMON /rancom/ irand, ias, ics
252  SAVE /rancom/
253 * ..
254 * .. Executable Statements ..
255 *
256  psrand = ( real(irand(1)) + pow16 * real(irand(2)) ) / divfac
257 *
258  CALL lmul( irand, ias, j )
259  CALL ladd( j, ics, irand )
260 *
261  RETURN
262 *
263 * End of PSRAND
264 *
265  END
266 *
267 * =====================================================================
268 * DOUBLE PRECISION FUNCTION PDRAND
269 * =====================================================================
270 *
271  DOUBLE PRECISION FUNCTION pdrand( IDUMM )
272 *
273 * -- ScaLAPACK routine (version 1.7) --
274 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
275 * and University of California, Berkeley.
276 * May 1, 1997
277 *
278 * .. Scalar Arguments ..
279  INTEGER idumm
280 * ..
281 *
282 * =====================================================================
283 *
284 * .. Parameters ..
285  DOUBLE PRECISION divfac, pow16
286  parameter( divfac=2.147483648d+9, pow16=6.5536d+4 )
287 * ..
288 * .. Local Arrays ..
289  INTEGER j(2)
290 * ..
291 * .. External Subroutines ..
292  EXTERNAL ladd, lmul
293 * ..
294 * .. Intrinsic Functions ..
295  INTRINSIC dble
296 * ..
297 * .. Common Blocks ..
298  INTEGER ias(2), ics(2), irand(2)
299  COMMON /rancom/ irand, ias, ics
300  SAVE /rancom/
301 * ..
302 * .. Executable Statements ..
303 *
304  pdrand = ( dble(irand(1)) + pow16 * dble(irand(2)) ) / divfac
305 *
306  CALL lmul( irand, ias, j )
307  CALL ladd( j, ics, irand )
308 *
309  RETURN
310 *
311 * End of PDRAND
312 *
313  END
jumpit
subroutine jumpit(MULT, IADD, IRANN, IRANM)
Definition: pmatgeninc.f:183
xjumpm
subroutine xjumpm(JUMPM, MULT, IADD, IRANN, IRANM, IAM, ICM)
Definition: pmatgeninc.f:85
pdrand
double precision function pdrand(IDUMM)
Definition: pmatgeninc.f:272
ladd
subroutine ladd(J, K, I)
Definition: pmatgeninc.f:6
psrand
real function psrand(IDUMM)
Definition: pmatgeninc.f:224
lmul
subroutine lmul(K, J, I)
Definition: pmatgeninc.f:41
setran
subroutine setran(IRAN, IA, IC)
Definition: pmatgeninc.f:142