SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
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
pdrand
double precision function pdrand(idumm)
Definition pmatgeninc.f:272
psrand
real function psrand(idumm)
Definition pmatgeninc.f:224
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
ladd
subroutine ladd(j, k, i)
Definition pmatgeninc.f:6
setran
subroutine setran(iran, ia, ic)
Definition pmatgeninc.f:142
lmul
subroutine lmul(k, j, i)
Definition pmatgeninc.f:41