pslaedz.f

Go to the documentation of this file.

      SUBROUTINE pslaedz( N, N1, ID, Q, IQ, JQ, LDQ, DESCQ, Z, WORK )
*
*  -- ScaLAPACK auxiliary routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     December 31, 1998
*
*     .. Scalar Arguments ..
      INTEGER            ID, IQ, JQ, LDQ, N, N1
*     ..
*     .. Array Arguments ..
      INTEGER            DESCQ( * )
      REAL               Q( LDQ, * ), WORK( * ), Z( * )
*     ..
*
*  Purpose
*  =======
*
*  PSLAEDZ Form the z-vector which consists of the last row of Q_1
*  and the first row of Q_2.
*  =====================================================================
*
*     .. Parameters ..
*
      INTEGER            BLOCK_CYCLIC_2D, DLEN_, DTYPE_, CTXT_, M_, N_,
     $                   MB_, NB_, RSRC_, CSRC_, LLD_
      parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
     $                   ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
     $                   rsrc_ = 7, csrc_ = 8, lld_ = 9 )
*     ..
*     .. Local Scalars ..
*
      INTEGER            COL, I, IBUF, ICTXT, IIQ, IIZ1, IIZ2, IQCOL,
     $                   IQROW, IZ, IZ1, IZ1COL, IZ1ROW, IZ2, IZ2COL,
     $                   IZ2ROW, J, JJQ, JJZ1, JJZ2, MYCOL, MYROW, N2,
     $                   NB, NBLOC, NPCOL, NPROW, NQ1, NQ2, ZSIZ
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          min, mod
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_gridinfo, infog2l, scopy, sgebr2d,
     $                   sgebs2d, sgerv2d, sgesd2d
*     ..
*     .. External Functions ..
      INTEGER            NUMROC
      EXTERNAL           numroc
*     ..
*     .. Executable Statements ..
*
*       This is just to keep ftnchek and toolpack/1 happy
      IF( block_cyclic_2d*csrc_*ctxt_*dlen_*dtype_*lld_*mb_*m_*nb_*n_*
     $    rsrc_.LT.0 )RETURN
*
      ictxt = descq( ctxt_ )
      nb = descq( nb_ )
      CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
      CALL infog2l( id, id, descq, nprow, npcol, myrow, mycol, iiq, jjq,
     $              iqrow, iqcol )
      n2 = n - n1
*
*     Form z1 which consist of the last row of Q1
*
      CALL infog2l( iq-1+( id+n1-1 ), jq-1+id, descq, nprow, npcol,
     $              myrow, mycol, iiz1, jjz1, iz1row, iz1col )
      nq1 = numroc( n1, nb, mycol, iz1col, npcol )
      IF( ( myrow.EQ.iz1row ) .AND. ( nq1.NE.0 ) ) THEN
         CALL scopy( nq1, q( iiz1, jjz1 ), ldq, work, 1 )
         IF( myrow.NE.iqrow .OR. mycol.NE.iqcol )
     $      CALL sgesd2d( ictxt, nq1, 1, work, nq1, iqrow, iqcol )
      END IF
*
*     Proc (IQROW, IQCOL) receive the parts of z1
*
      IF( myrow.EQ.iqrow .AND. mycol.EQ.iqcol ) THEN
         col = iz1col
         DO 20 i = 0, npcol - 1
            nq1 = numroc( n1, nb, col, iz1col, npcol )
            IF( nq1.GT.0 ) THEN
               IF( iz1row.NE.iqrow .OR. col.NE.iqcol ) THEN
                  ibuf = n1 + 1
                  CALL sgerv2d( ictxt, nq1, 1, work( ibuf ), nq1,
     $                          iz1row, col )
               ELSE
                  ibuf = 1
               END IF
               iz1 = 0
               iz = i*nb + 1
               nbloc = ( nq1-1 ) / nb + 1
               DO 10 j = 1, nbloc
                  zsiz = min( nb, nq1-iz1 )
                  CALL scopy( zsiz, work( ibuf+iz1 ), 1, z( iz ), 1 )
                  iz1 = iz1 + nb
                  iz = iz + nb*npcol
   10          CONTINUE
            END IF
            col = mod( col+1, npcol )
   20    CONTINUE
      END IF
*
*     Form z2 which consist of the first row of Q2
*
      CALL infog2l( iq-1+( id+n1 ), jq-1+( id+n1 ), descq, nprow, npcol,
     $              myrow, mycol, iiz2, jjz2, iz2row, iz2col )
      nq2 = numroc( n2, nb, mycol, iz2col, npcol )
      IF( ( myrow.EQ.iz2row ) .AND. ( nq2.NE.0 ) ) THEN
         CALL scopy( nq2, q( iiz2, jjz2 ), ldq, work, 1 )
         IF( myrow.NE.iqrow .OR. mycol.NE.iqcol )
     $      CALL sgesd2d( ictxt, nq2, 1, work, nq2, iqrow, iqcol )
      END IF
*
*     Proc (IQROW, IQCOL) receive the parts of z2
*
      IF( myrow.EQ.iqrow .AND. mycol.EQ.iqcol ) THEN
         col = iz2col
         DO 40 i = 0, npcol - 1
            nq2 = numroc( n2, nb, col, iz2col, npcol )
            IF( nq2.GT.0 ) THEN
               IF( iqrow.NE.iz2row .OR. iqcol.NE.col ) THEN
                  ibuf = 1 + n2
                  CALL sgerv2d( ictxt, nq2, 1, work( ibuf ), nq2,
     $                          iz2row, col )
               ELSE
                  ibuf = 1
               END IF
               iz2 = 0
               iz = nb*i + n1 + 1
               nbloc = ( nq2-1 ) / nb + 1
               DO 30 j = 1, nbloc
                  zsiz = min( nb, nq2-iz2 )
                  CALL scopy( zsiz, work( ibuf+iz2 ), 1, z( iz ), 1 )
                  iz2 = iz2 + nb
                  iz = iz + nb*npcol
   30          CONTINUE
            END IF
            col = mod( col+1, npcol )
   40    CONTINUE
      END IF
*
*     proc(IQROW,IQCOL) broadcast Z=(Z1,Z2)
*
      IF( myrow.EQ.iqrow .AND. mycol.EQ.iqcol ) THEN
         CALL sgebs2d( ictxt, 'All', ' ', n, 1, z, n )
      ELSE
         CALL sgebr2d( ictxt, 'All', ' ', n, 1, z, n, iqrow, iqcol )
      END IF
*
      RETURN
*
*     End of PSLAEDZ
*
*
      END