ScaLAPACK  2.0.2
ScaLAPACK: Scalable Linear Algebra PACKage
pslaedz.f
Go to the documentation of this file.
00001       SUBROUTINE PSLAEDZ( N, N1, ID, Q, IQ, JQ, LDQ, DESCQ, Z, WORK )
00002 *
00003 *  -- ScaLAPACK auxiliary routine (version 1.7) --
00004 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
00005 *     and University of California, Berkeley.
00006 *     December 31, 1998
00007 *
00008 *     .. Scalar Arguments ..
00009       INTEGER            ID, IQ, JQ, LDQ, N, N1
00010 *     ..
00011 *     .. Array Arguments ..
00012       INTEGER            DESCQ( * )
00013       REAL               Q( LDQ, * ), WORK( * ), Z( * )
00014 *     ..
00015 *
00016 *  Purpose
00017 *  =======
00018 *
00019 *  PSLAEDZ Form the z-vector which consists of the last row of Q_1
00020 *  and the first row of Q_2.
00021 *  =====================================================================
00022 *
00023 *     .. Parameters ..
00024 *
00025       INTEGER            BLOCK_CYCLIC_2D, DLEN_, DTYPE_, CTXT_, M_, N_,
00026      $                   MB_, NB_, RSRC_, CSRC_, LLD_
00027       PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
00028      $                   CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
00029      $                   RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
00030 *     ..
00031 *     .. Local Scalars ..
00032 *
00033       INTEGER            COL, I, IBUF, ICTXT, IIQ, IIZ1, IIZ2, IQCOL,
00034      $                   IQROW, IZ, IZ1, IZ1COL, IZ1ROW, IZ2, IZ2COL,
00035      $                   IZ2ROW, J, JJQ, JJZ1, JJZ2, MYCOL, MYROW, N2,
00036      $                   NB, NBLOC, NPCOL, NPROW, NQ1, NQ2, ZSIZ
00037 *     ..
00038 *     .. Intrinsic Functions ..
00039       INTRINSIC          MIN, MOD
00040 *     ..
00041 *     .. External Subroutines ..
00042       EXTERNAL           BLACS_GRIDINFO, INFOG2L, SCOPY, SGEBR2D,
00043      $                   SGEBS2D, SGERV2D, SGESD2D
00044 *     ..
00045 *     .. External Functions ..
00046       INTEGER            NUMROC
00047       EXTERNAL           NUMROC
00048 *     ..
00049 *     .. Executable Statements ..
00050 *
00051 *       This is just to keep ftnchek and toolpack/1 happy
00052       IF( BLOCK_CYCLIC_2D*CSRC_*CTXT_*DLEN_*DTYPE_*LLD_*MB_*M_*NB_*N_*
00053      $    RSRC_.LT.0 )RETURN
00054 *
00055       ICTXT = DESCQ( CTXT_ )
00056       NB = DESCQ( NB_ )
00057       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
00058       CALL INFOG2L( ID, ID, DESCQ, NPROW, NPCOL, MYROW, MYCOL, IIQ, JJQ,
00059      $              IQROW, IQCOL )
00060       N2 = N - N1
00061 *
00062 *     Form z1 which consist of the last row of Q1
00063 *
00064       CALL INFOG2L( IQ-1+( ID+N1-1 ), JQ-1+ID, DESCQ, NPROW, NPCOL,
00065      $              MYROW, MYCOL, IIZ1, JJZ1, IZ1ROW, IZ1COL )
00066       NQ1 = NUMROC( N1, NB, MYCOL, IZ1COL, NPCOL )
00067       IF( ( MYROW.EQ.IZ1ROW ) .AND. ( NQ1.NE.0 ) ) THEN
00068          CALL SCOPY( NQ1, Q( IIZ1, JJZ1 ), LDQ, WORK, 1 )
00069          IF( MYROW.NE.IQROW .OR. MYCOL.NE.IQCOL )
00070      $      CALL SGESD2D( ICTXT, NQ1, 1, WORK, NQ1, IQROW, IQCOL )
00071       END IF
00072 *
00073 *     Proc (IQROW, IQCOL) receive the parts of z1
00074 *
00075       IF( MYROW.EQ.IQROW .AND. MYCOL.EQ.IQCOL ) THEN
00076          COL = IZ1COL
00077          DO 20 I = 0, NPCOL - 1
00078             NQ1 = NUMROC( N1, NB, COL, IZ1COL, NPCOL )
00079             IF( NQ1.GT.0 ) THEN
00080                IF( IZ1ROW.NE.IQROW .OR. COL.NE.IQCOL ) THEN
00081                   IBUF = N1 + 1
00082                   CALL SGERV2D( ICTXT, NQ1, 1, WORK( IBUF ), NQ1,
00083      $                          IZ1ROW, COL )
00084                ELSE
00085                   IBUF = 1
00086                END IF
00087                IZ1 = 0
00088                IZ = I*NB + 1
00089                NBLOC = ( NQ1-1 ) / NB + 1
00090                DO 10 J = 1, NBLOC
00091                   ZSIZ = MIN( NB, NQ1-IZ1 )
00092                   CALL SCOPY( ZSIZ, WORK( IBUF+IZ1 ), 1, Z( IZ ), 1 )
00093                   IZ1 = IZ1 + NB
00094                   IZ = IZ + NB*NPCOL
00095    10          CONTINUE
00096             END IF
00097             COL = MOD( COL+1, NPCOL )
00098    20    CONTINUE
00099       END IF
00100 *
00101 *     Form z2 which consist of the first row of Q2
00102 *
00103       CALL INFOG2L( IQ-1+( ID+N1 ), JQ-1+( ID+N1 ), DESCQ, NPROW, NPCOL,
00104      $              MYROW, MYCOL, IIZ2, JJZ2, IZ2ROW, IZ2COL )
00105       NQ2 = NUMROC( N2, NB, MYCOL, IZ2COL, NPCOL )
00106       IF( ( MYROW.EQ.IZ2ROW ) .AND. ( NQ2.NE.0 ) ) THEN
00107          CALL SCOPY( NQ2, Q( IIZ2, JJZ2 ), LDQ, WORK, 1 )
00108          IF( MYROW.NE.IQROW .OR. MYCOL.NE.IQCOL )
00109      $      CALL SGESD2D( ICTXT, NQ2, 1, WORK, NQ2, IQROW, IQCOL )
00110       END IF
00111 *
00112 *     Proc (IQROW, IQCOL) receive the parts of z2
00113 *
00114       IF( MYROW.EQ.IQROW .AND. MYCOL.EQ.IQCOL ) THEN
00115          COL = IZ2COL
00116          DO 40 I = 0, NPCOL - 1
00117             NQ2 = NUMROC( N2, NB, COL, IZ2COL, NPCOL )
00118             IF( NQ2.GT.0 ) THEN
00119                IF( IQROW.NE.IZ2ROW .OR. IQCOL.NE.COL ) THEN
00120                   IBUF = 1 + N2
00121                   CALL SGERV2D( ICTXT, NQ2, 1, WORK( IBUF ), NQ2,
00122      $                          IZ2ROW, COL )
00123                ELSE
00124                   IBUF = 1
00125                END IF
00126                IZ2 = 0
00127                IZ = NB*I + N1 + 1
00128                NBLOC = ( NQ2-1 ) / NB + 1
00129                DO 30 J = 1, NBLOC
00130                   ZSIZ = MIN( NB, NQ2-IZ2 )
00131                   CALL SCOPY( ZSIZ, WORK( IBUF+IZ2 ), 1, Z( IZ ), 1 )
00132                   IZ2 = IZ2 + NB
00133                   IZ = IZ + NB*NPCOL
00134    30          CONTINUE
00135             END IF
00136             COL = MOD( COL+1, NPCOL )
00137    40    CONTINUE
00138       END IF
00139 *
00140 *     proc(IQROW,IQCOL) broadcast Z=(Z1,Z2)
00141 *
00142       IF( MYROW.EQ.IQROW .AND. MYCOL.EQ.IQCOL ) THEN
00143          CALL SGEBS2D( ICTXT, 'All', ' ', N, 1, Z, N )
00144       ELSE
00145          CALL SGEBR2D( ICTXT, 'All', ' ', N, 1, Z, N, IQROW, IQCOL )
00146       END IF
00147 *
00148       RETURN
00149 *
00150 *     End of PSLAEDZ
00151 *
00152 *
00153       END