#include "Bdef.h"

#if (INTFACE == C_CALL)
void Cblacs_setup(mypnum, nprocs)
int  *mypnum;
int  *nprocs;
#else
void blacs_setup_(mypnum, nprocs)
int  *mypnum;
int  *nprocs;
#endif
{
/*
 * blacs_setup_ allocates the pvm machine and spawns the processes as indicated
 * by the optional input file blacs_setup.dat.  The parameter nprocs is input on
 * node 0 (the spawning node), and output for all other nodes.  Mypnum is
 * output for all nodes.
 */
#include <string.h>
#define LEN 80
#define WAIT_SEC 30
#ifdef SpawnWithOneCall
#define SpawnFlag PvmTaskDefault
#else
#define SpawnFlag PvmTaskHost
#endif
#if (INTFACE == C_CALL)
   void Csetpvmtids();
#else
   void setpvmtids_();
#endif
   double Mwalltime();
   extern int Np00, Iam00, minID00;
   FILE *fpin;
   char INline[LEN], host[LEN], exenam[LEN], *cptr;
   struct pvmhostinfo *hptr;
   struct pvmtaskinfo *tptr;
   int *tids;
   int i, info, nhosts, nproc, mypar, mytid, spawnflag=0, nspawned=1;
   double t1;
   extern int *pvmtids00;

   if (pvmtids00)  /* just call BLACS_PINFO if machine already setup */
   {
      Cblacs_pinfo(mypnum, nprocs);
      return;
   }
   mytid = pvm_mytid();
   if (mytid < 0)
   {
      BlacsWarn(-1, __LINE__, __FILE__,
                "Must start PVM before calling BLACS_SETUP.  Aborting run.");
      exit(0);
   }
   mypar = pvm_parent();
   if (mypar == PvmNoParent)
   {
      if (*nprocs < 1)
      {
         BlacsWarn(-1, __LINE__, __FILE__,
                   "NPROCS=%d, must be at least 1.  Aborting run.");
         exit(0);
      }
#ifndef BLACSNoCatchout
      pvm_catchout(stdout);
#endif
      nproc = *nprocs;
      tids = (int *) malloc(nproc*sizeof(*tids));
      tids[0] = mytid;
/*
 *    Open blacs_setup.dat to get name of executable, spawn flags, and the
 *    machine names to add to virtual machine.
 */
      fpin = fopen("blacs_setup.dat", "r");
      if (fpin != NULL)
      {
         fprintf(stdout, "Reading in hosts from blacs_setup.dat\n");
         if ( fgets(INline, LEN, fpin) ) sscanf(INline, "%s", exenam);
         else BlacsErr(-1, __LINE__, __FILE__,
                       "blacs_setup.dat: illegal executable name");

         if ( fgets(INline, LEN, fpin) )
         {
            sscanf(INline, "%d", &spawnflag);
            if ( (spawnflag != PvmTaskDebug) && (spawnflag != PvmTaskTrace) &&
                 (spawnflag != 0) && (spawnflag != PvmTaskDebug+PvmTaskTrace) )
            {
               BlacsWarn(-1, __LINE__, __FILE__,
                         "Illegal PVM spawnflag(%d), ignored", spawnflag);
               spawnflag = 0;
            }
         }
         while ( fgets(INline, LEN, fpin) )
         {
            for (i=0; isspace(INline[i]); i++);
            if (INline[i]) /* if not a blank line */
            {
               sscanf(INline, "%s", host);
               pvm_config(&nhosts, &i, &hptr);
               for (i=0; i < nhosts; i++)
                  if ( !strcmp(hptr[i].hi_name, host) ) break;
/*
 *             Add to virtual machine if it's not already in virtual machine
 */
               if (i == nhosts)
               {
                  fprintf(stdout, "Adding host %s to virtual machine . . .\n",
                          host);
                  cptr = host;
                  pvm_addhosts(&cptr, 1, &info);
                  if (info < 0) fprintf(stderr,
   "WARNING: Error %d in adding host %s to virtual machine.\n", info, host);
               }
            }
         }
         fclose(fpin);
      }
/*
 *    If blacs_setup does not exist, get executable name from keyboard
 *    and spawn procs to preset virtual machine
 */
      else
      {
         fprintf(stdout, "File 'blacs_setup.dat' not found.  Spawning ");
         fprintf(stdout, "processes to current configuration.\n");
         fprintf(stdout, "Enter the name of the executable to run: ");
         fscanf(stdin, "%s", exenam);
      }
      spawnflag += SpawnFlag;
/*
 * Some MPP's want all spawning to be done with one call to pvm_spawn
 */
#ifdef SpawnWithOneCall
      if (nproc > 1)
      {
         fprintf(stdout, "Spawning %d more copies of %s\n", nproc-1, exenam);
         nspawned = info = pvm_spawn(exenam, NULL, spawnflag, NULL, nproc-1,
                                     &tids[1]);
         if (info < nproc-1)
         {
            if (info > 0) for (i=1; i < nproc; i++) if (tids[i] < 0) info = tids[i];
            fprintf(stderr, "ERROR #%d during pvm_spawn call.\n", info);
/*
 *          Give special help for most common error
 */
            if (info == PvmNoFile)
            {
                fprintf(stderr,
            "PVM could not find your executable.  Have you moved it into\n");
                fprintf(stderr, "your ~/pvm3/bin/<ARCH>/ directory?\n");
            }
            fprintf(stderr, "BLACS_SETUP exiting . . . \n");
            Minitsend(i, __LINE__);
            i = -1;
            pvm_pkint(&i, 1, 1);
            pvm_mcast(&tids[1], nspawned, minID00);
            pvm_exit();
            exit(1);
         }
      }
/*
 * Normally, spawn tasks to machines in explicit round-robin fashion
 */
#else
      pvm_tasks(tids[0], &i, &tptr);
      pvm_config(&nhosts, &i, &hptr);
/*
 *    Spawn processes to hosts in round robin fashion, beginning with the
 *    host after the one that the launcher was run on.
 */
      if (nproc > 1)
      {
         fprintf(stdout, "Spawning %d more copies of %s\n", nproc-1, exenam);
         for (i=0; (i < nhosts && hptr[i].hi_tid != tptr->ti_host); i++);
         i = (i+1) % nhosts;
      }
      while(nspawned < nproc)
      {
         while ( i < nhosts && nspawned < nproc)
         {
            fprintf(stdout, "Spawning process '%s' to host %s\n",
                    exenam, hptr[i].hi_name);
            info = pvm_spawn(exenam, NULL, spawnflag, hptr[i].hi_name,
                             1, &tids[nspawned]);
            if (info < 0 || tids[nspawned] < 0)
	    {
               if (tids[nspawned] < 0) info = tids[nspawned];
               fprintf(stdout, "ERROR #%d spawning process to host %s.\n",
		       info, hptr[i].hi_name);
/*
 *             Give special help for most commen error
 */
               if (info == PvmNoFile)
               {
                   fprintf(stderr,
               "PVM could not find your executable.  Have you moved it into\n");
                   fprintf(stderr, "your ~/pvm3/bin/<ARCH>/ directory?\n");
               }
               fprintf(stderr, "BLACS_SETUP exiting . . . \n");
               Minitsend(i, __LINE__);
               i = -1;
               pvm_pkint(&i, 1, 1);
               pvm_mcast(&tids[1], nspawned-1, minID00);
               pvm_exit();
               exit(1);
            }
	    nspawned++;
	    i++;
         }
         i=0;
      }
#endif
/*
 *    Wait for check in message from all spawned processes before proceeding
 */
      info = 1;
      for (i = 1; i < nproc; i++)
      {
	 info = 0;
	 t1 = Mwalltime();
         while ( ((Mwalltime() - t1) < WAIT_SEC) && (info == 0) )
	    info = pvm_probe(tids[i], minID00);
	 if (info > 0) pvm_recv(tids[i], minID00);
	 else break;
      }
/*
 *    If a process failed to check in, kill all other processes and exit
 */
      if (info <= 0)
      {
	 mypar = i;
	 for (i=1; i < nproc; i++) pvm_kill(tids[i]);
	 if (info < 0)
	 {
	    Mpvmerror(mypar, "pvm_probe", __LINE__, __FILE__);
         }
	 else
	 {
	    fprintf(stderr,
	    "Process #%d did not check in even though pvm_spawn succeeded.\n",
            mypar);
            fprintf(stderr,
"The most common cause of this is that there is not enough memory to start\n");
            fprintf(stderr,
            "all processes.  You can decrease program size or add machines\n");
            fprintf(stderr,
            "(assuming multiple processes are spawned to one machine).\n");
	    fprintf(stderr, "Exiting . . .\n");
	    exit(0);
         }
      }
/*
 *    Send out nprocs and tids to all spawned processes
 */
      Minitsend(i, __LINE__);
      i = pvm_pkint(&nproc, 1, 1);
      Mpvmerror(i, "pvm_pkint", __LINE__, __FILE__);
      i = pvm_pkint(tids, nproc, 1);
      Mpvmerror(i, "pvm_pkint", __LINE__, __FILE__);
      i = pvm_mcast(&tids[1], nproc-1, minID00);
      Mpvmerror(i, "pvm_mcast", __LINE__, __FILE__);
   }
   else
   {
/*
 *    Send 0 byte check-in message to parent
 */
      Minitsend(i, __LINE__);
      i = pvm_send(mypar, minID00);
      Mpvmerror(i, "pvm_send", __LINE__, __FILE__);
/*
 *    Receive number of processors and tids from node 0.  If there was a
 *    spawning error, nproc < 0, so we know to exit.
 */
      i = pvm_recv(mypar, minID00);
      Mpvmerror(i, "pvm_recv", __LINE__, __FILE__);
      i = pvm_upkint(&nproc, 1, 1);
      Mpvmerror(i, "pvm_upkint", __LINE__, __FILE__);
      if (nproc < 0)
      {
         pvm_exit();
         exit(1);
      }
      tids = (int *) malloc(nproc*sizeof(*tids));
      i = pvm_upkint(tids, nproc, 1);
      Mpvmerror(i, "pvm_upkint", __LINE__, __FILE__);
   }
#if (INTFACE == C_CALL)
   Csetpvmtids(nproc, tids);
#else
   setpvmtids_(&nproc, tids);
#endif
   free(tids);
   *mypnum = Iam00;
   *nprocs = Np00;
}
