psrow2col.f

Go to the documentation of this file.

      SUBROUTINE psrow2col( 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 row of processes, and distribute those rows over a column of
*  processes. This routine minimizes communication by sending all
*  information it has that a given process in the CDEST 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 row consisting of Q processes, and I want to send all of that
*  vector that I own to a new vector distributed over P processes within
*  a process column, 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)/Q ) 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 row.
*
*  VS      (local input) REAL
*          Array of dimension (LDVS,N), the block of vectors stored on
*          process row RSRC to be put into memory VD, and stored on
*          process column CDEST.
*
*  LDVS    (local input) INTEGER
*          The leading dimension of VS.
*
*  VD      (local output) REAL
*          Array of dimension (LDVD,N), on output, the contents of VD
*          stored on process column CDEST will be here.
*
*  LDVD    (local input) INTEGER
*          The leading dimension of VD.
*
*  RSRC    (global input) INTEGER
*          The process row VS is distributed over.
*
*  CSRC    (global input) INTEGER
*          The process column the distributed block of vectors VS
*          begins on.
*
*  RDEST   (global input) INTEGER
*          The process row that VD begins on.
*
*  CDEST   (global input) INTEGER
*          The process column to distribute VD over.
*
*  WORK    (local workspace) REAL
*          Array, 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.
*             Mq  = number of rows of VS on my process.
*             npcol = number of process columns
*             CEIL = the ceiling of given operation
*             LDW = NB*N*CEIL( CEIL( Mq/NB )/(LCM/npcol) )
*          end if
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            CBLKSKIP, ICPY, II, ISTART, ICSRC, IRDEST, 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
*      
      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( myrow.EQ.rsrc ) THEN
*
            istart = 1
*
*           Figure my distance from CSRC: the process in CDEST the same
*           distance from RDEST will want my first block
*
            mydist = mod( npcol+mycol-csrc, npcol )
            mq = numroc( m, nb, mycol, csrc, npcol )
            irdest = mod( rdest+mydist, nprow )
*
*           Loop over all possible destination processes
*
            DO 20 k = 1, rblkskip
               jj = 1
*
*              If I am not destination process
*
               IF( (myrow.NE.irdest).OR.(mycol.NE.cdest) ) THEN
*
*                 Pack all data I own that destination needs
*
                  DO 10 ii = istart, mq, nb*rblkskip
                     jb = min( nb, mq-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, irdest,
     $                             cdest )
*
*              I am both source and destination, save where to start
*              copying from for later use
*
               ELSE
                  icpy = istart
               END IF
*
               istart = istart + nb
               irdest = mod( irdest+npcol, nprow )
   20       CONTINUE
         END IF
*
*        If I should receive info into VD
*
         IF( mycol.EQ.cdest ) THEN
*
            istart = 1
*
*           Figure my distance from CDEST: the process in CSRC the same
*           distance from RSRC will have my first block
*
            mydist = mod( nprow+myrow-rdest, nprow )
            mp = numroc( m, nb, myrow, rdest, nprow )
            icsrc = mod( csrc+mydist, npcol )
*
*           Loop over all sending processes
*
            DO 50 k = 1, cblkskip
*
*              If I don't already possess the required data
*
               IF( (myrow.NE.rsrc).OR.(mycol.NE.icsrc) ) THEN
*
*                 Figure how many rows to receive, and receive them
*                 NOTE: may receive to much -- NB instead of JB
*
                  nblocks = (mp - istart + nb) / nb
                  jj = ((nblocks+cblkskip-1) / cblkskip)*nb
                  IF( jj.GT.0 )
     $               CALL sgerv2d( ictxt, jj, n, work, jj, rsrc, icsrc )
*
*                 Copy data to destination vector
*
                  jj = 1
                  DO 30 ii = istart, mp, nb*cblkskip
                     jb = min( nb, mp-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, mp, nb*cblkskip
                     jb = min( nb, mp-ii+1 )
                     CALL slacpy( 'G', jb, n, vs(jj,1), ldvs, vd(ii,1),
     $                            ldvd )
                     jj = jj + nb*rblkskip
   40             CONTINUE
               END IF
               istart = istart + nb
               icsrc = mod( icsrc+nprow, npcol )
   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( myrow.EQ.rsrc ) THEN
*
*           Figure my distance from CSRC: the process in CDEST the same
*           distance from RDEST will want my piece of the vector
*
            mydist = mod( npcol+mycol-csrc, npcol )
            mq = numroc( m, nb, mycol, csrc, npcol )
            irdest = mod( rdest+mydist, nprow )
            IF( (myrow.NE.irdest).OR.(mycol.NE.cdest) ) THEN
               CALL sgesd2d( ictxt, mq, n, vs, ldvs, irdest, cdest )
            ELSE
               CALL slacpy( 'G', mq, n, vs, ldvs, vd, ldvd )
            END IF
         END IF
         IF( mycol.EQ.cdest ) THEN
*
*           Figure my distance from RDEST: the process in RSRC the same
*           distance from CSRC will have my piece of the vector
*
            mydist = mod( nprow+myrow-rdest, nprow )
            mp = numroc( m, nb, myrow, rdest, nprow )
            icsrc = mod( csrc+mydist, npcol )
            IF( (mycol.NE.icsrc).OR.(myrow.NE. rsrc) )
     $         CALL sgerv2d( ictxt, mp, n, vd, ldvd, rsrc, icsrc )
         END IF
      END IF
*
      RETURN
*
*     End of PSROW2COL
*
      END