pscol2row.f

Go to the documentation of this file.

      SUBROUTINE pscol2row( ICTXT, M, N, NB, VS, LDVS, VD, LDVD, RSRC,
     $                      CSRC, RDEST, CDEST, WORK)
*
*  -- ScaLAPACK tools routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      INTEGER            CDEST, CSRC, ICTXT, LDVD, LDVS, M, N, NB,
     $                   rdest, rsrc
*     ..
*     .. Array Arguments ..
      REAL               VD( LDVD, * ), VS( LDVS, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  Take a block of vectors with M total rows which are distributed over
*  a column of processes, and distribute those rows over a row of
*  processes. This routine minimizes communication by sending all
*  information it has that a given process in the RDEST needs at once.
*  To do this it uses the least common multiple (LCM) concept.  This is
*  simply the realization that if I have part of a vector split over a
*  process column consisting of P processes, and I want to send all of
*  that vector that I own to a new vector distributed over Q processes
*  within a process row, that after I find the process in RDEST that
*  owns the row of the vector I'm currently looking at, he will want
*  every ( (LCM(P,Q) / P ) block of my vector (the block being of size
*  NB x N).
*
*  Arguments
*  =========
*
*  Rem:  MP, resp. NQ, denotes the number of local rows, resp. local
*  ====  columns, necessary to store a global vector of dimension M
*        across P processes, resp. N over Q processes.
*
*  ICTXT   (global input) INTEGER
*          The BLACS context handle, indicating the global context of
*          the operation. The context itself is global.
*
*  M       (global input) INTEGER
*          The number of global rows each vector has.
*
*  N       (global input) INTEGER
*          The number of vectors in the vector block.
*
*  NB      (global input) INTEGER
*          The blocking factor used to divide the rows of the vector
*          amongst the processes of a column.
*
*  VS      (local input) REAL
*          Array of dimension (LDVS,N), the block of vectors stored on
*          process column CSRC to be put into memory VD, and stored
*          on process row RDEST.
*
*  LDVS    (local input) INTEGER
*          The leading dimension of VS, LDVS >= MAX( 1, MP ).
*
*  VD      (local output) REAL
*          Array of dimension (LDVD,N), on output, the contents of VS
*          stored on process row RDEST will be here.
*
*  LDVD    (local input) INTEGER
*          The leading dimension of VD, LDVD >= MAX( 1, MQ ).
*
*  RSRC    (global input) INTEGER
*          The process row the distributed block of vectors VS begins
*          on.
*
*  CSRC    (global input) INTEGER
*          The process column VS is distributed over.
*
*  RDEST   (global input) INTEGER
*          The process row to distribute VD over.
*
*  CDEST   (global input) INTEGER
*          The process column that VD begins on.
*
*  WORK    (local workspace) REAL
*          Array of dimension (LDW), the required size of work varies:
*          if( nprow.eq.npcol ) then
*             LDW = 0; WORK not accessed.
*          else
*             lcm = least common multiple of process rows and columns.
*             Mp  = number of rows of VS on my process.
*             nprow = number of process rows
*             CEIL = the ceiling of given operation
*             LDW = NB*N*CEIL( CEIL( Mp/NB )/(LCM/nprow) )
*          end if
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            CBLKSKIP, ICPY, ICDEST, II, IRSRC, ISTART, JB,
     $                   jj, k, lcm, mp, mq, mycol, mydist, myrow,
     $                   nblocks, npcol, nprow, rblkskip
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_gridinfo, sgesd2d, sgerv2d, slacpy
*     ..
*     .. External Functions ..
      INTEGER            ILCM, NUMROC
      EXTERNAL           ilcm, numroc
*     ..
*     .. Executable Statements ..
*
*
*     .. Initialize Variables ..
*
      icpy = 0
*      
*     Get grid parameters.
*
      CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
*
*     If we are not in special case for NPROW = NPCOL where there
*     is no copying required
*
      IF( nprow.NE.npcol ) THEN
         lcm = ilcm( nprow, npcol )
         rblkskip = lcm / npcol
         cblkskip = lcm / nprow
*
*        If I have part of VS, the source vector(s)
*
         IF( mycol.EQ.csrc ) THEN
*
            istart = 1
*
*           Figure my distance from RSRC: the process in RDEST the same
*           distance from CDEST will want my first block
*
            mydist = mod( nprow+myrow-rsrc, nprow )
            mp = numroc( m, nb, myrow, rsrc, nprow )
            icdest = mod( cdest+mydist, npcol )
*
*           Loop over all possible destination processes
*
            DO 20 k = 1, cblkskip
               jj = 1
*
*              If I am not destination process
*
               IF( (mycol.NE.icdest).OR.(myrow.NE.rdest) ) THEN
*
*                 Pack all data I own that destination needs
*
                  DO 10 ii = istart, mp, nb*cblkskip
                     jb = min(nb, mp-ii+1)
                     CALL slacpy( 'G', jb, n, vs(ii,1), ldvs,
     $                            work(jj), jb )
                     jj = jj + nb*n
   10             CONTINUE
*
*                 Figure how many rows are to be sent and send them if
*                 necessary (NOTE: will send extra if NB > JB)
*
                  jj = jj - 1
                  IF( jj.GT.0 )
     $               CALL sgesd2d( ictxt, jj, 1, work, jj, rdest,
     $                             icdest )
*
               ELSE
*
*                 I am both source and destination, save where to start
*                 copying from for later use.
*
                  icpy = istart
               END IF
*
               istart = istart + nb
               icdest = mod(icdest+nprow, npcol)
   20       CONTINUE
         END IF
*
*        If I should receive info into VD
*
         IF( myrow.EQ.rdest ) THEN
*
            istart = 1
*
*           Figure my distance from CDEST: the process in CSRC the same
*           distance from RSRC will have my first block.
*
            mydist = mod( npcol+mycol-cdest, npcol )
            mq = numroc( m, nb, mycol, cdest, npcol )
            irsrc = mod( rsrc+mydist, nprow )
            DO 50 k = 1, rblkskip
*
*              If I don't already possess the required data
*
               IF( (mycol.NE.csrc).OR.(myrow.NE.irsrc) ) THEN
*
*                 Figure how many rows to receive, and receive them
*                 NOTE: may receive to much -- NB instead of JB
*
                  nblocks = (mq - istart + nb) / nb
                  jj = ((nblocks+rblkskip-1) / rblkskip)*nb
                  IF( jj.GT.0 )
     $               CALL sgerv2d( ictxt, jj, n, work, jj, irsrc, csrc )
*
*                 Copy data to destination vector
*
                  jj = 1
                  DO 30 ii = istart, mq, nb*rblkskip
                     jb = min( nb, mq-ii+1 )
                     CALL slacpy( 'G', jb, n, work(jj), jb,
     $                            vd(ii,1), ldvd )
                     jj = jj + nb*n
   30             CONTINUE
*
*                 If I am both source and destination
*
               ELSE
                  jj = icpy
                  DO 40 ii = istart, mq, nb*rblkskip
                     jb = min( nb, mq-ii+1 )
                     CALL slacpy( 'G', jb, n, vs(jj,1), ldvs,
     $                            vd(ii,1), ldvd )
                     jj = jj + nb*cblkskip
   40             CONTINUE
               END IF
               istart = istart + nb
               irsrc = mod( irsrc+npcol, nprow )
   50       CONTINUE
         END IF
*
*     If NPROW = NPCOL, there is a one-to-one correspondance between
*     process rows and columns, so no work space or copying required
*
      ELSE
*
         IF( mycol.EQ.csrc ) THEN
*
*           Figure my distance from RSRC: the process in RDEST the same
*           distance from CDEST will want my piece of the vector.
*
            mydist = mod( nprow+myrow-rsrc, nprow )
            mp = numroc( m, nb, myrow, rsrc, nprow )
            icdest = mod( cdest+mydist, npcol )
*
            IF( (mycol.NE.icdest).OR.(myrow.NE.rdest) ) THEN
               CALL sgesd2d( ictxt, mp, n, vs, ldvs, rdest, icdest )
            ELSE
               CALL slacpy( 'G', mp, n, vs, ldvs, vd, ldvd )
            END IF
         END IF
*
         IF( myrow.EQ.rdest ) THEN
*
*           Figure my distance from CDEST: the process in CSRC the same
*           distance from RSRC will have my piece of the vector.
*
            mydist = mod( npcol+mycol-cdest, npcol )
            mq = numroc( m, nb, mycol, cdest, npcol )
            irsrc = mod( rsrc+mydist, nprow )
*
            IF( (myrow.NE.irsrc).OR.(mycol.NE.csrc) )
     $         CALL sgerv2d( ictxt, mq, n, vd, ldvd, irsrc, csrc )
*
          END IF
*
      END IF
*
      RETURN
*
*     End of PSCOL2ROW
*
      END