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

◆ pb_slagen()

subroutine pb_slagen ( character*1  uplo,
character*1  aform,
real, 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 9736 of file psblastst.f.

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