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

◆ pb_pclaprn2()

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

Definition at line 9514 of file pcblastst.f.

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