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 314