#include "Bdef.h"


#if (INTFACE == C_CALL)
void Cdgamx2d(ConTxt, scope, top, m, n, A, lda, rA, cA, ldia, rdest, cdest)
int  ConTxt;
char  *scope;
char  *top;
int  m;
int  n;
double  *A;
int  lda;
int  *rA;
int  *cA;
int  ldia;
int  rdest;
int  cdest;
#else
void dgamx2d_(ConTxt, scope, top, m, n, A, lda, rA, cA, ldia, rdest, cdest)
int  *ConTxt;
char  *scope;
char  *top;
int  *m;
int  *n;
double  *A;
int  *lda;
int  *rA;
int  *cA;
int  *ldia;
int  *rdest;
int  *cdest;
#endif
/*
 *  -- V1.1 BLACS routine --
 *  University of Tennessee, May 1, 1996
 *  Written by Clint Whaley.
 *
 *  Purpose
 *  =======
 *  Combine amx operation for double precision rectangular matrices.
 *
 *  Arguments
 *  =========
 *
 *  ConTxt  (input) Ptr to int
 *          Index into MyConTxts00 (my contexts array).
 *
 *  SCOPE   (input) Ptr to char
 *          Limit the scope of the operation.
 *          = 'R' :   Operation is performed by a process row.
 *          = 'C' :   Operation is performed by a process column.
 *          = 'A' :   Operation is performed by all processes in grid.
 *
 *  TOP     (input) Ptr to char
 *          Controls fashion in which messages flow within the operation.
 *
 *  M       (input) Ptr to int
 *          The number of rows of the matrix A.  M >= 0.
 *
 *  N       (input) Ptr to int
 *          The number of columns of the matrix A.  N >= 0.
 *
 *  A       (output) Ptr to double precision two dimensional array
 *          The m by n matrix A.  Fortran77 (column-major) storage
 *          assumed.
 *
 *  LDA     (input) Ptr to int
 *          The leading dimension of the array A.  LDA >= M.
 *
 *  RA      (output) Integer Array, dimension (LDIA, N)
 *          Contains process row that the amx of each element
 *          of A was found on: i.e., rA(1,2) contains the process
 *          row that the amx of A(1,2) was found on.
 *          Values are left on process {rdest, cdest} only, others
 *          may be modified, but not left with interesting data.
 *          If rdest == -1, then result is left on all processes in scope.
 *          If LDIA == -1, this array is not accessed, and need not exist.
 *
 *  CA      (output) Integer Array, dimension (LDIA, N)
 *          Contains process column that the amx of each element
 *          of A was found on: i.e., cA(1,2) contains the process
 *          column that the max/min of A(1,2) was found on.
 *          Values are left on process {rdest, cdest} only, others
 *          may be modified, but not left with interesting data.
 *          If rdest == -1, then result is left on all processes in scope.
 *          If LDIA == -1, this array is not accessed, and need not exist.
 *
 *  LDIA    (input) Ptr to int
 *          If (LDIA == -1), then the arrays RA and CA are not accessed.
 *          ELSE leading dimension of the arrays RA and CA.  LDIA >= M.
 *
 *  RDEST   (input) Ptr to int
 *          The process row of the destination of the amx.
 *          If rdest == -1, then result is left on all processes in scope.
 *
 *  CDEST   (input) Ptr to int
 *          The process column of the destination of the amx.
 *          If rdest == -1, then CDEST ignored.
 *
 * ------------------------------------------------------------------------
 */
{
   void TransDist();
   void tree_comb();
   void BE_comb();
   void dgpk4op();
   void dgupk4op();
   void dgpk4amxamn();
   void dgupk4amxamn();
   void dgupk_amx();
   void dgupk_amx2();
   void dpack00();
   void dunpack00();
   char *getbuff();
#if (BlacsDebugLvl > 0)
   void ArgCheck00();
#endif
/*
 *  Variable Declarations
 */
   MATINFO MatInf;
   MVPK mpk, mupk;   /* matrix pack and unpack routines */
   MVUPKOP mupk_op;  /* matrix unpack and do operation routine */
   char *buff;
   BLACSCONTEXT *ctxt;
   char ttop, tscope;
   int i, j, length, tlda, tldia, trdest;
   unsigned short *dist, mydist;

   MGetConTxt(Mpval(ConTxt), ctxt);
   ttop = Mlowcase(*top);
   tscope = Mlowcase(*scope);
   if (Mpval(ldia) < 1)
   {
      mpk = dgpk4op;
      mupk = dgupk4op;
      mupk_op = dgupk_amx2;
      if (Mpval(m) != 1) length = Mpval(m) * sizeof(double);
      else length = Mpval(n) * sizeof(double);
   }
   else
   {
      mpk = dgpk4amxamn;
      mupk = dgupk4amxamn;
      mupk_op = dgupk_amx;
      length = Mpval(m) * ( sizeof(double) + sizeof(unsigned short) );
      MatInf.B = (char *) cA;
      MatInf.ldb = Mpval(ldia);
   }

   if (Mpval(cdest) == -1) trdest = -1;
   else trdest = Mpval(rdest);
#if (BlacsDebugLvl > 0)
   ArgCheck00(Mpval(ConTxt), RT_COMB, __FILE__, tscope, 'u', 'u', Mpval(m),
              Mpval(n), Mpval(lda), 1, &trdest, Mpaddress(cdest));
   if (Mpval(ldia) < Mpval(m))
   {
      if (Mpval(ldia) != -1)
         BlacsWarn(Mpval(ConTxt), __LINE__, __FILE__,
                   "LDIA too small (LDIA=%d, but M=%d)", Mpval(ldia), Mpval(m));
   }
#endif
   if (Mpval(lda) >= Mpval(m)) tlda = Mpval(lda);
   else tlda = Mpval(m);
   if (Mpval(ldia) < Mpval(m)) tldia = Mpval(m);
   else tldia = Mpval(ldia);

   MatInf.M = Mpval(m);
   MatInf.N = Mpval(n);
   MatInf.A = (char *) A;
   MatInf.lda = tlda;
   buff = getbuff(length);

   if (Mpval(ldia) != -1)
   {
      switch(tscope)
      {
      case 'r':
         if (trdest == -1) mydist = ctxt->mycol;
         else mydist = (ctxt->npcol+ctxt->mycol-Mpval(cdest))%ctxt->npcol;
         break;
      case 'c':
         if (trdest == -1) mydist = ctxt->myrow;
         else mydist = (ctxt->nprow+ctxt->myrow-Mpval(rdest))%ctxt->nprow;
         break;
      case 'a':
         if (trdest == -1) mydist = ctxt->vIam;
         else
         {
            i = Mvkpnum(ctxt, Mpval(rdest), Mpval(cdest));
            mydist = (ctxt->Ng+ctxt->vIam-i)%ctxt->Ng;
         }
         break;
      }
      for (j=0; j < Mpval(n); j++)
      {
	 dist = (unsigned short *) &cA[j*tldia];
	 for (i=0; i < Mpval(m); i++) dist[i] = mydist;
      }
   }

   switch(ttop)
   {
   case ' ':
      tree_comb(ctxt, tscope, 2, &MatInf, buff, trdest, Mpval(cdest),
                mpk, mupk, mupk_op);
      break;
   case '1':
   case '2':
   case '3':
   case '4':
   case '5':
   case '6':
   case '7':
   case '8':
   case '9':
      tree_comb(ctxt, tscope, ttop-47, &MatInf, buff, trdest, Mpval(cdest),
                mpk, mupk, mupk_op);
      break;
   case 'f':
      tree_comb(ctxt, tscope, FULLCON, &MatInf, buff, trdest, Mpval(cdest),
                mpk, mupk, mupk_op);
      break;
   case 't':
      tree_comb(ctxt, tscope, ctxt->Nb_co, &MatInf, buff, trdest,
                Mpval(cdest), mpk, mupk, mupk_op);
      break;
   case 'h':
/*
 *    Use bidirectional exchange if everyone wants answer
 */
      if ( (trdest == -1) && !(ctxt->TopsCohrnt) )
         BE_comb(ctxt, tscope, &MatInf, buff, mpk, mupk, mupk_op);
      else
         tree_comb(ctxt, tscope, 2, &MatInf, buff, trdest, Mpval(cdest),
                   mpk, mupk, mupk_op);
      break;
   default :
      BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",*top);
   }

/*
 * If I am selected to receive answer
 */
   if ( ( (ctxt->myrow == trdest) && (ctxt->mycol == Mpval(cdest)) ) ||
        (trdest == -1) )
   {
/*
 *    Translate the unsigned short distances stored in cA array into
 *    row and column offsets of sources of each amx.
 */
      if (Mpval(ldia) != -1)
         TransDist(ctxt, tscope, Mpval(m), Mpval(n), rA, cA, tldia,
                   trdest, Mpval(cdest));
   }
}
