pbstrget.f

Go to the documentation of this file.

      SUBROUTINE pbstrget( ICONTXT, ADIST, M, N, MNB, A, LDA, MCROW,
     $                     MCCOL, IGD, MYROW, MYCOL, NPROW, NPCOL )
*
*  -- PB-BLAS routine (version 2.1) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory.
*     April 28, 1996
*
*     .. Scalar Arguments ..
      CHARACTER*1        ADIST
      INTEGER            ICONTXT, IGD, LDA, M, MCCOL, MCROW, MNB, MYCOL,
     $                   myrow, n, npcol, nprow
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  PBSTRGET forms a row block of A from scattered row subblocks if
*  ADIST = 'R', or forms a column block of A from scattered column
*  subblocks,  if ADIST = 'C'.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, TWO
      parameter( one = 1.0e+0, two = 2.0e+0 )
*     ..
*     .. Local Variables ..
      INTEGER            KINT, KINT2, KLEN, KMOD, KPPOS, NLEN, NNUM,
     $                   ntlen
      REAL               TEMP
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ICEIL, NUMROC
      EXTERNAL           lsame,  iceil, numroc
*     ..
*     .. External Subroutines ..
      EXTERNAL           sgerv2d, sgesd2d
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          max, min, mod
*
*     if A is a row block, it needs to communicate columnwise.
*
      IF( lsame( adist, 'R' ) ) THEN
         kppos = mod( nprow+myrow-mcrow, nprow )
         IF( mod( kppos, igd ).EQ.0 ) THEN
            kint = igd
            nlen = n
            nnum = min( nprow/igd, mnb-mccol )
            temp = real( nnum )
            ntlen = n * nnum
            nnum = igd * nnum
            IF( kppos.GE.nnum ) GO TO 30
            kppos = mod( kppos, nprow )
*
   10       CONTINUE
            IF( temp.GT.one ) THEN
               kint2 = 2 * kint
               kmod = mod( kppos, kint2 )
*
               IF( kmod.EQ.0 ) THEN
                  IF( kppos+kint.LT.nnum ) THEN
                     klen = ntlen - (kppos/kint2)*(kint2/igd)*n
                     klen = min( klen-nlen, nlen )
                     CALL sgerv2d( icontxt, m, klen, a(1,nlen+1), lda,
     $                             mod(myrow+kint, nprow), mycol )
                     nlen = nlen + klen
                  END IF
               ELSE
                  CALL sgesd2d( icontxt, m, nlen, a, lda,
     $                          mod(nprow+myrow-kint, nprow), mycol )
                  GO TO 30
               END IF
*
               kint = kint2
               temp = temp / two
               GO TO 10
            END IF
         END IF
*
*     if A is a column block, it needs to communicate rowwise.
*
      ELSE IF( lsame( adist, 'C' ) ) THEN
*
         kppos = mod( npcol+mycol-mccol, npcol )
         IF( mod( kppos, igd ).EQ.0 ) THEN
            kint = igd
            nlen = n
            nnum = min( npcol/igd, mnb-mcrow )
            temp = real( nnum )
            ntlen = n * nnum
            nnum = igd * nnum
            IF( kppos.GE.nnum ) GO TO 30
            kppos = mod( kppos, npcol )
*
   20       CONTINUE
            IF( temp.GT.one ) THEN
               kint2 = 2 * kint
               kmod = mod( kppos, kint2 )
*
               IF( kmod.EQ.0 ) THEN
                  IF( kppos+kint.LT.nnum ) THEN
                     klen = ntlen - (kppos/kint2)*(kint2/igd)*n
                     klen = min( klen-nlen, nlen )
                     CALL sgerv2d( icontxt, m, klen, a(1,nlen+1), lda,
     $                             myrow, mod(mycol+kint, npcol) )
                     nlen = nlen + klen
                  END IF
               ELSE
                  CALL sgesd2d( icontxt, m, nlen, a, lda, myrow,
     $                          mod(npcol+mycol-kint, npcol) )
                  GO TO 30
               END IF
*
               kint = kint2
               temp = temp / two
               GO TO 20
            END IF
         END IF
      END IF
*
   30 CONTINUE
*
      RETURN
*
*     End of PBSTRGET
*
      END