#include "Bdef.h"

#if (INTFACE == C_CALL)
void Cblacs_gridmap(ConTxt, usermap, ldup, nprow0, npcol0)
int  *ConTxt;
int  *usermap;
int  ldup;
int  nprow0;
int  npcol0;
#else
void blacs_gridmap_(ConTxt, usermap, ldup, nprow0, npcol0)
int  *ConTxt;
int  *usermap;
int  *ldup;
int  *nprow0;
int  *npcol0;
#endif
{
#if (INTFACE == C_CALL)
   void Cblacs_pinfo();
#else
   void blacs_pinfo_();
#endif
   void Ssend2d00();
   void Srecv2d00();

   int i, j, k, msgid, ctxtMinID, *iptr;
   int Ng, nprow, npcol;
   BLACSCONTEXT *ctxt, **tCTxts;
   extern BLACSCONTEXT **MyConTxts00;
   extern int Iam00, Np00, minID00, maxID00, availID00, MaxNCtxt00;
   extern int *pvmtids00;

/*
 * If first call to blacs_gridmap
 */
   if (availID00 == -1)
   {
#if (INTFACE == C_CALL)
      Cblacs_pinfo(&Iam00, &Np00);
#else
      blacs_pinfo_(&Iam00, &Np00);
#endif
   }

#if (BlacsDebugLvl > 0)
   if (*ConTxt != NOTINCONTEXT)
      BlacsWarn(-1, -1, "BLACS_GRIDINIT/BLACS_GRIDMAP",
      "Failure to call BLACS_GET before grid creation makes code non-portable");
#endif
   if (pvmtids00 == NULL)
      BlacsErr(-1, __LINE__, "BLACS_GRIDINIT/BLACS_GRIDMAP",
               "Must call SETPVMTIDS or BLACS_SETUP before creating grid");

   nprow = Mpval(nprow0);
   npcol = Mpval(npcol0);
   Ng = nprow * npcol;
   if ( (Ng > Np00) || (nprow < 1) || (npcol < 1) )
      BlacsErr(-1, -1, "BLACS_GRIDINIT/BLACS_GRIDMAP",
               "Illegal grid (%d x %d), #procs=%d", nprow, npcol, Np00);

/*
 * Weed out callers who are not participating in present grid
 */
   for (k=0; k < Ng; k++)
   {
      i = k % nprow;
      j = k / nprow;
      if (usermap[j*Mpval(ldup)+i] == pvmtids00[Iam00]) break;
   }
   if (k == Ng)
   {
      *ConTxt = NOTINCONTEXT;
      return;
   }

/*
 * ==================================================
 * Get new context and add it to my array of contexts
 * ==================================================
 */
   ctxt = (BLACSCONTEXT *) malloc(sizeof(BLACSCONTEXT));
/*
 * Find free slot in my context array
 */
   for (i=0; i < MaxNCtxt00; i++) if (MyConTxts00[i] == NULL) break;
/*
 * Get bigger context pointer array, if needed
 */
   if (i == MaxNCtxt00)
   {
      j = MaxNCtxt00 + MAXNCTXT;
      tCTxts = (BLACSCONTEXT **) malloc(j * sizeof(*tCTxts));
      for (i=0; i < MaxNCtxt00; i++) tCTxts[i] = MyConTxts00[i];
      MaxNCtxt00 = j;
      for(j=i; j < MaxNCtxt00; j++) tCTxts[j] = NULL;
      if (MyConTxts00) free(MyConTxts00);
      MyConTxts00 = tCTxts;
   }
   MyConTxts00[i] = ctxt;
   *ConTxt = i;

   ctxt->nprow = nprow;
   ctxt->npcol = npcol;
   ctxt->Ng = Ng;
   ctxt->Nr_bs = ctxt->Nr_co = 1;
   ctxt->Nb_bs = ctxt->Nb_co = 2;
   ctxt->coord2proc = (int *) malloc(Ng*sizeof(int));
   ctxt->TopsRepeat = ctxt->TopsCohrnt = 0;

/*
 * Define process grid. NOTE: fortran uses column-major order.
 */
   for (j=0; j < npcol; j++)
   {
      for (i=0; i < nprow; i++)
         ctxt->coord2proc[i*npcol+j] = usermap[j*Mpval(ldup)+i];
   }
   Mpcoord(ctxt, pvmtids00[Iam00], ctxt->myrow, ctxt->mycol);
   ctxt->vIam = Mvkpnum(ctxt, ctxt->myrow, ctxt->mycol);
/*
 * ===========================
 * Set up the message id stuff
 * ===========================
 */

/*
 * Find what I think minID should be
 */
   if (availID00 != -1) ctxtMinID = availID00;
   else ctxtMinID = minID00 + Np00;

#if (BlacsDebugLvl > 0)
   j = Np00 + 5;
#else
   j = 3;
#endif
   iptr = (int *) malloc(j * sizeof(int));

   if (ctxt->vIam == 0)
   {
/*
 *    Receive grid and start ID from other nodes
 */
      for (i=1; i < Ng; i++)
      {
         msgid = ctxt->coord2proc[i];
         for (k=0; ((k < Np00) && (pvmtids00[k] != msgid)); k++);
         if (k == Np00)
            BlacsErr(-1, __LINE__, "BLACS_GRIDINIT/BLACS_GRIDMAP",
                     "Non-BLACS PVM task calling BLACS_GRIDINIT/BLACS_GRIDMAP");
         msgid = minID00 + k;
         Srecv2d00(ctxt, msgid);
         k = pvm_upkint(&iptr[0], 1, 1);                 /* unpack nprow */
         Mpvmerror(k, "pvm_upkint", __LINE__, __FILE__);
         k = pvm_upkint(&iptr[1], 1, 1);                 /* unpack npcol */
         Mpvmerror(k, "pvm_upkint", __LINE__, __FILE__);
         k = pvm_upkint(&iptr[2], 1, 1);                 /* unpack ctxtMinID */
         Mpvmerror(k, "pvm_upkint", __LINE__, __FILE__);
         if (iptr[2] > ctxtMinID) ctxtMinID = iptr[2];
         if ( (iptr[0] != nprow) || (iptr[1] != npcol) )
            BlacsErr(-1, -1, "BLACS_GRIDINIT/BLACS_GRIDMAP",
                     "Process %d had %d x %d grid; correct is %d x %d",
                     ctxt->coord2proc[i], iptr[0], iptr[1], nprow, npcol);
/*
 *       If we are playing it safe, check some additional stuff
 */
#if (BlacsDebugLvl > 0)
         k = pvm_upkint(&iptr[3], 1, 1);                 /* unpack minID00 */
         Mpvmerror(k, "pvm_upkint", __LINE__, __FILE__);
         k = pvm_upkint(&iptr[4], 1, 1);                 /* unpack maxID00 */
         Mpvmerror(k, "pvm_upkint", __LINE__, __FILE__);
         k = pvm_upkint(&iptr[5], Ng, 1);                /* unpack coord2proc */
         Mpvmerror(k, "pvm_upkint", __LINE__, __FILE__);
/*
 *       Check we have same msgid range
 */
         if ( (iptr[3] != minID00) || (iptr[4] != maxID00) )
            BlacsErr(-1, -1, "BLACS_GRIDINIT/BLACS_GRIDMAP",
                     "Processes had different message ID ranges");
/*
 *       Check that we agree on mapping
 */
         for (k=0; k < Ng; k++)
         {
            if (iptr[k+5] != ctxt->coord2proc[k])
            {
               BlacsErr(-1, -1, "BLACS_GRIDINIT/BLACS_GRIDMAP",
                        "Process %d had incorrect grid map",
                        ctxt->coord2proc[k]);
            }
         }
/*
 *       Check we're using same virtual machine
 */
         k = pvm_upkint(iptr, Np00, 1);
         Mpvmerror(k, "pvm_upkint", __LINE__, __FILE__);
         for (k=0; k < Np00; k++)
         {
            if (iptr[k] != pvmtids00[k])
               BlacsErr(-1, -1, "BLACS_GRIDINIT/BLACS_GRIDMAP",
                        "Process %d had incorrect tid list",
                        ctxt->coord2proc[k]);
         }
#endif
      }
/*
 *    Send out minID for this context to use
 */
      Minitsend(i, __LINE__);
      i = pvm_pkint(&ctxtMinID, 1, 1);
      Mpvmerror(i, "pvm_pkint", __LINE__, __FILE__);
      for (i=1; i < Ng; i++)
      {
         msgid = ctxt->coord2proc[i];
         for (k=0; ((k < Np00) && (pvmtids00[k] != msgid)); k++);
         msgid = minID00 + k;
         Mvpcoord(ctxt, i, j, k);
         Ssend2d00(ctxt, j, k, msgid);
      }
   }
   else
   {
      msgid = minID00 + Iam00;
      Minitsend(i, __LINE__);
      i = pvm_pkint(&nprow, 1, 1);
      Mpvmerror(i, "pvm_pkint", __LINE__, __FILE__);
      i = pvm_pkint(&npcol, 1, 1);
      Mpvmerror(i, "pvm_pkint", __LINE__, __FILE__);
      i = pvm_pkint(&ctxtMinID, 1, 1);
      Mpvmerror(i, "pvm_pkint", __LINE__, __FILE__);
#if (BlacsDebugLvl > 0)
      i = pvm_pkint(&minID00, 1, 1);
      Mpvmerror(i, "pvm_pkint", __LINE__, __FILE__);
      i = pvm_pkint(&maxID00, 1, 1);
      Mpvmerror(i, "pvm_pkint", __LINE__, __FILE__);
      i = pvm_pkint(ctxt->coord2proc, Ng, 1);
      Mpvmerror(i, "pvm_pkint", __LINE__, __FILE__);
      i = pvm_pkint(pvmtids00, Np00, 1);
      Mpvmerror(i, "pvm_pkint", __LINE__, __FILE__);
#endif

      Ssend2d00(ctxt, 0, 0, msgid);
      Srecv2d00(ctxt, msgid);
      i = pvm_upkint(&ctxtMinID, 1, 1);
      Mpvmerror(i, "pvm_upkint", __LINE__, __FILE__);
   }
   free(iptr);

/*
 * Find begining and end of this context's IDs
 */
   ctxt->minID = ctxtMinID;
   k = (maxID00 - ctxt->minID) * IDPERC;   /* # of IDs for this context */
   ctxt->maxID = ctxt->minID + k;
   availID00 = ctxt->maxID + 1;
/*
 * Set up point to point IDs (they get half the range)
 */
   j = k / 2;                           /* # of IDs for pt2pt comm */
   ctxt->SDminID = ctxt->minID;
   ctxt->SDmaxID = ctxt->minID + j;
   ctxt->IDsPerNode = j / Ng;
   ctxt->SDmyminID = ctxt->IDsPerNode * ctxt->vIam + ctxt->SDminID;
   ctxt->SDcount = (int *) malloc(Ng*sizeof(int));
   ctxt->RVcount = (int *) malloc(Ng*sizeof(int));
   for (i=0; i < Ng; i++) ctxt->SDcount[i] = ctxt->RVcount[i] = 0;
/*
 * Set up scoped IDs
 */
   k = ( (k + 1) / 2 ) / 3;                /* # of IDs for each scope */
   ctxt->RminID = ctxt->SDmaxID + 1;
   ctxt->CminID = ctxt->RminID + k;
   ctxt->AminID = ctxt->CminID + k;

   ctxt->Rcount = ctxt->RminID;
   ctxt->Ccount = ctxt->CminID;
   ctxt->Acount = ctxt->AminID;

   if (ctxt->vIam == 0)
   {
      if (ctxt->IDsPerNode < 100)
         BlacsWarn(-1, -1, "BLACS_GRIDINIT/BLACS_GRIDMAP",
                 "Point to point message IDs will be reused every %d messages",
                 ctxt->IDsPerNode);
      if ( (ctxt->CminID - ctxt->RminID) < 100 )
         BlacsWarn(-1, -1, "BLACS_GRIDINIT/BLACS_GRIDMAP",
                   "Scoped message IDs will be reused every %d operations",
                   ctxt->CminID - ctxt->RminID);
   }
}
