ScaLAPACK  2.0.2
ScaLAPACK: Scalable Linear Algebra PACKage
pcblastim.f
Go to the documentation of this file.
00001       SUBROUTINE PCLASCAL( TYPE, M, N, ALPHA, A, IA, JA, DESCA )
00002 *
00003 *  -- PBLAS test routine (version 2.0) --
00004 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
00005 *     and University of California, Berkeley.
00006 *     April 1, 1998
00007 *
00008 *     .. Scalar Arguments ..
00009       CHARACTER*1        TYPE
00010       INTEGER            IA, JA, M, N
00011       COMPLEX            ALPHA
00012 *     ..
00013 *     .. Array Arguments ..
00014       INTEGER            DESCA( * )
00015       COMPLEX            A( * )
00016 *     ..
00017 *
00018 *  Purpose
00019 *  =======
00020 *
00021 *  PCLASCAL  scales the  m by n submatrix A(IA:IA+M-1,JA:JA+N-1) denoted
00022 *  by sub( A ) by the scalar alpha. TYPE  specifies if sub( A ) is full,
00023 *  upper triangular, lower triangular or upper Hessenberg.
00024 *
00025 *  Notes
00026 *  =====
00027 *
00028 *  A description  vector  is associated with each 2D block-cyclicly dis-
00029 *  tributed matrix.  This  vector  stores  the  information  required to
00030 *  establish the  mapping  between a  matrix entry and its corresponding
00031 *  process and memory location.
00032 *
00033 *  In  the  following  comments,   the character _  should  be  read  as
00034 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
00035 *  block cyclicly distributed matrix.  Its description vector is DESCA:
00036 *
00037 *  NOTATION         STORED IN       EXPLANATION
00038 *  ---------------- --------------- ------------------------------------
00039 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
00040 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
00041 *                                   the NPROW x NPCOL BLACS process grid
00042 *                                   A  is distributed over.  The context
00043 *                                   itself  is  global,  but  the handle
00044 *                                   (the integer value) may vary.
00045 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
00046 *                                   ted matrix A, M_A >= 0.
00047 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
00048 *                                   buted matrix A, N_A >= 0.
00049 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
00050 *                                   block of the matrix A, IMB_A > 0.
00051 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
00052 *                                   left   block   of   the   matrix  A,
00053 *                                   INB_A > 0.
00054 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
00055 *                                   bute the last  M_A-IMB_A rows of  A,
00056 *                                   MB_A > 0.
00057 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
00058 *                                   bute the last  N_A-INB_A  columns of
00059 *                                   A, NB_A > 0.
00060 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
00061 *                                   row of the matrix  A is distributed,
00062 *                                   NPROW > RSRC_A >= 0.
00063 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
00064 *                                   first  column of  A  is distributed.
00065 *                                   NPCOL > CSRC_A >= 0.
00066 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
00067 *                                   array  storing  the  local blocks of
00068 *                                   the distributed matrix A,
00069 *                                   IF( Lc( 1, N_A ) > 0 )
00070 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
00071 *                                   ELSE
00072 *                                      LLD_A >= 1.
00073 *
00074 *  Let K be the number of  rows of a matrix A starting at the global in-
00075 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
00076 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
00077 *  receive if these K rows were distributed over NPROW processes.  If  K
00078 *  is the number of columns of a matrix  A  starting at the global index
00079 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
00080 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
00081 *  these K columns were distributed over NPCOL processes.
00082 *
00083 *  The values of Lr() and Lc() may be determined via a call to the func-
00084 *  tion PB_NUMROC:
00085 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
00086 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
00087 *
00088 *  Arguments
00089 *  =========
00090 *
00091 *  TYPE    (global input) CHARACTER*1
00092 *          On entry,  TYPE  specifies the type of the input submatrix as
00093 *          follows:
00094 *             = 'L' or 'l':  sub( A ) is a lower triangular matrix,
00095 *             = 'U' or 'u':  sub( A ) is an upper triangular matrix,
00096 *             = 'H' or 'h':  sub( A ) is an upper Hessenberg matrix,
00097 *             otherwise sub( A ) is a  full matrix.
00098 *
00099 *  M       (global input) INTEGER
00100 *          On entry,  M  specifies the number of rows of  the  submatrix
00101 *          sub( A ). M  must be at least zero.
00102 *
00103 *  N       (global input) INTEGER
00104 *          On entry, N  specifies the number of columns of the submatrix
00105 *          sub( A ). N  must be at least zero.
00106 *
00107 *  ALPHA   (global input) COMPLEX
00108 *          On entry, ALPHA specifies the scalar alpha.
00109 *
00110 *  A       (local input/local output) COMPLEX array
00111 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
00112 *          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
00113 *          the local entries of the matrix  A.
00114 *          On exit, the local entries of this array corresponding to the
00115 *          to  the entries of the submatrix sub( A ) are  overwritten by
00116 *          the local entries of the m by n scaled submatrix.
00117 *
00118 *  IA      (global input) INTEGER
00119 *          On entry, IA  specifies A's global row index, which points to
00120 *          the beginning of the submatrix sub( A ).
00121 *
00122 *  JA      (global input) INTEGER
00123 *          On entry, JA  specifies A's global column index, which points
00124 *          to the beginning of the submatrix sub( A ).
00125 *
00126 *  DESCA   (global and local input) INTEGER array
00127 *          On entry, DESCA  is an integer array of dimension DLEN_. This
00128 *          is the array descriptor for the matrix A.
00129 *
00130 *  -- Written on April 1, 1998 by
00131 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
00132 *
00133 *  =====================================================================
00134 *
00135 *     .. Parameters ..
00136       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
00137      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
00138      $                   RSRC_
00139       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
00140      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
00141      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
00142      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
00143 *     ..
00144 *     .. Local Scalars ..
00145       CHARACTER*1        UPLO
00146       LOGICAL            GODOWN, GOLEFT, LOWER, UPPER
00147       INTEGER            IACOL, IAROW, ICTXT, IIA, IIMAX, ILOW, IMB1,
00148      $                   IMBLOC, INB1, INBLOC, IOFFA, IOFFD, ITYPE,
00149      $                   IUPP, JJA, JJMAX, JOFFA, JOFFD, LCMT, LCMT00,
00150      $                   LDA, LMBLOC, LNBLOC, LOW, M1, MB, MBLKD, MBLKS,
00151      $                   MBLOC, MP, MRCOL, MRROW, MYCOL, MYROW, N1, NB,
00152      $                   NBLKD, NBLKS, NBLOC, NPCOL, NPROW, NQ, PMB,
00153      $                   QNB, TMP1, UPP
00154 *     ..
00155 *     .. Local Arrays ..
00156       INTEGER            DESCA2( DLEN_ )
00157 *     ..
00158 *     .. External Subroutines ..
00159       EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
00160      $                   PB_CLASCAL, PB_DESCTRANS, PB_INFOG2L
00161 *     ..
00162 *     .. External Functions ..
00163       LOGICAL            LSAME
00164       INTEGER            PB_NUMROC
00165       EXTERNAL           LSAME, PB_NUMROC
00166 *     ..
00167 *     .. Intrinsic Functions ..
00168       INTRINSIC          MIN
00169 *     ..
00170 *     .. Executable Statements ..
00171 *
00172 *     Convert descriptor
00173 *
00174       CALL PB_DESCTRANS( DESCA, DESCA2 )
00175 *
00176 *     Get grid parameters
00177 *
00178       ICTXT = DESCA2( CTXT_ )
00179       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
00180 *
00181 *     Quick return if possible
00182 *
00183       IF( M.EQ.0 .OR. N.EQ.0 )
00184      $   RETURN
00185 *
00186       IF( LSAME( TYPE, 'L' ) ) THEN
00187          ITYPE = 1
00188          UPLO  = TYPE
00189          UPPER = .FALSE.
00190          LOWER = .TRUE.
00191          IOFFD = 0
00192       ELSE IF( LSAME( TYPE, 'U' ) ) THEN
00193          ITYPE = 2
00194          UPLO  = TYPE
00195          UPPER = .TRUE.
00196          LOWER = .FALSE.
00197          IOFFD = 0
00198       ELSE IF( LSAME( TYPE, 'H' ) ) THEN
00199          ITYPE = 3
00200          UPLO  = 'U'
00201          UPPER = .TRUE.
00202          LOWER = .FALSE.
00203          IOFFD = 1
00204       ELSE
00205          ITYPE = 0
00206          UPLO  = 'A'
00207          UPPER = .TRUE.
00208          LOWER = .TRUE.
00209          IOFFD = 0
00210       END IF
00211 *
00212 *     Compute local indexes
00213 *
00214       IF( ITYPE.EQ.0 ) THEN
00215 *
00216 *        Full matrix
00217 *
00218          CALL PB_INFOG2L( IA, JA, DESCA2, NPROW, NPCOL, MYROW, MYCOL,
00219      $                    IIA, JJA, IAROW, IACOL )
00220          MP = PB_NUMROC( M, IA, DESCA2( IMB_ ), DESCA2( MB_ ), MYROW,
00221      $                   DESCA2( RSRC_ ), NPROW )
00222          NQ = PB_NUMROC( N, JA, DESCA2( INB_ ), DESCA2( NB_ ), MYCOL,
00223      $                   DESCA2( CSRC_ ), NPCOL )
00224 *
00225          IF( MP.LE.0 .OR. NQ.LE.0 )
00226      $      RETURN
00227 *
00228          LDA   = DESCA2( LLD_ )
00229          IOFFA = IIA + ( JJA - 1 ) * LDA
00230 *
00231          CALL PB_CLASCAL( 'All', MP, NQ, 0, ALPHA, A( IOFFA ), LDA )
00232 *
00233       ELSE
00234 *
00235 *        Trapezoidal matrix
00236 *
00237          CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
00238      $                     MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW,
00239      $                     IACOL, MRROW, MRCOL )
00240 *
00241          IF( MP.LE.0 .OR. NQ.LE.0 )
00242      $      RETURN
00243 *
00244 *        Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
00245 *        LNBLOC, ILOW, LOW, IUPP, and UPP.
00246 *
00247          MB  = DESCA2( MB_ )
00248          NB  = DESCA2( NB_ )
00249          LDA = DESCA2( LLD_ )
00250 *
00251          CALL PB_BINFO( IOFFD, MP, NQ, IMB1, INB1, MB, NB, MRROW,
00252      $                  MRCOL, LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC,
00253      $                  LMBLOC, LNBLOC, ILOW, LOW, IUPP, UPP )
00254 *
00255          M1    = MP
00256          N1    = NQ
00257          IOFFA = IIA - 1
00258          JOFFA = JJA - 1
00259          IIMAX = IOFFA + MP
00260          JJMAX = JOFFA + NQ
00261 *
00262          IF( DESCA2( RSRC_ ).LT.0 ) THEN
00263             PMB = MB
00264          ELSE
00265             PMB = NPROW * MB
00266          END IF
00267          IF( DESCA2( CSRC_ ).LT.0 ) THEN
00268             QNB = NB
00269          ELSE
00270             QNB = NPCOL * NB
00271          END IF
00272 *
00273 *        Handle the first block of rows or columns separately, and
00274 *        update LCMT00, MBLKS and NBLKS.
00275 *
00276          GODOWN = ( LCMT00.GT.IUPP )
00277          GOLEFT = ( LCMT00.LT.ILOW )
00278 *
00279          IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN
00280 *
00281 *           LCMT00 >= ILOW && LCMT00 <= IUPP
00282 *
00283             GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW )
00284             GODOWN = .NOT.GOLEFT
00285 *
00286             CALL PB_CLASCAL( UPLO, IMBLOC, INBLOC, LCMT00, ALPHA,
00287      $                       A( IIA+JOFFA*LDA ), LDA )
00288             IF( GODOWN ) THEN
00289                IF( UPPER .AND. NQ.GT.INBLOC )
00290      $            CALL PB_CLASCAL( 'All', IMBLOC, NQ-INBLOC, 0, ALPHA,
00291      $                             A( IIA+(JOFFA+INBLOC)*LDA ), LDA )
00292                IIA = IIA + IMBLOC
00293                M1  = M1 - IMBLOC
00294             ELSE
00295                IF( LOWER .AND. MP.GT.IMBLOC )
00296      $            CALL PB_CLASCAL( 'All', MP-IMBLOC, INBLOC, 0, ALPHA,
00297      $                             A( IIA+IMBLOC+JOFFA*LDA ), LDA )
00298                JJA = JJA + INBLOC
00299                N1  = N1 - INBLOC
00300             END IF
00301 *
00302          END IF
00303 *
00304          IF( GODOWN ) THEN
00305 *
00306             LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
00307             MBLKS  = MBLKS - 1
00308             IOFFA  = IOFFA + IMBLOC
00309 *
00310    10       CONTINUE
00311             IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
00312                LCMT00 = LCMT00 - PMB
00313                MBLKS  = MBLKS - 1
00314                IOFFA  = IOFFA + MB
00315                GO TO 10
00316             END IF
00317 *
00318             TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
00319             IF( UPPER .AND. TMP1.GT.0 ) THEN
00320                CALL PB_CLASCAL( 'All', TMP1, N1, 0, ALPHA,
00321      $                          A( IIA+JOFFA*LDA ), LDA )
00322                IIA = IIA + TMP1
00323                M1  = M1 - TMP1
00324             END IF
00325 *
00326             IF( MBLKS.LE.0 )
00327      $         RETURN
00328 *
00329             LCMT  = LCMT00
00330             MBLKD = MBLKS
00331             IOFFD = IOFFA
00332 *
00333             MBLOC = MB
00334    20       CONTINUE
00335             IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN
00336                IF( MBLKD.EQ.1 )
00337      $            MBLOC = LMBLOC
00338                CALL PB_CLASCAL( UPLO, MBLOC, INBLOC, LCMT, ALPHA,
00339      $                          A( IOFFD+1+JOFFA*LDA ), LDA )
00340                LCMT00 = LCMT
00341                LCMT   = LCMT - PMB
00342                MBLKS  = MBLKD
00343                MBLKD  = MBLKD - 1
00344                IOFFA  = IOFFD
00345                IOFFD  = IOFFD + MBLOC
00346                GO TO 20
00347             END IF
00348 *
00349             TMP1 = M1 - IOFFD + IIA - 1
00350             IF( LOWER .AND. TMP1.GT.0 )
00351      $         CALL PB_CLASCAL( 'All', TMP1, INBLOC, 0, ALPHA,
00352      $                          A( IOFFD+1+JOFFA*LDA ), LDA )
00353 *
00354             TMP1   = IOFFA - IIA + 1
00355             M1     = M1 - TMP1
00356             N1     = N1 - INBLOC
00357             LCMT00 = LCMT00 + LOW - ILOW + QNB
00358             NBLKS  = NBLKS - 1
00359             JOFFA  = JOFFA + INBLOC
00360 *
00361             IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 )
00362      $         CALL PB_CLASCAL( 'All', TMP1, N1, 0, ALPHA,
00363      $                          A( IIA+JOFFA*LDA ), LDA )
00364 *
00365             IIA = IOFFA + 1
00366             JJA = JOFFA + 1
00367 *
00368          ELSE IF( GOLEFT ) THEN
00369 *
00370             LCMT00 = LCMT00 + LOW - ILOW + QNB
00371             NBLKS  = NBLKS - 1
00372             JOFFA  = JOFFA + INBLOC
00373 *
00374    30       CONTINUE
00375             IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN
00376                LCMT00 = LCMT00 + QNB
00377                NBLKS  = NBLKS - 1
00378                JOFFA  = JOFFA + NB
00379                GO TO 30
00380             END IF
00381 *
00382             TMP1 = MIN( JOFFA, JJMAX ) - JJA + 1
00383             IF( LOWER .AND. TMP1.GT.0 ) THEN
00384                CALL PB_CLASCAL( 'All', M1, TMP1, 0, ALPHA,
00385      $                          A( IIA+(JJA-1)*LDA ), LDA )
00386                JJA = JJA + TMP1
00387                N1  = N1 - TMP1
00388             END IF
00389 *
00390             IF( NBLKS.LE.0 )
00391      $         RETURN
00392 *
00393             LCMT  = LCMT00
00394             NBLKD = NBLKS
00395             JOFFD = JOFFA
00396 *
00397             NBLOC = NB
00398    40       CONTINUE
00399             IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN
00400                IF( NBLKD.EQ.1 )
00401      $            NBLOC = LNBLOC
00402                CALL PB_CLASCAL( UPLO, IMBLOC, NBLOC, LCMT, ALPHA,
00403      $                          A( IIA+JOFFD*LDA ), LDA )
00404                LCMT00 = LCMT
00405                LCMT   = LCMT + QNB
00406                NBLKS  = NBLKD
00407                NBLKD  = NBLKD - 1
00408                JOFFA  = JOFFD
00409                JOFFD  = JOFFD + NBLOC
00410                GO TO 40
00411             END IF
00412 *
00413             TMP1 = N1 - JOFFD + JJA - 1
00414             IF( UPPER .AND. TMP1.GT.0 )
00415      $         CALL PB_CLASCAL( 'All', IMBLOC, TMP1, 0, ALPHA,
00416      $                          A( IIA+JOFFD*LDA ), LDA )
00417 *
00418             TMP1   = JOFFA - JJA + 1
00419             M1     = M1 - IMBLOC
00420             N1     = N1 - TMP1
00421             LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
00422             MBLKS  = MBLKS - 1
00423             IOFFA  = IOFFA + IMBLOC
00424 *
00425             IF( LOWER .AND. M1.GT.0 .AND. TMP1.GT.0 )
00426      $         CALL PB_CLASCAL( 'All', M1, TMP1, 0, ALPHA,
00427      $                          A( IOFFA+1+(JJA-1)*LDA ), LDA )
00428 *
00429             IIA = IOFFA + 1
00430             JJA = JOFFA + 1
00431 *
00432          END IF
00433 *
00434          NBLOC = NB
00435    50    CONTINUE
00436          IF( NBLKS.GT.0 ) THEN
00437             IF( NBLKS.EQ.1 )
00438      $         NBLOC = LNBLOC
00439    60       CONTINUE
00440             IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
00441                LCMT00 = LCMT00 - PMB
00442                MBLKS  = MBLKS - 1
00443                IOFFA  = IOFFA + MB
00444                GO TO 60
00445             END IF
00446 *
00447             TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
00448             IF( UPPER .AND. TMP1.GT.0 ) THEN
00449                CALL PB_CLASCAL( 'All', TMP1, N1, 0, ALPHA,
00450      $                          A( IIA+JOFFA*LDA ), LDA )
00451                IIA = IIA + TMP1
00452                M1  = M1 - TMP1
00453             END IF
00454 *
00455             IF( MBLKS.LE.0 )
00456      $         RETURN
00457 *
00458             LCMT  = LCMT00
00459             MBLKD = MBLKS
00460             IOFFD = IOFFA
00461 *
00462             MBLOC = MB
00463    70       CONTINUE
00464             IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN
00465                IF( MBLKD.EQ.1 )
00466      $            MBLOC = LMBLOC
00467                CALL PB_CLASCAL( UPLO, MBLOC, NBLOC, LCMT, ALPHA,
00468      $                          A( IOFFD+1+JOFFA*LDA ), LDA )
00469                LCMT00 = LCMT
00470                LCMT   = LCMT - PMB
00471                MBLKS  = MBLKD
00472                MBLKD  = MBLKD - 1
00473                IOFFA  = IOFFD
00474                IOFFD  = IOFFD + MBLOC
00475                GO TO 70
00476             END IF
00477 *
00478             TMP1 = M1 - IOFFD + IIA - 1
00479             IF( LOWER .AND. TMP1.GT.0 )
00480      $         CALL PB_CLASCAL( 'All', TMP1, NBLOC, 0, ALPHA,
00481      $                          A( IOFFD+1+JOFFA*LDA ), LDA )
00482 *
00483             TMP1   = MIN( IOFFA, IIMAX )  - IIA + 1
00484             M1     = M1 - TMP1
00485             N1     = N1 - NBLOC
00486             LCMT00 = LCMT00 + QNB
00487             NBLKS  = NBLKS - 1
00488             JOFFA  = JOFFA + NBLOC
00489 *
00490             IF( UPPER .AND. TMP1.GT.0 .AND. N1.GT.0 )
00491      $         CALL PB_CLASCAL( 'All', TMP1, N1, 0, ALPHA,
00492      $                          A( IIA+JOFFA*LDA ), LDA )
00493 *
00494             IIA = IOFFA + 1
00495             JJA = JOFFA + 1
00496 *
00497             GO TO 50
00498 *
00499          END IF
00500 *
00501       END IF
00502 *
00503       RETURN
00504 *
00505 *     End of PCLASCAL
00506 *
00507       END
00508       SUBROUTINE PCLAGEN( INPLACE, AFORM, DIAG, OFFA, M, N, IA, JA,
00509      $                    DESCA, IASEED, A, LDA )
00510 *
00511 *  -- PBLAS test routine (version 2.0) --
00512 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
00513 *     and University of California, Berkeley.
00514 *     April 1, 1998
00515 *
00516 *     .. Scalar Arguments ..
00517       LOGICAL            INPLACE
00518       CHARACTER*1        AFORM, DIAG
00519       INTEGER            IA, IASEED, JA, LDA, M, N, OFFA
00520 *     ..
00521 *     .. Array Arguments ..
00522       INTEGER            DESCA( * )
00523       COMPLEX            A( LDA, * )
00524 *     ..
00525 *
00526 *  Purpose
00527 *  =======
00528 *
00529 *  PCLAGEN  generates  (or regenerates)  a  submatrix  sub( A ) denoting
00530 *  A(IA:IA+M-1,JA:JA+N-1).
00531 *
00532 *  Notes
00533 *  =====
00534 *
00535 *  A description  vector  is associated with each 2D block-cyclicly dis-
00536 *  tributed matrix.  This  vector  stores  the  information  required to
00537 *  establish the  mapping  between a  matrix entry and its corresponding
00538 *  process and memory location.
00539 *
00540 *  In  the  following  comments,   the character _  should  be  read  as
00541 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
00542 *  block cyclicly distributed matrix.  Its description vector is DESCA:
00543 *
00544 *  NOTATION         STORED IN       EXPLANATION
00545 *  ---------------- --------------- ------------------------------------
00546 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
00547 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
00548 *                                   the NPROW x NPCOL BLACS process grid
00549 *                                   A  is distributed over.  The context
00550 *                                   itself  is  global,  but  the handle
00551 *                                   (the integer value) may vary.
00552 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
00553 *                                   ted matrix A, M_A >= 0.
00554 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
00555 *                                   buted matrix A, N_A >= 0.
00556 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
00557 *                                   block of the matrix A, IMB_A > 0.
00558 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
00559 *                                   left   block   of   the   matrix  A,
00560 *                                   INB_A > 0.
00561 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
00562 *                                   bute the last  M_A-IMB_A rows of  A,
00563 *                                   MB_A > 0.
00564 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
00565 *                                   bute the last  N_A-INB_A  columns of
00566 *                                   A, NB_A > 0.
00567 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
00568 *                                   row of the matrix  A is distributed,
00569 *                                   NPROW > RSRC_A >= 0.
00570 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
00571 *                                   first  column of  A  is distributed.
00572 *                                   NPCOL > CSRC_A >= 0.
00573 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
00574 *                                   array  storing  the  local blocks of
00575 *                                   the distributed matrix A,
00576 *                                   IF( Lc( 1, N_A ) > 0 )
00577 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
00578 *                                   ELSE
00579 *                                      LLD_A >= 1.
00580 *
00581 *  Let K be the number of  rows of a matrix A starting at the global in-
00582 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
00583 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
00584 *  receive if these K rows were distributed over NPROW processes.  If  K
00585 *  is the number of columns of a matrix  A  starting at the global index
00586 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
00587 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
00588 *  these K columns were distributed over NPCOL processes.
00589 *
00590 *  The values of Lr() and Lc() may be determined via a call to the func-
00591 *  tion PB_NUMROC:
00592 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
00593 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
00594 *
00595 *  Arguments
00596 *  =========
00597 *
00598 *  INPLACE (global input) LOGICAL
00599 *          On entry, INPLACE specifies if the matrix should be generated
00600 *          in place or not. If INPLACE is .TRUE., the local random array
00601 *          to be generated  will start in memory at the local memory lo-
00602 *          cation A( 1, 1 ),  otherwise it will start at the local posi-
00603 *          tion induced by IA and JA.
00604 *
00605 *  AFORM   (global input) CHARACTER*1
00606 *          On entry, AFORM specifies the type of submatrix to be genera-
00607 *          ted as follows:
00608 *             AFORM = 'S', sub( A ) is a symmetric matrix,
00609 *             AFORM = 'H', sub( A ) is a Hermitian matrix,
00610 *             AFORM = 'T', sub( A ) is overrwritten  with  the transpose
00611 *                          of what would normally be generated,
00612 *             AFORM = 'C', sub( A ) is overwritten  with  the  conjugate
00613 *                          transpose  of  what would normally be genera-
00614 *                          ted.
00615 *             AFORM = 'N', a random submatrix is generated.
00616 *
00617 *  DIAG    (global input) CHARACTER*1
00618 *          On entry, DIAG specifies if the generated submatrix is diago-
00619 *          nally dominant or not as follows:
00620 *             DIAG = 'D' : sub( A ) is diagonally dominant,
00621 *             DIAG = 'N' : sub( A ) is not diagonally dominant.
00622 *
00623 *  OFFA    (global input) INTEGER
00624 *          On entry, OFFA  specifies  the  offdiagonal of the underlying
00625 *          matrix A(1:DESCA(M_),1:DESCA(N_)) of interest when the subma-
00626 *          trix is symmetric, Hermitian or diagonally dominant. OFFA = 0
00627 *          specifies the main diagonal,  OFFA > 0  specifies a subdiago-
00628 *          nal,  and OFFA < 0 specifies a superdiagonal (see further de-
00629 *          tails).
00630 *
00631 *  M       (global input) INTEGER
00632 *          On entry, M specifies the global number of matrix rows of the
00633 *          submatrix sub( A ) to be generated. M must be at least zero.
00634 *
00635 *  N       (global input) INTEGER
00636 *          On entry,  N specifies the global number of matrix columns of
00637 *          the  submatrix  sub( A )  to be generated. N must be at least
00638 *          zero.
00639 *
00640 *  IA      (global input) INTEGER
00641 *          On entry, IA  specifies A's global row index, which points to
00642 *          the beginning of the submatrix sub( A ).
00643 *
00644 *  JA      (global input) INTEGER
00645 *          On entry, JA  specifies A's global column index, which points
00646 *          to the beginning of the submatrix sub( A ).
00647 *
00648 *  DESCA   (global and local input) INTEGER array
00649 *          On entry, DESCA  is an integer array of dimension DLEN_. This
00650 *          is the array descriptor for the matrix A.
00651 *
00652 *  IASEED  (global input) INTEGER
00653 *          On entry, IASEED  specifies  the  seed number to generate the
00654 *          matrix A. IASEED must be at least zero.
00655 *
00656 *  A       (local output) COMPLEX array
00657 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
00658 *          at least Lc( 1, JA+N-1 ).  On  exit, this array  contains the
00659 *          local entries of the randomly generated submatrix sub( A ).
00660 *
00661 *  LDA     (local input) INTEGER
00662 *          On entry,  LDA  specifies  the local leading dimension of the
00663 *          array A. When INPLACE is .FALSE., LDA is usually DESCA(LLD_).
00664 *          This restriction is however not enforced, and this subroutine
00665 *          requires only that LDA >= MAX( 1, Mp ) where
00666 *
00667 *          Mp = PB_NUMROC( M, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ).
00668 *
00669 *          PB_NUMROC  is  a ScaLAPACK tool function; MYROW, MYCOL, NPROW
00670 *          and NPCOL  can  be determined by calling the BLACS subroutine
00671 *          BLACS_GRIDINFO.
00672 *
00673 *  Further Details
00674 *  ===============
00675 *
00676 *  OFFD  is  tied  to  the matrix described by  DESCA, as opposed to the
00677 *  piece that is currently  (re)generated.  This is a global information
00678 *  independent from the distribution  parameters.  Below are examples of
00679 *  the meaning of OFFD for a global 7 by 5 matrix:
00680 *
00681 *  ---------------------------------------------------------------------
00682 *  OFFD   |  0 -1 -2 -3 -4         0 -1 -2 -3 -4          0 -1 -2 -3 -4
00683 *  -------|-------------------------------------------------------------
00684 *         |     | OFFD=-1          |   OFFD=0                 OFFD=2
00685 *         |     V                  V
00686 *  0      |  .  d  .  .  .      -> d  .  .  .  .          .  .  .  .  .
00687 *  1      |  .  .  d  .  .         .  d  .  .  .          .  .  .  .  .
00688 *  2      |  .  .  .  d  .         .  .  d  .  .       -> d  .  .  .  .
00689 *  3      |  .  .  .  .  d         .  .  .  d  .          .  d  .  .  .
00690 *  4      |  .  .  .  .  .         .  .  .  .  d          .  .  d  .  .
00691 *  5      |  .  .  .  .  .         .  .  .  .  .          .  .  .  d  .
00692 *  6      |  .  .  .  .  .         .  .  .  .  .          .  .  .  .  d
00693 *  ---------------------------------------------------------------------
00694 *
00695 *  -- Written on April 1, 1998 by
00696 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
00697 *
00698 *  =====================================================================
00699 *
00700 *     .. Parameters ..
00701       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
00702      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
00703      $                   RSRC_
00704       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
00705      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
00706      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
00707      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
00708       INTEGER            JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
00709      $                   JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
00710      $                   JMP_NQINBLOC, JMP_NQNB, JMP_ROW
00711       PARAMETER          ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3,
00712      $                   JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6,
00713      $                   JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9,
00714      $                   JMP_NQNB = 10, JMP_NQINBLOC = 11,
00715      $                   JMP_LEN = 11 )
00716       REAL               ZERO
00717       PARAMETER          ( ZERO = 0.0E+0 )
00718 *     ..
00719 *     .. Local Scalars ..
00720       LOGICAL            DIAGDO, SYMM, HERM, NOTRAN
00721       INTEGER            CSRC, I, IACOL, IAROW, ICTXT, IIA, ILOCBLK,
00722      $                   ILOCOFF, ILOW, IMB, IMB1, IMBLOC, IMBVIR, INB,
00723      $                   INB1, INBLOC, INBVIR, INFO, IOFFDA, ITMP, IUPP,
00724      $                   IVIR, JJA, JLOCBLK, JLOCOFF, JVIR, LCMT00,
00725      $                   LMBLOC, LNBLOC, LOW, MAXMN, MB, MBLKS, MP,
00726      $                   MRCOL, MRROW, MYCDIST, MYCOL, MYRDIST, MYROW,
00727      $                   NB, NBLKS, NPCOL, NPROW, NQ, NVIR, RSRC, UPP
00728       COMPLEX            ALPHA
00729 *     ..
00730 *     .. Local Arrays ..
00731       INTEGER            DESCA2( DLEN_ ), IMULADD( 4, JMP_LEN ),
00732      $                   IRAN( 2 ), JMP( JMP_LEN ), MULADD0( 4 )
00733 *     ..
00734 *     .. External Subroutines ..
00735       EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
00736      $                   PB_CHKMAT, PB_CLAGEN, PB_DESCTRANS, PB_INITJMP,
00737      $                   PB_INITMULADD, PB_JUMP, PB_JUMPIT, PB_LOCINFO,
00738      $                   PB_SETLOCRAN, PB_SETRAN, PCLADOM, PXERBLA
00739 *     ..
00740 *     .. External Functions ..
00741       LOGICAL            LSAME
00742       EXTERNAL           LSAME
00743 *     ..
00744 *     .. Intrinsic Functions ..
00745       INTRINSIC          CMPLX, MAX, MIN, REAL
00746 *     ..
00747 *     .. Data Statements ..
00748       DATA               ( MULADD0( I ), I = 1, 4 ) / 20077, 16838,
00749      $                   12345, 0 /
00750 *     ..
00751 *     .. Executable Statements ..
00752 *
00753 *     Convert descriptor
00754 *
00755       CALL PB_DESCTRANS( DESCA, DESCA2 )
00756 *
00757 *     Test the input arguments
00758 *
00759       ICTXT = DESCA2( CTXT_ )
00760       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
00761 *
00762 *     Test the input parameters
00763 *
00764       INFO = 0
00765       IF( NPROW.EQ.-1 ) THEN
00766          INFO = -( 1000 + CTXT_ )
00767       ELSE
00768          SYMM   = LSAME( AFORM, 'S' )
00769          HERM   = LSAME( AFORM, 'H' )
00770          NOTRAN = LSAME( AFORM, 'N' )
00771          DIAGDO = LSAME( DIAG, 'D' )
00772          IF( .NOT.( SYMM.OR.HERM.OR.NOTRAN ) .AND.
00773      $       .NOT.( LSAME( AFORM, 'T' )    ) .AND.
00774      $       .NOT.( LSAME( AFORM, 'C' )    ) ) THEN
00775             INFO = -2
00776          ELSE IF( ( .NOT.DIAGDO ) .AND.
00777      $            ( .NOT.LSAME( DIAG, 'N' ) ) ) THEN
00778             INFO = -3
00779          END IF
00780          CALL PB_CHKMAT( ICTXT, M, 5, N, 6, IA, JA, DESCA2, 10, INFO )
00781       END IF
00782 *
00783       IF( INFO.NE.0 ) THEN
00784          CALL PXERBLA( ICTXT, 'PCLAGEN', -INFO )
00785          RETURN
00786       END IF
00787 *
00788 *     Quick return if possible
00789 *
00790       IF( ( M.LE.0 ).OR.( N.LE.0 ) )
00791      $   RETURN
00792 *
00793 *     Start the operations
00794 *
00795       MB   = DESCA2( MB_   )
00796       NB   = DESCA2( NB_   )
00797       IMB  = DESCA2( IMB_  )
00798       INB  = DESCA2( INB_  )
00799       RSRC = DESCA2( RSRC_ )
00800       CSRC = DESCA2( CSRC_ )
00801 *
00802 *     Figure out local information about the distributed matrix operand
00803 *
00804       CALL PB_AINFOG2L( M, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
00805      $                  MYCOL, IMB1, INB1, MP, NQ, IIA, JJA, IAROW,
00806      $                  IACOL, MRROW, MRCOL )
00807 *
00808 *     Decide where the entries shall be stored in memory
00809 *
00810       IF( INPLACE ) THEN
00811          IIA = 1
00812          JJA = 1
00813       END IF
00814 *
00815 *     Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
00816 *     ILOW, LOW, IUPP, and UPP.
00817 *
00818       IOFFDA = JA + OFFA - IA
00819       CALL PB_BINFO( IOFFDA, MP, NQ, IMB1, INB1, MB, NB, MRROW,
00820      $               MRCOL, LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC,
00821      $               LMBLOC, LNBLOC, ILOW, LOW, IUPP, UPP )
00822 *
00823 *     Initialize ILOCBLK, ILOCOFF, MYRDIST, JLOCBLK, JLOCOFF, MYCDIST
00824 *     This values correspond to the square virtual underlying matrix
00825 *     of size MAX( M_ + MAX( 0, -OFFA ), N_ + MAX( 0, OFFA ) ) used
00826 *     to set up the random sequence. For practical purposes, the size
00827 *     of this virtual matrix is upper bounded by M_ + N_ - 1.
00828 *
00829       ITMP   = MAX( 0, -OFFA )
00830       IVIR   = IA  + ITMP
00831       IMBVIR = IMB + ITMP
00832       NVIR   = DESCA2( M_ ) + ITMP
00833 *
00834       CALL PB_LOCINFO( IVIR, IMBVIR, MB, MYROW, RSRC, NPROW, ILOCBLK,
00835      $                 ILOCOFF, MYRDIST )
00836 *
00837       ITMP   = MAX( 0, OFFA )
00838       JVIR   = JA  + ITMP
00839       INBVIR = INB + ITMP
00840       NVIR   = MAX( MAX( NVIR, DESCA2( N_ ) + ITMP ),
00841      $              DESCA2( M_ ) + DESCA2( N_ ) - 1 )
00842 *
00843       CALL PB_LOCINFO( JVIR, INBVIR, NB, MYCOL, CSRC, NPCOL, JLOCBLK,
00844      $                 JLOCOFF, MYCDIST )
00845 *
00846       IF( SYMM .OR. HERM .OR. NOTRAN ) THEN
00847 *
00848          CALL PB_INITJMP( .TRUE., NVIR, IMBVIR, INBVIR, IMBLOC, INBLOC,
00849      $                    MB, NB, RSRC, CSRC, NPROW, NPCOL, 2, JMP )
00850 *
00851 *        Compute constants to jump JMP( * ) numbers in the sequence
00852 *
00853          CALL PB_INITMULADD( MULADD0, JMP, IMULADD )
00854 *
00855 *        Compute and set the random value corresponding to A( IA, JA )
00856 *
00857          CALL PB_SETLOCRAN( IASEED, ILOCBLK, JLOCBLK, ILOCOFF, JLOCOFF,
00858      $                      MYRDIST, MYCDIST, NPROW, NPCOL, JMP,
00859      $                      IMULADD, IRAN )
00860 *
00861          CALL PB_CLAGEN( 'Lower', AFORM, A( IIA, JJA ), LDA, LCMT00,
00862      $                   IRAN, MBLKS, IMBLOC, MB, LMBLOC, NBLKS, INBLOC,
00863      $                   NB, LNBLOC, JMP, IMULADD )
00864 *
00865       END IF
00866 *
00867       IF( SYMM .OR. HERM .OR. ( .NOT. NOTRAN ) ) THEN
00868 *
00869          CALL PB_INITJMP( .FALSE., NVIR, IMBVIR, INBVIR, IMBLOC, INBLOC,
00870      $                    MB, NB, RSRC, CSRC, NPROW, NPCOL, 2, JMP )
00871 *
00872 *        Compute constants to jump JMP( * ) numbers in the sequence
00873 *
00874          CALL PB_INITMULADD( MULADD0, JMP, IMULADD )
00875 *
00876 *        Compute and set the random value corresponding to A( IA, JA )
00877 *
00878          CALL PB_SETLOCRAN( IASEED, ILOCBLK, JLOCBLK, ILOCOFF, JLOCOFF,
00879      $                      MYRDIST, MYCDIST, NPROW, NPCOL, JMP,
00880      $                      IMULADD, IRAN )
00881 *
00882          CALL PB_CLAGEN( 'Upper', AFORM, A( IIA, JJA ), LDA, LCMT00,
00883      $                   IRAN, MBLKS, IMBLOC, MB, LMBLOC, NBLKS, INBLOC,
00884      $                   NB, LNBLOC, JMP, IMULADD )
00885 *
00886       END IF
00887 *
00888       IF( DIAGDO ) THEN
00889 *
00890          MAXMN = MAX( DESCA2( M_ ), DESCA2( N_ ) )
00891          IF( HERM ) THEN
00892             ALPHA = CMPLX( REAL( 2 * MAXMN ), ZERO )
00893          ELSE
00894             ALPHA = CMPLX( REAL( MAXMN ), REAL( MAXMN ) )
00895          END IF
00896 *
00897          IF( IOFFDA.GE.0 ) THEN
00898             CALL PCLADOM( INPLACE, MIN( MAX( 0, M-IOFFDA ), N ), ALPHA,
00899      $                    A, MIN( IA+IOFFDA, IA+M-1 ), JA, DESCA )
00900          ELSE
00901             CALL PCLADOM( INPLACE, MIN( M, MAX( 0, N+IOFFDA ) ), ALPHA,
00902      $                    A, IA, MIN( JA-IOFFDA, JA+N-1 ), DESCA )
00903          END IF
00904 *
00905       END IF
00906 *
00907       RETURN
00908 *
00909 *     End of PCLAGEN
00910 *
00911       END
00912       SUBROUTINE PCLADOM( INPLACE, N, ALPHA, A, IA, JA, DESCA )
00913 *
00914 *  -- PBLAS test routine (version 2.0) --
00915 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
00916 *     and University of California, Berkeley.
00917 *     April 1, 1998
00918 *
00919 *     .. Scalar Arguments ..
00920       LOGICAL            INPLACE
00921       INTEGER            IA, JA, N
00922       COMPLEX            ALPHA
00923 *     ..
00924 *     .. Array Arguments ..
00925       INTEGER            DESCA( * )
00926       COMPLEX            A( * )
00927 *     ..
00928 *
00929 *  Purpose
00930 *  =======
00931 *
00932 *  PCLADOM  adds alpha to the diagonal entries  of  an  n by n submatrix
00933 *  sub( A ) denoting A( IA:IA+N-1, JA:JA+N-1 ).
00934 *
00935 *  Notes
00936 *  =====
00937 *
00938 *  A description  vector  is associated with each 2D block-cyclicly dis-
00939 *  tributed matrix.  This  vector  stores  the  information  required to
00940 *  establish the  mapping  between a  matrix entry and its corresponding
00941 *  process and memory location.
00942 *
00943 *  In  the  following  comments,   the character _  should  be  read  as
00944 *  "of  the  distributed  matrix".  Let  A  be a generic term for any 2D
00945 *  block cyclicly distributed matrix.  Its description vector is DESCA:
00946 *
00947 *  NOTATION         STORED IN       EXPLANATION
00948 *  ---------------- --------------- ------------------------------------
00949 *  DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
00950 *  CTXT_A  (global) DESCA( CTXT_  ) The BLACS context handle, indicating
00951 *                                   the NPROW x NPCOL BLACS process grid
00952 *                                   A  is distributed over.  The context
00953 *                                   itself  is  global,  but  the handle
00954 *                                   (the integer value) may vary.
00955 *  M_A     (global) DESCA( M_     ) The  number of rows in the distribu-
00956 *                                   ted matrix A, M_A >= 0.
00957 *  N_A     (global) DESCA( N_     ) The number of columns in the distri-
00958 *                                   buted matrix A, N_A >= 0.
00959 *  IMB_A   (global) DESCA( IMB_   ) The number of rows of the upper left
00960 *                                   block of the matrix A, IMB_A > 0.
00961 *  INB_A   (global) DESCA( INB_   ) The  number  of columns of the upper
00962 *                                   left   block   of   the   matrix  A,
00963 *                                   INB_A > 0.
00964 *  MB_A    (global) DESCA( MB_    ) The blocking factor used to  distri-
00965 *                                   bute the last  M_A-IMB_A rows of  A,
00966 *                                   MB_A > 0.
00967 *  NB_A    (global) DESCA( NB_    ) The blocking factor used to  distri-
00968 *                                   bute the last  N_A-INB_A  columns of
00969 *                                   A, NB_A > 0.
00970 *  RSRC_A  (global) DESCA( RSRC_  ) The process row over which the first
00971 *                                   row of the matrix  A is distributed,
00972 *                                   NPROW > RSRC_A >= 0.
00973 *  CSRC_A  (global) DESCA( CSRC_  ) The  process  column  over which the
00974 *                                   first  column of  A  is distributed.
00975 *                                   NPCOL > CSRC_A >= 0.
00976 *  LLD_A   (local)  DESCA( LLD_   ) The  leading  dimension of the local
00977 *                                   array  storing  the  local blocks of
00978 *                                   the distributed matrix A,
00979 *                                   IF( Lc( 1, N_A ) > 0 )
00980 *                                      LLD_A >= MAX( 1, Lr( 1, M_A ) )
00981 *                                   ELSE
00982 *                                      LLD_A >= 1.
00983 *
00984 *  Let K be the number of  rows of a matrix A starting at the global in-
00985 *  dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
00986 *  that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
00987 *  receive if these K rows were distributed over NPROW processes.  If  K
00988 *  is the number of columns of a matrix  A  starting at the global index
00989 *  JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number  of co-
00990 *  lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would  receive if
00991 *  these K columns were distributed over NPCOL processes.
00992 *
00993 *  The values of Lr() and Lc() may be determined via a call to the func-
00994 *  tion PB_NUMROC:
00995 *  Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
00996 *  Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
00997 *
00998 *  Arguments
00999 *  =========
01000 *
01001 *  INPLACE (global input) LOGICAL
01002 *          On entry, INPLACE specifies if the matrix should be generated
01003 *          in place or not. If INPLACE is .TRUE., the local random array
01004 *          to be generated  will start in memory at the local memory lo-
01005 *          cation A( 1, 1 ),  otherwise it will start at the local posi-
01006 *          tion induced by IA and JA.
01007 *
01008 *  N       (global input) INTEGER
01009 *          On entry,  N  specifies  the  global  order  of the submatrix
01010 *          sub( A ) to be modified. N must be at least zero.
01011 *
01012 *  ALPHA   (global input) COMPLEX
01013 *          On entry, ALPHA specifies the scalar alpha.
01014 *
01015 *  A       (local input/local output) COMPLEX array
01016 *          On entry, A is an array of dimension (LLD_A, Ka), where Ka is
01017 *          at least Lc( 1, JA+N-1 ).  Before  entry, this array contains
01018 *          the local entries of the matrix A. On exit, the local entries
01019 *          of this array corresponding to the main diagonal of  sub( A )
01020 *          have been updated.
01021 *
01022 *  IA      (global input) INTEGER
01023 *          On entry, IA  specifies A's global row index, which points to
01024 *          the beginning of the submatrix sub( A ).
01025 *
01026 *  JA      (global input) INTEGER
01027 *          On entry, JA  specifies A's global column index, which points
01028 *          to the beginning of the submatrix sub( A ).
01029 *
01030 *  DESCA   (global and local input) INTEGER array
01031 *          On entry, DESCA  is an integer array of dimension DLEN_. This
01032 *          is the array descriptor for the matrix A.
01033 *
01034 *  -- Written on April 1, 1998 by
01035 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
01036 *
01037 *  =====================================================================
01038 *
01039 *     .. Parameters ..
01040       INTEGER            BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
01041      $                   DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
01042      $                   RSRC_
01043       PARAMETER          ( BLOCK_CYCLIC_2D_INB = 2, DLEN_ = 11,
01044      $                   DTYPE_ = 1, CTXT_ = 2, M_ = 3, N_ = 4,
01045      $                   IMB_ = 5, INB_ = 6, MB_ = 7, NB_ = 8,
01046      $                   RSRC_ = 9, CSRC_ = 10, LLD_ = 11 )
01047 *     ..
01048 *     .. Local Scalars ..
01049       LOGICAL            GODOWN, GOLEFT
01050       INTEGER            I, IACOL, IAROW, ICTXT, IIA, IJOFFA, ILOW,
01051      $                   IMB1, IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP,
01052      $                   JJA, JOFFA, JOFFD, LCMT, LCMT00, LDA, LDAP1,
01053      $                   LMBLOC, LNBLOC, LOW, MB, MBLKD, MBLKS, MBLOC,
01054      $                   MRCOL, MRROW, MYCOL, MYROW, NB, NBLKD, NBLKS,
01055      $                   NBLOC, NP, NPCOL, NPROW, NQ, PMB, QNB, UPP
01056       COMPLEX            ATMP
01057 *     ..
01058 *     .. Local Scalars ..
01059       INTEGER            DESCA2( DLEN_ )
01060 *     ..
01061 *     .. External Subroutines ..
01062       EXTERNAL           BLACS_GRIDINFO, PB_AINFOG2L, PB_BINFO,
01063      $                   PB_DESCTRANS
01064 *     ..
01065 *     .. Intrinsic Functions ..
01066       INTRINSIC          ABS, AIMAG, CMPLX, MAX, MIN, REAL
01067 *     ..
01068 *     .. Executable Statements ..
01069 *
01070 *     Convert descriptor
01071 *
01072       CALL PB_DESCTRANS( DESCA, DESCA2 )
01073 *
01074 *     Get grid parameters
01075 *
01076       ICTXT = DESCA2( CTXT_ )
01077       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
01078 *
01079       IF( N.EQ.0 )
01080      $   RETURN
01081 *
01082       CALL PB_AINFOG2L( N, N, IA, JA, DESCA2, NPROW, NPCOL, MYROW,
01083      $                  MYCOL, IMB1, INB1, NP, NQ, IIA, JJA, IAROW,
01084      $                  IACOL, MRROW, MRCOL )
01085 *
01086 *     Decide where the entries shall be stored in memory
01087 *
01088       IF( INPLACE ) THEN
01089          IIA = 1
01090          JJA = 1
01091       END IF
01092 *
01093 *     Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
01094 *     ILOW, LOW, IUPP, and UPP.
01095 *
01096       MB = DESCA2( MB_ )
01097       NB = DESCA2( NB_ )
01098 *
01099       CALL PB_BINFO( 0, NP, NQ, IMB1, INB1, MB, NB, MRROW, MRCOL,
01100      $               LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
01101      $               LNBLOC, ILOW, LOW, IUPP, UPP )
01102 *
01103       IOFFA  = IIA - 1
01104       JOFFA  = JJA - 1
01105       LDA    = DESCA2( LLD_ )
01106       LDAP1  = LDA + 1
01107 *
01108       IF( DESCA2( RSRC_ ).LT.0 ) THEN
01109          PMB = MB
01110       ELSE
01111          PMB = NPROW * MB
01112       END IF
01113       IF( DESCA2( CSRC_ ).LT.0 ) THEN
01114          QNB = NB
01115       ELSE
01116          QNB = NPCOL * NB
01117       END IF
01118 *
01119 *     Handle the first block of rows or columns separately, and update
01120 *     LCMT00, MBLKS and NBLKS.
01121 *
01122       GODOWN = ( LCMT00.GT.IUPP )
01123       GOLEFT = ( LCMT00.LT.ILOW )
01124 *
01125       IF( .NOT.GODOWN .AND. .NOT.GOLEFT ) THEN
01126 *
01127 *        LCMT00 >= ILOW && LCMT00 <= IUPP
01128 *
01129          IF( LCMT00.GE.0 ) THEN
01130             IJOFFA = IOFFA+LCMT00 + ( JOFFA - 1 ) * LDA
01131             DO 10 I = 1, MIN( INBLOC, MAX( 0, IMBLOC - LCMT00 ) )
01132                ATMP = A( IJOFFA + I*LDAP1 )
01133                A( IJOFFA + I*LDAP1 ) = ALPHA +
01134      $                                 CMPLX( ABS( REAL(  ATMP ) ),
01135      $                                        ABS( AIMAG( ATMP ) ) )
01136    10       CONTINUE
01137          ELSE
01138             IJOFFA = IOFFA + ( JOFFA - LCMT00 - 1 ) * LDA
01139             DO 20 I = 1, MIN( IMBLOC, MAX( 0, INBLOC + LCMT00 ) )
01140                ATMP = A( IJOFFA + I*LDAP1 )
01141                A( IJOFFA + I*LDAP1 ) = ALPHA +
01142      $                                 CMPLX( ABS( REAL(  ATMP ) ),
01143      $                                        ABS( AIMAG( ATMP ) ) )
01144    20       CONTINUE
01145          END IF
01146          GOLEFT = ( ( LCMT00 - ( IUPP - UPP + PMB ) ).LT.ILOW )
01147          GODOWN = .NOT.GOLEFT
01148 *
01149       END IF
01150 *
01151       IF( GODOWN ) THEN
01152 *
01153          LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
01154          MBLKS  = MBLKS - 1
01155          IOFFA  = IOFFA + IMBLOC
01156 *
01157    30    CONTINUE
01158          IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
01159             LCMT00 = LCMT00 - PMB
01160             MBLKS  = MBLKS - 1
01161             IOFFA  = IOFFA + MB
01162             GO TO 30
01163          END IF
01164 *
01165          LCMT  = LCMT00
01166          MBLKD = MBLKS
01167          IOFFD = IOFFA
01168 *
01169          MBLOC = MB
01170    40    CONTINUE
01171          IF( MBLKD.GT.0 .AND. LCMT.GE.ILOW ) THEN
01172             IF( MBLKD.EQ.1 )
01173      $         MBLOC = LMBLOC
01174             IF( LCMT.GE.0 ) THEN
01175                IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA
01176                DO 50 I = 1, MIN( INBLOC, MAX( 0, MBLOC - LCMT ) )
01177                   ATMP = A( IJOFFA + I*LDAP1 )
01178                   A( IJOFFA + I*LDAP1 ) = ALPHA +
01179      $                                    CMPLX( ABS( REAL(  ATMP ) ),
01180      $                                           ABS( AIMAG( ATMP ) ) )
01181    50          CONTINUE
01182             ELSE
01183                IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA
01184                DO 60 I = 1, MIN( MBLOC, MAX( 0, INBLOC + LCMT ) )
01185                   ATMP = A( IJOFFA + I*LDAP1 )
01186                   A( IJOFFA + I*LDAP1 ) = ALPHA +
01187      $                                    CMPLX( ABS( REAL(  ATMP ) ),
01188      $                                           ABS( AIMAG( ATMP ) ) )
01189    60          CONTINUE
01190             END IF
01191             LCMT00 = LCMT
01192             LCMT   = LCMT - PMB
01193             MBLKS  = MBLKD
01194             MBLKD  = MBLKD - 1
01195             IOFFA  = IOFFD
01196             IOFFD  = IOFFD + MBLOC
01197             GO TO 40
01198          END IF
01199 *
01200          LCMT00 = LCMT00 + LOW - ILOW + QNB
01201          NBLKS  = NBLKS - 1
01202          JOFFA  = JOFFA + INBLOC
01203 *
01204       ELSE IF( GOLEFT ) THEN
01205 *
01206          LCMT00 = LCMT00 + LOW - ILOW + QNB
01207          NBLKS  = NBLKS - 1
01208          JOFFA  = JOFFA + INBLOC
01209 *
01210    70    CONTINUE
01211          IF( NBLKS.GT.0 .AND. LCMT00.LT.LOW ) THEN
01212             LCMT00 = LCMT00 + QNB
01213             NBLKS  = NBLKS - 1
01214             JOFFA  = JOFFA + NB
01215             GO TO 70
01216          END IF
01217 *
01218          LCMT  = LCMT00
01219          NBLKD = NBLKS
01220          JOFFD = JOFFA
01221 *
01222          NBLOC = NB
01223    80    CONTINUE
01224          IF( NBLKD.GT.0 .AND. LCMT.LE.IUPP ) THEN
01225             IF( NBLKD.EQ.1 )
01226      $         NBLOC = LNBLOC
01227             IF( LCMT.GE.0 ) THEN
01228                IJOFFA = IOFFA + LCMT + ( JOFFD - 1 ) * LDA
01229                DO 90 I = 1, MIN( NBLOC, MAX( 0, IMBLOC - LCMT ) )
01230                   ATMP = A( IJOFFA + I*LDAP1 )
01231                   A( IJOFFA + I*LDAP1 ) = ALPHA +
01232      $                                    CMPLX( ABS( REAL(  ATMP ) ),
01233      $                                           ABS( AIMAG( ATMP ) ) )
01234    90          CONTINUE
01235             ELSE
01236                IJOFFA = IOFFA + ( JOFFD - LCMT - 1 ) * LDA
01237                DO 100 I = 1, MIN( IMBLOC, MAX( 0, NBLOC + LCMT ) )
01238                   ATMP = A( IJOFFA + I*LDAP1 )
01239                   A( IJOFFA + I*LDAP1 ) = ALPHA +
01240      $                                    CMPLX( ABS( REAL(  ATMP ) ),
01241      $                                           ABS( AIMAG( ATMP ) ) )
01242   100          CONTINUE
01243             END IF
01244             LCMT00 = LCMT
01245             LCMT   = LCMT + QNB
01246             NBLKS  = NBLKD
01247             NBLKD  = NBLKD - 1
01248             JOFFA  = JOFFD
01249             JOFFD  = JOFFD + NBLOC
01250             GO TO 80
01251          END IF
01252 *
01253          LCMT00 = LCMT00 - ( IUPP - UPP + PMB )
01254          MBLKS  = MBLKS - 1
01255          IOFFA  = IOFFA + IMBLOC
01256 *
01257       END IF
01258 *
01259       NBLOC = NB
01260   110 CONTINUE
01261       IF( NBLKS.GT.0 ) THEN
01262          IF( NBLKS.EQ.1 )
01263      $      NBLOC = LNBLOC
01264   120    CONTINUE
01265          IF( MBLKS.GT.0 .AND. LCMT00.GT.UPP ) THEN
01266             LCMT00 = LCMT00 - PMB
01267             MBLKS  = MBLKS - 1
01268             IOFFA  = IOFFA + MB
01269             GO TO 120
01270          END IF
01271 *
01272          LCMT  = LCMT00
01273          MBLKD = MBLKS
01274          IOFFD = IOFFA
01275 *
01276          MBLOC = MB
01277   130    CONTINUE
01278          IF( MBLKD.GT.0 .AND. LCMT.GE.LOW ) THEN
01279             IF( MBLKD.EQ.1 )
01280      $         MBLOC = LMBLOC
01281             IF( LCMT.GE.0 ) THEN
01282                IJOFFA = IOFFD + LCMT + ( JOFFA - 1 ) * LDA
01283                DO 140 I = 1, MIN( NBLOC, MAX( 0, MBLOC - LCMT ) )
01284                   ATMP = A( IJOFFA + I*LDAP1 )
01285                   A( IJOFFA + I*LDAP1 ) = ALPHA +
01286      $                                    CMPLX( ABS( REAL(  ATMP ) ),
01287      $                                           ABS( AIMAG( ATMP ) ) )
01288   140          CONTINUE
01289             ELSE
01290                IJOFFA = IOFFD + ( JOFFA - LCMT - 1 ) * LDA
01291                DO 150 I = 1, MIN( MBLOC, MAX( 0, NBLOC + LCMT ) )
01292                   ATMP = A( IJOFFA + I*LDAP1 )
01293                   A( IJOFFA + I*LDAP1 ) = ALPHA +
01294      $                                    CMPLX( ABS( REAL(  ATMP ) ),
01295      $                                           ABS( AIMAG( ATMP ) ) )
01296   150          CONTINUE
01297             END IF
01298             LCMT00 = LCMT
01299             LCMT   = LCMT - PMB
01300             MBLKS  = MBLKD
01301             MBLKD  = MBLKD - 1
01302             IOFFA  = IOFFD
01303             IOFFD  = IOFFD + MBLOC
01304             GO TO 130
01305          END IF
01306 *
01307          LCMT00 = LCMT00 + QNB
01308          NBLKS  = NBLKS - 1
01309          JOFFA  = JOFFA + NBLOC
01310          GO TO 110
01311 *
01312       END IF
01313 *
01314       RETURN
01315 *
01316 *     End of PCLADOM
01317 *
01318       END
01319       SUBROUTINE PB_CLASCAL( UPLO, M, N, IOFFD, ALPHA, A, LDA )
01320 *
01321 *  -- PBLAS test routine (version 2.0) --
01322 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
01323 *     and University of California, Berkeley.
01324 *     April 1, 1998
01325 *
01326 *     .. Scalar Arguments ..
01327       CHARACTER*1        UPLO
01328       INTEGER            IOFFD, LDA, M, N
01329       COMPLEX            ALPHA
01330 *     ..
01331 *     .. Array Arguments ..
01332       COMPLEX            A( LDA, * )
01333 *     ..
01334 *
01335 *  Purpose
01336 *  =======
01337 *
01338 *  PB_CLASCAL scales a two-dimensional array A by the scalar alpha.
01339 *
01340 *  Arguments
01341 *  =========
01342 *
01343 *  UPLO    (input) CHARACTER*1
01344 *          On entry,  UPLO  specifies  which trapezoidal part of the ar-
01345 *          ray A is to be scaled as follows:
01346 *             = 'L' or 'l':          the lower trapezoid of A is scaled,
01347 *             = 'U' or 'u':          the upper trapezoid of A is scaled,
01348 *             = 'D' or 'd':       diagonal specified by IOFFD is scaled,
01349 *             Otherwise:                   all of the array A is scaled.
01350 *
01351 *  M       (input) INTEGER
01352 *          On entry,  M  specifies the number of rows of the array A.  M
01353 *          must be at least zero.
01354 *
01355 *  N       (input) INTEGER
01356 *          On entry,  N  specifies the number of columns of the array A.
01357 *          N must be at least zero.
01358 *
01359 *  IOFFD   (input) INTEGER
01360 *          On entry, IOFFD specifies the position of the offdiagonal de-
01361 *          limiting the upper and lower trapezoidal part of A as follows
01362 *          (see the notes below):
01363 *
01364 *             IOFFD = 0  specifies the main diagonal A( i, i ),
01365 *                        with i = 1 ... MIN( M, N ),
01366 *             IOFFD > 0  specifies the subdiagonal   A( i+IOFFD, i ),
01367 *                        with i = 1 ... MIN( M-IOFFD, N ),
01368 *             IOFFD < 0  specifies the superdiagonal A( i, i-IOFFD ),
01369 *                        with i = 1 ... MIN( M, N+IOFFD ).
01370 *
01371 *  ALPHA   (input) COMPLEX
01372 *          On entry, ALPHA specifies the scalar alpha.
01373 *
01374 *  A       (input/output) COMPLEX array
01375 *          On entry, A is an array of dimension  (LDA,N).  Before  entry
01376 *          with  UPLO = 'U' or 'u', the leading m by n part of the array
01377 *          A must contain the upper trapezoidal  part  of the matrix  as
01378 *          specified by  IOFFD to be scaled, and the strictly lower tra-
01379 *          pezoidal part of A is not referenced; When UPLO = 'L' or 'l',
01380 *          the leading m by n part of the array A must contain the lower
01381 *          trapezoidal  part  of  the matrix as specified by IOFFD to be
01382 *          scaled,  and  the strictly upper trapezoidal part of A is not
01383 *          referenced. On exit, the entries of the  trapezoid part of  A
01384 *          determined by UPLO and IOFFD are scaled.
01385 *
01386 *  LDA     (input) INTEGER
01387 *          On entry, LDA specifies the leading dimension of the array A.
01388 *          LDA must be at least max( 1, M ).
01389 *
01390 *  Notes
01391 *  =====
01392 *                           N                                    N
01393 *             ----------------------------                  -----------
01394 *            |       d                    |                |           |
01395 *          M |         d        'U'       |                |      'U'  |
01396 *            |  'L'     'D'               |                |d          |
01397 *            |             d              |              M |  d        |
01398 *             ----------------------------                 |   'D'     |
01399 *                                                          |      d    |
01400 *              IOFFD < 0                                   | 'L'    d  |
01401 *                                                          |          d|
01402 *                  N                                       |           |
01403 *             -----------                                   -----------
01404 *            |    d   'U'|
01405 *            |      d    |                                   IOFFD > 0
01406 *          M |       'D' |
01407 *            |          d|                              N
01408 *            |  'L'      |                 ----------------------------
01409 *            |           |                |          'U'               |
01410 *            |           |                |d                           |
01411 *            |           |                | 'D'                        |
01412 *            |           |                |    d                       |
01413 *            |           |                |'L'   d                     |
01414 *             -----------                  ----------------------------
01415 *
01416 *  -- Written on April 1, 1998 by
01417 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
01418 *
01419 *  =====================================================================
01420 *
01421 *     .. Local Scalars ..
01422       INTEGER            I, J, JTMP, MN
01423 *     ..
01424 *     .. External Functions ..
01425       LOGICAL            LSAME
01426       EXTERNAL           LSAME
01427 *     ..
01428 *     .. Intrinsic Functions ..
01429       INTRINSIC          MAX, MIN
01430 *     ..
01431 *     .. Executable Statements ..
01432 *
01433 *     Quick return if possible
01434 *
01435       IF( M.LE.0 .OR. N.LE.0 )
01436      $   RETURN
01437 *
01438 *     Start the operations
01439 *
01440       IF( LSAME( UPLO, 'L' ) ) THEN
01441 *
01442 *        Scales the lower triangular part of the array by ALPHA.
01443 *
01444          MN = MAX( 0, -IOFFD )
01445          DO 20 J = 1, MIN( MN, N )
01446             DO 10 I = 1, M
01447                A( I, J ) = ALPHA * A( I, J )
01448    10       CONTINUE
01449    20    CONTINUE
01450          DO 40 J = MN + 1, MIN( M - IOFFD, N )
01451             DO 30 I = J + IOFFD, M
01452                A( I, J ) = ALPHA * A( I, J )
01453    30       CONTINUE
01454    40    CONTINUE
01455 *
01456       ELSE IF( LSAME( UPLO, 'U' ) ) THEN
01457 *
01458 *        Scales the upper triangular part of the array by ALPHA.
01459 *
01460          MN = MIN( M - IOFFD, N )
01461          DO 60 J = MAX( 0, -IOFFD ) + 1, MN
01462             DO 50 I = 1, J + IOFFD
01463                A( I, J ) = ALPHA * A( I, J )
01464    50       CONTINUE
01465    60    CONTINUE
01466          DO 80 J = MAX( 0, MN ) + 1, N
01467             DO 70 I = 1, M
01468                A( I, J ) = ALPHA * A( I, J )
01469    70       CONTINUE
01470    80    CONTINUE
01471 *
01472       ELSE IF( LSAME( UPLO, 'D' ) ) THEN
01473 *
01474 *        Scales the diagonal entries by ALPHA.
01475 *
01476          DO 90 J = MAX( 0, -IOFFD ) + 1, MIN( M - IOFFD, N )
01477             JTMP = J + IOFFD
01478             A( JTMP, J ) = ALPHA * A( JTMP, J )
01479    90    CONTINUE
01480 *
01481       ELSE
01482 *
01483 *        Scales the entire array by ALPHA.
01484 *
01485          DO 110 J = 1, N
01486             DO 100 I = 1, M
01487                A( I, J ) = ALPHA * A( I, J )
01488   100       CONTINUE
01489   110    CONTINUE
01490 *
01491       END IF
01492 *
01493       RETURN
01494 *
01495 *     End of PB_CLASCAL
01496 *
01497       END
01498       SUBROUTINE PB_CLAGEN( UPLO, AFORM, A, LDA, LCMT00, IRAN, MBLKS,
01499      $                      IMBLOC, MB, LMBLOC, NBLKS, INBLOC, NB,
01500      $                      LNBLOC, JMP, IMULADD )
01501 *
01502 *  -- PBLAS test routine (version 2.0) --
01503 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
01504 *     and University of California, Berkeley.
01505 *     April 1, 1998
01506 *
01507 *     .. Scalar Arguments ..
01508       CHARACTER*1        UPLO, AFORM
01509       INTEGER            IMBLOC, INBLOC, LCMT00, LDA, LMBLOC, LNBLOC,
01510      $                   MB, MBLKS, NB, NBLKS
01511 *     ..
01512 *     .. Array Arguments ..
01513       INTEGER            IMULADD( 4, * ), IRAN( * ), JMP( * )
01514       COMPLEX            A( LDA, * )
01515 *     ..
01516 *
01517 *  Purpose
01518 *  =======
01519 *
01520 *  PB_CLAGEN locally initializes an array A.
01521 *
01522 *  Arguments
01523 *  =========
01524 *
01525 *  UPLO    (global input) CHARACTER*1
01526 *          On entry, UPLO  specifies whether the lower (UPLO='L') trape-
01527 *          zoidal part or the upper (UPLO='U') trapezoidal part is to be
01528 *          generated  when  the  matrix  to be generated is symmetric or
01529 *          Hermitian. For  all  the  other values of AFORM, the value of
01530 *          this input argument is ignored.
01531 *
01532 *  AFORM   (global input) CHARACTER*1
01533 *          On entry, AFORM specifies the type of submatrix to be genera-
01534 *          ted as follows:
01535 *             AFORM = 'S', sub( A ) is a symmetric matrix,
01536 *             AFORM = 'H', sub( A ) is a Hermitian matrix,
01537 *             AFORM = 'T', sub( A ) is overrwritten  with  the transpose
01538 *                          of what would normally be generated,
01539 *             AFORM = 'C', sub( A ) is overwritten  with  the  conjugate
01540 *                          transpose  of  what would normally be genera-
01541 *                          ted.
01542 *             AFORM = 'N', a random submatrix is generated.
01543 *
01544 *  A       (local output) COMPLEX array
01545 *          On entry,  A  is  an array of dimension (LLD_A, *).  On exit,
01546 *          this array contains the local entries of the randomly genera-
01547 *          ted submatrix sub( A ).
01548 *
01549 *  LDA     (local input) INTEGER
01550 *          On entry,  LDA  specifies  the local leading dimension of the
01551 *          array A. LDA must be at least one.
01552 *
01553 *  LCMT00  (global input) INTEGER
01554 *          On entry, LCMT00 is the LCM value specifying the off-diagonal
01555 *          of the underlying matrix of interest. LCMT00=0 specifies  the
01556 *          main diagonal, LCMT00 > 0 specifies a subdiagonal, LCMT00 < 0
01557 *          specifies superdiagonals.
01558 *
01559 *  IRAN    (local input) INTEGER array
01560 *          On entry, IRAN  is an array of dimension 2 containing respec-
01561 *          tively the 16-lower and 16-higher bits of the encoding of the
01562 *          entry of  the  random  sequence  corresponding locally to the
01563 *          first local array entry to generate. Usually,  this  array is
01564 *          computed by PB_SETLOCRAN.
01565 *
01566 *  MBLKS   (local input) INTEGER
01567 *          On entry, MBLKS specifies the local number of blocks of rows.
01568 *          MBLKS is at least zero.
01569 *
01570 *  IMBLOC  (local input) INTEGER
01571 *          On entry, IMBLOC specifies  the  number of rows (size) of the
01572 *          local uppest  blocks. IMBLOC is at least zero.
01573 *
01574 *  MB      (global input) INTEGER
01575 *          On entry, MB  specifies the blocking factor used to partition
01576 *          the rows of the matrix.  MB  must be at least one.
01577 *
01578 *  LMBLOC  (local input) INTEGER
01579 *          On entry, LMBLOC specifies the number of  rows  (size) of the
01580 *          local lowest blocks. LMBLOC is at least zero.
01581 *
01582 *  NBLKS   (local input) INTEGER
01583 *          On entry,  NBLKS  specifies the local number of blocks of co-
01584 *          lumns. NBLKS is at least zero.
01585 *
01586 *  INBLOC  (local input) INTEGER
01587 *          On entry,  INBLOC  specifies the number of columns (size)  of
01588 *          the local leftmost blocks. INBLOC is at least zero.
01589 *
01590 *  NB      (global input) INTEGER
01591 *          On entry, NB  specifies the blocking factor used to partition
01592 *          the the columns of the matrix.  NB  must be at least one.
01593 *
01594 *  LNBLOC  (local input) INTEGER
01595 *          On entry,  LNBLOC  specifies  the number of columns (size) of
01596 *          the local rightmost blocks. LNBLOC is at least zero.
01597 *
01598 *  JMP     (local input) INTEGER array
01599 *          On entry, JMP is an array of dimension JMP_LEN containing the
01600 *          different jump values used by the random matrix generator.
01601 *
01602 *  IMULADD (local input) INTEGER array
01603 *          On entry, IMULADD is an array of dimension (4, JMP_LEN).  The
01604 *          jth  column  of this array contains the encoded initial cons-
01605 *          tants a_j and c_j to  jump  from X( n ) to  X( n + JMP( j ) )
01606 *          (= a_j * X( n ) + c_j) in the random sequence. IMULADD(1:2,j)
01607 *          contains respectively the 16-lower and 16-higher bits of  the
01608 *          constant a_j, and IMULADD(3:4,j)  contains  the 16-lower  and
01609 *          16-higher bits of the constant c_j.
01610 *
01611 *  -- Written on April 1, 1998 by
01612 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
01613 *
01614 *  =====================================================================
01615 *
01616 *     .. Parameters ..
01617       INTEGER            JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
01618      $                   JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
01619      $                   JMP_NQINBLOC, JMP_NQNB, JMP_ROW
01620       PARAMETER          ( JMP_1 = 1, JMP_ROW = 2, JMP_COL = 3,
01621      $                   JMP_MB = 4, JMP_IMBV = 5, JMP_NPMB = 6,
01622      $                   JMP_NPIMBLOC = 7, JMP_NB = 8, JMP_INBV = 9,
01623      $                   JMP_NQNB = 10, JMP_NQINBLOC = 11,
01624      $                   JMP_LEN = 11 )
01625       REAL               ZERO
01626       PARAMETER          ( ZERO = 0.0E+0 )
01627 *     ..
01628 *     .. Local Scalars ..
01629       INTEGER            I, IB, IBLK, II, IK, ITMP, JB, JBLK, JJ, JK,
01630      $                   JTMP, LCMTC, LCMTR, LOW, MNB, UPP
01631       COMPLEX            DUMMY
01632 *     ..
01633 *     .. Local Arrays ..
01634       INTEGER            IB0( 2 ), IB1( 2 ), IB2( 2 ), IB3( 2 )
01635 *     ..
01636 *     .. External Subroutines ..
01637       EXTERNAL           PB_JUMPIT
01638 *     ..
01639 *     .. External Functions ..
01640       LOGICAL            LSAME
01641       REAL               PB_SRAND
01642       EXTERNAL           LSAME, PB_SRAND
01643 *     ..
01644 *     .. Intrinsic Functions ..
01645       INTRINSIC          CMPLX, MAX, MIN, REAL
01646 *     ..
01647 *     .. Executable Statements ..
01648 *
01649       DO 10 I = 1, 2
01650          IB1( I ) = IRAN( I )
01651          IB2( I ) = IRAN( I )
01652          IB3( I ) = IRAN( I )
01653    10 CONTINUE
01654 *
01655       IF( LSAME( AFORM, 'N' ) ) THEN
01656 *
01657 *        Generate random matrix
01658 *
01659          JJ = 1
01660 *
01661          DO 50 JBLK = 1, NBLKS
01662 *
01663             IF( JBLK.EQ.1 ) THEN
01664                JB = INBLOC
01665             ELSE IF( JBLK.EQ.NBLKS ) THEN
01666                JB = LNBLOC
01667             ELSE
01668                JB = NB
01669             END IF
01670 *
01671             DO 40 JK = JJ, JJ + JB - 1
01672 *
01673                II = 1
01674 *
01675                DO 30 IBLK = 1, MBLKS
01676 *
01677                   IF( IBLK.EQ.1 ) THEN
01678                      IB = IMBLOC
01679                   ELSE IF( IBLK.EQ.MBLKS ) THEN
01680                      IB = LMBLOC
01681                   ELSE
01682                      IB = MB
01683                   END IF
01684 *
01685 *                 Blocks are IB by JB
01686 *
01687                   DO 20 IK = II, II + IB - 1
01688                      A( IK, JK ) = CMPLX( PB_SRAND( 0 ), PB_SRAND( 0 ) )
01689    20             CONTINUE
01690 *
01691                   II = II + IB
01692 *
01693                   IF( IBLK.EQ.1 ) THEN
01694 *
01695 *                    Jump IMBLOC + ( NPROW - 1 ) * MB rows
01696 *
01697                      CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1,
01698      $                               IB0 )
01699 *
01700                   ELSE
01701 *
01702 *                    Jump NPROW * MB rows
01703 *
01704                      CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1, IB0 )
01705 *
01706                   END IF
01707 *
01708                   IB1( 1 ) = IB0( 1 )
01709                   IB1( 2 ) = IB0( 2 )
01710 *
01711    30          CONTINUE
01712 *
01713 *              Jump one column
01714 *
01715                CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 )
01716 *
01717                IB1( 1 ) = IB0( 1 )
01718                IB1( 2 ) = IB0( 2 )
01719                IB2( 1 ) = IB0( 1 )
01720                IB2( 2 ) = IB0( 2 )
01721 *
01722    40       CONTINUE
01723 *
01724             JJ = JJ + JB
01725 *
01726             IF( JBLK.EQ.1 ) THEN
01727 *
01728 *              Jump INBLOC + ( NPCOL - 1 ) * NB columns
01729 *
01730                CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 )
01731 *
01732             ELSE
01733 *
01734 *              Jump NPCOL * NB columns
01735 *
01736                CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 )
01737 *
01738             END IF
01739 *
01740             IB1( 1 ) = IB0( 1 )
01741             IB1( 2 ) = IB0( 2 )
01742             IB2( 1 ) = IB0( 1 )
01743             IB2( 2 ) = IB0( 2 )
01744             IB3( 1 ) = IB0( 1 )
01745             IB3( 2 ) = IB0( 2 )
01746 *
01747    50    CONTINUE
01748 *
01749       ELSE IF( LSAME( AFORM, 'T' ) ) THEN
01750 *
01751 *        Generate the transpose of the matrix that would be normally
01752 *        generated.
01753 *
01754          II = 1
01755 *
01756          DO 90 IBLK = 1, MBLKS
01757 *
01758             IF( IBLK.EQ.1 ) THEN
01759                IB = IMBLOC
01760             ELSE IF( IBLK.EQ.MBLKS ) THEN
01761                IB = LMBLOC
01762             ELSE
01763                IB = MB
01764             END IF
01765 *
01766             DO 80 IK = II, II + IB - 1
01767 *
01768                JJ = 1
01769 *
01770                DO 70 JBLK = 1, NBLKS
01771 *
01772                   IF( JBLK.EQ.1 ) THEN
01773                      JB = INBLOC
01774                   ELSE IF( JBLK.EQ.NBLKS ) THEN
01775                      JB = LNBLOC
01776                   ELSE
01777                      JB = NB
01778                   END IF
01779 *
01780 *                 Blocks are IB by JB
01781 *
01782                   DO 60 JK = JJ, JJ + JB - 1
01783                      A( IK, JK ) = CMPLX( PB_SRAND( 0 ), PB_SRAND( 0 ) )
01784    60             CONTINUE
01785 *
01786                   JJ = JJ + JB
01787 *
01788                   IF( JBLK.EQ.1 ) THEN
01789 *
01790 *                    Jump INBLOC + ( NPCOL - 1 ) * NB columns
01791 *
01792                      CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1,
01793      $                               IB0 )
01794 *
01795                   ELSE
01796 *
01797 *                    Jump NPCOL * NB columns
01798 *
01799                      CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1, IB0 )
01800 *
01801                   END IF
01802 *
01803                   IB1( 1 ) = IB0( 1 )
01804                   IB1( 2 ) = IB0( 2 )
01805 *
01806    70          CONTINUE
01807 *
01808 *              Jump one row
01809 *
01810                CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 )
01811 *
01812                IB1( 1 ) = IB0( 1 )
01813                IB1( 2 ) = IB0( 2 )
01814                IB2( 1 ) = IB0( 1 )
01815                IB2( 2 ) = IB0( 2 )
01816 *
01817    80       CONTINUE
01818 *
01819             II = II + IB
01820 *
01821             IF( IBLK.EQ.1 ) THEN
01822 *
01823 *              Jump IMBLOC + ( NPROW - 1 ) * MB rows
01824 *
01825                CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 )
01826 *
01827             ELSE
01828 *
01829 *              Jump NPROW * MB rows
01830 *
01831                CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 )
01832 *
01833             END IF
01834 *
01835             IB1( 1 ) = IB0( 1 )
01836             IB1( 2 ) = IB0( 2 )
01837             IB2( 1 ) = IB0( 1 )
01838             IB2( 2 ) = IB0( 2 )
01839             IB3( 1 ) = IB0( 1 )
01840             IB3( 2 ) = IB0( 2 )
01841 *
01842    90    CONTINUE
01843 *
01844       ELSE IF( LSAME( AFORM, 'S' ) ) THEN
01845 *
01846 *        Generate a symmetric matrix
01847 *
01848          IF( LSAME( UPLO, 'L' ) ) THEN
01849 *
01850 *           generate lower trapezoidal part
01851 *
01852             JJ = 1
01853             LCMTC = LCMT00
01854 *
01855             DO 170 JBLK = 1, NBLKS
01856 *
01857                IF( JBLK.EQ.1 ) THEN
01858                   JB  = INBLOC
01859                   LOW = 1 - INBLOC
01860                ELSE IF( JBLK.EQ.NBLKS ) THEN
01861                   JB = LNBLOC
01862                   LOW = 1 - NB
01863                ELSE
01864                   JB  = NB
01865                   LOW = 1 - NB
01866                END IF
01867 *
01868                DO 160 JK = JJ, JJ + JB - 1
01869 *
01870                   II = 1
01871                   LCMTR = LCMTC
01872 *
01873                   DO 150 IBLK = 1, MBLKS
01874 *
01875                      IF( IBLK.EQ.1 ) THEN
01876                         IB  = IMBLOC
01877                         UPP = IMBLOC - 1
01878                      ELSE IF( IBLK.EQ.MBLKS ) THEN
01879                         IB  = LMBLOC
01880                         UPP = MB - 1
01881                      ELSE
01882                         IB  = MB
01883                         UPP = MB - 1
01884                      END IF
01885 *
01886 *                    Blocks are IB by JB
01887 *
01888                      IF( LCMTR.GT.UPP ) THEN
01889 *
01890                         DO 100 IK = II, II + IB - 1
01891                            DUMMY = CMPLX( PB_SRAND( 0 ),
01892      $                                    PB_SRAND( 0 ) )
01893   100                   CONTINUE
01894 *
01895                      ELSE IF( LCMTR.GE.LOW ) THEN
01896 *
01897                         JTMP = JK - JJ + 1
01898                         MNB  = MAX( 0, -LCMTR )
01899 *
01900                         IF( JTMP.LE.MIN( MNB, JB ) ) THEN
01901 *
01902                            DO 110 IK = II, II + IB - 1
01903                               A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
01904      $                                             PB_SRAND( 0 ) )
01905   110                      CONTINUE
01906 *
01907                         ELSE IF( ( JTMP.GE.( MNB + 1 )         ) .AND.
01908      $                           ( JTMP.LE.MIN( IB-LCMTR, JB ) ) ) THEN
01909 *
01910                            ITMP = II + JTMP + LCMTR - 1
01911 *
01912                            DO 120 IK = II, ITMP - 1
01913                               DUMMY = CMPLX( PB_SRAND( 0 ),
01914      $                                       PB_SRAND( 0 ) )
01915   120                      CONTINUE
01916 *
01917                            DO 130 IK = ITMP, II + IB - 1
01918                               A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
01919      $                                             PB_SRAND( 0 ) )
01920   130                      CONTINUE
01921 *
01922                         END IF
01923 *
01924                      ELSE
01925 *
01926                         DO 140 IK = II, II + IB - 1
01927                            A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
01928      $                                          PB_SRAND( 0 ) )
01929   140                   CONTINUE
01930 *
01931                      END IF
01932 *
01933                      II = II + IB
01934 *
01935                      IF( IBLK.EQ.1 ) THEN
01936 *
01937 *                       Jump IMBLOC + ( NPROW - 1 ) * MB rows
01938 *
01939                         LCMTR = LCMTR - JMP( JMP_NPIMBLOC )
01940                         CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1,
01941      $                                  IB0 )
01942 *
01943                      ELSE
01944 *
01945 *                       Jump NPROW * MB rows
01946 *
01947                         LCMTR = LCMTR - JMP( JMP_NPMB )
01948                         CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1,
01949      $                                  IB0 )
01950 *
01951                      END IF
01952 *
01953                      IB1( 1 ) = IB0( 1 )
01954                      IB1( 2 ) = IB0( 2 )
01955 *
01956   150             CONTINUE
01957 *
01958 *                 Jump one column
01959 *
01960                   CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 )
01961 *
01962                   IB1( 1 ) = IB0( 1 )
01963                   IB1( 2 ) = IB0( 2 )
01964                   IB2( 1 ) = IB0( 1 )
01965                   IB2( 2 ) = IB0( 2 )
01966 *
01967   160          CONTINUE
01968 *
01969                JJ = JJ + JB
01970 *
01971                IF( JBLK.EQ.1 ) THEN
01972 *
01973 *                 Jump INBLOC + ( NPCOL - 1 ) * NB columns
01974 *
01975                   LCMTC = LCMTC + JMP( JMP_NQINBLOC )
01976                   CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 )
01977 *
01978                ELSE
01979 *
01980 *                 Jump NPCOL * NB columns
01981 *
01982                   LCMTC = LCMTC + JMP( JMP_NQNB )
01983                   CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 )
01984 *
01985                END IF
01986 *
01987                IB1( 1 ) = IB0( 1 )
01988                IB1( 2 ) = IB0( 2 )
01989                IB2( 1 ) = IB0( 1 )
01990                IB2( 2 ) = IB0( 2 )
01991                IB3( 1 ) = IB0( 1 )
01992                IB3( 2 ) = IB0( 2 )
01993 *
01994   170       CONTINUE
01995 *
01996          ELSE
01997 *
01998 *           generate upper trapezoidal part
01999 *
02000             II = 1
02001             LCMTR = LCMT00
02002 *
02003             DO 250 IBLK = 1, MBLKS
02004 *
02005                IF( IBLK.EQ.1 ) THEN
02006                   IB  = IMBLOC
02007                   UPP = IMBLOC - 1
02008                ELSE IF( IBLK.EQ.MBLKS ) THEN
02009                   IB  = LMBLOC
02010                   UPP = MB - 1
02011                ELSE
02012                   IB  = MB
02013                   UPP = MB - 1
02014                END IF
02015 *
02016                DO 240 IK = II, II + IB - 1
02017 *
02018                   JJ = 1
02019                   LCMTC = LCMTR
02020 *
02021                   DO 230 JBLK = 1, NBLKS
02022 *
02023                      IF( JBLK.EQ.1 ) THEN
02024                         JB  = INBLOC
02025                         LOW = 1 - INBLOC
02026                      ELSE IF( JBLK.EQ.NBLKS ) THEN
02027                         JB  = LNBLOC
02028                         LOW = 1 - NB
02029                      ELSE
02030                         JB  = NB
02031                         LOW = 1 - NB
02032                      END IF
02033 *
02034 *                    Blocks are IB by JB
02035 *
02036                      IF( LCMTC.LT.LOW ) THEN
02037 *
02038                         DO 180 JK = JJ, JJ + JB - 1
02039                            DUMMY = CMPLX( PB_SRAND( 0 ), PB_SRAND( 0 ) )
02040   180                   CONTINUE
02041 *
02042                      ELSE IF( LCMTC.LE.UPP ) THEN
02043 *
02044                         ITMP = IK - II + 1
02045                         MNB  = MAX( 0, LCMTC )
02046 *
02047                         IF( ITMP.LE.MIN( MNB, IB ) ) THEN
02048 *
02049                            DO 190 JK = JJ, JJ + JB - 1
02050                               A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
02051      $                                             PB_SRAND( 0 ) )
02052   190                      CONTINUE
02053 *
02054                         ELSE IF( ( ITMP.GE.( MNB + 1 )         ) .AND.
02055      $                           ( ITMP.LE.MIN( JB+LCMTC, IB ) ) ) THEN
02056 *
02057                            JTMP = JJ + ITMP - LCMTC - 1
02058 *
02059                            DO 200 JK = JJ, JTMP - 1
02060                               DUMMY = CMPLX( PB_SRAND( 0 ),
02061      $                                       PB_SRAND( 0 ) )
02062   200                      CONTINUE
02063 *
02064                            DO 210 JK = JTMP, JJ + JB - 1
02065                               A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
02066      $                                             PB_SRAND( 0 ) )
02067   210                      CONTINUE
02068 *
02069                         END IF
02070 *
02071                      ELSE
02072 *
02073                         DO 220 JK = JJ, JJ + JB - 1
02074                            A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
02075      $                                          PB_SRAND( 0 ) )
02076   220                   CONTINUE
02077 *
02078                      END IF
02079 *
02080                      JJ = JJ + JB
02081 *
02082                      IF( JBLK.EQ.1 ) THEN
02083 *
02084 *                       Jump INBLOC + ( NPCOL - 1 ) * NB columns
02085 *
02086                         LCMTC = LCMTC + JMP( JMP_NQINBLOC )
02087                         CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1,
02088      $                                  IB0 )
02089 *
02090                      ELSE
02091 *
02092 *                       Jump NPCOL * NB columns
02093 *
02094                         LCMTC = LCMTC + JMP( JMP_NQNB )
02095                         CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1,
02096      $                                  IB0 )
02097 *
02098                      END IF
02099 *
02100                      IB1( 1 ) = IB0( 1 )
02101                      IB1( 2 ) = IB0( 2 )
02102 *
02103   230             CONTINUE
02104 *
02105 *                 Jump one row
02106 *
02107                   CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 )
02108 *
02109                   IB1( 1 ) = IB0( 1 )
02110                   IB1( 2 ) = IB0( 2 )
02111                   IB2( 1 ) = IB0( 1 )
02112                   IB2( 2 ) = IB0( 2 )
02113 *
02114   240          CONTINUE
02115 *
02116                II = II + IB
02117 *
02118                IF( IBLK.EQ.1 ) THEN
02119 *
02120 *                 Jump IMBLOC + ( NPROW - 1 ) * MB rows
02121 *
02122                   LCMTR = LCMTR - JMP( JMP_NPIMBLOC )
02123                   CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 )
02124 *
02125                ELSE
02126 *
02127 *                 Jump NPROW * MB rows
02128 *
02129                   LCMTR = LCMTR - JMP( JMP_NPMB )
02130                   CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 )
02131 *
02132                END IF
02133 *
02134                IB1( 1 ) = IB0( 1 )
02135                IB1( 2 ) = IB0( 2 )
02136                IB2( 1 ) = IB0( 1 )
02137                IB2( 2 ) = IB0( 2 )
02138                IB3( 1 ) = IB0( 1 )
02139                IB3( 2 ) = IB0( 2 )
02140 *
02141   250       CONTINUE
02142 *
02143          END IF
02144 *
02145       ELSE IF( LSAME( AFORM, 'C' ) ) THEN
02146 *
02147 *        Generate the conjugate transpose of the matrix that would be
02148 *        normally generated.
02149 *
02150          II = 1
02151 *
02152          DO 290 IBLK = 1, MBLKS
02153 *
02154             IF( IBLK.EQ.1 ) THEN
02155                IB = IMBLOC
02156             ELSE IF( IBLK.EQ.MBLKS ) THEN
02157                IB = LMBLOC
02158             ELSE
02159                IB = MB
02160             END IF
02161 *
02162             DO 280 IK = II, II + IB - 1
02163 *
02164                JJ = 1
02165 *
02166                DO 270 JBLK = 1, NBLKS
02167 *
02168                   IF( JBLK.EQ.1 ) THEN
02169                      JB = INBLOC
02170                   ELSE IF( JBLK.EQ.NBLKS ) THEN
02171                      JB = LNBLOC
02172                   ELSE
02173                      JB = NB
02174                   END IF
02175 *
02176 *                 Blocks are IB by JB
02177 *
02178                   DO 260 JK = JJ, JJ + JB - 1
02179                      A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
02180      $                                   -PB_SRAND( 0 ) )
02181   260             CONTINUE
02182 *
02183                   JJ = JJ + JB
02184 *
02185                   IF( JBLK.EQ.1 ) THEN
02186 *
02187 *                    Jump INBLOC + ( NPCOL - 1 ) * NB columns
02188 *
02189                      CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1,
02190      $                               IB0 )
02191 *
02192                   ELSE
02193 *
02194 *                    Jump NPCOL * NB columns
02195 *
02196                      CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1,
02197      $                               IB0 )
02198 *
02199                   END IF
02200 *
02201                   IB1( 1 ) = IB0( 1 )
02202                   IB1( 2 ) = IB0( 2 )
02203 *
02204   270          CONTINUE
02205 *
02206 *              Jump one row
02207 *
02208                CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 )
02209 *
02210                IB1( 1 ) = IB0( 1 )
02211                IB1( 2 ) = IB0( 2 )
02212                IB2( 1 ) = IB0( 1 )
02213                IB2( 2 ) = IB0( 2 )
02214 *
02215   280       CONTINUE
02216 *
02217             II = II + IB
02218 *
02219             IF( IBLK.EQ.1 ) THEN
02220 *
02221 *              Jump IMBLOC + ( NPROW - 1 ) * MB rows
02222 *
02223                CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 )
02224 *
02225             ELSE
02226 *
02227 *              Jump NPROW * MB rows
02228 *
02229                CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 )
02230 *
02231             END IF
02232 *
02233             IB1( 1 ) = IB0( 1 )
02234             IB1( 2 ) = IB0( 2 )
02235             IB2( 1 ) = IB0( 1 )
02236             IB2( 2 ) = IB0( 2 )
02237             IB3( 1 ) = IB0( 1 )
02238             IB3( 2 ) = IB0( 2 )
02239 *
02240   290    CONTINUE
02241 *
02242       ELSE IF( LSAME( AFORM, 'H' ) ) THEN
02243 *
02244 *        Generate a Hermitian matrix
02245 *
02246          IF( LSAME( UPLO, 'L' ) ) THEN
02247 *
02248 *           generate lower trapezoidal part
02249 *
02250             JJ = 1
02251             LCMTC = LCMT00
02252 *
02253             DO 370 JBLK = 1, NBLKS
02254 *
02255                IF( JBLK.EQ.1 ) THEN
02256                   JB  = INBLOC
02257                   LOW = 1 - INBLOC
02258                ELSE IF( JBLK.EQ.NBLKS ) THEN
02259                   JB = LNBLOC
02260                   LOW = 1 - NB
02261                ELSE
02262                   JB  = NB
02263                   LOW = 1 - NB
02264                END IF
02265 *
02266                DO 360 JK = JJ, JJ + JB - 1
02267 *
02268                   II = 1
02269                   LCMTR = LCMTC
02270 *
02271                   DO 350 IBLK = 1, MBLKS
02272 *
02273                      IF( IBLK.EQ.1 ) THEN
02274                         IB  = IMBLOC
02275                         UPP = IMBLOC - 1
02276                      ELSE IF( IBLK.EQ.MBLKS ) THEN
02277                         IB  = LMBLOC
02278                         UPP = MB - 1
02279                      ELSE
02280                         IB  = MB
02281                         UPP = MB - 1
02282                      END IF
02283 *
02284 *                    Blocks are IB by JB
02285 *
02286                      IF( LCMTR.GT.UPP ) THEN
02287 *
02288                         DO 300 IK = II, II + IB - 1
02289                            DUMMY = CMPLX( PB_SRAND( 0 ),
02290      $                                    PB_SRAND( 0 ) )
02291   300                   CONTINUE
02292 *
02293                      ELSE IF( LCMTR.GE.LOW ) THEN
02294 *
02295                         JTMP = JK - JJ + 1
02296                         MNB  = MAX( 0, -LCMTR )
02297 *
02298                         IF( JTMP.LE.MIN( MNB, JB ) ) THEN
02299 *
02300                            DO 310 IK = II, II + IB - 1
02301                               A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
02302      $                                             PB_SRAND( 0 ) )
02303   310                      CONTINUE
02304 *
02305                         ELSE IF( ( JTMP.GE.( MNB + 1 )         ) .AND.
02306      $                           ( JTMP.LE.MIN( IB-LCMTR, JB ) ) ) THEN
02307 *
02308                            ITMP = II + JTMP + LCMTR - 1
02309 *
02310                            DO 320 IK = II, ITMP - 1
02311                               DUMMY = CMPLX( PB_SRAND( 0 ),
02312      $                                       PB_SRAND( 0 ) )
02313   320                      CONTINUE
02314 *
02315                            IF( ITMP.LE.( II + IB - 1 ) ) THEN
02316                               DUMMY = CMPLX( PB_SRAND( 0 ),
02317      $                                      -PB_SRAND( 0 ) )
02318                               A( ITMP, JK ) = CMPLX( REAL( DUMMY ),
02319      $                                               ZERO )
02320                            END IF
02321 *
02322                            DO 330 IK = ITMP + 1, II + IB - 1
02323                               A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
02324      $                                             PB_SRAND( 0 ) )
02325   330                      CONTINUE
02326 *
02327                         END IF
02328 *
02329                      ELSE
02330 *
02331                         DO 340 IK = II, II + IB - 1
02332                            A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
02333      $                                          PB_SRAND( 0 ) )
02334   340                   CONTINUE
02335 *
02336                      END IF
02337 *
02338                      II = II + IB
02339 *
02340                      IF( IBLK.EQ.1 ) THEN
02341 *
02342 *                       Jump IMBLOC + ( NPROW - 1 ) * MB rows
02343 *
02344                         LCMTR = LCMTR - JMP( JMP_NPIMBLOC )
02345                         CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB1,
02346      $                                  IB0 )
02347 *
02348                      ELSE
02349 *
02350 *                       Jump NPROW * MB rows
02351 *
02352                         LCMTR = LCMTR - JMP( JMP_NPMB )
02353                         CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB1,
02354      $                                  IB0 )
02355 *
02356                      END IF
02357 *
02358                      IB1( 1 ) = IB0( 1 )
02359                      IB1( 2 ) = IB0( 2 )
02360 *
02361   350             CONTINUE
02362 *
02363 *                 Jump one column
02364 *
02365                   CALL PB_JUMPIT( IMULADD( 1, JMP_COL ), IB2, IB0 )
02366 *
02367                   IB1( 1 ) = IB0( 1 )
02368                   IB1( 2 ) = IB0( 2 )
02369                   IB2( 1 ) = IB0( 1 )
02370                   IB2( 2 ) = IB0( 2 )
02371 *
02372   360          CONTINUE
02373 *
02374                JJ = JJ + JB
02375 *
02376                IF( JBLK.EQ.1 ) THEN
02377 *
02378 *                 Jump INBLOC + ( NPCOL - 1 ) * NB columns
02379 *
02380                   LCMTC = LCMTC + JMP( JMP_NQINBLOC )
02381                   CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB3, IB0 )
02382 *
02383                ELSE
02384 *
02385 *                 Jump NPCOL * NB columns
02386 *
02387                   LCMTC = LCMTC + JMP( JMP_NQNB )
02388                   CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB3, IB0 )
02389 *
02390                END IF
02391 *
02392                IB1( 1 ) = IB0( 1 )
02393                IB1( 2 ) = IB0( 2 )
02394                IB2( 1 ) = IB0( 1 )
02395                IB2( 2 ) = IB0( 2 )
02396                IB3( 1 ) = IB0( 1 )
02397                IB3( 2 ) = IB0( 2 )
02398 *
02399   370       CONTINUE
02400 *
02401          ELSE
02402 *
02403 *           generate upper trapezoidal part
02404 *
02405             II = 1
02406             LCMTR = LCMT00
02407 *
02408             DO 450 IBLK = 1, MBLKS
02409 *
02410                IF( IBLK.EQ.1 ) THEN
02411                   IB  = IMBLOC
02412                   UPP = IMBLOC - 1
02413                ELSE IF( IBLK.EQ.MBLKS ) THEN
02414                   IB  = LMBLOC
02415                   UPP = MB - 1
02416                ELSE
02417                   IB  = MB
02418                   UPP = MB - 1
02419                END IF
02420 *
02421                DO 440 IK = II, II + IB - 1
02422 *
02423                   JJ = 1
02424                   LCMTC = LCMTR
02425 *
02426                   DO 430 JBLK = 1, NBLKS
02427 *
02428                      IF( JBLK.EQ.1 ) THEN
02429                         JB  = INBLOC
02430                         LOW = 1 - INBLOC
02431                      ELSE IF( JBLK.EQ.NBLKS ) THEN
02432                         JB  = LNBLOC
02433                         LOW = 1 - NB
02434                      ELSE
02435                         JB  = NB
02436                         LOW = 1 - NB
02437                      END IF
02438 *
02439 *                    Blocks are IB by JB
02440 *
02441                      IF( LCMTC.LT.LOW ) THEN
02442 *
02443                         DO 380 JK = JJ, JJ + JB - 1
02444                            DUMMY = CMPLX( PB_SRAND( 0 ),
02445      $                                   -PB_SRAND( 0 ) )
02446   380                   CONTINUE
02447 *
02448                      ELSE IF( LCMTC.LE.UPP ) THEN
02449 *
02450                         ITMP = IK - II + 1
02451                         MNB  = MAX( 0, LCMTC )
02452 *
02453                         IF( ITMP.LE.MIN( MNB, IB ) ) THEN
02454 *
02455                            DO 390 JK = JJ, JJ + JB - 1
02456                               A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
02457      $                                            -PB_SRAND( 0 ) )
02458   390                      CONTINUE
02459 *
02460                         ELSE IF( ( ITMP.GE.( MNB + 1 )         ) .AND.
02461      $                           ( ITMP.LE.MIN( JB+LCMTC, IB ) ) ) THEN
02462 *
02463                            JTMP = JJ + ITMP - LCMTC - 1
02464 *
02465                            DO 400 JK = JJ, JTMP - 1
02466                               DUMMY = CMPLX( PB_SRAND( 0 ),
02467      $                                      -PB_SRAND( 0 ) )
02468   400                      CONTINUE
02469 *
02470                            IF( JTMP.LE.( JJ + JB - 1 ) ) THEN
02471                               DUMMY = CMPLX( PB_SRAND( 0 ),
02472      $                                      -PB_SRAND( 0 ) )
02473                               A( IK, JTMP ) = CMPLX( REAL( DUMMY ),
02474      $                                               ZERO )
02475                            END IF
02476 *
02477                            DO 410 JK = JTMP + 1, JJ + JB - 1
02478                               A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
02479      $                                            -PB_SRAND( 0 ) )
02480   410                      CONTINUE
02481 *
02482                         END IF
02483 *
02484                      ELSE
02485 *
02486                         DO 420 JK = JJ, JJ + JB - 1
02487                            A( IK, JK ) = CMPLX( PB_SRAND( 0 ),
02488      $                                         -PB_SRAND( 0 ) )
02489   420                   CONTINUE
02490 *
02491                      END IF
02492 *
02493                      JJ = JJ + JB
02494 *
02495                      IF( JBLK.EQ.1 ) THEN
02496 *
02497 *                       Jump INBLOC + ( NPCOL - 1 ) * NB columns
02498 *
02499                         LCMTC = LCMTC + JMP( JMP_NQINBLOC )
02500                         CALL PB_JUMPIT( IMULADD( 1, JMP_NQINBLOC ), IB1,
02501      $                                  IB0 )
02502 *
02503                      ELSE
02504 *
02505 *                       Jump NPCOL * NB columns
02506 *
02507                         LCMTC = LCMTC + JMP( JMP_NQNB )
02508                         CALL PB_JUMPIT( IMULADD( 1, JMP_NQNB ), IB1,
02509      $                                  IB0 )
02510 *
02511                      END IF
02512 *
02513                      IB1( 1 ) = IB0( 1 )
02514                      IB1( 2 ) = IB0( 2 )
02515 *
02516   430             CONTINUE
02517 *
02518 *                 Jump one row
02519 *
02520                   CALL PB_JUMPIT( IMULADD( 1, JMP_ROW ), IB2, IB0 )
02521 *
02522                   IB1( 1 ) = IB0( 1 )
02523                   IB1( 2 ) = IB0( 2 )
02524                   IB2( 1 ) = IB0( 1 )
02525                   IB2( 2 ) = IB0( 2 )
02526 *
02527   440          CONTINUE
02528 *
02529                II = II + IB
02530 *
02531                IF( IBLK.EQ.1 ) THEN
02532 *
02533 *                 Jump IMBLOC + ( NPROW - 1 ) * MB rows
02534 *
02535                   LCMTR = LCMTR - JMP( JMP_NPIMBLOC )
02536                   CALL PB_JUMPIT( IMULADD( 1, JMP_NPIMBLOC ), IB3, IB0 )
02537 *
02538                ELSE
02539 *
02540 *                 Jump NPROW * MB rows
02541 *
02542                   LCMTR = LCMTR - JMP( JMP_NPMB )
02543                   CALL PB_JUMPIT( IMULADD( 1, JMP_NPMB ), IB3, IB0 )
02544 *
02545                END IF
02546 *
02547                IB1( 1 ) = IB0( 1 )
02548                IB1( 2 ) = IB0( 2 )
02549                IB2( 1 ) = IB0( 1 )
02550                IB2( 2 ) = IB0( 2 )
02551                IB3( 1 ) = IB0( 1 )
02552                IB3( 2 ) = IB0( 2 )
02553 *
02554   450       CONTINUE
02555 *
02556          END IF
02557 *
02558       END IF
02559 *
02560       RETURN
02561 *
02562 *     End of PB_CLAGEN
02563 *
02564       END
02565       REAL               FUNCTION PB_SRAND( IDUMM )
02566 *
02567 *  -- PBLAS test routine (version 2.0) --
02568 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
02569 *     and University of California, Berkeley.
02570 *     April 1, 1998
02571 *
02572 *     .. Scalar Arguments ..
02573       INTEGER            IDUMM
02574 *     ..
02575 *
02576 *  Purpose
02577 *  =======
02578 *
02579 *  PB_SRAND generates the next number in the random sequence. This func-
02580 *  tion ensures that this number will be in the interval ( -1.0, 1.0 ).
02581 *
02582 *  Arguments
02583 *  =========
02584 *
02585 *  IDUMM   (local input) INTEGER
02586 *          This argument is ignored, but necessary to a FORTRAN 77 func-
02587 *          tion.
02588 *
02589 *  Further Details
02590 *  ===============
02591 *
02592 *  On entry, the array IRAND stored in the common block  RANCOM contains
02593 *  the information (2 integers)  required to generate the next number in
02594 *  the sequence X( n ). This number is computed as
02595 *
02596 *     X( n ) = ( 2^16 * IRAND( 2 ) + IRAND( 1 ) ) / d,
02597 *
02598 *  where the constant d is the  largest  32 bit  positive  integer.  The
02599 *  array  IRAND  is  then  updated for the generation of the next number
02600 *  X( n+1 ) in the random sequence as follows X( n+1 ) = a * X( n ) + c.
02601 *  The constants  a  and c  should have been preliminarily stored in the
02602 *  array  IACS  as  2 pairs of integers. The initial set up of IRAND and
02603 *  IACS is performed by the routine PB_SETRAN.
02604 *
02605 *  -- Written on April 1, 1998 by
02606 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
02607 *
02608 *  =====================================================================
02609 *
02610 *     .. Parameters ..
02611       REAL               ONE, TWO
02612       PARAMETER          ( ONE = 1.0E+0, TWO = 2.0E+0 )
02613 *     ..
02614 *     .. External Functions ..
02615       REAL               PB_SRAN
02616       EXTERNAL           PB_SRAN
02617 *     ..
02618 *     .. Executable Statements ..
02619 *
02620       PB_SRAND = ONE - TWO * PB_SRAN( IDUMM )
02621 *
02622       RETURN
02623 *
02624 *     End of PB_SRAND
02625 *
02626       END
02627       REAL               FUNCTION PB_SRAN( IDUMM )
02628 *
02629 *  -- PBLAS test routine (version 2.0) --
02630 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
02631 *     and University of California, Berkeley.
02632 *     April 1, 1998
02633 *
02634 *     .. Scalar Arguments ..
02635       INTEGER            IDUMM
02636 *     ..
02637 *
02638 *  Purpose
02639 *  =======
02640 *
02641 *  PB_SRAN generates the next number in the random sequence.
02642 *
02643 *  Arguments
02644 *  =========
02645 *
02646 *  IDUMM   (local input) INTEGER
02647 *          This argument is ignored, but necessary to a FORTRAN 77 func-
02648 *          tion.
02649 *
02650 *  Further Details
02651 *  ===============
02652 *
02653 *  On entry, the array IRAND stored in the common block  RANCOM contains
02654 *  the information (2 integers)  required to generate the next number in
02655 *  the sequence X( n ). This number is computed as
02656 *
02657 *     X( n ) = ( 2^16 * IRAND( 2 ) + IRAND( 1 ) ) / d,
02658 *
02659 *  where the constant d is the  largest  32 bit  positive  integer.  The
02660 *  array  IRAND  is  then  updated for the generation of the next number
02661 *  X( n+1 ) in the random sequence as follows X( n+1 ) = a * X( n ) + c.
02662 *  The constants  a  and c  should have been preliminarily stored in the
02663 *  array  IACS  as  2 pairs of integers. The initial set up of IRAND and
02664 *  IACS is performed by the routine PB_SETRAN.
02665 *
02666 *  -- Written on April 1, 1998 by
02667 *     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
02668 *
02669 *  =====================================================================
02670 *
02671 *     .. Parameters ..
02672       REAL               DIVFAC, POW16
02673       PARAMETER          ( DIVFAC = 2.147483648E+9,
02674      $                   POW16 = 6.5536E+4 )
02675 *     ..
02676 *     .. Local Arrays ..
02677       INTEGER            J( 2 )
02678 *     ..
02679 *     .. External Subroutines ..
02680       EXTERNAL           PB_LADD, PB_LMUL
02681 *     ..
02682 *     .. Intrinsic Functions ..
02683       INTRINSIC          REAL
02684 *     ..
02685 *     .. Common Blocks ..
02686       INTEGER            IACS( 4 ), IRAND( 2 )
02687       COMMON             /RANCOM/ IRAND, IACS
02688 *     ..
02689 *     .. Save Statements ..
02690       SAVE               /RANCOM/
02691 *     ..
02692 *     .. Executable Statements ..
02693 *
02694       PB_SRAN = ( REAL( IRAND( 1 ) ) + POW16 * REAL( IRAND( 2 ) ) ) /
02695      $            DIVFAC
02696 *
02697       CALL PB_LMUL( IRAND, IACS, J )
02698       CALL PB_LADD( J, IACS( 3 ), IRAND )
02699 *
02700       RETURN
02701 *
02702 *     End of PB_SRAN
02703 *
02704       END