OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
pzblastst.f File Reference

Go to the source code of this file.

Functions/Subroutines

subroutine pzoptee (ictxt, nout, subptr, scode, sname)
subroutine pzchkopt (ictxt, nout, subptr, scode, sname, argnam, argpos)
subroutine pzdimee (ictxt, nout, subptr, scode, sname)
subroutine pzchkdim (ictxt, nout, subptr, scode, sname, argnam, argpos)
subroutine pzvecee (ictxt, nout, subptr, scode, sname)
subroutine pzmatee (ictxt, nout, subptr, scode, sname)
subroutine pzsetpblas (ictxt)
subroutine pzchkmat (ictxt, nout, subptr, scode, sname, argnam, argpos)
subroutine pzcallsub (subptr, scode)
subroutine pzerrset (err, errmax, xtrue, x)
subroutine pzchkvin (errmax, n, x, px, ix, jx, descx, incx, info)
subroutine pzchkvout (n, x, px, ix, jx, descx, incx, info)
subroutine pzchkmin (errmax, m, n, a, pa, ia, ja, desca, info)
subroutine pzchkmout (m, n, a, pa, ia, ja, desca, info)
subroutine pzmprnt (ictxt, nout, m, n, a, lda, irprnt, icprnt, cmatnm)
subroutine pzvprnt (ictxt, nout, n, x, incx, irprnt, icprnt, cvecnm)
subroutine pzmvch (ictxt, trans, m, n, alpha, a, ia, ja, desca, x, ix, jx, descx, incx, beta, y, py, iy, jy, descy, incy, g, err, info)
subroutine pzvmch (ictxt, trans, uplo, m, n, alpha, x, ix, jx, descx, incx, y, iy, jy, descy, incy, a, pa, ia, ja, desca, g, err, info)
subroutine pzvmch2 (ictxt, uplo, m, n, alpha, x, ix, jx, descx, incx, y, iy, jy, descy, incy, a, pa, ia, ja, desca, g, err, info)
subroutine pzmmch (ictxt, transa, transb, m, n, k, alpha, a, ia, ja, desca, b, ib, jb, descb, beta, c, pc, ic, jc, descc, ct, g, err, info)
subroutine pzmmch1 (ictxt, uplo, trans, n, k, alpha, a, ia, ja, desca, beta, c, pc, ic, jc, descc, ct, g, err, info)
subroutine pzmmch2 (ictxt, uplo, trans, n, k, alpha, a, ia, ja, desca, b, ib, jb, descb, beta, c, pc, ic, jc, descc, ct, g, err, info)
subroutine pzmmch3 (uplo, trans, m, n, alpha, a, ia, ja, desca, beta, c, pc, ic, jc, descc, err, info)
subroutine pzerraxpby (errbnd, alpha, x, beta, y, prec)
subroutine pzipset (toggle, n, a, ia, ja, desca)
double precision function pdlamch (ictxt, cmach)
subroutine pzlaset (uplo, m, n, alpha, beta, a, ia, ja, desca)
subroutine pzlascal (type, m, n, alpha, a, ia, ja, desca)
subroutine pzlagen (inplace, aform, diag, offa, m, n, ia, ja, desca, iaseed, a, lda)
subroutine pzladom (inplace, n, alpha, a, ia, ja, desca)
subroutine pb_pzlaprnt (m, n, a, ia, ja, desca, irprnt, icprnt, cmatnm, nout, work)
subroutine pb_pzlaprn2 (m, n, a, ia, ja, desca, irprnt, icprnt, cmatnm, nout, prow, pcol, work)
subroutine pb_zfillpad (ictxt, m, n, a, lda, ipre, ipost, chkval)
subroutine pb_zchekpad (ictxt, mess, m, n, a, lda, ipre, ipost, chkval)
subroutine pb_zlaset (uplo, m, n, ioffd, alpha, beta, a, lda)
subroutine pb_zlascal (uplo, m, n, ioffd, alpha, a, lda)
subroutine pb_zlagen (uplo, aform, a, lda, lcmt00, iran, mblks, imbloc, mb, lmbloc, nblks, inbloc, nb, lnbloc, jmp, imuladd)
double precision function pb_drand (idumm)
double precision function pb_dran (idumm)

Function/Subroutine Documentation

◆ pb_dran()

double precision function pb_dran ( integer idumm)

Definition at line 11556 of file pzblastst.f.

11557*
11558* -- PBLAS test routine (version 2.0) --
11559* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
11560* and University of California, Berkeley.
11561* April 1, 1998
11562*
11563* .. Scalar Arguments ..
11564 INTEGER IDUMM
11565* ..
11566*
11567* Purpose
11568* =======
11569*
11570* PB_DRAN generates the next number in the random sequence.
11571*
11572* Arguments
11573* =========
11574*
11575* IDUMM (local input) INTEGER
11576* This argument is ignored, but necessary to a FORTRAN 77 func-
11577* tion.
11578*
11579* Further Details
11580* ===============
11581*
11582* On entry, the array IRAND stored in the common block RANCOM contains
11583* the information (2 integers) required to generate the next number in
11584* the sequence X( n ). This number is computed as
11585*
11586* X( n ) = ( 2^16 * IRAND( 2 ) + IRAND( 1 ) ) / d,
11587*
11588* where the constant d is the largest 32 bit positive integer. The
11589* array IRAND is then updated for the generation of the next number
11590* X( n+1 ) in the random sequence as follows X( n+1 ) = a * X( n ) + c.
11591* The constants a and c should have been preliminarily stored in the
11592* array IACS as 2 pairs of integers. The initial set up of IRAND and
11593* IACS is performed by the routine PB_SETRAN.
11594*
11595* -- Written on April 1, 1998 by
11596* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
11597*
11598* =====================================================================
11599*
11600* .. Parameters ..
11601 DOUBLE PRECISION DIVFAC, POW16
11602 PARAMETER ( divfac = 2.147483648d+9,
11603 $ pow16 = 6.5536d+4 )
11604* ..
11605* .. Local Arrays ..
11606 INTEGER J( 2 )
11607* ..
11608* .. External Subroutines ..
11609 EXTERNAL pb_ladd, pb_lmul
11610* ..
11611* .. Intrinsic Functions ..
11612 INTRINSIC dble
11613* ..
11614* .. Common Blocks ..
11615 INTEGER IACS( 4 ), IRAND( 2 )
11616 COMMON /rancom/ irand, iacs
11617* ..
11618* .. Save Statements ..
11619 SAVE /rancom/
11620* ..
11621* .. Executable Statements ..
11622*
11623 pb_dran = ( dble( irand( 1 ) ) + pow16 * dble( irand( 2 ) ) ) /
11624 $ divfac
11625*
11626 CALL pb_lmul( irand, iacs, j )
11627 CALL pb_ladd( j, iacs( 3 ), irand )
11628*
11629 RETURN
11630*
11631* End of PB_DRAN
11632*
pb_ladd
subroutine pb_ladd(j, k, i)
Definition pblastst.f:4480
pb_lmul
subroutine pb_lmul(k, j, i)
Definition pblastst.f:4559
pb_dran
double precision function pb_dran(idumm)
Definition pzblastst.f:11557

◆ pb_drand()

double precision function pb_drand ( integer idumm)

Definition at line 11494 of file pzblastst.f.

11495*
11496* -- PBLAS test routine (version 2.0) --
11497* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
11498* and University of California, Berkeley.
11499* April 1, 1998
11500*
11501* .. Scalar Arguments ..
11502 INTEGER IDUMM
11503* ..
11504*
11505* Purpose
11506* =======
11507*
11508* PB_DRAND generates the next number in the random sequence. This func-
11509* tion ensures that this number will be in the interval ( -1.0, 1.0 ).
11510*
11511* Arguments
11512* =========
11513*
11514* IDUMM (local input) INTEGER
11515* This argument is ignored, but necessary to a FORTRAN 77 func-
11516* tion.
11517*
11518* Further Details
11519* ===============
11520*
11521* On entry, the array IRAND stored in the common block RANCOM contains
11522* the information (2 integers) required to generate the next number in
11523* the sequence X( n ). This number is computed as
11524*
11525* X( n ) = ( 2^16 * IRAND( 2 ) + IRAND( 1 ) ) / d,
11526*
11527* where the constant d is the largest 32 bit positive integer. The
11528* array IRAND is then updated for the generation of the next number
11529* X( n+1 ) in the random sequence as follows X( n+1 ) = a * X( n ) + c.
11530* The constants a and c should have been preliminarily stored in the
11531* array IACS as 2 pairs of integers. The initial set up of IRAND and
11532* IACS is performed by the routine PB_SETRAN.
11533*
11534* -- Written on April 1, 1998 by
11535* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
11536*
11537* =====================================================================
11538*
11539* .. Parameters ..
11540 DOUBLE PRECISION ONE, TWO
11541 parameter( one = 1.0d+0, two = 2.0d+0 )
11542* ..
11543* .. External Functions ..
11544 DOUBLE PRECISION PB_DRAN
11545 EXTERNAL pb_dran
11546* ..
11547* .. Executable Statements ..
11548*
11549 pb_drand = one - two * pb_dran( idumm )
11550*
11551 RETURN
11552*
11553* End of PB_DRAND
11554*
pb_drand
double precision function pb_drand(idumm)
Definition pzblastst.f:11495

◆ pb_pzlaprn2()

subroutine pb_pzlaprn2 ( integer m,
integer n,
complex*16, dimension( * ) a,
integer ia,
integer ja,
integer, dimension( * ) desca,
integer irprnt,
integer icprnt,
character*(*) cmatnm,
integer nout,
integer prow,
integer pcol,
complex*16, dimension( * ) work )

Definition at line 9516 of file pzblastst.f.

9518*
9519* -- PBLAS test routine (version 2.0) --
9520* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
9521* and University of California, Berkeley.
9522* April 1, 1998
9523*
9524* .. Scalar Arguments ..
9525 INTEGER IA, ICPRNT, IRPRNT, JA, M, N, NOUT, PCOL, PROW
9526* ..
9527* .. Array Arguments ..
9528 CHARACTER*(*) CMATNM
9529 INTEGER DESCA( * )
9530 COMPLEX*16 A( * ), WORK( * )
9531* ..
9532*
9533* .. Parameters ..
9534 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
9535 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
9536 $ RSRC_
9537 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
9538 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
9539 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
9540 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
9541* ..
9542* .. Local Scalars ..
9543 LOGICAL AISCOLREP, AISROWREP
9544 INTEGER H, I, IACOL, IAROW, IB, ICTXT, ICURCOL,
9545 $ ICURROW, II, IIA, IN, J, JB, JJ, JJA, JN, K,
9546 $ LDA, LDW, MYCOL, MYROW, NPCOL, NPROW
9547* ..
9548* .. External Subroutines ..
9549 EXTERNAL blacs_barrier, blacs_gridinfo, pb_infog2l,
9550 $ zgerv2d, zgesd2d
9551* ..
9552* .. Intrinsic Functions ..
9553 INTRINSIC dble, dimag, min
9554* ..
9555* .. Executable Statements ..
9556*
9557* Get grid parameters
9558*
9559 ictxt = desca( ctxt_ )
9560 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
9561 CALL pb_infog2l( ia, ja, desca, nprow, npcol, myrow, mycol,
9562 $ iia, jja, iarow, iacol )
9563 ii = iia
9564 jj = jja
9565 IF( desca( rsrc_ ).LT.0 ) THEN
9566 aisrowrep = .true.
9567 iarow = prow
9568 icurrow = prow
9569 ELSE
9570 aisrowrep = .false.
9571 icurrow = iarow
9572 END IF
9573 IF( desca( csrc_ ).LT.0 ) THEN
9574 aiscolrep = .true.
9575 iacol = pcol
9576 icurcol = pcol
9577 ELSE
9578 aiscolrep = .false.
9579 icurcol = iacol
9580 END IF
9581 lda = desca( lld_ )
9582 ldw = max( desca( imb_ ), desca( mb_ ) )
9583*
9584* Handle the first block of column separately
9585*
9586 jb = desca( inb_ ) - ja + 1
9587 IF( jb.LE.0 )
9588 $ jb = ( (-jb) / desca( nb_ ) + 1 ) * desca( nb_ ) + jb
9589 jb = min( jb, n )
9590 jn = ja+jb-1
9591 DO 60 h = 0, jb-1
9592 ib = desca( imb_ ) - ia + 1
9593 IF( ib.LE.0 )
9594 $ ib = ( (-ib) / desca( mb_ ) + 1 ) * desca( mb_ ) + ib
9595 ib = min( ib, m )
9596 in = ia+ib-1
9597 IF( icurrow.EQ.irprnt .AND. icurcol.EQ.icprnt ) THEN
9598 IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
9599 DO 10 k = 0, ib-1
9600 WRITE( nout, fmt = 9999 )
9601 $ cmatnm, ia+k, ja+h,
9602 $ dble( a( ii+k+(jj+h-1)*lda ) ),
9603 $ dimag( a( ii+k+(jj+h-1)*lda ) )
9604 10 CONTINUE
9605 END IF
9606 ELSE
9607 IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
9608 CALL zgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ), lda,
9609 $ irprnt, icprnt )
9610 ELSE IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
9611 CALL zgerv2d( ictxt, ib, 1, work, ldw, icurrow, icurcol )
9612 DO 20 k = 1, ib
9613 WRITE( nout, fmt = 9999 )
9614 $ cmatnm, ia+k-1, ja+h, dble( work( k ) ),
9615 $ dimag( work( k ) )
9616 20 CONTINUE
9617 END IF
9618 END IF
9619 IF( myrow.EQ.icurrow )
9620 $ ii = ii + ib
9621 IF( .NOT.aisrowrep )
9622 $ icurrow = mod( icurrow+1, nprow )
9623 CALL blacs_barrier( ictxt, 'All' )
9624*
9625* Loop over remaining block of rows
9626*
9627 DO 50 i = in+1, ia+m-1, desca( mb_ )
9628 ib = min( desca( mb_ ), ia+m-i )
9629 IF( icurrow.EQ.irprnt .AND. icurcol.EQ.icprnt ) THEN
9630 IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
9631 DO 30 k = 0, ib-1
9632 WRITE( nout, fmt = 9999 )
9633 $ cmatnm, i+k, ja+h,
9634 $ dble( a( ii+k+(jj+h-1)*lda ) ),
9635 $ dimag( a( ii+k+(jj+h-1)*lda ) )
9636 30 CONTINUE
9637 END IF
9638 ELSE
9639 IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
9640 CALL zgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ),
9641 $ lda, irprnt, icprnt )
9642 ELSE IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
9643 CALL zgerv2d( ictxt, ib, 1, work, ldw, icurrow,
9644 $ icurcol )
9645 DO 40 k = 1, ib
9646 WRITE( nout, fmt = 9999 )
9647 $ cmatnm, i+k-1, ja+h, dble( work( k ) ),
9648 $ dimag( work( k ) )
9649 40 CONTINUE
9650 END IF
9651 END IF
9652 IF( myrow.EQ.icurrow )
9653 $ ii = ii + ib
9654 IF( .NOT.aisrowrep )
9655 $ icurrow = mod( icurrow+1, nprow )
9656 CALL blacs_barrier( ictxt, 'All' )
9657 50 CONTINUE
9658*
9659 ii = iia
9660 icurrow = iarow
9661 60 CONTINUE
9662*
9663 IF( mycol.EQ.icurcol )
9664 $ jj = jj + jb
9665 IF( .NOT.aiscolrep )
9666 $ icurcol = mod( icurcol+1, npcol )
9667 CALL blacs_barrier( ictxt, 'All' )
9668*
9669* Loop over remaining column blocks
9670*
9671 DO 130 j = jn+1, ja+n-1, desca( nb_ )
9672 jb = min( desca( nb_ ), ja+n-j )
9673 DO 120 h = 0, jb-1
9674 ib = desca( imb_ )-ia+1
9675 IF( ib.LE.0 )
9676 $ ib = ( (-ib) / desca( mb_ ) + 1 ) * desca( mb_ ) + ib
9677 ib = min( ib, m )
9678 in = ia+ib-1
9679 IF( icurrow.EQ.irprnt .AND. icurcol.EQ.icprnt ) THEN
9680 IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
9681 DO 70 k = 0, ib-1
9682 WRITE( nout, fmt = 9999 )
9683 $ cmatnm, ia+k, j+h,
9684 $ dble( a( ii+k+(jj+h-1)*lda ) ),
9685 $ dimag( a( ii+k+(jj+h-1)*lda ) )
9686 70 CONTINUE
9687 END IF
9688 ELSE
9689 IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
9690 CALL zgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ),
9691 $ lda, irprnt, icprnt )
9692 ELSE IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
9693 CALL zgerv2d( ictxt, ib, 1, work, ldw, icurrow,
9694 $ icurcol )
9695 DO 80 k = 1, ib
9696 WRITE( nout, fmt = 9999 )
9697 $ cmatnm, ia+k-1, j+h, dble( work( k ) ),
9698 $ dimag( work( k ) )
9699 80 CONTINUE
9700 END IF
9701 END IF
9702 IF( myrow.EQ.icurrow )
9703 $ ii = ii + ib
9704 icurrow = mod( icurrow+1, nprow )
9705 CALL blacs_barrier( ictxt, 'All' )
9706*
9707* Loop over remaining block of rows
9708*
9709 DO 110 i = in+1, ia+m-1, desca( mb_ )
9710 ib = min( desca( mb_ ), ia+m-i )
9711 IF( icurrow.EQ.irprnt .AND. icurcol.EQ.icprnt ) THEN
9712 IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
9713 DO 90 k = 0, ib-1
9714 WRITE( nout, fmt = 9999 )
9715 $ cmatnm, i+k, j+h,
9716 $ dble( a( ii+k+(jj+h-1)*lda ) ),
9717 $ dimag( a( ii+k+(jj+h-1)*lda ) )
9718 90 CONTINUE
9719 END IF
9720 ELSE
9721 IF( myrow.EQ.icurrow .AND. mycol.EQ.icurcol ) THEN
9722 CALL zgesd2d( ictxt, ib, 1, a( ii+(jj+h-1)*lda ),
9723 $ lda, irprnt, icprnt )
9724 ELSE IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
9725 CALL zgerv2d( ictxt, ib, 1, work, ldw, icurrow,
9726 $ icurcol )
9727 DO 100 k = 1, ib
9728 WRITE( nout, fmt = 9999 )
9729 $ cmatnm, i+k-1, j+h, dble( work( k ) ),
9730 $ dimag( work( k ) )
9731 100 CONTINUE
9732 END IF
9733 END IF
9734 IF( myrow.EQ.icurrow )
9735 $ ii = ii + ib
9736 IF( .NOT.aisrowrep )
9737 $ icurrow = mod( icurrow+1, nprow )
9738 CALL blacs_barrier( ictxt, 'All' )
9739 110 CONTINUE
9740*
9741 ii = iia
9742 icurrow = iarow
9743 120 CONTINUE
9744*
9745 IF( mycol.EQ.icurcol )
9746 $ jj = jj + jb
9747 IF( .NOT.aiscolrep )
9748 $ icurcol = mod( icurcol+1, npcol )
9749 CALL blacs_barrier( ictxt, 'All' )
9750*
9751 130 CONTINUE
9752*
9753 9999 FORMAT( 1x, a, '(', i6, ',', i6, ')=', d30.18, '+i*(',
9754 $ d30.18, ')' )
9755*
9756 RETURN
9757*
9758* End of PB_PZLAPRN2
9759*
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
blacs_gridinfo
subroutine blacs_gridinfo(cntxt, nprow, npcol, myrow, mycol)
Definition mpi.f:754
pb_infog2l
subroutine pb_infog2l(i, j, desc, nprow, npcol, myrow, mycol, ii, jj, prow, pcol)
Definition pblastst.f:1673

◆ pb_pzlaprnt()

subroutine pb_pzlaprnt ( integer m,
integer n,
complex*16, dimension( * ) a,
integer ia,
integer ja,
integer, dimension( * ) desca,
integer irprnt,
integer icprnt,
character*(*) cmatnm,
integer nout,
complex*16, dimension( * ) work )

Definition at line 9302 of file pzblastst.f.

9304*
9305* -- PBLAS test routine (version 2.0) --
9306* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
9307* and University of California, Berkeley.
9308* April 1, 1998
9309*
9310* .. Scalar Arguments ..
9311 INTEGER IA, ICPRNT, IRPRNT, JA, M, N, NOUT
9312* ..
9313* .. Array Arguments ..
9314 CHARACTER*(*) CMATNM
9315 INTEGER DESCA( * )
9316 COMPLEX*16 A( * ), WORK( * )
9317* ..
9318*
9319* Purpose
9320* =======
9321*
9322* PB_PZLAPRNT prints to the standard output a submatrix sub( A ) deno-
9323* ting A(IA:IA+M-1,JA:JA+N-1). The local pieces are sent and printed by
9324* the process of coordinates (IRPRNT, ICPRNT).
9325*
9326* Notes
9327* =====
9328*
9329* A description vector is associated with each 2D block-cyclicly dis-
9330* tributed matrix. This vector stores the information required to
9331* establish the mapping between a matrix entry and its corresponding
9332* process and memory location.
9333*
9334* In the following comments, the character _ should be read as
9335* "of the distributed matrix". Let A be a generic term for any 2D
9336* block cyclicly distributed matrix. Its description vector is DESCA:
9337*
9338* NOTATION STORED IN EXPLANATION
9339* ---------------- --------------- ------------------------------------
9340* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
9341* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
9342* the NPROW x NPCOL BLACS process grid
9343* A is distributed over. The context
9344* itself is global, but the handle
9345* (the integer value) may vary.
9346* M_A (global) DESCA( M_ ) The number of rows in the distribu-
9347* ted matrix A, M_A >= 0.
9348* N_A (global) DESCA( N_ ) The number of columns in the distri-
9349* buted matrix A, N_A >= 0.
9350* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
9351* block of the matrix A, IMB_A > 0.
9352* INB_A (global) DESCA( INB_ ) The number of columns of the upper
9353* left block of the matrix A,
9354* INB_A > 0.
9355* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
9356* bute the last M_A-IMB_A rows of A,
9357* MB_A > 0.
9358* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
9359* bute the last N_A-INB_A columns of
9360* A, NB_A > 0.
9361* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
9362* row of the matrix A is distributed,
9363* NPROW > RSRC_A >= 0.
9364* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
9365* first column of A is distributed.
9366* NPCOL > CSRC_A >= 0.
9367* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
9368* array storing the local blocks of
9369* the distributed matrix A,
9370* IF( Lc( 1, N_A ) > 0 )
9371* LLD_A >= MAX( 1, Lr( 1, M_A ) )
9372* ELSE
9373* LLD_A >= 1.
9374*
9375* Let K be the number of rows of a matrix A starting at the global in-
9376* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
9377* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
9378* receive if these K rows were distributed over NPROW processes. If K
9379* is the number of columns of a matrix A starting at the global index
9380* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
9381* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
9382* these K columns were distributed over NPCOL processes.
9383*
9384* The values of Lr() and Lc() may be determined via a call to the func-
9385* tion PB_NUMROC:
9386* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
9387* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
9388*
9389* Arguments
9390* =========
9391*
9392* M (global input) INTEGER
9393* On entry, M specifies the number of rows of the submatrix
9394* sub( A ). M must be at least zero.
9395*
9396* N (global input) INTEGER
9397* On entry, N specifies the number of columns of the submatrix
9398* sub( A ). N must be at least zero.
9399*
9400* A (local input) COMPLEX*16 array
9401* On entry, A is an array of dimension (LLD_A, Ka), where Ka is
9402* at least Lc( 1, JA+N-1 ). Before entry, this array contains
9403* the local entries of the matrix A.
9404*
9405* IA (global input) INTEGER
9406* On entry, IA specifies A's global row index, which points to
9407* the beginning of the submatrix sub( A ).
9408*
9409* JA (global input) INTEGER
9410* On entry, JA specifies A's global column index, which points
9411* to the beginning of the submatrix sub( A ).
9412*
9413* DESCA (global and local input) INTEGER array
9414* On entry, DESCA is an integer array of dimension DLEN_. This
9415* is the array descriptor for the matrix A.
9416*
9417* IRPRNT (global input) INTEGER
9418* On entry, IRPRNT specifies the row index of the printing pro-
9419* cess.
9420*
9421* ICPRNT (global input) INTEGER
9422* On entry, ICPRNT specifies the column index of the printing
9423* process.
9424*
9425* CMATNM (global input) CHARACTER*(*)
9426* On entry, CMATNM is the name of the matrix to be printed.
9427*
9428* NOUT (global input) INTEGER
9429* On entry, NOUT specifies the output unit number. When NOUT is
9430* equal to 6, the submatrix is printed on the screen.
9431*
9432* WORK (local workspace) COMPLEX*16 array
9433* On entry, WORK is a work array of dimension at least equal to
9434* MAX( IMB_A, MB_A ).
9435*
9436* -- Written on April 1, 1998 by
9437* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
9438*
9439* =====================================================================
9440*
9441* .. Parameters ..
9442 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
9443 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
9444 $ RSRC_
9445 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
9446 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
9447 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
9448 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
9449* ..
9450* .. Local Scalars ..
9451 INTEGER MYCOL, MYROW, NPCOL, NPROW, PCOL, PROW
9452* ..
9453* .. Local Arrays ..
9454 INTEGER DESCA2( DLEN_ )
9455* ..
9456* .. External Subroutines ..
9457 EXTERNAL blacs_gridinfo, pb_desctrans, pb_pzlaprn2
9458* ..
9459* .. Executable Statements ..
9460*
9461* Quick return if possible
9462*
9463 IF( ( m.LE.0 ).OR.( n.LE.0 ) )
9464 $ RETURN
9465*
9466* Convert descriptor
9467*
9468 CALL pb_desctrans( desca, desca2 )
9469*
9470 CALL blacs_gridinfo( desca2( ctxt_ ), nprow, npcol, myrow, mycol )
9471*
9472 IF( desca2( rsrc_ ).GE.0 ) THEN
9473 IF( desca2( csrc_ ).GE.0 ) THEN
9474 CALL pb_pzlaprn2( m, n, a, ia, ja, desca2, irprnt, icprnt,
9475 $ cmatnm, nout, desca2( rsrc_ ),
9476 $ desca2( csrc_ ), work )
9477 ELSE
9478 DO 10 pcol = 0, npcol - 1
9479 IF( ( myrow.EQ.irprnt ).AND.( mycol.EQ.icprnt ) )
9480 $ WRITE( nout, * ) 'Colum-replicated array -- ' ,
9481 $ 'copy in process column: ', pcol
9482 CALL pb_pzlaprn2( m, n, a, ia, ja, desca2, irprnt,
9483 $ icprnt, cmatnm, nout, desca2( rsrc_ ),
9484 $ pcol, work )
9485 10 CONTINUE
9486 END IF
9487 ELSE
9488 IF( desca2( csrc_ ).GE.0 ) THEN
9489 DO 20 prow = 0, nprow - 1
9490 IF( ( myrow.EQ.irprnt ).AND.( mycol.EQ.icprnt ) )
9491 $ WRITE( nout, * ) 'Row-replicated array -- ' ,
9492 $ 'copy in process row: ', prow
9493 CALL pb_pzlaprn2( m, n, a, ia, ja, desca2, irprnt,
9494 $ icprnt, cmatnm, nout, prow,
9495 $ desca2( csrc_ ), work )
9496 20 CONTINUE
9497 ELSE
9498 DO 40 prow = 0, nprow - 1
9499 DO 30 pcol = 0, npcol - 1
9500 IF( ( myrow.EQ.irprnt ).AND.( mycol.EQ.icprnt ) )
9501 $ WRITE( nout, * ) 'Replicated array -- ' ,
9502 $ 'copy in process (', prow, ',', pcol, ')'
9503 CALL pb_pzlaprn2( m, n, a, ia, ja, desca2, irprnt,
9504 $ icprnt, cmatnm, nout, prow, pcol,
9505 $ work )
9506 30 CONTINUE
9507 40 CONTINUE
9508 END IF
9509 END IF
9510*
9511 RETURN
9512*
9513* End of PB_PZLAPRNT
9514*
pb_desctrans
subroutine pb_desctrans(descin, descout)
Definition pblastst.f:2964
pb_pzlaprn2
subroutine pb_pzlaprn2(m, n, a, ia, ja, desca, irprnt, icprnt, cmatnm, nout, prow, pcol, work)
Definition pzblastst.f:9518

◆ pb_zchekpad()

subroutine pb_zchekpad ( integer ictxt,
character*(*) mess,
integer m,
integer n,
complex*16, dimension( * ) a,
integer lda,
integer ipre,
integer ipost,
complex*16 chkval )

Definition at line 9873 of file pzblastst.f.

9875*
9876* -- PBLAS test routine (version 2.0) --
9877* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
9878* and University of California, Berkeley.
9879* April 1, 1998
9880*
9881* .. Scalar Arguments ..
9882 INTEGER ICTXT, IPOST, IPRE, LDA, M, N
9883 COMPLEX*16 CHKVAL
9884* ..
9885* .. Array Arguments ..
9886 CHARACTER*(*) MESS
9887 COMPLEX*16 A( * )
9888* ..
9889*
9890* Purpose
9891* =======
9892*
9893* PB_ZCHEKPAD checks that the padding around a local array has not been
9894* overwritten since the call to PB_ZFILLPAD. Three types of errors are
9895* reported:
9896*
9897* 1) Overwrite in pre-guardzone. This indicates a memory overwrite has
9898* occurred in the first IPRE elements which form a buffer before the
9899* beginning of A. Therefore, the error message:
9900* 'Overwrite in pre-guardzone: loc( 5) = 18.00000'
9901* tells that the 5th element of the IPRE long buffer has been overwrit-
9902* ten with the value 18, where it should still have the value CHKVAL.
9903*
9904* 2) Overwrite in post-guardzone. This indicates a memory overwrite has
9905* occurred in the last IPOST elements which form a buffer after the end
9906* of A. Error reports are refered from the end of A. Therefore,
9907* 'Overwrite in post-guardzone: loc( 19) = 24.00000'
9908* tells that the 19th element after the end of A was overwritten with
9909* the value 24, where it should still have the value of CHKVAL.
9910*
9911* 3) Overwrite in lda-m gap. Tells you elements between M and LDA were
9912* overwritten. So,
9913* 'Overwrite in lda-m gap: A( 12, 3) = 22.00000'
9914* tells that the element at the 12th row and 3rd column of A was over-
9915* written with the value of 22, where it should still have the value of
9916* CHKVAL.
9917*
9918* Arguments
9919* =========
9920*
9921* ICTXT (local input) INTEGER
9922* On entry, ICTXT specifies the BLACS context handle, indica-
9923* ting the global context of the operation. The context itself
9924* is global, but the value of ICTXT is local.
9925*
9926* MESS (local input) CHARACTER*(*)
9927* On entry, MESS is a ttring containing a user-defined message.
9928*
9929* M (local input) INTEGER
9930* On entry, M specifies the number of rows in the local array
9931* A. M must be at least zero.
9932*
9933* N (local input) INTEGER
9934* On entry, N specifies the number of columns in the local ar-
9935* ray A. N must be at least zero.
9936*
9937* A (local input) COMPLEX*16 array
9938* On entry, A is an array of dimension (LDA,N).
9939*
9940* LDA (local input) INTEGER
9941* On entry, LDA specifies the leading dimension of the local
9942* array to be padded. LDA must be at least MAX( 1, M ).
9943*
9944* IPRE (local input) INTEGER
9945* On entry, IPRE specifies the size of the guard zone to put
9946* before the start of the padded array.
9947*
9948* IPOST (local input) INTEGER
9949* On entry, IPOST specifies the size of the guard zone to put
9950* after the end of the padded array.
9951*
9952* CHKVAL (local input) COMPLEX*16
9953* On entry, CHKVAL specifies the value to pad the array with.
9954*
9955*
9956* -- Written on April 1, 1998 by
9957* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
9958*
9959* =====================================================================
9960*
9961* .. Local Scalars ..
9962 CHARACTER*1 TOP
9963 INTEGER I, IAM, IDUMM, INFO, J, K, MYCOL, MYROW, NPCOL,
9964 $ NPROW
9965* ..
9966* .. External Subroutines ..
9967 EXTERNAL blacs_gridinfo, igamx2d, pb_topget
9968* ..
9969* .. Intrinsic Functions ..
9970 INTRINSIC dble, dimag
9971* ..
9972* .. Executable Statements ..
9973*
9974* Get grid parameters
9975*
9976 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
9977 iam = myrow*npcol + mycol
9978 info = -1
9979*
9980* Check buffer in front of A
9981*
9982 IF( ipre.GT.0 ) THEN
9983 DO 10 i = 1, ipre
9984 IF( a( i ).NE.chkval ) THEN
9985 WRITE( *, fmt = 9998 ) myrow, mycol, mess, ' pre', i,
9986 $ dble( a( i ) ), dimag( a( i ) )
9987 info = iam
9988 END IF
9989 10 CONTINUE
9990 ELSE
9991 WRITE( *, fmt = * ) 'WARNING no pre-guardzone in PB_ZCHEKPAD'
9992 END IF
9993*
9994* Check buffer after A
9995*
9996 IF( ipost.GT.0 ) THEN
9997 j = ipre+lda*n+1
9998 DO 20 i = j, j+ipost-1
9999 IF( a( i ).NE.chkval ) THEN
10000 WRITE( *, fmt = 9998 ) myrow, mycol, mess, 'post',
10001 $ i-j+1, dble( a( i ) ),
10002 $ dimag( a( i ) )
10003 info = iam
10004 END IF
10005 20 CONTINUE
10006 ELSE
10007 WRITE( *, fmt = * )
10008 $ 'WARNING no post-guardzone buffer in PB_ZCHEKPAD'
10009 END IF
10010*
10011* Check all (LDA-M) gaps
10012*
10013 IF( lda.GT.m ) THEN
10014 k = ipre + m + 1
10015 DO 40 j = 1, n
10016 DO 30 i = k, k + (lda-m) - 1
10017 IF( a( i ).NE.chkval ) THEN
10018 WRITE( *, fmt = 9997 ) myrow, mycol, mess,
10019 $ i-ipre-lda*(j-1), j, dble( a( i ) ),
10020 $ dimag( a( i ) )
10021 info = iam
10022 END IF
10023 30 CONTINUE
10024 k = k + lda
10025 40 CONTINUE
10026 END IF
10027*
10028 CALL pb_topget( ictxt, 'Combine', 'All', top )
10029 CALL igamx2d( ictxt, 'All', top, 1, 1, info, 1, idumm, idumm, -1,
10030 $ 0, 0 )
10031 IF( iam.EQ.0 .AND. info.GE.0 ) THEN
10032 WRITE( *, fmt = 9999 ) info / npcol, mod( info, npcol ), mess
10033 END IF
10034*
10035 9999 FORMAT( '{', i5, ',', i5, '}: Memory overwrite in ', a )
10036 9998 FORMAT( '{', i5, ',', i5, '}: ', a, ' memory overwrite in ',
10037 $ a4, '-guardzone: loc(', i3, ') = ', g20.7, '+ i*',
10038 $ g20.7 )
10039 9997 FORMAT( '{', i5, ',', i5, '}: ', a, ' memory overwrite in ',
10040 $ 'lda-m gap: loc(', i3, ',', i3, ') = ', g20.7,
10041 $ '+ i*', g20.7 )
10042*
10043 RETURN
10044*
10045* End of PB_ZCHEKPAD
10046*

◆ pb_zfillpad()

subroutine pb_zfillpad ( integer ictxt,
integer m,
integer n,
complex*16, dimension( * ) a,
integer lda,
integer ipre,
integer ipost,
complex*16 chkval )

Definition at line 9761 of file pzblastst.f.

9762*
9763* -- PBLAS test routine (version 2.0) --
9764* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
9765* and University of California, Berkeley.
9766* April 1, 1998
9767*
9768* .. Scalar Arguments ..
9769 INTEGER ICTXT, IPOST, IPRE, LDA, M, N
9770 COMPLEX*16 CHKVAL
9771* ..
9772* .. Array Arguments ..
9773 COMPLEX*16 A( * )
9774* ..
9775*
9776* Purpose
9777* =======
9778*
9779* PB_ZFILLPAD surrounds a two dimensional local array with a guard-zone
9780* initialized to the value CHKVAL. The user may later call the routine
9781* PB_ZCHEKPAD to discover if the guardzone has been violated. There are
9782* three guardzones. The first is a buffer of size IPRE that is before
9783* the start of the array. The second is the buffer of size IPOST which
9784* is after the end of the array to be padded. Finally, there is a guard
9785* zone inside every column of the array to be padded, in the elements
9786* of A(M+1:LDA, J).
9787*
9788* Arguments
9789* =========
9790*
9791* ICTXT (local input) INTEGER
9792* On entry, ICTXT specifies the BLACS context handle, indica-
9793* ting the global context of the operation. The context itself
9794* is global, but the value of ICTXT is local.
9795*
9796* M (local input) INTEGER
9797* On entry, M specifies the number of rows in the local array
9798* A. M must be at least zero.
9799*
9800* N (local input) INTEGER
9801* On entry, N specifies the number of columns in the local ar-
9802* ray A. N must be at least zero.
9803*
9804* A (local input/local output) COMPLEX*16 array
9805* On entry, A is an array of dimension (LDA,N). On exit, this
9806* array is the padded array.
9807*
9808* LDA (local input) INTEGER
9809* On entry, LDA specifies the leading dimension of the local
9810* array to be padded. LDA must be at least MAX( 1, M ).
9811*
9812* IPRE (local input) INTEGER
9813* On entry, IPRE specifies the size of the guard zone to put
9814* before the start of the padded array.
9815*
9816* IPOST (local input) INTEGER
9817* On entry, IPOST specifies the size of the guard zone to put
9818* after the end of the padded array.
9819*
9820* CHKVAL (local input) COMPLEX*16
9821* On entry, CHKVAL specifies the value to pad the array with.
9822*
9823* -- Written on April 1, 1998 by
9824* R. Clint Whaley, University of Tennessee, Knoxville 37996, USA.
9825*
9826* =====================================================================
9827*
9828* .. Local Scalars ..
9829 INTEGER I, J, K
9830* ..
9831* .. Executable Statements ..
9832*
9833* Put check buffer in front of A
9834*
9835 IF( ipre.GT.0 ) THEN
9836 DO 10 i = 1, ipre
9837 a( i ) = chkval
9838 10 CONTINUE
9839 ELSE
9840 WRITE( *, fmt = '(A)' )
9841 $ 'WARNING no pre-guardzone in PB_ZFILLPAD'
9842 END IF
9843*
9844* Put check buffer in back of A
9845*
9846 IF( ipost.GT.0 ) THEN
9847 j = ipre+lda*n+1
9848 DO 20 i = j, j+ipost-1
9849 a( i ) = chkval
9850 20 CONTINUE
9851 ELSE
9852 WRITE( *, fmt = '(a)' )
9853 $ 'warning no post-guardzone in pb_zfillpad'
9854 END IF
9855*
9856* Put check buffer in all (LDA-M) gaps
9857*
9858.GT. IF( LDAM ) THEN
9859 K = IPRE + M + 1
9860 DO 40 J = 1, N
9861 DO 30 I = K, K + ( LDA - M ) - 1
9862 A( I ) = CHKVAL
9863 30 CONTINUE
9864 K = K + LDA
9865 40 CONTINUE
9866 END IF
9867*
9868 RETURN
9869*
9870* End of PB_ZFILLPAD
9871*
pb_zfillpad
subroutine pb_zfillpad(ictxt, m, n, a, lda, ipre, ipost, chkval)
Definition pzblastst.f:9762

◆ pb_zlagen()

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

Definition at line 10424 of file pzblastst.f.

10427*
10428* -- PBLAS test routine (version 2.0) --
10429* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
10430* and University of California, Berkeley.
10431* April 1, 1998
10432*
10433* .. Scalar Arguments ..
10434 CHARACTER*1 UPLO, AFORM
10435 INTEGER IMBLOC, INBLOC, LCMT00, LDA, LMBLOC, LNBLOC,
10436 $ MB, MBLKS, NB, NBLKS
10437* ..
10438* .. Array Arguments ..
10439 INTEGER IMULADD( 4, * ), IRAN( * ), JMP( * )
10440 COMPLEX*16 A( LDA, * )
10441* ..
10442*
10443* Purpose
10444* =======
10445*
10446* PB_ZLAGEN locally initializes an array A.
10447*
10448* Arguments
10449* =========
10450*
10451* UPLO (global input) CHARACTER*1
10452* On entry, UPLO specifies whether the lower (UPLO='L') trape-
10453* zoidal part or the upper (UPLO='U') trapezoidal part is to be
10454* generated when the matrix to be generated is symmetric or
10455* Hermitian. For all the other values of AFORM, the value of
10456* this input argument is ignored.
10457*
10458* AFORM (global input) CHARACTER*1
10459* On entry, AFORM specifies the type of submatrix to be genera-
10460* ted as follows:
10461* AFORM = 'S', sub( A ) is a symmetric matrix,
10462* AFORM = 'H', sub( A ) is a Hermitian matrix,
10463* AFORM = 'T', sub( A ) is overrwritten with the transpose
10464* of what would normally be generated,
10465* AFORM = 'C', sub( A ) is overwritten with the conjugate
10466* transpose of what would normally be genera-
10467* ted.
10468* AFORM = 'N', a random submatrix is generated.
10469*
10470* A (local output) COMPLEX*16 array
10471* On entry, A is an array of dimension (LLD_A, *). On exit,
10472* this array contains the local entries of the randomly genera-
10473* ted submatrix sub( A ).
10474*
10475* LDA (local input) INTEGER
10476* On entry, LDA specifies the local leading dimension of the
10477* array A. LDA must be at least one.
10478*
10479* LCMT00 (global input) INTEGER
10480* On entry, LCMT00 is the LCM value specifying the off-diagonal
10481* of the underlying matrix of interest. LCMT00=0 specifies the
10482* main diagonal, LCMT00 > 0 specifies a subdiagonal, LCMT00 < 0
10483* specifies superdiagonals.
10484*
10485* IRAN (local input) INTEGER array
10486* On entry, IRAN is an array of dimension 2 containing respec-
10487* tively the 16-lower and 16-higher bits of the encoding of the
10488* entry of the random sequence corresponding locally to the
10489* first local array entry to generate. Usually, this array is
10490* computed by PB_SETLOCRAN.
10491*
10492* MBLKS (local input) INTEGER
10493* On entry, MBLKS specifies the local number of blocks of rows.
10494* MBLKS is at least zero.
10495*
10496* IMBLOC (local input) INTEGER
10497* On entry, IMBLOC specifies the number of rows (size) of the
10498* local uppest blocks. IMBLOC is at least zero.
10499*
10500* MB (global input) INTEGER
10501* On entry, MB specifies the blocking factor used to partition
10502* the rows of the matrix. MB must be at least one.
10503*
10504* LMBLOC (local input) INTEGER
10505* On entry, LMBLOC specifies the number of rows (size) of the
10506* local lowest blocks. LMBLOC is at least zero.
10507*
10508* NBLKS (local input) INTEGER
10509* On entry, NBLKS specifies the local number of blocks of co-
10510* lumns. NBLKS is at least zero.
10511*
10512* INBLOC (local input) INTEGER
10513* On entry, INBLOC specifies the number of columns (size) of
10514* the local leftmost blocks. INBLOC is at least zero.
10515*
10516* NB (global input) INTEGER
10517* On entry, NB specifies the blocking factor used to partition
10518* the the columns of the matrix. NB must be at least one.
10519*
10520* LNBLOC (local input) INTEGER
10521* On entry, LNBLOC specifies the number of columns (size) of
10522* the local rightmost blocks. LNBLOC is at least zero.
10523*
10524* JMP (local input) INTEGER array
10525* On entry, JMP is an array of dimension JMP_LEN containing the
10526* different jump values used by the random matrix generator.
10527*
10528* IMULADD (local input) INTEGER array
10529* On entry, IMULADD is an array of dimension (4, JMP_LEN). The
10530* jth column of this array contains the encoded initial cons-
10531* tants a_j and c_j to jump from X( n ) to X( n + JMP( j ) )
10532* (= a_j * X( n ) + c_j) in the random sequence. IMULADD(1:2,j)
10533* contains respectively the 16-lower and 16-higher bits of the
10534* constant a_j, and IMULADD(3:4,j) contains the 16-lower and
10535* 16-higher bits of the constant c_j.
10536*
10537* -- Written on April 1, 1998 by
10538* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
10539*
10540* =====================================================================
10541*
10542* .. Parameters ..
10543 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
10544 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
10545 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW
10546 parameter( jmp_1 = 1, jmp_row = 2, jmp_col = 3,
10547 $ jmp_mb = 4, jmp_imbv = 5, jmp_npmb = 6,
10548 $ jmp_npimbloc = 7, jmp_nb = 8, jmp_inbv = 9,
10549 $ jmp_nqnb = 10, jmp_nqinbloc = 11,
10550 $ jmp_len = 11 )
10551 DOUBLE PRECISION ZERO
10552 parameter( zero = 0.0d+0 )
10553* ..
10554* .. Local Scalars ..
10555 INTEGER I, IB, IBLK, II, IK, ITMP, JB, JBLK, JJ, JK,
10556 $ JTMP, LCMTC, LCMTR, LOW, MNB, UPP
10557 COMPLEX*16 DUMMY
10558* ..
10559* .. Local Arrays ..
10560 INTEGER IB0( 2 ), IB1( 2 ), IB2( 2 ), IB3( 2 )
10561* ..
10562* .. External Subroutines ..
10563 EXTERNAL pb_jumpit
10564* ..
10565* .. External Functions ..
10566 LOGICAL LSAME
10567 DOUBLE PRECISION PB_DRAND
10568 EXTERNAL lsame, pb_drand
10569* ..
10570* .. Intrinsic Functions ..
10571 INTRINSIC dble, dcmplx, max, min
10572* ..
10573* .. Executable Statements ..
10574*
10575 DO 10 i = 1, 2
10576 ib1( i ) = iran( i )
10577 ib2( i ) = iran( i )
10578 ib3( i ) = iran( i )
10579 10 CONTINUE
10580*
10581 IF( lsame( aform, 'N' ) ) THEN
10582*
10583* Generate random matrix
10584*
10585 jj = 1
10586*
10587 DO 50 jblk = 1, nblks
10588*
10589 IF( jblk.EQ.1 ) THEN
10590 jb = inbloc
10591 ELSE IF( jblk.EQ.nblks ) THEN
10592 jb = lnbloc
10593 ELSE
10594 jb = nb
10595 END IF
10596*
10597 DO 40 jk = jj, jj + jb - 1
10598*
10599 ii = 1
10600*
10601 DO 30 iblk = 1, mblks
10602*
10603 IF( iblk.EQ.1 ) THEN
10604 ib = imbloc
10605 ELSE IF( iblk.EQ.mblks ) THEN
10606 ib = lmbloc
10607 ELSE
10608 ib = mb
10609 END IF
10610*
10611* Blocks are IB by JB
10612*
10613 DO 20 ik = ii, ii + ib - 1
10614 a( ik, jk ) = dcmplx( pb_drand( 0 ),
10615 $ pb_drand( 0 ) )
10616 20 CONTINUE
10617*
10618 ii = ii + ib
10619*
10620 IF( iblk.EQ.1 ) THEN
10621*
10622* Jump IMBLOC + ( NPROW - 1 ) * MB rows
10623*
10624 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib1,
10625 $ ib0 )
10626*
10627 ELSE
10628*
10629* Jump NPROW * MB rows
10630*
10631 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib1, ib0 )
10632*
10633 END IF
10634*
10635 ib1( 1 ) = ib0( 1 )
10636 ib1( 2 ) = ib0( 2 )
10637*
10638 30 CONTINUE
10639*
10640* Jump one column
10641*
10642 CALL pb_jumpit( imuladd( 1, jmp_col ), ib2, ib0 )
10643*
10644 ib1( 1 ) = ib0( 1 )
10645 ib1( 2 ) = ib0( 2 )
10646 ib2( 1 ) = ib0( 1 )
10647 ib2( 2 ) = ib0( 2 )
10648*
10649 40 CONTINUE
10650*
10651 jj = jj + jb
10652*
10653 IF( jblk.EQ.1 ) THEN
10654*
10655* Jump INBLOC + ( NPCOL - 1 ) * NB columns
10656*
10657 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib3, ib0 )
10658*
10659 ELSE
10660*
10661* Jump NPCOL * NB columns
10662*
10663 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib3, ib0 )
10664*
10665 END IF
10666*
10667 ib1( 1 ) = ib0( 1 )
10668 ib1( 2 ) = ib0( 2 )
10669 ib2( 1 ) = ib0( 1 )
10670 ib2( 2 ) = ib0( 2 )
10671 ib3( 1 ) = ib0( 1 )
10672 ib3( 2 ) = ib0( 2 )
10673*
10674 50 CONTINUE
10675*
10676 ELSE IF( lsame( aform, 'T' ) ) THEN
10677*
10678* Generate the transpose of the matrix that would be normally
10679* generated.
10680*
10681 ii = 1
10682*
10683 DO 90 iblk = 1, mblks
10684*
10685 IF( iblk.EQ.1 ) THEN
10686 ib = imbloc
10687 ELSE IF( iblk.EQ.mblks ) THEN
10688 ib = lmbloc
10689 ELSE
10690 ib = mb
10691 END IF
10692*
10693 DO 80 ik = ii, ii + ib - 1
10694*
10695 jj = 1
10696*
10697 DO 70 jblk = 1, nblks
10698*
10699 IF( jblk.EQ.1 ) THEN
10700 jb = inbloc
10701 ELSE IF( jblk.EQ.nblks ) THEN
10702 jb = lnbloc
10703 ELSE
10704 jb = nb
10705 END IF
10706*
10707* Blocks are IB by JB
10708*
10709 DO 60 jk = jj, jj + jb - 1
10710 a( ik, jk ) = dcmplx( pb_drand( 0 ),
10711 $ pb_drand( 0 ) )
10712 60 CONTINUE
10713*
10714 jj = jj + jb
10715*
10716 IF( jblk.EQ.1 ) THEN
10717*
10718* Jump INBLOC + ( NPCOL - 1 ) * NB columns
10719*
10720 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib1,
10721 $ ib0 )
10722*
10723 ELSE
10724*
10725* Jump NPCOL * NB columns
10726*
10727 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib1, ib0 )
10728*
10729 END IF
10730*
10731 ib1( 1 ) = ib0( 1 )
10732 ib1( 2 ) = ib0( 2 )
10733*
10734 70 CONTINUE
10735*
10736* Jump one row
10737*
10738 CALL pb_jumpit( imuladd( 1, jmp_row ), ib2, ib0 )
10739*
10740 ib1( 1 ) = ib0( 1 )
10741 ib1( 2 ) = ib0( 2 )
10742 ib2( 1 ) = ib0( 1 )
10743 ib2( 2 ) = ib0( 2 )
10744*
10745 80 CONTINUE
10746*
10747 ii = ii + ib
10748*
10749 IF( iblk.EQ.1 ) THEN
10750*
10751* Jump IMBLOC + ( NPROW - 1 ) * MB rows
10752*
10753 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib3, ib0 )
10754*
10755 ELSE
10756*
10757* Jump NPROW * MB rows
10758*
10759 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib3, ib0 )
10760*
10761 END IF
10762*
10763 ib1( 1 ) = ib0( 1 )
10764 ib1( 2 ) = ib0( 2 )
10765 ib2( 1 ) = ib0( 1 )
10766 ib2( 2 ) = ib0( 2 )
10767 ib3( 1 ) = ib0( 1 )
10768 ib3( 2 ) = ib0( 2 )
10769*
10770 90 CONTINUE
10771*
10772 ELSE IF( lsame( aform, 'S' ) ) THEN
10773*
10774* Generate a symmetric matrix
10775*
10776 IF( lsame( uplo, 'L' ) ) THEN
10777*
10778* generate lower trapezoidal part
10779*
10780 jj = 1
10781 lcmtc = lcmt00
10782*
10783 DO 170 jblk = 1, nblks
10784*
10785 IF( jblk.EQ.1 ) THEN
10786 jb = inbloc
10787 low = 1 - inbloc
10788 ELSE IF( jblk.EQ.nblks ) THEN
10789 jb = lnbloc
10790 low = 1 - nb
10791 ELSE
10792 jb = nb
10793 low = 1 - nb
10794 END IF
10795*
10796 DO 160 jk = jj, jj + jb - 1
10797*
10798 ii = 1
10799 lcmtr = lcmtc
10800*
10801 DO 150 iblk = 1, mblks
10802*
10803 IF( iblk.EQ.1 ) THEN
10804 ib = imbloc
10805 upp = imbloc - 1
10806 ELSE IF( iblk.EQ.mblks ) THEN
10807 ib = lmbloc
10808 upp = mb - 1
10809 ELSE
10810 ib = mb
10811 upp = mb - 1
10812 END IF
10813*
10814* Blocks are IB by JB
10815*
10816 IF( lcmtr.GT.upp ) THEN
10817*
10818 DO 100 ik = ii, ii + ib - 1
10819 dummy = dcmplx( pb_drand( 0 ),
10820 $ pb_drand( 0 ) )
10821 100 CONTINUE
10822*
10823 ELSE IF( lcmtr.GE.low ) THEN
10824*
10825 jtmp = jk - jj + 1
10826 mnb = max( 0, -lcmtr )
10827*
10828 IF( jtmp.LE.min( mnb, jb ) ) THEN
10829*
10830 DO 110 ik = ii, ii + ib - 1
10831 a( ik, jk ) = dcmplx( pb_drand( 0 ),
10832 $ pb_drand( 0 ) )
10833 110 CONTINUE
10834*
10835 ELSE IF( ( jtmp.GE.( mnb + 1 ) ) .AND.
10836 $ ( jtmp.LE.min( ib-lcmtr, jb ) ) ) THEN
10837*
10838 itmp = ii + jtmp + lcmtr - 1
10839*
10840 DO 120 ik = ii, itmp - 1
10841 dummy = dcmplx( pb_drand( 0 ),
10842 $ pb_drand( 0 ) )
10843 120 CONTINUE
10844*
10845 DO 130 ik = itmp, ii + ib - 1
10846 a( ik, jk ) = dcmplx( pb_drand( 0 ),
10847 $ pb_drand( 0 ) )
10848 130 CONTINUE
10849*
10850 END IF
10851*
10852 ELSE
10853*
10854 DO 140 ik = ii, ii + ib - 1
10855 a( ik, jk ) = dcmplx( pb_drand( 0 ),
10856 $ pb_drand( 0 ) )
10857 140 CONTINUE
10858*
10859 END IF
10860*
10861 ii = ii + ib
10862*
10863 IF( iblk.EQ.1 ) THEN
10864*
10865* Jump IMBLOC + ( NPROW - 1 ) * MB rows
10866*
10867 lcmtr = lcmtr - jmp( jmp_npimbloc )
10868 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib1,
10869 $ ib0 )
10870*
10871 ELSE
10872*
10873* Jump NPROW * MB rows
10874*
10875 lcmtr = lcmtr - jmp( jmp_npmb )
10876 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib1,
10877 $ ib0 )
10878*
10879 END IF
10880*
10881 ib1( 1 ) = ib0( 1 )
10882 ib1( 2 ) = ib0( 2 )
10883*
10884 150 CONTINUE
10885*
10886* Jump one column
10887*
10888 CALL pb_jumpit( imuladd( 1, jmp_col ), ib2, ib0 )
10889*
10890 ib1( 1 ) = ib0( 1 )
10891 ib1( 2 ) = ib0( 2 )
10892 ib2( 1 ) = ib0( 1 )
10893 ib2( 2 ) = ib0( 2 )
10894*
10895 160 CONTINUE
10896*
10897 jj = jj + jb
10898*
10899 IF( jblk.EQ.1 ) THEN
10900*
10901* Jump INBLOC + ( NPCOL - 1 ) * NB columns
10902*
10903 lcmtc = lcmtc + jmp( jmp_nqinbloc )
10904 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib3, ib0 )
10905*
10906 ELSE
10907*
10908* Jump NPCOL * NB columns
10909*
10910 lcmtc = lcmtc + jmp( jmp_nqnb )
10911 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib3, ib0 )
10912*
10913 END IF
10914*
10915 ib1( 1 ) = ib0( 1 )
10916 ib1( 2 ) = ib0( 2 )
10917 ib2( 1 ) = ib0( 1 )
10918 ib2( 2 ) = ib0( 2 )
10919 ib3( 1 ) = ib0( 1 )
10920 ib3( 2 ) = ib0( 2 )
10921*
10922 170 CONTINUE
10923*
10924 ELSE
10925*
10926* generate upper trapezoidal part
10927*
10928 ii = 1
10929 lcmtr = lcmt00
10930*
10931 DO 250 iblk = 1, mblks
10932*
10933 IF( iblk.EQ.1 ) THEN
10934 ib = imbloc
10935 upp = imbloc - 1
10936 ELSE IF( iblk.EQ.mblks ) THEN
10937 ib = lmbloc
10938 upp = mb - 1
10939 ELSE
10940 ib = mb
10941 upp = mb - 1
10942 END IF
10943*
10944 DO 240 ik = ii, ii + ib - 1
10945*
10946 jj = 1
10947 lcmtc = lcmtr
10948*
10949 DO 230 jblk = 1, nblks
10950*
10951 IF( jblk.EQ.1 ) THEN
10952 jb = inbloc
10953 low = 1 - inbloc
10954 ELSE IF( jblk.EQ.nblks ) THEN
10955 jb = lnbloc
10956 low = 1 - nb
10957 ELSE
10958 jb = nb
10959 low = 1 - nb
10960 END IF
10961*
10962* Blocks are IB by JB
10963*
10964 IF( lcmtc.LT.low ) THEN
10965*
10966 DO 180 jk = jj, jj + jb - 1
10967 dummy = dcmplx( pb_drand( 0 ),
10968 $ pb_drand( 0 ) )
10969 180 CONTINUE
10970*
10971 ELSE IF( lcmtc.LE.upp ) THEN
10972*
10973 itmp = ik - ii + 1
10974 mnb = max( 0, lcmtc )
10975*
10976 IF( itmp.LE.min( mnb, ib ) ) THEN
10977*
10978 DO 190 jk = jj, jj + jb - 1
10979 a( ik, jk ) = dcmplx( pb_drand( 0 ),
10980 $ pb_drand( 0 ) )
10981 190 CONTINUE
10982*
10983 ELSE IF( ( itmp.GE.( mnb + 1 ) ) .AND.
10984 $ ( itmp.LE.min( jb+lcmtc, ib ) ) ) THEN
10985*
10986 jtmp = jj + itmp - lcmtc - 1
10987*
10988 DO 200 jk = jj, jtmp - 1
10989 dummy = dcmplx( pb_drand( 0 ),
10990 $ pb_drand( 0 ) )
10991 200 CONTINUE
10992*
10993 DO 210 jk = jtmp, jj + jb - 1
10994 a( ik, jk ) = dcmplx( pb_drand( 0 ),
10995 $ pb_drand( 0 ) )
10996 210 CONTINUE
10997*
10998 END IF
10999*
11000 ELSE
11001*
11002 DO 220 jk = jj, jj + jb - 1
11003 a( ik, jk ) = dcmplx( pb_drand( 0 ),
11004 $ pb_drand( 0 ) )
11005 220 CONTINUE
11006*
11007 END IF
11008*
11009 jj = jj + jb
11010*
11011 IF( jblk.EQ.1 ) THEN
11012*
11013* Jump INBLOC + ( NPCOL - 1 ) * NB columns
11014*
11015 lcmtc = lcmtc + jmp( jmp_nqinbloc )
11016 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib1,
11017 $ ib0 )
11018*
11019 ELSE
11020*
11021* Jump NPCOL * NB columns
11022*
11023 lcmtc = lcmtc + jmp( jmp_nqnb )
11024 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib1,
11025 $ ib0 )
11026*
11027 END IF
11028*
11029 ib1( 1 ) = ib0( 1 )
11030 ib1( 2 ) = ib0( 2 )
11031*
11032 230 CONTINUE
11033*
11034* Jump one row
11035*
11036 CALL pb_jumpit( imuladd( 1, jmp_row ), ib2, ib0 )
11037*
11038 ib1( 1 ) = ib0( 1 )
11039 ib1( 2 ) = ib0( 2 )
11040 ib2( 1 ) = ib0( 1 )
11041 ib2( 2 ) = ib0( 2 )
11042*
11043 240 CONTINUE
11044*
11045 ii = ii + ib
11046*
11047 IF( iblk.EQ.1 ) THEN
11048*
11049* Jump IMBLOC + ( NPROW - 1 ) * MB rows
11050*
11051 lcmtr = lcmtr - jmp( jmp_npimbloc )
11052 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib3, ib0 )
11053*
11054 ELSE
11055*
11056* Jump NPROW * MB rows
11057*
11058 lcmtr = lcmtr - jmp( jmp_npmb )
11059 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib3, ib0 )
11060*
11061 END IF
11062*
11063 ib1( 1 ) = ib0( 1 )
11064 ib1( 2 ) = ib0( 2 )
11065 ib2( 1 ) = ib0( 1 )
11066 ib2( 2 ) = ib0( 2 )
11067 ib3( 1 ) = ib0( 1 )
11068 ib3( 2 ) = ib0( 2 )
11069*
11070 250 CONTINUE
11071*
11072 END IF
11073*
11074 ELSE IF( lsame( aform, 'C' ) ) THEN
11075*
11076* Generate the conjugate transpose of the matrix that would be
11077* normally generated.
11078*
11079 ii = 1
11080*
11081 DO 290 iblk = 1, mblks
11082*
11083 IF( iblk.EQ.1 ) THEN
11084 ib = imbloc
11085 ELSE IF( iblk.EQ.mblks ) THEN
11086 ib = lmbloc
11087 ELSE
11088 ib = mb
11089 END IF
11090*
11091 DO 280 ik = ii, ii + ib - 1
11092*
11093 jj = 1
11094*
11095 DO 270 jblk = 1, nblks
11096*
11097 IF( jblk.EQ.1 ) THEN
11098 jb = inbloc
11099 ELSE IF( jblk.EQ.nblks ) THEN
11100 jb = lnbloc
11101 ELSE
11102 jb = nb
11103 END IF
11104*
11105* Blocks are IB by JB
11106*
11107 DO 260 jk = jj, jj + jb - 1
11108 a( ik, jk ) = dcmplx( pb_drand( 0 ),
11109 $ -pb_drand( 0 ) )
11110 260 CONTINUE
11111*
11112 jj = jj + jb
11113*
11114 IF( jblk.EQ.1 ) THEN
11115*
11116* Jump INBLOC + ( NPCOL - 1 ) * NB columns
11117*
11118 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib1,
11119 $ ib0 )
11120*
11121 ELSE
11122*
11123* Jump NPCOL * NB columns
11124*
11125 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib1,
11126 $ ib0 )
11127*
11128 END IF
11129*
11130 ib1( 1 ) = ib0( 1 )
11131 ib1( 2 ) = ib0( 2 )
11132*
11133 270 CONTINUE
11134*
11135* Jump one row
11136*
11137 CALL pb_jumpit( imuladd( 1, jmp_row ), ib2, ib0 )
11138*
11139 ib1( 1 ) = ib0( 1 )
11140 ib1( 2 ) = ib0( 2 )
11141 ib2( 1 ) = ib0( 1 )
11142 ib2( 2 ) = ib0( 2 )
11143*
11144 280 CONTINUE
11145*
11146 ii = ii + ib
11147*
11148 IF( iblk.EQ.1 ) THEN
11149*
11150* Jump IMBLOC + ( NPROW - 1 ) * MB rows
11151*
11152 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib3, ib0 )
11153*
11154 ELSE
11155*
11156* Jump NPROW * MB rows
11157*
11158 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib3, ib0 )
11159*
11160 END IF
11161*
11162 ib1( 1 ) = ib0( 1 )
11163 ib1( 2 ) = ib0( 2 )
11164 ib2( 1 ) = ib0( 1 )
11165 ib2( 2 ) = ib0( 2 )
11166 ib3( 1 ) = ib0( 1 )
11167 ib3( 2 ) = ib0( 2 )
11168*
11169 290 CONTINUE
11170*
11171 ELSE IF( lsame( aform, 'H' ) ) THEN
11172*
11173* Generate a Hermitian matrix
11174*
11175 IF( lsame( uplo, 'L' ) ) THEN
11176*
11177* generate lower trapezoidal part
11178*
11179 jj = 1
11180 lcmtc = lcmt00
11181*
11182 DO 370 jblk = 1, nblks
11183*
11184 IF( jblk.EQ.1 ) THEN
11185 jb = inbloc
11186 low = 1 - inbloc
11187 ELSE IF( jblk.EQ.nblks ) THEN
11188 jb = lnbloc
11189 low = 1 - nb
11190 ELSE
11191 jb = nb
11192 low = 1 - nb
11193 END IF
11194*
11195 DO 360 jk = jj, jj + jb - 1
11196*
11197 ii = 1
11198 lcmtr = lcmtc
11199*
11200 DO 350 iblk = 1, mblks
11201*
11202 IF( iblk.EQ.1 ) THEN
11203 ib = imbloc
11204 upp = imbloc - 1
11205 ELSE IF( iblk.EQ.mblks ) THEN
11206 ib = lmbloc
11207 upp = mb - 1
11208 ELSE
11209 ib = mb
11210 upp = mb - 1
11211 END IF
11212*
11213* Blocks are IB by JB
11214*
11215 IF( lcmtr.GT.upp ) THEN
11216*
11217 DO 300 ik = ii, ii + ib - 1
11218 dummy = dcmplx( pb_drand( 0 ),
11219 $ pb_drand( 0 ) )
11220 300 CONTINUE
11221*
11222 ELSE IF( lcmtr.GE.low ) THEN
11223*
11224 jtmp = jk - jj + 1
11225 mnb = max( 0, -lcmtr )
11226*
11227 IF( jtmp.LE.min( mnb, jb ) ) THEN
11228*
11229 DO 310 ik = ii, ii + ib - 1
11230 a( ik, jk ) = dcmplx( pb_drand( 0 ),
11231 $ pb_drand( 0 ) )
11232 310 CONTINUE
11233*
11234 ELSE IF( ( jtmp.GE.( mnb + 1 ) ) .AND.
11235 $ ( jtmp.LE.min( ib-lcmtr, jb ) ) ) THEN
11236*
11237 itmp = ii + jtmp + lcmtr - 1
11238*
11239 DO 320 ik = ii, itmp - 1
11240 dummy = dcmplx( pb_drand( 0 ),
11241 $ pb_drand( 0 ) )
11242 320 CONTINUE
11243*
11244 IF( itmp.LE.( ii + ib - 1 ) ) THEN
11245 dummy = dcmplx( pb_drand( 0 ),
11246 $ -pb_drand( 0 ) )
11247 a( itmp, jk ) = dcmplx( dble( dummy ),
11248 $ zero )
11249 END IF
11250*
11251 DO 330 ik = itmp + 1, ii + ib - 1
11252 a( ik, jk ) = dcmplx( pb_drand( 0 ),
11253 $ pb_drand( 0 ) )
11254 330 CONTINUE
11255*
11256 END IF
11257*
11258 ELSE
11259*
11260 DO 340 ik = ii, ii + ib - 1
11261 a( ik, jk ) = dcmplx( pb_drand( 0 ),
11262 $ pb_drand( 0 ) )
11263 340 CONTINUE
11264*
11265 END IF
11266*
11267 ii = ii + ib
11268*
11269 IF( iblk.EQ.1 ) THEN
11270*
11271* Jump IMBLOC + ( NPROW - 1 ) * MB rows
11272*
11273 lcmtr = lcmtr - jmp( jmp_npimbloc )
11274 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib1,
11275 $ ib0 )
11276*
11277 ELSE
11278*
11279* Jump NPROW * MB rows
11280*
11281 lcmtr = lcmtr - jmp( jmp_npmb )
11282 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib1,
11283 $ ib0 )
11284*
11285 END IF
11286*
11287 ib1( 1 ) = ib0( 1 )
11288 ib1( 2 ) = ib0( 2 )
11289*
11290 350 CONTINUE
11291*
11292* Jump one column
11293*
11294 CALL pb_jumpit( imuladd( 1, jmp_col ), ib2, ib0 )
11295*
11296 ib1( 1 ) = ib0( 1 )
11297 ib1( 2 ) = ib0( 2 )
11298 ib2( 1 ) = ib0( 1 )
11299 ib2( 2 ) = ib0( 2 )
11300*
11301 360 CONTINUE
11302*
11303 jj = jj + jb
11304*
11305 IF( jblk.EQ.1 ) THEN
11306*
11307* Jump INBLOC + ( NPCOL - 1 ) * NB columns
11308*
11309 lcmtc = lcmtc + jmp( jmp_nqinbloc )
11310 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib3, ib0 )
11311*
11312 ELSE
11313*
11314* Jump NPCOL * NB columns
11315*
11316 lcmtc = lcmtc + jmp( jmp_nqnb )
11317 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib3, ib0 )
11318*
11319 END IF
11320*
11321 ib1( 1 ) = ib0( 1 )
11322 ib1( 2 ) = ib0( 2 )
11323 ib2( 1 ) = ib0( 1 )
11324 ib2( 2 ) = ib0( 2 )
11325 ib3( 1 ) = ib0( 1 )
11326 ib3( 2 ) = ib0( 2 )
11327*
11328 370 CONTINUE
11329*
11330 ELSE
11331*
11332* generate upper trapezoidal part
11333*
11334 ii = 1
11335 lcmtr = lcmt00
11336*
11337 DO 450 iblk = 1, mblks
11338*
11339 IF( iblk.EQ.1 ) THEN
11340 ib = imbloc
11341 upp = imbloc - 1
11342 ELSE IF( iblk.EQ.mblks ) THEN
11343 ib = lmbloc
11344 upp = mb - 1
11345 ELSE
11346 ib = mb
11347 upp = mb - 1
11348 END IF
11349*
11350 DO 440 ik = ii, ii + ib - 1
11351*
11352 jj = 1
11353 lcmtc = lcmtr
11354*
11355 DO 430 jblk = 1, nblks
11356*
11357 IF( jblk.EQ.1 ) THEN
11358 jb = inbloc
11359 low = 1 - inbloc
11360 ELSE IF( jblk.EQ.nblks ) THEN
11361 jb = lnbloc
11362 low = 1 - nb
11363 ELSE
11364 jb = nb
11365 low = 1 - nb
11366 END IF
11367*
11368* Blocks are IB by JB
11369*
11370 IF( lcmtc.LT.low ) THEN
11371*
11372 DO 380 jk = jj, jj + jb - 1
11373 dummy = dcmplx( pb_drand( 0 ),
11374 $ -pb_drand( 0 ) )
11375 380 CONTINUE
11376*
11377 ELSE IF( lcmtc.LE.upp ) THEN
11378*
11379 itmp = ik - ii + 1
11380 mnb = max( 0, lcmtc )
11381*
11382 IF( itmp.LE.min( mnb, ib ) ) THEN
11383*
11384 DO 390 jk = jj, jj + jb - 1
11385 a( ik, jk ) = dcmplx( pb_drand( 0 ),
11386 $ -pb_drand( 0 ) )
11387 390 CONTINUE
11388*
11389 ELSE IF( ( itmp.GE.( mnb + 1 ) ) .AND.
11390 $ ( itmp.LE.min( jb+lcmtc, ib ) ) ) THEN
11391*
11392 jtmp = jj + itmp - lcmtc - 1
11393*
11394 DO 400 jk = jj, jtmp - 1
11395 dummy = dcmplx( pb_drand( 0 ),
11396 $ -pb_drand( 0 ) )
11397 400 CONTINUE
11398*
11399 IF( jtmp.LE.( jj + jb - 1 ) ) THEN
11400 dummy = dcmplx( pb_drand( 0 ),
11401 $ -pb_drand( 0 ) )
11402 a( ik, jtmp ) = dcmplx( dble( dummy ),
11403 $ zero )
11404 END IF
11405*
11406 DO 410 jk = jtmp + 1, jj + jb - 1
11407 a( ik, jk ) = dcmplx( pb_drand( 0 ),
11408 $ -pb_drand( 0 ) )
11409 410 CONTINUE
11410*
11411 END IF
11412*
11413 ELSE
11414*
11415 DO 420 jk = jj, jj + jb - 1
11416 a( ik, jk ) = dcmplx( pb_drand( 0 ),
11417 $ -pb_drand( 0 ) )
11418 420 CONTINUE
11419*
11420 END IF
11421*
11422 jj = jj + jb
11423*
11424 IF( jblk.EQ.1 ) THEN
11425*
11426* Jump INBLOC + ( NPCOL - 1 ) * NB columns
11427*
11428 lcmtc = lcmtc + jmp( jmp_nqinbloc )
11429 CALL pb_jumpit( imuladd( 1, jmp_nqinbloc ), ib1,
11430 $ ib0 )
11431*
11432 ELSE
11433*
11434* Jump NPCOL * NB columns
11435*
11436 lcmtc = lcmtc + jmp( jmp_nqnb )
11437 CALL pb_jumpit( imuladd( 1, jmp_nqnb ), ib1,
11438 $ ib0 )
11439*
11440 END IF
11441*
11442 ib1( 1 ) = ib0( 1 )
11443 ib1( 2 ) = ib0( 2 )
11444*
11445 430 CONTINUE
11446*
11447* Jump one row
11448*
11449 CALL pb_jumpit( imuladd( 1, jmp_row ), ib2, ib0 )
11450*
11451 ib1( 1 ) = ib0( 1 )
11452 ib1( 2 ) = ib0( 2 )
11453 ib2( 1 ) = ib0( 1 )
11454 ib2( 2 ) = ib0( 2 )
11455*
11456 440 CONTINUE
11457*
11458 ii = ii + ib
11459*
11460 IF( iblk.EQ.1 ) THEN
11461*
11462* Jump IMBLOC + ( NPROW - 1 ) * MB rows
11463*
11464 lcmtr = lcmtr - jmp( jmp_npimbloc )
11465 CALL pb_jumpit( imuladd( 1, jmp_npimbloc ), ib3, ib0 )
11466*
11467 ELSE
11468*
11469* Jump NPROW * MB rows
11470*
11471 lcmtr = lcmtr - jmp( jmp_npmb )
11472 CALL pb_jumpit( imuladd( 1, jmp_npmb ), ib3, ib0 )
11473*
11474 END IF
11475*
11476 ib1( 1 ) = ib0( 1 )
11477 ib1( 2 ) = ib0( 2 )
11478 ib2( 1 ) = ib0( 1 )
11479 ib2( 2 ) = ib0( 2 )
11480 ib3( 1 ) = ib0( 1 )
11481 ib3( 2 ) = ib0( 2 )
11482*
11483 450 CONTINUE
11484*
11485 END IF
11486*
11487 END IF
11488*
11489 RETURN
11490*
11491* End of PB_ZLAGEN
11492*
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53
pb_jumpit
subroutine pb_jumpit(muladd, irann, iranm)
Definition pblastst.f:4822

◆ pb_zlascal()

subroutine pb_zlascal ( character*1 uplo,
integer m,
integer n,
integer ioffd,
complex*16 alpha,
complex*16, dimension( lda, * ) a,
integer lda )

Definition at line 10245 of file pzblastst.f.

10246*
10247* -- PBLAS test routine (version 2.0) --
10248* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
10249* and University of California, Berkeley.
10250* April 1, 1998
10251*
10252* .. Scalar Arguments ..
10253 CHARACTER*1 UPLO
10254 INTEGER IOFFD, LDA, M, N
10255 COMPLEX*16 ALPHA
10256* ..
10257* .. Array Arguments ..
10258 COMPLEX*16 A( LDA, * )
10259* ..
10260*
10261* Purpose
10262* =======
10263*
10264* PB_ZLASCAL scales a two-dimensional array A by the scalar alpha.
10265*
10266* Arguments
10267* =========
10268*
10269* UPLO (input) CHARACTER*1
10270* On entry, UPLO specifies which trapezoidal part of the ar-
10271* ray A is to be scaled as follows:
10272* = 'L' or 'l': the lower trapezoid of A is scaled,
10273* = 'U' or 'u': the upper trapezoid of A is scaled,
10274* = 'D' or 'd': diagonal specified by IOFFD is scaled,
10275* Otherwise: all of the array A is scaled.
10276*
10277* M (input) INTEGER
10278* On entry, M specifies the number of rows of the array A. M
10279* must be at least zero.
10280*
10281* N (input) INTEGER
10282* On entry, N specifies the number of columns of the array A.
10283* N must be at least zero.
10284*
10285* IOFFD (input) INTEGER
10286* On entry, IOFFD specifies the position of the offdiagonal de-
10287* limiting the upper and lower trapezoidal part of A as follows
10288* (see the notes below):
10289*
10290* IOFFD = 0 specifies the main diagonal A( i, i ),
10291* with i = 1 ... MIN( M, N ),
10292* IOFFD > 0 specifies the subdiagonal A( i+IOFFD, i ),
10293* with i = 1 ... MIN( M-IOFFD, N ),
10294* IOFFD < 0 specifies the superdiagonal A( i, i-IOFFD ),
10295* with i = 1 ... MIN( M, N+IOFFD ).
10296*
10297* ALPHA (input) COMPLEX*16
10298* On entry, ALPHA specifies the scalar alpha.
10299*
10300* A (input/output) COMPLEX*16 array
10301* On entry, A is an array of dimension (LDA,N). Before entry
10302* with UPLO = 'U' or 'u', the leading m by n part of the array
10303* A must contain the upper trapezoidal part of the matrix as
10304* specified by IOFFD to be scaled, and the strictly lower tra-
10305* pezoidal part of A is not referenced; When UPLO = 'L' or 'l',
10306* the leading m by n part of the array A must contain the lower
10307* trapezoidal part of the matrix as specified by IOFFD to be
10308* scaled, and the strictly upper trapezoidal part of A is not
10309* referenced. On exit, the entries of the trapezoid part of A
10310* determined by UPLO and IOFFD are scaled.
10311*
10312* LDA (input) INTEGER
10313* On entry, LDA specifies the leading dimension of the array A.
10314* LDA must be at least max( 1, M ).
10315*
10316* Notes
10317* =====
10318* N N
10319* ---------------------------- -----------
10320* | d | | |
10321* M | d 'U' | | 'U' |
10322* | 'L' 'D' | |d |
10323* | d | M | d |
10324* ---------------------------- | 'D' |
10325* | d |
10326* IOFFD < 0 | 'L' d |
10327* | d|
10328* N | |
10329* ----------- -----------
10330* | d 'U'|
10331* | d | IOFFD > 0
10332* M | 'D' |
10333* | d| N
10334* | 'L' | ----------------------------
10335* | | | 'U' |
10336* | | |d |
10337* | | | 'D' |
10338* | | | d |
10339* | | |'L' d |
10340* ----------- ----------------------------
10341*
10342* -- Written on April 1, 1998 by
10343* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
10344*
10345* =====================================================================
10346*
10347* .. Local Scalars ..
10348 INTEGER I, J, JTMP, MN
10349* ..
10350* .. External Functions ..
10351 LOGICAL LSAME
10352 EXTERNAL lsame
10353* ..
10354* .. Intrinsic Functions ..
10355 INTRINSIC max, min
10356* ..
10357* .. Executable Statements ..
10358*
10359* Quick return if possible
10360*
10361 IF( m.LE.0 .OR. n.LE.0 )
10362 $ RETURN
10363*
10364* Start the operations
10365*
10366 IF( lsame( uplo, 'L' ) ) THEN
10367*
10368* Scales the lower triangular part of the array by ALPHA.
10369*
10370 mn = max( 0, -ioffd )
10371 DO 20 j = 1, min( mn, n )
10372 DO 10 i = 1, m
10373 a( i, j ) = alpha * a( i, j )
10374 10 CONTINUE
10375 20 CONTINUE
10376 DO 40 j = mn + 1, min( m - ioffd, n )
10377 DO 30 i = j + ioffd, m
10378 a( i, j ) = alpha * a( i, j )
10379 30 CONTINUE
10380 40 CONTINUE
10381*
10382 ELSE IF( lsame( uplo, 'U' ) ) THEN
10383*
10384* Scales the upper triangular part of the array by ALPHA.
10385*
10386 mn = min( m - ioffd, n )
10387 DO 60 j = max( 0, -ioffd ) + 1, mn
10388 DO 50 i = 1, j + ioffd
10389 a( i, j ) = alpha * a( i, j )
10390 50 CONTINUE
10391 60 CONTINUE
10392 DO 80 j = max( 0, mn ) + 1, n
10393 DO 70 i = 1, m
10394 a( i, j ) = alpha * a( i, j )
10395 70 CONTINUE
10396 80 CONTINUE
10397*
10398 ELSE IF( lsame( uplo, 'D' ) ) THEN
10399*
10400* Scales the diagonal entries by ALPHA.
10401*
10402 DO 90 j = max( 0, -ioffd ) + 1, min( m - ioffd, n )
10403 jtmp = j + ioffd
10404 a( jtmp, j ) = alpha * a( jtmp, j )
10405 90 CONTINUE
10406*
10407 ELSE
10408*
10409* Scales the entire array by ALPHA.
10410*
10411 DO 110 j = 1, n
10412 DO 100 i = 1, m
10413 a( i, j ) = alpha * a( i, j )
10414 100 CONTINUE
10415 110 CONTINUE
10416*
10417 END IF
10418*
10419 RETURN
10420*
10421* End of PB_ZLASCAL
10422*
alpha
#define alpha
Definition eval.h:35

◆ pb_zlaset()

subroutine pb_zlaset ( character*1 uplo,
integer m,
integer n,
integer ioffd,
complex*16 alpha,
complex*16 beta,
complex*16, dimension( lda, * ) a,
integer lda )

Definition at line 10048 of file pzblastst.f.

10049*
10050* -- PBLAS test routine (version 2.0) --
10051* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
10052* and University of California, Berkeley.
10053* April 1, 1998
10054*
10055* .. Scalar Arguments ..
10056 CHARACTER*1 UPLO
10057 INTEGER IOFFD, LDA, M, N
10058 COMPLEX*16 ALPHA, BETA
10059* ..
10060* .. Array Arguments ..
10061 COMPLEX*16 A( LDA, * )
10062* ..
10063*
10064* Purpose
10065* =======
10066*
10067* PB_ZLASET initializes a two-dimensional array A to beta on the diago-
10068* nal specified by IOFFD and alpha on the offdiagonals.
10069*
10070* Arguments
10071* =========
10072*
10073* UPLO (global input) CHARACTER*1
10074* On entry, UPLO specifies which trapezoidal part of the ar-
10075* ray A is to be set as follows:
10076* = 'L' or 'l': Lower triangular part is set; the strictly
10077* upper triangular part of A is not changed,
10078* = 'U' or 'u': Upper triangular part is set; the strictly
10079* lower triangular part of A is not changed,
10080* = 'D' or 'd' Only the diagonal of A is set,
10081* Otherwise: All of the array A is set.
10082*
10083* M (input) INTEGER
10084* On entry, M specifies the number of rows of the array A. M
10085* must be at least zero.
10086*
10087* N (input) INTEGER
10088* On entry, N specifies the number of columns of the array A.
10089* N must be at least zero.
10090*
10091* IOFFD (input) INTEGER
10092* On entry, IOFFD specifies the position of the offdiagonal de-
10093* limiting the upper and lower trapezoidal part of A as follows
10094* (see the notes below):
10095*
10096* IOFFD = 0 specifies the main diagonal A( i, i ),
10097* with i = 1 ... MIN( M, N ),
10098* IOFFD > 0 specifies the subdiagonal A( i+IOFFD, i ),
10099* with i = 1 ... MIN( M-IOFFD, N ),
10100* IOFFD < 0 specifies the superdiagonal A( i, i-IOFFD ),
10101* with i = 1 ... MIN( M, N+IOFFD ).
10102*
10103* ALPHA (input) COMPLEX*16
10104* On entry, ALPHA specifies the value to which the offdiagonal
10105* array elements are set to.
10106*
10107* BETA (input) COMPLEX*16
10108* On entry, BETA specifies the value to which the diagonal ar-
10109* ray elements are set to.
10110*
10111* A (input/output) COMPLEX*16 array
10112* On entry, A is an array of dimension (LDA,N). Before entry
10113* with UPLO = 'U' or 'u', the leading m by n part of the array
10114* A must contain the upper trapezoidal part of the matrix as
10115* specified by IOFFD to be set, and the strictly lower trape-
10116* zoidal part of A is not referenced; When IUPLO = 'L' or 'l',
10117* the leading m by n part of the array A must contain the
10118* lower trapezoidal part of the matrix as specified by IOFFD to
10119* be set, and the strictly upper trapezoidal part of A is
10120* not referenced.
10121*
10122* LDA (input) INTEGER
10123* On entry, LDA specifies the leading dimension of the array A.
10124* LDA must be at least max( 1, M ).
10125*
10126* Notes
10127* =====
10128* N N
10129* ---------------------------- -----------
10130* | d | | |
10131* M | d 'U' | | 'U' |
10132* | 'L' 'D' | |d |
10133* | d | M | d |
10134* ---------------------------- | 'D' |
10135* | d |
10136* IOFFD < 0 | 'L' d |
10137* | d|
10138* N | |
10139* ----------- -----------
10140* | d 'U'|
10141* | d | IOFFD > 0
10142* M | 'D' |
10143* | d| N
10144* | 'L' | ----------------------------
10145* | | | 'U' |
10146* | | |d |
10147* | | | 'D' |
10148* | | | d |
10149* | | |'L' d |
10150* ----------- ----------------------------
10151*
10152* -- Written on April 1, 1998 by
10153* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
10154*
10155* =====================================================================
10156*
10157* .. Local Scalars ..
10158 INTEGER I, J, JTMP, MN
10159* ..
10160* .. External Functions ..
10161 LOGICAL LSAME
10162 EXTERNAL lsame
10163* ..
10164* .. Intrinsic Functions ..
10165 INTRINSIC max, min
10166* ..
10167* .. Executable Statements ..
10168*
10169* Quick return if possible
10170*
10171 IF( m.LE.0 .OR. n.LE.0 )
10172 $ RETURN
10173*
10174* Start the operations
10175*
10176 IF( lsame( uplo, 'L' ) ) THEN
10177*
10178* Set the diagonal to BETA and the strictly lower triangular
10179* part of the array to ALPHA.
10180*
10181 mn = max( 0, -ioffd )
10182 DO 20 j = 1, min( mn, n )
10183 DO 10 i = 1, m
10184 a( i, j ) = alpha
10185 10 CONTINUE
10186 20 CONTINUE
10187 DO 40 j = mn + 1, min( m - ioffd, n )
10188 jtmp = j + ioffd
10189 a( jtmp, j ) = beta
10190 DO 30 i = jtmp + 1, m
10191 a( i, j ) = alpha
10192 30 CONTINUE
10193 40 CONTINUE
10194*
10195 ELSE IF( lsame( uplo, 'U' ) ) THEN
10196*
10197* Set the diagonal to BETA and the strictly upper triangular
10198* part of the array to ALPHA.
10199*
10200 mn = min( m - ioffd, n )
10201 DO 60 j = max( 0, -ioffd ) + 1, mn
10202 jtmp = j + ioffd
10203 DO 50 i = 1, jtmp - 1
10204 a( i, j ) = alpha
10205 50 CONTINUE
10206 a( jtmp, j ) = beta
10207 60 CONTINUE
10208 DO 80 j = max( 0, mn ) + 1, n
10209 DO 70 i = 1, m
10210 a( i, j ) = alpha
10211 70 CONTINUE
10212 80 CONTINUE
10213*
10214 ELSE IF( lsame( uplo, 'D' ) ) THEN
10215*
10216* Set the array to BETA on the diagonal.
10217*
10218 DO 90 j = max( 0, -ioffd ) + 1, min( m - ioffd, n )
10219 a( j + ioffd, j ) = beta
10220 90 CONTINUE
10221*
10222 ELSE
10223*
10224* Set the array to BETA on the diagonal and ALPHA on the
10225* offdiagonal.
10226*
10227 DO 110 j = 1, n
10228 DO 100 i = 1, m
10229 a( i, j ) = alpha
10230 100 CONTINUE
10231 110 CONTINUE
10232 IF( alpha.NE.beta .AND. ioffd.LT.m .AND. ioffd.GT.-n ) THEN
10233 DO 120 j = max( 0, -ioffd ) + 1, min( m - ioffd, n )
10234 a( j + ioffd, j ) = beta
10235 120 CONTINUE
10236 END IF
10237*
10238 END IF
10239*
10240 RETURN
10241*
10242* End of PB_ZLASET
10243*

◆ pdlamch()

double precision function pdlamch ( integer ictxt,
character*1 cmach )

Definition at line 7455 of file pzblastst.f.

7456*
7457* -- PBLAS test routine (version 2.0) --
7458* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
7459* and University of California, Berkeley.
7460* April 1, 1998
7461*
7462* .. Scalar Arguments ..
7463 CHARACTER*1 CMACH
7464 INTEGER ICTXT
7465* ..
7466*
7467* Purpose
7468* =======
7469*
7470*
7471* .. Local Scalars ..
7472 CHARACTER*1 TOP
7473 INTEGER IDUMM
7474 DOUBLE PRECISION TEMP
7475* ..
7476* .. External Subroutines ..
7477 EXTERNAL dgamn2d, dgamx2d, pb_topget
7478* ..
7479* .. External Functions ..
7480 LOGICAL LSAME
7481 DOUBLE PRECISION DLAMCH
7482 EXTERNAL dlamch, lsame
7483* ..
7484* .. Executable Statements ..
7485*
7486 temp = dlamch( cmach )
7487*
7488 IF( lsame( cmach, 'E' ).OR.lsame( cmach, 'S' ).OR.
7489 $ lsame( cmach, 'M' ).OR.lsame( cmach, 'U' ) ) THEN
7490 CALL pb_topget( ictxt, 'Combine', 'All', top )
7491 idumm = 0
7492 CALL dgamx2d( ictxt, 'All', top, 1, 1, temp, 1, idumm,
7493 $ idumm, -1, -1, idumm )
7494 ELSE IF( lsame( cmach, 'L' ).OR.lsame( cmach, 'O' ) ) THEN
7495 CALL pb_topget( ictxt, 'Combine', 'All', top )
7496 idumm = 0
7497 CALL dgamn2d( ictxt, 'All', top, 1, 1, temp, 1, idumm,
7498 $ idumm, -1, -1, idumm )
7499 END IF
7500*
7501 pdlamch = temp
7502*
7503 RETURN
7504*
7505* End of PDLAMCH
7506*
dlamch
double precision function dlamch(cmach)
DLAMCH
Definition dlamch.f:69
pdlamch
double precision function pdlamch(ictxt, cmach)
Definition pzblastst.f:7456

◆ pzcallsub()

subroutine pzcallsub ( external subptr,
integer scode )

Definition at line 2182 of file pzblastst.f.

2183*
2184* -- PBLAS test routine (version 2.0) --
2185* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2186* and University of California, Berkeley.
2187* April 1, 1998
2188*
2189* .. Scalar Arguments ..
2190 INTEGER SCODE
2191* ..
2192* .. Subroutine Arguments ..
2193 EXTERNAL subptr
2194* ..
2195*
2196* Purpose
2197* =======
2198*
2199* PZCALLSUB calls the subroutine SUBPTR with the calling sequence iden-
2200* tified by SCODE.
2201*
2202* Notes
2203* =====
2204*
2205* A description vector is associated with each 2D block-cyclicly dis-
2206* tributed matrix. This vector stores the information required to
2207* establish the mapping between a matrix entry and its corresponding
2208* process and memory location.
2209*
2210* In the following comments, the character _ should be read as
2211* "of the distributed matrix". Let A be a generic term for any 2D
2212* block cyclicly distributed matrix. Its description vector is DESCA:
2213*
2214* NOTATION STORED IN EXPLANATION
2215* ---------------- --------------- ------------------------------------
2216* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2217* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2218* the NPROW x NPCOL BLACS process grid
2219* A is distributed over. The context
2220* itself is global, but the handle
2221* (the integer value) may vary.
2222* M_A (global) DESCA( M_ ) The number of rows in the distribu-
2223* ted matrix A, M_A >= 0.
2224* N_A (global) DESCA( N_ ) The number of columns in the distri-
2225* buted matrix A, N_A >= 0.
2226* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2227* block of the matrix A, IMB_A > 0.
2228* INB_A (global) DESCA( INB_ ) The number of columns of the upper
2229* left block of the matrix A,
2230* INB_A > 0.
2231* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2232* bute the last M_A-IMB_A rows of A,
2233* MB_A > 0.
2234* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2235* bute the last N_A-INB_A columns of
2236* A, NB_A > 0.
2237* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2238* row of the matrix A is distributed,
2239* NPROW > RSRC_A >= 0.
2240* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2241* first column of A is distributed.
2242* NPCOL > CSRC_A >= 0.
2243* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2244* array storing the local blocks of
2245* the distributed matrix A,
2246* IF( Lc( 1, N_A ) > 0 )
2247* LLD_A >= MAX( 1, Lr( 1, M_A ) )
2248* ELSE
2249* LLD_A >= 1.
2250*
2251* Let K be the number of rows of a matrix A starting at the global in-
2252* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2253* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2254* receive if these K rows were distributed over NPROW processes. If K
2255* is the number of columns of a matrix A starting at the global index
2256* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2257* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2258* these K columns were distributed over NPCOL processes.
2259*
2260* The values of Lr() and Lc() may be determined via a call to the func-
2261* tion PB_NUMROC:
2262* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2263* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2264*
2265* Arguments
2266* =========
2267*
2268* SUBPTR (global input) SUBROUTINE
2269* On entry, SUBPTR is a subroutine. SUBPTR must be declared
2270* EXTERNAL in the calling subroutine.
2271*
2272* SCODE (global input) INTEGER
2273* On entry, SCODE specifies the calling sequence code.
2274*
2275* Calling sequence encodings
2276* ==========================
2277*
2278* code Formal argument list Examples
2279*
2280* 11 (n, v1,v2) _SWAP, _COPY
2281* 12 (n,s1, v1 ) _SCAL, _SCAL
2282* 13 (n,s1, v1,v2) _AXPY, _DOT_
2283* 14 (n,s1,i1,v1 ) _AMAX
2284* 15 (n,u1, v1 ) _ASUM, _NRM2
2285*
2286* 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV
2287* 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV
2288* 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV
2289* 24 ( m,n,s1,v1,v2,m1) _GER_
2290* 25 (uplo, n,s1,v1, m1) _SYR
2291* 26 (uplo, n,u1,v1, m1) _HER
2292* 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2
2293*
2294* 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM
2295* 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM
2296* 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK
2297* 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK
2298* 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K
2299* 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K
2300* 37 ( m,n, s1,m1, s2,m3) _TRAN_
2301* 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM
2302* 39 ( trans, m,n, s1,m1, s2,m3) _GEADD
2303* 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD
2304*
2305* -- Written on April 1, 1998 by
2306* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2307*
2308* =====================================================================
2309*
2310* .. Parameters ..
2311 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2312 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2313 $ RSRC_
2314 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
2315 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
2316 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
2317 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
2318* ..
2319* .. Common Blocks ..
2320 CHARACTER*1 DIAG, SIDE, TRANSA, TRANSB, UPLO
2321 INTEGER IA, IB, IC, INCX, INCY, ISCLR, IX, IY, JA, JB,
2322 $ JC, JX, JY, KDIM, MDIM, NDIM
2323 DOUBLE PRECISION USCLR
2324 COMPLEX*16 SCLR
2325 INTEGER DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ),
2326 $ DESCX( DLEN_ ), DESCY( DLEN_ )
2327 COMPLEX*16 A( 2, 2 ), B( 2, 2 ), C( 2, 2 ), X( 2 ), Y( 2 )
2328 COMMON /pblasc/diag, side, transa, transb, uplo
2329 COMMON /pblasd/desca, descb, descc, descx, descy
2330 COMMON /pblasi/ia, ib, ic, incx, incy, isclr, ix, iy,
2331 $ ja, jb, jc, jx, jy
2332 COMMON /pblasm/a, b, c
2333 COMMON /pblasn/kdim, mdim, ndim
2334 COMMON /pblass/sclr, usclr
2335 COMMON /pblasv/x, y
2336* ..
2337* .. Executable Statements ..
2338*
2339* Level 1 PBLAS
2340*
2341 IF( scode.EQ.11 ) THEN
2342*
2343 CALL subptr( ndim, x, ix, jx, descx, incx, y, iy, jy, descy,
2344 $ incy )
2345*
2346 ELSE IF( scode.EQ.12 ) THEN
2347*
2348 CALL subptr( ndim, sclr, x, ix, jx, descx, incx )
2349*
2350 ELSE IF( scode.EQ.13 ) THEN
2351*
2352 CALL subptr( ndim, sclr, x, ix, jx, descx, incx, y, iy, jy,
2353 $ descy, incy )
2354*
2355 ELSE IF( scode.EQ.14 ) THEN
2356*
2357 CALL subptr( ndim, sclr, isclr, x, ix, jx, descx, incx )
2358*
2359 ELSE IF( scode.EQ.15 ) THEN
2360*
2361 CALL subptr( ndim, usclr, x, ix, jx, descx, incx )
2362*
2363* Level 2 PBLAS
2364*
2365 ELSE IF( scode.EQ.21 ) THEN
2366*
2367 CALL subptr( transa, mdim, ndim, sclr, a, ia, ja, desca, x, ix,
2368 $ jx, descx, incx, sclr, y, iy, jy, descy, incy )
2369*
2370 ELSE IF( scode.EQ.22 ) THEN
2371*
2372 CALL subptr( uplo, ndim, sclr, a, ia, ja, desca, x, ix, jx,
2373 $ descx, incx, sclr, y, iy, jy, descy, incy )
2374*
2375 ELSE IF( scode.EQ.23 ) THEN
2376*
2377 CALL subptr( uplo, transa, diag, ndim, a, ia, ja, desca, x, ix,
2378 $ jx, descx, incx )
2379*
2380 ELSE IF( scode.EQ.24 ) THEN
2381*
2382 CALL subptr( mdim, ndim, sclr, x, ix, jx, descx, incx, y, iy,
2383 $ jy, descy, incy, a, ia, ja, desca )
2384*
2385 ELSE IF( scode.EQ.25 ) THEN
2386*
2387 CALL subptr( uplo, ndim, sclr, x, ix, jx, descx, incx, a, ia,
2388 $ ja, desca )
2389*
2390 ELSE IF( scode.EQ.26 ) THEN
2391*
2392 CALL subptr( uplo, ndim, usclr, x, ix, jx, descx, incx, a, ia,
2393 $ ja, desca )
2394*
2395 ELSE IF( scode.EQ.27 ) THEN
2396*
2397 CALL subptr( uplo, ndim, sclr, x, ix, jx, descx, incx, y, iy,
2398 $ jy, descy, incy, a, ia, ja, desca )
2399*
2400* Level 3 PBLAS
2401*
2402 ELSE IF( scode.EQ.31 ) THEN
2403*
2404 CALL subptr( transa, transb, mdim, ndim, kdim, sclr, a, ia, ja,
2405 $ desca, b, ib, jb, descb, sclr, c, ic, jc, descc )
2406*
2407 ELSE IF( scode.EQ.32 ) THEN
2408*
2409 CALL subptr( side, uplo, mdim, ndim, sclr, a, ia, ja, desca, b,
2410 $ ib, jb, descb, sclr, c, ic, jc, descc )
2411*
2412 ELSE IF( scode.EQ.33 ) THEN
2413*
2414 CALL subptr( uplo, transa, ndim, kdim, sclr, a, ia, ja, desca,
2415 $ sclr, c, ic, jc, descc )
2416*
2417 ELSE IF( scode.EQ.34 ) THEN
2418*
2419 CALL subptr( uplo, transa, ndim, kdim, usclr, a, ia, ja, desca,
2420 $ usclr, c, ic, jc, descc )
2421*
2422 ELSE IF( scode.EQ.35 ) THEN
2423*
2424 CALL subptr( uplo, transa, ndim, kdim, sclr, a, ia, ja, desca,
2425 $ b, ib, jb, descb, sclr, c, ic, jc, descc )
2426*
2427 ELSE IF( scode.EQ.36 ) THEN
2428*
2429 CALL subptr( uplo, transa, ndim, kdim, sclr, a, ia, ja, desca,
2430 $ b, ib, jb, descb, usclr, c, ic, jc, descc )
2431*
2432 ELSE IF( scode.EQ.37 ) THEN
2433*
2434 CALL subptr( mdim, ndim, sclr, a, ia, ja, desca, sclr, c, ic,
2435 $ jc, descc )
2436*
2437 ELSE IF( scode.EQ.38 ) THEN
2438*
2439 CALL subptr( side, uplo, transa, diag, mdim, ndim, sclr, a, ia,
2440 $ ja, desca, b, ib, jb, descb )
2441*
2442 ELSE IF( scode.EQ.39 ) THEN
2443*
2444 CALL subptr( transa, mdim, ndim, sclr, a, ia, ja, desca, sclr,
2445 $ c, ic, jc, descc )
2446*
2447 ELSE IF( scode.EQ.40 ) THEN
2448*
2449 CALL subptr( uplo, transa, mdim, ndim, sclr, a, ia, ja, desca,
2450 $ sclr, c, ic, jc, descc )
2451*
2452 END IF
2453*
2454 RETURN
2455*
2456* End of PZCALLSUB
2457*
jc
subroutine jc(p, t, a, b, cm, cn, tref, tm, epsm, sigmam, jc_yield, tan_jc)
Definition sigeps106.F:339

◆ pzchkdim()

subroutine pzchkdim ( integer ictxt,
integer nout,
external subptr,
integer scode,
character*(*) sname,
character*1 argnam,
integer argpos )

Definition at line 757 of file pzblastst.f.

759*
760* -- PBLAS test routine (version 2.0) --
761* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
762* and University of California, Berkeley.
763* April 1, 1998
764*
765* .. Scalar Arguments ..
766 CHARACTER*1 ARGNAM
767 INTEGER ARGPOS, ICTXT, NOUT, SCODE
768* ..
769* .. Array Arguments ..
770 CHARACTER*(*) SNAME
771* ..
772* .. Subroutine Arguments ..
773 EXTERNAL subptr
774* ..
775*
776* Purpose
777* =======
778*
779* PZCHKDIM tests the dimension ARGNAM in any PBLAS routine.
780*
781* Notes
782* =====
783*
784* A description vector is associated with each 2D block-cyclicly dis-
785* tributed matrix. This vector stores the information required to
786* establish the mapping between a matrix entry and its corresponding
787* process and memory location.
788*
789* In the following comments, the character _ should be read as
790* "of the distributed matrix". Let A be a generic term for any 2D
791* block cyclicly distributed matrix. Its description vector is DESCA:
792*
793* NOTATION STORED IN EXPLANATION
794* ---------------- --------------- ------------------------------------
795* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
796* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
797* the NPROW x NPCOL BLACS process grid
798* A is distributed over. The context
799* itself is global, but the handle
800* (the integer value) may vary.
801* M_A (global) DESCA( M_ ) The number of rows in the distribu-
802* ted matrix A, M_A >= 0.
803* N_A (global) DESCA( N_ ) The number of columns in the distri-
804* buted matrix A, N_A >= 0.
805* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
806* block of the matrix A, IMB_A > 0.
807* INB_A (global) DESCA( INB_ ) The number of columns of the upper
808* left block of the matrix A,
809* INB_A > 0.
810* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
811* bute the last M_A-IMB_A rows of A,
812* MB_A > 0.
813* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
814* bute the last N_A-INB_A columns of
815* A, NB_A > 0.
816* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
817* row of the matrix A is distributed,
818* NPROW > RSRC_A >= 0.
819* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
820* first column of A is distributed.
821* NPCOL > CSRC_A >= 0.
822* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
823* array storing the local blocks of
824* the distributed matrix A,
825* IF( Lc( 1, N_A ) > 0 )
826* LLD_A >= MAX( 1, Lr( 1, M_A ) )
827* ELSE
828* LLD_A >= 1.
829*
830* Let K be the number of rows of a matrix A starting at the global in-
831* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
832* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
833* receive if these K rows were distributed over NPROW processes. If K
834* is the number of columns of a matrix A starting at the global index
835* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
836* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
837* these K columns were distributed over NPCOL processes.
838*
839* The values of Lr() and Lc() may be determined via a call to the func-
840* tion PB_NUMROC:
841* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
842* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
843*
844* Arguments
845* =========
846*
847* ICTXT (local input) INTEGER
848* On entry, ICTXT specifies the BLACS context handle, indica-
849* ting the global context of the operation. The context itself
850* is global, but the value of ICTXT is local.
851*
852* NOUT (global input) INTEGER
853* On entry, NOUT specifies the unit number for the output file.
854* When NOUT is 6, output to screen, when NOUT is 0, output to
855* stderr. NOUT is only defined for process 0.
856*
857* SUBPTR (global input) SUBROUTINE
858* On entry, SUBPTR is a subroutine. SUBPTR must be declared
859* EXTERNAL in the calling subroutine.
860*
861* SCODE (global input) INTEGER
862* On entry, SCODE specifies the calling sequence code.
863*
864* SNAME (global input) CHARACTER*(*)
865* On entry, SNAME specifies the subroutine name calling this
866* subprogram.
867*
868* ARGNAM (global input) CHARACTER*(*)
869* On entry, ARGNAM specifies the name of the dimension to be
870* checked. ARGNAM can either be 'M', 'N' or 'K'.
871*
872* ARGPOS (global input) INTEGER
873* On entry, ARGPOS indicates the position of the option ARGNAM
874* to be tested.
875*
876* -- Written on April 1, 1998 by
877* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
878*
879* =====================================================================
880*
881* .. Local Scalars ..
882 INTEGER INFOT
883* ..
884* .. External Subroutines ..
885 EXTERNAL pchkpbe, pzcallsub, pzsetpblas
886* ..
887* .. External Functions ..
888 LOGICAL LSAME
889 EXTERNAL lsame
890* ..
891* .. Common Blocks ..
892 INTEGER KDIM, MDIM, NDIM
893 COMMON /pblasn/kdim, mdim, ndim
894* ..
895* .. Executable Statements ..
896*
897* Reiniatilize the dummy arguments to correct values
898*
899 CALL pzsetpblas( ictxt )
900*
901 IF( lsame( argnam, 'M' ) ) THEN
902*
903* Generate bad MDIM
904*
905 mdim = -1
906*
907 ELSE IF( lsame( argnam, 'N' ) ) THEN
908*
909* Generate bad NDIM
910*
911 ndim = -1
912*
913 ELSE
914*
915* Generate bad KDIM
916*
917 kdim = -1
918*
919 END IF
920*
921* Set INFOT to the position of the bad dimension argument
922*
923 infot = argpos
924*
925* Call the PBLAS routine
926*
927 CALL pzcallsub( subptr, scode )
928 CALL pchkpbe( ictxt, nout, sname, infot )
929*
930 RETURN
931*
932* End of PZCHKDIM
933*
pchkpbe
subroutine pchkpbe(ictxt, nout, sname, infot)
Definition pblastst.f:1084
pzcallsub
subroutine pzcallsub(subptr, scode)
Definition pzblastst.f:2183
pzsetpblas
subroutine pzsetpblas(ictxt)
Definition pzblastst.f:1478

◆ pzchkmat()

subroutine pzchkmat ( integer ictxt,
integer nout,
external subptr,
integer scode,
character*(*) sname,
character*1 argnam,
integer argpos )

Definition at line 1675 of file pzblastst.f.

1677*
1678* -- PBLAS test routine (version 2.0) --
1679* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1680* and University of California, Berkeley.
1681* April 1, 1998
1682*
1683* .. Scalar Arguments ..
1684 CHARACTER*1 ARGNAM
1685 INTEGER ARGPOS, ICTXT, NOUT, SCODE
1686* ..
1687* .. Array Arguments ..
1688 CHARACTER*(*) SNAME
1689* ..
1690* .. Subroutine Arguments ..
1691 EXTERNAL subptr
1692* ..
1693*
1694* Purpose
1695* =======
1696*
1697* PZCHKMAT tests the matrix (or vector) ARGNAM in any PBLAS routine.
1698*
1699* Notes
1700* =====
1701*
1702* A description vector is associated with each 2D block-cyclicly dis-
1703* tributed matrix. This vector stores the information required to
1704* establish the mapping between a matrix entry and its corresponding
1705* process and memory location.
1706*
1707* In the following comments, the character _ should be read as
1708* "of the distributed matrix". Let A be a generic term for any 2D
1709* block cyclicly distributed matrix. Its description vector is DESCA:
1710*
1711* NOTATION STORED IN EXPLANATION
1712* ---------------- --------------- ------------------------------------
1713* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
1714* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
1715* the NPROW x NPCOL BLACS process grid
1716* A is distributed over. The context
1717* itself is global, but the handle
1718* (the integer value) may vary.
1719* M_A (global) DESCA( M_ ) The number of rows in the distribu-
1720* ted matrix A, M_A >= 0.
1721* N_A (global) DESCA( N_ ) The number of columns in the distri-
1722* buted matrix A, N_A >= 0.
1723* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
1724* block of the matrix A, IMB_A > 0.
1725* INB_A (global) DESCA( INB_ ) The number of columns of the upper
1726* left block of the matrix A,
1727* INB_A > 0.
1728* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
1729* bute the last M_A-IMB_A rows of A,
1730* MB_A > 0.
1731* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
1732* bute the last N_A-INB_A columns of
1733* A, NB_A > 0.
1734* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
1735* row of the matrix A is distributed,
1736* NPROW > RSRC_A >= 0.
1737* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
1738* first column of A is distributed.
1739* NPCOL > CSRC_A >= 0.
1740* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
1741* array storing the local blocks of
1742* the distributed matrix A,
1743* IF( Lc( 1, N_A ) > 0 )
1744* LLD_A >= MAX( 1, Lr( 1, M_A ) )
1745* ELSE
1746* LLD_A >= 1.
1747*
1748* Let K be the number of rows of a matrix A starting at the global in-
1749* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
1750* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
1751* receive if these K rows were distributed over NPROW processes. If K
1752* is the number of columns of a matrix A starting at the global index
1753* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
1754* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
1755* these K columns were distributed over NPCOL processes.
1756*
1757* The values of Lr() and Lc() may be determined via a call to the func-
1758* tion PB_NUMROC:
1759* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
1760* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
1761*
1762* Arguments
1763* =========
1764*
1765* ICTXT (local input) INTEGER
1766* On entry, ICTXT specifies the BLACS context handle, indica-
1767* ting the global context of the operation. The context itself
1768* is global, but the value of ICTXT is local.
1769*
1770* NOUT (global input) INTEGER
1771* On entry, NOUT specifies the unit number for the output file.
1772* When NOUT is 6, output to screen, when NOUT is 0, output to
1773* stderr. NOUT is only defined for process 0.
1774*
1775* SUBPTR (global input) SUBROUTINE
1776* On entry, SUBPTR is a subroutine. SUBPTR must be declared
1777* EXTERNAL in the calling subroutine.
1778*
1779* SCODE (global input) INTEGER
1780* On entry, SCODE specifies the calling sequence code.
1781*
1782* SNAME (global input) CHARACTER*(*)
1783* On entry, SNAME specifies the subroutine name calling this
1784* subprogram.
1785*
1786* ARGNAM (global input) CHARACTER*(*)
1787* On entry, ARGNAM specifies the name of the matrix or vector
1788* to be checked. ARGNAM can either be 'A', 'B' or 'C' when one
1789* wants to check a matrix, and 'X' or 'Y' for a vector.
1790*
1791* ARGPOS (global input) INTEGER
1792* On entry, ARGPOS indicates the position of the first argument
1793* of the matrix (or vector) ARGNAM.
1794*
1795* -- Written on April 1, 1998 by
1796* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1797*
1798* =====================================================================
1799*
1800* .. Parameters ..
1801 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
1802 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
1803 $ RSRC_
1804 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
1805 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
1806 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
1807 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
1808 INTEGER DESCMULT
1809 parameter( descmult = 100 )
1810* ..
1811* .. Local Scalars ..
1812 INTEGER I, INFOT, NPROW, NPCOL, MYROW, MYCOL
1813* ..
1814* .. External Subroutines ..
1815 EXTERNAL blacs_gridinfo, pchkpbe, pzcallsub, pzsetpblas
1816* ..
1817* .. External Functions ..
1818 LOGICAL LSAME
1819 EXTERNAL lsame
1820* ..
1821* .. Common Blocks ..
1822 INTEGER IA, IB, IC, INCX, INCY, ISCLR, IX, IY, JA, JB,
1823 $ JC, JX, JY
1824 INTEGER DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ),
1825 $ DESCX( DLEN_ ), DESCY( DLEN_ )
1826 COMMON /pblasd/desca, descb, descc, descx, descy
1827 COMMON /pblasi/ia, ib, ic, incx, incy, isclr, ix, iy,
1828 $ ja, jb, jc, jx, jy
1829* ..
1830* .. Executable Statements ..
1831*
1832 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
1833*
1834 IF( lsame( argnam, 'A' ) ) THEN
1835*
1836* Check IA. Set all other OK, bad IA
1837*
1838 CALL pzsetpblas( ictxt )
1839 ia = -1
1840 infot = argpos + 1
1841 CALL pzcallsub( subptr, scode )
1842 CALL pchkpbe( ictxt, nout, sname, infot )
1843*
1844* Check JA. Set all other OK, bad JA
1845*
1846 CALL pzsetpblas( ictxt )
1847 ja = -1
1848 infot = argpos + 2
1849 CALL pzcallsub( subptr, scode )
1850 CALL pchkpbe( ictxt, nout, sname, infot )
1851*
1852* Check DESCA. Set all other OK, bad DESCA
1853*
1854 DO 10 i = 1, dlen_
1855*
1856* Set I'th entry of DESCA to incorrect value, rest ok.
1857*
1858 CALL pzsetpblas( ictxt )
1859 desca( i ) = -2
1860 infot = ( ( argpos + 3 ) * descmult ) + i
1861 CALL pzcallsub( subptr, scode )
1862 CALL pchkpbe( ictxt, nout, sname, infot )
1863*
1864* Extra tests for RSRCA, CSRCA, LDA
1865*
1866 IF( ( i.EQ.rsrc_ ) .OR. ( i.EQ.csrc_ ) .OR.
1867 $ ( i.EQ.lld_ ) ) THEN
1868*
1869 CALL pzsetpblas( ictxt )
1870*
1871* Test RSRCA >= NPROW
1872*
1873 IF( i.EQ.rsrc_ )
1874 $ desca( i ) = nprow
1875*
1876* Test CSRCA >= NPCOL
1877*
1878 IF( i.EQ.csrc_ )
1879 $ desca( i ) = npcol
1880*
1881* Test LDA >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
1882*
1883 IF( i.EQ.lld_ ) THEN
1884 IF( myrow.EQ.0 .AND.mycol.EQ.0 ) THEN
1885 desca( i ) = 1
1886 ELSE
1887 desca( i ) = 0
1888 END IF
1889 END IF
1890*
1891 infot = ( ( argpos + 3 ) * descmult ) + i
1892 CALL pzcallsub( subptr, scode )
1893 CALL pchkpbe( ictxt, nout, sname, infot )
1894*
1895 END IF
1896*
1897 10 CONTINUE
1898*
1899 ELSE IF( lsame( argnam, 'B' ) ) THEN
1900*
1901* Check IB. Set all other OK, bad IB
1902*
1903 CALL pzsetpblas( ictxt )
1904 ib = -1
1905 infot = argpos + 1
1906 CALL pzcallsub( subptr, scode )
1907 CALL pchkpbe( ictxt, nout, sname, infot )
1908*
1909* Check JB. Set all other OK, bad JB
1910*
1911 CALL pzsetpblas( ictxt )
1912 jb = -1
1913 infot = argpos + 2
1914 CALL pzcallsub( subptr, scode )
1915 CALL pchkpbe( ictxt, nout, sname, infot )
1916*
1917* Check DESCB. Set all other OK, bad DESCB
1918*
1919 DO 20 i = 1, dlen_
1920*
1921* Set I'th entry of DESCB to incorrect value, rest ok.
1922*
1923 CALL pzsetpblas( ictxt )
1924 descb( i ) = -2
1925 infot = ( ( argpos + 3 ) * descmult ) + i
1926 CALL pzcallsub( subptr, scode )
1927 CALL pchkpbe( ictxt, nout, sname, infot )
1928*
1929* Extra tests for RSRCB, CSRCB, LDB
1930*
1931 IF( ( i.EQ.rsrc_ ) .OR. ( i.EQ.csrc_ ) .OR.
1932 $ ( i.EQ.lld_ ) ) THEN
1933*
1934 CALL pzsetpblas( ictxt )
1935*
1936* Test RSRCB >= NPROW
1937*
1938 IF( i.EQ.rsrc_ )
1939 $ descb( i ) = nprow
1940*
1941* Test CSRCB >= NPCOL
1942*
1943 IF( i.EQ.csrc_ )
1944 $ descb( i ) = npcol
1945*
1946* Test LDB >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
1947*
1948 IF( i.EQ.lld_ ) THEN
1949 IF( myrow.EQ.0 .AND.mycol.EQ.0 ) THEN
1950 descb( i ) = 1
1951 ELSE
1952 descb( i ) = 0
1953 END IF
1954 END IF
1955*
1956 infot = ( ( argpos + 3 ) * descmult ) + i
1957 CALL pzcallsub( subptr, scode )
1958 CALL pchkpbe( ictxt, nout, sname, infot )
1959*
1960 END IF
1961*
1962 20 CONTINUE
1963*
1964 ELSE IF( lsame( argnam, 'C' ) ) THEN
1965*
1966* Check IC. Set all other OK, bad IC
1967*
1968 CALL pzsetpblas( ictxt )
1969 ic = -1
1970 infot = argpos + 1
1971 CALL pzcallsub( subptr, scode )
1972 CALL pchkpbe( ictxt, nout, sname, infot )
1973*
1974* Check JC. Set all other OK, bad JC
1975*
1976 CALL pzsetpblas( ictxt )
1977 jc = -1
1978 infot = argpos + 2
1979 CALL pzcallsub( subptr, scode )
1980 CALL pchkpbe( ictxt, nout, sname, infot )
1981*
1982* Check DESCC. Set all other OK, bad DESCC
1983*
1984 DO 30 i = 1, dlen_
1985*
1986* Set I'th entry of DESCC to incorrect value, rest ok.
1987*
1988 CALL pzsetpblas( ictxt )
1989 descc( i ) = -2
1990 infot = ( ( argpos + 3 ) * descmult ) + i
1991 CALL pzcallsub( subptr, scode )
1992 CALL pchkpbe( ictxt, nout, sname, infot )
1993*
1994* Extra tests for RSRCC, CSRCC, LDC
1995*
1996 IF( ( i.EQ.rsrc_ ) .OR. ( i.EQ.csrc_ ) .OR.
1997 $ ( i.EQ.lld_ ) ) THEN
1998*
1999 CALL pzsetpblas( ictxt )
2000*
2001* Test RSRCC >= NPROW
2002*
2003 IF( i.EQ.rsrc_ )
2004 $ descc( i ) = nprow
2005*
2006* Test CSRCC >= NPCOL
2007*
2008 IF( i.EQ.csrc_ )
2009 $ descc( i ) = npcol
2010*
2011* Test LDC >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
2012*
2013 IF( i.EQ.lld_ ) THEN
2014 IF( myrow.EQ.0 .AND.mycol.EQ.0 ) THEN
2015 descc( i ) = 1
2016 ELSE
2017 descc( i ) = 0
2018 END IF
2019 END IF
2020*
2021 infot = ( ( argpos + 3 ) * descmult ) + i
2022 CALL pzcallsub( subptr, scode )
2023 CALL pchkpbe( ictxt, nout, sname, infot )
2024*
2025 END IF
2026*
2027 30 CONTINUE
2028*
2029 ELSE IF( lsame( argnam, 'X' ) ) THEN
2030*
2031* Check IX. Set all other OK, bad IX
2032*
2033 CALL pzsetpblas( ictxt )
2034 ix = -1
2035 infot = argpos + 1
2036 CALL pzcallsub( subptr, scode )
2037 CALL pchkpbe( ictxt, nout, sname, infot )
2038*
2039* Check JX. Set all other OK, bad JX
2040*
2041 CALL pzsetpblas( ictxt )
2042 jx = -1
2043 infot = argpos + 2
2044 CALL pzcallsub( subptr, scode )
2045 CALL pchkpbe( ictxt, nout, sname, infot )
2046*
2047* Check DESCX. Set all other OK, bad DESCX
2048*
2049 DO 40 i = 1, dlen_
2050*
2051* Set I'th entry of DESCX to incorrect value, rest ok.
2052*
2053 CALL pzsetpblas( ictxt )
2054 descx( i ) = -2
2055 infot = ( ( argpos + 3 ) * descmult ) + i
2056 CALL pzcallsub( subptr, scode )
2057 CALL pchkpbe( ictxt, nout, sname, infot )
2058*
2059* Extra tests for RSRCX, CSRCX, LDX
2060*
2061 IF( ( i.EQ.rsrc_ ) .OR. ( i.EQ.csrc_ ) .OR.
2062 $ ( i.EQ.lld_ ) ) THEN
2063*
2064 CALL pzsetpblas( ictxt )
2065*
2066* Test RSRCX >= NPROW
2067*
2068 IF( i.EQ.rsrc_ )
2069 $ descx( i ) = nprow
2070*
2071* Test CSRCX >= NPCOL
2072*
2073 IF( i.EQ.csrc_ )
2074 $ descx( i ) = npcol
2075*
2076* Test LDX >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
2077*
2078 IF( i.EQ.lld_ ) THEN
2079 IF( myrow.EQ.0 .AND.mycol.EQ.0 ) THEN
2080 descx( i ) = 1
2081 ELSE
2082 descx( i ) = 0
2083 END IF
2084 END IF
2085*
2086 infot = ( ( argpos + 3 ) * descmult ) + i
2087 CALL pzcallsub( subptr, scode )
2088 CALL pchkpbe( ictxt, nout, sname, infot )
2089*
2090 END IF
2091*
2092 40 CONTINUE
2093*
2094* Check INCX. Set all other OK, bad INCX
2095*
2096 CALL pzsetpblas( ictxt )
2097 incx = -1
2098 infot = argpos + 4
2099 CALL pzcallsub( subptr, scode )
2100 CALL pchkpbe( ictxt, nout, sname, infot )
2101*
2102 ELSE
2103*
2104* Check IY. Set all other OK, bad IY
2105*
2106 CALL pzsetpblas( ictxt )
2107 iy = -1
2108 infot = argpos + 1
2109 CALL pzcallsub( subptr, scode )
2110 CALL pchkpbe( ictxt, nout, sname, infot )
2111*
2112* Check JY. Set all other OK, bad JY
2113*
2114 CALL pzsetpblas( ictxt )
2115 jy = -1
2116 infot = argpos + 2
2117 CALL pzcallsub( subptr, scode )
2118 CALL pchkpbe( ictxt, nout, sname, infot )
2119*
2120* Check DESCY. Set all other OK, bad DESCY
2121*
2122 DO 50 i = 1, dlen_
2123*
2124* Set I'th entry of DESCY to incorrect value, rest ok.
2125*
2126 CALL pzsetpblas( ictxt )
2127 descy( i ) = -2
2128 infot = ( ( argpos + 3 ) * descmult ) + i
2129 CALL pzcallsub( subptr, scode )
2130 CALL pchkpbe( ictxt, nout, sname, infot )
2131*
2132* Extra tests for RSRCY, CSRCY, LDY
2133*
2134 IF( ( i.EQ.rsrc_ ) .OR. ( i.EQ.csrc_ ) .OR.
2135 $ ( i.EQ.lld_ ) ) THEN
2136*
2137 CALL pzsetpblas( ictxt )
2138*
2139* Test RSRCY >= NPROW
2140*
2141 IF( i.EQ.rsrc_ )
2142 $ descy( i ) = nprow
2143*
2144* Test CSRCY >= NPCOL
2145*
2146 IF( i.EQ.csrc_ )
2147 $ descy( i ) = npcol
2148*
2149* Test LDY >= MAX(1, PB_NUMROC(...)). Set to 1 as mat 2x2.
2150*
2151 IF( i.EQ.lld_ ) THEN
2152 IF( myrow.EQ.0 .AND.mycol.EQ.0 ) THEN
2153 descy( i ) = 1
2154 ELSE
2155 descy( i ) = 0
2156 END IF
2157 END IF
2158*
2159 infot = ( ( argpos + 3 ) * descmult ) + i
2160 CALL pzcallsub( subptr, scode )
2161 CALL pchkpbe( ictxt, nout, sname, infot )
2162*
2163 END IF
2164*
2165 50 CONTINUE
2166*
2167* Check INCY. Set all other OK, bad INCY
2168*
2169 CALL pzsetpblas( ictxt )
2170 incy = -1
2171 infot = argpos + 4
2172 CALL pzcallsub( subptr, scode )
2173 CALL pchkpbe( ictxt, nout, sname, infot )
2174*
2175 END IF
2176*
2177 RETURN
2178*
2179* End of PZCHKMAT
2180*

◆ pzchkmin()

subroutine pzchkmin ( double precision errmax,
integer m,
integer n,
complex*16, dimension( * ) a,
complex*16, dimension( * ) pa,
integer ia,
integer ja,
integer, dimension( * ) desca,
integer info )

Definition at line 3331 of file pzblastst.f.

3332*
3333* -- PBLAS test routine (version 2.0) --
3334* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3335* and University of California, Berkeley.
3336* April 1, 1998
3337*
3338* .. Scalar Arguments ..
3339 INTEGER IA, INFO, JA, M, N
3340 DOUBLE PRECISION ERRMAX
3341* ..
3342* .. Array Arguments ..
3343 INTEGER DESCA( * )
3344 COMPLEX*16 PA( * ), A( * )
3345* ..
3346*
3347* Purpose
3348* =======
3349*
3350* PZCHKMIN checks that the submatrix sub( PA ) remained unchanged. The
3351* local array entries are compared element by element, and their dif-
3352* ference is tested against 0.0 as well as the epsilon machine. Notice
3353* that this difference should be numerically exactly the zero machine,
3354* but because of the possible fluctuation of some of the data we flag-
3355* ged differently a difference less than twice the epsilon machine. The
3356* largest error is also returned.
3357*
3358* Notes
3359* =====
3360*
3361* A description vector is associated with each 2D block-cyclicly dis-
3362* tributed matrix. This vector stores the information required to
3363* establish the mapping between a matrix entry and its corresponding
3364* process and memory location.
3365*
3366* In the following comments, the character _ should be read as
3367* "of the distributed matrix". Let A be a generic term for any 2D
3368* block cyclicly distributed matrix. Its description vector is DESCA:
3369*
3370* NOTATION STORED IN EXPLANATION
3371* ---------------- --------------- ------------------------------------
3372* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
3373* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
3374* the NPROW x NPCOL BLACS process grid
3375* A is distributed over. The context
3376* itself is global, but the handle
3377* (the integer value) may vary.
3378* M_A (global) DESCA( M_ ) The number of rows in the distribu-
3379* ted matrix A, M_A >= 0.
3380* N_A (global) DESCA( N_ ) The number of columns in the distri-
3381* buted matrix A, N_A >= 0.
3382* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
3383* block of the matrix A, IMB_A > 0.
3384* INB_A (global) DESCA( INB_ ) The number of columns of the upper
3385* left block of the matrix A,
3386* INB_A > 0.
3387* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
3388* bute the last M_A-IMB_A rows of A,
3389* MB_A > 0.
3390* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
3391* bute the last N_A-INB_A columns of
3392* A, NB_A > 0.
3393* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
3394* row of the matrix A is distributed,
3395* NPROW > RSRC_A >= 0.
3396* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
3397* first column of A is distributed.
3398* NPCOL > CSRC_A >= 0.
3399* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
3400* array storing the local blocks of
3401* the distributed matrix A,
3402* IF( Lc( 1, N_A ) > 0 )
3403* LLD_A >= MAX( 1, Lr( 1, M_A ) )
3404* ELSE
3405* LLD_A >= 1.
3406*
3407* Let K be the number of rows of a matrix A starting at the global in-
3408* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
3409* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
3410* receive if these K rows were distributed over NPROW processes. If K
3411* is the number of columns of a matrix A starting at the global index
3412* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
3413* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
3414* these K columns were distributed over NPCOL processes.
3415*
3416* The values of Lr() and Lc() may be determined via a call to the func-
3417* tion PB_NUMROC:
3418* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
3419* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
3420*
3421* Arguments
3422* =========
3423*
3424* ERRMAX (global output) DOUBLE PRECISION
3425* On exit, ERRMAX specifies the largest absolute element-wise
3426* difference between sub( A ) and sub( PA ).
3427*
3428* M (global input) INTEGER
3429* On entry, M specifies the number of rows of the submatrix
3430* operand sub( A ). M must be at least zero.
3431*
3432* N (global input) INTEGER
3433* On entry, N specifies the number of columns of the submatrix
3434* operand sub( A ). N must be at least zero.
3435*
3436* A (local input) COMPLEX*16 array
3437* On entry, A is an array of dimension (DESCA( M_ ),*). This
3438* array contains a local copy of the initial entire matrix PA.
3439*
3440* PA (local input) COMPLEX*16 array
3441* On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
3442* array contains the local entries of the matrix PA.
3443*
3444* IA (global input) INTEGER
3445* On entry, IA specifies A's global row index, which points to
3446* the beginning of the submatrix sub( A ).
3447*
3448* JA (global input) INTEGER
3449* On entry, JA specifies A's global column index, which points
3450* to the beginning of the submatrix sub( A ).
3451*
3452* DESCA (global and local input) INTEGER array
3453* On entry, DESCA is an integer array of dimension DLEN_. This
3454* is the array descriptor for the matrix A.
3455*
3456* INFO (global output) INTEGER
3457* On exit, if INFO = 0, no error has been found,
3458* If INFO > 0, the maximum abolute error found is in (0,eps],
3459* If INFO < 0, the maximum abolute error found is in (eps,+oo).
3460*
3461* -- Written on April 1, 1998 by
3462* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3463*
3464* =====================================================================
3465*
3466* .. Parameters ..
3467 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
3468 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
3469 $ RSRC_
3470 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
3471 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
3472 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
3473 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
3474 DOUBLE PRECISION ZERO
3475 PARAMETER ( zero = 0.0d+0 )
3476* ..
3477* .. Local Scalars ..
3478 LOGICAL COLREP, ROWREP
3479 INTEGER H, I, IACOL, IAROW, IB, ICTXT, ICURCOL,
3480 $ ICURROW, II, IIA, IN, J, JB, JJ, JJA, JN, K,
3481 $ KK, LDA, LDPA, LL, MYCOL, MYROW, NPCOL, NPROW
3482 DOUBLE PRECISION ERR, EPS
3483* ..
3484* .. External Subroutines ..
3485 EXTERNAL blacs_gridinfo, dgamx2d, pb_infog2l, pzerrset
3486* ..
3487* .. External Functions ..
3488 DOUBLE PRECISION PDLAMCH
3489 EXTERNAL pdlamch
3490* ..
3491* .. Intrinsic Functions ..
3492 INTRINSIC abs, dble, dimag, max, min, mod
3493* ..
3494* .. Executable Statements ..
3495*
3496 info = 0
3497 errmax = zero
3498*
3499* Quick return if posssible
3500*
3501 IF( ( m.EQ.0 ).OR.( n.EQ.0 ) )
3502 $ RETURN
3503*
3504* Start the operations
3505*
3506 ictxt = desca( ctxt_ )
3507 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
3508*
3509 eps = pdlamch( ictxt, 'eps' )
3510*
3511 CALL pb_infog2l( ia, ja, desca, nprow, npcol, myrow, mycol, iia,
3512 $ jja, iarow, iacol )
3513*
3514 ii = iia
3515 jj = jja
3516 lda = desca( m_ )
3517 ldpa = desca( lld_ )
3518 icurrow = iarow
3519 icurcol = iacol
3520 rowrep = ( iarow.EQ.-1 )
3521 colrep = ( iacol.EQ.-1 )
3522*
3523* Handle the first block of column separately
3524*
3525 jb = desca( inb_ ) - ja + 1
3526 IF( jb.LE.0 )
3527 $ jb = ( ( -jb ) / desca( nb_ ) + 1 ) * desca( nb_ ) + jb
3528 jb = min( jb, n )
3529 jn = ja + jb - 1
3530*
3531 IF( mycol.EQ.icurcol .OR. colrep ) THEN
3532*
3533 DO 40 h = 0, jb-1
3534 ib = desca( imb_ ) - ia + 1
3535 IF( ib.LE.0 )
3536 $ ib = ( ( -ib ) / desca( mb_ ) + 1 ) * desca( mb_ ) + ib
3537 ib = min( ib, m )
3538 in = ia + ib - 1
3539 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3540 DO 10 k = 0, ib-1
3541 CALL pzerrset( err, errmax, a( ia+k+(ja+h-1)*lda ),
3542 $ pa( ii+k+(jj+h-1)*ldpa ) )
3543 10 CONTINUE
3544 ii = ii + ib
3545 END IF
3546 icurrow = mod( icurrow+1, nprow )
3547*
3548* Loop over remaining block of rows
3549*
3550 DO 30 i = in+1, ia+m-1, desca( mb_ )
3551 ib = min( desca( mb_ ), ia+m-i )
3552 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3553 DO 20 k = 0, ib-1
3554 CALL pzerrset( err, errmax, a( i+k+(ja+h-1)*lda ),
3555 $ pa( ii+k+(jj+h-1)*ldpa ) )
3556 20 CONTINUE
3557 ii = ii + ib
3558 END IF
3559 icurrow = mod( icurrow+1, nprow )
3560 30 CONTINUE
3561*
3562 ii = iia
3563 icurrow = iarow
3564 40 CONTINUE
3565*
3566 jj = jj + jb
3567*
3568 END IF
3569*
3570 icurcol = mod( icurcol+1, npcol )
3571*
3572* Loop over remaining column blocks
3573*
3574 DO 90 j = jn+1, ja+n-1, desca( nb_ )
3575 jb = min( desca( nb_ ), ja+n-j )
3576 IF( mycol.EQ.icurcol .OR. colrep ) THEN
3577 DO 80 h = 0, jb-1
3578 ib = desca( imb_ ) - ia + 1
3579 IF( ib.LE.0 )
3580 $ ib = ( ( -ib ) / desca( mb_ ) + 1 )*desca( mb_ ) + ib
3581 ib = min( ib, m )
3582 in = ia + ib - 1
3583 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3584 DO 50 k = 0, ib-1
3585 CALL pzerrset( err, errmax, a( ia+k+(j+h-1)*lda ),
3586 $ pa( ii+k+(jj+h-1)*ldpa ) )
3587 50 CONTINUE
3588 ii = ii + ib
3589 END IF
3590 icurrow = mod( icurrow+1, nprow )
3591*
3592* Loop over remaining block of rows
3593*
3594 DO 70 i = in+1, ia+m-1, desca( mb_ )
3595 ib = min( desca( mb_ ), ia+m-i )
3596 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3597 DO 60 k = 0, ib-1
3598 CALL pzerrset( err, errmax,
3599 $ a( i+k+(j+h-1)*lda ),
3600 $ pa( ii+k+(jj+h-1)*ldpa ) )
3601 60 CONTINUE
3602 ii = ii + ib
3603 END IF
3604 icurrow = mod( icurrow+1, nprow )
3605 70 CONTINUE
3606*
3607 ii = iia
3608 icurrow = iarow
3609 80 CONTINUE
3610*
3611 jj = jj + jb
3612 END IF
3613*
3614 icurcol = mod( icurcol+1, npcol )
3615*
3616 90 CONTINUE
3617*
3618 CALL dgamx2d( ictxt, 'All', ' ', 1, 1, errmax, 1, kk, ll, -1,
3619 $ -1, -1 )
3620*
3621 IF( errmax.GT.zero .AND. errmax.LE.eps ) THEN
3622 info = 1
3623 ELSE IF( errmax.GT.eps ) THEN
3624 info = -1
3625 END IF
3626*
3627 RETURN
3628*
3629* End of PZCHKMIN
3630*
pzerrset
subroutine pzerrset(err, errmax, xtrue, x)
Definition pzblastst.f:2460

◆ pzchkmout()

subroutine pzchkmout ( integer m,
integer n,
complex*16, dimension( * ) a,
complex*16, dimension( * ) pa,
integer ia,
integer ja,
integer, dimension( * ) desca,
integer info )

Definition at line 3632 of file pzblastst.f.

3633*
3634* -- PBLAS test routine (version 2.0) --
3635* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3636* and University of California, Berkeley.
3637* April 1, 1998
3638*
3639* .. Scalar Arguments ..
3640 INTEGER IA, INFO, JA, M, N
3641* ..
3642* .. Array Arguments ..
3643 INTEGER DESCA( * )
3644 COMPLEX*16 A( * ), PA( * )
3645* ..
3646*
3647* Purpose
3648* =======
3649*
3650* PZCHKMOUT checks that the matrix PA \ sub( PA ) remained unchanged.
3651* The local array entries are compared element by element, and their
3652* difference is tested against 0.0 as well as the epsilon machine. No-
3653* tice that this difference should be numerically exactly the zero ma-
3654* chine, but because of the possible movement of some of the data we
3655* flagged differently a difference less than twice the epsilon machine.
3656* The largest error is reported.
3657*
3658* Notes
3659* =====
3660*
3661* A description vector is associated with each 2D block-cyclicly dis-
3662* tributed matrix. This vector stores the information required to
3663* establish the mapping between a matrix entry and its corresponding
3664* process and memory location.
3665*
3666* In the following comments, the character _ should be read as
3667* "of the distributed matrix". Let A be a generic term for any 2D
3668* block cyclicly distributed matrix. Its description vector is DESCA:
3669*
3670* NOTATION STORED IN EXPLANATION
3671* ---------------- --------------- ------------------------------------
3672* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
3673* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
3674* the NPROW x NPCOL BLACS process grid
3675* A is distributed over. The context
3676* itself is global, but the handle
3677* (the integer value) may vary.
3678* M_A (global) DESCA( M_ ) The number of rows in the distribu-
3679* ted matrix A, M_A >= 0.
3680* N_A (global) DESCA( N_ ) The number of columns in the distri-
3681* buted matrix A, N_A >= 0.
3682* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
3683* block of the matrix A, IMB_A > 0.
3684* INB_A (global) DESCA( INB_ ) The number of columns of the upper
3685* left block of the matrix A,
3686* INB_A > 0.
3687* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
3688* bute the last M_A-IMB_A rows of A,
3689* MB_A > 0.
3690* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
3691* bute the last N_A-INB_A columns of
3692* A, NB_A > 0.
3693* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
3694* row of the matrix A is distributed,
3695* NPROW > RSRC_A >= 0.
3696* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
3697* first column of A is distributed.
3698* NPCOL > CSRC_A >= 0.
3699* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
3700* array storing the local blocks of
3701* the distributed matrix A,
3702* IF( Lc( 1, N_A ) > 0 )
3703* LLD_A >= MAX( 1, Lr( 1, M_A ) )
3704* ELSE
3705* LLD_A >= 1.
3706*
3707* Let K be the number of rows of a matrix A starting at the global in-
3708* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
3709* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
3710* receive if these K rows were distributed over NPROW processes. If K
3711* is the number of columns of a matrix A starting at the global index
3712* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
3713* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
3714* these K columns were distributed over NPCOL processes.
3715*
3716* The values of Lr() and Lc() may be determined via a call to the func-
3717* tion PB_NUMROC:
3718* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
3719* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
3720*
3721* Arguments
3722* =========
3723*
3724* M (global input) INTEGER
3725* On entry, M specifies the number of rows of the submatrix
3726* sub( PA ). M must be at least zero.
3727*
3728* N (global input) INTEGER
3729* On entry, N specifies the number of columns of the submatrix
3730* sub( PA ). N must be at least zero.
3731*
3732* A (local input) COMPLEX*16 array
3733* On entry, A is an array of dimension (DESCA( M_ ),*). This
3734* array contains a local copy of the initial entire matrix PA.
3735*
3736* PA (local input) COMPLEX*16 array
3737* On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
3738* array contains the local entries of the matrix PA.
3739*
3740* IA (global input) INTEGER
3741* On entry, IA specifies A's global row index, which points to
3742* the beginning of the submatrix sub( A ).
3743*
3744* JA (global input) INTEGER
3745* On entry, JA specifies A's global column index, which points
3746* to the beginning of the submatrix sub( A ).
3747*
3748* DESCA (global and local input) INTEGER array
3749* On entry, DESCA is an integer array of dimension DLEN_. This
3750* is the array descriptor for the matrix A.
3751*
3752* INFO (global output) INTEGER
3753* On exit, if INFO = 0, no error has been found,
3754* If INFO > 0, the maximum abolute error found is in (0,eps],
3755* If INFO < 0, the maximum abolute error found is in (eps,+oo).
3756*
3757* -- Written on April 1, 1998 by
3758* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3759*
3760* =====================================================================
3761*
3762* .. Parameters ..
3763 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
3764 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
3765 $ RSRC_
3766 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
3767 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
3768 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
3769 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
3770 DOUBLE PRECISION ZERO
3771 parameter( zero = 0.0d+0 )
3772* ..
3773* .. Local Scalars ..
3774 LOGICAL COLREP, ROWREP
3775 INTEGER I, IB, ICTXT, ICURCOL, II, IMBA, J, JB, JJ, KK,
3776 $ LDA, LDPA, LL, MPALL, MYCOL, MYROW, MYROWDIST,
3777 $ NPCOL, NPROW
3778 DOUBLE PRECISION EPS, ERR, ERRMAX
3779* ..
3780* .. External Subroutines ..
3781 EXTERNAL blacs_gridinfo, dgamx2d, pzerrset
3782* ..
3783* .. External Functions ..
3784 INTEGER PB_NUMROC
3785 DOUBLE PRECISION PDLAMCH
3786 EXTERNAL pdlamch, pb_numroc
3787* ..
3788* .. Intrinsic Functions ..
3789 INTRINSIC max, min, mod
3790* ..
3791* .. Executable Statements ..
3792*
3793 info = 0
3794 errmax = zero
3795*
3796* Quick return if possible
3797*
3798 IF( ( desca( m_ ).LE.0 ).OR.( desca( n_ ).LE.0 ) )
3799 $ RETURN
3800*
3801* Start the operations
3802*
3803 ictxt = desca( ctxt_ )
3804 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
3805*
3806 eps = pdlamch( ictxt, 'eps' )
3807*
3808 mpall = pb_numroc( desca( m_ ), 1, desca( imb_ ), desca( mb_ ),
3809 $ myrow, desca( rsrc_ ), nprow )
3810*
3811 lda = desca( m_ )
3812 ldpa = desca( lld_ )
3813*
3814 ii = 1
3815 jj = 1
3816 rowrep = ( desca( rsrc_ ).EQ.-1 )
3817 colrep = ( desca( csrc_ ).EQ.-1 )
3818 icurcol = desca( csrc_ )
3819 IF( myrow.EQ.desca( rsrc_ ) .OR. rowrep ) THEN
3820 imba = desca( imb_ )
3821 ELSE
3822 imba = desca( mb_ )
3823 END IF
3824 IF( rowrep ) THEN
3825 myrowdist = 0
3826 ELSE
3827 myrowdist = mod( myrow - desca( rsrc_ ) + nprow, nprow )
3828 END IF
3829*
3830 IF( mycol.EQ.icurcol .OR. colrep ) THEN
3831*
3832 j = 1
3833 IF( myrowdist.EQ.0 ) THEN
3834 i = 1
3835 ELSE
3836 i = desca( imb_ ) + ( myrowdist - 1 ) * desca( mb_ ) + 1
3837 END IF
3838 ib = min( max( 0, desca( m_ ) - i + 1 ), imba )
3839 jb = min( desca( n_ ), desca( inb_ ) )
3840*
3841 DO 20 kk = 0, jb-1
3842 DO 10 ll = 0, ib-1
3843 IF( i+ll.LT.ia .OR. i+ll.GT.ia+m-1 .OR.
3844 $ j+kk.LT.ja .OR. j+kk.GT.ja+n-1 )
3845 $ CALL pzerrset( err, errmax, a( i+ll+(j+kk-1)*lda ),
3846 $ pa( ii+ll+(jj+kk-1)*ldpa ) )
3847 10 CONTINUE
3848 20 CONTINUE
3849 IF( rowrep ) THEN
3850 i = i + imba
3851 ELSE
3852 i = i + imba + ( nprow - 1 ) * desca( mb_ )
3853 END IF
3854*
3855 DO 50 ii = imba + 1, mpall, desca( mb_ )
3856 ib = min( mpall-ii+1, desca( mb_ ) )
3857*
3858 DO 40 kk = 0, jb-1
3859 DO 30 ll = 0, ib-1
3860 IF( i+ll.LT.ia .OR. i+ll.GT.ia+m-1 .OR.
3861 $ j+kk.LT.ja .OR. j+kk.GT.ja+n-1 )
3862 $ CALL pzerrset( err, errmax,
3863 $ a( i+ll+(j+kk-1)*lda ),
3864 $ pa( ii+ll+(jj+kk-1)*ldpa ) )
3865 30 CONTINUE
3866 40 CONTINUE
3867*
3868 IF( rowrep ) THEN
3869 i = i + desca( mb_ )
3870 ELSE
3871 i = i + nprow * desca( mb_ )
3872 END IF
3873*
3874 50 CONTINUE
3875*
3876 jj = jj + jb
3877*
3878 END IF
3879*
3880 icurcol = mod( icurcol + 1, npcol )
3881*
3882 DO 110 j = desca( inb_ ) + 1, desca( n_ ), desca( nb_ )
3883 jb = min( desca( n_ ) - j + 1, desca( nb_ ) )
3884*
3885 IF( mycol.EQ.icurcol .OR. colrep ) THEN
3886*
3887 IF( myrowdist.EQ.0 ) THEN
3888 i = 1
3889 ELSE
3890 i = desca( imb_ ) + ( myrowdist - 1 ) * desca( mb_ ) + 1
3891 END IF
3892*
3893 ii = 1
3894 ib = min( max( 0, desca( m_ ) - i + 1 ), imba )
3895 DO 70 kk = 0, jb-1
3896 DO 60 ll = 0, ib-1
3897 IF( i+ll.LT.ia .OR. i+ll.GT.ia+m-1 .OR.
3898 $ j+kk.LT.ja .OR. j+kk.GT.ja+n-1 )
3899 $ CALL pzerrset( err, errmax,
3900 $ a( i+ll+(j+kk-1)*lda ),
3901 $ pa( ii+ll+(jj+kk-1)*ldpa ) )
3902 60 CONTINUE
3903 70 CONTINUE
3904 IF( rowrep ) THEN
3905 i = i + imba
3906 ELSE
3907 i = i + imba + ( nprow - 1 ) * desca( mb_ )
3908 END IF
3909*
3910 DO 100 ii = imba+1, mpall, desca( mb_ )
3911 ib = min( mpall-ii+1, desca( mb_ ) )
3912*
3913 DO 90 kk = 0, jb-1
3914 DO 80 ll = 0, ib-1
3915 IF( i+ll.LT.ia .OR. i+ll.GT.ia+m-1 .OR.
3916 $ j+kk.LT.ja .OR. j+kk.GT.ja+n-1 )
3917 $ CALL pzerrset( err, errmax,
3918 $ a( i+ll+(j+kk-1)*lda ),
3919 $ pa( ii+ll+(jj+kk-1)*ldpa ) )
3920 80 CONTINUE
3921 90 CONTINUE
3922*
3923 IF( rowrep ) THEN
3924 i = i + desca( mb_ )
3925 ELSE
3926 i = i + nprow * desca( mb_ )
3927 END IF
3928*
3929 100 CONTINUE
3930*
3931 jj = jj + jb
3932*
3933 END IF
3934*
3935 icurcol = mod( icurcol + 1, npcol )
3936* INSERT MODE
3937 110 CONTINUE
3938*
3939 CALL dgamx2d( ictxt, 'All', ' ', 1, 1, errmax, 1, kk, ll, -1,
3940 $ -1, -1 )
3941*
3942 IF( errmax.GT.zero .AND. errmax.LE.eps ) THEN
3943 info = 1
3944 ELSE IF( errmax.GT.eps ) THEN
3945 info = -1
3946 END IF
3947*
3948 RETURN
3949*
3950* End of PZCHKMOUT
3951*
pb_numroc
integer function pb_numroc(n, i, inb, nb, proc, srcproc, nprocs)
Definition pblastst.f:2548

◆ pzchkopt()

subroutine pzchkopt ( integer ictxt,
integer nout,
external subptr,
integer scode,
character*(*) sname,
character*1 argnam,
integer argpos )

Definition at line 264 of file pzblastst.f.

266*
267* -- PBLAS test routine (version 2.0) --
268* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
269* and University of California, Berkeley.
270* April 1, 1998
271*
272* .. Scalar Arguments ..
273 CHARACTER*1 ARGNAM
274 INTEGER ARGPOS, ICTXT, NOUT, SCODE
275* ..
276* .. Array Arguments ..
277 CHARACTER*(*) SNAME
278* ..
279* .. Subroutine Arguments ..
280 EXTERNAL subptr
281* ..
282*
283* Purpose
284* =======
285*
286* PZCHKOPT tests the option ARGNAM in any PBLAS routine.
287*
288* Notes
289* =====
290*
291* A description vector is associated with each 2D block-cyclicly dis-
292* tributed matrix. This vector stores the information required to
293* establish the mapping between a matrix entry and its corresponding
294* process and memory location.
295*
296* In the following comments, the character _ should be read as
297* "of the distributed matrix". Let A be a generic term for any 2D
298* block cyclicly distributed matrix. Its description vector is DESCA:
299*
300* NOTATION STORED IN EXPLANATION
301* ---------------- --------------- ------------------------------------
302* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
303* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
304* the NPROW x NPCOL BLACS process grid
305* A is distributed over. The context
306* itself is global, but the handle
307* (the integer value) may vary.
308* M_A (global) DESCA( M_ ) The number of rows in the distribu-
309* ted matrix A, M_A >= 0.
310* N_A (global) DESCA( N_ ) The number of columns in the distri-
311* buted matrix A, N_A >= 0.
312* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
313* block of the matrix A, IMB_A > 0.
314* INB_A (global) DESCA( INB_ ) The number of columns of the upper
315* left block of the matrix A,
316* INB_A > 0.
317* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
318* bute the last M_A-IMB_A rows of A,
319* MB_A > 0.
320* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
321* bute the last N_A-INB_A columns of
322* A, NB_A > 0.
323* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
324* row of the matrix A is distributed,
325* NPROW > RSRC_A >= 0.
326* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
327* first column of A is distributed.
328* NPCOL > CSRC_A >= 0.
329* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
330* array storing the local blocks of
331* the distributed matrix A,
332* IF( Lc( 1, N_A ) > 0 )
333* LLD_A >= MAX( 1, Lr( 1, M_A ) )
334* ELSE
335* LLD_A >= 1.
336*
337* Let K be the number of rows of a matrix A starting at the global in-
338* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
339* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
340* receive if these K rows were distributed over NPROW processes. If K
341* is the number of columns of a matrix A starting at the global index
342* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
343* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
344* these K columns were distributed over NPCOL processes.
345*
346* The values of Lr() and Lc() may be determined via a call to the func-
347* tion PB_NUMROC:
348* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
349* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
350*
351* Arguments
352* =========
353*
354* ICTXT (local input) INTEGER
355* On entry, ICTXT specifies the BLACS context handle, indica-
356* ting the global context of the operation. The context itself
357* is global, but the value of ICTXT is local.
358*
359* NOUT (global input) INTEGER
360* On entry, NOUT specifies the unit number for the output file.
361* When NOUT is 6, output to screen, when NOUT is 0, output to
362* stderr. NOUT is only defined for process 0.
363*
364* SUBPTR (global input) SUBROUTINE
365* On entry, SUBPTR is a subroutine. SUBPTR must be declared
366* EXTERNAL in the calling subroutine.
367*
368* SCODE (global input) INTEGER
369* On entry, SCODE specifies the calling sequence code.
370*
371* SNAME (global input) CHARACTER*(*)
372* On entry, SNAME specifies the subroutine name calling this
373* subprogram.
374*
375* ARGNAM (global input) CHARACTER*(*)
376* On entry, ARGNAM specifies the name of the option to be
377* checked. ARGNAM can either be 'D', 'S', 'A', 'B', or 'U'.
378*
379* ARGPOS (global input) INTEGER
380* On entry, ARGPOS indicates the position of the option ARGNAM
381* to be tested.
382*
383* -- Written on April 1, 1998 by
384* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
385*
386* =====================================================================
387*
388* .. Local Scalars ..
389 INTEGER INFOT
390* ..
391* .. External Subroutines ..
392 EXTERNAL pchkpbe, pzcallsub, pzsetpblas
393* ..
394* .. External Functions ..
395 LOGICAL LSAME
396 EXTERNAL lsame
397* ..
398* .. Common Blocks ..
399 CHARACTER DIAG, SIDE, TRANSA, TRANSB, UPLO
400 COMMON /pblasc/diag, side, transa, transb, uplo
401* ..
402* .. Executable Statements ..
403*
404* Reiniatilize the dummy arguments to correct values
405*
406 CALL pzsetpblas( ictxt )
407*
408 IF( lsame( argnam, 'D' ) ) THEN
409*
410* Generate bad DIAG option
411*
412 diag = '/'
413*
414 ELSE IF( lsame( argnam, 'S' ) ) THEN
415*
416* Generate bad SIDE option
417*
418 side = '/'
419*
420 ELSE IF( lsame( argnam, 'A' ) ) THEN
421*
422* Generate bad TRANSA option
423*
424 transa = '/'
425*
426 ELSE IF( lsame( argnam, 'B' ) ) THEN
427*
428* Generate bad TRANSB option
429*
430 transb = '/'
431*
432 ELSE IF( lsame( argnam, 'U' ) ) THEN
433*
434* Generate bad UPLO option
435*
436 uplo = '/'
437*
438 END IF
439*
440* Set INFOT to the position of the bad dimension argument
441*
442 infot = argpos
443*
444* Call the PBLAS routine
445*
446 CALL pzcallsub( subptr, scode )
447 CALL pchkpbe( ictxt, nout, sname, infot )
448*
449 RETURN
450*
451* End of PZCHKOPT
452*

◆ pzchkvin()

subroutine pzchkvin ( double precision errmax,
integer n,
complex*16, dimension( * ) x,
complex*16, dimension( * ) px,
integer ix,
integer jx,
integer, dimension( * ) descx,
integer incx,
integer info )

Definition at line 2580 of file pzblastst.f.

2582*
2583* -- PBLAS test routine (version 2.0) --
2584* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2585* and University of California, Berkeley.
2586* April 1, 1998
2587*
2588* .. Scalar Arguments ..
2589 INTEGER INCX, INFO, IX, JX, N
2590 DOUBLE PRECISION ERRMAX
2591* ..
2592* .. Array Arguments ..
2593 INTEGER DESCX( * )
2594 COMPLEX*16 PX( * ), X( * )
2595* ..
2596*
2597* Purpose
2598* =======
2599*
2600* PZCHKVIN checks that the submatrix sub( PX ) remained unchanged. The
2601* local array entries are compared element by element, and their dif-
2602* ference is tested against 0.0 as well as the epsilon machine. Notice
2603* that this difference should be numerically exactly the zero machine,
2604* but because of the possible fluctuation of some of the data we flag-
2605* ged differently a difference less than twice the epsilon machine. The
2606* largest error is also returned.
2607*
2608* Notes
2609* =====
2610*
2611* A description vector is associated with each 2D block-cyclicly dis-
2612* tributed matrix. This vector stores the information required to
2613* establish the mapping between a matrix entry and its corresponding
2614* process and memory location.
2615*
2616* In the following comments, the character _ should be read as
2617* "of the distributed matrix". Let A be a generic term for any 2D
2618* block cyclicly distributed matrix. Its description vector is DESCA:
2619*
2620* NOTATION STORED IN EXPLANATION
2621* ---------------- --------------- ------------------------------------
2622* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2623* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2624* the NPROW x NPCOL BLACS process grid
2625* A is distributed over. The context
2626* itself is global, but the handle
2627* (the integer value) may vary.
2628* M_A (global) DESCA( M_ ) The number of rows in the distribu-
2629* ted matrix A, M_A >= 0.
2630* N_A (global) DESCA( N_ ) The number of columns in the distri-
2631* buted matrix A, N_A >= 0.
2632* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2633* block of the matrix A, IMB_A > 0.
2634* INB_A (global) DESCA( INB_ ) The number of columns of the upper
2635* left block of the matrix A,
2636* INB_A > 0.
2637* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2638* bute the last M_A-IMB_A rows of A,
2639* MB_A > 0.
2640* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2641* bute the last N_A-INB_A columns of
2642* A, NB_A > 0.
2643* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2644* row of the matrix A is distributed,
2645* NPROW > RSRC_A >= 0.
2646* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2647* first column of A is distributed.
2648* NPCOL > CSRC_A >= 0.
2649* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2650* array storing the local blocks of
2651* the distributed matrix A,
2652* IF( Lc( 1, N_A ) > 0 )
2653* LLD_A >= MAX( 1, Lr( 1, M_A ) )
2654* ELSE
2655* LLD_A >= 1.
2656*
2657* Let K be the number of rows of a matrix A starting at the global in-
2658* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2659* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2660* receive if these K rows were distributed over NPROW processes. If K
2661* is the number of columns of a matrix A starting at the global index
2662* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2663* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2664* these K columns were distributed over NPCOL processes.
2665*
2666* The values of Lr() and Lc() may be determined via a call to the func-
2667* tion PB_NUMROC:
2668* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2669* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2670*
2671* Arguments
2672* =========
2673*
2674* ERRMAX (global output) DOUBLE PRECISION
2675* On exit, ERRMAX specifies the largest absolute element-wise
2676* difference between sub( X ) and sub( PX ).
2677*
2678* N (global input) INTEGER
2679* On entry, N specifies the length of the subvector operand
2680* sub( X ). N must be at least zero.
2681*
2682* X (local input) COMPLEX*16 array
2683* On entry, X is an array of dimension (DESCX( M_ ),*). This
2684* array contains a local copy of the initial entire matrix PX.
2685*
2686* PX (local input) COMPLEX*16 array
2687* On entry, PX is an array of dimension (DESCX( LLD_ ),*). This
2688* array contains the local entries of the matrix PX.
2689*
2690* IX (global input) INTEGER
2691* On entry, IX specifies X's global row index, which points to
2692* the beginning of the submatrix sub( X ).
2693*
2694* JX (global input) INTEGER
2695* On entry, JX specifies X's global column index, which points
2696* to the beginning of the submatrix sub( X ).
2697*
2698* DESCX (global and local input) INTEGER array
2699* On entry, DESCX is an integer array of dimension DLEN_. This
2700* is the array descriptor for the matrix X.
2701*
2702* INCX (global input) INTEGER
2703* On entry, INCX specifies the global increment for the
2704* elements of X. Only two values of INCX are supported in
2705* this version, namely 1 and M_X. INCX must not be zero.
2706*
2707* INFO (global output) INTEGER
2708* On exit, if INFO = 0, no error has been found,
2709* If INFO > 0, the maximum abolute error found is in (0,eps],
2710* If INFO < 0, the maximum abolute error found is in (eps,+oo).
2711*
2712* -- Written on April 1, 1998 by
2713* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2714*
2715* =====================================================================
2716*
2717* .. Parameters ..
2718 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
2719 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
2720 $ RSRC_
2721 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
2722 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
2723 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
2724 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
2725 DOUBLE PRECISION ZERO
2726 parameter( zero = 0.0d+0 )
2727* ..
2728* .. Local Scalars ..
2729 LOGICAL COLREP, ROWREP
2730 INTEGER I, IB, ICTXT, ICURCOL, ICURROW, IIX, IN, IXCOL,
2731 $ IXROW, J, JB, JJX, JN, KK, LDPX, LDX, LL,
2732 $ MYCOL, MYROW, NPCOL, NPROW
2733 DOUBLE PRECISION ERR, EPS
2734* ..
2735* .. External Subroutines ..
2736 EXTERNAL blacs_gridinfo, dgamx2d, pb_infog2l, pzerrset
2737* ..
2738* .. External Functions ..
2739 DOUBLE PRECISION PDLAMCH
2740 EXTERNAL pdlamch
2741* ..
2742* .. Intrinsic Functions ..
2743 INTRINSIC abs, dble, dimag, max, min, mod
2744* ..
2745* .. Executable Statements ..
2746*
2747 info = 0
2748 errmax = zero
2749*
2750* Quick return if possible
2751*
2752 IF( n.LE.0 )
2753 $ RETURN
2754*
2755 ictxt = descx( ctxt_ )
2756 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
2757*
2758 eps = pdlamch( ictxt, 'eps' )
2759*
2760 CALL pb_infog2l( ix, jx, descx, nprow, npcol, myrow, mycol, iix,
2761 $ jjx, ixrow, ixcol )
2762*
2763 ldx = descx( m_ )
2764 ldpx = descx( lld_ )
2765 rowrep = ( ixrow.EQ.-1 )
2766 colrep = ( ixcol.EQ.-1 )
2767*
2768 IF( n.EQ.1 ) THEN
2769*
2770 IF( ( myrow.EQ.ixrow .OR. rowrep ) .AND.
2771 $ ( mycol.EQ.ixcol .OR. colrep ) )
2772 $ CALL pzerrset( err, errmax, x( ix+(jx-1)*ldx ),
2773 $ px( iix+(jjx-1)*ldpx ) )
2774*
2775 ELSE IF( incx.EQ.descx( m_ ) ) THEN
2776*
2777* sub( X ) is a row vector
2778*
2779 jb = descx( inb_ ) - jx + 1
2780 IF( jb.LE.0 )
2781 $ jb = ( ( -jb ) / descx( nb_ ) + 1 ) * descx( nb_ ) + jb
2782 jb = min( jb, n )
2783 jn = jx + jb - 1
2784*
2785 IF( myrow.EQ.ixrow .OR. rowrep ) THEN
2786*
2787 icurcol = ixcol
2788 IF( mycol.EQ.icurcol .OR. colrep ) THEN
2789 DO 10 j = jx, jn
2790 CALL pzerrset( err, errmax, x( ix+(j-1)*ldx ),
2791 $ px( iix+(jjx-1)*ldpx ) )
2792 jjx = jjx + 1
2793 10 CONTINUE
2794 END IF
2795 icurcol = mod( icurcol+1, npcol )
2796*
2797 DO 30 j = jn+1, jx+n-1, descx( nb_ )
2798 jb = min( jx+n-j, descx( nb_ ) )
2799*
2800 IF( mycol.EQ.icurcol .OR. colrep ) THEN
2801*
2802 DO 20 kk = 0, jb-1
2803 CALL pzerrset( err, errmax, x( ix+(j+kk-1)*ldx ),
2804 $ px( iix+(jjx+kk-1)*ldpx ) )
2805 20 CONTINUE
2806*
2807 jjx = jjx + jb
2808*
2809 END IF
2810*
2811 icurcol = mod( icurcol+1, npcol )
2812*
2813 30 CONTINUE
2814*
2815 END IF
2816*
2817 ELSE
2818*
2819* sub( X ) is a column vector
2820*
2821 ib = descx( imb_ ) - ix + 1
2822 IF( ib.LE.0 )
2823 $ ib = ( ( -ib ) / descx( mb_ ) + 1 ) * descx( mb_ ) + ib
2824 ib = min( ib, n )
2825 in = ix + ib - 1
2826*
2827 IF( mycol.EQ.ixcol .OR. colrep ) THEN
2828*
2829 icurrow = ixrow
2830 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
2831 DO 40 i = ix, in
2832 CALL pzerrset( err, errmax, x( i+(jx-1)*ldx ),
2833 $ px( iix+(jjx-1)*ldpx ) )
2834 iix = iix + 1
2835 40 CONTINUE
2836 END IF
2837 icurrow = mod( icurrow+1, nprow )
2838*
2839 DO 60 i = in+1, ix+n-1, descx( mb_ )
2840 ib = min( ix+n-i, descx( mb_ ) )
2841*
2842 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
2843*
2844 DO 50 kk = 0, ib-1
2845 CALL pzerrset( err, errmax, x( i+kk+(jx-1)*ldx ),
2846 $ px( iix+kk+(jjx-1)*ldpx ) )
2847 50 CONTINUE
2848*
2849 iix = iix + ib
2850*
2851 END IF
2852*
2853 icurrow = mod( icurrow+1, nprow )
2854*
2855 60 CONTINUE
2856*
2857 END IF
2858*
2859 END IF
2860*
2861 CALL dgamx2d( ictxt, 'All', ' ', 1, 1, errmax, 1, kk, ll, -1,
2862 $ -1, -1 )
2863*
2864 IF( errmax.GT.zero .AND. errmax.LE.eps ) THEN
2865 info = 1
2866 ELSE IF( errmax.GT.eps ) THEN
2867 info = -1
2868 END IF
2869*
2870 RETURN
2871*
2872* End of PZCHKVIN
2873*

◆ pzchkvout()

subroutine pzchkvout ( integer n,
complex*16, dimension( * ) x,
complex*16, dimension( * ) px,
integer ix,
integer jx,
integer, dimension( * ) descx,
integer incx,
integer info )

Definition at line 2875 of file pzblastst.f.

2876*
2877* -- PBLAS test routine (version 2.0) --
2878* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2879* and University of California, Berkeley.
2880* April 1, 1998
2881*
2882* .. Scalar Arguments ..
2883 INTEGER INCX, INFO, IX, JX, N
2884* ..
2885* .. Array Arguments ..
2886 INTEGER DESCX( * )
2887 COMPLEX*16 PX( * ), X( * )
2888* ..
2889*
2890* Purpose
2891* =======
2892*
2893* PZCHKVOUT checks that the matrix PX \ sub( PX ) remained unchanged.
2894* The local array entries are compared element by element, and their
2895* difference is tested against 0.0 as well as the epsilon machine. No-
2896* tice that this difference should be numerically exactly the zero ma-
2897* chine, but because of the possible movement of some of the data we
2898* flagged differently a difference less than twice the epsilon machine.
2899* The largest error is reported.
2900*
2901* Notes
2902* =====
2903*
2904* A description vector is associated with each 2D block-cyclicly dis-
2905* tributed matrix. This vector stores the information required to
2906* establish the mapping between a matrix entry and its corresponding
2907* process and memory location.
2908*
2909* In the following comments, the character _ should be read as
2910* "of the distributed matrix". Let A be a generic term for any 2D
2911* block cyclicly distributed matrix. Its description vector is DESCA:
2912*
2913* NOTATION STORED IN EXPLANATION
2914* ---------------- --------------- ------------------------------------
2915* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2916* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2917* the NPROW x NPCOL BLACS process grid
2918* A is distributed over. The context
2919* itself is global, but the handle
2920* (the integer value) may vary.
2921* M_A (global) DESCA( M_ ) The number of rows in the distribu-
2922* ted matrix A, M_A >= 0.
2923* N_A (global) DESCA( N_ ) The number of columns in the distri-
2924* buted matrix A, N_A >= 0.
2925* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2926* block of the matrix A, IMB_A > 0.
2927* INB_A (global) DESCA( INB_ ) The number of columns of the upper
2928* left block of the matrix A,
2929* INB_A > 0.
2930* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2931* bute the last M_A-IMB_A rows of A,
2932* MB_A > 0.
2933* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2934* bute the last N_A-INB_A columns of
2935* A, NB_A > 0.
2936* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2937* row of the matrix A is distributed,
2938* NPROW > RSRC_A >= 0.
2939* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2940* first column of A is distributed.
2941* NPCOL > CSRC_A >= 0.
2942* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2943* array storing the local blocks of
2944* the distributed matrix A,
2945* IF( Lc( 1, N_A ) > 0 )
2946* LLD_A >= MAX( 1, Lr( 1, M_A ) )
2947* ELSE
2948* LLD_A >= 1.
2949*
2950* Let K be the number of rows of a matrix A starting at the global in-
2951* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2952* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2953* receive if these K rows were distributed over NPROW processes. If K
2954* is the number of columns of a matrix A starting at the global index
2955* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2956* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2957* these K columns were distributed over NPCOL processes.
2958*
2959* The values of Lr() and Lc() may be determined via a call to the func-
2960* tion PB_NUMROC:
2961* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2962* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2963*
2964* Arguments
2965* =========
2966*
2967* N (global input) INTEGER
2968* On entry, N specifies the length of the subvector operand
2969* sub( X ). N must be at least zero.
2970*
2971* X (local input) COMPLEX*16 array
2972* On entry, X is an array of dimension (DESCX( M_ ),*). This
2973* array contains a local copy of the initial entire matrix PX.
2974*
2975* PX (local input) COMPLEX*16 array
2976* On entry, PX is an array of dimension (DESCX( LLD_ ),*). This
2977* array contains the local entries of the matrix PX.
2978*
2979* IX (global input) INTEGER
2980* On entry, IX specifies X's global row index, which points to
2981* the beginning of the submatrix sub( X ).
2982*
2983* JX (global input) INTEGER
2984* On entry, JX specifies X's global column index, which points
2985* to the beginning of the submatrix sub( X ).
2986*
2987* DESCX (global and local input) INTEGER array
2988* On entry, DESCX is an integer array of dimension DLEN_. This
2989* is the array descriptor for the matrix X.
2990*
2991* INCX (global input) INTEGER
2992* On entry, INCX specifies the global increment for the
2993* elements of X. Only two values of INCX are supported in
2994* this version, namely 1 and M_X. INCX must not be zero.
2995*
2996* INFO (global output) INTEGER
2997* On exit, if INFO = 0, no error has been found,
2998* If INFO > 0, the maximum abolute error found is in (0,eps],
2999* If INFO < 0, the maximum abolute error found is in (eps,+oo).
3000*
3001* -- Written on April 1, 1998 by
3002* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
3003*
3004* =====================================================================
3005*
3006* .. Parameters ..
3007 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
3008 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
3009 $ RSRC_
3010 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
3011 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
3012 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
3013 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
3014 DOUBLE PRECISION ZERO
3015 parameter( zero = 0.0d+0 )
3016* ..
3017* .. Local Scalars ..
3018 LOGICAL COLREP, ROWREP
3019 INTEGER I, IB, ICTXT, ICURCOL, ICURROW, II, IMBX, INBX,
3020 $ J, JB, JJ, KK, LDPX, LDX, LL, MBX, MPALL,
3021 $ MYCOL, MYCOLDIST, MYROW, MYROWDIST, NBX, NPCOL,
3022 $ NPROW, NQALL
3023 DOUBLE PRECISION EPS, ERR, ERRMAX
3024* ..
3025* .. External Subroutines ..
3026 EXTERNAL blacs_gridinfo, dgamx2d, pzerrset
3027* ..
3028* .. External Functions ..
3029 INTEGER PB_NUMROC
3030 DOUBLE PRECISION PDLAMCH
3031 EXTERNAL pdlamch, pb_numroc
3032* ..
3033* .. Intrinsic Functions ..
3034 INTRINSIC abs, dble, dimag, max, min, mod
3035* ..
3036* .. Executable Statements ..
3037*
3038 info = 0
3039 errmax = zero
3040*
3041* Quick return if possible
3042*
3043 IF( ( descx( m_ ).LE.0 ).OR.( descx( n_ ).LE.0 ) )
3044 $ RETURN
3045*
3046* Start the operations
3047*
3048 ictxt = descx( ctxt_ )
3049 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
3050*
3051 eps = pdlamch( ictxt, 'eps' )
3052*
3053 mpall = pb_numroc( descx( m_ ), 1, descx( imb_ ), descx( mb_ ),
3054 $ myrow, descx( rsrc_ ), nprow )
3055 nqall = pb_numroc( descx( n_ ), 1, descx( inb_ ), descx( nb_ ),
3056 $ mycol, descx( csrc_ ), npcol )
3057*
3058 mbx = descx( mb_ )
3059 nbx = descx( nb_ )
3060 ldx = descx( m_ )
3061 ldpx = descx( lld_ )
3062 icurrow = descx( rsrc_ )
3063 icurcol = descx( csrc_ )
3064 rowrep = ( icurrow.EQ.-1 )
3065 colrep = ( icurcol.EQ.-1 )
3066 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3067 imbx = descx( imb_ )
3068 ELSE
3069 imbx = mbx
3070 END IF
3071 IF( mycol.EQ.icurcol .OR. colrep ) THEN
3072 inbx = descx( inb_ )
3073 ELSE
3074 inbx = nbx
3075 END IF
3076 IF( rowrep ) THEN
3077 myrowdist = 0
3078 ELSE
3079 myrowdist = mod( myrow - icurrow + nprow, nprow )
3080 END IF
3081 IF( colrep ) THEN
3082 mycoldist = 0
3083 ELSE
3084 mycoldist = mod( mycol - icurcol + npcol, npcol )
3085 END IF
3086 ii = 1
3087 jj = 1
3088*
3089 IF( incx.EQ.descx( m_ ) ) THEN
3090*
3091* sub( X ) is a row vector
3092*
3093 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3094*
3095 i = 1
3096 IF( mycoldist.EQ.0 ) THEN
3097 j = 1
3098 ELSE
3099 j = descx( inb_ ) + ( mycoldist - 1 ) * nbx + 1
3100 END IF
3101 jb = min( max( 0, descx( n_ ) - j + 1 ), inbx )
3102 ib = min( descx( m_ ), descx( imb_ ) )
3103*
3104 DO 20 kk = 0, jb-1
3105 DO 10 ll = 0, ib-1
3106 IF( i+ll.NE.ix .OR. j+kk.LT.jx .OR. j+kk.GT.jx+n-1 )
3107 $ CALL pzerrset( err, errmax,
3108 $ x( i+ll+(j+kk-1)*ldx ),
3109 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3110 10 CONTINUE
3111 20 CONTINUE
3112 IF( colrep ) THEN
3113 j = j + inbx
3114 ELSE
3115 j = j + inbx + ( npcol - 1 ) * nbx
3116 END IF
3117*
3118 DO 50 jj = inbx+1, nqall, nbx
3119 jb = min( nqall-jj+1, nbx )
3120*
3121 DO 40 kk = 0, jb-1
3122 DO 30 ll = 0, ib-1
3123 IF( i+ll.NE.ix .OR. j+kk.LT.jx .OR.
3124 $ j+kk.GT.jx+n-1 )
3125 $ CALL pzerrset( err, errmax,
3126 $ x( i+ll+(j+kk-1)*ldx ),
3127 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3128 30 CONTINUE
3129 40 CONTINUE
3130*
3131 IF( colrep ) THEN
3132 j = j + nbx
3133 ELSE
3134 j = j + npcol * nbx
3135 END IF
3136*
3137 50 CONTINUE
3138*
3139 ii = ii + ib
3140*
3141 END IF
3142*
3143 icurrow = mod( icurrow + 1, nprow )
3144*
3145 DO 110 i = descx( imb_ ) + 1, descx( m_ ), mbx
3146 ib = min( descx( m_ ) - i + 1, mbx )
3147*
3148 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
3149*
3150 IF( mycoldist.EQ.0 ) THEN
3151 j = 1
3152 ELSE
3153 j = descx( inb_ ) + ( mycoldist - 1 ) * nbx + 1
3154 END IF
3155*
3156 jj = 1
3157 jb = min( max( 0, descx( n_ ) - j + 1 ), inbx )
3158 DO 70 kk = 0, jb-1
3159 DO 60 ll = 0, ib-1
3160 IF( i+ll.NE.ix .OR. j+kk.LT.jx .OR.
3161 $ j+kk.GT.jx+n-1 )
3162 $ CALL pzerrset( err, errmax,
3163 $ x( i+ll+(j+kk-1)*ldx ),
3164 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3165 60 CONTINUE
3166 70 CONTINUE
3167 IF( colrep ) THEN
3168 j = j + inbx
3169 ELSE
3170 j = j + inbx + ( npcol - 1 ) * nbx
3171 END IF
3172*
3173 DO 100 jj = inbx+1, nqall, nbx
3174 jb = min( nqall-jj+1, nbx )
3175*
3176 DO 90 kk = 0, jb-1
3177 DO 80 ll = 0, ib-1
3178 IF( i+ll.NE.ix .OR. j+kk.LT.jx .OR.
3179 $ j+kk.GT.jx+n-1 )
3180 $ CALL pzerrset( err, errmax,
3181 $ x( i+ll+(j+kk-1)*ldx ),
3182 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3183 80 CONTINUE
3184 90 CONTINUE
3185*
3186 IF( colrep ) THEN
3187 j = j + nbx
3188 ELSE
3189 j = j + npcol * nbx
3190 END IF
3191*
3192 100 CONTINUE
3193*
3194 ii = ii + ib
3195*
3196 END IF
3197*
3198 icurrow = mod( icurrow + 1, nprow )
3199*
3200 110 CONTINUE
3201*
3202 ELSE
3203*
3204* sub( X ) is a column vector
3205*
3206 IF( mycol.EQ.icurcol .OR. colrep ) THEN
3207*
3208 j = 1
3209 IF( myrowdist.EQ.0 ) THEN
3210 i = 1
3211 ELSE
3212 i = descx( imb_ ) + ( myrowdist - 1 ) * mbx + 1
3213 END IF
3214 ib = min( max( 0, descx( m_ ) - i + 1 ), imbx )
3215 jb = min( descx( n_ ), descx( inb_ ) )
3216*
3217 DO 130 kk = 0, jb-1
3218 DO 120 ll = 0, ib-1
3219 IF( j+kk.NE.jx .OR. i+ll.LT.ix .OR. i+ll.GT.ix+n-1 )
3220 $ CALL pzerrset( err, errmax,
3221 $ x( i+ll+(j+kk-1)*ldx ),
3222 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3223 120 CONTINUE
3224 130 CONTINUE
3225 IF( rowrep ) THEN
3226 i = i + imbx
3227 ELSE
3228 i = i + imbx + ( nprow - 1 ) * mbx
3229 END IF
3230*
3231 DO 160 ii = imbx+1, mpall, mbx
3232 ib = min( mpall-ii+1, mbx )
3233*
3234 DO 150 kk = 0, jb-1
3235 DO 140 ll = 0, ib-1
3236 IF( j+kk.NE.jx .OR. i+ll.LT.ix .OR.
3237 $ i+ll.GT.ix+n-1 )
3238 $ CALL pzerrset( err, errmax,
3239 $ x( i+ll+(j+kk-1)*ldx ),
3240 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3241 140 CONTINUE
3242 150 CONTINUE
3243*
3244 IF( rowrep ) THEN
3245 i = i + mbx
3246 ELSE
3247 i = i + nprow * mbx
3248 END IF
3249*
3250 160 CONTINUE
3251*
3252 jj = jj + jb
3253*
3254 END IF
3255*
3256 icurcol = mod( icurcol + 1, npcol )
3257*
3258 DO 220 j = descx( inb_ ) + 1, descx( n_ ), nbx
3259 jb = min( descx( n_ ) - j + 1, nbx )
3260*
3261 IF( mycol.EQ.icurcol .OR. colrep ) THEN
3262*
3263 IF( myrowdist.EQ.0 ) THEN
3264 i = 1
3265 ELSE
3266 i = descx( imb_ ) + ( myrowdist - 1 ) * mbx + 1
3267 END IF
3268*
3269 ii = 1
3270 ib = min( max( 0, descx( m_ ) - i + 1 ), imbx )
3271 DO 180 kk = 0, jb-1
3272 DO 170 ll = 0, ib-1
3273 IF( j+kk.NE.jx .OR. i+ll.LT.ix .OR.
3274 $ i+ll.GT.ix+n-1 )
3275 $ CALL pzerrset( err, errmax,
3276 $ x( i+ll+(j+kk-1)*ldx ),
3277 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3278 170 CONTINUE
3279 180 CONTINUE
3280 IF( rowrep ) THEN
3281 i = i + imbx
3282 ELSE
3283 i = i + imbx + ( nprow - 1 ) * mbx
3284 END IF
3285*
3286 DO 210 ii = imbx+1, mpall, mbx
3287 ib = min( mpall-ii+1, mbx )
3288*
3289 DO 200 kk = 0, jb-1
3290 DO 190 ll = 0, ib-1
3291 IF( j+kk.NE.jx .OR. i+ll.LT.ix .OR.
3292 $ i+ll.GT.ix+n-1 )
3293 $ CALL pzerrset( err, errmax,
3294 $ x( i+ll+(j+kk-1)*ldx ),
3295 $ px( ii+ll+(jj+kk-1)*ldpx ) )
3296 190 CONTINUE
3297 200 CONTINUE
3298*
3299 IF( rowrep ) THEN
3300 i = i + mbx
3301 ELSE
3302 i = i + nprow * mbx
3303 END IF
3304*
3305 210 CONTINUE
3306*
3307 jj = jj + jb
3308*
3309 END IF
3310*
3311 icurcol = mod( icurcol + 1, npcol )
3312*
3313 220 CONTINUE
3314*
3315 END IF
3316*
3317 CALL dgamx2d( ictxt, 'All', ' ', 1, 1, errmax, 1, kk, ll, -1,
3318 $ -1, -1 )
3319*
3320 IF( errmax.GT.zero .AND. errmax.LE.eps ) THEN
3321 info = 1
3322 ELSE IF( errmax.GT.eps ) THEN
3323 info = -1
3324 END IF
3325*
3326 RETURN
3327*
3328* End of PZCHKVOUT
3329*

◆ pzdimee()

subroutine pzdimee ( integer ictxt,
integer nout,
external subptr,
integer scode,
character*(*) sname )

Definition at line 454 of file pzblastst.f.

455*
456* -- PBLAS test routine (version 2.0) --
457* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
458* and University of California, Berkeley.
459* April 1, 1998
460*
461* .. Scalar Arguments ..
462 INTEGER ICTXT, NOUT, SCODE
463* ..
464* .. Array Arguments ..
465 CHARACTER*(*) SNAME
466* ..
467* .. Subroutine Arguments ..
468 EXTERNAL subptr
469* ..
470*
471* Purpose
472* =======
473*
474* PZDIMEE tests whether the PBLAS respond correctly to a bad dimension
475* argument.
476*
477* Notes
478* =====
479*
480* A description vector is associated with each 2D block-cyclicly dis-
481* tributed matrix. This vector stores the information required to
482* establish the mapping between a matrix entry and its corresponding
483* process and memory location.
484*
485* In the following comments, the character _ should be read as
486* "of the distributed matrix". Let A be a generic term for any 2D
487* block cyclicly distributed matrix. Its description vector is DESCA:
488*
489* NOTATION STORED IN EXPLANATION
490* ---------------- --------------- ------------------------------------
491* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
492* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
493* the NPROW x NPCOL BLACS process grid
494* A is distributed over. The context
495* itself is global, but the handle
496* (the integer value) may vary.
497* M_A (global) DESCA( M_ ) The number of rows in the distribu-
498* ted matrix A, M_A >= 0.
499* N_A (global) DESCA( N_ ) The number of columns in the distri-
500* buted matrix A, N_A >= 0.
501* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
502* block of the matrix A, IMB_A > 0.
503* INB_A (global) DESCA( INB_ ) The number of columns of the upper
504* left block of the matrix A,
505* INB_A > 0.
506* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
507* bute the last M_A-IMB_A rows of A,
508* MB_A > 0.
509* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
510* bute the last N_A-INB_A columns of
511* A, NB_A > 0.
512* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
513* row of the matrix A is distributed,
514* NPROW > RSRC_A >= 0.
515* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
516* first column of A is distributed.
517* NPCOL > CSRC_A >= 0.
518* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
519* array storing the local blocks of
520* the distributed matrix A,
521* IF( Lc( 1, N_A ) > 0 )
522* LLD_A >= MAX( 1, Lr( 1, M_A ) )
523* ELSE
524* LLD_A >= 1.
525*
526* Let K be the number of rows of a matrix A starting at the global in-
527* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
528* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
529* receive if these K rows were distributed over NPROW processes. If K
530* is the number of columns of a matrix A starting at the global index
531* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
532* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
533* these K columns were distributed over NPCOL processes.
534*
535* The values of Lr() and Lc() may be determined via a call to the func-
536* tion PB_NUMROC:
537* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
538* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
539*
540* Arguments
541* =========
542*
543* ICTXT (local input) INTEGER
544* On entry, ICTXT specifies the BLACS context handle, indica-
545* ting the global context of the operation. The context itself
546* is global, but the value of ICTXT is local.
547*
548* NOUT (global input) INTEGER
549* On entry, NOUT specifies the unit number for the output file.
550* When NOUT is 6, output to screen, when NOUT is 0, output to
551* stderr. NOUT is only defined for process 0.
552*
553* SUBPTR (global input) SUBROUTINE
554* On entry, SUBPTR is a subroutine. SUBPTR must be declared
555* EXTERNAL in the calling subroutine.
556*
557* SCODE (global input) INTEGER
558* On entry, SCODE specifies the calling sequence code.
559*
560* SNAME (global input) CHARACTER*(*)
561* On entry, SNAME specifies the subroutine name calling this
562* subprogram.
563*
564* Calling sequence encodings
565* ==========================
566*
567* code Formal argument list Examples
568*
569* 11 (n, v1,v2) _SWAP, _COPY
570* 12 (n,s1, v1 ) _SCAL, _SCAL
571* 13 (n,s1, v1,v2) _AXPY, _DOT_
572* 14 (n,s1,i1,v1 ) _AMAX
573* 15 (n,u1, v1 ) _ASUM, _NRM2
574*
575* 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV
576* 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV
577* 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV
578* 24 ( m,n,s1,v1,v2,m1) _GER_
579* 25 (uplo, n,s1,v1, m1) _SYR
580* 26 (uplo, n,u1,v1, m1) _HER
581* 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2
582*
583* 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM
584* 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM
585* 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK
586* 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK
587* 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K
588* 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K
589* 37 ( m,n, s1,m1, s2,m3) _TRAN_
590* 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM
591* 39 ( trans, m,n, s1,m1, s2,m3) _GEADD
592* 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD
593*
594* -- Written on April 1, 1998 by
595* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
596*
597* =====================================================================
598*
599* .. Local Scalars ..
600 INTEGER APOS
601* ..
602* .. External Subroutines ..
603 EXTERNAL pzchkdim
604* ..
605* .. Executable Statements ..
606*
607* Level 1 PBLAS
608*
609 IF( scode.EQ.11 .OR. scode.EQ.12 .OR. scode.EQ.13 .OR.
610 $ scode.EQ.14 .OR. scode.EQ.15 ) THEN
611*
612* Check 1st (and only) dimension
613*
614 apos = 1
615 CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
616*
617* Level 2 PBLAS
618*
619 ELSE IF( scode.EQ.21 ) THEN
620*
621* Check 1st dimension
622*
623 apos = 2
624 CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
625*
626* Check 2nd dimension
627*
628 apos = 3
629 CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
630*
631 ELSE IF( scode.EQ.22 .OR. scode.EQ.25 .OR. scode.EQ.26 .OR.
632 $ scode.EQ.27 ) THEN
633*
634* Check 1st (and only) dimension
635*
636 apos = 2
637 CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
638*
639 ELSE IF( scode.EQ.23 ) THEN
640*
641* Check 1st (and only) dimension
642*
643 apos = 4
644 CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
645*
646 ELSE IF( scode.EQ.24 ) THEN
647*
648* Check 1st dimension
649*
650 apos = 1
651 CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
652*
653* Check 2nd dimension
654*
655 apos = 2
656 CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
657*
658* Level 3 PBLAS
659*
660 ELSE IF( scode.EQ.31 ) THEN
661*
662* Check 1st dimension
663*
664 apos = 3
665 CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
666*
667* Check 2nd dimension
668*
669 apos = 4
670 CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
671*
672* Check 3rd dimension
673*
674 apos = 5
675 CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'K', apos )
676*
677 ELSE IF( scode.EQ.32 ) THEN
678*
679* Check 1st dimension
680*
681 apos = 3
682 CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
683*
684* Check 2nd dimension
685*
686 apos = 4
687 CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
688*
689 ELSE IF( scode.EQ.33 .OR. scode.EQ.34 .OR. scode.EQ.35 .OR.
690 $ scode.EQ.36 ) THEN
691*
692* Check 1st dimension
693*
694 apos = 3
695 CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
696*
697* Check 2nd dimension
698*
699 apos = 4
700 CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'K', apos )
701*
702 ELSE IF( scode.EQ.37 ) THEN
703*
704* Check 1st dimension
705*
706 apos = 1
707 CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
708*
709* Check 2nd dimension
710*
711 apos = 2
712 CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
713*
714 ELSE IF( scode.EQ.38 ) THEN
715*
716* Check 1st dimension
717*
718 apos = 5
719 CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
720*
721* Check 2nd dimension
722*
723 apos = 6
724 CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
725*
726 ELSE IF( scode.EQ.39 ) THEN
727*
728* Check 1st dimension
729*
730 apos = 2
731 CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
732*
733* Check 2nd dimension
734*
735 apos = 3
736 CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
737*
738 ELSE IF( scode.EQ.40 ) THEN
739*
740* Check 1st dimension
741*
742 apos = 3
743 CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'M', apos )
744*
745* Check 2nd dimension
746*
747 apos = 4
748 CALL pzchkdim( ictxt, nout, subptr, scode, sname, 'N', apos )
749*
750 END IF
751*
752 RETURN
753*
754* End of PZDIMEE
755*
pzchkdim
subroutine pzchkdim(ictxt, nout, subptr, scode, sname, argnam, argpos)
Definition pzblastst.f:759

◆ pzerraxpby()

subroutine pzerraxpby ( double precision errbnd,
complex*16 alpha,
complex*16 x,
complex*16 beta,
complex*16 y,
double precision prec )

Definition at line 6943 of file pzblastst.f.

6944*
6945* -- PBLAS test routine (version 2.0) --
6946* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
6947* and University of California, Berkeley.
6948* April 1, 1998
6949*
6950* .. Scalar Arguments ..
6951 DOUBLE PRECISION ERRBND, PREC
6952 COMPLEX*16 ALPHA, BETA, X, Y
6953* ..
6954*
6955* Purpose
6956* =======
6957*
6958* PZERRAXPBY serially computes y := beta*y + alpha * x and returns a
6959* scaled relative acceptable error bound on the result.
6960*
6961* Arguments
6962* =========
6963*
6964* ERRBND (global output) DOUBLE PRECISION
6965* On exit, ERRBND specifies the scaled relative acceptable er-
6966* ror bound.
6967*
6968* ALPHA (global input) COMPLEX*16
6969* On entry, ALPHA specifies the scalar alpha.
6970*
6971* X (global input) COMPLEX*16
6972* On entry, X specifies the scalar x to be scaled.
6973*
6974* BETA (global input) COMPLEX*16
6975* On entry, BETA specifies the scalar beta.
6976*
6977* Y (global input/global output) COMPLEX*16
6978* On entry, Y specifies the scalar y to be added. On exit, Y
6979* contains the resulting scalar y.
6980*
6981* PREC (global input) DOUBLE PRECISION
6982* On entry, PREC specifies the machine precision.
6983*
6984* -- Written on April 1, 1998 by
6985* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
6986*
6987* =====================================================================
6988*
6989* .. Parameters ..
6990 DOUBLE PRECISION ONE, TWO, ZERO
6991 parameter( one = 1.0d+0, two = 2.0d+0,
6992 $ zero = 0.0d+0 )
6993* ..
6994* .. Local Scalars ..
6995 DOUBLE PRECISION ADDBND, FACT, SUMINEG, SUMIPOS, SUMRNEG,
6996 $ SUMRPOS
6997 COMPLEX*16 TMP
6998* ..
6999* .. Intrinsic Functions ..
7000* ..
7001* .. Executable Statements ..
7002*
7003 sumipos = zero
7004 sumineg = zero
7005 sumrpos = zero
7006 sumrneg = zero
7007 fact = one + two * prec
7008 addbnd = two * two * two * prec
7009*
7010 tmp = alpha * x
7011 IF( dble( tmp ).GE.zero ) THEN
7012 sumrpos = sumrpos + dble( tmp ) * fact
7013 ELSE
7014 sumrneg = sumrneg - dble( tmp ) * fact
7015 END IF
7016 IF( dimag( tmp ).GE.zero ) THEN
7017 sumipos = sumipos + dimag( tmp ) * fact
7018 ELSE
7019 sumineg = sumineg - dimag( tmp ) * fact
7020 END IF
7021*
7022 tmp = beta * y
7023 IF( dble( tmp ).GE.zero ) THEN
7024 sumrpos = sumrpos + dble( tmp ) * fact
7025 ELSE
7026 sumrneg = sumrneg - dble( tmp ) * fact
7027 END IF
7028 IF( dimag( tmp ).GE.zero ) THEN
7029 sumipos = sumipos + dimag( tmp ) * fact
7030 ELSE
7031 sumineg = sumineg - dimag( tmp ) * fact
7032 END IF
7033*
7034 y = ( beta * y ) + ( alpha * x )
7035*
7036 errbnd = addbnd * max( max( sumrpos, sumrneg ),
7037 $ max( sumipos, sumineg ) )
7038*
7039 RETURN
7040*
7041* End of PZERRAXPBY
7042*

◆ pzerrset()

subroutine pzerrset ( double precision err,
double precision errmax,
complex*16 xtrue,
complex*16 x )

Definition at line 2459 of file pzblastst.f.

2460*
2461* -- PBLAS test routine (version 2.0) --
2462* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
2463* and University of California, Berkeley.
2464* April 1, 1998
2465*
2466* .. Scalar Arguments ..
2467 DOUBLE PRECISION ERR, ERRMAX
2468 COMPLEX*16 X, XTRUE
2469* ..
2470*
2471* Purpose
2472* =======
2473*
2474* PZERRSET computes the absolute difference ERR = |XTRUE - X| and com-
2475* pares it with zero. ERRMAX accumulates the absolute error difference.
2476*
2477* Notes
2478* =====
2479*
2480* A description vector is associated with each 2D block-cyclicly dis-
2481* tributed matrix. This vector stores the information required to
2482* establish the mapping between a matrix entry and its corresponding
2483* process and memory location.
2484*
2485* In the following comments, the character _ should be read as
2486* "of the distributed matrix". Let A be a generic term for any 2D
2487* block cyclicly distributed matrix. Its description vector is DESCA:
2488*
2489* NOTATION STORED IN EXPLANATION
2490* ---------------- --------------- ------------------------------------
2491* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
2492* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
2493* the NPROW x NPCOL BLACS process grid
2494* A is distributed over. The context
2495* itself is global, but the handle
2496* (the integer value) may vary.
2497* M_A (global) DESCA( M_ ) The number of rows in the distribu-
2498* ted matrix A, M_A >= 0.
2499* N_A (global) DESCA( N_ ) The number of columns in the distri-
2500* buted matrix A, N_A >= 0.
2501* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
2502* block of the matrix A, IMB_A > 0.
2503* INB_A (global) DESCA( INB_ ) The number of columns of the upper
2504* left block of the matrix A,
2505* INB_A > 0.
2506* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
2507* bute the last M_A-IMB_A rows of A,
2508* MB_A > 0.
2509* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
2510* bute the last N_A-INB_A columns of
2511* A, NB_A > 0.
2512* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
2513* row of the matrix A is distributed,
2514* NPROW > RSRC_A >= 0.
2515* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
2516* first column of A is distributed.
2517* NPCOL > CSRC_A >= 0.
2518* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
2519* array storing the local blocks of
2520* the distributed matrix A,
2521* IF( Lc( 1, N_A ) > 0 )
2522* LLD_A >= MAX( 1, Lr( 1, M_A ) )
2523* ELSE
2524* LLD_A >= 1.
2525*
2526* Let K be the number of rows of a matrix A starting at the global in-
2527* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
2528* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
2529* receive if these K rows were distributed over NPROW processes. If K
2530* is the number of columns of a matrix A starting at the global index
2531* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
2532* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
2533* these K columns were distributed over NPCOL processes.
2534*
2535* The values of Lr() and Lc() may be determined via a call to the func-
2536* tion PB_NUMROC:
2537* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
2538* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
2539*
2540* Arguments
2541* =========
2542*
2543* ERR (local output) DOUBLE PRECISION
2544* On exit, ERR specifies the absolute difference |XTRUE - X|.
2545*
2546* ERRMAX (local input/local output) DOUBLE PRECISION
2547* On entry, ERRMAX specifies a previously computed error. On
2548* exit ERRMAX is the accumulated error MAX( ERRMAX, ERR ).
2549*
2550* XTRUE (local input) COMPLEX*16
2551* On entry, XTRUE specifies the true value.
2552*
2553* X (local input) COMPLEX*16
2554* On entry, X specifies the value to be compared to XTRUE.
2555*
2556* -- Written on April 1, 1998 by
2557* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
2558*
2559* =====================================================================
2560*
2561* .. External Functions ..
2562 DOUBLE PRECISION PDDIFF
2563 EXTERNAL pddiff
2564* ..
2565* .. Intrinsic Functions ..
2566 INTRINSIC abs, dble, dimag, max
2567* ..
2568* .. Executable Statements ..
2569*
2570 err = abs( pddiff( dble( xtrue ), dble( x ) ) )
2571 err = max( err, abs( pddiff( dimag( xtrue ), dimag( x ) ) ) )
2572*
2573 errmax = max( errmax, err )
2574*
2575 RETURN
2576*
2577* End of PZERRSET
2578*
pddiff
double precision function pddiff(x, y)
Definition pblastst.f:1269

◆ pzipset()

subroutine pzipset ( character*1 toggle,
integer n,
complex*16, dimension( * ) a,
integer ia,
integer ja,
integer, dimension( * ) desca )

Definition at line 7044 of file pzblastst.f.

7045*
7046* -- PBLAS test routine (version 2.0) --
7047* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
7048* and University of California, Berkeley.
7049* April 1, 1998
7050*
7051* .. Scalar Arguments ..
7052 CHARACTER*1 TOGGLE
7053 INTEGER IA, JA, N
7054* ..
7055* .. Array Arguments ..
7056 INTEGER DESCA( * )
7057 COMPLEX*16 A( * )
7058* ..
7059*
7060* Purpose
7061* =======
7062*
7063* PZIPSET sets the imaginary part of the diagonal entries of an n by n
7064* matrix sub( A ) denoting A( IA:IA+N-1, JA:JA+N-1 ). This is used to
7065* test the PBLAS routines for complex Hermitian matrices, which are
7066* either not supposed to access or use the imaginary parts of the dia-
7067* gonals, or supposed to set them to zero. The value used to set the
7068* imaginary part of the diagonals depends on the value of TOGGLE.
7069*
7070* Notes
7071* =====
7072*
7073* A description vector is associated with each 2D block-cyclicly dis-
7074* tributed matrix. This vector stores the information required to
7075* establish the mapping between a matrix entry and its corresponding
7076* process and memory location.
7077*
7078* In the following comments, the character _ should be read as
7079* "of the distributed matrix". Let A be a generic term for any 2D
7080* block cyclicly distributed matrix. Its description vector is DESCA:
7081*
7082* NOTATION STORED IN EXPLANATION
7083* ---------------- --------------- ------------------------------------
7084* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
7085* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
7086* the NPROW x NPCOL BLACS process grid
7087* A is distributed over. The context
7088* itself is global, but the handle
7089* (the integer value) may vary.
7090* M_A (global) DESCA( M_ ) The number of rows in the distribu-
7091* ted matrix A, M_A >= 0.
7092* N_A (global) DESCA( N_ ) The number of columns in the distri-
7093* buted matrix A, N_A >= 0.
7094* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
7095* block of the matrix A, IMB_A > 0.
7096* INB_A (global) DESCA( INB_ ) The number of columns of the upper
7097* left block of the matrix A,
7098* INB_A > 0.
7099* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
7100* bute the last M_A-IMB_A rows of A,
7101* MB_A > 0.
7102* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
7103* bute the last N_A-INB_A columns of
7104* A, NB_A > 0.
7105* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
7106* row of the matrix A is distributed,
7107* NPROW > RSRC_A >= 0.
7108* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
7109* first column of A is distributed.
7110* NPCOL > CSRC_A >= 0.
7111* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
7112* array storing the local blocks of
7113* the distributed matrix A,
7114* IF( Lc( 1, N_A ) > 0 )
7115* LLD_A >= MAX( 1, Lr( 1, M_A ) )
7116* ELSE
7117* LLD_A >= 1.
7118*
7119* Let K be the number of rows of a matrix A starting at the global in-
7120* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
7121* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
7122* receive if these K rows were distributed over NPROW processes. If K
7123* is the number of columns of a matrix A starting at the global index
7124* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
7125* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
7126* these K columns were distributed over NPCOL processes.
7127*
7128* The values of Lr() and Lc() may be determined via a call to the func-
7129* tion PB_NUMROC:
7130* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
7131* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
7132*
7133* Arguments
7134* =========
7135*
7136* TOGGLE (global input) CHARACTER*1
7137* On entry, TOGGLE specifies the set-value to be used as fol-
7138* lows:
7139* If TOGGLE = 'Z' or 'z', the imaginary part of the diago-
7140* nals are set to zero,
7141* If TOGGLE = 'B' or 'b', the imaginary part of the diago-
7142* nals are set to a large value.
7143*
7144* N (global input) INTEGER
7145* On entry, N specifies the order of sub( A ). N must be at
7146* least zero.
7147*
7148* A (local input/local output) pointer to COMPLEX*16
7149* On entry, A is an array of dimension (LLD_A, Ka), where Ka is
7150* at least Lc( 1, JA+N-1 ). Before entry, this array contains
7151* the local entries of the matrix A. On exit, the diagonals of
7152* sub( A ) have been updated as specified by TOGGLE.
7153*
7154* IA (global input) INTEGER
7155* On entry, IA specifies A's global row index, which points to
7156* the beginning of the submatrix sub( A ).
7157*
7158* JA (global input) INTEGER
7159* On entry, JA specifies A's global column index, which points
7160* to the beginning of the submatrix sub( A ).
7161*
7162* DESCA (global and local input) INTEGER array
7163* On entry, DESCA is an integer array of dimension DLEN_. This
7164* is the array descriptor for the matrix A.
7165*
7166* -- Written on April 1, 1998 by
7167* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
7168*
7169* =====================================================================
7170*
7171* .. Parameters ..
7172 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
7173 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
7174 $ RSRC_
7175 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
7176 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
7177 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
7178 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
7179 DOUBLE PRECISION ZERO
7180 parameter( zero = 0.0d+0 )
7181* ..
7182* .. Local Scalars ..
7183 LOGICAL COLREP, GODOWN, GOLEFT, ROWREP
7184 INTEGER I, IACOL, IAROW, ICTXT, IIA, IJOFFA, ILOW,
7185 $ IMB1, IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP,
7186 $ JJA, JOFFA, JOFFD, LCMT, LCMT00, LDA, LDAP1,
7187 $ LMBLOC, LNBLOC, LOW, MB, MBLKD, MBLKS, MBLOC,
7188 $ MRCOL, MRROW, MYCOL, MYROW, NB, NBLKD, NBLKS,
7189 $ NBLOC, NP, NPCOL, NPROW, NQ, PMB, QNB, UPP
7190 DOUBLE PRECISION ALPHA, ATMP
7191* ..
7192* .. Local Arrays ..
7193 INTEGER DESCA2( DLEN_ )
7194* ..
7195* .. External Subroutines ..
7196 EXTERNAL blacs_gridinfo, pb_ainfog2l, pb_binfo,
7197 $ pb_desctrans
7198* ..
7199* .. External Functions ..
7200 LOGICAL LSAME
7201 DOUBLE PRECISION PDLAMCH
7202 EXTERNAL lsame, pdlamch
7203* ..
7204* .. Intrinsic Functions ..
7205 INTRINSIC dble, dcmplx, max, min
7206* ..
7207* .. Executable Statements ..
7208*
7209* Convert descriptor
7210*
7211 CALL pb_desctrans( desca, desca2 )
7212*
7213* Get grid parameters
7214*
7215 ictxt = desca2( ctxt_ )
7216 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
7217*
7218 IF( n.LE.0 )
7219 $ RETURN
7220*
7221 IF( lsame( toggle, 'Z' ) ) THEN
7222 alpha = zero
7223 ELSE IF( lsame( toggle, 'B' ) ) THEN
7224 alpha = pdlamch( ictxt, 'Epsilon' )
7225 alpha = alpha / pdlamch( ictxt, 'Safe minimum' )
7226 END IF
7227*
7228 CALL pb_ainfog2l( n, n, ia, ja, desca2, nprow, npcol, myrow,
7229 $ mycol, imb1, inb1, np, nq, iia, jja, iarow,
7230 $ iacol, mrrow, mrcol )
7231*
7232 IF( np.LE.0 .OR. nq.LE.0 )
7233 $ RETURN
7234*
7235* Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
7236* ILOW, LOW, IUPP, and UPP.
7237*
7238 mb = desca2( mb_ )
7239 nb = desca2( nb_ )
7240 CALL pb_binfo( 0, np, nq, imb1, inb1, mb, nb, mrrow, mrcol,
7241 $ lcmt00, mblks, nblks, imbloc, inbloc, lmbloc,
7242 $ lnbloc, ilow, low, iupp, upp )
7243*
7244 ioffa = iia - 1
7245 joffa = jja - 1
7246 rowrep = ( desca2( rsrc_ ).EQ.-1 )
7247 colrep = ( desca2( csrc_ ).EQ.-1 )
7248 lda = desca2( lld_ )
7249 ldap1 = lda + 1
7250*
7251 IF( rowrep ) THEN
7252 pmb = mb
7253 ELSE
7254 pmb = nprow * mb
7255 END IF
7256 IF( colrep ) THEN
7257 qnb = nb
7258 ELSE
7259 qnb = npcol * nb
7260 END IF
7261*
7262* Handle the first block of rows or columns separately, and update
7263* LCMT00, MBLKS and NBLKS.
7264*
7265 godown = ( lcmt00.GT.iupp )
7266 goleft = ( lcmt00.LT.ilow )
7267*
7268 IF( .NOT.godown .AND. .NOT.goleft ) THEN
7269*
7270* LCMT00 >= ILOW && LCMT00 <= IUPP
7271*
7272 IF( lcmt00.GE.0 ) THEN
7273 ijoffa = ioffa + lcmt00 + ( joffa - 1 ) * lda
7274 DO 10 i = 1, min( inbloc, max( 0, imbloc - lcmt00 ) )
7275 atmp = dble( a( ijoffa + i*ldap1 ) )
7276 a( ijoffa + i*ldap1 ) = dcmplx( atmp, alpha )
7277 10 CONTINUE
7278 ELSE
7279 ijoffa = ioffa + ( joffa - lcmt00 - 1 ) * lda
7280 DO 20 i = 1, min( imbloc, max( 0, inbloc + lcmt00 ) )
7281 atmp = dble( a( ijoffa + i*ldap1 ) )
7282 a( ijoffa + i*ldap1 ) = dcmplx( atmp, alpha )
7283 20 CONTINUE
7284 END IF
7285 goleft = ( ( lcmt00 - ( iupp - upp + pmb ) ).LT.ilow )
7286 godown = .NOT.goleft
7287*
7288 END IF
7289*
7290 IF( godown ) THEN
7291*
7292 lcmt00 = lcmt00 - ( iupp - upp + pmb )
7293 mblks = mblks - 1
7294 ioffa = ioffa + imbloc
7295*
7296 30 CONTINUE
7297 IF( mblks.GT.0 .AND. lcmt00.GT.upp ) THEN
7298 lcmt00 = lcmt00 - pmb
7299 mblks = mblks - 1
7300 ioffa = ioffa + mb
7301 GO TO 30
7302 END IF
7303*
7304 IF( mblks.LE.0 )
7305 $ RETURN
7306*
7307 lcmt = lcmt00
7308 mblkd = mblks
7309 ioffd = ioffa
7310*
7311 mbloc = mb
7312 40 CONTINUE
7313 IF( mblkd.GT.0 .AND. lcmt.GE.ilow ) THEN
7314 IF( mblkd.EQ.1 )
7315 $ mbloc = lmbloc
7316 IF( lcmt.GE.0 ) THEN
7317 ijoffa = ioffd + lcmt + ( joffa - 1 ) * lda
7318 DO 50 i = 1, min( inbloc, max( 0, mbloc - lcmt ) )
7319 atmp = dble( a( ijoffa + i*ldap1 ) )
7320 a( ijoffa + i*ldap1 ) = dcmplx( atmp, alpha )
7321 50 CONTINUE
7322 ELSE
7323 ijoffa = ioffd + ( joffa - lcmt - 1 ) * lda
7324 DO 60 i = 1, min( mbloc, max( 0, inbloc + lcmt ) )
7325 atmp = dble( a( ijoffa + i*ldap1 ) )
7326 a( ijoffa + i*ldap1 ) = dcmplx( atmp, alpha )
7327 60 CONTINUE
7328 END IF
7329 lcmt00 = lcmt
7330 lcmt = lcmt - pmb
7331 mblks = mblkd
7332 mblkd = mblkd - 1
7333 ioffa = ioffd
7334 ioffd = ioffd + mbloc
7335 GO TO 40
7336 END IF
7337*
7338 lcmt00 = lcmt00 + low - ilow + qnb
7339 nblks = nblks - 1
7340 joffa = joffa + inbloc
7341*
7342 ELSE IF( goleft ) THEN
7343*
7344 lcmt00 = lcmt00 + low - ilow + qnb
7345 nblks = nblks - 1
7346 joffa = joffa + inbloc
7347*
7348 70 CONTINUE
7349 IF( nblks.GT.0 .AND. lcmt00.LT.low ) THEN
7350 lcmt00 = lcmt00 + qnb
7351 nblks = nblks - 1
7352 joffa = joffa + nb
7353 GO TO 70
7354 END IF
7355*
7356 IF( nblks.LE.0 )
7357 $ RETURN
7358*
7359 lcmt = lcmt00
7360 nblkd = nblks
7361 joffd = joffa
7362*
7363 nbloc = nb
7364 80 CONTINUE
7365 IF( nblkd.GT.0 .AND. lcmt.LE.iupp ) THEN
7366 IF( nblkd.EQ.1 )
7367 $ nbloc = lnbloc
7368 IF( lcmt.GE.0 ) THEN
7369 ijoffa = ioffa + lcmt + ( joffd - 1 ) * lda
7370 DO 90 i = 1, min( nbloc, max( 0, imbloc - lcmt ) )
7371 atmp = dble( a( ijoffa + i*ldap1 ) )
7372 a( ijoffa + i*ldap1 ) = dcmplx( atmp, alpha )
7373 90 CONTINUE
7374 ELSE
7375 ijoffa = ioffa + ( joffd - lcmt - 1 ) * lda
7376 DO 100 i = 1, min( imbloc, max( 0, nbloc + lcmt ) )
7377 atmp = dble( a( ijoffa + i*ldap1 ) )
7378 a( ijoffa + i*ldap1 ) = dcmplx( atmp, alpha )
7379 100 CONTINUE
7380 END IF
7381 lcmt00 = lcmt
7382 lcmt = lcmt + qnb
7383 nblks = nblkd
7384 nblkd = nblkd - 1
7385 joffa = joffd
7386 joffd = joffd + nbloc
7387 GO TO 80
7388 END IF
7389*
7390 lcmt00 = lcmt00 - ( iupp - upp + pmb )
7391 mblks = mblks - 1
7392 ioffa = ioffa + imbloc
7393*
7394 END IF
7395*
7396 nbloc = nb
7397 110 CONTINUE
7398 IF( nblks.GT.0 ) THEN
7399 IF( nblks.EQ.1 )
7400 $ nbloc = lnbloc
7401 120 CONTINUE
7402 IF( mblks.GT.0 .AND. lcmt00.GT.upp ) THEN
7403 lcmt00 = lcmt00 - pmb
7404 mblks = mblks - 1
7405 ioffa = ioffa + mb
7406 GO TO 120
7407 END IF
7408*
7409 IF( mblks.LE.0 )
7410 $ RETURN
7411*
7412 lcmt = lcmt00
7413 mblkd = mblks
7414 ioffd = ioffa
7415*
7416 mbloc = mb
7417 130 CONTINUE
7418 IF( mblkd.GT.0 .AND. lcmt.GE.low ) THEN
7419 IF( mblkd.EQ.1 )
7420 $ mbloc = lmbloc
7421 IF( lcmt.GE.0 ) THEN
7422 ijoffa = ioffd + lcmt + ( joffa - 1 ) * lda
7423 DO 140 i = 1, min( nbloc, max( 0, mbloc - lcmt ) )
7424 atmp = dble( a( ijoffa + i*ldap1 ) )
7425 a( ijoffa + i*ldap1 ) = dcmplx( atmp, alpha )
7426 140 CONTINUE
7427 ELSE
7428 ijoffa = ioffd + ( joffa - lcmt - 1 ) * lda
7429 DO 150 i = 1, min( mbloc, max( 0, nbloc + lcmt ) )
7430 atmp = dble( a( ijoffa + i*ldap1 ) )
7431 a( ijoffa + i*ldap1 ) = dcmplx( atmp, alpha )
7432 150 CONTINUE
7433 END IF
7434 lcmt00 = lcmt
7435 lcmt = lcmt - pmb
7436 mblks = mblkd
7437 mblkd = mblkd - 1
7438 ioffa = ioffd
7439 ioffd = ioffd + mbloc
7440 GO TO 130
7441 END IF
7442*
7443 lcmt00 = lcmt00 + qnb
7444 nblks = nblks - 1
7445 joffa = joffa + nbloc
7446 GO TO 110
7447*
7448 END IF
7449*
7450 RETURN
7451*
7452* End of PZIPSET
7453*
pb_ainfog2l
subroutine pb_ainfog2l(m, n, i, j, desc, nprow, npcol, myrow, mycol, imb1, inb1, mp, nq, ii, jj, prow, pcol, rprow, rpcol)
Definition pblastst.f:2023
pb_binfo
subroutine pb_binfo(offd, m, n, imb1, inb1, mb, nb, mrrow, mrcol, lcmt00, mblks, nblks, imbloc, inbloc, lmbloc, lnbloc, ilow, low, iupp, upp)
Definition pblastst.f:3577

◆ pzladom()

subroutine pzladom ( logical inplace,
integer n,
complex*16 alpha,
complex*16, dimension( * ) a,
integer ia,
integer ja,
integer, dimension( * ) desca )

Definition at line 8895 of file pzblastst.f.

8896*
8897* -- PBLAS test routine (version 2.0) --
8898* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
8899* and University of California, Berkeley.
8900* April 1, 1998
8901*
8902* .. Scalar Arguments ..
8903 LOGICAL INPLACE
8904 INTEGER IA, JA, N
8905 COMPLEX*16 ALPHA
8906* ..
8907* .. Array Arguments ..
8908 INTEGER DESCA( * )
8909 COMPLEX*16 A( * )
8910* ..
8911*
8912* Purpose
8913* =======
8914*
8915* PZLADOM adds alpha to the diagonal entries of an n by n submatrix
8916* sub( A ) denoting A( IA:IA+N-1, JA:JA+N-1 ).
8917*
8918* Notes
8919* =====
8920*
8921* A description vector is associated with each 2D block-cyclicly dis-
8922* tributed matrix. This vector stores the information required to
8923* establish the mapping between a matrix entry and its corresponding
8924* process and memory location.
8925*
8926* In the following comments, the character _ should be read as
8927* "of the distributed matrix". Let A be a generic term for any 2D
8928* block cyclicly distributed matrix. Its description vector is DESCA:
8929*
8930* NOTATION STORED IN EXPLANATION
8931* ---------------- --------------- ------------------------------------
8932* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
8933* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
8934* the NPROW x NPCOL BLACS process grid
8935* A is distributed over. The context
8936* itself is global, but the handle
8937* (the integer value) may vary.
8938* M_A (global) DESCA( M_ ) The number of rows in the distribu-
8939* ted matrix A, M_A >= 0.
8940* N_A (global) DESCA( N_ ) The number of columns in the distri-
8941* buted matrix A, N_A >= 0.
8942* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
8943* block of the matrix A, IMB_A > 0.
8944* INB_A (global) DESCA( INB_ ) The number of columns of the upper
8945* left block of the matrix A,
8946* INB_A > 0.
8947* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
8948* bute the last M_A-IMB_A rows of A,
8949* MB_A > 0.
8950* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
8951* bute the last N_A-INB_A columns of
8952* A, NB_A > 0.
8953* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
8954* row of the matrix A is distributed,
8955* NPROW > RSRC_A >= 0.
8956* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
8957* first column of A is distributed.
8958* NPCOL > CSRC_A >= 0.
8959* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
8960* array storing the local blocks of
8961* the distributed matrix A,
8962* IF( Lc( 1, N_A ) > 0 )
8963* LLD_A >= MAX( 1, Lr( 1, M_A ) )
8964* ELSE
8965* LLD_A >= 1.
8966*
8967* Let K be the number of rows of a matrix A starting at the global in-
8968* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
8969* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
8970* receive if these K rows were distributed over NPROW processes. If K
8971* is the number of columns of a matrix A starting at the global index
8972* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
8973* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
8974* these K columns were distributed over NPCOL processes.
8975*
8976* The values of Lr() and Lc() may be determined via a call to the func-
8977* tion PB_NUMROC:
8978* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
8979* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
8980*
8981* Arguments
8982* =========
8983*
8984* INPLACE (global input) LOGICAL
8985* On entry, INPLACE specifies if the matrix should be generated
8986* in place or not. If INPLACE is .TRUE., the local random array
8987* to be generated will start in memory at the local memory lo-
8988* cation A( 1, 1 ), otherwise it will start at the local posi-
8989* tion induced by IA and JA.
8990*
8991* N (global input) INTEGER
8992* On entry, N specifies the global order of the submatrix
8993* sub( A ) to be modified. N must be at least zero.
8994*
8995* ALPHA (global input) COMPLEX*16
8996* On entry, ALPHA specifies the scalar alpha.
8997*
8998* A (local input/local output) COMPLEX*16 array
8999* On entry, A is an array of dimension (LLD_A, Ka), where Ka is
9000* at least Lc( 1, JA+N-1 ). Before entry, this array contains
9001* the local entries of the matrix A. On exit, the local entries
9002* of this array corresponding to the main diagonal of sub( A )
9003* have been updated.
9004*
9005* IA (global input) INTEGER
9006* On entry, IA specifies A's global row index, which points to
9007* the beginning of the submatrix sub( A ).
9008*
9009* JA (global input) INTEGER
9010* On entry, JA specifies A's global column index, which points
9011* to the beginning of the submatrix sub( A ).
9012*
9013* DESCA (global and local input) INTEGER array
9014* On entry, DESCA is an integer array of dimension DLEN_. This
9015* is the array descriptor for the matrix A.
9016*
9017* -- Written on April 1, 1998 by
9018* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
9019*
9020* =====================================================================
9021*
9022* .. Parameters ..
9023 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
9024 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
9025 $ RSRC_
9026 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
9027 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
9028 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
9029 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
9030* ..
9031* .. Local Scalars ..
9032 LOGICAL GODOWN, GOLEFT
9033 INTEGER I, IACOL, IAROW, ICTXT, IIA, IJOFFA, ILOW,
9034 $ IMB1, IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP,
9035 $ JJA, JOFFA, JOFFD, LCMT, LCMT00, LDA, LDAP1,
9036 $ LMBLOC, LNBLOC, LOW, MB, MBLKD, MBLKS, MBLOC,
9037 $ MRCOL, MRROW, MYCOL, MYROW, NB, NBLKD, NBLKS,
9038 $ NBLOC, NP, NPCOL, NPROW, NQ, PMB, QNB, UPP
9039 COMPLEX*16 ATMP
9040* ..
9041* .. Local Scalars ..
9042 INTEGER DESCA2( DLEN_ )
9043* ..
9044* .. External Subroutines ..
9045 EXTERNAL blacs_gridinfo, pb_ainfog2l, pb_binfo,
9046 $ pb_desctrans
9047* ..
9048* .. Intrinsic Functions ..
9049 INTRINSIC abs, dble, dcmplx, dimag, max, min
9050* ..
9051* .. Executable Statements ..
9052*
9053* Convert descriptor
9054*
9055 CALL pb_desctrans( desca, desca2 )
9056*
9057* Get grid parameters
9058*
9059 ictxt = desca2( ctxt_ )
9060 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
9061*
9062 IF( n.EQ.0 )
9063 $ RETURN
9064*
9065 CALL pb_ainfog2l( n, n, ia, ja, desca2, nprow, npcol, myrow,
9066 $ mycol, imb1, inb1, np, nq, iia, jja, iarow,
9067 $ iacol, mrrow, mrcol )
9068*
9069* Decide where the entries shall be stored in memory
9070*
9071 IF( inplace ) THEN
9072 iia = 1
9073 jja = 1
9074 END IF
9075*
9076* Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
9077* ILOW, LOW, IUPP, and UPP.
9078*
9079 mb = desca2( mb_ )
9080 nb = desca2( nb_ )
9081*
9082 CALL pb_binfo( 0, np, nq, imb1, inb1, mb, nb, mrrow, mrcol,
9083 $ lcmt00, mblks, nblks, imbloc, inbloc, lmbloc,
9084 $ lnbloc, ilow, low, iupp, upp )
9085*
9086 ioffa = iia - 1
9087 joffa = jja - 1
9088 lda = desca2( lld_ )
9089 ldap1 = lda + 1
9090*
9091 IF( desca2( rsrc_ ).LT.0 ) THEN
9092 pmb = mb
9093 ELSE
9094 pmb = nprow * mb
9095 END IF
9096 IF( desca2( csrc_ ).LT.0 ) THEN
9097 qnb = nb
9098 ELSE
9099 qnb = npcol * nb
9100 END IF
9101*
9102* Handle the first block of rows or columns separately, and update
9103* LCMT00, MBLKS and NBLKS.
9104*
9105 godown = ( lcmt00.GT.iupp )
9106 goleft = ( lcmt00.LT.ilow )
9107*
9108 IF( .NOT.godown .AND. .NOT.goleft ) THEN
9109*
9110* LCMT00 >= ILOW && LCMT00 <= IUPP
9111*
9112 IF( lcmt00.GE.0 ) THEN
9113 ijoffa = ioffa+lcmt00 + ( joffa - 1 ) * lda
9114 DO 10 i = 1, min( inbloc, max( 0, imbloc - lcmt00 ) )
9115 atmp = a( ijoffa + i*ldap1 )
9116 a( ijoffa + i*ldap1 ) = alpha +
9117 $ dcmplx( abs( dble( atmp ) ),
9118 $ abs( dimag( atmp ) ) )
9119 10 CONTINUE
9120 ELSE
9121 ijoffa = ioffa + ( joffa - lcmt00 - 1 ) * lda
9122 DO 20 i = 1, min( imbloc, max( 0, inbloc + lcmt00 ) )
9123 atmp = a( ijoffa + i*ldap1 )
9124 a( ijoffa + i*ldap1 ) = alpha +
9125 $ dcmplx( abs( dble( atmp ) ),
9126 $ abs( dimag( atmp ) ) )
9127 20 CONTINUE
9128 END IF
9129 goleft = ( ( lcmt00 - ( iupp - upp + pmb ) ).LT.ilow )
9130 godown = .NOT.goleft
9131*
9132 END IF
9133*
9134 IF( godown ) THEN
9135*
9136 lcmt00 = lcmt00 - ( iupp - upp + pmb )
9137 mblks = mblks - 1
9138 ioffa = ioffa + imbloc
9139*
9140 30 CONTINUE
9141 IF( mblks.GT.0 .AND. lcmt00.GT.upp ) THEN
9142 lcmt00 = lcmt00 - pmb
9143 mblks = mblks - 1
9144 ioffa = ioffa + mb
9145 GO TO 30
9146 END IF
9147*
9148 lcmt = lcmt00
9149 mblkd = mblks
9150 ioffd = ioffa
9151*
9152 mbloc = mb
9153 40 CONTINUE
9154 IF( mblkd.GT.0 .AND. lcmt.GE.ilow ) THEN
9155 IF( mblkd.EQ.1 )
9156 $ mbloc = lmbloc
9157 IF( lcmt.GE.0 ) THEN
9158 ijoffa = ioffd + lcmt + ( joffa - 1 ) * lda
9159 DO 50 i = 1, min( inbloc, max( 0, mbloc - lcmt ) )
9160 atmp = a( ijoffa + i*ldap1 )
9161 a( ijoffa + i*ldap1 ) = alpha +
9162 $ dcmplx( abs( dble( atmp ) ),
9163 $ abs( dimag( atmp ) ) )
9164 50 CONTINUE
9165 ELSE
9166 ijoffa = ioffd + ( joffa - lcmt - 1 ) * lda
9167 DO 60 i = 1, min( mbloc, max( 0, inbloc + lcmt ) )
9168 atmp = a( ijoffa + i*ldap1 )
9169 a( ijoffa + i*ldap1 ) = alpha +
9170 $ dcmplx( abs( dble( atmp ) ),
9171 $ abs( dimag( atmp ) ) )
9172 60 CONTINUE
9173 END IF
9174 lcmt00 = lcmt
9175 lcmt = lcmt - pmb
9176 mblks = mblkd
9177 mblkd = mblkd - 1
9178 ioffa = ioffd
9179 ioffd = ioffd + mbloc
9180 GO TO 40
9181 END IF
9182*
9183 lcmt00 = lcmt00 + low - ilow + qnb
9184 nblks = nblks - 1
9185 joffa = joffa + inbloc
9186*
9187 ELSE IF( goleft ) THEN
9188*
9189 lcmt00 = lcmt00 + low - ilow + qnb
9190 nblks = nblks - 1
9191 joffa = joffa + inbloc
9192*
9193 70 CONTINUE
9194 IF( nblks.GT.0 .AND. lcmt00.LT.low ) THEN
9195 lcmt00 = lcmt00 + qnb
9196 nblks = nblks - 1
9197 joffa = joffa + nb
9198 GO TO 70
9199 END IF
9200*
9201 lcmt = lcmt00
9202 nblkd = nblks
9203 joffd = joffa
9204*
9205 nbloc = nb
9206 80 CONTINUE
9207 IF( nblkd.GT.0 .AND. lcmt.LE.iupp ) THEN
9208 IF( nblkd.EQ.1 )
9209 $ nbloc = lnbloc
9210 IF( lcmt.GE.0 ) THEN
9211 ijoffa = ioffa + lcmt + ( joffd - 1 ) * lda
9212 DO 90 i = 1, min( nbloc, max( 0, imbloc - lcmt ) )
9213 atmp = a( ijoffa + i*ldap1 )
9214 a( ijoffa + i*ldap1 ) = alpha +
9215 $ dcmplx( abs( dble( atmp ) ),
9216 $ abs( dimag( atmp ) ) )
9217 90 CONTINUE
9218 ELSE
9219 ijoffa = ioffa + ( joffd - lcmt - 1 ) * lda
9220 DO 100 i = 1, min( imbloc, max( 0, nbloc + lcmt ) )
9221 atmp = a( ijoffa + i*ldap1 )
9222 a( ijoffa + i*ldap1 ) = alpha +
9223 $ dcmplx( abs( dble( atmp ) ),
9224 $ abs( dimag( atmp ) ) )
9225 100 CONTINUE
9226 END IF
9227 lcmt00 = lcmt
9228 lcmt = lcmt + qnb
9229 nblks = nblkd
9230 nblkd = nblkd - 1
9231 joffa = joffd
9232 joffd = joffd + nbloc
9233 GO TO 80
9234 END IF
9235*
9236 lcmt00 = lcmt00 - ( iupp - upp + pmb )
9237 mblks = mblks - 1
9238 ioffa = ioffa + imbloc
9239*
9240 END IF
9241*
9242 nbloc = nb
9243 110 CONTINUE
9244 IF( nblks.GT.0 ) THEN
9245 IF( nblks.EQ.1 )
9246 $ nbloc = lnbloc
9247 120 CONTINUE
9248 IF( mblks.GT.0 .AND. lcmt00.GT.upp ) THEN
9249 lcmt00 = lcmt00 - pmb
9250 mblks = mblks - 1
9251 ioffa = ioffa + mb
9252 GO TO 120
9253 END IF
9254*
9255 lcmt = lcmt00
9256 mblkd = mblks
9257 ioffd = ioffa
9258*
9259 mbloc = mb
9260 130 CONTINUE
9261 IF( mblkd.GT.0 .AND. lcmt.GE.low ) THEN
9262 IF( mblkd.EQ.1 )
9263 $ mbloc = lmbloc
9264 IF( lcmt.GE.0 ) THEN
9265 ijoffa = ioffd + lcmt + ( joffa - 1 ) * lda
9266 DO 140 i = 1, min( nbloc, max( 0, mbloc - lcmt ) )
9267 atmp = a( ijoffa + i*ldap1 )
9268 a( ijoffa + i*ldap1 ) = alpha +
9269 $ dcmplx( abs( dble( atmp ) ),
9270 $ abs( dimag( atmp ) ) )
9271 140 CONTINUE
9272 ELSE
9273 ijoffa = ioffd + ( joffa - lcmt - 1 ) * lda
9274 DO 150 i = 1, min( mbloc, max( 0, nbloc + lcmt ) )
9275 atmp = a( ijoffa + i*ldap1 )
9276 a( ijoffa + i*ldap1 ) = alpha +
9277 $ dcmplx( abs( dble( atmp ) ),
9278 $ abs( dimag( atmp ) ) )
9279 150 CONTINUE
9280 END IF
9281 lcmt00 = lcmt
9282 lcmt = lcmt - pmb
9283 mblks = mblkd
9284 mblkd = mblkd - 1
9285 ioffa = ioffd
9286 ioffd = ioffd + mbloc
9287 GO TO 130
9288 END IF
9289*
9290 lcmt00 = lcmt00 + qnb
9291 nblks = nblks - 1
9292 joffa = joffa + nbloc
9293 GO TO 110
9294*
9295 END IF
9296*
9297 RETURN
9298*
9299* End of PZLADOM
9300*

◆ pzlagen()

subroutine pzlagen ( logical inplace,
character*1 aform,
character*1 diag,
integer offa,
integer m,
integer n,
integer ia,
integer ja,
integer, dimension( * ) desca,
integer iaseed,
complex*16, dimension( lda, * ) a,
integer lda )

Definition at line 8490 of file pzblastst.f.

8492*
8493* -- PBLAS test routine (version 2.0) --
8494* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
8495* and University of California, Berkeley.
8496* April 1, 1998
8497*
8498* .. Scalar Arguments ..
8499 LOGICAL INPLACE
8500 CHARACTER*1 AFORM, DIAG
8501 INTEGER IA, IASEED, JA, LDA, M, N, OFFA
8502* ..
8503* .. Array Arguments ..
8504 INTEGER DESCA( * )
8505 COMPLEX*16 A( LDA, * )
8506* ..
8507*
8508* Purpose
8509* =======
8510*
8511* PZLAGEN generates (or regenerates) a submatrix sub( A ) denoting
8512* A(IA:IA+M-1,JA:JA+N-1).
8513*
8514* Notes
8515* =====
8516*
8517* A description vector is associated with each 2D block-cyclicly dis-
8518* tributed matrix. This vector stores the information required to
8519* establish the mapping between a matrix entry and its corresponding
8520* process and memory location.
8521*
8522* In the following comments, the character _ should be read as
8523* "of the distributed matrix". Let A be a generic term for any 2D
8524* block cyclicly distributed matrix. Its description vector is DESCA:
8525*
8526* NOTATION STORED IN EXPLANATION
8527* ---------------- --------------- ------------------------------------
8528* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
8529* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
8530* the NPROW x NPCOL BLACS process grid
8531* A is distributed over. The context
8532* itself is global, but the handle
8533* (the integer value) may vary.
8534* M_A (global) DESCA( M_ ) The number of rows in the distribu-
8535* ted matrix A, M_A >= 0.
8536* N_A (global) DESCA( N_ ) The number of columns in the distri-
8537* buted matrix A, N_A >= 0.
8538* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
8539* block of the matrix A, IMB_A > 0.
8540* INB_A (global) DESCA( INB_ ) The number of columns of the upper
8541* left block of the matrix A,
8542* INB_A > 0.
8543* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
8544* bute the last M_A-IMB_A rows of A,
8545* MB_A > 0.
8546* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
8547* bute the last N_A-INB_A columns of
8548* A, NB_A > 0.
8549* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
8550* row of the matrix A is distributed,
8551* NPROW > RSRC_A >= 0.
8552* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
8553* first column of A is distributed.
8554* NPCOL > CSRC_A >= 0.
8555* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
8556* array storing the local blocks of
8557* the distributed matrix A,
8558* IF( Lc( 1, N_A ) > 0 )
8559* LLD_A >= MAX( 1, Lr( 1, M_A ) )
8560* ELSE
8561* LLD_A >= 1.
8562*
8563* Let K be the number of rows of a matrix A starting at the global in-
8564* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
8565* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
8566* receive if these K rows were distributed over NPROW processes. If K
8567* is the number of columns of a matrix A starting at the global index
8568* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
8569* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
8570* these K columns were distributed over NPCOL processes.
8571*
8572* The values of Lr() and Lc() may be determined via a call to the func-
8573* tion PB_NUMROC:
8574* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
8575* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
8576*
8577* Arguments
8578* =========
8579*
8580* INPLACE (global input) LOGICAL
8581* On entry, INPLACE specifies if the matrix should be generated
8582* in place or not. If INPLACE is .TRUE., the local random array
8583* to be generated will start in memory at the local memory lo-
8584* cation A( 1, 1 ), otherwise it will start at the local posi-
8585* tion induced by IA and JA.
8586*
8587* AFORM (global input) CHARACTER*1
8588* On entry, AFORM specifies the type of submatrix to be genera-
8589* ted as follows:
8590* AFORM = 'S', sub( A ) is a symmetric matrix,
8591* AFORM = 'H', sub( A ) is a Hermitian matrix,
8592* AFORM = 'T', sub( A ) is overrwritten with the transpose
8593* of what would normally be generated,
8594* AFORM = 'C', sub( A ) is overwritten with the conjugate
8595* transpose of what would normally be genera-
8596* ted.
8597* AFORM = 'N', a random submatrix is generated.
8598*
8599* DIAG (global input) CHARACTER*1
8600* On entry, DIAG specifies if the generated submatrix is diago-
8601* nally dominant or not as follows:
8602* DIAG = 'D' : sub( A ) is diagonally dominant,
8603* DIAG = 'N' : sub( A ) is not diagonally dominant.
8604*
8605* OFFA (global input) INTEGER
8606* On entry, OFFA specifies the offdiagonal of the underlying
8607* matrix A(1:DESCA(M_),1:DESCA(N_)) of interest when the subma-
8608* trix is symmetric, Hermitian or diagonally dominant. OFFA = 0
8609* specifies the main diagonal, OFFA > 0 specifies a subdiago-
8610* nal, and OFFA < 0 specifies a superdiagonal (see further de-
8611* tails).
8612*
8613* M (global input) INTEGER
8614* On entry, M specifies the global number of matrix rows of the
8615* submatrix sub( A ) to be generated. M must be at least zero.
8616*
8617* N (global input) INTEGER
8618* On entry, N specifies the global number of matrix columns of
8619* the submatrix sub( A ) to be generated. N must be at least
8620* zero.
8621*
8622* IA (global input) INTEGER
8623* On entry, IA specifies A's global row index, which points to
8624* the beginning of the submatrix sub( A ).
8625*
8626* JA (global input) INTEGER
8627* On entry, JA specifies A's global column index, which points
8628* to the beginning of the submatrix sub( A ).
8629*
8630* DESCA (global and local input) INTEGER array
8631* On entry, DESCA is an integer array of dimension DLEN_. This
8632* is the array descriptor for the matrix A.
8633*
8634* IASEED (global input) INTEGER
8635* On entry, IASEED specifies the seed number to generate the
8636* matrix A. IASEED must be at least zero.
8637*
8638* A (local output) COMPLEX*16 array
8639* On entry, A is an array of dimension (LLD_A, Ka), where Ka is
8640* at least Lc( 1, JA+N-1 ). On exit, this array contains the
8641* local entries of the randomly generated submatrix sub( A ).
8642*
8643* LDA (local input) INTEGER
8644* On entry, LDA specifies the local leading dimension of the
8645* array A. When INPLACE is .FALSE., LDA is usually DESCA(LLD_).
8646* This restriction is however not enforced, and this subroutine
8647* requires only that LDA >= MAX( 1, Mp ) where
8648*
8649* Mp = PB_NUMROC( M, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW ).
8650*
8651* PB_NUMROC is a ScaLAPACK tool function; MYROW, MYCOL, NPROW
8652* and NPCOL can be determined by calling the BLACS subroutine
8653* BLACS_GRIDINFO.
8654*
8655* Further Details
8656* ===============
8657*
8658* OFFD is tied to the matrix described by DESCA, as opposed to the
8659* piece that is currently (re)generated. This is a global information
8660* independent from the distribution parameters. Below are examples of
8661* the meaning of OFFD for a global 7 by 5 matrix:
8662*
8663* ---------------------------------------------------------------------
8664* OFFD | 0 -1 -2 -3 -4 0 -1 -2 -3 -4 0 -1 -2 -3 -4
8665* -------|-------------------------------------------------------------
8666* | | OFFD=-1 | OFFD=0 OFFD=2
8667* | V V
8668* 0 | . d . . . -> d . . . . . . . . .
8669* 1 | . . d . . . d . . . . . . . .
8670* 2 | . . . d . . . d . . -> d . . . .
8671* 3 | . . . . d . . . d . . d . . .
8672* 4 | . . . . . . . . . d . . d . .
8673* 5 | . . . . . . . . . . . . . d .
8674* 6 | . . . . . . . . . . . . . . d
8675* ---------------------------------------------------------------------
8676*
8677* -- Written on April 1, 1998 by
8678* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
8679*
8680* =====================================================================
8681*
8682* .. Parameters ..
8683 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
8684 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
8685 $ RSRC_
8686 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
8687 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
8688 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
8689 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
8690 INTEGER JMP_1, JMP_COL, JMP_IMBV, JMP_INBV, JMP_LEN,
8691 $ JMP_MB, JMP_NB, JMP_NPIMBLOC, JMP_NPMB,
8692 $ JMP_NQINBLOC, JMP_NQNB, JMP_ROW
8693 parameter( jmp_1 = 1, jmp_row = 2, jmp_col = 3,
8694 $ jmp_mb = 4, jmp_imbv = 5, jmp_npmb = 6,
8695 $ jmp_npimbloc = 7, jmp_nb = 8, jmp_inbv = 9,
8696 $ jmp_nqnb = 10, jmp_nqinbloc = 11,
8697 $ jmp_len = 11 )
8698 DOUBLE PRECISION ZERO
8699 parameter( zero = 0.0d+0 )
8700* ..
8701* .. Local Scalars ..
8702 LOGICAL DIAGDO, SYMM, HERM, NOTRAN
8703 INTEGER CSRC, I, IACOL, IAROW, ICTXT, IIA, ILOCBLK,
8704 $ ILOCOFF, ILOW, IMB, IMB1, IMBLOC, IMBVIR, INB,
8705 $ INB1, INBLOC, INBVIR, INFO, IOFFDA, ITMP, IUPP,
8706 $ IVIR, JJA, JLOCBLK, JLOCOFF, JVIR, LCMT00,
8707 $ LMBLOC, LNBLOC, LOW, MAXMN, MB, MBLKS, MP,
8708 $ MRCOL, MRROW, MYCDIST, MYCOL, MYRDIST, MYROW,
8709 $ NB, NBLKS, NPCOL, NPROW, NQ, NVIR, RSRC, UPP
8710 COMPLEX*16 ALPHA
8711* ..
8712* .. Local Arrays ..
8713 INTEGER DESCA2( DLEN_ ), IMULADD( 4, JMP_LEN ),
8714 $ IRAN( 2 ), JMP( JMP_LEN ), MULADD0( 4 )
8715* ..
8716* .. External Subroutines ..
8717 EXTERNAL blacs_gridinfo, pb_ainfog2l, pb_binfo,
8718 $ pb_chkmat, pb_desctrans, pb_initjmp,
8719 $ pb_initmuladd, pb_jump, pb_jumpit, pb_locinfo,
8720 $ pb_setlocran, pb_setran, pb_zlagen, pxerbla,
8721 $ pzladom
8722* ..
8723* .. External Functions ..
8724 LOGICAL LSAME
8725 EXTERNAL lsame
8726* ..
8727* .. Intrinsic Functions ..
8728 INTRINSIC dble, dcmplx, max, min
8729* ..
8730* .. Data Statements ..
8731 DATA ( muladd0( i ), i = 1, 4 ) / 20077, 16838,
8732 $ 12345, 0 /
8733* ..
8734* .. Executable Statements ..
8735*
8736* Convert descriptor
8737*
8738 CALL pb_desctrans( desca, desca2 )
8739*
8740* Test the input arguments
8741*
8742 ictxt = desca2( ctxt_ )
8743 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
8744*
8745* Test the input parameters
8746*
8747 info = 0
8748 IF( nprow.EQ.-1 ) THEN
8749 info = -( 1000 + ctxt_ )
8750 ELSE
8751 symm = lsame( aform, 'S' )
8752 herm = lsame( aform, 'H' )
8753 notran = lsame( aform, 'N' )
8754 diagdo = lsame( diag, 'D' )
8755 IF( .NOT.( symm.OR.herm.OR.notran ) .AND.
8756 $ .NOT.( lsame( aform, 'T' ) ) .AND.
8757 $ .NOT.( lsame( aform, 'C' ) ) ) THEN
8758 info = -2
8759 ELSE IF( ( .NOT.diagdo ) .AND.
8760 $ ( .NOT.lsame( diag, 'N' ) ) ) THEN
8761 info = -3
8762 END IF
8763 CALL pb_chkmat( ictxt, m, 5, n, 6, ia, ja, desca2, 10, info )
8764 END IF
8765*
8766 IF( info.NE.0 ) THEN
8767 CALL pxerbla( ictxt, 'PZLAGEN', -info )
8768 RETURN
8769 END IF
8770*
8771* Quick return if possible
8772*
8773 IF( ( m.LE.0 ).OR.( n.LE.0 ) )
8774 $ RETURN
8775*
8776* Start the operations
8777*
8778 mb = desca2( mb_ )
8779 nb = desca2( nb_ )
8780 imb = desca2( imb_ )
8781 inb = desca2( inb_ )
8782 rsrc = desca2( rsrc_ )
8783 csrc = desca2( csrc_ )
8784*
8785* Figure out local information about the distributed matrix operand
8786*
8787 CALL pb_ainfog2l( m, n, ia, ja, desca2, nprow, npcol, myrow,
8788 $ mycol, imb1, inb1, mp, nq, iia, jja, iarow,
8789 $ iacol, mrrow, mrcol )
8790*
8791* Decide where the entries shall be stored in memory
8792*
8793 IF( inplace ) THEN
8794 iia = 1
8795 jja = 1
8796 END IF
8797*
8798* Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
8799* ILOW, LOW, IUPP, and UPP.
8800*
8801 ioffda = ja + offa - ia
8802 CALL pb_binfo( ioffda, mp, nq, imb1, inb1, mb, nb, mrrow,
8803 $ mrcol, lcmt00, mblks, nblks, imbloc, inbloc,
8804 $ lmbloc, lnbloc, ilow, low, iupp, upp )
8805*
8806* Initialize ILOCBLK, ILOCOFF, MYRDIST, JLOCBLK, JLOCOFF, MYCDIST
8807* This values correspond to the square virtual underlying matrix
8808* of size MAX( M_ + MAX( 0, -OFFA ), N_ + MAX( 0, OFFA ) ) used
8809* to set up the random sequence. For practical purposes, the size
8810* of this virtual matrix is upper bounded by M_ + N_ - 1.
8811*
8812 itmp = max( 0, -offa )
8813 ivir = ia + itmp
8814 imbvir = imb + itmp
8815 nvir = desca2( m_ ) + itmp
8816*
8817 CALL pb_locinfo( ivir, imbvir, mb, myrow, rsrc, nprow, ilocblk,
8818 $ ilocoff, myrdist )
8819*
8820 itmp = max( 0, offa )
8821 jvir = ja + itmp
8822 inbvir = inb + itmp
8823 nvir = max( max( nvir, desca2( n_ ) + itmp ),
8824 $ desca2( m_ ) + desca2( n_ ) - 1 )
8825*
8826 CALL pb_locinfo( jvir, inbvir, nb, mycol, csrc, npcol, jlocblk,
8827 $ jlocoff, mycdist )
8828*
8829 IF( symm .OR. herm .OR. notran ) THEN
8830*
8831 CALL pb_initjmp( .true., nvir, imbvir, inbvir, imbloc, inbloc,
8832 $ mb, nb, rsrc, csrc, nprow, npcol, 2, jmp )
8833*
8834* Compute constants to jump JMP( * ) numbers in the sequence
8835*
8836 CALL pb_initmuladd( muladd0, jmp, imuladd )
8837*
8838* Compute and set the random value corresponding to A( IA, JA )
8839*
8840 CALL pb_setlocran( iaseed, ilocblk, jlocblk, ilocoff, jlocoff,
8841 $ myrdist, mycdist, nprow, npcol, jmp,
8842 $ imuladd, iran )
8843*
8844 CALL pb_zlagen( 'Lower', aform, a( iia, jja ), lda, lcmt00,
8845 $ iran, mblks, imbloc, mb, lmbloc, nblks, inbloc,
8846 $ nb, lnbloc, jmp, imuladd )
8847*
8848 END IF
8849*
8850 IF( symm .OR. herm .OR. ( .NOT. notran ) ) THEN
8851*
8852 CALL pb_initjmp( .false., nvir, imbvir, inbvir, imbloc, inbloc,
8853 $ mb, nb, rsrc, csrc, nprow, npcol, 2, jmp )
8854*
8855* Compute constants to jump JMP( * ) numbers in the sequence
8856*
8857 CALL pb_initmuladd( muladd0, jmp, imuladd )
8858*
8859* Compute and set the random value corresponding to A( IA, JA )
8860*
8861 CALL pb_setlocran( iaseed, ilocblk, jlocblk, ilocoff, jlocoff,
8862 $ myrdist, mycdist, nprow, npcol, jmp,
8863 $ imuladd, iran )
8864*
8865 CALL pb_zlagen( 'Upper', aform, a( iia, jja ), lda, lcmt00,
8866 $ iran, mblks, imbloc, mb, lmbloc, nblks, inbloc,
8867 $ nb, lnbloc, jmp, imuladd )
8868*
8869 END IF
8870*
8871 IF( diagdo ) THEN
8872*
8873 maxmn = max( desca2( m_ ), desca2( n_ ) )
8874 IF( herm ) THEN
8875 alpha = dcmplx( dble( 2 * maxmn ), zero )
8876 ELSE
8877 alpha = dcmplx( dble( nvir ), dble( maxmn ) )
8878 END IF
8879*
8880 IF( ioffda.GE.0 ) THEN
8881 CALL pzladom( inplace, min( max( 0, m-ioffda ), n ), alpha,
8882 $ a, min( ia+ioffda, ia+m-1 ), ja, desca )
8883 ELSE
8884 CALL pzladom( inplace, min( m, max( 0, n+ioffda ) ), alpha,
8885 $ a, ia, min( ja-ioffda, ja+n-1 ), desca )
8886 END IF
8887*
8888 END IF
8889*
8890 RETURN
8891*
8892* End of PZLAGEN
8893*
pxerbla
subroutine pxerbla(contxt, srname, info)
Definition mpi.f:1600
pb_setran
subroutine pb_setran(iran, iac)
Definition pblastst.f:4759
pb_locinfo
subroutine pb_locinfo(i, inb, nb, myroc, srcproc, nprocs, ilocblk, ilocoff, mydist)
Definition pblastst.f:3910
pb_chkmat
subroutine pb_chkmat(ictxt, m, mpos0, n, npos0, ia, ja, desca, dpos0, info)
Definition pblastst.f:2742
pb_jump
subroutine pb_jump(k, muladd, irann, iranm, ima)
Definition pblastst.f:4648
pb_setlocran
subroutine pb_setlocran(seed, ilocblk, jlocblk, ilocoff, jlocoff, myrdist, mycdist, nprow, npcol, jmp, imuladd, iran)
Definition pblastst.f:4302
pb_initmuladd
subroutine pb_initmuladd(muladd0, jmp, imuladd)
Definition pblastst.f:4196
pb_initjmp
subroutine pb_initjmp(colmaj, nvir, imbvir, inbvir, imbloc, inbloc, mb, nb, rsrc, csrc, nprow, npcol, stride, jmp)
Definition pblastst.f:4045
pb_zlagen
subroutine pb_zlagen(uplo, aform, a, lda, lcmt00, iran, mblks, imbloc, mb, lmbloc, nblks, inbloc, nb, lnbloc, jmp, imuladd)
Definition pzblastst.f:10427
pzladom
subroutine pzladom(inplace, n, alpha, a, ia, ja, desca)
Definition pzblastst.f:8896

◆ pzlascal()

subroutine pzlascal ( character*1 type,
integer m,
integer n,
complex*16 alpha,
complex*16, dimension( * ) a,
integer ia,
integer ja,
integer, dimension( * ) desca )

Definition at line 7983 of file pzblastst.f.

7984*
7985* -- PBLAS test routine (version 2.0) --
7986* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
7987* and University of California, Berkeley.
7988* April 1, 1998
7989*
7990* .. Scalar Arguments ..
7991 CHARACTER*1 TYPE
7992 INTEGER IA, JA, M, N
7993 COMPLEX*16 ALPHA
7994* ..
7995* .. Array Arguments ..
7996 INTEGER DESCA( * )
7997 COMPLEX*16 A( * )
7998* ..
7999*
8000* Purpose
8001* =======
8002*
8003* PZLASCAL scales the m by n submatrix A(IA:IA+M-1,JA:JA+N-1) denoted
8004* by sub( A ) by the scalar alpha. TYPE specifies if sub( A ) is full,
8005* upper triangular, lower triangular or upper Hessenberg.
8006*
8007* Notes
8008* =====
8009*
8010* A description vector is associated with each 2D block-cyclicly dis-
8011* tributed matrix. This vector stores the information required to
8012* establish the mapping between a matrix entry and its corresponding
8013* process and memory location.
8014*
8015* In the following comments, the character _ should be read as
8016* "of the distributed matrix". Let A be a generic term for any 2D
8017* block cyclicly distributed matrix. Its description vector is DESCA:
8018*
8019* NOTATION STORED IN EXPLANATION
8020* ---------------- --------------- ------------------------------------
8021* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
8022* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
8023* the NPROW x NPCOL BLACS process grid
8024* A is distributed over. The context
8025* itself is global, but the handle
8026* (the integer value) may vary.
8027* M_A (global) DESCA( M_ ) The number of rows in the distribu-
8028* ted matrix A, M_A >= 0.
8029* N_A (global) DESCA( N_ ) The number of columns in the distri-
8030* buted matrix A, N_A >= 0.
8031* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
8032* block of the matrix A, IMB_A > 0.
8033* INB_A (global) DESCA( INB_ ) The number of columns of the upper
8034* left block of the matrix A,
8035* INB_A > 0.
8036* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
8037* bute the last M_A-IMB_A rows of A,
8038* MB_A > 0.
8039* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
8040* bute the last N_A-INB_A columns of
8041* A, NB_A > 0.
8042* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
8043* row of the matrix A is distributed,
8044* NPROW > RSRC_A >= 0.
8045* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
8046* first column of A is distributed.
8047* NPCOL > CSRC_A >= 0.
8048* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
8049* array storing the local blocks of
8050* the distributed matrix A,
8051* IF( Lc( 1, N_A ) > 0 )
8052* LLD_A >= MAX( 1, Lr( 1, M_A ) )
8053* ELSE
8054* LLD_A >= 1.
8055*
8056* Let K be the number of rows of a matrix A starting at the global in-
8057* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
8058* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
8059* receive if these K rows were distributed over NPROW processes. If K
8060* is the number of columns of a matrix A starting at the global index
8061* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
8062* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
8063* these K columns were distributed over NPCOL processes.
8064*
8065* The values of Lr() and Lc() may be determined via a call to the func-
8066* tion PB_NUMROC:
8067* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
8068* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
8069*
8070* Arguments
8071* =========
8072*
8073* TYPE (global input) CHARACTER*1
8074* On entry, TYPE specifies the type of the input submatrix as
8075* follows:
8076* = 'L' or 'l': sub( A ) is a lower triangular matrix,
8077* = 'U' or 'u': sub( A ) is an upper triangular matrix,
8078* = 'H' or 'h': sub( A ) is an upper Hessenberg matrix,
8079* otherwise sub( A ) is a full matrix.
8080*
8081* M (global input) INTEGER
8082* On entry, M specifies the number of rows of the submatrix
8083* sub( A ). M must be at least zero.
8084*
8085* N (global input) INTEGER
8086* On entry, N specifies the number of columns of the submatrix
8087* sub( A ). N must be at least zero.
8088*
8089* ALPHA (global input) COMPLEX*16
8090* On entry, ALPHA specifies the scalar alpha.
8091*
8092* A (local input/local output) COMPLEX*16 array
8093* On entry, A is an array of dimension (LLD_A, Ka), where Ka is
8094* at least Lc( 1, JA+N-1 ). Before entry, this array contains
8095* the local entries of the matrix A.
8096* On exit, the local entries of this array corresponding to the
8097* to the entries of the submatrix sub( A ) are overwritten by
8098* the local entries of the m by n scaled submatrix.
8099*
8100* IA (global input) INTEGER
8101* On entry, IA specifies A's global row index, which points to
8102* the beginning of the submatrix sub( A ).
8103*
8104* JA (global input) INTEGER
8105* On entry, JA specifies A's global column index, which points
8106* to the beginning of the submatrix sub( A ).
8107*
8108* DESCA (global and local input) INTEGER array
8109* On entry, DESCA is an integer array of dimension DLEN_. This
8110* is the array descriptor for the matrix A.
8111*
8112* -- Written on April 1, 1998 by
8113* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
8114*
8115* =====================================================================
8116*
8117* .. Parameters ..
8118 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
8119 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
8120 $ RSRC_
8121 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
8122 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
8123 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
8124 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
8125* ..
8126* .. Local Scalars ..
8127 CHARACTER*1 UPLO
8128 LOGICAL GODOWN, GOLEFT, LOWER, UPPER
8129 INTEGER IACOL, IAROW, ICTXT, IIA, IIMAX, ILOW, IMB1,
8130 $ IMBLOC, INB1, INBLOC, IOFFA, IOFFD, ITYPE,
8131 $ IUPP, JJA, JJMAX, JOFFA, JOFFD, LCMT, LCMT00,
8132 $ LDA, LMBLOC, LNBLOC, LOW, M1, MB, MBLKD, MBLKS,
8133 $ MBLOC, MP, MRCOL, MRROW, MYCOL, MYROW, N1, NB,
8134 $ NBLKD, NBLKS, NBLOC, NPCOL, NPROW, NQ, PMB,
8135 $ QNB, TMP1, UPP
8136* ..
8137* .. Local Arrays ..
8138 INTEGER DESCA2( DLEN_ )
8139* ..
8140* .. External Subroutines ..
8141 EXTERNAL blacs_gridinfo, pb_ainfog2l, pb_binfo,
8142 $ pb_desctrans, pb_infog2l, pb_zlascal
8143* ..
8144* .. External Functions ..
8145 LOGICAL LSAME
8146 INTEGER PB_NUMROC
8147 EXTERNAL lsame, pb_numroc
8148* ..
8149* .. Intrinsic Functions ..
8150 INTRINSIC min
8151* ..
8152* .. Executable Statements ..
8153*
8154* Convert descriptor
8155*
8156 CALL pb_desctrans( desca, desca2 )
8157*
8158* Get grid parameters
8159*
8160 ictxt = desca2( ctxt_ )
8161 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
8162*
8163* Quick return if possible
8164*
8165 IF( m.EQ.0 .OR. n.EQ.0 )
8166 $ RETURN
8167*
8168 IF( lsame( TYPE, 'L' ) ) THEN
8169 itype = 1
8170 uplo = TYPE
8171 upper = .false.
8172 lower = .true.
8173 ioffd = 0
8174 ELSE IF( lsame( TYPE, 'U' ) ) THEN
8175 itype = 2
8176 uplo = TYPE
8177 upper = .true.
8178 lower = .false.
8179 ioffd = 0
8180 ELSE IF( lsame( TYPE, 'H' ) ) THEN
8181 itype = 3
8182 uplo = 'U'
8183 upper = .true.
8184 lower = .false.
8185 ioffd = 1
8186 ELSE
8187 itype = 0
8188 uplo = 'A'
8189 upper = .true.
8190 lower = .true.
8191 ioffd = 0
8192 END IF
8193*
8194* Compute local indexes
8195*
8196 IF( itype.EQ.0 ) THEN
8197*
8198* Full matrix
8199*
8200 CALL pb_infog2l( ia, ja, desca2, nprow, npcol, myrow, mycol,
8201 $ iia, jja, iarow, iacol )
8202 mp = pb_numroc( m, ia, desca2( imb_ ), desca2( mb_ ), myrow,
8203 $ desca2( rsrc_ ), nprow )
8204 nq = pb_numroc( n, ja, desca2( inb_ ), desca2( nb_ ), mycol,
8205 $ desca2( csrc_ ), npcol )
8206*
8207 IF( mp.LE.0 .OR. nq.LE.0 )
8208 $ RETURN
8209*
8210 lda = desca2( lld_ )
8211 ioffa = iia + ( jja - 1 ) * lda
8212*
8213 CALL pb_zlascal( 'All', mp, nq, 0, alpha, a( ioffa ), lda )
8214*
8215 ELSE
8216*
8217* Trapezoidal matrix
8218*
8219 CALL pb_ainfog2l( m, n, ia, ja, desca2, nprow, npcol, myrow,
8220 $ mycol, imb1, inb1, mp, nq, iia, jja, iarow,
8221 $ iacol, mrrow, mrcol )
8222*
8223 IF( mp.LE.0 .OR. nq.LE.0 )
8224 $ RETURN
8225*
8226* Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC,
8227* LNBLOC, ILOW, LOW, IUPP, and UPP.
8228*
8229 mb = desca2( mb_ )
8230 nb = desca2( nb_ )
8231 lda = desca2( lld_ )
8232*
8233 CALL pb_binfo( ioffd, mp, nq, imb1, inb1, mb, nb, mrrow,
8234 $ mrcol, lcmt00, mblks, nblks, imbloc, inbloc,
8235 $ lmbloc, lnbloc, ilow, low, iupp, upp )
8236*
8237 m1 = mp
8238 n1 = nq
8239 ioffa = iia - 1
8240 joffa = jja - 1
8241 iimax = ioffa + mp
8242 jjmax = joffa + nq
8243*
8244 IF( desca2( rsrc_ ).LT.0 ) THEN
8245 pmb = mb
8246 ELSE
8247 pmb = nprow * mb
8248 END IF
8249 IF( desca2( csrc_ ).LT.0 ) THEN
8250 qnb = nb
8251 ELSE
8252 qnb = npcol * nb
8253 END IF
8254*
8255* Handle the first block of rows or columns separately, and
8256* update LCMT00, MBLKS and NBLKS.
8257*
8258 godown = ( lcmt00.GT.iupp )
8259 goleft = ( lcmt00.LT.ilow )
8260*
8261 IF( .NOT.godown .AND. .NOT.goleft ) THEN
8262*
8263* LCMT00 >= ILOW && LCMT00 <= IUPP
8264*
8265 goleft = ( ( lcmt00 - ( iupp - upp + pmb ) ).LT.ilow )
8266 godown = .NOT.goleft
8267*
8268 CALL pb_zlascal( uplo, imbloc, inbloc, lcmt00, alpha,
8269 $ a( iia+joffa*lda ), lda )
8270 IF( godown ) THEN
8271 IF( upper .AND. nq.GT.inbloc )
8272 $ CALL pb_zlascal( 'All', imbloc, nq-inbloc, 0, alpha,
8273 $ a( iia+(joffa+inbloc)*lda ), lda )
8274 iia = iia + imbloc
8275 m1 = m1 - imbloc
8276 ELSE
8277 IF( lower .AND. mp.GT.imbloc )
8278 $ CALL pb_zlascal( 'All', mp-imbloc, inbloc, 0, alpha,
8279 $ a( iia+imbloc+joffa*lda ), lda )
8280 jja = jja + inbloc
8281 n1 = n1 - inbloc
8282 END IF
8283*
8284 END IF
8285*
8286 IF( godown ) THEN
8287*
8288 lcmt00 = lcmt00 - ( iupp - upp + pmb )
8289 mblks = mblks - 1
8290 ioffa = ioffa + imbloc
8291*
8292 10 CONTINUE
8293 IF( mblks.GT.0 .AND. lcmt00.GT.upp ) THEN
8294 lcmt00 = lcmt00 - pmb
8295 mblks = mblks - 1
8296 ioffa = ioffa + mb
8297 GO TO 10
8298 END IF
8299*
8300 tmp1 = min( ioffa, iimax ) - iia + 1
8301 IF( upper .AND. tmp1.GT.0 ) THEN
8302 CALL pb_zlascal( 'All', tmp1, n1, 0, alpha,
8303 $ a( iia+joffa*lda ), lda )
8304 iia = iia + tmp1
8305 m1 = m1 - tmp1
8306 END IF
8307*
8308 IF( mblks.LE.0 )
8309 $ RETURN
8310*
8311 lcmt = lcmt00
8312 mblkd = mblks
8313 ioffd = ioffa
8314*
8315 mbloc = mb
8316 20 CONTINUE
8317 IF( mblkd.GT.0 .AND. lcmt.GE.ilow ) THEN
8318 IF( mblkd.EQ.1 )
8319 $ mbloc = lmbloc
8320 CALL pb_zlascal( uplo, mbloc, inbloc, lcmt, alpha,
8321 $ a( ioffd+1+joffa*lda ), lda )
8322 lcmt00 = lcmt
8323 lcmt = lcmt - pmb
8324 mblks = mblkd
8325 mblkd = mblkd - 1
8326 ioffa = ioffd
8327 ioffd = ioffd + mbloc
8328 GO TO 20
8329 END IF
8330*
8331 tmp1 = m1 - ioffd + iia - 1
8332 IF( lower .AND. tmp1.GT.0 )
8333 $ CALL pb_zlascal( 'All', tmp1, inbloc, 0, alpha,
8334 $ a( ioffd+1+joffa*lda ), lda )
8335*
8336 tmp1 = ioffa - iia + 1
8337 m1 = m1 - tmp1
8338 n1 = n1 - inbloc
8339 lcmt00 = lcmt00 + low - ilow + qnb
8340 nblks = nblks - 1
8341 joffa = joffa + inbloc
8342*
8343 IF( upper .AND. tmp1.GT.0 .AND. n1.GT.0 )
8344 $ CALL pb_zlascal( 'All', tmp1, n1, 0, alpha,
8345 $ a( iia+joffa*lda ), lda )
8346*
8347 iia = ioffa + 1
8348 jja = joffa + 1
8349*
8350 ELSE IF( goleft ) THEN
8351*
8352 lcmt00 = lcmt00 + low - ilow + qnb
8353 nblks = nblks - 1
8354 joffa = joffa + inbloc
8355*
8356 30 CONTINUE
8357 IF( nblks.GT.0 .AND. lcmt00.LT.low ) THEN
8358 lcmt00 = lcmt00 + qnb
8359 nblks = nblks - 1
8360 joffa = joffa + nb
8361 GO TO 30
8362 END IF
8363*
8364 tmp1 = min( joffa, jjmax ) - jja + 1
8365 IF( lower .AND. tmp1.GT.0 ) THEN
8366 CALL pb_zlascal( 'All', m1, tmp1, 0, alpha,
8367 $ a( iia+(jja-1)*lda ), lda )
8368 jja = jja + tmp1
8369 n1 = n1 - tmp1
8370 END IF
8371*
8372 IF( nblks.LE.0 )
8373 $ RETURN
8374*
8375 lcmt = lcmt00
8376 nblkd = nblks
8377 joffd = joffa
8378*
8379 nbloc = nb
8380 40 CONTINUE
8381 IF( nblkd.GT.0 .AND. lcmt.LE.iupp ) THEN
8382 IF( nblkd.EQ.1 )
8383 $ nbloc = lnbloc
8384 CALL pb_zlascal( uplo, imbloc, nbloc, lcmt, alpha,
8385 $ a( iia+joffd*lda ), lda )
8386 lcmt00 = lcmt
8387 lcmt = lcmt + qnb
8388 nblks = nblkd
8389 nblkd = nblkd - 1
8390 joffa = joffd
8391 joffd = joffd + nbloc
8392 GO TO 40
8393 END IF
8394*
8395 tmp1 = n1 - joffd + jja - 1
8396 IF( upper .AND. tmp1.GT.0 )
8397 $ CALL pb_zlascal( 'All', imbloc, tmp1, 0, alpha,
8398 $ a( iia+joffd*lda ), lda )
8399*
8400 tmp1 = joffa - jja + 1
8401 m1 = m1 - imbloc
8402 n1 = n1 - tmp1
8403 lcmt00 = lcmt00 - ( iupp - upp + pmb )
8404 mblks = mblks - 1
8405 ioffa = ioffa + imbloc
8406*
8407 IF( lower .AND. m1.GT.0 .AND. tmp1.GT.0 )
8408 $ CALL pb_zlascal( 'All', m1, tmp1, 0, alpha,
8409 $ a( ioffa+1+(jja-1)*lda ), lda )
8410*
8411 iia = ioffa + 1
8412 jja = joffa + 1
8413*
8414 END IF
8415*
8416 nbloc = nb
8417 50 CONTINUE
8418 IF( nblks.GT.0 ) THEN
8419 IF( nblks.EQ.1 )
8420 $ nbloc = lnbloc
8421 60 CONTINUE
8422 IF( mblks.GT.0 .AND. lcmt00.GT.upp ) THEN
8423 lcmt00 = lcmt00 - pmb
8424 mblks = mblks - 1
8425 ioffa = ioffa + mb
8426 GO TO 60
8427 END IF
8428*
8429 tmp1 = min( ioffa, iimax ) - iia + 1
8430 IF( upper .AND. tmp1.GT.0 ) THEN
8431 CALL pb_zlascal( 'All', tmp1, n1, 0, alpha,
8432 $ a( iia+joffa*lda ), lda )
8433 iia = iia + tmp1
8434 m1 = m1 - tmp1
8435 END IF
8436*
8437 IF( mblks.LE.0 )
8438 $ RETURN
8439*
8440 lcmt = lcmt00
8441 mblkd = mblks
8442 ioffd = ioffa
8443*
8444 mbloc = mb
8445 70 CONTINUE
8446 IF( mblkd.GT.0 .AND. lcmt.GE.low ) THEN
8447 IF( mblkd.EQ.1 )
8448 $ mbloc = lmbloc
8449 CALL pb_zlascal( uplo, mbloc, nbloc, lcmt, alpha,
8450 $ a( ioffd+1+joffa*lda ), lda )
8451 lcmt00 = lcmt
8452 lcmt = lcmt - pmb
8453 mblks = mblkd
8454 mblkd = mblkd - 1
8455 ioffa = ioffd
8456 ioffd = ioffd + mbloc
8457 GO TO 70
8458 END IF
8459*
8460 tmp1 = m1 - ioffd + iia - 1
8461 IF( lower .AND. tmp1.GT.0 )
8462 $ CALL pb_zlascal( 'all', TMP1, NBLOC, 0, ALPHA,
8463 $ A( IOFFD+1+JOFFA*LDA ), LDA )
8464*
8465 TMP1 = MIN( IOFFA, IIMAX ) - IIA + 1
8466 M1 = M1 - TMP1
8467 N1 = N1 - NBLOC
8468 LCMT00 = LCMT00 + QNB
8469 NBLKS = NBLKS - 1
8470 JOFFA = JOFFA + NBLOC
8471*
8472.AND..GT..AND..GT. IF( UPPER TMP10 N10 )
8473 $ CALL PB_ZLASCAL( 'all', TMP1, N1, 0, ALPHA,
8474 $ A( IIA+JOFFA*LDA ), LDA )
8475*
8476 IIA = IOFFA + 1
8477 JJA = JOFFA + 1
8478*
8479 GO TO 50
8480*
8481 END IF
8482*
8483 END IF
8484*
8485 RETURN
8486*
8487* End of PZLASCAL
8488*
pb_zlascal
subroutine pb_zlascal(uplo, m, n, ioffd, alpha, a, lda)
Definition pzblastst.f:10246

◆ pzlaset()

subroutine pzlaset ( character*1 uplo,
integer m,
integer n,
complex*16 alpha,
complex*16 beta,
complex*16, dimension( * ) a,
integer ia,
integer ja,
integer, dimension( * ) desca )

Definition at line 7508 of file pzblastst.f.

7509*
7510* -- PBLAS test routine (version 2.0) --
7511* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
7512* and University of California, Berkeley.
7513* April 1, 1998
7514*
7515* .. Scalar Arguments ..
7516 CHARACTER*1 UPLO
7517 INTEGER IA, JA, M, N
7518 COMPLEX*16 ALPHA, BETA
7519* ..
7520* .. Array Arguments ..
7521 INTEGER DESCA( * )
7522 COMPLEX*16 A( * )
7523* ..
7524*
7525* Purpose
7526* =======
7527*
7528* PZLASET initializes an m by n submatrix A(IA:IA+M-1,JA:JA+N-1) deno-
7529* ted by sub( A ) to beta on the diagonal and alpha on the offdiago-
7530* nals.
7531*
7532* Notes
7533* =====
7534*
7535* A description vector is associated with each 2D block-cyclicly dis-
7536* tributed matrix. This vector stores the information required to
7537* establish the mapping between a matrix entry and its corresponding
7538* process and memory location.
7539*
7540* In the following comments, the character _ should be read as
7541* "of the distributed matrix". Let A be a generic term for any 2D
7542* block cyclicly distributed matrix. Its description vector is DESCA:
7543*
7544* NOTATION STORED IN EXPLANATION
7545* ---------------- --------------- ------------------------------------
7546* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
7547* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
7548* the NPROW x NPCOL BLACS process grid
7549* A is distributed over. The context
7550* itself is global, but the handle
7551* (the integer value) may vary.
7552* M_A (global) DESCA( M_ ) The number of rows in the distribu-
7553* ted matrix A, M_A >= 0.
7554* N_A (global) DESCA( N_ ) The number of columns in the distri-
7555* buted matrix A, N_A >= 0.
7556* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
7557* block of the matrix A, IMB_A > 0.
7558* INB_A (global) DESCA( INB_ ) The number of columns of the upper
7559* left block of the matrix A,
7560* INB_A > 0.
7561* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
7562* bute the last M_A-IMB_A rows of A,
7563* MB_A > 0.
7564* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
7565* bute the last N_A-INB_A columns of
7566* A, NB_A > 0.
7567* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
7568* row of the matrix A is distributed,
7569* NPROW > RSRC_A >= 0.
7570* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
7571* first column of A is distributed.
7572* NPCOL > CSRC_A >= 0.
7573* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
7574* array storing the local blocks of
7575* the distributed matrix A,
7576* IF( Lc( 1, N_A ) > 0 )
7577* LLD_A >= MAX( 1, Lr( 1, M_A ) )
7578* ELSE
7579* LLD_A >= 1.
7580*
7581* Let K be the number of rows of a matrix A starting at the global in-
7582* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
7583* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
7584* receive if these K rows were distributed over NPROW processes. If K
7585* is the number of columns of a matrix A starting at the global index
7586* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
7587* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
7588* these K columns were distributed over NPCOL processes.
7589*
7590* The values of Lr() and Lc() may be determined via a call to the func-
7591* tion PB_NUMROC:
7592* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
7593* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
7594*
7595* Arguments
7596* =========
7597*
7598* UPLO (global input) CHARACTER*1
7599* On entry, UPLO specifies the part of the submatrix sub( A )
7600* to be set:
7601* = 'L' or 'l': Lower triangular part is set; the strictly
7602* upper triangular part of sub( A ) is not changed;
7603* = 'U' or 'u': Upper triangular part is set; the strictly
7604* lower triangular part of sub( A ) is not changed;
7605* Otherwise: All of the matrix sub( A ) is set.
7606*
7607* M (global input) INTEGER
7608* On entry, M specifies the number of rows of the submatrix
7609* sub( A ). M must be at least zero.
7610*
7611* N (global input) INTEGER
7612* On entry, N specifies the number of columns of the submatrix
7613* sub( A ). N must be at least zero.
7614*
7615* ALPHA (global input) COMPLEX*16
7616* On entry, ALPHA specifies the scalar alpha, i.e., the cons-
7617* tant to which the offdiagonal elements are to be set.
7618*
7619* BETA (global input) COMPLEX*16
7620* On entry, BETA specifies the scalar beta, i.e., the constant
7621* to which the diagonal elements are to be set.
7622*
7623* A (local input/local output) COMPLEX*16 array
7624* On entry, A is an array of dimension (LLD_A, Ka), where Ka is
7625* at least Lc( 1, JA+N-1 ). Before entry, this array contains
7626* the local entries of the matrix A to be set. On exit, the
7627* leading m by n submatrix sub( A ) is set as follows:
7628*
7629* if UPLO = 'U', A(IA+i-1,JA+j-1) = ALPHA, 1<=i<=j-1, 1<=j<=N,
7630* if UPLO = 'L', A(IA+i-1,JA+j-1) = ALPHA, j+1<=i<=M, 1<=j<=N,
7631* otherwise, A(IA+i-1,JA+j-1) = ALPHA, 1<=i<=M, 1<=j<=N,
7632* and IA+i.NE.JA+j,
7633* and, for all UPLO, A(IA+i-1,JA+i-1) = BETA, 1<=i<=min(M,N).
7634*
7635* IA (global input) INTEGER
7636* On entry, IA specifies A's global row index, which points to
7637* the beginning of the submatrix sub( A ).
7638*
7639* JA (global input) INTEGER
7640* On entry, JA specifies A's global column index, which points
7641* to the beginning of the submatrix sub( A ).
7642*
7643* DESCA (global and local input) INTEGER array
7644* On entry, DESCA is an integer array of dimension DLEN_. This
7645* is the array descriptor for the matrix A.
7646*
7647* -- Written on April 1, 1998 by
7648* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
7649*
7650* =====================================================================
7651*
7652* .. Parameters ..
7653 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
7654 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
7655 $ RSRC_
7656 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
7657 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
7658 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
7659 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
7660* ..
7661* .. Local Scalars ..
7662 LOGICAL GODOWN, GOLEFT, ISCOLREP, ISROWREP, LOWER,
7663 $ UPPER
7664 INTEGER IACOL, IAROW, ICTXT, IIA, IIMAX, ILOW, IMB1,
7665 $ IMBLOC, INB1, INBLOC, IOFFA, IOFFD, IUPP, JJA,
7666 $ JJMAX, JOFFA, JOFFD, LCMT, LCMT00, LDA, LMBLOC,
7667 $ LNBLOC, LOW, M1, MB, MBLKD, MBLKS, MBLOC, MP,
7668 $ MRCOL, MRROW, MYCOL, MYROW, N1, NB, NBLKD,
7669 $ NBLKS, NBLOC, NPCOL, NPROW, NQ, PMB, QNB, TMP1,
7670 $ UPP
7671* ..
7672* .. Local Arrays ..
7673 INTEGER DESCA2( DLEN_ )
7674* ..
7675* .. External Subroutines ..
7676 EXTERNAL blacs_gridinfo, pb_ainfog2l, pb_binfo,
7677 $ pb_desctrans, pb_zlaset
7678* ..
7679* .. External Functions ..
7680 LOGICAL LSAME
7681 EXTERNAL lsame
7682* ..
7683* .. Intrinsic Functions ..
7684 INTRINSIC min
7685* ..
7686* .. Executable Statements ..
7687*
7688 IF( m.EQ.0 .OR. n.EQ.0 )
7689 $ RETURN
7690*
7691* Convert descriptor
7692*
7693 CALL pb_desctrans( desca, desca2 )
7694*
7695* Get grid parameters
7696*
7697 ictxt = desca2( ctxt_ )
7698 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
7699*
7700 CALL pb_ainfog2l( m, n, ia, ja, desca2, nprow, npcol, myrow,
7701 $ mycol, imb1, inb1, mp, nq, iia, jja, iarow,
7702 $ iacol, mrrow, mrcol )
7703*
7704 IF( mp.LE.0 .OR. nq.LE.0 )
7705 $ RETURN
7706*
7707 isrowrep = ( desca2( rsrc_ ).LT.0 )
7708 iscolrep = ( desca2( csrc_ ).LT.0 )
7709 lda = desca2( lld_ )
7710*
7711 upper = .NOT.( lsame( uplo, 'L' ) )
7712 lower = .NOT.( lsame( uplo, 'U' ) )
7713*
7714 IF( ( ( lower.AND.upper ).AND.( alpha.EQ.beta ) ).OR.
7715 $ ( isrowrep .AND. iscolrep ) ) THEN
7716 IF( ( mp.GT.0 ).AND.( nq.GT.0 ) )
7717 $ CALL pb_zlaset( uplo, mp, nq, 0, alpha, beta,
7718 $ a( iia + ( jja - 1 ) * lda ), lda )
7719 RETURN
7720 END IF
7721*
7722* Initialize LCMT00, MBLKS, NBLKS, IMBLOC, INBLOC, LMBLOC, LNBLOC,
7723* ILOW, LOW, IUPP, and UPP.
7724*
7725 mb = desca2( mb_ )
7726 nb = desca2( nb_ )
7727 CALL pb_binfo( 0, mp, nq, imb1, inb1, mb, nb, mrrow, mrcol,
7728 $ lcmt00, mblks, nblks, imbloc, inbloc, lmbloc,
7729 $ lnbloc, ilow, low, iupp, upp )
7730*
7731 ioffa = iia - 1
7732 joffa = jja - 1
7733 iimax = ioffa + mp
7734 jjmax = joffa + nq
7735*
7736 IF( isrowrep ) THEN
7737 pmb = mb
7738 ELSE
7739 pmb = nprow * mb
7740 END IF
7741 IF( iscolrep ) THEN
7742 qnb = nb
7743 ELSE
7744 qnb = npcol * nb
7745 END IF
7746*
7747 m1 = mp
7748 n1 = nq
7749*
7750* Handle the first block of rows or columns separately, and update
7751* LCMT00, MBLKS and NBLKS.
7752*
7753 godown = ( lcmt00.GT.iupp )
7754 goleft = ( lcmt00.LT.ilow )
7755*
7756 IF( .NOT.godown .AND. .NOT.goleft ) THEN
7757*
7758* LCMT00 >= ILOW && LCMT00 <= IUPP
7759*
7760 goleft = ( ( lcmt00 - ( iupp - upp + pmb ) ).LT.ilow )
7761 godown = .NOT.goleft
7762*
7763 CALL pb_zlaset( uplo, imbloc, inbloc, lcmt00, alpha, beta,
7764 $ a( iia+joffa*lda ), lda )
7765 IF( godown ) THEN
7766 IF( upper .AND. nq.GT.inbloc )
7767 $ CALL pb_zlaset( 'All', imbloc, nq-inbloc, 0, alpha,
7768 $ alpha, a( iia+(joffa+inbloc)*lda ), lda )
7769 iia = iia + imbloc
7770 m1 = m1 - imbloc
7771 ELSE
7772 IF( lower .AND. mp.GT.imbloc )
7773 $ CALL pb_zlaset( 'All', mp-imbloc, inbloc, 0, alpha,
7774 $ alpha, a( iia+imbloc+joffa*lda ), lda )
7775 jja = jja + inbloc
7776 n1 = n1 - inbloc
7777 END IF
7778*
7779 END IF
7780*
7781 IF( godown ) THEN
7782*
7783 lcmt00 = lcmt00 - ( iupp - upp + pmb )
7784 mblks = mblks - 1
7785 ioffa = ioffa + imbloc
7786*
7787 10 CONTINUE
7788 IF( mblks.GT.0 .AND. lcmt00.GT.upp ) THEN
7789 lcmt00 = lcmt00 - pmb
7790 mblks = mblks - 1
7791 ioffa = ioffa + mb
7792 GO TO 10
7793 END IF
7794*
7795 tmp1 = min( ioffa, iimax ) - iia + 1
7796 IF( upper .AND. tmp1.GT.0 ) THEN
7797 CALL pb_zlaset( 'All', tmp1, n1, 0, alpha, alpha,
7798 $ a( iia+joffa*lda ), lda )
7799 iia = iia + tmp1
7800 m1 = m1 - tmp1
7801 END IF
7802*
7803 IF( mblks.LE.0 )
7804 $ RETURN
7805*
7806 lcmt = lcmt00
7807 mblkd = mblks
7808 ioffd = ioffa
7809*
7810 mbloc = mb
7811 20 CONTINUE
7812 IF( mblkd.GT.0 .AND. lcmt.GE.ilow ) THEN
7813 IF( mblkd.EQ.1 )
7814 $ mbloc = lmbloc
7815 CALL pb_zlaset( uplo, mbloc, inbloc, lcmt, alpha, beta,
7816 $ a( ioffd+1+joffa*lda ), lda )
7817 lcmt00 = lcmt
7818 lcmt = lcmt - pmb
7819 mblks = mblkd
7820 mblkd = mblkd - 1
7821 ioffa = ioffd
7822 ioffd = ioffd + mbloc
7823 GO TO 20
7824 END IF
7825*
7826 tmp1 = m1 - ioffd + iia - 1
7827 IF( lower .AND. tmp1.GT.0 )
7828 $ CALL pb_zlaset( 'ALL', tmp1, inbloc, 0, alpha, alpha,
7829 $ a( ioffd+1+joffa*lda ), lda )
7830*
7831 tmp1 = ioffa - iia + 1
7832 m1 = m1 - tmp1
7833 n1 = n1 - inbloc
7834 lcmt00 = lcmt00 + low - ilow + qnb
7835 nblks = nblks - 1
7836 joffa = joffa + inbloc
7837*
7838 IF( upper .AND. tmp1.GT.0 .AND. n1.GT.0 )
7839 $ CALL pb_zlaset( 'ALL', tmp1, n1, 0, alpha, alpha,
7840 $ a( iia+joffa*lda ), lda )
7841*
7842 iia = ioffa + 1
7843 jja = joffa + 1
7844*
7845 ELSE IF( goleft ) THEN
7846*
7847 lcmt00 = lcmt00 + low - ilow + qnb
7848 nblks = nblks - 1
7849 joffa = joffa + inbloc
7850*
7851 30 CONTINUE
7852 IF( nblks.GT.0 .AND. lcmt00.LT.low ) THEN
7853 lcmt00 = lcmt00 + qnb
7854 nblks = nblks - 1
7855 joffa = joffa + nb
7856 GO TO 30
7857 END IF
7858*
7859 tmp1 = min( joffa, jjmax ) - jja + 1
7860 IF( lower .AND. tmp1.GT.0 ) THEN
7861 CALL pb_zlaset( 'All', m1, tmp1, 0, alpha, alpha,
7862 $ a( iia+(jja-1)*lda ), lda )
7863 jja = jja + tmp1
7864 n1 = n1 - tmp1
7865 END IF
7866*
7867 IF( nblks.LE.0 )
7868 $ RETURN
7869*
7870 lcmt = lcmt00
7871 nblkd = nblks
7872 joffd = joffa
7873*
7874 nbloc = nb
7875 40 CONTINUE
7876 IF( nblkd.GT.0 .AND. lcmt.LE.iupp ) THEN
7877 IF( nblkd.EQ.1 )
7878 $ nbloc = lnbloc
7879 CALL pb_zlaset( uplo, imbloc, nbloc, lcmt, alpha, beta,
7880 $ a( iia+joffd*lda ), lda )
7881 lcmt00 = lcmt
7882 lcmt = lcmt + qnb
7883 nblks = nblkd
7884 nblkd = nblkd - 1
7885 joffa = joffd
7886 joffd = joffd + nbloc
7887 GO TO 40
7888 END IF
7889*
7890 tmp1 = n1 - joffd + jja - 1
7891 IF( upper .AND. tmp1.GT.0 )
7892 $ CALL pb_zlaset( 'All', imbloc, tmp1, 0, alpha, alpha,
7893 $ a( iia+joffd*lda ), lda )
7894*
7895 tmp1 = joffa - jja + 1
7896 m1 = m1 - imbloc
7897 n1 = n1 - tmp1
7898 lcmt00 = lcmt00 - ( iupp - upp + pmb )
7899 mblks = mblks - 1
7900 ioffa = ioffa + imbloc
7901*
7902 IF( lower .AND. m1.GT.0 .AND. tmp1.GT.0 )
7903 $ CALL pb_zlaset( 'All', m1, tmp1, 0, alpha, alpha,
7904 $ a( ioffa+1+(jja-1)*lda ), lda )
7905*
7906 iia = ioffa + 1
7907 jja = joffa + 1
7908*
7909 END IF
7910*
7911 nbloc = nb
7912 50 CONTINUE
7913 IF( nblks.GT.0 ) THEN
7914 IF( nblks.EQ.1 )
7915 $ nbloc = lnbloc
7916 60 CONTINUE
7917 IF( mblks.GT.0 .AND. lcmt00.GT.upp ) THEN
7918 lcmt00 = lcmt00 - pmb
7919 mblks = mblks - 1
7920 ioffa = ioffa + mb
7921 GO TO 60
7922 END IF
7923*
7924 tmp1 = min( ioffa, iimax ) - iia + 1
7925 IF( upper .AND. tmp1.GT.0 ) THEN
7926 CALL pb_zlaset( 'All', tmp1, n1, 0, alpha, alpha,
7927 $ a( iia+joffa*lda ), lda )
7928 iia = iia + tmp1
7929 m1 = m1 - tmp1
7930 END IF
7931*
7932 IF( mblks.LE.0 )
7933 $ RETURN
7934*
7935 lcmt = lcmt00
7936 mblkd = mblks
7937 ioffd = ioffa
7938*
7939 mbloc = mb
7940 70 CONTINUE
7941 IF( mblkd.GT.0 .AND. lcmt.GE.low ) THEN
7942 IF( mblkd.EQ.1 )
7943 $ mbloc = lmbloc
7944 CALL pb_zlaset( uplo, mbloc, nbloc, lcmt, alpha, beta,
7945 $ a( ioffd+1+joffa*lda ), lda )
7946 lcmt00 = lcmt
7947 lcmt = lcmt - pmb
7948 mblks = mblkd
7949 mblkd = mblkd - 1
7950 ioffa = ioffd
7951 ioffd = ioffd + mbloc
7952 GO TO 70
7953 END IF
7954*
7955 tmp1 = m1 - ioffd + iia - 1
7956 IF( lower .AND. tmp1.GT.0 )
7957 $ CALL pb_zlaset( 'All', tmp1, nbloc, 0, alpha, alpha,
7958 $ a( ioffd+1+joffa*lda ), lda )
7959*
7960 tmp1 = min( ioffa, iimax ) - iia + 1
7961 m1 = m1 - tmp1
7962 n1 = n1 - nbloc
7963 lcmt00 = lcmt00 + qnb
7964 nblks = nblks - 1
7965 joffa = joffa + nbloc
7966*
7967 IF( upper .AND. tmp1.GT.0 .AND. n1.GT.0 )
7968 $ CALL pb_zlaset( 'All', tmp1, n1, 0, alpha, alpha,
7969 $ a( iia+joffa*lda ), lda )
7970*
7971 iia = ioffa + 1
7972 jja = joffa + 1
7973*
7974 GO TO 50
7975*
7976 END IF
7977*
7978 RETURN
7979*
7980* End of PZLASET
7981*
pb_zlaset
subroutine pb_zlaset(uplo, m, n, ioffd, alpha, beta, a, lda)
Definition pzblastst.f:10049

◆ pzmatee()

subroutine pzmatee ( integer ictxt,
integer nout,
external subptr,
integer scode,
character*7 sname )

Definition at line 1189 of file pzblastst.f.

1190*
1191* -- PBLAS test routine (version 2.0) --
1192* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1193* and University of California, Berkeley.
1194* April 1, 1998
1195*
1196* .. Scalar Arguments ..
1197 INTEGER ICTXT, NOUT, SCODE
1198* ..
1199* .. Array Arguments ..
1200 CHARACTER*7 SNAME
1201* ..
1202* .. Subroutine Arguments ..
1203 EXTERNAL subptr
1204* ..
1205*
1206* Purpose
1207* =======
1208*
1209* PZMATEE tests whether the PBLAS respond correctly to a bad matrix
1210* argument. Each matrix <mat> is described by: <mat>, I<mat>, J<mat>,
1211* and DESC<mat>. Out of all these, only I<vec>, J<vec> and DESC<mat>
1212* can be tested.
1213*
1214* Notes
1215* =====
1216*
1217* A description vector is associated with each 2D block-cyclicly dis-
1218* tributed matrix. This vector stores the information required to
1219* establish the mapping between a matrix entry and its corresponding
1220* process and memory location.
1221*
1222* In the following comments, the character _ should be read as
1223* "of the distributed matrix". Let A be a generic term for any 2D
1224* block cyclicly distributed matrix. Its description vector is DESCA:
1225*
1226* NOTATION STORED IN EXPLANATION
1227* ---------------- --------------- ------------------------------------
1228* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
1229* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
1230* the NPROW x NPCOL BLACS process grid
1231* A is distributed over. The context
1232* itself is global, but the handle
1233* (the integer value) may vary.
1234* M_A (global) DESCA( M_ ) The number of rows in the distribu-
1235* ted matrix A, M_A >= 0.
1236* N_A (global) DESCA( N_ ) The number of columns in the distri-
1237* buted matrix A, N_A >= 0.
1238* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
1239* block of the matrix A, IMB_A > 0.
1240* INB_A (global) DESCA( INB_ ) The number of columns of the upper
1241* left block of the matrix A,
1242* INB_A > 0.
1243* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
1244* bute the last M_A-IMB_A rows of A,
1245* MB_A > 0.
1246* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
1247* bute the last N_A-INB_A columns of
1248* A, NB_A > 0.
1249* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
1250* row of the matrix A is distributed,
1251* NPROW > RSRC_A >= 0.
1252* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
1253* first column of A is distributed.
1254* NPCOL > CSRC_A >= 0.
1255* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
1256* array storing the local blocks of
1257* the distributed matrix A,
1258* IF( Lc( 1, N_A ) > 0 )
1259* LLD_A >= MAX( 1, Lr( 1, M_A ) )
1260* ELSE
1261* LLD_A >= 1.
1262*
1263* Let K be the number of rows of a matrix A starting at the global in-
1264* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
1265* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
1266* receive if these K rows were distributed over NPROW processes. If K
1267* is the number of columns of a matrix A starting at the global index
1268* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
1269* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
1270* these K columns were distributed over NPCOL processes.
1271*
1272* The values of Lr() and Lc() may be determined via a call to the func-
1273* tion PB_NUMROC:
1274* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
1275* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
1276*
1277* Arguments
1278* =========
1279*
1280* ICTXT (local input) INTEGER
1281* On entry, ICTXT specifies the BLACS context handle, indica-
1282* ting the global context of the operation. The context itself
1283* is global, but the value of ICTXT is local.
1284*
1285* NOUT (global input) INTEGER
1286* On entry, NOUT specifies the unit number for the output file.
1287* When NOUT is 6, output to screen, when NOUT is 0, output to
1288* stderr. NOUT is only defined for process 0.
1289*
1290* SUBPTR (global input) SUBROUTINE
1291* On entry, SUBPTR is a subroutine. SUBPTR must be declared
1292* EXTERNAL in the calling subroutine.
1293*
1294* SCODE (global input) INTEGER
1295* On entry, SCODE specifies the calling sequence code.
1296*
1297* SNAME (global input) CHARACTER*(*)
1298* On entry, SNAME specifies the subroutine name calling this
1299* subprogram.
1300*
1301* Calling sequence encodings
1302* ==========================
1303*
1304* code Formal argument list Examples
1305*
1306* 11 (n, v1,v2) _SWAP, _COPY
1307* 12 (n,s1, v1 ) _SCAL, _SCAL
1308* 13 (n,s1, v1,v2) _AXPY, _DOT_
1309* 14 (n,s1,i1,v1 ) _AMAX
1310* 15 (n,u1, v1 ) _ASUM, _NRM2
1311*
1312* 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV
1313* 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV
1314* 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV
1315* 24 ( m,n,s1,v1,v2,m1) _GER_
1316* 25 (uplo, n,s1,v1, m1) _SYR
1317* 26 (uplo, n,u1,v1, m1) _HER
1318* 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2
1319*
1320* 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM
1321* 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM
1322* 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK
1323* 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK
1324* 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K
1325* 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K
1326* 37 ( m,n, s1,m1, s2,m3) _TRAN_
1327* 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM
1328* 39 ( trans, m,n, s1,m1, s2,m3) _GEADD
1329* 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD
1330*
1331* -- Written on April 1, 1998 by
1332* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1333*
1334* =====================================================================
1335*
1336* .. Local Scalars ..
1337 INTEGER APOS
1338* ..
1339* .. External Subroutines ..
1340 EXTERNAL pzchkmat
1341* ..
1342* .. Executable Statements ..
1343*
1344* Level 2 PBLAS
1345*
1346 IF( scode.EQ.21 .OR. scode.EQ.23 ) THEN
1347*
1348* Check 1st (and only) matrix
1349*
1350 apos = 5
1351 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
1352*
1353 ELSE IF( scode.EQ.22 ) THEN
1354*
1355* Check 1st (and only) matrix
1356*
1357 apos = 4
1358 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
1359*
1360 ELSE IF( scode.EQ.24 .OR. scode.EQ.27 ) THEN
1361*
1362* Check 1st (and only) matrix
1363*
1364 apos = 14
1365 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
1366*
1367 ELSE IF( scode.EQ.25 .OR. scode.EQ.26 ) THEN
1368*
1369* Check 1st (and only) matrix
1370*
1371 apos = 9
1372 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
1373*
1374* Level 3 PBLAS
1375*
1376 ELSE IF( scode.EQ.31 ) THEN
1377*
1378* Check 1st matrix
1379*
1380 apos = 7
1381 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
1382*
1383* Check 2nd matrix
1384*
1385 apos = 11
1386 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'B', apos )
1387*
1388* Check 3nd matrix
1389*
1390 apos = 16
1391 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'C', apos )
1392*
1393 ELSE IF( scode.EQ.32 .OR. scode.EQ.35 .OR. scode.EQ.36 ) THEN
1394*
1395* Check 1st matrix
1396*
1397 apos = 6
1398 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
1399*
1400* Check 2nd matrix
1401*
1402 apos = 10
1403 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'B', apos )
1404*
1405* Check 3nd matrix
1406*
1407 apos = 15
1408 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'C', apos )
1409*
1410 ELSE IF( scode.EQ.33 .OR. scode.EQ.34 ) THEN
1411*
1412* Check 1st matrix
1413*
1414 apos = 6
1415 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
1416*
1417* Check 2nd matrix
1418*
1419 apos = 11
1420 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'C', apos )
1421*
1422 ELSE IF( scode.EQ.37 ) THEN
1423*
1424* Check 1st matrix
1425*
1426 apos = 4
1427 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
1428*
1429* Check 2nd matrix
1430*
1431 apos = 9
1432 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'C', apos )
1433*
1434 ELSE IF( scode.EQ.38 ) THEN
1435*
1436* Check 1st matrix
1437*
1438 apos = 8
1439 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
1440*
1441* Check 2nd matrix
1442*
1443 apos = 12
1444 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'B', apos )
1445*
1446 ELSE IF( scode.EQ.39 ) THEN
1447*
1448* Check 1st matrix
1449*
1450 apos = 5
1451 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
1452*
1453* Check 2nd matrix
1454*
1455 apos = 10
1456 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'C', apos )
1457*
1458 ELSE IF( scode.EQ.40 ) THEN
1459*
1460* Check 1st matrix
1461*
1462 apos = 6
1463 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'A', apos )
1464*
1465* Check 2nd matrix
1466*
1467 apos = 11
1468 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'C', apos )
1469*
1470 END IF
1471*
1472 RETURN
1473*
1474* End of PZMATEE
1475*
pzchkmat
subroutine pzchkmat(ictxt, nout, subptr, scode, sname, argnam, argpos)
Definition pzblastst.f:1677

◆ pzmmch()

subroutine pzmmch ( integer ictxt,
character*1 transa,
character*1 transb,
integer m,
integer n,
integer k,
complex*16 alpha,
complex*16, dimension( * ) a,
integer ia,
integer ja,
integer, dimension( * ) desca,
complex*16, dimension( * ) b,
integer ib,
integer jb,
integer, dimension( * ) descb,
complex*16 beta,
complex*16, dimension( * ) c,
complex*16, dimension( * ) pc,
integer ic,
integer jc,
integer, dimension( * ) descc,
complex*16, dimension( * ) ct,
double precision, dimension( * ) g,
double precision err,
integer info )

Definition at line 5333 of file pzblastst.f.

5336*
5337* -- PBLAS test routine (version 2.0) --
5338* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
5339* and University of California, Berkeley.
5340* April 1, 1998
5341*
5342* .. Scalar Arguments ..
5343 CHARACTER*1 TRANSA, TRANSB
5344 INTEGER IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, M, N
5345 DOUBLE PRECISION ERR
5346 COMPLEX*16 ALPHA, BETA
5347* ..
5348* .. Array Arguments ..
5349 INTEGER DESCA( * ), DESCB( * ), DESCC( * )
5350 DOUBLE PRECISION G( * )
5351 COMPLEX*16 A( * ), B( * ), C( * ), CT( * ), PC( * )
5352* ..
5353*
5354* Purpose
5355* =======
5356*
5357* PZMMCH checks the results of the computational tests.
5358*
5359* Notes
5360* =====
5361*
5362* A description vector is associated with each 2D block-cyclicly dis-
5363* tributed matrix. This vector stores the information required to
5364* establish the mapping between a matrix entry and its corresponding
5365* process and memory location.
5366*
5367* In the following comments, the character _ should be read as
5368* "of the distributed matrix". Let A be a generic term for any 2D
5369* block cyclicly distributed matrix. Its description vector is DESCA:
5370*
5371* NOTATION STORED IN EXPLANATION
5372* ---------------- --------------- ------------------------------------
5373* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
5374* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
5375* the NPROW x NPCOL BLACS process grid
5376* A is distributed over. The context
5377* itself is global, but the handle
5378* (the integer value) may vary.
5379* M_A (global) DESCA( M_ ) The number of rows in the distribu-
5380* ted matrix A, M_A >= 0.
5381* N_A (global) DESCA( N_ ) The number of columns in the distri-
5382* buted matrix A, N_A >= 0.
5383* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
5384* block of the matrix A, IMB_A > 0.
5385* INB_A (global) DESCA( INB_ ) The number of columns of the upper
5386* left block of the matrix A,
5387* INB_A > 0.
5388* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
5389* bute the last M_A-IMB_A rows of A,
5390* MB_A > 0.
5391* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
5392* bute the last N_A-INB_A columns of
5393* A, NB_A > 0.
5394* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
5395* row of the matrix A is distributed,
5396* NPROW > RSRC_A >= 0.
5397* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
5398* first column of A is distributed.
5399* NPCOL > CSRC_A >= 0.
5400* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
5401* array storing the local blocks of
5402* the distributed matrix A,
5403* IF( Lc( 1, N_A ) > 0 )
5404* LLD_A >= MAX( 1, Lr( 1, M_A ) )
5405* ELSE
5406* LLD_A >= 1.
5407*
5408* Let K be the number of rows of a matrix A starting at the global in-
5409* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
5410* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
5411* receive if these K rows were distributed over NPROW processes. If K
5412* is the number of columns of a matrix A starting at the global index
5413* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
5414* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
5415* these K columns were distributed over NPCOL processes.
5416*
5417* The values of Lr() and Lc() may be determined via a call to the func-
5418* tion PB_NUMROC:
5419* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
5420* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
5421*
5422* Arguments
5423* =========
5424*
5425* ICTXT (local input) INTEGER
5426* On entry, ICTXT specifies the BLACS context handle, indica-
5427* ting the global context of the operation. The context itself
5428* is global, but the value of ICTXT is local.
5429*
5430* TRANSA (global input) CHARACTER*1
5431* On entry, TRANSA specifies if the matrix operand A is to be
5432* transposed.
5433*
5434* TRANSB (global input) CHARACTER*1
5435* On entry, TRANSB specifies if the matrix operand B is to be
5436* transposed.
5437*
5438* M (global input) INTEGER
5439* On entry, M specifies the number of rows of C.
5440*
5441* N (global input) INTEGER
5442* On entry, N specifies the number of columns of C.
5443*
5444* K (global input) INTEGER
5445* On entry, K specifies the number of columns (resp. rows) of A
5446* when TRANSA = 'N' (resp. TRANSA <> 'N') in PxGEMM, PxSYRK,
5447* PxSYR2K, PxHERK and PxHER2K.
5448*
5449* ALPHA (global input) COMPLEX*16
5450* On entry, ALPHA specifies the scalar alpha.
5451*
5452* A (local input) COMPLEX*16 array
5453* On entry, A is an array of dimension (DESCA( M_ ),*). This
5454* array contains a local copy of the initial entire matrix PA.
5455*
5456* IA (global input) INTEGER
5457* On entry, IA specifies A's global row index, which points to
5458* the beginning of the submatrix sub( A ).
5459*
5460* JA (global input) INTEGER
5461* On entry, JA specifies A's global column index, which points
5462* to the beginning of the submatrix sub( A ).
5463*
5464* DESCA (global and local input) INTEGER array
5465* On entry, DESCA is an integer array of dimension DLEN_. This
5466* is the array descriptor for the matrix A.
5467*
5468* B (local input) COMPLEX*16 array
5469* On entry, B is an array of dimension (DESCB( M_ ),*). This
5470* array contains a local copy of the initial entire matrix PB.
5471*
5472* IB (global input) INTEGER
5473* On entry, IB specifies B's global row index, which points to
5474* the beginning of the submatrix sub( B ).
5475*
5476* JB (global input) INTEGER
5477* On entry, JB specifies B's global column index, which points
5478* to the beginning of the submatrix sub( B ).
5479*
5480* DESCB (global and local input) INTEGER array
5481* On entry, DESCB is an integer array of dimension DLEN_. This
5482* is the array descriptor for the matrix B.
5483*
5484* BETA (global input) COMPLEX*16
5485* On entry, BETA specifies the scalar beta.
5486*
5487* C (local input/local output) COMPLEX*16 array
5488* On entry, C is an array of dimension (DESCC( M_ ),*). This
5489* array contains a local copy of the initial entire matrix PC.
5490*
5491* PC (local input) COMPLEX*16 array
5492* On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
5493* array contains the local pieces of the matrix PC.
5494*
5495* IC (global input) INTEGER
5496* On entry, IC specifies C's global row index, which points to
5497* the beginning of the submatrix sub( C ).
5498*
5499* JC (global input) INTEGER
5500* On entry, JC specifies C's global column index, which points
5501* to the beginning of the submatrix sub( C ).
5502*
5503* DESCC (global and local input) INTEGER array
5504* On entry, DESCC is an integer array of dimension DLEN_. This
5505* is the array descriptor for the matrix C.
5506*
5507* CT (workspace) COMPLEX*16 array
5508* On entry, CT is an array of dimension at least MAX(M,N,K). CT
5509* holds a copy of the current column of C.
5510*
5511* G (workspace) DOUBLE PRECISION array
5512* On entry, G is an array of dimension at least MAX(M,N,K). G
5513* is used to compute the gauges.
5514*
5515* ERR (global output) DOUBLE PRECISION
5516* On exit, ERR specifies the largest error in absolute value.
5517*
5518* INFO (global output) INTEGER
5519* On exit, if INFO <> 0, the result is less than half accurate.
5520*
5521* -- Written on April 1, 1998 by
5522* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
5523*
5524* =====================================================================
5525*
5526* .. Parameters ..
5527 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
5528 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
5529 $ RSRC_
5530 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
5531 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
5532 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
5533 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
5534 DOUBLE PRECISION RZERO, RONE
5535 parameter( rzero = 0.0d+0, rone = 1.0d+0 )
5536 COMPLEX*16 ZERO
5537 parameter( zero = ( 0.0d+0, 0.0d+0 ) )
5538* ..
5539* .. Local Scalars ..
5540 LOGICAL COLREP, CTRANA, CTRANB, ROWREP, TRANA, TRANB
5541 INTEGER I, IBB, ICCOL, ICROW, ICURROW, IIC, IN, IOFFA,
5542 $ IOFFB, IOFFC, J, JJC, KK, LDA, LDB, LDC, LDPC,
5543 $ MYCOL, MYROW, NPCOL, NPROW
5544 DOUBLE PRECISION EPS, ERRI
5545 COMPLEX*16 Z
5546* ..
5547* .. External Subroutines ..
5548 EXTERNAL blacs_gridinfo, dgamx2d, igsum2d, pb_infog2l
5549* ..
5550* .. External Functions ..
5551 LOGICAL LSAME
5552 DOUBLE PRECISION PDLAMCH
5553 EXTERNAL lsame, pdlamch
5554* ..
5555* .. Intrinsic Functions ..
5556 INTRINSIC abs, dble, dconjg, dimag, max, min, mod, sqrt
5557* ..
5558* .. Statement Functions ..
5559 DOUBLE PRECISION ABS1
5560 abs1( z ) = abs( dble( z ) ) + abs( dimag( z ) )
5561* ..
5562* .. Executable Statements ..
5563*
5564 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
5565*
5566 eps = pdlamch( ictxt, 'eps' )
5567*
5568 trana = lsame( transa, 'T' ).OR.lsame( transa, 'C' )
5569 tranb = lsame( transb, 'T' ).OR.lsame( transb, 'C' )
5570 ctrana = lsame( transa, 'C' )
5571 ctranb = lsame( transb, 'C' )
5572*
5573 lda = max( 1, desca( m_ ) )
5574 ldb = max( 1, descb( m_ ) )
5575 ldc = max( 1, descc( m_ ) )
5576*
5577* Compute expected result in C using data in A, B and C.
5578* Compute gauges in G. This part of the computation is performed
5579* by every process in the grid.
5580*
5581 DO 240 j = 1, n
5582*
5583 ioffc = ic + ( jc + j - 2 ) * ldc
5584 DO 10 i = 1, m
5585 ct( i ) = zero
5586 g( i ) = rzero
5587 10 CONTINUE
5588*
5589 IF( .NOT.trana .AND. .NOT.tranb ) THEN
5590 DO 30 kk = 1, k
5591 ioffb = ib + kk - 1 + ( jb + j - 2 ) * ldb
5592 DO 20 i = 1, m
5593 ioffa = ia + i - 1 + ( ja + kk - 2 ) * lda
5594 ct( i ) = ct( i ) + a( ioffa ) * b( ioffb )
5595 g( i ) = g( i ) + abs( a( ioffa ) ) *
5596 $ abs( b( ioffb ) )
5597 20 CONTINUE
5598 30 CONTINUE
5599 ELSE IF( trana .AND. .NOT.tranb ) THEN
5600 IF( ctrana ) THEN
5601 DO 50 kk = 1, k
5602 ioffb = ib + kk - 1 + ( jb + j - 2 ) * ldb
5603 DO 40 i = 1, m
5604 ioffa = ia + kk - 1 + ( ja + i - 2 ) * lda
5605 ct( i ) = ct( i ) + dconjg( a( ioffa ) ) *
5606 $ b( ioffb )
5607 g( i ) = g( i ) + abs1( a( ioffa ) ) *
5608 $ abs1( b( ioffb ) )
5609 40 CONTINUE
5610 50 CONTINUE
5611 ELSE
5612 DO 70 kk = 1, k
5613 ioffb = ib + kk - 1 + ( jb + j - 2 ) * ldb
5614 DO 60 i = 1, m
5615 ioffa = ia + kk - 1 + ( ja + i - 2 ) * lda
5616 ct( i ) = ct( i ) + a( ioffa ) * b( ioffb )
5617 g( i ) = g( i ) + abs1( a( ioffa ) ) *
5618 $ abs1( b( ioffb ) )
5619 60 CONTINUE
5620 70 CONTINUE
5621 END IF
5622 ELSE IF( .NOT.trana .AND. tranb ) THEN
5623 IF( ctranb ) THEN
5624 DO 90 kk = 1, k
5625 ioffb = ib + j - 1 + ( jb + kk - 2 ) * ldb
5626 DO 80 i = 1, m
5627 ioffa = ia + i - 1 + ( ja + kk - 2 ) * lda
5628 ct( i ) = ct( i ) + a( ioffa ) *
5629 $ dconjg( b( ioffb ) )
5630 g( i ) = g( i ) + abs1( a( ioffa ) ) *
5631 $ abs1( b( ioffb ) )
5632 80 CONTINUE
5633 90 CONTINUE
5634 ELSE
5635 DO 110 kk = 1, k
5636 ioffb = ib + j - 1 + ( jb + kk - 2 ) * ldb
5637 DO 100 i = 1, m
5638 ioffa = ia + i - 1 + ( ja + kk - 2 ) * lda
5639 ct( i ) = ct( i ) + a( ioffa ) * b( ioffb )
5640 g( i ) = g( i ) + abs1( a( ioffa ) ) *
5641 $ abs1( b( ioffb ) )
5642 100 CONTINUE
5643 110 CONTINUE
5644 END IF
5645 ELSE IF( trana .AND. tranb ) THEN
5646 IF( ctrana ) THEN
5647 IF( ctranb ) THEN
5648 DO 130 kk = 1, k
5649 ioffb = ib + j - 1 + ( jb + kk - 2 ) * ldb
5650 DO 120 i = 1, m
5651 ioffa = ia + kk - 1 + ( ja + i - 2 ) * lda
5652 ct( i ) = ct( i ) + dconjg( a( ioffa ) ) *
5653 $ dconjg( b( ioffb ) )
5654 g( i ) = g( i ) + abs1( a( ioffa ) ) *
5655 $ abs1( b( ioffb ) )
5656 120 CONTINUE
5657 130 CONTINUE
5658 ELSE
5659 DO 150 kk = 1, k
5660 ioffb = ib + j - 1 + ( jb + kk - 2 ) * ldb
5661 DO 140 i = 1, m
5662 ioffa = ia + kk - 1 + ( ja + i - 2 ) * lda
5663 ct( i ) = ct( i ) + dconjg( a( ioffa ) ) *
5664 $ b( ioffb )
5665 g( i ) = g( i ) + abs1( a( ioffa ) ) *
5666 $ abs1( b( ioffb ) )
5667 140 CONTINUE
5668 150 CONTINUE
5669 END IF
5670 ELSE
5671 IF( ctranb ) THEN
5672 DO 170 kk = 1, k
5673 ioffb = ib + j - 1 + ( jb + kk - 2 ) * ldb
5674 DO 160 i = 1, m
5675 ioffa = ia + kk - 1 + ( ja + i - 2 ) * lda
5676 ct( i ) = ct( i ) + a( ioffa ) *
5677 $ dconjg( b( ioffb ) )
5678 g( i ) = g( i ) + abs1( a( ioffa ) ) *
5679 $ abs1( b( ioffb ) )
5680 160 CONTINUE
5681 170 CONTINUE
5682 ELSE
5683 DO 190 kk = 1, k
5684 ioffb = ib + j - 1 + ( jb + kk - 2 ) * ldb
5685 DO 180 i = 1, m
5686 ioffa = ia + kk - 1 + ( ja + i - 2 ) * lda
5687 ct( i ) = ct( i ) + a( ioffa ) * b( ioffb )
5688 g( i ) = g( i ) + abs1( a( ioffa ) ) *
5689 $ abs1( b( ioffb ) )
5690 180 CONTINUE
5691 190 CONTINUE
5692 END IF
5693 END IF
5694 END IF
5695*
5696 DO 200 i = 1, m
5697 ct( i ) = alpha*ct( i ) + beta * c( ioffc )
5698 g( i ) = abs1( alpha )*g( i ) +
5699 $ abs1( beta )*abs1( c( ioffc ) )
5700 c( ioffc ) = ct( i )
5701 ioffc = ioffc + 1
5702 200 CONTINUE
5703*
5704* Compute the error ratio for this result.
5705*
5706 err = rzero
5707 info = 0
5708 ldpc = descc( lld_ )
5709 ioffc = ic + ( jc + j - 2 ) * ldc
5710 CALL pb_infog2l( ic, jc+j-1, descc, nprow, npcol, myrow, mycol,
5711 $ iic, jjc, icrow, iccol )
5712 icurrow = icrow
5713 rowrep = ( icrow.EQ.-1 )
5714 colrep = ( iccol.EQ.-1 )
5715*
5716 IF( mycol.EQ.iccol .OR. colrep ) THEN
5717*
5718 ibb = descc( imb_ ) - ic + 1
5719 IF( ibb.LE.0 )
5720 $ ibb = ( ( -ibb ) / descc( mb_ ) + 1 )*descc( mb_ ) + ibb
5721 ibb = min( ibb, m )
5722 in = ic + ibb - 1
5723*
5724 DO 210 i = ic, in
5725*
5726 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
5727 erri = abs( pc( iic+(jjc-1)*ldpc ) -
5728 $ c( ioffc ) ) / eps
5729 IF( g( i-ic+1 ).NE.rzero )
5730 $ erri = erri / g( i-ic+1 )
5731 err = max( err, erri )
5732 IF( err*sqrt( eps ).GE.rone )
5733 $ info = 1
5734 iic = iic + 1
5735 END IF
5736*
5737 ioffc = ioffc + 1
5738*
5739 210 CONTINUE
5740*
5741 icurrow = mod( icurrow+1, nprow )
5742*
5743 DO 230 i = in+1, ic+m-1, descc( mb_ )
5744 ibb = min( ic+m-i, descc( mb_ ) )
5745*
5746 DO 220 kk = 0, ibb-1
5747*
5748 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
5749 erri = abs( pc( iic+(jjc-1)*ldpc ) -
5750 $ c( ioffc ) )/eps
5751 IF( g( i+kk-ic+1 ).NE.rzero )
5752 $ erri = erri / g( i+kk-ic+1 )
5753 err = max( err, erri )
5754 IF( err*sqrt( eps ).GE.rone )
5755 $ info = 1
5756 iic = iic + 1
5757 END IF
5758*
5759 ioffc = ioffc + 1
5760*
5761 220 CONTINUE
5762*
5763 icurrow = mod( icurrow+1, nprow )
5764*
5765 230 CONTINUE
5766*
5767 END IF
5768*
5769* If INFO = 0, all results are at least half accurate.
5770*
5771 CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, mycol )
5772 CALL dgamx2d( ictxt, 'All', ' ', 1, 1, err, 1, i, j, -1, -1,
5773 $ mycol )
5774 IF( info.NE.0 )
5775 $ GO TO 250
5776*
5777 240 CONTINUE
5778*
5779 250 CONTINUE
5780*
5781 RETURN
5782*
5783* End of PZMMCH
5784*

◆ pzmmch1()

subroutine pzmmch1 ( integer ictxt,
character*1 uplo,
character*1 trans,
integer n,
integer k,
complex*16 alpha,
complex*16, dimension( * ) a,
integer ia,
integer ja,
integer, dimension( * ) desca,
complex*16 beta,
complex*16, dimension( * ) c,
complex*16, dimension( * ) pc,
integer ic,
integer jc,
integer, dimension( * ) descc,
complex*16, dimension( * ) ct,
double precision, dimension( * ) g,
double precision err,
integer info )

Definition at line 5786 of file pzblastst.f.

5789*
5790* -- PBLAS test routine (version 2.0) --
5791* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
5792* and University of California, Berkeley.
5793* April 1, 1998
5794*
5795* .. Scalar Arguments ..
5796 CHARACTER*1 TRANS, UPLO
5797 INTEGER IA, IC, ICTXT, INFO, JA, JC, K, N
5798 DOUBLE PRECISION ERR
5799 COMPLEX*16 ALPHA, BETA
5800* ..
5801* .. Array Arguments ..
5802 INTEGER DESCA( * ), DESCC( * )
5803 DOUBLE PRECISION G( * )
5804 COMPLEX*16 A( * ), C( * ), CT( * ), PC( * )
5805* ..
5806*
5807* Purpose
5808* =======
5809*
5810* PZMMCH1 checks the results of the computational tests.
5811*
5812* Notes
5813* =====
5814*
5815* A description vector is associated with each 2D block-cyclicly dis-
5816* tributed matrix. This vector stores the information required to
5817* establish the mapping between a matrix entry and its corresponding
5818* process and memory location.
5819*
5820* In the following comments, the character _ should be read as
5821* "of the distributed matrix". Let A be a generic term for any 2D
5822* block cyclicly distributed matrix. Its description vector is DESCA:
5823*
5824* NOTATION STORED IN EXPLANATION
5825* ---------------- --------------- ------------------------------------
5826* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
5827* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
5828* the NPROW x NPCOL BLACS process grid
5829* A is distributed over. The context
5830* itself is global, but the handle
5831* (the integer value) may vary.
5832* M_A (global) DESCA( M_ ) The number of rows in the distribu-
5833* ted matrix A, M_A >= 0.
5834* N_A (global) DESCA( N_ ) The number of columns in the distri-
5835* buted matrix A, N_A >= 0.
5836* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
5837* block of the matrix A, IMB_A > 0.
5838* INB_A (global) DESCA( INB_ ) The number of columns of the upper
5839* left block of the matrix A,
5840* INB_A > 0.
5841* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
5842* bute the last M_A-IMB_A rows of A,
5843* MB_A > 0.
5844* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
5845* bute the last N_A-INB_A columns of
5846* A, NB_A > 0.
5847* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
5848* row of the matrix A is distributed,
5849* NPROW > RSRC_A >= 0.
5850* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
5851* first column of A is distributed.
5852* NPCOL > CSRC_A >= 0.
5853* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
5854* array storing the local blocks of
5855* the distributed matrix A,
5856* IF( Lc( 1, N_A ) > 0 )
5857* LLD_A >= MAX( 1, Lr( 1, M_A ) )
5858* ELSE
5859* LLD_A >= 1.
5860*
5861* Let K be the number of rows of a matrix A starting at the global in-
5862* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
5863* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
5864* receive if these K rows were distributed over NPROW processes. If K
5865* is the number of columns of a matrix A starting at the global index
5866* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
5867* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
5868* these K columns were distributed over NPCOL processes.
5869*
5870* The values of Lr() and Lc() may be determined via a call to the func-
5871* tion PB_NUMROC:
5872* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
5873* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
5874*
5875* Arguments
5876* =========
5877*
5878* ICTXT (local input) INTEGER
5879* On entry, ICTXT specifies the BLACS context handle, indica-
5880* ting the global context of the operation. The context itself
5881* is global, but the value of ICTXT is local.
5882*
5883* UPLO (global input) CHARACTER*1
5884* On entry, UPLO specifies which part of C should contain the
5885* result.
5886*
5887* TRANS (global input) CHARACTER*1
5888* On entry, TRANS specifies whether the matrix A has to be
5889* transposed or not before computing the matrix-matrix product.
5890*
5891* N (global input) INTEGER
5892* On entry, N specifies the order the submatrix operand C. N
5893* must be at least zero.
5894*
5895* K (global input) INTEGER
5896* On entry, K specifies the number of columns (resp. rows) of A
5897* when TRANS = 'N' (resp. TRANS <> 'N'). K must be at least
5898* zero.
5899*
5900* ALPHA (global input) COMPLEX*16
5901* On entry, ALPHA specifies the scalar alpha.
5902*
5903* A (local input) COMPLEX*16 array
5904* On entry, A is an array of dimension (DESCA( M_ ),*). This
5905* array contains a local copy of the initial entire matrix PA.
5906*
5907* IA (global input) INTEGER
5908* On entry, IA specifies A's global row index, which points to
5909* the beginning of the submatrix sub( A ).
5910*
5911* JA (global input) INTEGER
5912* On entry, JA specifies A's global column index, which points
5913* to the beginning of the submatrix sub( A ).
5914*
5915* DESCA (global and local input) INTEGER array
5916* On entry, DESCA is an integer array of dimension DLEN_. This
5917* is the array descriptor for the matrix A.
5918*
5919* BETA (global input) COMPLEX*16
5920* On entry, BETA specifies the scalar beta.
5921*
5922* C (local input/local output) COMPLEX*16 array
5923* On entry, C is an array of dimension (DESCC( M_ ),*). This
5924* array contains a local copy of the initial entire matrix PC.
5925*
5926* PC (local input) COMPLEX*16 array
5927* On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
5928* array contains the local pieces of the matrix PC.
5929*
5930* IC (global input) INTEGER
5931* On entry, IC specifies C's global row index, which points to
5932* the beginning of the submatrix sub( C ).
5933*
5934* JC (global input) INTEGER
5935* On entry, JC specifies C's global column index, which points
5936* to the beginning of the submatrix sub( C ).
5937*
5938* DESCC (global and local input) INTEGER array
5939* On entry, DESCC is an integer array of dimension DLEN_. This
5940* is the array descriptor for the matrix C.
5941*
5942* CT (workspace) COMPLEX*16 array
5943* On entry, CT is an array of dimension at least MAX(M,N,K). CT
5944* holds a copy of the current column of C.
5945*
5946* G (workspace) DOUBLE PRECISION array
5947* On entry, G is an array of dimension at least MAX(M,N,K). G
5948* is used to compute the gauges.
5949*
5950* ERR (global output) DOUBLE PRECISION
5951* On exit, ERR specifies the largest error in absolute value.
5952*
5953* INFO (global output) INTEGER
5954* On exit, if INFO <> 0, the result is less than half accurate.
5955*
5956* -- Written on April 1, 1998 by
5957* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
5958*
5959* =====================================================================
5960*
5961* .. Parameters ..
5962 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
5963 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
5964 $ RSRC_
5965 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
5966 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
5967 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
5968 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
5969 DOUBLE PRECISION RZERO, RONE
5970 parameter( rzero = 0.0d+0, rone = 1.0d+0 )
5971 COMPLEX*16 ZERO
5972 parameter( zero = ( 0.0d+0, 0.0d+0 ) )
5973* ..
5974* .. Local Scalars ..
5975 LOGICAL COLREP, HTRAN, NOTRAN, ROWREP, TRAN, UPPER
5976 INTEGER I, IBB, IBEG, ICCOL, ICROW, ICURROW, IEND, IIC,
5977 $ IN, IOFFAK, IOFFAN, IOFFC, J, JJC, KK, LDA,
5978 $ LDC, LDPC, MYCOL, MYROW, NPCOL, NPROW
5979 DOUBLE PRECISION EPS, ERRI
5980 COMPLEX*16 Z
5981* ..
5982* .. External Subroutines ..
5983 EXTERNAL blacs_gridinfo, dgamx2d, igsum2d, pb_infog2l
5984* ..
5985* .. External Functions ..
5986 LOGICAL LSAME
5987 DOUBLE PRECISION PDLAMCH
5988 EXTERNAL lsame, pdlamch
5989* ..
5990* .. Intrinsic Functions ..
5991 INTRINSIC abs, dble, dconjg, dimag, max, min, mod, sqrt
5992* ..
5993* .. Statement Functions ..
5994 DOUBLE PRECISION ABS1
5995 abs1( z ) = abs( dble( z ) ) + abs( dimag( z ) )
5996* ..
5997* .. Executable Statements ..
5998*
5999 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
6000*
6001 eps = pdlamch( ictxt, 'eps' )
6002*
6003 upper = lsame( uplo, 'U' )
6004 notran = lsame( trans, 'N' )
6005 tran = lsame( trans, 'T' )
6006 htran = lsame( trans, 'H' )
6007*
6008 lda = max( 1, desca( m_ ) )
6009 ldc = max( 1, descc( m_ ) )
6010*
6011* Compute expected result in C using data in A, B and C.
6012* Compute gauges in G. This part of the computation is performed
6013* by every process in the grid.
6014*
6015 DO 140 j = 1, n
6016*
6017 IF( upper ) THEN
6018 ibeg = 1
6019 iend = j
6020 ELSE
6021 ibeg = j
6022 iend = n
6023 END IF
6024*
6025 DO 10 i = 1, n
6026 ct( i ) = zero
6027 g( i ) = rzero
6028 10 CONTINUE
6029*
6030 IF( notran ) THEN
6031 DO 30 kk = 1, k
6032 ioffak = ia + j - 1 + ( ja + kk - 2 ) * lda
6033 DO 20 i = ibeg, iend
6034 ioffan = ia + i - 1 + ( ja + kk - 2 ) * lda
6035 ct( i ) = ct( i ) + a( ioffak ) * a( ioffan )
6036 g( i ) = g( i ) + abs1( a( ioffak ) ) *
6037 $ abs1( a( ioffan ) )
6038 20 CONTINUE
6039 30 CONTINUE
6040 ELSE IF( tran ) THEN
6041 DO 50 kk = 1, k
6042 ioffak = ia + kk - 1 + ( ja + j - 2 ) * lda
6043 DO 40 i = ibeg, iend
6044 ioffan = ia + kk - 1 + ( ja + i - 2 ) * lda
6045 ct( i ) = ct( i ) + a( ioffak ) * a( ioffan )
6046 g( i ) = g( i ) + abs1( a( ioffak ) ) *
6047 $ abs1( a( ioffan ) )
6048 40 CONTINUE
6049 50 CONTINUE
6050 ELSE IF( htran ) THEN
6051 DO 70 kk = 1, k
6052 ioffak = ia + j - 1 + ( ja + kk - 2 ) * lda
6053 DO 60 i = ibeg, iend
6054 ioffan = ia + i - 1 + ( ja + kk - 2 ) * lda
6055 ct( i ) = ct( i ) + a( ioffan ) *
6056 $ dconjg( a( ioffak ) )
6057 g( i ) = g( i ) + abs1( a( ioffak ) ) *
6058 $ abs1( a( ioffan ) )
6059 60 CONTINUE
6060 70 CONTINUE
6061 ELSE
6062 DO 90 kk = 1, k
6063 ioffak = ia + kk - 1 + ( ja + j - 2 ) * lda
6064 DO 80 i = ibeg, iend
6065 ioffan = ia + kk - 1 + ( ja + i - 2 ) * lda
6066 ct( i ) = ct( i ) + dconjg( a( ioffan ) ) *
6067 $ a( ioffak )
6068 g( i ) = g( i ) + abs1( dconjg( a( ioffan ) ) ) *
6069 $ abs1( a( ioffak ) )
6070 80 CONTINUE
6071 90 CONTINUE
6072 END IF
6073*
6074 ioffc = ic + ibeg - 1 + ( jc + j - 2 ) * ldc
6075*
6076 DO 100 i = ibeg, iend
6077 ct( i ) = alpha*ct( i ) + beta * c( ioffc )
6078 g( i ) = abs1( alpha )*g( i ) +
6079 $ abs1( beta )*abs1( c( ioffc ) )
6080 c( ioffc ) = ct( i )
6081 ioffc = ioffc + 1
6082 100 CONTINUE
6083*
6084* Compute the error ratio for this result.
6085*
6086 err = rzero
6087 info = 0
6088 ldpc = descc( lld_ )
6089 ioffc = ic + ( jc + j - 2 ) * ldc
6090 CALL pb_infog2l( ic, jc+j-1, descc, nprow, npcol, myrow, mycol,
6091 $ iic, jjc, icrow, iccol )
6092 icurrow = icrow
6093 rowrep = ( icrow.EQ.-1 )
6094 colrep = ( iccol.EQ.-1 )
6095*
6096 IF( mycol.EQ.iccol .OR. colrep ) THEN
6097*
6098 ibb = descc( imb_ ) - ic + 1
6099 IF( ibb.LE.0 )
6100 $ ibb = ( ( -ibb ) / descc( mb_ ) + 1 )*descc( mb_ ) + ibb
6101 ibb = min( ibb, n )
6102 in = ic + ibb - 1
6103*
6104 DO 110 i = ic, in
6105*
6106 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
6107 erri = abs( pc( iic+(jjc-1)*ldpc ) -
6108 $ c( ioffc ) ) / eps
6109 IF( g( i-ic+1 ).NE.rzero )
6110 $ erri = erri / g( i-ic+1 )
6111 err = max( err, erri )
6112 IF( err*sqrt( eps ).GE.rone )
6113 $ info = 1
6114 iic = iic + 1
6115 END IF
6116*
6117 ioffc = ioffc + 1
6118*
6119 110 CONTINUE
6120*
6121 icurrow = mod( icurrow+1, nprow )
6122*
6123 DO 130 i = in+1, ic+n-1, descc( mb_ )
6124 ibb = min( ic+n-i, descc( mb_ ) )
6125*
6126 DO 120 kk = 0, ibb-1
6127*
6128 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
6129 erri = abs( pc( iic+(jjc-1)*ldpc ) -
6130 $ c( ioffc ) )/eps
6131 IF( g( i+kk-ic+1 ).NE.rzero )
6132 $ erri = erri / g( i+kk-ic+1 )
6133 err = max( err, erri )
6134 IF( err*sqrt( eps ).GE.rone )
6135 $ info = 1
6136 iic = iic + 1
6137 END IF
6138*
6139 ioffc = ioffc + 1
6140*
6141 120 CONTINUE
6142*
6143 icurrow = mod( icurrow+1, nprow )
6144*
6145 130 CONTINUE
6146*
6147 END IF
6148*
6149* If INFO = 0, all results are at least half accurate.
6150*
6151 CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, mycol )
6152 CALL dgamx2d( ictxt, 'All', ' ', 1, 1, err, 1, i, j, -1, -1,
6153 $ mycol )
6154 IF( info.NE.0 )
6155 $ GO TO 150
6156*
6157 140 CONTINUE
6158*
6159 150 CONTINUE
6160*
6161 RETURN
6162*
6163* End of PZMMCH1
6164*

◆ pzmmch2()

subroutine pzmmch2 ( integer ictxt,
character*1 uplo,
character*1 trans,
integer n,
integer k,
complex*16 alpha,
complex*16, dimension( * ) a,
integer ia,
integer ja,
integer, dimension( * ) desca,
complex*16, dimension( * ) b,
integer ib,
integer jb,
integer, dimension( * ) descb,
complex*16 beta,
complex*16, dimension( * ) c,
complex*16, dimension( * ) pc,
integer ic,
integer jc,
integer, dimension( * ) descc,
complex*16, dimension( * ) ct,
double precision, dimension( * ) g,
double precision err,
integer info )

Definition at line 6166 of file pzblastst.f.

6169*
6170* -- PBLAS test routine (version 2.0) --
6171* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
6172* and University of California, Berkeley.
6173* April 1, 1998
6174*
6175* .. Scalar Arguments ..
6176 CHARACTER*1 TRANS, UPLO
6177 INTEGER IA, IB, IC, ICTXT, INFO, JA, JB, JC, K, N
6178 DOUBLE PRECISION ERR
6179 COMPLEX*16 ALPHA, BETA
6180* ..
6181* .. Array Arguments ..
6182 INTEGER DESCA( * ), DESCB( * ), DESCC( * )
6183 DOUBLE PRECISION G( * )
6184 COMPLEX*16 A( * ), B( * ), C( * ), CT( * ),
6185 $ PC( * )
6186* ..
6187*
6188* Purpose
6189* =======
6190*
6191* PZMMCH2 checks the results of the computational tests.
6192*
6193* Notes
6194* =====
6195*
6196* A description vector is associated with each 2D block-cyclicly dis-
6197* tributed matrix. This vector stores the information required to
6198* establish the mapping between a matrix entry and its corresponding
6199* process and memory location.
6200*
6201* In the following comments, the character _ should be read as
6202* "of the distributed matrix". Let A be a generic term for any 2D
6203* block cyclicly distributed matrix. Its description vector is DESCA:
6204*
6205* NOTATION STORED IN EXPLANATION
6206* ---------------- --------------- ------------------------------------
6207* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
6208* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
6209* the NPROW x NPCOL BLACS process grid
6210* A is distributed over. The context
6211* itself is global, but the handle
6212* (the integer value) may vary.
6213* M_A (global) DESCA( M_ ) The number of rows in the distribu-
6214* ted matrix A, M_A >= 0.
6215* N_A (global) DESCA( N_ ) The number of columns in the distri-
6216* buted matrix A, N_A >= 0.
6217* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
6218* block of the matrix A, IMB_A > 0.
6219* INB_A (global) DESCA( INB_ ) The number of columns of the upper
6220* left block of the matrix A,
6221* INB_A > 0.
6222* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
6223* bute the last M_A-IMB_A rows of A,
6224* MB_A > 0.
6225* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
6226* bute the last N_A-INB_A columns of
6227* A, NB_A > 0.
6228* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
6229* row of the matrix A is distributed,
6230* NPROW > RSRC_A >= 0.
6231* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
6232* first column of A is distributed.
6233* NPCOL > CSRC_A >= 0.
6234* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
6235* array storing the local blocks of
6236* the distributed matrix A,
6237* IF( Lc( 1, N_A ) > 0 )
6238* LLD_A >= MAX( 1, Lr( 1, M_A ) )
6239* ELSE
6240* LLD_A >= 1.
6241*
6242* Let K be the number of rows of a matrix A starting at the global in-
6243* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
6244* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
6245* receive if these K rows were distributed over NPROW processes. If K
6246* is the number of columns of a matrix A starting at the global index
6247* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
6248* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
6249* these K columns were distributed over NPCOL processes.
6250*
6251* The values of Lr() and Lc() may be determined via a call to the func-
6252* tion PB_NUMROC:
6253* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
6254* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
6255*
6256* Arguments
6257* =========
6258*
6259* ICTXT (local input) INTEGER
6260* On entry, ICTXT specifies the BLACS context handle, indica-
6261* ting the global context of the operation. The context itself
6262* is global, but the value of ICTXT is local.
6263*
6264* UPLO (global input) CHARACTER*1
6265* On entry, UPLO specifies which part of C should contain the
6266* result.
6267*
6268* TRANS (global input) CHARACTER*1
6269* On entry, TRANS specifies whether the matrices A and B have
6270* to be transposed or not before computing the matrix-matrix
6271* product.
6272*
6273* N (global input) INTEGER
6274* On entry, N specifies the order the submatrix operand C. N
6275* must be at least zero.
6276*
6277* K (global input) INTEGER
6278* On entry, K specifies the number of columns (resp. rows) of A
6279* and B when TRANS = 'N' (resp. TRANS <> 'N'). K must be at
6280* least zero.
6281*
6282* ALPHA (global input) COMPLEX*16
6283* On entry, ALPHA specifies the scalar alpha.
6284*
6285* A (local input) COMPLEX*16 array
6286* On entry, A is an array of dimension (DESCA( M_ ),*). This
6287* array contains a local copy of the initial entire matrix PA.
6288*
6289* IA (global input) INTEGER
6290* On entry, IA specifies A's global row index, which points to
6291* the beginning of the submatrix sub( A ).
6292*
6293* JA (global input) INTEGER
6294* On entry, JA specifies A's global column index, which points
6295* to the beginning of the submatrix sub( A ).
6296*
6297* DESCA (global and local input) INTEGER array
6298* On entry, DESCA is an integer array of dimension DLEN_. This
6299* is the array descriptor for the matrix A.
6300*
6301* B (local input) COMPLEX*16 array
6302* On entry, B is an array of dimension (DESCB( M_ ),*). This
6303* array contains a local copy of the initial entire matrix PB.
6304*
6305* IB (global input) INTEGER
6306* On entry, IB specifies B's global row index, which points to
6307* the beginning of the submatrix sub( B ).
6308*
6309* JB (global input) INTEGER
6310* On entry, JB specifies B's global column index, which points
6311* to the beginning of the submatrix sub( B ).
6312*
6313* DESCB (global and local input) INTEGER array
6314* On entry, DESCB is an integer array of dimension DLEN_. This
6315* is the array descriptor for the matrix B.
6316*
6317* BETA (global input) COMPLEX*16
6318* On entry, BETA specifies the scalar beta.
6319*
6320* C (local input/local output) COMPLEX*16 array
6321* On entry, C is an array of dimension (DESCC( M_ ),*). This
6322* array contains a local copy of the initial entire matrix PC.
6323*
6324* PC (local input) COMPLEX*16 array
6325* On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
6326* array contains the local pieces of the matrix PC.
6327*
6328* IC (global input) INTEGER
6329* On entry, IC specifies C's global row index, which points to
6330* the beginning of the submatrix sub( C ).
6331*
6332* JC (global input) INTEGER
6333* On entry, JC specifies C's global column index, which points
6334* to the beginning of the submatrix sub( C ).
6335*
6336* DESCC (global and local input) INTEGER array
6337* On entry, DESCC is an integer array of dimension DLEN_. This
6338* is the array descriptor for the matrix C.
6339*
6340* CT (workspace) COMPLEX*16 array
6341* On entry, CT is an array of dimension at least MAX(M,N,K). CT
6342* holds a copy of the current column of C.
6343*
6344* G (workspace) DOUBLE PRECISION array
6345* On entry, G is an array of dimension at least MAX(M,N,K). G
6346* is used to compute the gauges.
6347*
6348* ERR (global output) DOUBLE PRECISION
6349* On exit, ERR specifies the largest error in absolute value.
6350*
6351* INFO (global output) INTEGER
6352* On exit, if INFO <> 0, the result is less than half accurate.
6353*
6354* -- Written on April 1, 1998 by
6355* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
6356*
6357* =====================================================================
6358*
6359* .. Parameters ..
6360 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
6361 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
6362 $ RSRC_
6363 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
6364 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
6365 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
6366 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
6367 DOUBLE PRECISION RZERO, RONE
6368 parameter( rzero = 0.0d+0, rone = 1.0d+0 )
6369 COMPLEX*16 ZERO
6370 parameter( zero = ( 0.0d+0, 0.0d+0 ) )
6371* ..
6372* .. Local Scalars ..
6373 LOGICAL COLREP, HTRAN, NOTRAN, ROWREP, TRAN, UPPER
6374 INTEGER I, IBB, IBEG, ICCOL, ICROW, ICURROW, IEND, IIC,
6375 $ IN, IOFFAK, IOFFAN, IOFFBK, IOFFBN, IOFFC, J,
6376 $ JJC, KK, LDA, LDB, LDC, LDPC, MYCOL, MYROW,
6377 $ NPCOL, NPROW
6378 DOUBLE PRECISION EPS, ERRI
6379 COMPLEX*16 Z
6380* ..
6381* .. External Subroutines ..
6382 EXTERNAL blacs_gridinfo, dgamx2d, igsum2d, pb_infog2l
6383* ..
6384* .. External Functions ..
6385 LOGICAL LSAME
6386 DOUBLE PRECISION PDLAMCH
6387 EXTERNAL lsame, pdlamch
6388* ..
6389* .. Intrinsic Functions ..
6390 INTRINSIC abs, dble, dconjg, dimag, max, min, mod, sqrt
6391* ..
6392* .. Statement Functions ..
6393 DOUBLE PRECISION ABS1
6394 abs1( z ) = abs( dble( z ) ) + abs( dimag( z ) )
6395* ..
6396* .. Executable Statements ..
6397*
6398 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
6399*
6400 eps = pdlamch( ictxt, 'eps' )
6401*
6402 upper = lsame( uplo, 'U' )
6403 htran = lsame( trans, 'H' )
6404 notran = lsame( trans, 'N' )
6405 tran = lsame( trans, 'T' )
6406*
6407 lda = max( 1, desca( m_ ) )
6408 ldb = max( 1, descb( m_ ) )
6409 ldc = max( 1, descc( m_ ) )
6410*
6411* Compute expected result in C using data in A, B and C.
6412* Compute gauges in G. This part of the computation is performed
6413* by every process in the grid.
6414*
6415 DO 140 j = 1, n
6416*
6417 IF( upper ) THEN
6418 ibeg = 1
6419 iend = j
6420 ELSE
6421 ibeg = j
6422 iend = n
6423 END IF
6424*
6425 DO 10 i = 1, n
6426 ct( i ) = zero
6427 g( i ) = rzero
6428 10 CONTINUE
6429*
6430 IF( notran ) THEN
6431 DO 30 kk = 1, k
6432 ioffak = ia + j - 1 + ( ja + kk - 2 ) * lda
6433 ioffbk = ib + j - 1 + ( jb + kk - 2 ) * ldb
6434 DO 20 i = ibeg, iend
6435 ioffan = ia + i - 1 + ( ja + kk - 2 ) * lda
6436 ioffbn = ib + i - 1 + ( jb + kk - 2 ) * ldb
6437 ct( i ) = ct( i ) + alpha * (
6438 $ a( ioffan ) * b( ioffbk ) +
6439 $ b( ioffbn ) * a( ioffak ) )
6440 g( i ) = g( i ) + abs( alpha ) * (
6441 $ abs1( a( ioffan ) ) * abs1( b( ioffbk ) ) +
6442 $ abs1( b( ioffbn ) ) * abs1( a( ioffak ) ) )
6443 20 CONTINUE
6444 30 CONTINUE
6445 ELSE IF( tran ) THEN
6446 DO 50 kk = 1, k
6447 ioffak = ia + kk - 1 + ( ja + j - 2 ) * lda
6448 ioffbk = ib + kk - 1 + ( jb + j - 2 ) * ldb
6449 DO 40 i = ibeg, iend
6450 ioffan = ia + kk - 1 + ( ja + i - 2 ) * lda
6451 ioffbn = ib + kk - 1 + ( jb + i - 2 ) * ldb
6452 ct( i ) = ct( i ) + alpha * (
6453 $ a( ioffan ) * b( ioffbk ) +
6454 $ b( ioffbn ) * a( ioffak ) )
6455 g( i ) = g( i ) + abs( alpha ) * (
6456 $ abs1( a( ioffan ) ) * abs1( b( ioffbk ) ) +
6457 $ abs1( b( ioffbn ) ) * abs1( a( ioffak ) ) )
6458 40 CONTINUE
6459 50 CONTINUE
6460 ELSE IF( htran ) THEN
6461 DO 70 kk = 1, k
6462 ioffak = ia + j - 1 + ( ja + kk - 2 ) * lda
6463 ioffbk = ib + j - 1 + ( jb + kk - 2 ) * ldb
6464 DO 60 i = ibeg, iend
6465 ioffan = ia + i - 1 + ( ja + kk - 2 ) * lda
6466 ioffbn = ib + i - 1 + ( jb + kk - 2 ) * ldb
6467 ct( i ) = ct( i ) +
6468 $ alpha * a( ioffan ) * dconjg( b( ioffbk ) ) +
6469 $ b( ioffbn ) * dconjg( alpha * a( ioffak ) )
6470 g( i ) = g( i ) + abs1( alpha ) * (
6471 $ abs1( a( ioffan ) ) * abs1( b( ioffbk ) ) +
6472 $ abs1( b( ioffbn ) ) * abs1( a( ioffak ) ) )
6473 60 CONTINUE
6474 70 CONTINUE
6475 ELSE
6476 DO 90 kk = 1, k
6477 ioffak = ia + kk - 1 + ( ja + j - 2 ) * lda
6478 ioffbk = ib + kk - 1 + ( jb + j - 2 ) * ldb
6479 DO 80 i = ibeg, iend
6480 ioffan = ia + kk - 1 + ( ja + i - 2 ) * lda
6481 ioffbn = ib + kk - 1 + ( jb + i - 2 ) * ldb
6482 ct( i ) = ct( i ) +
6483 $ alpha * dconjg( a( ioffan ) ) * b( ioffbk ) +
6484 $ dconjg( alpha * b( ioffbn ) ) * a( ioffak )
6485 g( i ) = g( i ) + abs1( alpha ) * (
6486 $ abs1( dconjg( a( ioffan ) ) * b( ioffbk ) ) +
6487 $ abs1( dconjg( b( ioffbn ) ) * a( ioffak ) ) )
6488 80 CONTINUE
6489 90 CONTINUE
6490 END IF
6491*
6492 ioffc = ic + ibeg - 1 + ( jc + j - 2 ) * ldc
6493*
6494 DO 100 i = ibeg, iend
6495 ct( i ) = ct( i ) + beta * c( ioffc )
6496 g( i ) = g( i ) + abs1( beta )*abs1( c( ioffc ) )
6497 c( ioffc ) = ct( i )
6498 ioffc = ioffc + 1
6499 100 CONTINUE
6500*
6501* Compute the error ratio for this result.
6502*
6503 err = rzero
6504 info = 0
6505 ldpc = descc( lld_ )
6506 ioffc = ic + ( jc + j - 2 ) * ldc
6507 CALL pb_infog2l( ic, jc+j-1, descc, nprow, npcol, myrow, mycol,
6508 $ iic, jjc, icrow, iccol )
6509 icurrow = icrow
6510 rowrep = ( icrow.EQ.-1 )
6511 colrep = ( iccol.EQ.-1 )
6512*
6513 IF( mycol.EQ.iccol .OR. colrep ) THEN
6514*
6515 ibb = descc( imb_ ) - ic + 1
6516 IF( ibb.LE.0 )
6517 $ ibb = ( ( -ibb ) / descc( mb_ ) + 1 )*descc( mb_ ) + ibb
6518 ibb = min( ibb, n )
6519 in = ic + ibb - 1
6520*
6521 DO 110 i = ic, in
6522*
6523 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
6524 erri = abs( pc( iic+(jjc-1)*ldpc ) -
6525 $ c( ioffc ) ) / eps
6526 IF( g( i-ic+1 ).NE.rzero )
6527 $ erri = erri / g( i-ic+1 )
6528 err = max( err, erri )
6529 IF( err*sqrt( eps ).GE.rone )
6530 $ info = 1
6531 iic = iic + 1
6532 END IF
6533*
6534 ioffc = ioffc + 1
6535*
6536 110 CONTINUE
6537*
6538 icurrow = mod( icurrow+1, nprow )
6539*
6540 DO 130 i = in+1, ic+n-1, descc( mb_ )
6541 ibb = min( ic+n-i, descc( mb_ ) )
6542*
6543 DO 120 kk = 0, ibb-1
6544*
6545 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
6546 erri = abs( pc( iic+(jjc-1)*ldpc ) -
6547 $ c( ioffc ) )/eps
6548 IF( g( i+kk-ic+1 ).NE.rzero )
6549 $ erri = erri / g( i+kk-ic+1 )
6550 err = max( err, erri )
6551 IF( err*sqrt( eps ).GE.rone )
6552 $ info = 1
6553 iic = iic + 1
6554 END IF
6555*
6556 ioffc = ioffc + 1
6557*
6558 120 CONTINUE
6559*
6560 icurrow = mod( icurrow+1, nprow )
6561*
6562 130 CONTINUE
6563*
6564 END IF
6565*
6566* If INFO = 0, all results are at least half accurate.
6567*
6568 CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, mycol )
6569 CALL dgamx2d( ictxt, 'All', ' ', 1, 1, err, 1, i, j, -1, -1,
6570 $ mycol )
6571 IF( info.NE.0 )
6572 $ GO TO 150
6573*
6574 140 CONTINUE
6575*
6576 150 CONTINUE
6577*
6578 RETURN
6579*
6580* End of PZMMCH2
6581*

◆ pzmmch3()

subroutine pzmmch3 ( character*1 uplo,
character*1 trans,
integer m,
integer n,
complex*16 alpha,
complex*16, dimension( * ) a,
integer ia,
integer ja,
integer, dimension( * ) desca,
complex*16 beta,
complex*16, dimension( * ) c,
complex*16, dimension( * ) pc,
integer ic,
integer jc,
integer, dimension( * ) descc,
double precision err,
integer info )

Definition at line 6583 of file pzblastst.f.

6585*
6586* -- PBLAS test routine (version 2.0) --
6587* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
6588* and University of California, Berkeley.
6589* April 1, 1998
6590*
6591* .. Scalar Arguments ..
6592 CHARACTER*1 TRANS, UPLO
6593 INTEGER IA, IC, INFO, JA, JC, M, N
6594 DOUBLE PRECISION ERR
6595 COMPLEX*16 ALPHA, BETA
6596* ..
6597* .. Array Arguments ..
6598 INTEGER DESCA( * ), DESCC( * )
6599 COMPLEX*16 A( * ), C( * ), PC( * )
6600* ..
6601*
6602* Purpose
6603* =======
6604*
6605* PZMMCH3 checks the results of the computational tests.
6606*
6607* Notes
6608* =====
6609*
6610* A description vector is associated with each 2D block-cyclicly dis-
6611* tributed matrix. This vector stores the information required to
6612* establish the mapping between a matrix entry and its corresponding
6613* process and memory location.
6614*
6615* In the following comments, the character _ should be read as
6616* "of the distributed matrix". Let A be a generic term for any 2D
6617* block cyclicly distributed matrix. Its description vector is DESCA:
6618*
6619* NOTATION STORED IN EXPLANATION
6620* ---------------- --------------- ------------------------------------
6621* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
6622* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
6623* the NPROW x NPCOL BLACS process grid
6624* A is distributed over. The context
6625* itself is global, but the handle
6626* (the integer value) may vary.
6627* M_A (global) DESCA( M_ ) The number of rows in the distribu-
6628* ted matrix A, M_A >= 0.
6629* N_A (global) DESCA( N_ ) The number of columns in the distri-
6630* buted matrix A, N_A >= 0.
6631* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
6632* block of the matrix A, IMB_A > 0.
6633* INB_A (global) DESCA( INB_ ) The number of columns of the upper
6634* left block of the matrix A,
6635* INB_A > 0.
6636* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
6637* bute the last M_A-IMB_A rows of A,
6638* MB_A > 0.
6639* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
6640* bute the last N_A-INB_A columns of
6641* A, NB_A > 0.
6642* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
6643* row of the matrix A is distributed,
6644* NPROW > RSRC_A >= 0.
6645* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
6646* first column of A is distributed.
6647* NPCOL > CSRC_A >= 0.
6648* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
6649* array storing the local blocks of
6650* the distributed matrix A,
6651* IF( Lc( 1, N_A ) > 0 )
6652* LLD_A >= MAX( 1, Lr( 1, M_A ) )
6653* ELSE
6654* LLD_A >= 1.
6655*
6656* Let K be the number of rows of a matrix A starting at the global in-
6657* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
6658* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
6659* receive if these K rows were distributed over NPROW processes. If K
6660* is the number of columns of a matrix A starting at the global index
6661* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
6662* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
6663* these K columns were distributed over NPCOL processes.
6664*
6665* The values of Lr() and Lc() may be determined via a call to the func-
6666* tion PB_NUMROC:
6667* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
6668* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
6669*
6670* Arguments
6671* =========
6672*
6673* UPLO (global input) CHARACTER*1
6674* On entry, UPLO specifies which part of C should contain the
6675* result.
6676*
6677* TRANS (global input) CHARACTER*1
6678* On entry, TRANS specifies whether the matrix A has to be
6679* transposed or not before computing the matrix-matrix addi-
6680* tion.
6681*
6682* M (global input) INTEGER
6683* On entry, M specifies the number of rows of C.
6684*
6685* N (global input) INTEGER
6686* On entry, N specifies the number of columns of C.
6687*
6688* ALPHA (global input) COMPLEX*16
6689* On entry, ALPHA specifies the scalar alpha.
6690*
6691* A (local input) COMPLEX*16 array
6692* On entry, A is an array of dimension (DESCA( M_ ),*). This
6693* array contains a local copy of the initial entire matrix PA.
6694*
6695* IA (global input) INTEGER
6696* On entry, IA specifies A's global row index, which points to
6697* the beginning of the submatrix sub( A ).
6698*
6699* JA (global input) INTEGER
6700* On entry, JA specifies A's global column index, which points
6701* to the beginning of the submatrix sub( A ).
6702*
6703* DESCA (global and local input) INTEGER array
6704* On entry, DESCA is an integer array of dimension DLEN_. This
6705* is the array descriptor for the matrix A.
6706*
6707* BETA (global input) COMPLEX*16
6708* On entry, BETA specifies the scalar beta.
6709*
6710* C (local input/local output) COMPLEX*16 array
6711* On entry, C is an array of dimension (DESCC( M_ ),*). This
6712* array contains a local copy of the initial entire matrix PC.
6713*
6714* PC (local input) COMPLEX*16 array
6715* On entry, PC is an array of dimension (DESCC( LLD_ ),*). This
6716* array contains the local pieces of the matrix PC.
6717*
6718* IC (global input) INTEGER
6719* On entry, IC specifies C's global row index, which points to
6720* the beginning of the submatrix sub( C ).
6721*
6722* JC (global input) INTEGER
6723* On entry, JC specifies C's global column index, which points
6724* to the beginning of the submatrix sub( C ).
6725*
6726* DESCC (global and local input) INTEGER array
6727* On entry, DESCC is an integer array of dimension DLEN_. This
6728* is the array descriptor for the matrix C.
6729*
6730* ERR (global output) DOUBLE PRECISION
6731* On exit, ERR specifies the largest error in absolute value.
6732*
6733* INFO (global output) INTEGER
6734* On exit, if INFO <> 0, the result is less than half accurate.
6735*
6736* -- Written on April 1, 1998 by
6737* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
6738*
6739* =====================================================================
6740*
6741* .. Parameters ..
6742 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
6743 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
6744 $ RSRC_
6745 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
6746 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
6747 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
6748 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
6749 DOUBLE PRECISION ZERO
6750 parameter( zero = 0.0d+0 )
6751* ..
6752* .. Local Scalars ..
6753 LOGICAL COLREP, CTRAN, LOWER, NOTRAN, ROWREP, UPPER
6754 INTEGER I, ICCOL, ICROW, ICTXT, IIC, IOFFA, IOFFC, J,
6755 $ JJC, LDA, LDC, LDPC, MYCOL, MYROW, NPCOL,
6756 $ NPROW
6757 DOUBLE PRECISION ERR0, ERRI, PREC
6758* ..
6759* .. External Subroutines ..
6760 EXTERNAL blacs_gridinfo, dgamx2d, igsum2d, pb_infog2l,
6761 $ pzerraxpby
6762* ..
6763* .. External Functions ..
6764 LOGICAL LSAME
6765 DOUBLE PRECISION PDLAMCH
6766 EXTERNAL lsame, pdlamch
6767* ..
6768* .. Intrinsic Functions ..
6769 INTRINSIC abs, dconjg, max
6770* ..
6771* .. Executable Statements ..
6772*
6773 ictxt = descc( ctxt_ )
6774 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
6775*
6776 prec = pdlamch( ictxt, 'eps' )
6777*
6778 upper = lsame( uplo, 'U' )
6779 lower = lsame( uplo, 'L' )
6780 notran = lsame( trans, 'N' )
6781 ctran = lsame( trans, 'C' )
6782*
6783* Compute expected result in C using data in A and C. This part of
6784* the computation is performed by every process in the grid.
6785*
6786 info = 0
6787 err = zero
6788*
6789 lda = max( 1, desca( m_ ) )
6790 ldc = max( 1, descc( m_ ) )
6791 ldpc = max( 1, descc( lld_ ) )
6792 rowrep = ( descc( rsrc_ ).EQ.-1 )
6793 colrep = ( descc( csrc_ ).EQ.-1 )
6794*
6795 IF( notran ) THEN
6796*
6797 DO 20 j = jc, jc + n - 1
6798*
6799 ioffc = ic + ( j - 1 ) * ldc
6800 ioffa = ia + ( ja - 1 + j - jc ) * lda
6801*
6802 DO 10 i = ic, ic + m - 1
6803*
6804 IF( upper ) THEN
6805 IF( ( j - jc ).GE.( i - ic ) ) THEN
6806 CALL pzerraxpby( erri, alpha, a( ioffa ), beta,
6807 $ c( ioffc ), prec )
6808 ELSE
6809 erri = zero
6810 END IF
6811 ELSE IF( lower ) THEN
6812 IF( ( j - jc ).LE.( i - ic ) ) THEN
6813 CALL pzerraxpby( erri, alpha, a( ioffa ), beta,
6814 $ c( ioffc ), prec )
6815 ELSE
6816 erri = zero
6817 END IF
6818 ELSE
6819 CALL pzerraxpby( erri, alpha, a( ioffa ), beta,
6820 $ c( ioffc ), prec )
6821 END IF
6822*
6823 CALL pb_infog2l( i, j, descc, nprow, npcol, myrow, mycol,
6824 $ iic, jjc, icrow, iccol )
6825 IF( ( myrow.EQ.icrow .OR. rowrep ) .AND.
6826 $ ( mycol.EQ.iccol .OR. colrep ) ) THEN
6827 err0 = abs( pc( iic+(jjc-1)*ldpc )-c( ioffc ) )
6828 IF( err0.GT.erri )
6829 $ info = 1
6830 err = max( err, err0 )
6831 END IF
6832*
6833 ioffa = ioffa + 1
6834 ioffc = ioffc + 1
6835*
6836 10 CONTINUE
6837*
6838 20 CONTINUE
6839*
6840 ELSE IF( ctran ) THEN
6841*
6842 DO 40 j = jc, jc + n - 1
6843*
6844 ioffc = ic + ( j - 1 ) * ldc
6845 ioffa = ia + ( j - jc ) + ( ja - 1 ) * lda
6846*
6847 DO 30 i = ic, ic + m - 1
6848*
6849 IF( upper ) THEN
6850 IF( ( j - jc ).GE.( i - ic ) ) THEN
6851 CALL pzerraxpby( erri, alpha, dconjg( a( ioffa ) ),
6852 $ beta, c( ioffc ), prec )
6853 ELSE
6854 erri = zero
6855 END IF
6856 ELSE IF( lower ) THEN
6857 IF( ( j - jc ).LE.( i - ic ) ) THEN
6858 CALL pzerraxpby( erri, alpha, dconjg( a( ioffa ) ),
6859 $ beta, c( ioffc ), prec )
6860 ELSE
6861 erri = zero
6862 END IF
6863 ELSE
6864 CALL pzerraxpby( erri, alpha, dconjg( a( ioffa ) ),
6865 $ beta, c( ioffc ), prec )
6866 END IF
6867*
6868 CALL pb_infog2l( i, j, descc, nprow, npcol, myrow, mycol,
6869 $ iic, jjc, icrow, iccol )
6870 IF( ( myrow.EQ.icrow .OR. rowrep ) .AND.
6871 $ ( mycol.EQ.iccol .OR. colrep ) ) THEN
6872 err0 = abs( pc( iic+(jjc-1)*ldpc )-c( ioffc ) )
6873 IF( err0.GT.erri )
6874 $ info = 1
6875 err = max( err, err0 )
6876 END IF
6877*
6878 ioffc = ioffc + 1
6879 ioffa = ioffa + lda
6880*
6881 30 CONTINUE
6882*
6883 40 CONTINUE
6884*
6885 ELSE
6886*
6887 DO 60 j = jc, jc + n - 1
6888*
6889 ioffc = ic + ( j - 1 ) * ldc
6890 ioffa = ia + ( j - jc ) + ( ja - 1 ) * lda
6891*
6892 DO 50 i = ic, ic + m - 1
6893*
6894 IF( upper ) THEN
6895 IF( ( j - jc ).GE.( i - ic ) ) THEN
6896 CALL pzerraxpby( erri, alpha, a( ioffa ), beta,
6897 $ c( ioffc ), prec )
6898 ELSE
6899 erri = zero
6900 END IF
6901 ELSE IF( lower ) THEN
6902 IF( ( j - jc ).LE.( i - ic ) ) THEN
6903 CALL pzerraxpby( erri, alpha, a( ioffa ), beta,
6904 $ c( ioffc ), prec )
6905 ELSE
6906 erri = zero
6907 END IF
6908 ELSE
6909 CALL pzerraxpby( erri, alpha, a( ioffa ), beta,
6910 $ c( ioffc ), prec )
6911 END IF
6912*
6913 CALL pb_infog2l( i, j, descc, nprow, npcol, myrow, mycol,
6914 $ iic, jjc, icrow, iccol )
6915 IF( ( myrow.EQ.icrow .OR. rowrep ) .AND.
6916 $ ( mycol.EQ.iccol .OR. colrep ) ) THEN
6917 err0 = abs( pc( iic+(jjc-1)*ldpc )-c( ioffc ) )
6918 IF( err0.GT.erri )
6919 $ info = 1
6920 err = max( err, err0 )
6921 END IF
6922*
6923 ioffc = ioffc + 1
6924 ioffa = ioffa + lda
6925*
6926 50 CONTINUE
6927*
6928 60 CONTINUE
6929*
6930 END IF
6931*
6932* If INFO = 0, all results are at least half accurate.
6933*
6934 CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, mycol )
6935 CALL dgamx2d( ictxt, 'All', ' ', 1, 1, err, 1, i, j, -1, -1,
6936 $ mycol )
6937*
6938 RETURN
6939*
6940* End of PZMMCH3
6941*
pzerraxpby
subroutine pzerraxpby(errbnd, alpha, x, beta, y, prec)
Definition pzblastst.f:6944

◆ pzmprnt()

subroutine pzmprnt ( integer ictxt,
integer nout,
integer m,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
integer irprnt,
integer icprnt,
character*(*) cmatnm )

Definition at line 3953 of file pzblastst.f.

3955*
3956* -- PBLAS test routine (version 2.0) --
3957* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
3958* and University of California, Berkeley.
3959* April 1, 1998
3960*
3961* .. Scalar Arguments ..
3962 INTEGER ICPRNT, ICTXT, IRPRNT, LDA, M, N, NOUT
3963* ..
3964* .. Array Arguments ..
3965 CHARACTER*(*) CMATNM
3966 COMPLEX*16 A( LDA, * )
3967* ..
3968*
3969* Purpose
3970* =======
3971*
3972* PZMPRNT prints to the standard output an array A of size m by n. Only
3973* the process of coordinates ( IRPRNT, ICPRNT ) is printing.
3974*
3975* Arguments
3976* =========
3977*
3978* ICTXT (local input) INTEGER
3979* On entry, ICTXT specifies the BLACS context handle, indica-
3980* ting the global context of the operation. The context itself
3981* is global, but the value of ICTXT is local.
3982*
3983* NOUT (global input) INTEGER
3984* On entry, NOUT specifies the unit number for the output file.
3985* When NOUT is 6, output to screen, when NOUT is 0, output to
3986* stderr. NOUT is only defined for process 0.
3987*
3988* M (global input) INTEGER
3989* On entry, M specifies the number of rows of the matrix A. M
3990* must be at least zero.
3991*
3992* N (global input) INTEGER
3993* On entry, N specifies the number of columns of the matrix A.
3994* N must be at least zero.
3995*
3996* A (local input) COMPLEX*16 array
3997* On entry, A is an array of dimension (LDA,N). The leading m
3998* by n part of this array is printed.
3999*
4000* LDA (local input) INTEGER
4001* On entry, LDA specifies the leading dimension of the local
4002* array A to be printed. LDA must be at least MAX( 1, M ).
4003*
4004* IRPRNT (global input) INTEGER
4005* On entry, IRPRNT specifies the process row coordinate of the
4006* printing process.
4007*
4008* ICPRNT (global input) INTEGER
4009* On entry, ICPRNT specifies the process column coordinate of
4010* the printing process.
4011*
4012* CMATNM (global input) CHARACTER*(*)
4013* On entry, CMATNM specifies the identifier of the matrix to be
4014* printed.
4015*
4016* -- Written on April 1, 1998 by
4017* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4018*
4019* =====================================================================
4020*
4021* .. Local Scalars ..
4022 INTEGER I, J, MYCOL, MYROW, NPCOL, NPROW
4023* ..
4024* .. External Subroutines ..
4025 EXTERNAL blacs_gridinfo
4026* ..
4027* .. Intrinsic Functions ..
4028 INTRINSIC dble, dimag
4029* ..
4030* .. Executable Statements ..
4031*
4032* Quick return if possible
4033*
4034 IF( ( m.LE.0 ).OR.( n.LE.0 ) )
4035 $ RETURN
4036*
4037* Get grid parameters
4038*
4039 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
4040*
4041 IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
4042*
4043 WRITE( nout, fmt = * )
4044 DO 20 j = 1, n
4045*
4046 DO 10 i = 1, m
4047*
4048 WRITE( nout, fmt = 9999 ) cmatnm, i, j,
4049 $ dble( a( i, j ) ), dimag( a( i, j ) )
4050*
4051 10 CONTINUE
4052*
4053 20 CONTINUE
4054*
4055 END IF
4056*
4057 9999 FORMAT( 1x, a, '(', i6, ',', i6, ')=', d30.18, '+i*(',
4058 $ d30.18, ')' )
4059*
4060 RETURN
4061*
4062* End of PZMPRNT
4063*

◆ pzmvch()

subroutine pzmvch ( integer ictxt,
character*1 trans,
integer m,
integer n,
complex*16 alpha,
complex*16, dimension( * ) a,
integer ia,
integer ja,
integer, dimension( * ) desca,
complex*16, dimension( * ) x,
integer ix,
integer jx,
integer, dimension( * ) descx,
integer incx,
complex*16 beta,
complex*16, dimension( * ) y,
complex*16, dimension( * ) py,
integer iy,
integer jy,
integer, dimension( * ) descy,
integer incy,
double precision, dimension( * ) g,
double precision err,
integer info )

Definition at line 4169 of file pzblastst.f.

4172*
4173* -- PBLAS test routine (version 2.0) --
4174* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4175* and University of California, Berkeley.
4176* April 1, 1998
4177*
4178* .. Scalar Arguments ..
4179 CHARACTER*1 TRANS
4180 INTEGER IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
4181 $ JY, M, N
4182 DOUBLE PRECISION ERR
4183 COMPLEX*16 ALPHA, BETA
4184* ..
4185* .. Array Arguments ..
4186 INTEGER DESCA( * ), DESCX( * ), DESCY( * )
4187 DOUBLE PRECISION G( * )
4188 COMPLEX*16 A( * ), PY( * ), X( * ), Y( * )
4189* ..
4190*
4191* Purpose
4192* =======
4193*
4194* PZMVCH checks the results of the computational tests.
4195*
4196* Notes
4197* =====
4198*
4199* A description vector is associated with each 2D block-cyclicly dis-
4200* tributed matrix. This vector stores the information required to
4201* establish the mapping between a matrix entry and its corresponding
4202* process and memory location.
4203*
4204* In the following comments, the character _ should be read as
4205* "of the distributed matrix". Let A be a generic term for any 2D
4206* block cyclicly distributed matrix. Its description vector is DESCA:
4207*
4208* NOTATION STORED IN EXPLANATION
4209* ---------------- --------------- ------------------------------------
4210* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
4211* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
4212* the NPROW x NPCOL BLACS process grid
4213* A is distributed over. The context
4214* itself is global, but the handle
4215* (the integer value) may vary.
4216* M_A (global) DESCA( M_ ) The number of rows in the distribu-
4217* ted matrix A, M_A >= 0.
4218* N_A (global) DESCA( N_ ) The number of columns in the distri-
4219* buted matrix A, N_A >= 0.
4220* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
4221* block of the matrix A, IMB_A > 0.
4222* INB_A (global) DESCA( INB_ ) The number of columns of the upper
4223* left block of the matrix A,
4224* INB_A > 0.
4225* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
4226* bute the last M_A-IMB_A rows of A,
4227* MB_A > 0.
4228* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
4229* bute the last N_A-INB_A columns of
4230* A, NB_A > 0.
4231* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
4232* row of the matrix A is distributed,
4233* NPROW > RSRC_A >= 0.
4234* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
4235* first column of A is distributed.
4236* NPCOL > CSRC_A >= 0.
4237* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
4238* array storing the local blocks of
4239* the distributed matrix A,
4240* IF( Lc( 1, N_A ) > 0 )
4241* LLD_A >= MAX( 1, Lr( 1, M_A ) )
4242* ELSE
4243* LLD_A >= 1.
4244*
4245* Let K be the number of rows of a matrix A starting at the global in-
4246* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
4247* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
4248* receive if these K rows were distributed over NPROW processes. If K
4249* is the number of columns of a matrix A starting at the global index
4250* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
4251* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
4252* these K columns were distributed over NPCOL processes.
4253*
4254* The values of Lr() and Lc() may be determined via a call to the func-
4255* tion PB_NUMROC:
4256* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
4257* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
4258*
4259* Arguments
4260* =========
4261*
4262* ICTXT (local input) INTEGER
4263* On entry, ICTXT specifies the BLACS context handle, indica-
4264* ting the global context of the operation. The context itself
4265* is global, but the value of ICTXT is local.
4266*
4267* TRANS (global input) CHARACTER*1
4268* On entry, TRANS specifies which matrix-vector product is to
4269* be computed as follows:
4270* If TRANS = 'T',
4271* sub( Y ) = BETA * sub( Y ) + sub( A )**T * sub( X ),
4272* else if TRANS = 'C',
4273* sub( Y ) = BETA * sub( Y ) + sub( A )**H * sub( X ),
4274* otherwise
4275* sub( Y ) = BETA * sub( Y ) + sub( A ) * sub( X ).
4276*
4277* M (global input) INTEGER
4278* On entry, M specifies the number of rows of the submatrix
4279* operand matrix A. M must be at least zero.
4280*
4281* N (global input) INTEGER
4282* On entry, N specifies the number of columns of the subma-
4283* trix operand matrix A. N must be at least zero.
4284*
4285* ALPHA (global input) COMPLEX*16
4286* On entry, ALPHA specifies the scalar alpha.
4287*
4288* A (local input) COMPLEX*16 array
4289* On entry, A is an array of dimension (DESCA( M_ ),*). This
4290* array contains a local copy of the initial entire matrix PA.
4291*
4292* IA (global input) INTEGER
4293* On entry, IA specifies A's global row index, which points to
4294* the beginning of the submatrix sub( A ).
4295*
4296* JA (global input) INTEGER
4297* On entry, JA specifies A's global column index, which points
4298* to the beginning of the submatrix sub( A ).
4299*
4300* DESCA (global and local input) INTEGER array
4301* On entry, DESCA is an integer array of dimension DLEN_. This
4302* is the array descriptor for the matrix A.
4303*
4304* X (local input) COMPLEX*16 array
4305* On entry, X is an array of dimension (DESCX( M_ ),*). This
4306* array contains a local copy of the initial entire matrix PX.
4307*
4308* IX (global input) INTEGER
4309* On entry, IX specifies X's global row index, which points to
4310* the beginning of the submatrix sub( X ).
4311*
4312* JX (global input) INTEGER
4313* On entry, JX specifies X's global column index, which points
4314* to the beginning of the submatrix sub( X ).
4315*
4316* DESCX (global and local input) INTEGER array
4317* On entry, DESCX is an integer array of dimension DLEN_. This
4318* is the array descriptor for the matrix X.
4319*
4320* INCX (global input) INTEGER
4321* On entry, INCX specifies the global increment for the
4322* elements of X. Only two values of INCX are supported in
4323* this version, namely 1 and M_X. INCX must not be zero.
4324*
4325* BETA (global input) COMPLEX*16
4326* On entry, BETA specifies the scalar beta.
4327*
4328* Y (local input/local output) COMPLEX*16 array
4329* On entry, Y is an array of dimension (DESCY( M_ ),*). This
4330* array contains a local copy of the initial entire matrix PY.
4331*
4332* PY (local input) COMPLEX*16 array
4333* On entry, PY is an array of dimension (DESCY( LLD_ ),*). This
4334* array contains the local entries of the matrix PY.
4335*
4336* IY (global input) INTEGER
4337* On entry, IY specifies Y's global row index, which points to
4338* the beginning of the submatrix sub( Y ).
4339*
4340* JY (global input) INTEGER
4341* On entry, JY specifies Y's global column index, which points
4342* to the beginning of the submatrix sub( Y ).
4343*
4344* DESCY (global and local input) INTEGER array
4345* On entry, DESCY is an integer array of dimension DLEN_. This
4346* is the array descriptor for the matrix Y.
4347*
4348* INCY (global input) INTEGER
4349* On entry, INCY specifies the global increment for the
4350* elements of Y. Only two values of INCY are supported in
4351* this version, namely 1 and M_Y. INCY must not be zero.
4352*
4353* G (workspace) DOUBLE PRECISION array
4354* On entry, G is an array of dimension at least MAX( M, N ). G
4355* is used to compute the gauges.
4356*
4357* ERR (global output) DOUBLE PRECISION
4358* On exit, ERR specifies the largest error in absolute value.
4359*
4360* INFO (global output) INTEGER
4361* On exit, if INFO <> 0, the result is less than half accurate.
4362*
4363* -- Written on April 1, 1998 by
4364* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4365*
4366* =====================================================================
4367*
4368* .. Parameters ..
4369 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
4370 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
4371 $ RSRC_
4372 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
4373 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
4374 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
4375 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
4376 DOUBLE PRECISION RZERO, RONE
4377 parameter( rzero = 0.0d+0, rone = 1.0d+0 )
4378 COMPLEX*16 ZERO, ONE
4379 parameter( zero = ( 0.0d+0, 0.0d+0 ),
4380 $ one = ( 1.0d+0, 0.0d+0 ) )
4381* ..
4382* .. Local Scalars ..
4383 LOGICAL COLREP, CTRAN, ROWREP, TRAN
4384 INTEGER I, IB, ICURCOL, ICURROW, IIY, IN, IOFFA, IOFFX,
4385 $ IOFFY, IYCOL, IYROW, J, JB, JJY, JN, KK, LDA,
4386 $ LDPY, LDX, LDY, ML, MYCOL, MYROW, NL, NPCOL,
4387 $ NPROW
4388 DOUBLE PRECISION EPS, ERRI, GTMP
4389 COMPLEX*16 C, TBETA, YTMP
4390* ..
4391* .. External Subroutines ..
4392 EXTERNAL blacs_gridinfo, dgamx2d, igsum2d, pb_infog2l
4393* ..
4394* .. External Functions ..
4395 LOGICAL LSAME
4396 DOUBLE PRECISION PDLAMCH
4397 EXTERNAL lsame, pdlamch
4398* ..
4399* .. Intrinsic Functions ..
4400 INTRINSIC abs, dble, dconjg, dimag, max, min, mod, sqrt
4401* ..
4402* .. Statement Functions ..
4403 DOUBLE PRECISION ABS1
4404 abs1( c ) = abs( dble( c ) ) + abs( dimag( c ) )
4405* ..
4406* .. Executable Statements ..
4407*
4408 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
4409*
4410 eps = pdlamch( ictxt, 'eps' )
4411*
4412 IF( m.EQ.0 .OR. n.EQ.0 ) THEN
4413 tbeta = one
4414 ELSE
4415 tbeta = beta
4416 END IF
4417*
4418 tran = lsame( trans, 'T' )
4419 ctran = lsame( trans, 'C' )
4420 IF( tran.OR.ctran ) THEN
4421 ml = n
4422 nl = m
4423 ELSE
4424 ml = m
4425 nl = n
4426 END IF
4427*
4428 lda = max( 1, desca( m_ ) )
4429 ldx = max( 1, descx( m_ ) )
4430 ldy = max( 1, descy( m_ ) )
4431*
4432* Compute expected result in Y using data in A, X and Y.
4433* Compute gauges in G. This part of the computation is performed
4434* by every process in the grid.
4435*
4436 ioffy = iy + ( jy - 1 ) * ldy
4437 DO 40 i = 1, ml
4438 ytmp = zero
4439 gtmp = rzero
4440 ioffx = ix + ( jx - 1 ) * ldx
4441 IF( tran )THEN
4442 ioffa = ia + ( ja + i - 2 ) * lda
4443 DO 10 j = 1, nl
4444 ytmp = ytmp + a( ioffa ) * x( ioffx )
4445 gtmp = gtmp + abs1( a( ioffa ) ) * abs1( x( ioffx ) )
4446 ioffa = ioffa + 1
4447 ioffx = ioffx + incx
4448 10 CONTINUE
4449 ELSE IF( ctran )THEN
4450 ioffa = ia + ( ja + i - 2 ) * lda
4451 DO 20 j = 1, nl
4452 ytmp = ytmp + dconjg( a( ioffa ) ) * x( ioffx )
4453 gtmp = gtmp + abs1( a( ioffa ) ) * abs1( x( ioffx ) )
4454 ioffa = ioffa + 1
4455 ioffx = ioffx + incx
4456 20 CONTINUE
4457 ELSE
4458 ioffa = ia + i - 1 + ( ja - 1 ) * lda
4459 DO 30 j = 1, nl
4460 ytmp = ytmp + a( ioffa ) * x( ioffx )
4461 gtmp = gtmp + abs1( a( ioffa ) ) * abs1( x( ioffx ) )
4462 ioffa = ioffa + lda
4463 ioffx = ioffx + incx
4464 30 CONTINUE
4465 END IF
4466 g( i ) = abs1( alpha )*gtmp + abs1( tbeta )*abs1( y( ioffy ) )
4467 y( ioffy ) = alpha * ytmp + tbeta * y( ioffy )
4468 ioffy = ioffy + incy
4469 40 CONTINUE
4470*
4471* Compute the error ratio for this result.
4472*
4473 err = rzero
4474 info = 0
4475 ldpy = descy( lld_ )
4476 ioffy = iy + ( jy - 1 ) * ldy
4477 CALL pb_infog2l( iy, jy, descy, nprow, npcol, myrow, mycol, iiy,
4478 $ jjy, iyrow, iycol )
4479 icurrow = iyrow
4480 icurcol = iycol
4481 rowrep = ( iyrow.EQ.-1 )
4482 colrep = ( iycol.EQ.-1 )
4483*
4484 IF( incy.EQ.descy( m_ ) ) THEN
4485*
4486* sub( Y ) is a row vector
4487*
4488 jb = descy( inb_ ) - jy + 1
4489 IF( jb.LE.0 )
4490 $ jb = ( ( -jb ) / descy( nb_ ) + 1 ) * descy( nb_ ) + jb
4491 jb = min( jb, ml )
4492 jn = jy + jb - 1
4493*
4494 DO 50 j = jy, jn
4495*
4496 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
4497 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
4498 erri = abs( py( iiy+(jjy-1)*ldpy ) - y( ioffy ) ) / eps
4499 IF( g( j-jy+1 ).NE.rzero )
4500 $ erri = erri / g( j-jy+1 )
4501 err = max( err, erri )
4502 IF( err*sqrt( eps ).GE.rone )
4503 $ info = 1
4504 jjy = jjy + 1
4505 END IF
4506*
4507 ioffy = ioffy + incy
4508*
4509 50 CONTINUE
4510*
4511 icurcol = mod( icurcol+1, npcol )
4512*
4513 DO 70 j = jn+1, jy+ml-1, descy( nb_ )
4514 jb = min( jy+ml-j, descy( nb_ ) )
4515*
4516 DO 60 kk = 0, jb-1
4517*
4518 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
4519 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
4520 erri = abs( py( iiy+(jjy-1)*ldpy ) - y( ioffy ) )/eps
4521 IF( g( j+kk-jy+1 ).NE.rzero )
4522 $ erri = erri / g( j+kk-jy+1 )
4523 err = max( err, erri )
4524 IF( err*sqrt( eps ).GE.rone )
4525 $ info = 1
4526 jjy = jjy + 1
4527 END IF
4528*
4529 ioffy = ioffy + incy
4530*
4531 60 CONTINUE
4532*
4533 icurcol = mod( icurcol+1, npcol )
4534*
4535 70 CONTINUE
4536*
4537 ELSE
4538*
4539* sub( Y ) is a column vector
4540*
4541 ib = descy( imb_ ) - iy + 1
4542 IF( ib.LE.0 )
4543 $ ib = ( ( -ib ) / descy( mb_ ) + 1 ) * descy( mb_ ) + ib
4544 ib = min( ib, ml )
4545 in = iy + ib - 1
4546*
4547 DO 80 i = iy, in
4548*
4549 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
4550 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
4551 erri = abs( py( iiy+(jjy-1)*ldpy ) - y( ioffy ) ) / eps
4552 IF( g( i-iy+1 ).NE.rzero )
4553 $ erri = erri / g( i-iy+1 )
4554 err = max( err, erri )
4555 IF( err*sqrt( eps ).GE.rone )
4556 $ info = 1
4557 iiy = iiy + 1
4558 END IF
4559*
4560 ioffy = ioffy + incy
4561*
4562 80 CONTINUE
4563*
4564 icurrow = mod( icurrow+1, nprow )
4565*
4566 DO 100 i = in+1, iy+ml-1, descy( mb_ )
4567 ib = min( iy+ml-i, descy( mb_ ) )
4568*
4569 DO 90 kk = 0, ib-1
4570*
4571 IF( ( myrow.EQ.icurrow .OR. rowrep ) .AND.
4572 $ ( mycol.EQ.icurcol .OR. colrep ) ) THEN
4573 erri = abs( py( iiy+(jjy-1)*ldpy ) - y( ioffy ) )/eps
4574 IF( g( i+kk-iy+1 ).NE.rzero )
4575 $ erri = erri / g( i+kk-iy+1 )
4576 err = max( err, erri )
4577 IF( err*sqrt( eps ).GE.rone )
4578 $ info = 1
4579 iiy = iiy + 1
4580 END IF
4581*
4582 ioffy = ioffy + incy
4583*
4584 90 CONTINUE
4585*
4586 icurrow = mod( icurrow+1, nprow )
4587*
4588 100 CONTINUE
4589*
4590 END IF
4591*
4592* If INFO = 0, all results are at least half accurate.
4593*
4594 CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, mycol )
4595 CALL dgamx2d( ictxt, 'All', ' ', 1, 1, err, 1, i, j, -1, -1,
4596 $ mycol )
4597*
4598 RETURN
4599*
4600* End of PZMVCH
4601*
nl
character *2 function nl()
Definition message.F:2354

◆ pzoptee()

subroutine pzoptee ( integer ictxt,
integer nout,
external subptr,
integer scode,
character*(*) sname )

Definition at line 1 of file pzblastst.f.

2*
3* -- PBLAS test routine (version 2.0) --
4* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
5* and University of California, Berkeley.
6* April 1, 1998
7*
8* .. Scalar Arguments ..
9 INTEGER ICTXT, NOUT, SCODE
10* ..
11* .. Array Arguments ..
12 CHARACTER*(*) SNAME
13* ..
14* .. Subroutine Arguments ..
15 EXTERNAL subptr
16* ..
17*
18* Purpose
19* =======
20*
21* PZOPTEE tests whether the PBLAS respond correctly to a bad option
22* argument.
23*
24* Notes
25* =====
26*
27* A description vector is associated with each 2D block-cyclicly dis-
28* tributed matrix. This vector stores the information required to
29* establish the mapping between a matrix entry and its corresponding
30* process and memory location.
31*
32* In the following comments, the character _ should be read as
33* "of the distributed matrix". Let A be a generic term for any 2D
34* block cyclicly distributed matrix. Its description vector is DESCA:
35*
36* NOTATION STORED IN EXPLANATION
37* ---------------- --------------- ------------------------------------
38* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
39* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
40* the NPROW x NPCOL BLACS process grid
41* A is distributed over. The context
42* itself is global, but the handle
43* (the integer value) may vary.
44* M_A (global) DESCA( M_ ) The number of rows in the distribu-
45* ted matrix A, M_A >= 0.
46* N_A (global) DESCA( N_ ) The number of columns in the distri-
47* buted matrix A, N_A >= 0.
48* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
49* block of the matrix A, IMB_A > 0.
50* INB_A (global) DESCA( INB_ ) The number of columns of the upper
51* left block of the matrix A,
52* INB_A > 0.
53* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
54* bute the last M_A-IMB_A rows of A,
55* MB_A > 0.
56* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
57* bute the last N_A-INB_A columns of
58* A, NB_A > 0.
59* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
60* row of the matrix A is distributed,
61* NPROW > RSRC_A >= 0.
62* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
63* first column of A is distributed.
64* NPCOL > CSRC_A >= 0.
65* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
66* array storing the local blocks of
67* the distributed matrix A,
68* IF( Lc( 1, N_A ) > 0 )
69* LLD_A >= MAX( 1, Lr( 1, M_A ) )
70* ELSE
71* LLD_A >= 1.
72*
73* Let K be the number of rows of a matrix A starting at the global in-
74* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
75* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
76* receive if these K rows were distributed over NPROW processes. If K
77* is the number of columns of a matrix A starting at the global index
78* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
79* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
80* these K columns were distributed over NPCOL processes.
81*
82* The values of Lr() and Lc() may be determined via a call to the func-
83* tion PB_NUMROC:
84* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
85* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
86*
87* Arguments
88* =========
89*
90* ICTXT (local input) INTEGER
91* On entry, ICTXT specifies the BLACS context handle, indica-
92* ting the global context of the operation. The context itself
93* is global, but the value of ICTXT is local.
94*
95* NOUT (global input) INTEGER
96* On entry, NOUT specifies the unit number for the output file.
97* When NOUT is 6, output to screen, when NOUT is 0, output to
98* stderr. NOUT is only defined for process 0.
99*
100* SUBPTR (global input) SUBROUTINE
101* On entry, SUBPTR is a subroutine. SUBPTR must be declared
102* EXTERNAL in the calling subroutine.
103*
104* SCODE (global input) INTEGER
105* On entry, SCODE specifies the calling sequence code.
106*
107* SNAME (global input) CHARACTER*(*)
108* On entry, SNAME specifies the subroutine name calling this
109* subprogram.
110*
111* Calling sequence encodings
112* ==========================
113*
114* code Formal argument list Examples
115*
116* 11 (n, v1,v2) _SWAP, _COPY
117* 12 (n,s1, v1 ) _SCAL, _SCAL
118* 13 (n,s1, v1,v2) _AXPY, _DOT_
119* 14 (n,s1,i1,v1 ) _AMAX
120* 15 (n,u1, v1 ) _ASUM, _NRM2
121*
122* 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV
123* 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV
124* 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV
125* 24 ( m,n,s1,v1,v2,m1) _GER_
126* 25 (uplo, n,s1,v1, m1) _SYR
127* 26 (uplo, n,u1,v1, m1) _HER
128* 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2
129*
130* 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM
131* 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM
132* 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK
133* 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK
134* 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K
135* 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K
136* 37 ( m,n, s1,m1, s2,m3) _TRAN_
137* 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM
138* 39 ( trans, m,n, s1,m1, s2,m3) _GEADD
139* 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD
140*
141* -- Written on April 1, 1998 by
142* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
143*
144* =====================================================================
145*
146* .. Local Scalars ..
147 INTEGER APOS
148* ..
149* .. External Subroutines ..
150 EXTERNAL pzchkopt
151* ..
152* .. Executable Statements ..
153*
154* Level 2 PBLAS
155*
156 IF( scode.EQ.21 ) THEN
157*
158* Check 1st (and only) option
159*
160 apos = 1
161 CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'A', apos )
162*
163 ELSE IF( scode.EQ.22 .OR. scode.EQ.25 .OR. scode.EQ.26 .OR.
164 $ scode.EQ.27 ) THEN
165*
166* Check 1st (and only) option
167*
168 apos = 1
169 CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'U', apos )
170*
171 ELSE IF( scode.EQ.23 ) THEN
172*
173* Check 1st option
174*
175 apos = 1
176 CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'U', apos )
177*
178* Check 2nd option
179*
180 apos = 2
181 CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'A', apos )
182*
183* Check 3rd option
184*
185 apos = 3
186 CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'D', apos )
187*
188* Level 3 PBLAS
189*
190 ELSE IF( scode.EQ.31 ) THEN
191*
192* Check 1st option
193*
194 apos = 1
195 CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'A', apos )
196*
197* Check 2'nd option
198*
199 apos = 2
200 CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'B', apos )
201*
202 ELSE IF( scode.EQ.32 ) THEN
203*
204* Check 1st option
205*
206 apos = 1
207 CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'S', apos )
208*
209* Check 2nd option
210*
211 apos = 2
212 CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'U', apos )
213*
214 ELSE IF( scode.EQ.33 .OR. scode.EQ.34 .OR. scode.EQ.35 .OR.
215 $ scode.EQ.36 .OR. scode.EQ.40 ) THEN
216*
217* Check 1st option
218*
219 apos = 1
220 CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'U', apos )
221*
222* Check 2'nd option
223*
224 apos = 2
225 CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'A', apos )
226*
227 ELSE IF( scode.EQ.38 ) THEN
228*
229* Check 1st option
230*
231 apos = 1
232 CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'S', apos )
233*
234* Check 2nd option
235*
236 apos = 2
237 CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'U', apos )
238*
239* Check 3rd option
240*
241 apos = 3
242 CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'A', apos )
243*
244* Check 4th option
245*
246 apos = 4
247 CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'D', apos )
248*
249*
250 ELSE IF( scode.EQ.39 ) THEN
251*
252* Check 1st option
253*
254 apos = 1
255 CALL pzchkopt( ictxt, nout, subptr, scode, sname, 'A', apos )
256*
257 END IF
258*
259 RETURN
260*
261* End of PZOPTEE
262*
pzchkopt
subroutine pzchkopt(ictxt, nout, subptr, scode, sname, argnam, argpos)
Definition pzblastst.f:266

◆ pzsetpblas()

subroutine pzsetpblas ( integer ictxt)

Definition at line 1477 of file pzblastst.f.

1478*
1479* -- PBLAS test routine (version 2.0) --
1480* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
1481* and University of California, Berkeley.
1482* April 1, 1998
1483*
1484* .. Scalar Arguments ..
1485 INTEGER ICTXT
1486* ..
1487*
1488* Purpose
1489* =======
1490*
1491* PZSETPBLAS initializes *all* the dummy arguments to correct values.
1492*
1493* Notes
1494* =====
1495*
1496* A description vector is associated with each 2D block-cyclicly dis-
1497* tributed matrix. This vector stores the information required to
1498* establish the mapping between a matrix entry and its corresponding
1499* process and memory location.
1500*
1501* In the following comments, the character _ should be read as
1502* "of the distributed matrix". Let A be a generic term for any 2D
1503* block cyclicly distributed matrix. Its description vector is DESCA:
1504*
1505* NOTATION STORED IN EXPLANATION
1506* ---------------- --------------- ------------------------------------
1507* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
1508* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
1509* the NPROW x NPCOL BLACS process grid
1510* A is distributed over. The context
1511* itself is global, but the handle
1512* (the integer value) may vary.
1513* M_A (global) DESCA( M_ ) The number of rows in the distribu-
1514* ted matrix A, M_A >= 0.
1515* N_A (global) DESCA( N_ ) The number of columns in the distri-
1516* buted matrix A, N_A >= 0.
1517* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
1518* block of the matrix A, IMB_A > 0.
1519* INB_A (global) DESCA( INB_ ) The number of columns of the upper
1520* left block of the matrix A,
1521* INB_A > 0.
1522* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
1523* bute the last M_A-IMB_A rows of A,
1524* MB_A > 0.
1525* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
1526* bute the last N_A-INB_A columns of
1527* A, NB_A > 0.
1528* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
1529* row of the matrix A is distributed,
1530* NPROW > RSRC_A >= 0.
1531* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
1532* first column of A is distributed.
1533* NPCOL > CSRC_A >= 0.
1534* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
1535* array storing the local blocks of
1536* the distributed matrix A,
1537* IF( Lc( 1, N_A ) > 0 )
1538* LLD_A >= MAX( 1, Lr( 1, M_A ) )
1539* ELSE
1540* LLD_A >= 1.
1541*
1542* Let K be the number of rows of a matrix A starting at the global in-
1543* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
1544* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
1545* receive if these K rows were distributed over NPROW processes. If K
1546* is the number of columns of a matrix A starting at the global index
1547* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
1548* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
1549* these K columns were distributed over NPCOL processes.
1550*
1551* The values of Lr() and Lc() may be determined via a call to the func-
1552* tion PB_NUMROC:
1553* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
1554* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
1555*
1556* Arguments
1557* =========
1558*
1559* ICTXT (local input) INTEGER
1560* On entry, ICTXT specifies the BLACS context handle, indica-
1561* ting the global context of the operation. The context itself
1562* is global, but the value of ICTXT is local.
1563*
1564* -- Written on April 1, 1998 by
1565* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1566*
1567* =====================================================================
1568*
1569* .. Parameters ..
1570 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
1571 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
1572 $ RSRC_
1573 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
1574 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
1575 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
1576 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
1577 DOUBLE PRECISION RONE
1578 COMPLEX*16 ONE
1579 parameter( one = ( 1.0d+0, 0.0d+0 ),
1580 $ rone = 1.0d+0 )
1581* ..
1582* .. External Subroutines ..
1583 EXTERNAL pb_descset2
1584* ..
1585* .. Common Blocks ..
1586 CHARACTER*1 DIAG, SIDE, TRANSA, TRANSB, UPLO
1587 INTEGER IA, IB, IC, INCX, INCY, ISCLR, IX, IY, JA, JB,
1588 $ JC, JX, JY, KDIM, MDIM, NDIM
1589 DOUBLE PRECISION USCLR
1590 COMPLEX*16 SCLR
1591 INTEGER DESCA( DLEN_ ), DESCB( DLEN_ ), DESCC( DLEN_ ),
1592 $ DESCX( DLEN_ ), DESCY( DLEN_ )
1593 COMPLEX*16 A( 2, 2 ), B( 2, 2 ), C( 2, 2 ), X( 2 ), Y( 2 )
1594 COMMON /pblasc/diag, side, transa, transb, uplo
1595 COMMON /pblasd/desca, descb, descc, descx, descy
1596 COMMON /pblasi/ia, ib, ic, incx, incy, isclr, ix, iy,
1597 $ ja, jb, jc, jx, jy
1598 COMMON /pblasm/a, b, c
1599 COMMON /pblasn/kdim, mdim, ndim
1600 COMMON /pblass/sclr, usclr
1601 COMMON /pblasv/x, y
1602* ..
1603* .. Executable Statements ..
1604*
1605* Set default values for options
1606*
1607 diag = 'N'
1608 side = 'l'
1609 TRANSA = 'n'
1610 TRANSB = 'n'
1611 UPLO = 'u'
1612*
1613* Set default values for scalars
1614*
1615 KDIM = 1
1616 MDIM = 1
1617 NDIM = 1
1618 ISCLR = 1
1619 SCLR = ONE
1620 USCLR = RONE
1621*
1622* Set default values for distributed matrix A
1623*
1624 A( 1, 1 ) = ONE
1625 A( 2, 1 ) = ONE
1626 A( 1, 2 ) = ONE
1627 A( 2, 2 ) = ONE
1628 IA = 1
1629 JA = 1
1630 CALL PB_DESCSET2( DESCA, 2, 2, 1, 1, 1, 1, 0, 0, ICTXT, 2 )
1631*
1632* Set default values for distributed matrix B
1633*
1634 B( 1, 1 ) = ONE
1635 B( 2, 1 ) = ONE
1636 B( 1, 2 ) = ONE
1637 B( 2, 2 ) = ONE
1638 IB = 1
1639 JB = 1
1640 CALL PB_DESCSET2( DESCB, 2, 2, 1, 1, 1, 1, 0, 0, ICTXT, 2 )
1641*
1642* Set default values for distributed matrix C
1643*
1644 C( 1, 1 ) = ONE
1645 C( 2, 1 ) = ONE
1646 C( 1, 2 ) = ONE
1647 C( 2, 2 ) = ONE
1648 IC = 1
1649 JC = 1
1650 CALL PB_DESCSET2( DESCC, 2, 2, 1, 1, 1, 1, 0, 0, ICTXT, 2 )
1651*
1652* Set default values for distributed matrix X
1653*
1654 X( 1 ) = ONE
1655 X( 2 ) = ONE
1656 IX = 1
1657 JX = 1
1658 CALL PB_DESCSET2( DESCX, 2, 1, 1, 1, 1, 1, 0, 0, ICTXT, 2 )
1659 INCX = 1
1660*
1661* Set default values for distributed matrix Y
1662*
1663 Y( 1 ) = ONE
1664 Y( 2 ) = ONE
1665 IY = 1
1666 JY = 1
1667 CALL PB_DESCSET2( DESCY, 2, 1, 1, 1, 1, 1, 0, 0, ICTXT, 2 )
1668 INCY = 1
1669*
1670 RETURN
1671*
1672* End of PZSETPBLAS
1673*
pb_descset2
subroutine pb_descset2(desc, m, n, imb, inb, mb, nb, rsrc, csrc, ctxt, lld)
Definition pblastst.f:3172

◆ pzvecee()

subroutine pzvecee ( integer ictxt,
integer nout,
external subptr,
integer scode,
character*7 sname )

Definition at line 935 of file pzblastst.f.

936*
937* -- PBLAS test routine (version 2.0) --
938* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
939* and University of California, Berkeley.
940* April 1, 1998
941*
942* .. Scalar Arguments ..
943 INTEGER ICTXT, NOUT, SCODE
944* ..
945* .. Array Arguments ..
946 CHARACTER*7 SNAME
947* ..
948* .. Subroutine Arguments ..
949 EXTERNAL subptr
950* ..
951*
952* Purpose
953* =======
954*
955* PZVECEE tests whether the PBLAS respond correctly to a bad vector
956* argument. Each vector <vec> is described by: <vec>, I<vec>, J<vec>,
957* DESC<vec>, INC<vec>. Out of all these, only I<vec>, J<vec>,
958* DESC<vec>, and INC<vec> can be tested.
959*
960* Notes
961* =====
962*
963* A description vector is associated with each 2D block-cyclicly dis-
964* tributed matrix. This vector stores the information required to
965* establish the mapping between a matrix entry and its corresponding
966* process and memory location.
967*
968* In the following comments, the character _ should be read as
969* "of the distributed matrix". Let A be a generic term for any 2D
970* block cyclicly distributed matrix. Its description vector is DESCA:
971*
972* NOTATION STORED IN EXPLANATION
973* ---------------- --------------- ------------------------------------
974* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
975* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
976* the NPROW x NPCOL BLACS process grid
977* A is distributed over. The context
978* itself is global, but the handle
979* (the integer value) may vary.
980* M_A (global) DESCA( M_ ) The number of rows in the distribu-
981* ted matrix A, M_A >= 0.
982* N_A (global) DESCA( N_ ) The number of columns in the distri-
983* buted matrix A, N_A >= 0.
984* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
985* block of the matrix A, IMB_A > 0.
986* INB_A (global) DESCA( INB_ ) The number of columns of the upper
987* left block of the matrix A,
988* INB_A > 0.
989* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
990* bute the last M_A-IMB_A rows of A,
991* MB_A > 0.
992* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
993* bute the last N_A-INB_A columns of
994* A, NB_A > 0.
995* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
996* row of the matrix A is distributed,
997* NPROW > RSRC_A >= 0.
998* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
999* first column of A is distributed.
1000* NPCOL > CSRC_A >= 0.
1001* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
1002* array storing the local blocks of
1003* the distributed matrix A,
1004* IF( Lc( 1, N_A ) > 0 )
1005* LLD_A >= MAX( 1, Lr( 1, M_A ) )
1006* ELSE
1007* LLD_A >= 1.
1008*
1009* Let K be the number of rows of a matrix A starting at the global in-
1010* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
1011* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
1012* receive if these K rows were distributed over NPROW processes. If K
1013* is the number of columns of a matrix A starting at the global index
1014* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
1015* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
1016* these K columns were distributed over NPCOL processes.
1017*
1018* The values of Lr() and Lc() may be determined via a call to the func-
1019* tion PB_NUMROC:
1020* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
1021* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
1022*
1023* Arguments
1024* =========
1025*
1026* ICTXT (local input) INTEGER
1027* On entry, ICTXT specifies the BLACS context handle, indica-
1028* ting the global context of the operation. The context itself
1029* is global, but the value of ICTXT is local.
1030*
1031* NOUT (global input) INTEGER
1032* On entry, NOUT specifies the unit number for the output file.
1033* When NOUT is 6, output to screen, when NOUT is 0, output to
1034* stderr. NOUT is only defined for process 0.
1035*
1036* SUBPTR (global input) SUBROUTINE
1037* On entry, SUBPTR is a subroutine. SUBPTR must be declared
1038* EXTERNAL in the calling subroutine.
1039*
1040* SCODE (global input) INTEGER
1041* On entry, SCODE specifies the calling sequence code.
1042*
1043* SNAME (global input) CHARACTER*(*)
1044* On entry, SNAME specifies the subroutine name calling this
1045* subprogram.
1046*
1047* Calling sequence encodings
1048* ==========================
1049*
1050* code Formal argument list Examples
1051*
1052* 11 (n, v1,v2) _SWAP, _COPY
1053* 12 (n,s1, v1 ) _SCAL, _SCAL
1054* 13 (n,s1, v1,v2) _AXPY, _DOT_
1055* 14 (n,s1,i1,v1 ) _AMAX
1056* 15 (n,u1, v1 ) _ASUM, _NRM2
1057*
1058* 21 ( trans, m,n,s1,m1,v1,s2,v2) _GEMV
1059* 22 (uplo, n,s1,m1,v1,s2,v2) _SYMV, _HEMV
1060* 23 (uplo,trans,diag, n, m1,v1 ) _TRMV, _TRSV
1061* 24 ( m,n,s1,v1,v2,m1) _GER_
1062* 25 (uplo, n,s1,v1, m1) _SYR
1063* 26 (uplo, n,u1,v1, m1) _HER
1064* 27 (uplo, n,s1,v1,v2,m1) _SYR2, _HER2
1065*
1066* 31 ( transa,transb, m,n,k,s1,m1,m2,s2,m3) _GEMM
1067* 32 (side,uplo, m,n, s1,m1,m2,s2,m3) _SYMM, _HEMM
1068* 33 ( uplo,trans, n,k,s1,m1, s2,m3) _SYRK
1069* 34 ( uplo,trans, n,k,u1,m1, u2,m3) _HERK
1070* 35 ( uplo,trans, n,k,s1,m1,m2,s2,m3) _SYR2K
1071* 36 ( uplo,trans, n,k,s1,m1,m2,u2,m3) _HER2K
1072* 37 ( m,n, s1,m1, s2,m3) _TRAN_
1073* 38 (side,uplo,transa, diag,m,n, s1,m1,m2 ) _TRMM, _TRSM
1074* 39 ( trans, m,n, s1,m1, s2,m3) _GEADD
1075* 40 ( uplo,trans, m,n, s1,m1, s2,m3) _TRADD
1076*
1077* -- Written on April 1, 1998 by
1078* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
1079*
1080* =====================================================================
1081*
1082* .. Local Scalars ..
1083 INTEGER APOS
1084* ..
1085* .. External Subroutines ..
1086 EXTERNAL pzchkmat
1087* ..
1088* .. Executable Statements ..
1089*
1090* Level 1 PBLAS
1091*
1092 IF( scode.EQ.11 ) THEN
1093*
1094* Check 1st vector
1095*
1096 apos = 2
1097 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'X', apos )
1098*
1099* Check 2nd vector
1100*
1101 apos = 7
1102 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'Y', apos )
1103*
1104 ELSE IF( scode.EQ.12 .OR. scode.EQ.15 ) THEN
1105*
1106* Check 1st (and only) vector
1107*
1108 apos = 3
1109 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'X', apos )
1110*
1111 ELSE IF( scode.EQ.13 ) THEN
1112*
1113* Check 1st vector
1114*
1115 apos = 3
1116 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'X', apos )
1117*
1118* Check 2nd vector
1119*
1120 apos = 8
1121 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'Y', apos )
1122*
1123 ELSE IF( scode.EQ.14 ) THEN
1124*
1125* Check 1st (and only) vector
1126*
1127 apos = 4
1128 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'X', apos )
1129*
1130* Level 2 PBLAS
1131*
1132 ELSE IF( scode.EQ.21 ) THEN
1133*
1134* Check 1st vector
1135*
1136 apos = 9
1137 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'X', apos )
1138*
1139* Check 2nd vector
1140*
1141 apos = 15
1142 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'Y', apos )
1143*
1144 ELSE IF( scode.EQ.22 ) THEN
1145*
1146* Check 1st vector
1147*
1148 apos = 8
1149 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'X', apos )
1150*
1151* Check 2nd vector
1152*
1153 apos = 14
1154 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'Y', apos )
1155*
1156 ELSE IF( scode.EQ.23 ) THEN
1157*
1158* Check 1st (and only) vector
1159*
1160 apos = 9
1161 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'X', apos )
1162*
1163 ELSE IF( scode.EQ.24 .OR. scode.EQ.27 ) THEN
1164*
1165* Check 1st vector
1166*
1167 apos = 4
1168 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'X', apos )
1169*
1170* Check 2nd vector
1171*
1172 apos = 9
1173 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'Y', apos )
1174*
1175 ELSE IF( scode.EQ.26 .OR. scode.EQ.27 ) THEN
1176*
1177* Check 1'st (and only) vector
1178*
1179 apos = 4
1180 CALL pzchkmat( ictxt, nout, subptr, scode, sname, 'X', apos )
1181*
1182 END IF
1183*
1184 RETURN
1185*
1186* End of PZVECEE
1187*

◆ pzvmch()

subroutine pzvmch ( integer ictxt,
character*1 trans,
character*1 uplo,
integer m,
integer n,
complex*16 alpha,
complex*16, dimension( * ) x,
integer ix,
integer jx,
integer, dimension( * ) descx,
integer incx,
complex*16, dimension( * ) y,
integer iy,
integer jy,
integer, dimension( * ) descy,
integer incy,
complex*16, dimension( * ) a,
complex*16, dimension( * ) pa,
integer ia,
integer ja,
integer, dimension( * ) desca,
double precision, dimension( * ) g,
double precision err,
integer info )

Definition at line 4603 of file pzblastst.f.

4606*
4607* -- PBLAS test routine (version 2.0) --
4608* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4609* and University of California, Berkeley.
4610* April 1, 1998
4611*
4612* .. Scalar Arguments ..
4613 CHARACTER*1 TRANS, UPLO
4614 INTEGER IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
4615 $ JY, M, N
4616 DOUBLE PRECISION ERR
4617 COMPLEX*16 ALPHA
4618* ..
4619* .. Array Arguments ..
4620 INTEGER DESCA( * ), DESCX( * ), DESCY( * )
4621 DOUBLE PRECISION G( * )
4622 COMPLEX*16 A( * ), PA( * ), X( * ), Y( * )
4623* ..
4624*
4625* Purpose
4626* =======
4627*
4628* PZVMCH checks the results of the computational tests.
4629*
4630* Notes
4631* =====
4632*
4633* A description vector is associated with each 2D block-cyclicly dis-
4634* tributed matrix. This vector stores the information required to
4635* establish the mapping between a matrix entry and its corresponding
4636* process and memory location.
4637*
4638* In the following comments, the character _ should be read as
4639* "of the distributed matrix". Let A be a generic term for any 2D
4640* block cyclicly distributed matrix. Its description vector is DESCA:
4641*
4642* NOTATION STORED IN EXPLANATION
4643* ---------------- --------------- ------------------------------------
4644* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
4645* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
4646* the NPROW x NPCOL BLACS process grid
4647* A is distributed over. The context
4648* itself is global, but the handle
4649* (the integer value) may vary.
4650* M_A (global) DESCA( M_ ) The number of rows in the distribu-
4651* ted matrix A, M_A >= 0.
4652* N_A (global) DESCA( N_ ) The number of columns in the distri-
4653* buted matrix A, N_A >= 0.
4654* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
4655* block of the matrix A, IMB_A > 0.
4656* INB_A (global) DESCA( INB_ ) The number of columns of the upper
4657* left block of the matrix A,
4658* INB_A > 0.
4659* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
4660* bute the last M_A-IMB_A rows of A,
4661* MB_A > 0.
4662* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
4663* bute the last N_A-INB_A columns of
4664* A, NB_A > 0.
4665* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
4666* row of the matrix A is distributed,
4667* NPROW > RSRC_A >= 0.
4668* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
4669* first column of A is distributed.
4670* NPCOL > CSRC_A >= 0.
4671* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
4672* array storing the local blocks of
4673* the distributed matrix A,
4674* IF( Lc( 1, N_A ) > 0 )
4675* LLD_A >= MAX( 1, Lr( 1, M_A ) )
4676* ELSE
4677* LLD_A >= 1.
4678*
4679* Let K be the number of rows of a matrix A starting at the global in-
4680* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
4681* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
4682* receive if these K rows were distributed over NPROW processes. If K
4683* is the number of columns of a matrix A starting at the global index
4684* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
4685* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
4686* these K columns were distributed over NPCOL processes.
4687*
4688* The values of Lr() and Lc() may be determined via a call to the func-
4689* tion PB_NUMROC:
4690* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
4691* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
4692*
4693* Arguments
4694* =========
4695*
4696* ICTXT (local input) INTEGER
4697* On entry, ICTXT specifies the BLACS context handle, indica-
4698* ting the global context of the operation. The context itself
4699* is global, but the value of ICTXT is local.
4700*
4701* TRANS (global input) CHARACTER*1
4702* On entry, TRANS specifies the operation to be performed in
4703* the complex cases:
4704* if TRANS = 'C',
4705* sub( A ) := sub( A ) + alpha * sub( X ) * sub( Y )**H,
4706* otherwise
4707* sub( A ) := sub( A ) + alpha * sub( X ) * sub( Y )**T.
4708*
4709* UPLO (global input) CHARACTER*1
4710* On entry, UPLO specifies which part of the submatrix sub( A )
4711* is to be referenced as follows:
4712* If UPLO = 'L', only the lower triangular part,
4713* If UPLO = 'U', only the upper triangular part,
4714* else the entire matrix is to be referenced.
4715*
4716* M (global input) INTEGER
4717* On entry, M specifies the number of rows of the submatrix
4718* operand matrix A. M must be at least zero.
4719*
4720* N (global input) INTEGER
4721* On entry, N specifies the number of columns of the subma-
4722* trix operand matrix A. N must be at least zero.
4723*
4724* ALPHA (global input) COMPLEX*16
4725* On entry, ALPHA specifies the scalar alpha.
4726*
4727* X (local input) COMPLEX*16 array
4728* On entry, X is an array of dimension (DESCX( M_ ),*). This
4729* array contains a local copy of the initial entire matrix PX.
4730*
4731* IX (global input) INTEGER
4732* On entry, IX specifies X's global row index, which points to
4733* the beginning of the submatrix sub( X ).
4734*
4735* JX (global input) INTEGER
4736* On entry, JX specifies X's global column index, which points
4737* to the beginning of the submatrix sub( X ).
4738*
4739* DESCX (global and local input) INTEGER array
4740* On entry, DESCX is an integer array of dimension DLEN_. This
4741* is the array descriptor for the matrix X.
4742*
4743* INCX (global input) INTEGER
4744* On entry, INCX specifies the global increment for the
4745* elements of X. Only two values of INCX are supported in
4746* this version, namely 1 and M_X. INCX must not be zero.
4747*
4748* Y (local input) COMPLEX*16 array
4749* On entry, Y is an array of dimension (DESCY( M_ ),*). This
4750* array contains a local copy of the initial entire matrix PY.
4751*
4752* IY (global input) INTEGER
4753* On entry, IY specifies Y's global row index, which points to
4754* the beginning of the submatrix sub( Y ).
4755*
4756* JY (global input) INTEGER
4757* On entry, JY specifies Y's global column index, which points
4758* to the beginning of the submatrix sub( Y ).
4759*
4760* DESCY (global and local input) INTEGER array
4761* On entry, DESCY is an integer array of dimension DLEN_. This
4762* is the array descriptor for the matrix Y.
4763*
4764* INCY (global input) INTEGER
4765* On entry, INCY specifies the global increment for the
4766* elements of Y. Only two values of INCY are supported in
4767* this version, namely 1 and M_Y. INCY must not be zero.
4768*
4769* A (local input/local output) COMPLEX*16 array
4770* On entry, A is an array of dimension (DESCA( M_ ),*). This
4771* array contains a local copy of the initial entire matrix PA.
4772*
4773* PA (local input) COMPLEX*16 array
4774* On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
4775* array contains the local entries of the matrix PA.
4776*
4777* IA (global input) INTEGER
4778* On entry, IA specifies A's global row index, which points to
4779* the beginning of the submatrix sub( A ).
4780*
4781* JA (global input) INTEGER
4782* On entry, JA specifies A's global column index, which points
4783* to the beginning of the submatrix sub( A ).
4784*
4785* DESCA (global and local input) INTEGER array
4786* On entry, DESCA is an integer array of dimension DLEN_. This
4787* is the array descriptor for the matrix A.
4788*
4789* G (workspace) DOUBLE PRECISION array
4790* On entry, G is an array of dimension at least MAX( M, N ). G
4791* is used to compute the gauges.
4792*
4793* ERR (global output) DOUBLE PRECISION
4794* On exit, ERR specifies the largest error in absolute value.
4795*
4796* INFO (global output) INTEGER
4797* On exit, if INFO <> 0, the result is less than half accurate.
4798*
4799* -- Written on April 1, 1998 by
4800* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4801*
4802* =====================================================================
4803*
4804* .. Parameters ..
4805 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
4806 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
4807 $ RSRC_
4808 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
4809 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
4810 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
4811 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
4812 DOUBLE PRECISION ZERO, ONE
4813 parameter( zero = 0.0d+0, one = 1.0d+0 )
4814* ..
4815* .. Local Scalars ..
4816 LOGICAL COLREP, CTRAN, LOWER, ROWREP, UPPER
4817 INTEGER I, IACOL, IAROW, IB, IBEG, ICURROW, IEND, IIA,
4818 $ IN, IOFFA, IOFFX, IOFFY, J, JJA, KK, LDA, LDPA,
4819 $ LDX, LDY, MYCOL, MYROW, NPCOL, NPROW
4820 DOUBLE PRECISION EPS, ERRI, GTMP
4821 COMPLEX*16 ATMP, C
4822* ..
4823* .. External Subroutines ..
4824 EXTERNAL blacs_gridinfo, dgamx2d, igsum2d, pb_infog2l
4825* ..
4826* .. External Functions ..
4827 LOGICAL LSAME
4828 DOUBLE PRECISION PDLAMCH
4829 EXTERNAL lsame, pdlamch
4830* ..
4831* .. Intrinsic Functions ..
4832 INTRINSIC abs, dble, dconjg, dimag, max, min, mod, sqrt
4833* ..
4834* .. Statement Functions ..
4835 DOUBLE PRECISION ABS1
4836 abs1( c ) = abs( dble( c ) ) + abs( dimag( c ) )
4837* ..
4838* .. Executable Statements ..
4839*
4840 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
4841*
4842 eps = pdlamch( ictxt, 'eps' )
4843*
4844 ctran = lsame( trans, 'C' )
4845 upper = lsame( uplo, 'U' )
4846 lower = lsame( uplo, 'L' )
4847*
4848 lda = max( 1, desca( m_ ) )
4849 ldx = max( 1, descx( m_ ) )
4850 ldy = max( 1, descy( m_ ) )
4851*
4852* Compute expected result in A using data in A, X and Y.
4853* Compute gauges in G. This part of the computation is performed
4854* by every process in the grid.
4855*
4856 DO 70 j = 1, n
4857*
4858 ioffy = iy + ( jy - 1 ) * ldy + ( j - 1 ) * incy
4859*
4860 IF( lower ) THEN
4861 ibeg = j
4862 iend = m
4863 DO 10 i = 1, j-1
4864 g( i ) = zero
4865 10 CONTINUE
4866 ELSE IF( upper ) THEN
4867 ibeg = 1
4868 iend = j
4869 DO 20 i = j+1, m
4870 g( i ) = zero
4871 20 CONTINUE
4872 ELSE
4873 ibeg = 1
4874 iend = m
4875 END IF
4876*
4877 DO 30 i = ibeg, iend
4878*
4879 ioffx = ix + ( jx - 1 ) * ldx + ( i - 1 ) * incx
4880 ioffa = ia + i - 1 + ( ja + j - 2 ) * lda
4881 IF( ctran ) THEN
4882 atmp = x( ioffx ) * dconjg( y( ioffy ) )
4883 ELSE
4884 atmp = x( ioffx ) * y( ioffy )
4885 END IF
4886 gtmp = abs1( x( ioffx ) ) * abs1( y( ioffy ) )
4887 g( i ) = abs1( alpha ) * gtmp + abs1( a( ioffa ) )
4888 a( ioffa ) = alpha * atmp + a( ioffa )
4889*
4890 30 CONTINUE
4891*
4892* Compute the error ratio for this result.
4893*
4894 info = 0
4895 err = zero
4896 ldpa = desca( lld_ )
4897 ioffa = ia + ( ja + j - 2 ) * lda
4898 CALL pb_infog2l( ia, ja+j-1, desca, nprow, npcol, myrow, mycol,
4899 $ iia, jja, iarow, iacol )
4900 rowrep = ( iarow.EQ.-1 )
4901 colrep = ( iacol.EQ.-1 )
4902*
4903 IF( mycol.EQ.iacol .OR. colrep ) THEN
4904*
4905 icurrow = iarow
4906 ib = desca( imb_ ) - ia + 1
4907 IF( ib.LE.0 )
4908 $ ib = ( ( -ib ) / desca( mb_ ) + 1 ) * desca( mb_ ) + ib
4909 ib = min( ib, m )
4910 in = ia + ib - 1
4911*
4912 DO 40 i = ia, in
4913*
4914 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
4915 erri = abs( pa( iia+(jja-1)*ldpa ) - a( ioffa ) )/eps
4916 IF( g( i-ia+1 ).NE.zero )
4917 $ erri = erri / g( i-ia+1 )
4918 err = max( err, erri )
4919 IF( err*sqrt( eps ).GE.one )
4920 $ info = 1
4921 iia = iia + 1
4922 END IF
4923*
4924 ioffa = ioffa + 1
4925*
4926 40 CONTINUE
4927*
4928 icurrow = mod( icurrow+1, nprow )
4929*
4930 DO 60 i = in+1, ia+m-1, desca( mb_ )
4931 ib = min( ia+m-i, desca( mb_ ) )
4932*
4933 DO 50 kk = 0, ib-1
4934*
4935 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
4936 erri = abs( pa( iia+(jja-1)*ldpa )-a( ioffa ) )/eps
4937 IF( g( i+kk-ia+1 ).NE.zero )
4938 $ erri = erri / g( i+kk-ia+1 )
4939 err = max( err, erri )
4940 IF( err*sqrt( eps ).GE.one )
4941 $ info = 1
4942 iia = iia + 1
4943 END IF
4944*
4945 ioffa = ioffa + 1
4946*
4947 50 CONTINUE
4948*
4949 icurrow = mod( icurrow+1, nprow )
4950*
4951 60 CONTINUE
4952*
4953 END IF
4954*
4955* If INFO = 0, all results are at least half accurate.
4956*
4957 CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, mycol )
4958 CALL dgamx2d( ictxt, 'All', ' ', 1, 1, err, 1, i, j, -1, -1,
4959 $ mycol )
4960 IF( info.NE.0 )
4961 $ GO TO 80
4962*
4963 70 CONTINUE
4964*
4965 80 CONTINUE
4966*
4967 RETURN
4968*
4969* End of PZVMCH
4970*

◆ pzvmch2()

subroutine pzvmch2 ( integer ictxt,
character*1 uplo,
integer m,
integer n,
complex*16 alpha,
complex*16, dimension( * ) x,
integer ix,
integer jx,
integer, dimension( * ) descx,
integer incx,
complex*16, dimension( * ) y,
integer iy,
integer jy,
integer, dimension( * ) descy,
integer incy,
complex*16, dimension( * ) a,
complex*16, dimension( * ) pa,
integer ia,
integer ja,
integer, dimension( * ) desca,
double precision, dimension( * ) g,
double precision err,
integer info )

Definition at line 4972 of file pzblastst.f.

4975*
4976* -- PBLAS test routine (version 2.0) --
4977* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4978* and University of California, Berkeley.
4979* April 1, 1998
4980*
4981* .. Scalar Arguments ..
4982 CHARACTER*1 UPLO
4983 INTEGER IA, ICTXT, INCX, INCY, INFO, IX, IY, JA, JX,
4984 $ JY, M, N
4985 DOUBLE PRECISION ERR
4986 COMPLEX*16 ALPHA
4987* ..
4988* .. Array Arguments ..
4989 INTEGER DESCA( * ), DESCX( * ), DESCY( * )
4990 DOUBLE PRECISION G( * )
4991 COMPLEX*16 A( * ), PA( * ), X( * ), Y( * )
4992* ..
4993*
4994* Purpose
4995* =======
4996*
4997* PZVMCH2 checks the results of the computational tests.
4998*
4999* Notes
5000* =====
5001*
5002* A description vector is associated with each 2D block-cyclicly dis-
5003* tributed matrix. This vector stores the information required to
5004* establish the mapping between a matrix entry and its corresponding
5005* process and memory location.
5006*
5007* In the following comments, the character _ should be read as
5008* "of the distributed matrix". Let A be a generic term for any 2D
5009* block cyclicly distributed matrix. Its description vector is DESCA:
5010*
5011* NOTATION STORED IN EXPLANATION
5012* ---------------- --------------- ------------------------------------
5013* DTYPE_A (global) DESCA( DTYPE_ ) The descriptor type.
5014* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
5015* the NPROW x NPCOL BLACS process grid
5016* A is distributed over. The context
5017* itself is global, but the handle
5018* (the integer value) may vary.
5019* M_A (global) DESCA( M_ ) The number of rows in the distribu-
5020* ted matrix A, M_A >= 0.
5021* N_A (global) DESCA( N_ ) The number of columns in the distri-
5022* buted matrix A, N_A >= 0.
5023* IMB_A (global) DESCA( IMB_ ) The number of rows of the upper left
5024* block of the matrix A, IMB_A > 0.
5025* INB_A (global) DESCA( INB_ ) The number of columns of the upper
5026* left block of the matrix A,
5027* INB_A > 0.
5028* MB_A (global) DESCA( MB_ ) The blocking factor used to distri-
5029* bute the last M_A-IMB_A rows of A,
5030* MB_A > 0.
5031* NB_A (global) DESCA( NB_ ) The blocking factor used to distri-
5032* bute the last N_A-INB_A columns of
5033* A, NB_A > 0.
5034* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
5035* row of the matrix A is distributed,
5036* NPROW > RSRC_A >= 0.
5037* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
5038* first column of A is distributed.
5039* NPCOL > CSRC_A >= 0.
5040* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
5041* array storing the local blocks of
5042* the distributed matrix A,
5043* IF( Lc( 1, N_A ) > 0 )
5044* LLD_A >= MAX( 1, Lr( 1, M_A ) )
5045* ELSE
5046* LLD_A >= 1.
5047*
5048* Let K be the number of rows of a matrix A starting at the global in-
5049* dex IA,i.e, A( IA:IA+K-1, : ). Lr( IA, K ) denotes the number of rows
5050* that the process of row coordinate MYROW ( 0 <= MYROW < NPROW ) would
5051* receive if these K rows were distributed over NPROW processes. If K
5052* is the number of columns of a matrix A starting at the global index
5053* JA, i.e, A( :, JA:JA+K-1, : ), Lc( JA, K ) denotes the number of co-
5054* lumns that the process MYCOL ( 0 <= MYCOL < NPCOL ) would receive if
5055* these K columns were distributed over NPCOL processes.
5056*
5057* The values of Lr() and Lc() may be determined via a call to the func-
5058* tion PB_NUMROC:
5059* Lr( IA, K ) = PB_NUMROC( K, IA, IMB_A, MB_A, MYROW, RSRC_A, NPROW )
5060* Lc( JA, K ) = PB_NUMROC( K, JA, INB_A, NB_A, MYCOL, CSRC_A, NPCOL )
5061*
5062* Arguments
5063* =========
5064*
5065* ICTXT (local input) INTEGER
5066* On entry, ICTXT specifies the BLACS context handle, indica-
5067* ting the global context of the operation. The context itself
5068* is global, but the value of ICTXT is local.
5069*
5070* UPLO (global input) CHARACTER*1
5071* On entry, UPLO specifies which part of the submatrix sub( A )
5072* is to be referenced as follows:
5073* If UPLO = 'L', only the lower triangular part,
5074* If UPLO = 'U', only the upper triangular part,
5075* else the entire matrix is to be referenced.
5076*
5077* M (global input) INTEGER
5078* On entry, M specifies the number of rows of the submatrix
5079* operand matrix A. M must be at least zero.
5080*
5081* N (global input) INTEGER
5082* On entry, N specifies the number of columns of the subma-
5083* trix operand matrix A. N must be at least zero.
5084*
5085* ALPHA (global input) COMPLEX*16
5086* On entry, ALPHA specifies the scalar alpha.
5087*
5088* X (local input) COMPLEX*16 array
5089* On entry, X is an array of dimension (DESCX( M_ ),*). This
5090* array contains a local copy of the initial entire matrix PX.
5091*
5092* IX (global input) INTEGER
5093* On entry, IX specifies X's global row index, which points to
5094* the beginning of the submatrix sub( X ).
5095*
5096* JX (global input) INTEGER
5097* On entry, JX specifies X's global column index, which points
5098* to the beginning of the submatrix sub( X ).
5099*
5100* DESCX (global and local input) INTEGER array
5101* On entry, DESCX is an integer array of dimension DLEN_. This
5102* is the array descriptor for the matrix X.
5103*
5104* INCX (global input) INTEGER
5105* On entry, INCX specifies the global increment for the
5106* elements of X. Only two values of INCX are supported in
5107* this version, namely 1 and M_X. INCX must not be zero.
5108*
5109* Y (local input) COMPLEX*16 array
5110* On entry, Y is an array of dimension (DESCY( M_ ),*). This
5111* array contains a local copy of the initial entire matrix PY.
5112*
5113* IY (global input) INTEGER
5114* On entry, IY specifies Y's global row index, which points to
5115* the beginning of the submatrix sub( Y ).
5116*
5117* JY (global input) INTEGER
5118* On entry, JY specifies Y's global column index, which points
5119* to the beginning of the submatrix sub( Y ).
5120*
5121* DESCY (global and local input) INTEGER array
5122* On entry, DESCY is an integer array of dimension DLEN_. This
5123* is the array descriptor for the matrix Y.
5124*
5125* INCY (global input) INTEGER
5126* On entry, INCY specifies the global increment for the
5127* elements of Y. Only two values of INCY are supported in
5128* this version, namely 1 and M_Y. INCY must not be zero.
5129*
5130* A (local input/local output) COMPLEX*16 array
5131* On entry, A is an array of dimension (DESCA( M_ ),*). This
5132* array contains a local copy of the initial entire matrix PA.
5133*
5134* PA (local input) COMPLEX*16 array
5135* On entry, PA is an array of dimension (DESCA( LLD_ ),*). This
5136* array contains the local entries of the matrix PA.
5137*
5138* IA (global input) INTEGER
5139* On entry, IA specifies A's global row index, which points to
5140* the beginning of the submatrix sub( A ).
5141*
5142* JA (global input) INTEGER
5143* On entry, JA specifies A's global column index, which points
5144* to the beginning of the submatrix sub( A ).
5145*
5146* DESCA (global and local input) INTEGER array
5147* On entry, DESCA is an integer array of dimension DLEN_. This
5148* is the array descriptor for the matrix A.
5149*
5150* G (workspace) DOUBLE PRECISION array
5151* On entry, G is an array of dimension at least MAX( M, N ). G
5152* is used to compute the gauges.
5153*
5154* ERR (global output) DOUBLE PRECISION
5155* On exit, ERR specifies the largest error in absolute value.
5156*
5157* INFO (global output) INTEGER
5158* On exit, if INFO <> 0, the result is less than half accurate.
5159*
5160* -- Written on April 1, 1998 by
5161* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
5162*
5163* =====================================================================
5164*
5165* .. Parameters ..
5166 INTEGER BLOCK_CYCLIC_2D_INB, CSRC_, CTXT_, DLEN_,
5167 $ DTYPE_, IMB_, INB_, LLD_, MB_, M_, NB_, N_,
5168 $ RSRC_
5169 parameter( block_cyclic_2d_inb = 2, dlen_ = 11,
5170 $ dtype_ = 1, ctxt_ = 2, m_ = 3, n_ = 4,
5171 $ imb_ = 5, inb_ = 6, mb_ = 7, nb_ = 8,
5172 $ rsrc_ = 9, csrc_ = 10, lld_ = 11 )
5173 DOUBLE PRECISION ZERO, ONE
5174 parameter( zero = 0.0d+0, one = 1.0d+0 )
5175* ..
5176* .. Local Scalars ..
5177 LOGICAL COLREP, LOWER, ROWREP, UPPER
5178 INTEGER I, IACOL, IAROW, IB, IBEG, ICURROW, IEND, IIA,
5179 $ IN, IOFFA, IOFFXI, IOFFXJ, IOFFYI, IOFFYJ, J,
5180 $ JJA, KK, LDA, LDPA, LDX, LDY, MYCOL, MYROW,
5181 $ NPCOL, NPROW
5182 DOUBLE PRECISION EPS, ERRI, GTMP
5183 COMPLEX*16 C, ATMP
5184* ..
5185* .. External Subroutines ..
5186 EXTERNAL blacs_gridinfo, dgamx2d, igsum2d, pb_infog2l
5187* ..
5188* .. External Functions ..
5189 LOGICAL LSAME
5190 DOUBLE PRECISION PDLAMCH
5191 EXTERNAL lsame, pdlamch
5192* ..
5193* .. Intrinsic Functions ..
5194 INTRINSIC abs, dble, dconjg, dimag, max, min, mod, sqrt
5195* ..
5196* .. Statement Functions ..
5197 DOUBLE PRECISION ABS1
5198 abs1( c ) = abs( dble( c ) ) + abs( dimag( c ) )
5199* ..
5200* .. Executable Statements ..
5201*
5202 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
5203*
5204 eps = pdlamch( ictxt, 'eps' )
5205*
5206 upper = lsame( uplo, 'U' )
5207 lower = lsame( uplo, 'L' )
5208*
5209 lda = max( 1, desca( m_ ) )
5210 ldx = max( 1, descx( m_ ) )
5211 ldy = max( 1, descy( m_ ) )
5212*
5213* Compute expected result in A using data in A, X and Y.
5214* Compute gauges in G. This part of the computation is performed
5215* by every process in the grid.
5216*
5217 DO 70 j = 1, n
5218*
5219 ioffxj = ix + ( jx - 1 ) * ldx + ( j - 1 ) * incx
5220 ioffyj = iy + ( jy - 1 ) * ldy + ( j - 1 ) * incy
5221*
5222 IF( lower ) THEN
5223 ibeg = j
5224 iend = m
5225 DO 10 i = 1, j-1
5226 g( i ) = zero
5227 10 CONTINUE
5228 ELSE IF( upper ) THEN
5229 ibeg = 1
5230 iend = j
5231 DO 20 i = j+1, m
5232 g( i ) = zero
5233 20 CONTINUE
5234 ELSE
5235 ibeg = 1
5236 iend = m
5237 END IF
5238*
5239 DO 30 i = ibeg, iend
5240 ioffa = ia + i - 1 + ( ja + j - 2 ) * lda
5241 ioffxi = ix + ( jx - 1 ) * ldx + ( i - 1 ) * incx
5242 ioffyi = iy + ( jy - 1 ) * ldy + ( i - 1 ) * incy
5243 atmp = alpha * x( ioffxi ) * dconjg( y( ioffyj ) )
5244 atmp = atmp + y( ioffyi ) * dconjg( alpha * x( ioffxj ) )
5245 gtmp = abs1( alpha * x( ioffxi ) ) * abs1( y( ioffyj ) )
5246 gtmp = gtmp + abs1( y( ioffyi ) ) *
5247 $ abs1( dconjg( alpha * x( ioffxj ) ) )
5248 g( i ) = gtmp + abs1( a( ioffa ) )
5249 a( ioffa ) = a( ioffa ) + atmp
5250*
5251 30 CONTINUE
5252*
5253* Compute the error ratio for this result.
5254*
5255 info = 0
5256 err = zero
5257 ldpa = desca( lld_ )
5258 ioffa = ia + ( ja + j - 2 ) * lda
5259 CALL pb_infog2l( ia, ja+j-1, desca, nprow, npcol, myrow, mycol,
5260 $ iia, jja, iarow, iacol )
5261 rowrep = ( iarow.EQ.-1 )
5262 colrep = ( iacol.EQ.-1 )
5263*
5264 IF( mycol.EQ.iacol .OR. colrep ) THEN
5265*
5266 icurrow = iarow
5267 ib = desca( imb_ ) - ia + 1
5268 IF( ib.LE.0 )
5269 $ ib = ( ( -ib ) / desca( mb_ ) + 1 ) * desca( mb_ ) + ib
5270 ib = min( ib, m )
5271 in = ia + ib - 1
5272*
5273 DO 40 i = ia, in
5274*
5275 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
5276 erri = abs( pa( iia+(jja-1)*ldpa ) - a( ioffa ) )/eps
5277 IF( g( i-ia+1 ).NE.zero )
5278 $ erri = erri / g( i-ia+1 )
5279 err = max( err, erri )
5280 IF( err*sqrt( eps ).GE.one )
5281 $ info = 1
5282 iia = iia + 1
5283 END IF
5284*
5285 ioffa = ioffa + 1
5286*
5287 40 CONTINUE
5288*
5289 icurrow = mod( icurrow+1, nprow )
5290*
5291 DO 60 i = in+1, ia+m-1, desca( mb_ )
5292 ib = min( ia+m-i, desca( mb_ ) )
5293*
5294 DO 50 kk = 0, ib-1
5295*
5296 IF( myrow.EQ.icurrow .OR. rowrep ) THEN
5297 erri = abs( pa( iia+(jja-1)*ldpa )-a( ioffa ) )/eps
5298 IF( g( i+kk-ia+1 ).NE.zero )
5299 $ erri = erri / g( i+kk-ia+1 )
5300 err = max( err, erri )
5301 IF( err*sqrt( eps ).GE.one )
5302 $ info = 1
5303 iia = iia + 1
5304 END IF
5305*
5306 ioffa = ioffa + 1
5307*
5308 50 CONTINUE
5309*
5310 icurrow = mod( icurrow+1, nprow )
5311*
5312 60 CONTINUE
5313*
5314 END IF
5315*
5316* If INFO = 0, all results are at least half accurate.
5317*
5318 CALL igsum2d( ictxt, 'All', ' ', 1, 1, info, 1, -1, mycol )
5319 CALL dgamx2d( ictxt, 'All', ' ', 1, 1, err, 1, i, j, -1, -1,
5320 $ mycol )
5321 IF( info.NE.0 )
5322 $ GO TO 80
5323*
5324 70 CONTINUE
5325*
5326 80 CONTINUE
5327*
5328 RETURN
5329*
5330* End of PZVMCH2
5331*

◆ pzvprnt()

subroutine pzvprnt ( integer ictxt,
integer nout,
integer n,
complex*16, dimension( * ) x,
integer incx,
integer irprnt,
integer icprnt,
character*(*) cvecnm )

Definition at line 4065 of file pzblastst.f.

4067*
4068* -- PBLAS test routine (version 2.0) --
4069* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
4070* and University of California, Berkeley.
4071* April 1, 1998
4072*
4073* .. Scalar Arguments ..
4074 INTEGER ICPRNT, ICTXT, INCX, IRPRNT, N, NOUT
4075* ..
4076* .. Array Arguments ..
4077 CHARACTER*(*) CVECNM
4078 COMPLEX*16 X( * )
4079* ..
4080*
4081* Purpose
4082* =======
4083*
4084* PZVPRNT prints to the standard output an vector x of length n. Only
4085* the process of coordinates ( IRPRNT, ICPRNT ) is printing.
4086*
4087* Arguments
4088* =========
4089*
4090* ICTXT (local input) INTEGER
4091* On entry, ICTXT specifies the BLACS context handle, indica-
4092* ting the global context of the operation. The context itself
4093* is global, but the value of ICTXT is local.
4094*
4095* NOUT (global input) INTEGER
4096* On entry, NOUT specifies the unit number for the output file.
4097* When NOUT is 6, output to screen, when NOUT is 0, output to
4098* stderr. NOUT is only defined for process 0.
4099*
4100* N (global input) INTEGER
4101* On entry, N specifies the length of the vector X. N must be
4102* at least zero.
4103*
4104* X (global input) COMPLEX*16 array
4105* On entry, X is an array of dimension at least
4106* ( 1 + ( n - 1 )*abs( INCX ) ). Before entry, the incremen-
4107* ted array X must contain the vector x.
4108*
4109* INCX (global input) INTEGER.
4110* On entry, INCX specifies the increment for the elements of X.
4111* INCX must not be zero.
4112*
4113* IRPRNT (global input) INTEGER
4114* On entry, IRPRNT specifies the process row coordinate of the
4115* printing process.
4116*
4117* ICPRNT (global input) INTEGER
4118* On entry, ICPRNT specifies the process column coordinate of
4119* the printing process.
4120*
4121* CVECNM (global input) CHARACTER*(*)
4122* On entry, CVECNM specifies the identifier of the vector to be
4123* printed.
4124*
4125* -- Written on April 1, 1998 by
4126* Antoine Petitet, University of Tennessee, Knoxville 37996, USA.
4127*
4128* =====================================================================
4129*
4130* .. Local Scalars ..
4131 INTEGER I, MYCOL, MYROW, NPCOL, NPROW
4132* ..
4133* .. External Subroutines ..
4134 EXTERNAL blacs_gridinfo
4135* ..
4136* .. Intrinsic Functions ..
4137 INTRINSIC dble, dimag
4138* ..
4139* .. Executable Statements ..
4140*
4141* Quick return if possible
4142*
4143 IF( n.LE.0 )
4144 $ RETURN
4145*
4146* Get grid parameters
4147*
4148 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
4149*
4150 IF( myrow.EQ.irprnt .AND. mycol.EQ.icprnt ) THEN
4151*
4152 WRITE( nout, fmt = * )
4153 DO 10 i = 1, 1 + ( n-1 )*incx, incx
4154*
4155 WRITE( nout, fmt = 9999 ) cvecnm, i, dble( x( i ) ),
4156 $ dimag( x( i ) )
4157*
4158 10 CONTINUE
4159*
4160 END IF
4161*
4162 9999 FORMAT( 1x, a, '(', i6, ')=', d30.18, '+i*(', d30.18, ')' )
4163*
4164 RETURN
4165*
4166* End of PZVPRNT
4167*