SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ pb_dlagen()

subroutine pb_dlagen ( character*1  uplo,
character*1  aform,
double precision, dimension( lda, * )  a,
integer  lda,
integer  lcmt00,
integer, dimension( * )  iran,
integer  mblks,
integer  imbloc,
integer  mb,
integer  lmbloc,
integer  nblks,
integer  inbloc,
integer  nb,
integer  lnbloc,
integer, dimension( * )  jmp,
integer, dimension( 4, * )  imuladd 
)

Definition at line 9734 of file pdblastst.f.

9737*
9738* -- PBLAS test routine (version 2.0) --
9739* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
9740* and University of California, Berkeley.
9741* April 1, 1998
9742*
9743* .. Scalar Arguments ..
9744 CHARACTER*1 UPLO, AFORM
9745 INTEGER IMBLOC, INBLOC, LCMT00, LDA, LMBLOC, LNBLOC,
9746 $ MB, MBLKS, NB, NBLKS
9747* ..
9748* .. Array Arguments ..
9749 INTEGER IMULADD( 4, * ), IRAN( * ), JMP( * )
9750 DOUBLE PRECISION A( LDA, * )
9751* ..
9752*
9753* Purpose
9754* =======
9755*
9756* PB_DLAGEN locally initializes an array A.
9757*
9758* Arguments
9759* =========
9760*
9761* UPLO (global input) CHARACTER*1
9762* On entry, UPLO specifies whether the lower (UPLO='L') trape-
9763* zoidal part or the upper (UPLO='U') trapezoidal part is to be
9764* generated when the matrix to be generated is symmetric or
9765* Hermitian. For all the other values of AFORM, the value of
9766* this input argument is ignored.
9767*
9768* AFORM (global input) CHARACTER*1
9769* On entry, AFORM specifies the type of submatrix to be genera-
9770* ted as follows:
9771* AFORM = 'S', sub( A ) is a symmetric matrix,
9772* AFORM = 'H', sub( A ) is a Hermitian matrix,
9773* AFORM = 'T', sub( A ) is overrwritten with the transpose
9774* of what would normally be generated,
9775* AFORM = 'C', sub( A ) is overwritten with the conjugate
9776* transpose of what would normally be genera-
9777* ted.
9778* AFORM = 'N', a random submatrix is generated.
9779*
9780* A (local output) DOUBLE PRECISION array
9781* On entry, A is an array of dimension (LLD_A, *). On exit,
9782* this array contains the local entries of the randomly genera-
9783* ted submatrix sub( A ).
9784*
9785* LDA (local input) INTEGER
9786* On entry, LDA specifies the local leading dimension of the
9787* array A. LDA must be at least one.
9788*
9789* LCMT00 (global input) INTEGER
9790* On entry, LCMT00 is the LCM value specifying the off-diagonal
9791* of the underlying matrix of interest. LCMT00=0 specifies the
9792* main diagonal, LCMT00 > 0 specifies a subdiagonal, LCMT00 < 0
9793* specifies superdiagonals.
9794*
9795* IRAN (local input) INTEGER array
9796* On entry, IRAN is an array of dimension 2 containing respec-
9797* tively the 16-lower and 16-higher bits of the encoding of the
9798* entry of the random sequence corresponding locally to the
9799* first local array entry to generate. Usually, this array is
9800* computed by PB_SETLOCRAN.
9801*
9802* MBLKS (local input) INTEGER
9803* On entry, MBLKS specifies the local number of blocks of rows.
9804* MBLKS is at least zero.
9805*
9806* IMBLOC (local input) INTEGER
9807* On entry, IMBLOC specifies the number of rows (size) of the
9808* local uppest blocks. IMBLOC is at least zero.
9809*
9810* MB (global input) INTEGER
9811* On entry, MB specifies the blocking factor used to partition
9812* the rows of the matrix. MB must be at least one.
9813*
9814* LMBLOC (local input) INTEGER
9815* On entry, LMBLOC specifies the number of rows (size) of the
9816* local lowest blocks. LMBLOC is at least zero.
9817*
9818* NBLKS (local input) INTEGER
9819* On entry, NBLKS specifies the local number of blocks of co-
9820* lumns. NBLKS is at least zero.
9821*
9822* INBLOC (local input) INTEGER
9823* On entry, INBLOC specifies the number of columns (size) of
9824* the local leftmost blocks. INBLOC is at least zero.
9825*
9826* NB (global input) INTEGER
9827* On entry, NB specifies the blocking factor used to partition
9828* the the columns of the matrix. NB must be at least one.
9829*
9830* LNBLOC (local input) INTEGER
9831* On entry, LNBLOC specifies the number of columns (size) of
9832* the local rightmost blocks. LNBLOC is at least zero.
9833*
9834* JMP (local input) INTEGER array
9835* On entry, JMP is an array of dimension JMP_LEN containing the
9836* different jump values used by the random matrix generator.
9837*
9838* IMULADD (local input) INTEGER array
9839* On entry, IMULADD is an array of dimension (4, JMP_LEN). The
9840* jth column of this array contains the encoded initial cons-
9841* tants a_j and c_j to jump from X( n ) to X( n + JMP( j ) )
9842* (= a_j * X( n ) + c_j) in the random sequence. IMULADD(1:2,j)
9843* contains respectively the 16-lower and 16-higher bits of the
9844* constant a_j, and IMULADD(3:4,j) contains the 16-lower and
9845* 16-higher bits of the constant c_j.
9846*
9847* -- Written on April 1, 1998 by
9848* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
9849*
9850* =====================================================================
9851*
9852* .. Parameters ..
9853 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
9854 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
9855 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW
9856 parameter( jmp_1 = 1, jmp_row = 2, jmp_col = 3,
9857 $ jmp_mb = 4, jmp_imbv = 5, jmp_npmb = 6,
9858 $ jmp_npimbloc = 7, jmp_nb = 8, jmp_inbv = 9,
9859 $ jmp_nqnb = 10, jmp_nqinbloc = 11,
9860 $ jmp_len = 11 )
9861* ..
9862* .. Local Scalars ..
9863 INTEGER I, IB, IBLK, II, IK, ITMP, JB, JBLK, JJ, JK,
9864 $ JTMP, LCMTC, LCMTR, LOW, MNB, UPP
9865 DOUBLE PRECISION DUMMY
9866* ..
9867* .. Local Arrays ..
9868 INTEGER IB0( 2 ), IB1( 2 ), IB2( 2 ), IB3( 2 )
9869* ..
9870* .. External Subroutines ..
9871 EXTERNAL pb_jumpit
9872* ..
9873* .. External Functions ..
9874 LOGICAL LSAME
9875 DOUBLE PRECISION PB_DRAND
9876 EXTERNAL lsame, pb_drand
9877* ..
9878* .. Intrinsic Functions ..
9879 INTRINSIC max, min
9880* ..
9881* .. Executable Statements ..
9882*
9883 DO 10 i = 1, 2
9884 ib1( i ) = iran( i )
9885 ib2( i ) = iran( i )
9886 ib3( i ) = iran( i )
9887 10 CONTINUE
9888*
9889 IF( lsame( aform, 'N' ) ) THEN
9890*
9891* Generate random matrix
9892*
9893 jj = 1
9894*
9895 DO 50 jblk = 1, nblks
9896*
9897 IF( jblk.EQ.1 ) THEN
9898 jb = inbloc
9899 ELSE IF( jblk.EQ.nblks ) THEN
9900 jb = lnbloc
9901 ELSE
9902 jb = nb
9903 END IF
9904*
9905 DO 40 jk = jj, jj + jb - 1
9906*
9907 ii = 1
9908*
9909 DO 30 iblk = 1, mblks
9910*
9911 IF( iblk.EQ.1 ) THEN
9912 ib = imbloc
9913 ELSE IF( iblk.EQ.mblks ) THEN
9914 ib = lmbloc
9915 ELSE
9916 ib = mb
9917 END IF
9918*
9919* Blocks are IB by JB
9920*
9921 DO 20 ik = ii, ii + ib - 1
9922 a( ik, jk ) = pb_drand( 0 )
9923 20 CONTINUE
9924*
9925 ii = ii + ib
9926*
9927 IF( iblk.EQ.1 ) THEN
9928*
9929* Jump IMBLOC + ( NPROW - 1 ) * MB rows
9930*
9931 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib1,
9932 $ ib0 )
9933*
9934 ELSE
9935*
9936* Jump NPROW * MB rows
9937*
9938 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib1, ib0 )
9939*
9940 END IF
9941*
9942 ib1( 1 ) = ib0( 1 )
9943 ib1( 2 ) = ib0( 2 )
9944*
9945 30 CONTINUE
9946*
9947* Jump one column
9948*
9949 CALL pb_jumpit( imuladd( 1, jmp_col ), ib2, ib0 )
9950*
9951 ib1( 1 ) = ib0( 1 )
9952 ib1( 2 ) = ib0( 2 )
9953 ib2( 1 ) = ib0( 1 )
9954 ib2( 2 ) = ib0( 2 )
9955*
9956 40 CONTINUE
9957*
9958 jj = jj + jb
9959*
9960 IF( jblk.EQ.1 ) THEN
9961*
9962* Jump INBLOC + ( NPCOL - 1 ) * NB columns
9963*
9964 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib3, ib0 )
9965*
9966 ELSE
9967*
9968* Jump NPCOL * NB columns
9969*
9970 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib3, ib0 )
9971*
9972 END IF
9973*
9974 ib1( 1 ) = ib0( 1 )
9975 ib1( 2 ) = ib0( 2 )
9976 ib2( 1 ) = ib0( 1 )
9977 ib2( 2 ) = ib0( 2 )
9978 ib3( 1 ) = ib0( 1 )
9979 ib3( 2 ) = ib0( 2 )
9980*
9981 50 CONTINUE
9982*
9983 ELSE IF( lsame( aform, 'T' ) .OR. lsame( aform, 'C' ) ) THEN
9984*
9985* Generate the transpose of the matrix that would be normally
9986* generated.
9987*
9988 ii = 1
9989*
9990 DO 90 iblk = 1, mblks
9991*
9992 IF( iblk.EQ.1 ) THEN
9993 ib = imbloc
9994 ELSE IF( iblk.EQ.mblks ) THEN
9995 ib = lmbloc
9996 ELSE
9997 ib = mb
9998 END IF
9999*
10000 DO 80 ik = ii, ii + ib - 1
10001*
10002 jj = 1
10003*
10004 DO 70 jblk = 1, nblks
10005*
10006 IF( jblk.EQ.1 ) THEN
10007 jb = inbloc
10008 ELSE IF( jblk.EQ.nblks ) THEN
10009 jb = lnbloc
10010 ELSE
10011 jb = nb
10012 END IF
10013*
10014* Blocks are IB by JB
10015*
10016 DO 60 jk = jj, jj + jb - 1
10017 a( ik, jk ) = pb_drand( 0 )
10018 60 CONTINUE
10019*
10020 jj = jj + jb
10021*
10022 IF( jblk.EQ.1 ) THEN
10023*
10024* Jump INBLOC + ( NPCOL - 1 ) * NB columns
10025*
10026 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib1,
10027 $ ib0 )
10028*
10029 ELSE
10030*
10031* Jump NPCOL * NB columns
10032*
10033 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib1, ib0 )
10034*
10035 END IF
10036*
10037 ib1( 1 ) = ib0( 1 )
10038 ib1( 2 ) = ib0( 2 )
10039*
10040 70 CONTINUE
10041*
10042* Jump one row
10043*
10044 CALL pb_jumpit( imuladd( 1, jmp_row ), ib2, ib0 )
10045*
10046 ib1( 1 ) = ib0( 1 )
10047 ib1( 2 ) = ib0( 2 )
10048 ib2( 1 ) = ib0( 1 )
10049 ib2( 2 ) = ib0( 2 )
10050*
10051 80 CONTINUE
10052*
10053 ii = ii + ib
10054*
10055 IF( iblk.EQ.1 ) THEN
10056*
10057* Jump IMBLOC + ( NPROW - 1 ) * MB rows
10058*
10059 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib3, ib0 )
10060*
10061 ELSE
10062*
10063* Jump NPROW * MB rows
10064*
10065 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib3, ib0 )
10066*
10067 END IF
10068*
10069 ib1( 1 ) = ib0( 1 )
10070 ib1( 2 ) = ib0( 2 )
10071 ib2( 1 ) = ib0( 1 )
10072 ib2( 2 ) = ib0( 2 )
10073 ib3( 1 ) = ib0( 1 )
10074 ib3( 2 ) = ib0( 2 )
10075*
10076 90 CONTINUE
10077*
10078 ELSE IF( ( lsame( aform, 'S' ) ).OR.( lsame( aform, 'H' ) ) ) THEN
10079*
10080* Generate a symmetric matrix
10081*
10082 IF( lsame( uplo, 'L' ) ) THEN
10083*
10084* generate lower trapezoidal part
10085*
10086 jj = 1
10087 lcmtc = lcmt00
10088*
10089 DO 170 jblk = 1, nblks
10090*
10091 IF( jblk.EQ.1 ) THEN
10092 jb = inbloc
10093 low = 1 - inbloc
10094 ELSE IF( jblk.EQ.nblks ) THEN
10095 jb = lnbloc
10096 low = 1 - nb
10097 ELSE
10098 jb = nb
10099 low = 1 - nb
10100 END IF
10101*
10102 DO 160 jk = jj, jj + jb - 1
10103*
10104 ii = 1
10105 lcmtr = lcmtc
10106*
10107 DO 150 iblk = 1, mblks
10108*
10109 IF( iblk.EQ.1 ) THEN
10110 ib = imbloc
10111 upp = imbloc - 1
10112 ELSE IF( iblk.EQ.mblks ) THEN
10113 ib = lmbloc
10114 upp = mb - 1
10115 ELSE
10116 ib = mb
10117 upp = mb - 1
10118 END IF
10119*
10120* Blocks are IB by JB
10121*
10122 IF( lcmtr.GT.upp ) THEN
10123*
10124 DO 100 ik = ii, ii + ib - 1
10125 dummy = pb_drand( 0 )
10126 100 CONTINUE
10127*
10128 ELSE IF( lcmtr.GE.low ) THEN
10129*
10130 jtmp = jk - jj + 1
10131 mnb = max( 0, -lcmtr )
10132*
10133 IF( jtmp.LE.min( mnb, jb ) ) THEN
10134*
10135 DO 110 ik = ii, ii + ib - 1
10136 a( ik, jk ) = pb_drand( 0 )
10137 110 CONTINUE
10138*
10139 ELSE IF( ( jtmp.GE.( mnb + 1 ) ) .AND.
10140 $ ( jtmp.LE.min( ib-lcmtr, jb ) ) ) THEN
10141*
10142 itmp = ii + jtmp + lcmtr - 1
10143*
10144 DO 120 ik = ii, itmp - 1
10145 dummy = pb_drand( 0 )
10146 120 CONTINUE
10147*
10148 DO 130 ik = itmp, ii + ib - 1
10149 a( ik, jk ) = pb_drand( 0 )
10150 130 CONTINUE
10151*
10152 END IF
10153*
10154 ELSE
10155*
10156 DO 140 ik = ii, ii + ib - 1
10157 a( ik, jk ) = pb_drand( 0 )
10158 140 CONTINUE
10159*
10160 END IF
10161*
10162 ii = ii + ib
10163*
10164 IF( iblk.EQ.1 ) THEN
10165*
10166* Jump IMBLOC + ( NPROW - 1 ) * MB rows
10167*
10168 lcmtr = lcmtr - jmp( jmp_npimbloc )
10169 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib1,
10170 $ ib0 )
10171*
10172 ELSE
10173*
10174* Jump NPROW * MB rows
10175*
10176 lcmtr = lcmtr - jmp( jmp_npmb )
10177 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib1,
10178 $ ib0 )
10179*
10180 END IF
10181*
10182 ib1( 1 ) = ib0( 1 )
10183 ib1( 2 ) = ib0( 2 )
10184*
10185 150 CONTINUE
10186*
10187* Jump one column
10188*
10189 CALL pb_jumpit( imuladd( 1, jmp_col ), ib2, ib0 )
10190*
10191 ib1( 1 ) = ib0( 1 )
10192 ib1( 2 ) = ib0( 2 )
10193 ib2( 1 ) = ib0( 1 )
10194 ib2( 2 ) = ib0( 2 )
10195*
10196 160 CONTINUE
10197*
10198 jj = jj + jb
10199*
10200 IF( jblk.EQ.1 ) THEN
10201*
10202* Jump INBLOC + ( NPCOL - 1 ) * NB columns
10203*
10204 lcmtc = lcmtc + jmp( jmp_nqinbloc )
10205 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib3, ib0 )
10206*
10207 ELSE
10208*
10209* Jump NPCOL * NB columns
10210*
10211 lcmtc = lcmtc + jmp( jmp_nqnb )
10212 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib3, ib0 )
10213*
10214 END IF
10215*
10216 ib1( 1 ) = ib0( 1 )
10217 ib1( 2 ) = ib0( 2 )
10218 ib2( 1 ) = ib0( 1 )
10219 ib2( 2 ) = ib0( 2 )
10220 ib3( 1 ) = ib0( 1 )
10221 ib3( 2 ) = ib0( 2 )
10222*
10223 170 CONTINUE
10224*
10225 ELSE
10226*
10227* generate upper trapezoidal part
10228*
10229 ii = 1
10230 lcmtr = lcmt00
10231*
10232 DO 250 iblk = 1, mblks
10233*
10234 IF( iblk.EQ.1 ) THEN
10235 ib = imbloc
10236 upp = imbloc - 1
10237 ELSE IF( iblk.EQ.mblks ) THEN
10238 ib = lmbloc
10239 upp = mb - 1
10240 ELSE
10241 ib = mb
10242 upp = mb - 1
10243 END IF
10244*
10245 DO 240 ik = ii, ii + ib - 1
10246*
10247 jj = 1
10248 lcmtc = lcmtr
10249*
10250 DO 230 jblk = 1, nblks
10251*
10252 IF( jblk.EQ.1 ) THEN
10253 jb = inbloc
10254 low = 1 - inbloc
10255 ELSE IF( jblk.EQ.nblks ) THEN
10256 jb = lnbloc
10257 low = 1 - nb
10258 ELSE
10259 jb = nb
10260 low = 1 - nb
10261 END IF
10262*
10263* Blocks are IB by JB
10264*
10265 IF( lcmtc.LT.low ) THEN
10266*
10267 DO 180 jk = jj, jj + jb - 1
10268 dummy = pb_drand( 0 )
10269 180 CONTINUE
10270*
10271 ELSE IF( lcmtc.LE.upp ) THEN
10272*
10273 itmp = ik - ii + 1
10274 mnb = max( 0, lcmtc )
10275*
10276 IF( itmp.LE.min( mnb, ib ) ) THEN
10277*
10278 DO 190 jk = jj, jj + jb - 1
10279 a( ik, jk ) = pb_drand( 0 )
10280 190 CONTINUE
10281*
10282 ELSE IF( ( itmp.GE.( mnb + 1 ) ) .AND.
10283 $ ( itmp.LE.min( jb+lcmtc, ib ) ) ) THEN
10284*
10285 jtmp = jj + itmp - lcmtc - 1
10286*
10287 DO 200 jk = jj, jtmp - 1
10288 dummy = pb_drand( 0 )
10289 200 CONTINUE
10290*
10291 DO 210 jk = jtmp, jj + jb - 1
10292 a( ik, jk ) = pb_drand( 0 )
10293 210 CONTINUE
10294*
10295 END IF
10296*
10297 ELSE
10298*
10299 DO 220 jk = jj, jj + jb - 1
10300 a( ik, jk ) = pb_drand( 0 )
10301 220 CONTINUE
10302*
10303 END IF
10304*
10305 jj = jj + jb
10306*
10307 IF( jblk.EQ.1 ) THEN
10308*
10309* Jump INBLOC + ( NPCOL - 1 ) * NB columns
10310*
10311 lcmtc = lcmtc + jmp( jmp_nqinbloc )
10312 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib1,
10313 $ ib0 )
10314*
10315 ELSE
10316*
10317* Jump NPCOL * NB columns
10318*
10319 lcmtc = lcmtc + jmp( jmp_nqnb )
10320 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib1,
10321 $ ib0 )
10322*
10323 END IF
10324*
10325 ib1( 1 ) = ib0( 1 )
10326 ib1( 2 ) = ib0( 2 )
10327*
10328 230 CONTINUE
10329*
10330* Jump one row
10331*
10332 CALL pb_jumpit( imuladd( 1, jmp_row ), ib2, ib0 )
10333*
10334 ib1( 1 ) = ib0( 1 )
10335 ib1( 2 ) = ib0( 2 )
10336 ib2( 1 ) = ib0( 1 )
10337 ib2( 2 ) = ib0( 2 )
10338*
10339 240 CONTINUE
10340*
10341 ii = ii + ib
10342*
10343 IF( iblk.EQ.1 ) THEN
10344*
10345* Jump IMBLOC + ( NPROW - 1 ) * MB rows
10346*
10347 lcmtr = lcmtr - jmp( jmp_npimbloc )
10348 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib3, ib0 )
10349*
10350 ELSE
10351*
10352* Jump NPROW * MB rows
10353*
10354 lcmtr = lcmtr - jmp( jmp_npmb )
10355 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib3, ib0 )
10356*
10357 END IF
10358*
10359 ib1( 1 ) = ib0( 1 )
10360 ib1( 2 ) = ib0( 2 )
10361 ib2( 1 ) = ib0( 1 )
10362 ib2( 2 ) = ib0( 2 )
10363 ib3( 1 ) = ib0( 1 )
10364 ib3( 2 ) = ib0( 2 )
10365*
10366 250 CONTINUE
10367*
10368 END IF
10369*
10370 END IF
10371*
10372 RETURN
10373*
10374* End of PB_DLAGEN
10375*
pb_jumpit
subroutine pb_jumpit(muladd, irann, iranm)
Definition pblastst.f:4822
max
#define max(A, B)
Definition pcgemr.c:180
min
#define min(A, B)
Definition pcgemr.c:181
pb_drand
double precision function pb_drand(idumm)
Definition pdblastst.f:10378
lsame
logical function lsame(ca, cb)
Definition tools.f:1724
Here is the caller graph for this function: