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

◆ 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*
pb_infog2l
subroutine pb_infog2l(i, j, desc, nprow, npcol, myrow, mycol, ii, jj, prow, pcol)
Definition pblastst.f:1673
max
#define max(A, B)
Definition pcgemr.c:180
min
#define min(A, B)
Definition pcgemr.c:181
Here is the call graph for this function: