Cpsgemr2d() [2/2]

void Cpsgemr2d	(	Int	m,
		Int	n,
		float *	ptrmyblock,
		Int	ia,
		Int	ja,
		MDESC *	ma,
		float *	ptrmynewblock,
		Int	ib,
		Int	jb,
		MDESC *	mb,
		Int	globcontext
	)

Definition at line 288 of file psgemr.c.

{
  float *ptrsendbuff, *ptrrecvbuff, *ptrNULL = 0;
  float *recvptr;
  MDESC newa, newb;
  Int  *proc0, *proc1, *param;
  Int   mypnum, myprow0, mypcol0, myprow1, mypcol1, nprocs;
  Int   i, j;
  Int   nprow, npcol, gcontext;
  Int   recvsize, sendsize;
  IDESC *h_inter;       /* to store the horizontal intersections */
  IDESC *v_inter;       /* to store the vertical intersections */
  Int   hinter_nb, vinter_nb;   /* number of intrsections in both directions */
  Int   dummy;
  Int   p0, q0, p1, q1;
  Int  *ra, *ca;
  /* end of variables */
  /* To simplify further calcul we change the matrix indexation from
   * 1..m,1..n (fortran) to 0..m-1,0..n-1 */
  if (m == 0 || n == 0)
    return;
  ia -= 1;
  ja -= 1;
  ib -= 1;
  jb -= 1;
  Cblacs_gridinfo(globcontext, &nprow, &npcol, &dummy, &mypnum);
  gcontext = globcontext;
  nprocs = nprow * npcol;
  /* if the global context that is given to us has not the shape of a line
   * (nprow != 1), create a new context.  TODO: to be optimal, we should
   * avoid this because it is an uncessary synchronisation */
  if (nprow != 1) {
    gridreshape(&gcontext);
    Cblacs_gridinfo(gcontext, &dummy, &dummy, &dummy, &mypnum);
  }
  Cblacs_gridinfo(ma->ctxt, &p0, &q0, &myprow0, &mypcol0);
  /* compatibility T3D, must check myprow  and mypcol are within bounds */
  if (myprow0 >= p0 || mypcol0 >= q0)
    myprow0 = mypcol0 = -1;
  assert((myprow0 < p0 && mypcol0 < q0) || (myprow0 == -1 && mypcol0 == -1));
  Cblacs_gridinfo(mb->ctxt, &p1, &q1, &myprow1, &mypcol1);
  if (myprow1 >= p1 || mypcol1 >= q1)
    myprow1 = mypcol1 = -1;
  assert((myprow1 < p1 && mypcol1 < q1) || (myprow1 == -1 && mypcol1 == -1));
  /* exchange the missing parameters among the processors: shape of grids and
   * location of the processors */
  param = (Int *) mr2d_malloc(3 * (nprocs * 2 + NBPARAM) * sizeof(Int));
  ra = param + nprocs * 2 + NBPARAM;
  ca = param + (nprocs * 2 + NBPARAM) * 2;
  for (i = 0; i < nprocs * 2 + NBPARAM; i++)
    param[i] = MAGIC_MAX;
  proc0 = param + NBPARAM;
  proc1 = param + NBPARAM + nprocs;
  /* we calulate proc0 and proc1 that will give the number of a proc in
   * respectively a or b in the global context */
  if (myprow0 >= 0) {
    proc0[myprow0 * q0 + mypcol0] = mypnum;
    param[0] = p0;
    param[1] = q0;
    param[4] = ma->m;
    param[5] = ma->n;
    param[6] = ma->nbrow;
    param[7] = ma->nbcol;
    param[8] = ma->sprow;
    param[9] = ma->spcol;
    param[10] = ia;
    param[11] = ja;
  }
  if (myprow1 >= 0) {
    proc1[myprow1 * q1 + mypcol1] = mypnum;
    param[2] = p1;
    param[3] = q1;
    param[12] = mb->m;
    param[13] = mb->n;
    param[14] = mb->nbrow;
    param[15] = mb->nbcol;
    param[16] = mb->sprow;
    param[17] = mb->spcol;
    param[18] = ib;
    param[19] = jb;
  }
  Cigamn2d(gcontext, "All", "H", 2 * nprocs + NBPARAM, (Int)1, param, 2 * nprocs + NBPARAM,
           ra, ca, 2 * nprocs + NBPARAM, (Int)-1, (Int)-1);
  newa = *ma;
  newb = *mb;
  ma = &newa;
  mb = &newb;
  if (myprow0 == -1) {
    p0 = param[0];
    q0 = param[1];
    ma->m = param[4];
    ma->n = param[5];
    ma->nbrow = param[6];
    ma->nbcol = param[7];
    ma->sprow = param[8];
    ma->spcol = param[9];
    ia = param[10];
    ja = param[11];
  }
  if (myprow1 == -1) {
    p1 = param[2];
    q1 = param[3];
    mb->m = param[12];
    mb->n = param[13];
    mb->nbrow = param[14];
    mb->nbcol = param[15];
    mb->sprow = param[16];
    mb->spcol = param[17];
    ib = param[18];
    jb = param[19];
  }
  for (i = 0; i < NBPARAM; i++) {
    if (param[i] == MAGIC_MAX) {
      fprintf(stderr, "xxGEMR2D:something wrong in the parameters\n");
      exit(1);
    }
  }
#ifndef NDEBUG
  for (i = 0; i < p0 * q0; i++)
    assert(proc0[i] >= 0 && proc0[i] < nprocs);
  for (i = 0; i < p1 * q1; i++)
    assert(proc1[i] >= 0 && proc1[i] < nprocs);
#endif
  /* check the validity of the parameters */
  paramcheck(ma, ia, ja, m, n, p0, q0, gcontext);
  paramcheck(mb, ib, jb, m, n, p1, q1, gcontext);
  /* we change the problem so that ia < a->nbrow ... andia + m = a->m ... */
  {
    Int   decal;
    ia = changeorigin(myprow0, ma->sprow, p0,
                      ma->nbrow, ia, &decal, &ma->sprow);
    ptrmyblock += decal;
    ja = changeorigin(mypcol0, ma->spcol, q0,
                      ma->nbcol, ja, &decal, &ma->spcol);
    ptrmyblock += decal * ma->lda;
    ma->m = ia + m;
    ma->n = ja + n;
    ib = changeorigin(myprow1, mb->sprow, p1,
                      mb->nbrow, ib, &decal, &mb->sprow);
    ptrmynewblock += decal;
    jb = changeorigin(mypcol1, mb->spcol, q1,
                      mb->nbcol, jb, &decal, &mb->spcol);
    ptrmynewblock += decal * mb->lda;
    mb->m = ib + m;
    mb->n = jb + n;
    if (p0 == 1)
      ma->nbrow = ma->m;
    if (q0 == 1)
      ma->nbcol = ma->n;
    if (p1 == 1)
      mb->nbrow = mb->m;
    if (q1 == 1)
      mb->nbcol = mb->n;
#ifndef NDEBUG
    paramcheck(ma, ia, ja, m, n, p0, q0, gcontext);
    paramcheck(mb, ib, jb, m, n, p1, q1, gcontext);
#endif
  }
  /* We compute the size of the memory buffer ( we choose the worst case,
   * when the buffer sizes == the memory block sizes). */
  if (myprow0 >= 0 && mypcol0 >= 0) {
    /* Initialize pointer variables */
    setmemory(&ptrsendbuff, memoryblocksize(ma));
  };    /* if (mypnum < p0 * q0) */
  if (myprow1 >= 0 && mypcol1 >= 0) {
    /* Initialize pointer variables */
    setmemory(&ptrrecvbuff, memoryblocksize(mb));
  };    /* if (mypnum < p1 * q1) */
  /* allocing room for the tabs, alloc for the worst case,local_n or local_m
   * intervals, in fact the worst case should be less, perhaps half that,I
   * should think of that one day. */
  h_inter = (IDESC *) mr2d_malloc(DIVUP(ma->n, q0 * ma->nbcol) *
                                  ma->nbcol * sizeof(IDESC));
  v_inter = (IDESC *) mr2d_malloc(DIVUP(ma->m, p0 * ma->nbrow)
                                  * ma->nbrow * sizeof(IDESC));
  /* We go for the scanning of indices. For each processor including mypnum,
   * we fill the sendbuff buffer (scanD0(SENDBUFF)) and when it is done send
   * it. Then for each processor, we compute the size of message to be
   * receive scanD0(SIZEBUFF)), post a receive and then allocate the elements
   * of recvbuff the right place (scanD)(RECVBUFF)) */
  recvptr = ptrrecvbuff;
  {
    Int   tot, myrang, step, sens;
    Int  *sender, *recver;
    Int   mesending, merecving;
    tot = max(p0 * q0, p1 * q1);
    init_chenille(mypnum, nprocs, p0 * q0, proc0, p1 * q1, proc1,
                  &sender, &recver, &myrang);
    if (myrang == -1)
      goto after_comm;
    mesending = myprow0 >= 0;
    assert(sender[myrang] >= 0 || !mesending);
    assert(!mesending || proc0[sender[myrang]] == mypnum);
    merecving = myprow1 >= 0;
    assert(recver[myrang] >= 0 || !merecving);
    assert(!merecving || proc1[recver[myrang]] == mypnum);
    step = tot - 1 - myrang;
    do {
      for (sens = 0; sens < 2; sens++) {
        /* be careful here, when we communicating with ourselves, we must
         * send first (myrang > step == 0) */
        if (mesending && recver[step] >= 0 &&
            (sens == 0)) {
          i = recver[step] / q1;
          j = recver[step] % q1;
          vinter_nb = scan_intervals('r', ia, ib, m, ma, mb, p0, p1, myprow0, i,
                                     v_inter);
          hinter_nb = scan_intervals('c', ja, jb, n, ma, mb, q0, q1, mypcol0, j,
                                     h_inter);
          sendsize = block2buff(v_inter, vinter_nb, h_inter, hinter_nb,
                                ptrmyblock, ma, ptrsendbuff);
        }       /* if (mesending...) { */
        if (mesending && recver[step] >= 0 &&
            (sens == myrang > step)) {
          i = recver[step] / q1;
          j = recver[step] % q1;
          if (sendsize > 0
              && (step != myrang || !merecving)
                ) {
            Csgesd2d(gcontext, sendsize, (Int)1, ptrsendbuff, sendsize,
                     (Int)0, proc1[i * q1 + j]);
          }     /* sendsize > 0 */
        }       /* if (mesending ... */
        if (merecving && sender[step] >= 0 &&
            (sens == myrang <= step)) {
          i = sender[step] / q0;
          j = sender[step] % q0;
          vinter_nb = scan_intervals('r', ib, ia, m, mb, ma, p1, p0, myprow1, i,
                                     v_inter);
          hinter_nb = scan_intervals('c', jb, ja, n, mb, ma, q1, q0, mypcol1, j,
                                     h_inter);
          recvsize = inter_len(hinter_nb, h_inter, vinter_nb, v_inter);
          if (recvsize > 0) {
            if (step == myrang && mesending) {
              Clacpy(recvsize, 1,
                     ptrsendbuff, recvsize,
                     ptrrecvbuff, recvsize);
            } else {
              Csgerv2d(gcontext, recvsize, (Int)1, ptrrecvbuff, recvsize,
                       0, proc0[i * q0 + j]);
            }
          }     /* recvsize > 0 */
        }       /* if (merecving ...) */
        if (merecving && sender[step] >= 0 && sens == 1) {
          buff2block(v_inter, vinter_nb, h_inter, hinter_nb,
                     recvptr, ptrmynewblock, mb);
        }       /* if (merecving...)  */
      } /* for (sens = 0) */
      step -= 1;
      if (step < 0)
        step = tot - 1;
    } while (step != tot - 1 - myrang);
after_comm:
    free(sender);
  }     /* { int tot,nr,ns ...} */
  /* don't forget to clean up things! */
  if (myprow1 >= 0 && mypcol1 >= 0) {
    freememory((char *) ptrrecvbuff);
  };
  if (myprow0 >= 0 && mypcol0 >= 0) {
    freememory((char *) ptrsendbuff);
  };
  if (nprow != 1)
    Cblacs_gridexit(gcontext);
  free(v_inter);
  free(h_inter);
  free(param);

Here is the call graph for this function: