/* Partial MPI library based on the Program-to-Program Communications
   ToolBox in the Macintosh OS.  No local buffering of messages is
   implemented, so that all messages must be received in the order sent,
   and receives with wildcard sources are not supported.
   the following subroutines are implemented:
   MPI_Init, MPI_Finalize, MPI_Send, MPI_Recv, MPI_Isend, MPI_Irecv
   MPI_Test, MPI_Wait, MPI_Sendrecv, MPI_Ssend, MPI_Issend, MPI_Waitall
   MPI_Waitany, MPI_Get_count, MPI_Initialized, MPI_Comm_size
   MPI_Comm_rank, MPI_Bcast, MPI_Barrier, MPI_Reduce, MPI_Scan
   MPI_Allreduce, MPI_Gather, MPI_Allgather, MPI_Scatter, MPI_Alltoall
   MPI_Gatherv, MPI_Allgatherv, MPI_Scatterv, MPI_Alltoallv
   MPI_Reduce_scatter, MPI_Abort, MPI_Wtime, MPI_Wtick, MPI_Type_extent
   The PPC Toolbox is described in Inside Macintosh: Interapplication
   Communication [Addison-Wesley, Reading, MA, 1993], chapter 11.
   The Message Passing Interface (MPI) is described in the reference,
   M. Snir, S. Otto, S. Huss-Lederman, D. Walker, and J. Dongarra,
   MPI: The Complete Reference [MIT Press, Cambridge, MA,1996].
   The file MPIerrs is used throughout for error messages
   written by viktor k. decyk, ucla
   copyright 1998-1999, regents of the university of california.
   all rights reserved.
   no warranty for proper operation of this software is given or implied.
   software or information may be copied, distributed, and used at own
   risk; it may not be distributed without this notice included verbatim
   with each file. 
   update: november 8, 2000                                             */

#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <math.h>
#include "mpi.h"

#include <Gestalt.h>
#include <PPCToolbox.h>
#include <Memory.h>
#include <Events.h>
#include <Windows.h>

#define MAXS  16
#define MAXM  16

/* internal mpi common block
   nproc = number of real or virtual processors obtained
   idproc = processor id
   srnum = array of session reference numbers for each participating node
   prnum = port reference number                                           */
   static int nproc = 0, idproc;
   static int srnum[MAXS+1];
   static short prnum;

/* internal common block for non-blocking messages
   curreq = request record for transmission parameters
   readwrec = PPCReadPB or PPCWritePB Record
   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */
   static int curreq[MAXM][5], monitor=1;
   static PPCReadPBRec readwrec[MAXM];

/* internal common block for message window
   cpptr = pointer to window structure
   crect = current drag region
   nsp = amount of space between boxes
   nbx = size of box
   nds = number of message sizes monitored  */

   static struct GrafPort *cpptr = 0;
   static Rect crect;
   static short nsp = 8, nbx = 16, nds = 24;

static FILE *unit2;

/* prototypes for internal procedures */

void clrport(char *portname, short *prnum);
void ctopascl(unsigned char *ichr, char *chr);
short ioresult(PPCReadPBRec *pblock);
int checkesc(long stk);
int imax(int val1, int val2);
int imin(int val1, int val2);
float flmax(float val1, float val2);
float flmin(float val1, float val2);
double dmax(double val1, double val2);
double dmin(double val1, double val2);
void iredux(int *recvbuf, int *sendbuf, int offset, int count, MPI_Op op);
void fredux(float *recvbuf, float *sendbuf, int offset, int count, MPI_Op op);  
void dredux(double *recvbuf, double *sendbuf, int offset, int count, MPI_Op op);
void writerrs(char *source, int ierror);
void messwin(int nvp);
void logmess(int idp, int lstat, int lsize, int tag);
void showmess(int idp, int istat, int istyle);
void showdism(int ibin,int nbin,int lmax,int istyle);
void delmess();

/* function definitions */

int MPI_Init(int *argc, char ***argv) {
/* initialize the MPI execution environment
   input: argc, argv, output: none
local data                                   */
   int ierror, nerr, nv, i;
   long response;
   short ierr;
   static short noerr = 0, notdone = 1;
   char ctemp;
   char *cnerr;
   PPCOpenPBRec openrec;
   PPCPortRec ppcport, remoteport;
   LocationNameRec locname, remotename;
   PPCInformPBRec informrec;
   PPCStartPBRec startrec;
   PPCRejectPBRec rejectrec;
   MPI_Status stat;
/* creator and type correspond to executables produced by Absoft */
   long creator = 'MRWE', ftype = 'APPL';
   char portname[34];
   char location[66];
   FILE *unit3;
/* internal mpi common block
   nproc = number of real or virtual processors obtained
   idproc = processor id
   srnum = array of session reference numbers for each participating node
   prnum = port reference number                                          */
/* internal common block for non-blocking messages
   curreq = request record for transmission parameters
   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */
/* initialize common block data */
   for (i = 0; i < MAXS+1; i++)
      srnum[i] = 0;
   for (i = 0; i < MAXM; i++) {
      for (nv = 0; nv < 5; nv++)
         curreq[i][nv] = 0;
   }
   unit2 = fopen("MPIerrs","w");
/*
   check status of PPC ToolBox
*/
/* get information about the operating environment */
   ierr = Gestalt(gestaltPPCToolboxAttr,&response);
   if (ierr != noerr) {
      fprintf(unit2,"PPC not supported on this computer\n");
      ierror = ierr;
      return ierror;
   }
/* check if gestaltPPCSupportsRealTime is set */
   nerr = response/4096;
   if ((nerr-2*(nerr/2)) != 1) {
      fprintf(unit2,"Initializing PPC\n");
/* initialize PPC Toolbox */
      ierr = PPCInit();
      if (ierr != noerr) {
         fprintf(unit2,"PPCInit Failed, ierr = %d\n",ierr);
         ierror = ierr;
         return ierror;
      }
      else
/* update information about the operating environment */
         ierr = Gestalt(gestaltPPCToolboxAttr,&response);
   }
   nerr = response/2;
/* check if gestaltPPCSupportsOutgoing is set */
   if ((nerr-2*(nerr/2)) != 1) {
      fprintf(unit2,"AppleTalk not enabled in Chooser\n");
      ierror = 3;
      return ierror;
   }
/* check if gestaltPPCSupportsIncoming is set */
   if ((response-2*nerr) != 1) {
      fprintf(unit2,"Program Linking not enabled in Sharing Setup CP\n");
      ierror = 4;
      return ierror;
   }
/*
   everyone opens a port
*/
/* open file containing portname (and possibly participating nodes)
   first line in nodelist file on all nodes contains common portname
   if the file is missing or empty, a default name of ppc_link is used */
   unit3 = fopen("nodelist","r");
   if (unit3) {
      cnerr = fgets(portname,33,unit3);
      if (!cnerr)
         strcpy(portname,"ppc_link");
/* replace trailing newlines with nulls */
      cnerr = strchr(portname,'\n');
      if (cnerr)
        cnerr[0] = '\0';
      if (portname[0]=='\0')
         strcpy(portname,"ppc_link");
   }
   else
      strcpy(portname,"ppc_link");
/* check if port name is already being used */
   prnum = 0;
   clrport(portname,&prnum);
/* set PPCPortRec */
/* script code = smRoman */
   ppcport.nameScript = 0;
/* set port name string to portname */
   ctopascl(ppcport.name,portname);
/* set selector to Creator and Type */
   ppcport.portKindSelector = 1;
/* set creator */
   ppcport.u.port.portCreator = creator;
/* set type */
   ppcport.u.port.portType = ftype;
/* set LocationNameRec */
/* set selector to NBPTypeLocation */
   locname.locationKindSelector = 2;
/* set object string to portname */
   ctopascl(locname.u.nbpType,portname);
/* set PPCOpenPBRec structure */
/* set ioCompletion code to NIL */
   openrec.ioCompletion = 0;
/* service type = ppcServiceRealTime and resFlag = 0 */
   openrec.serviceType = 1;
   openrec.resFlag = 0;
/* set pointer to ppcPortRec */
   openrec.portName = &ppcport;
/* set pointer to locationNameRec */
   openrec.locationName = &locname;
/* make port network visible */
   openrec.networkVisible = 1;
   openrec.nbpRegistered = 0;
/* open a PPC port synchronously */
   ierr = PPCOpenSync(&openrec);
   prnum = openrec.portRefNum;
   if (ierr != noerr) {
      fprintf(unit2,"PPCOpen Failed, ierr = %d\n",ierr);
      if (ierr==(-910))
         fprintf(unit2,"Another port is already open with this name\n");
      ierror = ierr;
      return ierror;
   }
/* write port reference number to file */
   else
      clrport(portname,&prnum);
/* debug */
   if (monitor==2)
      fprintf(unit2,"local portname=%s\n",portname);
/*
   determine if node is master (idproc=0) or slave (idproc>0).
   on the master node, the second and subsequent lines of nodelist file
   contain names of the nodes participating, in the format hostname@zone.
   if this list of nodes is missing, then the node is a slave.
   every node also makes a connection to itself.
*/
   nproc = 0;
   if (unit3) {
      cnerr = fgets(location,65,unit3);
   }
/* must be slave */
   if (!unit3 || !cnerr)
      idproc = 1;
   else {
/* replace trailing newlines with nulls */
      cnerr = strchr(location,'\n');
      if (cnerr)
         cnerr[0] = '\0';
/* must be slave */
      if (location[0]=='\0')
         idproc = 1;
/* must be master */
      else
         idproc = 0;
   }
/* 
   * * * begin main iteration loop * * *

   prepare to accept connection
*/
/* set PPCInformPBRec */
/* set ioCompletion code to NIL */
L10: informrec.ioCompletion = 0;
/* set portRefNum */
   informrec.portRefNum = prnum;
/* set autoAccept to false */
   informrec.autoAccept = 0;
/* for connections to oneself, set autoAccept to true */
   if (idproc==nproc)
      informrec.autoAccept = 1;
/* set pointer to ppcPortRec */
   informrec.portName = &remoteport;
/* set locationNameRec pointer to NIL */
   informrec.locationName = 0;
/* set userName pointer to NIL */
   informrec.userName = 0;
/* receive session requests asynchronously */
   ierr = PPCInformAsync(&informrec);
   if (ierr != noerr) {
      fprintf(unit2,"PPCInform failed, ierr=%d\n",ierr);
      ierror = ierr;
      nerr = MPI_Finalize();
      return ierror;
   }
/* for connections to oneself, set selector to NoLocation
   and jump to PPCStart                                    */
   if (idproc==nproc) {
      remotename.locationKindSelector = 0;
      goto L70;
   }
/* wait for connection */
L20: if (ioresult((PPCReadPBRec *)&informrec)==notdone) {
      if (checkesc(60)) {
         nerr = MPI_Finalize();
         exit(1);
      }
      else
         goto L20;
   }
   else {
      ierr = ioresult((PPCReadPBRec *)&informrec);
      if (ierr != noerr) {
         fprintf(unit2,"PPCInform failed, ierr=%d\n",ierr);
         ierror = ierr;
         nerr = MPI_Finalize();
         return ierror;
      }
   }
/* extract processor id on first connection */
   if (nproc==0)
      idproc = informrec.userData;
/* check if remote portname agrees with local portname */
   nv = ppcport.name[0];
   nerr = 0;
   for (i = 1; i <= nv; i++) {
      nerr += abs(ppcport.name[i] - remoteport.name[i]);
   }
/* set PPCRejectPBRec (also used for PPCAcceptPBRec) */
/* set ioCompletion code to NIL */
   rejectrec.ioCompletion = 0;
/* set session reference number */
   rejectrec.sessRefNum = informrec.sessRefNum;
/* accept if portnames agree */
   if (nerr==0) {
/* indicate willingness to accept incoming session request */
      ierr = PPCAcceptSync((PPCAcceptPBRec *)&rejectrec);
      if (ierr != noerr) {
         fprintf(unit2,"PPCAccept error, idproc, ierr = %d,%d\n",idproc,ierr);
         ierror = ierr;
         nerr = MPI_Finalize();
         return ierror;
      }
   }
/* reject if portnames disagree */
   else {
/* set rejectInfo code to 1 */
      rejectrec.rejectInfo = 1;
/* reject a session request */
      ierr = PPCRejectSync(&rejectrec);
      if (ierr != noerr) {
         fprintf(unit2,"PPCReject error, idproc, ierr = %d,%d\n",idproc,ierr);
         ierror = ierr;
      }
      else {
         fprintf(unit2,"Session rejected, idproc = %d\n",idproc);
         ierror = 5;
      }
/* make string length visible */
      remoteport.name[nv+1] = 0;
      fprintf(unit2,"remoteport = %s\n",remoteport.name[1]);
      nerr = MPI_Finalize();
      return ierror;
   }
   nproc += 1;
/* check for processor number overflow */
   if (nproc > MAXS) {
      fprintf(unit2,"processor number overflow, nproc = %d\n",nproc);
      ierror = 6;
      nerr = MPI_Finalize();
      return ierror;
   }
/* extract and store session reference number */
   srnum[nproc-1] = informrec.sessRefNum;
/* debug */
   if (monitor==2)
      fprintf(unit2,"connection accepted with idproc=%d\n",nproc-1);
/* accept more connections */
   if (idproc >= nproc)
      goto L10;
/*
   master prepares to start connection
*/
L40: nv = strlen(location);
/* find zone delimiter '@' */
   i = -1;
L50: i += 1;
   if (i >= nv)
      goto L60;
   if (location[i]=='@')
      goto L60;
   goto L50;
L60: nv = i;
/* set LocationNameRec */
/* set selector to NBPLocation */
   remotename.locationKindSelector = 1;
/* set object string to remote computer name */
   ctemp = location[nv];
   location[nv] = 0;
   ctopascl(remotename.u.nbpEntity.objStr,&location[0]);
   location[nv] = ctemp;
/* set type string to 'PPCToolBox' */
   ctopascl(remotename.u.nbpEntity.typeStr,"PPCToolbox");
/* set zone string to remote zone name */
   nv += 1;
   i = strlen(location);
   if (nv < i)
      ctopascl(remotename.u.nbpEntity.zoneStr,&location[nv]);
   else
      remotename.u.nbpEntity.zoneStr[0] = '\0';
/* set PPCStartPBRec */
/* set ioCompletion code to NIL */
L70: startrec.ioCompletion = 0;
/* set portRefNum */
   startrec.portRefNum = prnum;
/* service type = ppcServiceRealTime and resFlag = 0 */
   startrec.serviceType = 1;
   startrec.resFlag = 0;
/* set pointer to ppcPortRec */
   startrec.portName = &ppcport;
/* set pointer to locationNameRec */
   startrec.locationName = &remotename;
/* set rejectInfo to Null */
   startrec.rejectInfo = 0;
/* set userData to idproc */
   startrec.userData = nproc;
/* set userRefNum to guest */
   startrec.userRefNum = 0;
/* initiate a PPC session */
   ierr = PPCStartSync(&startrec);
   if (ierr != noerr) {
      fprintf(unit2,"PPCStart failed, ierr=%d\n",ierr);
      fprintf(unit2,"Trying to start %s\n",location);
      fprintf(unit2,"rejectInfo=%d\n",startrec.rejectInfo);
      if (startrec.rejectInfo==1)
         fprintf(unit2,"Port name not recognized\n");
      if (ierr==(-906))
         fprintf(unit2,"Port does not exist at destination\n");
      else if (ierr==(-912))
         fprintf(unit2,"Destination rejected the session request\n");
      else if (ierr==(-915))
         fprintf(unit2,"Unable to contact application\n");
      else if (ierr==(-926)) {
         fprintf(unit2,"Target application had no inform pending\n");
         fprintf(unit2,"nodelist may contain name of master node\n");
      }
      else if (ierr==(-932)) {
         fprintf(unit2,"Destination port requires authentication\n");
         fprintf(unit2,"Guest access probably not enabled\n");
      }
      ierror = ierr;
      nerr = MPI_Finalize();
      return ierror;
   }
/* for connections to oneself, sends use the inform session reference
   number and receives use the start session reference number         */
   if (idproc==nproc)
/* extract and store session reference number for sends to oneself */
      srnum[MAXS] = informrec.sessRefNum;
   nproc += 1;
/* check for processor number overflow */
   if (nproc > MAXS) {
      fprintf(unit2,"processor number overflow, nproc = %d\n",nproc);
      ierror = 6;
      nerr = MPI_Finalize();
      return ierror;
   }
/* extract session reference number */
   srnum[nproc-1] = startrec.sessRefNum;
/* debug */
   if (monitor==2)
      fprintf(unit2,"connection confirmed with idproc=%d\n",nproc-1);
/* pass current location to next node */
   if (nproc > (idproc+2))
      nerr = MPI_Send(location,16,MPI_INT,idproc+1,1,0);
/* read location of next node from file */
   if (idproc==0) {
      if ((nproc >= 2) || (!strcmp(location,"self"))) {
         if (!unit3)
            goto L80;
         cnerr = fgets(location,65,unit3);
         if (!cnerr)
            goto L80;
/* replace trailing newlines with nulls */
         cnerr = strchr(location,'\n');
         if (cnerr)
            cnerr[0] = '\0';
         if (location[0]=='\0')
            goto L80;
      }
   }
/* receive location of next node from another processor */
   else {
      nerr = MPI_Recv(location,16,MPI_INT,idproc-1,1,0,&stat);
/* end of file marker received */
      if (stat.len==0)
         goto L80;
   }
/* start another connection */
   goto L40;
/* 
   * * * end main iteration loop * * *
*/
/* all expected nodes activated */
L80: nv = nproc - 1;
/* debug */
   if (monitor==2)
      fprintf(unit2,"all nodes activated, idproc, nproc=%d,%d\n",
              idproc,nproc);
/* send null record to next processor */
   if (idproc < nv)
      nerr = MPI_Send(location,0,MPI_INT,idproc+1,1,0);
   if (unit3)
      fclose(unit3);
/* check number of processors */
   if (idproc==nv) {
      for (i = 1; i <= nv; i++) {
         nerr = MPI_Send(&nproc,1,MPI_INT,nv-i,2,0);
      }
   }
   else {
      nerr = MPI_Recv(&response,1,MPI_INT,nv,2,0,&stat);
/* local processor does not agree with last processor on total number */
      if (response != nproc) {
         fprintf(unit2,"processor number error, local/remote nproc = %d,%d\n",
                 nproc,response);
         ierror = 7;
         nerr = MPI_Finalize();
         return ierror;
      }
   }
/* Create window for showing MPI message status */
      if (monitor > 0) {
         messwin(nproc);
         checkesc(1);
      }
/* set errror code to success */
   ierror = 0;
   return ierror;
}

void clrport(char *portname, short *prnump) {
/* this subroutine checks to see if requested port name has already been
   used, and if so, it closes the old port.  this is necessary because
   applications which terminate abnormally can leave open ports.
   a file is created whose name is the port name and whose only contents
   is the port reference number (needed to close the port)
   if prnump = 0, the file is read (if it exists), and the port closed.
   otherwise, the current port reference number is written to the file
local data                                                              */
   int lc, nerr, iprnum;
   short ierr;
   char ctemp;
   PPCClosePBRec closerec;
   FILE *unit4;
   lc = strlen(portname);
   if (lc < 1)
      return;
/* omit trailing blanks */
L10:  if (portname[lc-1]==' ') {
      lc -= 1;
      if (lc > 0)
         goto L10;
   }
   if (lc < 1)
      return;
   ctemp = portname[lc];
   portname[lc] = 0;
   if (*prnump != 0) {
      unit4 = fopen(portname,"w+");
      fprintf(unit4,"%d\n",*prnump);
      fclose(unit4);
   }
   else {
      unit4 = fopen(portname,"r");
      if (unit4) {
         nerr = fscanf(unit4,"%d",&iprnum);
         *prnump = iprnum;
/* set PPCClosePBRec structure */
/* set ioCompletion to NIL */
         closerec.ioCompletion = 0;
/* set port reference number */
         closerec.portRefNum = *prnump;
/* close a PPC Port synchronously */
         ierr = PPCCloseSync(&closerec);
         if (ierr==0)
            fprintf(unit2,"closed old port: %s\n",portname);
         fclose(unit4);
      }
   }
   portname[lc] = ctemp;
   return;
}

void ctopascl(unsigned char *uchr, char *chr) {
/* this subroutine converts c style stings into pascal style strings
   trailing blanks are omitted.
   ichr = output characters
   chr = input characters
local data                                                           */
/* nd = number of words of output written */
   short nd = 0;
   int lc, i;
   lc = strlen(chr);
   if (lc < 1)
      return;
/* omit trailing blanks */
L10: if (chr[lc-1]==' ') {
      lc -= 1;
      if (lc > 0)
         goto L10;
   }
   if (lc < 1)
      return;
/* set length */
   uchr[0] = lc;
/* copy remaining characters */
   for (i = 0; i < lc; i++) {
      uchr[i+1] = chr[i];
   }
/* set output length */
   nd = lc + 1;
/* debug */
/* uchr[nd] = 0; */
   return;
}

short ioresult(PPCReadPBRec *pblock) {
/* this function returns ioResult for asynchronous PPC procedures
   input: pblock                                                  */
   return pblock->ioResult;
}

int checkesc(long stk) {
/* this procedure allows user to abort a procedure by checking for
   escape, Cmd-. or Ctrl-C keystrokes.  Calling WaitNextEvent also
   permits an idle procedure to time-share and checks for Quit Events
   returns true if an escape event occurred
   stk = maximum number of sleepTicks (sixtieths of a second) that
   application agrees to relinquish the processor if no events are 
   pending for it
   input: stk
local data                                                   */
/* myEventMask looks for mouse, keyboard, and quit events    */
   short myEventMask = 1086;
   EventRecord event;
   int key, nvp;
   struct GrafPort *which;
   int checkesc = 0;
/* internal common block for message window
   cpptr = pointer to window structure
   crect = current drag region                            */
/* if monitor window is open, look for update events also */
   if (cpptr)
      myEventMask += 64;
/* receive next event from event manager */
   if (WaitNextEvent(myEventMask,&event,stk,0)) {
      if ((event.what==keyDown) || (event.what==autoKey)) {
/* check for escape key */
         key = event.message - 256*(event.message/256);
         if (key==27)
            checkesc = 1;
/* check for Cmd-. */
         else if (key==46) {
            if ((event.modifiers/256) != (2*(event.modifiers/512)))
               checkesc = 1;
         }
/* check for Ctrl-C */
         else if (key==3)
            checkesc = 1;
      }
/* check for 'QuitApplication' Apple Event */
      else if (event.what==kHighLevelEvent) {
         if ((event.where.v=='qu') && (event.where.h=='it')) {
            fprintf(unit2,"Quit Application Apple Event received\n");
            key = MPI_Abort(MPI_COMM_WORLD,998);
            exit(1);
         }
      }
/* check for update events */
      else if (event.what==updateEvt) {
/* get window pointer */
         if (cpptr==(struct GrafPort *)event.message) {
/* signal start of window update */
            BeginUpdate(cpptr);
            key = MPI_Comm_size(MPI_COMM_WORLD,&nvp);
            messwin(nvp);
/* signal end of update after BeginUpdate */
            EndUpdate(cpptr);
         }
      }
/* check for drag window event */
      else if (event.what==mouseDown) {
/* see which window part, including menu bar, is at a point */
         if (FindWindow(event.where,&which)==4) {
/* track the mouse and move a window */
            if (cpptr==which)
               DragWindow(cpptr,event.where,&crect);
         }
      }
   }
   return checkesc;
}

int MPI_Finalize(void) {
/* terminate MPI execution environment
local data                             */
   int ierror, i;
   short ierr;
   static short noerr = 0;
   PPCEndPBRec endrec;
   PPCClosePBRec closerec;
/* internal mpi common block
   nproc = number of real or virtual processors obtained */
/* internal common block for non-blocking messages
   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */
/* set PPCEndPBRec */
   for (i = 0; i < nproc; i++) {
/* set ioCompletion code to NIL */
      endrec.ioCompletion = 0;
/* set session reference number */
      endrec.sessRefNum = srnum[i];
/* end a PPC Session */
      ierr = PPCEndSync(&endrec);
      if (ierr != noerr)
         fprintf(unit2,"PPCEnd failed, i, ierr= %d,%d\n",i,ierr);
   }
/* set PPCClosePBRec structure */
/* set ioCompletion to NIL */
   closerec.ioCompletion = 0;
/* set port reference number */
   closerec.portRefNum = prnum;
   ierror = 0;
/* MPI already finalized */
   if (nproc <= 0)
      ierror = 1;
/* close a PPC Port synchronously */
   ierr = PPCCloseSync(&closerec);
   if (ierr != noerr) {
      fprintf(unit2,"PPCClose Failed, ierr, prnum = %d,%d\n",ierr,prnum);
      ierror = ierr;
   }
/* Close window for showing MPI message status */
   if (monitor > 0) {
      logmess(0,0,-1,0);
      delmess();
   }
/* nullify nproc */
   nproc = 0;
/* nullify session reference numbers */
   for (i = 0; i < MAXS; i++) {
      srnum[i] = 0;
   }
/* delete file if empty */
   if (!fseek(unit2,0,SEEK_END)) {
      i = ftell(unit2);
      fclose(unit2);
      if (!i)
         remove("MPIerrs");
   }
   return ierror;
}

int MPI_Send(void* buf, int count, MPI_Datatype datatype, int dest,
             int tag, MPI_Comm comm) {
/* blocking standard mode send
   buf = initial address of send buffer
   count = number of entries to send
   datatype = datatype of each entry
   dest = rank of destination
   tag = message tag
   comm = communicator (only MPI_COMM_WORLD currently supported)
   input: buf, count, datatype, dest, tag, comm
local data                                                       */
   int ierror;
   MPI_Request request;
   MPI_Status status;
   ierror = MPI_Isend(buf,count,datatype,dest,tag,comm,&request);
   ierror = MPI_Wait(&request,&status);
   return ierror;
}
 
int MPI_Recv(void* buf, int count, MPI_Datatype datatype, int source,
             int tag, MPI_Comm comm, MPI_Status *status) {
/* blocking receive
   buf = initial address of receive buffer
   count = maximum number of entries to receive
   datatype = datatype of each entry
   source = rank of source
   tag = message tag
   comm = communicator (only MPI_COMM_WORLD currently supported)
   status = return status
   input: count, datatype, source, tag, comm
   output: buf, status
local data                                                       */
   int ierror;
   MPI_Request request;
   ierror = MPI_Irecv(buf,count,datatype,source,tag,comm,&request);
   ierror = MPI_Wait(&request,status);
   return ierror;
}

int MPI_Isend(void* buf, int count, MPI_Datatype datatype, int dest,
              int tag, MPI_Comm comm, MPI_Request *request) {
/* start a non-blocking send
   buf = initial address of send buffer
   count = number of entries to send
   datatype = datatype of each entry
   dest = rank of destination
   tag = message tag
   comm = communicator (only MPI_COMM_WORLD currently supported)
   request = request handle
   input: buf, count, datatype, dest, tag, comm
   output: request
local data                                                           */
   int ierror, longw, i;
   short ierr;
   static short noerr = 0;
/* internal mpi common block
   nproc = number of real or virtual processors obtained
   srnum = array of session reference numbers for each participating node */
/* internal common block for non-blocking messages
   curreq = request record for transmission parameters
   readwrec = PPCReadPB or PPCWritePB Record
   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */
   ierror = 0;
/* find space for record */
   i = -1;
L10: i += 1;
   if (i >= MAXM) {
      fprintf(unit2,"too many sends waiting, dest, tag = %d,%d,\n",
              dest,tag);
      *request = -1;
      ierror = 14;
      writerrs("MPI_Isend: ",ierror);
      return ierror;
   }
   else if (curreq[i][0])
      goto L10;
/* check for error conditions */
/* MPI not initialized        */
   if (nproc <= 0)
      ierror = 1;
/* invalid comm */
   else if (comm > MPI_COMM_WORLD)
      ierror = 2;
/* invalid count */
   else if (count < 0)
      ierror = 3;
/* invalid destination */
      else if ((dest < 0) || (dest >= nproc)) {
         fprintf(unit2,"destination = %d\n",dest);
         ierror = 4;
      }
/* invalid tag */
      else if (tag < (-1))
         ierror = 6;
/* handle errors */
   if (ierror) {
      writerrs("MPI_Isend: ",ierror);
      return ierror;
   }
/* set PPCWritePBRec */
/* set ioCompletion code to NIL */
   readwrec[i].ioCompletion = 0;
/* set session reference number */
/* for connections to oneself, sends use the inform session reference */
   if (idproc==dest)
      readwrec[i].sessRefNum = srnum[MAXS];
   else
/* normal reference number */
      readwrec[i].sessRefNum = srnum[dest];
/* find buffer length */
   if ((datatype==MPI_INT) || (datatype==MPI_FLOAT))
      longw = 4*count;
   else if (datatype==MPI_DOUBLE)
      longw = 8*count;
   else if (datatype==MPI_BYTE)
      longw = count;
/* invalid datatype */
   else {
      ierror = 7;
      writerrs("MPI_Isend: ",ierror);
      return ierror;
   }
/* set buffer length */
   readwrec[i].bufferLength = longw;
/* set buffer pointer */
   readwrec[i].bufferPtr = (char *)buf;
/* set more flag to FALSE */
   readwrec[i].more = 0;
/* set userData to tag */
   readwrec[i].userData = tag;
/* set blockCreator to comm */
   readwrec[i].blockCreator = comm;
/* set blockType to datatype */
   readwrec[i].blockType = datatype;
/* write to an application during a ppc session */
   ierr = PPCWriteAsync((PPCWritePBRec *)&readwrec[i]);
/* check for write errors */
   if (ierr != noerr) {
      fprintf(unit2,"PPCWrite Error, ierr, dest, tag = %d,%d,%d\n",
              ierr,dest,tag);
      if (ierr==(-917))
         fprintf(unit2,"The session has closed\n");
      ierror = ierr;
      writerrs("MPI_Isend: ",ierror);
   }
/* log MPI message state change and display status */
   if (monitor > 0) 
      logmess(dest,1,longw,tag);
/* save transmission mode as send */
   curreq[i][0] = -1;
/* save destination/source id */
   curreq[i][1] = dest;
/* save communicator */
   curreq[i][2] = comm;
/* save tag */
   curreq[i][3] = tag;
/* save datatype */
   curreq[i][4] = datatype;
/* assign request handle */
   *request = i;
   return ierror;
}

int MPI_Irecv(void* buf, int count, MPI_Datatype datatype, int source,
              int tag, MPI_Comm comm, MPI_Request *request) {
/* begin a non-blocking receive
   buf = initial address of receive buffer
   count = maximum number of entries to receive
   datatype = datatype of each entry
   source = rank of source
   tag = message tag
   comm = communicator (only MPI_COMM_WORLD currently supported)
   request = request handle
   input: count, datatype, source, tag, comm
   output: buf, request
local data                                                           */
   int ierror, longw, i;
   short ierr;
   static short noerr = 0;
/* internal mpi common block
   nproc = number of real or virtual processors obtained
   srnum = array of session reference numbers for each participating node */
/* internal common block for non-blocking messages
   curreq = request record for transmission parameters
   readwrec = PPCReadPB or PPCWritePB Record
   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */
   ierror = 0;
/* find space for record */
   i = -1;
L10: i += 1;
   if (i >= MAXM) {
      fprintf(unit2,"too many receives waiting, source, tag = %d,%d,\n",
              source,tag);
      *request = -1;
      ierror = 15;
      writerrs("MPI_Irecv: ",ierror);
      return ierror;
   }
   else if (curreq[i][0])
      goto L10;
/* check for error conditions */
/* MPI not initialized        */
   if (nproc <= 0)
      ierror = 1;
/* invalid comm */
   else if (comm > MPI_COMM_WORLD)
      ierror = 2;
/* invalid count */
   else if (count < 0)
      ierror = 3;
/* invalid source */
      else if ((source < 0) || (source >= nproc)) {
         if (source==MPI_ANY_SOURCE)
            fprintf(unit2,"MPI_ANY_SOURCE not supported\n");
         else
            fprintf(unit2,"source = %d\n",source);
         ierror = 5;
      }
/* invalid tag */
      else if (tag < (-1))
         ierror = 6;
/* handle errors */
   if (ierror) {
      writerrs("MPI_Irecv: ",ierror);
      return ierror;
   }
/* set PPCReadPBRec */
/* set ioCompletion code to NIL */
   readwrec[i].ioCompletion = 0;
/* set session reference number */
   readwrec[i].sessRefNum = srnum[source];
/* find buffer length */
   if ((datatype==MPI_INT) || (datatype==MPI_FLOAT))
      longw = 4*count;
   else if (datatype==MPI_DOUBLE)
      longw = 8*count;
   else if (datatype==MPI_BYTE)
      longw = count;
/* invalid datatype */
   else {
      ierror = 7;
      writerrs("MPI_Irecv: ",ierror);
      return ierror;
   }
/* set buffer length */
   readwrec[i].bufferLength = longw;
/* set buffer pointer */
   readwrec[i].bufferPtr = (char *)buf;
/* read incoming data from an application */
   ierr = PPCReadAsync(&readwrec[i]);
/* check for read errors */
   if (ierr != noerr) {
      fprintf(unit2,"PPCRead Error, ierr, source, tag = %d,%d,%d\n",
              ierr,source,tag);
      if (ierr==(-917))
         fprintf(unit2,"The session has closed\n");
      ierror = ierr;
      writerrs("MPI_Irecv: ",ierror);
      return ierror;
   }
/* log MPI message state change and display status */
   if (monitor > 0) 
      logmess(source,2,longw,tag);
/* save transmission mode as receive */
   curreq[i][0] = 1;
/* save destination/source id */
   curreq[i][1] = source;
/* save communicator */
   curreq[i][2] = comm;
/* save tag */
   curreq[i][3] = tag;
/* save datatype */
   curreq[i][4] = datatype;
/* assign request handle */
   *request = i;
   return ierror;
}

int MPI_Test(MPI_Request *request, int *flag, MPI_Status *status) {
/* check to see if a nonblocking send or receive operation has completed
   request = request handle
   flag = true if operation completed
   status = status object
   input: request
   output: request, flag, status
local data                                                              */
   int ierror, i, dest, source, slen, tag, rlen, rtag, nerr;
   char *longw;
   short ierr;
   static short noerr = 0, notdone = 1;
   MPI_Comm comm, rcomm;
   MPI_Datatype datatype, rdatat;
/* internal mpi common block
   nproc = number of real or virtual processors obtained */
/* internal common block for non-blocking messages
   curreq = request record for transmission parameters
   readwrec = PPCReadPB or PPCWritePB Record
   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */
   ierror = 0;
/* check for error conditions */
/* set status to empty */
   status->source = -1;
   status->tag = -1;
   status->error = ierror;
   status->len = 0;
   status->type = 0;
   i = *request;
/* MPI not initialized */
   if (nproc <= 0)
      ierror = 1;
/* null request */
   else if (*request < 0) {
      *flag = 1;
      return 0;
   }
/* invalid request handle */
   else if (i >= MAXM)
      ierror = 16;
   else if (curreq[i][0]==0)
      ierror = 16;
/* handle errors */
   if (ierror) {
      status->error = ierror;
      writerrs("MPI_Test: ",ierror);
      return ierror;
   }
   *flag = 0;
L10: if (ioresult(&readwrec[i])==notdone) {
      if (checkesc(1)) {
         nerr = MPI_Abort(MPI_COMM_WORLD,999);
         exit(1);
      }
/* if Incomplete Read bug has occurred, wait for the remainder */
      else {
         if (*flag)
            goto L10;
         return ierror;
      }
   }
   else {
      ierr = ioresult(&readwrec[i]);
      *flag = 1;
   }
/* get requested length */
   slen = readwrec[i].bufferLength;
/* get actual length */
   rlen = readwrec[i].actualLength;
/* read current request record */
   dest = curreq[i][1];
   tag = curreq[i][3];
/* check for send errors */
   if (curreq[i][0] < 0) {
/* check for write errors */
      if (ierr != noerr) {
         fprintf(unit2,"PPCWrite Error, ierr, dest, tag = %d,%d,%d\n",
                 ierr,dest,tag);
         if (ierr==(-917))
            fprintf(unit2,"The session has closed\n");
         ierror = ierr;
      }
      else if (rlen != slen) {
         fprintf(unit2,"Send Length Error, dest, tag, requested/actual length = %d,%d,%d,%d\n",
                 dest,tag,slen,rlen);
         ierror = 8;
      }
/* define length and type for MPI_Get_count */
      status->len = rlen;
      status->type = curreq[i][4];
/* log MPI message state change and display status */
      if (monitor > 0) {
         if (!ierror)
            logmess(dest,-1,rlen,tag);
      }
      goto L30;
   }
/* read current request record */
   source = curreq[i][1];
   comm = curreq[i][2];
   datatype = curreq[i][4];
   status->source = source;
   status->len += rlen;
/* get received tag from userData */
   rtag = readwrec[i].userData;
   status->tag = rtag;
/* get received comm from blockCreator */
   rcomm = readwrec[i].blockCreator;
/* get received datatype from blockType */
   rdatat = readwrec[i].blockType;
   status->type = rdatat;
/* check for read errors */
   if (ierr != noerr) {
      fprintf(unit2,"PPCRead Error, ierr, source, tag = %d,%d,%d\n",
              ierr,source,tag);
      if (ierr==(-917))
         fprintf(unit2,"The session has closed\n");
      ierror = ierr;
   }
/* comm error */
   else if (rcomm != comm) {
      fprintf(unit2,"Read Comm Error, source, tag, expected/received comm = %d,%d,%d,%d\n",
              source,tag,comm,rcomm);
      ierror = 9;
   }
/* tag error */
   else if ((tag >= 0) && (rtag != tag)) {
      fprintf(unit2,"Read Tag Error, source, expected/received tag = %d,%d,%d\n",
              source,tag,rtag);
      ierror = 10;
   }
/* type error */
   else if (rdatat != datatype) {
      fprintf(unit2,"Read Type Error, source, tag, expected/received type = %d,%d,%d,%d\n",
              source,tag,datatype,rdatat);
      ierror = 11;
   }
/* incomplete data error */
   else if (readwrec[i].more) {
      fprintf(unit2,"Incomplete Read, source, tag, requested/actual = %d,%d,%d,%d\n",    
              source,tag,slen,rlen);
      slen -= rlen;
/* this case is a workaround for a PPC Toolbox bug */
      if (slen==0) {
         readwrec[i].bufferLength = 4;
         longw = (char *)&nerr;
      }
/* get more data */
      else if (slen > 0) {
         readwrec[i].bufferLength = slen;
         longw = readwrec[i].bufferPtr + rlen;
      }
      else {
         ierror = 12;
         goto L30;
      }
/* set buffer pointer */
      readwrec[i].bufferPtr = longw;
/* read incoming data from an application */
      ierr = PPCReadAsync(&readwrec[i]);
/* check for read errors */
      if (ierr != noerr) {
         fprintf(unit2,"PPCRead Error, ierr, source, tag = %d,%d,%d\n",
                 ierr,source,tag);
         ierror = ierr;
         goto L30;
      }
      goto L10;
   }
/* length error */
   else if (rlen > slen) {
      fprintf(unit2,"Read Length Error, source, tag, requested/actual = %d,%d,%d,%d\n",
              source,tag,slen,rlen);
      ierror = 13;
   }
/* log MPI message state change and display status */
      if (monitor > 0) {
         if (!ierror)
            logmess(source,-2,rlen,tag);
      }
/* store error code */
L30: status->error = ierror;
/* nullify transmission mode */
   curreq[i][0] = 0;
/* nullify request handle */
   *request = -1;
/* handle read and write errors */
   if (ierror)
      writerrs("MPI_Test: ",ierror);
   return ierror;
}

int MPI_Wait(MPI_Request *request, MPI_Status *status) {
/* wait for an MPI send or receive to complete
   request = request handle
   status = status object
   input: request
   output: request, status
local data                                     */
   int ierror, flag;
L10: ierror = MPI_Test(request,&flag,status);
   if (!flag) goto L10;
   return ierror;
}

int MPI_Sendrecv(void* sendbuf, int sendcount, MPI_Datatype sendtype,
                 int dest, int sendtag, void* recvbuf, int recvcount,
                 MPI_Datatype recvtype, int source, int recvtag,
                 MPI_Comm comm, MPI_Status *status) {
/* blocking send and receive operation
   sendbuf = initial address of send buffer
   sendcount = number of entries to send
   sendtype = type of entries in send buffer
   dest = rank of destination
   sendtag = send tag
   recvbuf = initial address of receive buffer
   recvcount = max number of entries to receive
   recvtype = type of entries in receive buffer
   source = rank of source
   recvtag = receive tag
   comm = communicator (only MPI_COMM_WORLD currently supported)
   status = return status
   input: sendbuf, sendcount, sendtype, dest, sendtag, recvbuf, recvcount
         recvtype, source, recvtag, comm
   output: recvbuf, status
local data                                                                */
   int ierror;
   MPI_Request recvreq, sendreq;
/* post non-blocking receive and send */
   ierror = MPI_Irecv(recvbuf,recvcount,recvtype,source,recvtag,comm,&recvreq);
   ierror = MPI_Isend(sendbuf,sendcount,sendtype,dest,sendtag,comm,&sendreq);
/* wait for send and receive */
   ierror = MPI_Wait(&sendreq,status);
   ierror = MPI_Wait(&recvreq,status);
   return ierror;
}

int MPI_Ssend(void* buf, int count, MPI_Datatype datatype, int dest,
              int tag, MPI_Comm comm) {
/* blocking synchronous mode send
   buf = initial address of send buffer
   count = number of entries to send
   datatype = datatype of each entry
   dest = rank of destination
   tag = message tag
   comm = communicator (only MPI_COMM_WORLD currently supported)
   input: buf, count, datatype, dest, tag, comm
local data                                                           */
   int ierror;
   ierror = MPI_Send(buf,count,datatype,dest,tag,comm);
   return ierror;
}

int MPI_Issend(void* buf, int count, MPI_Datatype datatype, int dest,
               int tag, MPI_Comm comm, MPI_Request *request) {
/* start a non-blocking synchronous mode send
   buf = initial address of send buffer
   count = number of entries to send
   datatype = datatype of each entry
   dest = rank of destination
   tag = message tag
   comm = communicator (only MPI_COMM_WORLD currently supported)
   request = request handle
   input: buf, count, datatype, dest, tag, comm
   output: request
local data                                                        */
   int ierror;
   ierror = MPI_Isend(buf,count,datatype,dest,tag,comm,request);
   return ierror;
}

int MPI_Waitall(int count, MPI_Request *array_of_requests,
                MPI_Status *array_of_statuses) {
/* wait for a collection of specified MPI sends or receives to complete
   count = list length
   array_of_requests = array of request handles
   array_of_statuses = array of status objects
   input: count, array_of_requests
   output: array_of_requests, array_of_statuses
local data                                                             */
   int ierror, i, ierr;
/* invalid count */
   if (count < 0) {
      fprintf(unit2,"Invalid list length = %d\n",count);
      ierror = 17;
      writerrs("MPI_Waitall: ",ierror);
      return ierror;
   }
   ierror = 0;
   for (i = 0; i < count; i++) {
      ierr = MPI_Wait(&array_of_requests[i],&array_of_statuses[i]);
      if (ierr)
      ierror = MPI_ERR_IN_STATUS;
   }
   return ierror;
}

int MPI_Waitany(int count, MPI_Request *array_of_requests,
                int *index, MPI_Status *status) {
/* wait for any specified MPI send or receive to complete
   count = list length
   array_of_requests = array of request handles
   index = index of request handle that completed
   status = status object
   input: count, array_of_requests
   output: array_of_requests, index, status
local data                                                 */
   int ierror, i, k, flag;
/* invalid count */
   if (count < 0) {
      fprintf(unit2,"Invalid list length = %d\n",count);
      ierror = 17;
      writerrs("MPI_Waitany: ",ierror);
      return ierror;
   }
/* find number of requests already completed */
   k = 0;
   for (i = 0; i < count; i++)
      if (array_of_requests[i] < 0)
         k = k + 1;
   if (k==count) {
      *index = -1;
      ierror = 0;
      return ierror;
   }
   i = 0;
L20: flag = 0;
   if (array_of_requests[i] >= 0)
      ierror = MPI_Test(&array_of_requests[i],&flag,status);
   if (flag)
      *index = i;
   else {
      i += 1;
      if (i >= count)
         i = 0;
      goto L20;
   }
   return ierror;
}

int MPI_Get_count(MPI_Status *status, MPI_Datatype datatype,
                  int *count) {
/* get the number of "top level" elements
   status = return status of receive operation
   datatype = datatype of each receive buffer entry
   count = number of received entries
   input: status, datatype
   output: count
local data                                           */
   int ierror;
/* internal mpi common block
   nproc = number of real or virtual processors obtained    */     
   ierror = 0;
   *count = 0;
/* MPI not initialized */
   if (nproc <= 0)
      ierror = 1;
/* mismatched datatype */
   else if (datatype != status->type)
      ierror = 18;
/* calculate count */
   else if ((datatype==MPI_INT) || (datatype==MPI_FLOAT)) {
      *count = status->len/4;
      if (4*(*count) != status->len)
         *count = MPI_UNDEFINED;
   }
   else if (datatype==MPI_DOUBLE) {
      *count = status->len/8;
      if (8*(*count) != status->len)
         *count = MPI_UNDEFINED;
   }
   else if (datatype==MPI_BYTE)
      *count = status->len;
/* invalid datatype */
   else
      ierror = 7;
/* handle errors */
   if (ierror)
      writerrs("MPI_Get_count: ",ierror);
   return ierror;
}

int MPI_Initialized(int *flag) {
/* indicate whether MPI_Init has been called
   flag = true if MPI_Init has been called, false otherwise
   output: flag
local data                                                  */
   int ierror;
/* internal mpi common block
   nproc = number of real or virtual processors obtained    */
   if (nproc > 0)
      *flag = 1;
   else
      *flag = 0;
   ierror = 0;
   return ierror;
}

int MPI_Comm_size(MPI_Comm comm, int *size) {
/* determine the size of the group associated with a communicator
   comm = communicator (this is ignored)
   size = number of processors in the group of comm
   input: comm
   output: size
local data                                                         */
   int ierror;
/* internal mpi common block
   nproc = number of real or virtual processors obtained           */
/* check for error conditions */
/* MPI not initialized */
   if (nproc <= 0)
      ierror = 1;
/* invalid comm */
   else if (comm != MPI_COMM_WORLD)
      ierror = 2;
/* get size */
   else {
      *size = nproc;
      ierror = 0;
   }
/* handle errors */
   if (ierror)
      writerrs("MPI_Comm_size: ",ierror);
   return ierror;
}

int MPI_Comm_rank(MPI_Comm comm, int *rank) {
/* determine the rank of the calling process in the communicator
   comm = communicator (this is ignored)
   rank = rank of the calling process in group of comm
   input: comm
   output: rank
local data                                                        */
   int ierror;
/* internal mpi common block
   idproc = processor id                                          */
/* check for error conditions */
/* MPI not initialized        */
   if (nproc <= 0)
      ierror = 1;
/* invalid comm */
   else if (comm != MPI_COMM_WORLD)
      ierror = 2;
/* get rank */
   else {
      *rank = idproc;
      ierror = 0;
   }
/* handle errors */
   if (ierror)
         writerrs("MPI_Comm_rank: ",ierror);
   return ierror;
}

int MPI_Bcast(void* buffer, int count, MPI_Datatype datatype,
              int root, MPI_Comm comm) {
/* broadcast a message from root to all processes in comm
   buffer = starting address of buffer
   count = number of entries in buffer
   datatype = datatype of buffer
   root = rank of broadcast root
   comm = communicator (only MPI_COMM_WORLD currently supported)
   input: buffer, count, datatype, root, comm
   output: buffer
local data                                                          */
   int ierror, i;
   MPI_Status status;
/* internal mpi common block
   nproc = number of real or virtual processors obtained
   idproc = processor id                                            */
   ierror = 0;
/* check for error conditions */
/* MPI not initialized        */
   if (nproc <= 0)
      ierror = 1;
/* invalid comm */
   else if (comm != MPI_COMM_WORLD)
      ierror = 2;
/* invalid root */
   else if ((root < 0) || (root >= nproc))
      ierror = 19;
/* handle errors */
   if (ierror) {
      writerrs("MPI_Bcast: ",ierror);
      return ierror;
   }
/* start broadcast */
   if (idproc==root) {
      for (i = 0; i < nproc; i++) {
         if (i != root)
           ierror = MPI_Send(buffer,count,datatype,i,0,-1);
      }
   }
   else {
      ierror = MPI_Recv(buffer,count,datatype,root,0,-1,&status);
   }
   return ierror;
}

int MPI_Barrier(MPI_Comm comm) {
/* blocks each process in comm until all processes have called it.
   comm = communicator (only MPI_COMM_WORLD currently supported)
   input: comm
local data                                                          */
   int ierror, ntasks, isync, irync, i;
   MPI_Status status;
/* internal mpi common block
   nproc = number of real or virtual processors obtained
   idproc = processor id                                            */
   ierror = 0;
/* check for error conditions */
/* MPI not initialized        */
   if (nproc <= 0)
      ierror = 1;
/* invalid comm */
   else if (comm != MPI_COMM_WORLD)
      ierror = 2;
/* handle errors */
   if (ierror) {
      writerrs("MPI_Barrier: ",ierror);
      return ierror;
   }
/* begin synchronization */
   ntasks = nproc - 1;
   isync = -1;
   if (idproc==0) {
/* processor 0 receives a message from everyone else */
      for (i=1; i <= ntasks; i++) {
         ierror = MPI_Recv(&irync,1,MPI_INT,i,0,-2,&status);
         if (irync != isync)
            fprintf(unit2,"sync error from proc %d\n",i);
      }
/* then sends an acknowledgment back */
      isync = 1;
      ierror = MPI_Bcast(&isync,1,MPI_INT,0,comm);
   }
   else {
/* remaining processors send a message to processor 0 */
      ierror = MPI_Send(&isync,1,MPI_INT,0,0,-2);
/* then receive an acknowledgement back */
      isync = 1;
      ierror = MPI_Bcast(&irync,1,MPI_INT,0,comm);
      if (irync != isync)
         fprintf(unit2,"rsync error at proc %d\n",idproc);
   }
   return ierror;
}

int MPI_Reduce(void* sendbuf, void* recvbuf, int count,
               MPI_Datatype datatype, MPI_Op op, int root,
               MPI_Comm comm) {
/* applies a reduction operation to the vector sendbuf over the set of
   processes specified by comm and places the result in recvbuf on root
   sendbuf = address of send buffer
   recvbuf = address of receive buffer
   count = number of elements in send buffer
   datatype = datatype of elements in send buffer
   op = reduce operation (only max, min and sum currently supported)
   root = rank of root process
   comm = communicator (only MPI_COMM_WORLD currently supported)
   input: sendbuf, count, datatype, op, root, comm
   output: recvbuf
local data                                                              */
   int ierror, i, j, ltmp, loct, nl, lcnt, lsize;
   void *tmpbuf;
   MPI_Status status;
/* internal mpi common block
   nproc = number of real or virtual processors obtained
   idproc = processor id                                                */
   ierror = 0;
/* check for error conditions */
/* MPI not initialized        */
   if (nproc <= 0)
      ierror = 1;
/* invalid comm */
   else if (comm != MPI_COMM_WORLD)
      ierror = 2;
/* invalid root */
   else if ((root < 0) || (root >= nproc))
      ierror = 19;
/* invalid op */
   else if ((op < 0) || (op > 2))
      ierror = 20;
/* handle errors */
   if (ierror) {
      writerrs("MPI_Reduce: ",ierror);
      return ierror;
   }
/* determine size of temporary buffer */
   if ((datatype==MPI_INT) || (datatype==MPI_FLOAT))
      lsize = 4;
   else if (datatype==MPI_DOUBLE)
      lsize = 8;
/* invalid datatype */
   else {
      ierror = 7;
      writerrs("MPI_Reduce: ",ierror);
      return ierror;
   }
   loct = 0;
   if (idproc==root) {
/* initialize by copying from send to receive buffer */
      if (datatype==MPI_INT)
         iredux((int *)recvbuf,(int *)sendbuf,loct,count,-1);
      else if (datatype==MPI_FLOAT)
         fredux((float *)recvbuf,(float *)sendbuf,loct,count,-1);
      else if (datatype==MPI_DOUBLE)
         dredux((double *)recvbuf,(double *)sendbuf,loct,count,-1);
   }
   ltmp = lsize*count;
/* allocate a nonrelocatable block of memory */
   tmpbuf = NewPtr(ltmp);
/* memory not available */
   if (!tmpbuf) {
      ierror = 21;
      writerrs("MPI_Reduce: ",ierror);
      return ierror;
   }
   ltmp = ltmp/lsize;
/* send messages in groups of ltmp */
   nl = (count - 1)/ltmp + 1;
   lcnt = ltmp;
   lsize = lsize*ltmp/4;
   for (j = 0; j < nl; j++) {
/* better check to see if this is OK */
      if (j==(nl-1))
         lcnt = count - ltmp*(nl - 1);
      if (idproc==root) {
/* root receives data from everyone else */
         for (i = 0; i < nproc; i++) {
            if (i != root) {
               ierror = MPI_Recv(tmpbuf,lcnt,datatype,i,j+1,-3,&status);
/* reduce data */
               if (datatype==MPI_INT)
                  iredux((int *)recvbuf,(int *)tmpbuf,loct,lcnt,op);
               else if (datatype==MPI_FLOAT)
                  fredux((float *)recvbuf,(float *)tmpbuf,loct,lcnt,op);
               else if (datatype==MPI_DOUBLE)
                  dredux((double *)recvbuf,(double *)tmpbuf,loct,lcnt,op);
            }
         }
         loct = loct + ltmp;
      }
      else {
/* remaining processors send data to root */
         ierror = MPI_Send(&((int *)sendbuf)[loct],lcnt,datatype,root,j+1,-3);
         loct = loct + lsize;
      }
   }
/* release nonrelocatable memory block */
   DisposePtr((char *)tmpbuf);
   return ierror;
}

int MPI_Scan(void* sendbuf, void* recvbuf, int count,
             MPI_Datatype datatype, MPI_Op op, MPI_Comm comm) {
/* performs a parallel prefix reduction on data distributed across a
   group
   sendbuf = address of send buffer
   recvbuf = address of receive buffer
   count = number of elements in send buffer
   datatype = datatype of elements in send buffer
   op = reduce operation (only max, min and sum currently supported)
   comm = communicator (only MPI_COMM_WORLD currently supported)
   input: sendbuf, count, datatype, op, comm
   output: recvbuf
local data                                                              */
   int ierror, i, j, root = 0, ltmp, loct, nl, lcnt, lsize;
   void *tmpbuf;
   MPI_Status status;
/* internal mpi common block
   nproc = number of real or virtual processors obtained
   idproc = processor id                                                */
   ierror = 0;
/* check for error conditions */
/* MPI not initialized        */
   if (nproc <= 0)
      ierror = 1;
/* invalid comm */
   else if (comm != MPI_COMM_WORLD)
      ierror = 2;
/* invalid root */
   else if ((root < 0) || (root >= nproc))
      ierror = 19;
/* invalid op */
   else if ((op < 0) || (op > 2))
      ierror = 20;
/* handle errors */
   if (ierror) {
      writerrs("MPI_Scan: ",ierror);
      return ierror;
   }
/* determine size of temporary buffer */
   if ((datatype==MPI_INT) || (datatype==MPI_FLOAT))
      lsize = 4;
   else if (datatype==MPI_DOUBLE)
      lsize = 8;
/* invalid datatype */
   else {
      ierror = 7;
      writerrs("MPI_Scan: ",ierror);
      return ierror;
   }
   loct = 0;
   if (idproc==root) {
/* initialize by copying from send to receive buffer */
      if (datatype==MPI_INT)
         iredux((int *)recvbuf,(int *)sendbuf,loct,count,-1);
      else if (datatype==MPI_FLOAT)
         fredux((float *)recvbuf,(float *)sendbuf,loct,count,-1);
      else if (datatype==MPI_DOUBLE)
         dredux((double *)recvbuf,(double *)sendbuf,loct,count,-1);
   }
   ltmp = lsize*count;
/* allocate a nonrelocatable block of memory */
   tmpbuf = NewPtr(ltmp);
/* memory not available */
   if (!tmpbuf) {
      ierror = 21;
      writerrs("MPI_Scan: ",ierror);
      return ierror;
   }
   ltmp = ltmp/lsize;
/* send messages in groups of ltmp */
   nl = (count - 1)/ltmp + 1;
   lcnt = ltmp;
   lsize = lsize*ltmp/4;
   for (j = 0; j < nl; j++) {
/* better check to see if this is OK */
      if (j==(nl-1))
         lcnt = count - ltmp*(nl - 1);
      if (idproc==root) {
/* root receives data from everyone else */
         for (i = 0; i < nproc; i++) {
            if (i != root) {
               ierror = MPI_Recv(tmpbuf,lcnt,datatype,i,j+1,-3,&status);
/* reduce data */
               if (datatype==MPI_INT)
                  iredux((int *)recvbuf,(int *)tmpbuf,loct,lcnt,op);
               else if (datatype==MPI_FLOAT)
                  fredux((float *)recvbuf,(float *)tmpbuf,loct,lcnt,op);
               else if (datatype==MPI_DOUBLE)
                  dredux((double *)recvbuf,(double *)tmpbuf,loct,lcnt,op);
/* send partial result data to processor i */
               ierror = MPI_Send(&((int *)recvbuf)[loct],lcnt,datatype,i,
                                 j+nproc+1,-3);
            }
         }
         loct = loct + ltmp;
      }
      else {
/* remaining processors send data to root */
         ierror = MPI_Send(&((int *)sendbuf)[loct],lcnt,datatype,root,j+1,-3);
/* receive partial result data from root  */
         ierror = MPI_Recv(&((int *)recvbuf)[loct],lcnt,datatype,root,j+nproc+1,
                           -3,&status);
         loct = loct + lsize;
      }
   }
   if (idproc==root) {
      loct = 0;
/* initialize by copying from send to receive buffer */
      if (datatype==MPI_INT)
         iredux((int *)recvbuf,(int *)sendbuf,loct,count,-1);
      else if (datatype==MPI_FLOAT)
         fredux((float *)recvbuf,(float *)sendbuf,loct,count,-1);
      else if (datatype==MPI_DOUBLE)
         dredux((double *)recvbuf,(double *)sendbuf,loct,count,-1);
   }
/* release nonrelocatable memory block */
   DisposePtr((char *)tmpbuf);
   return ierror;
}

int imax(int val1, int val2) {
   return (val1 > val2 ? val1 : val2);
}
     
int imin(int val1, int val2) {
   return (val1 < val2 ? val1 : val2);
}
   
float flmax(float val1, float val2) {
   return (val1 > val2 ? val1 : val2);
}
     
float flmin(float val1, float val2) {
   return (val1 < val2 ? val1 : val2);
}
   
double dmax(double val1, double val2) {
   return (val1 > val2 ? val1 : val2);
}
     
double dmin(double val1, double val2) {
   return (val1 < val2 ? val1 : val2);
}

void iredux(int *recvbuf, int *sendbuf, int offset, int count, MPI_Op op) {
/* perform reduction operation for int types
   recvbuf = address of receive buffer
   sendbuf = address of send buffer
   offset = starting location in receive buffer
   count = number of elements in send buffer
   op = reduce operation (only max, min and sum currently supported)
   input: recvbuf, sendbuf, offset, count, op
   output: recvbuf
local data                                                                 */
   int i;
/* perform reduction */
   if (op==MPI_MAX) {
      for (i = 0; i < count; i++) {
         recvbuf[i+offset] = imax(recvbuf[i+offset],sendbuf[i]);
      }
   }
   else if (op==MPI_MIN) {
      for (i = 0; i < count; i++) {
         recvbuf[i+offset] = imin(recvbuf[i+offset],sendbuf[i]);
      }
   }
   else if (op==MPI_SUM) {
      for (i = 0; i < count; i++) {
         recvbuf[i+offset] = recvbuf[i+offset] + sendbuf[i];
      }
   }
/* copy initial data */
   else if (op==(-1)) {
      for (i = 0; i < count; i++) {
         recvbuf[i+offset] = sendbuf[i];
      }
   }
   return;
}

void fredux(float *recvbuf, float *sendbuf, int offset, int count, MPI_Op op) {
/* perform reduction operation for float types
   recvbuf = address of receive buffer
   sendbuf = address of send buffer
   offset = starting location in receive buffer
   count = number of elements in send buffer
   op = reduce operation (only max, min and sum currently supported)
   input: recvbuf, sendbuf, offset, count, op
   output: recvbuf
local data                                                                 */
   int i;
/* perform reduction */
   if (op==MPI_MAX) {
      for (i = 0; i < count; i++) {
         recvbuf[i+offset] = flmax(recvbuf[i+offset],sendbuf[i]);
      }
   }
   else if (op==MPI_MIN) {
      for (i = 0; i < count; i++) {
         recvbuf[i+offset] = flmin(recvbuf[i+offset],sendbuf[i]);
      }
   }
   else if (op==MPI_SUM) {
      for (i = 0; i < count; i++) {
         recvbuf[i+offset] = recvbuf[i+offset] + sendbuf[i];
      }
   }
/* copy initial data */
   else if (op==(-1)) {
      for (i = 0; i < count; i++) {
         recvbuf[i+offset] = sendbuf[i];
      }
   }
   return;
}

void dredux(double *recvbuf, double *sendbuf, int offset, int count, MPI_Op op) {
/* perform reduction operation for double types
   recvbuf = address of receive buffer
   sendbuf = address of send buffer
   offset = starting location in receive buffer
   count = number of elements in send buffer
   op = reduce operation (only max, min and sum currently supported)
   input: recvbuf, sendbuf, offset, count, op
   output: recvbuf
local data                                                                 */
   int i;
/* perform reduction */
   if (op==MPI_MAX) {
      for (i = 0; i < count; i++) {
         recvbuf[i+offset] = dmax(recvbuf[i+offset],sendbuf[i]);
      }
   }
   else if (op==MPI_MIN) {
      for (i = 0; i < count; i++) {
         recvbuf[i+offset] = dmin(recvbuf[i+offset],sendbuf[i]);
      }
   }
   else if (op==MPI_SUM) {
      for (i = 0; i < count; i++) {
         recvbuf[i+offset] = recvbuf[i+offset] + sendbuf[i];
      }
   }
/* copy initial data */
   else if (op==(-1)) {
      for (i = 0; i < count; i++) {
         recvbuf[i+offset] = sendbuf[i];
      }
   }
   return;
}

int MPI_Allreduce(void* sendbuf, void* recvbuf, int count,
                  MPI_Datatype datatype, MPI_Op op, MPI_Comm comm) {
/* applies a reduction operation to the vector sendbuf over the set of
   processes specified by comm and places result in recvbuf on all nodes
   sendbuf = address of send buffer
   recvbuf = address of receive buffer
   count = number of elements in send buffer
   datatype = datatype of elements in send buffer
   op = reduce operation (only max, min and sum currently supported)
   comm = communicator (only MPI_COMM_WORLD currently supported)
   input: sendbuf, count, datatype, op, root, comm
   output: recvbuf
local data                                                               */
   int ierror, root = 0, ierr;
   ierror = MPI_Reduce(sendbuf,recvbuf,count,datatype,op,root,comm);
   ierr = MPI_Bcast(recvbuf,count,datatype,root,comm);
   return ierror;
}

int MPI_Gather(void* sendbuf, int sendcount, MPI_Datatype sendtype,
               void* recvbuf, int recvcount, MPI_Datatype recvtype,
               int root, MPI_Comm comm) {
/* collect individual messages from each process in comm at root
   sendbuf = starting address of send buffer
   sendcount = number of elements in send buffer
   sendtype = datatype of send buffer elements
   recvbuf = address of receive buffer
   recvcount = number of elements for any single receive
   recvtype = datatype of recv buffer elements
   root = rank of receiving process
   comm = communicator (only MPI_COMM_WORLD currently supported)
   input: sendbuf, sendcount, sendtype, recvcount, recvtype, root, comm
   output: recvbuf
local data                                                               */
   int ierror, loct, lsize, i, j;
   MPI_Status status;
/* internal mpi common block
   nproc = number of real or virtual processors obtained
   idproc = processor id                                                */
   ierror = 0;
/* check for error conditions */
/* MPI not initialized        */
   if (nproc <= 0)
      ierror = 1;
/* invalid comm */
   else if (comm != MPI_COMM_WORLD)
      ierror = 2;
/* invalid root */
   else if ((root < 0) || (root >= nproc))
      ierror = 19;
/* invalid count */
   else if (sendcount < 0)
      ierror = 3;
/* handle errors */
   if (ierror) {
      writerrs("MPI_Gather: ",ierror);
      return ierror;
   }
/* root receives data */
   if (idproc==root) {
/* invalid count */
      if (recvcount < 0)
         ierror = 3;
/* determine size of data to be sent */
      if ((sendtype==MPI_INT) || (sendtype==MPI_FLOAT))
         loct = sendcount;
      else if (sendtype==MPI_DOUBLE)
         loct = 2*sendcount;
/* invalid datatype */
      else {
         loct = 0;
         ierror = 7;
      }
/* determine size of data to be received */
      if ((recvtype==MPI_INT) || (recvtype==MPI_FLOAT))
         lsize = recvcount;
      else if (recvtype==MPI_DOUBLE)
         lsize = 2*recvcount;
/* invalid datatype */
      else {
         lsize = 0;
         ierror = 7;
      }
/* unequal message length error */
      if (loct != lsize) {
         fprintf(unit2,"Unequal message length, send/receive bytes = %d,%d\n",
                loct,lsize);
         ierror = 22;
      }
/* handle count, datatype and length errors */
      if (ierror) {
         writerrs("MPI_Gather: ",ierror);
         return ierror;
      }
      for (i = 0; i < nproc; i++) {
         loct = lsize*i;
/* root copies its own data directly */
         if (i==root) {
            for (j = 0; j < lsize; j++)
               ((int *)recvbuf)[j+loct] = ((int *)sendbuf)[j];
         }
/* otherwise, root receives data from other processors */
         else
            ierror = MPI_Recv(&((int *)recvbuf)[loct],recvcount,recvtype,i,1,-4,
                              &status);
      }
   }
/* processors other than root send data to root */
   else
      ierror = MPI_Send(sendbuf,sendcount,sendtype,root,1,-4);
   return ierror;
}

int MPI_Allgather(void* sendbuf, int sendcount,
                  MPI_Datatype sendtype, void* recvbuf, int recvcount,
                  MPI_Datatype recvtype, MPI_Comm comm) {
/* gather individual messages from each process in comm and distribute
   the resulting message to each process.
   sendbuf = starting address of send buffer
   sendcount = number of elements in send buffer
   sendtype = datatype of send buffer elements
   recvbuf = address of receive buffer
   recvcount = number of elements for any process
   recvtype = datatype of receive buffer elements
   comm = communicator (only MPI_COMM_WORLD currently supported)
   input: sendbuf, sendcount, sendtype, recvcount, recvtype, comm
   output: recvbuf
local data                                                              */
   int ierror, root = 0, ierr;
/* internal mpi common block
   nproc = number of real or virtual processors obtained                */
   ierror = MPI_Gather(sendbuf,sendcount,sendtype,recvbuf,recvcount,recvtype,
                       root,comm);
   ierr = MPI_Bcast(recvbuf,nproc*recvcount,recvtype,root,comm);
   return ierror;
}

int MPI_Scatter(void* sendbuf, int sendcount, MPI_Datatype sendtype,
                void* recvbuf, int recvcount, MPI_Datatype recvtype,
                int root, MPI_Comm comm) {
/* distribute individual messages from root to each process in comm
   sendbuf = starting address of send buffer
   sendcount = number of elements in send buffer
   sendtype = datatype of send buffer elements
   recvbuf = address of receive buffer
   recvcount = number of elements for any single receive
   recvtype = datatype of recv buffer elements
   root = rank of sending process
   comm = communicator (only MPI_COMM_WORLD currently supported)
   input: sendbuf, sendcount, sendtype, recvcount, recvtype, root, comm
   output: recvbuf
local data                                                               */
   int ierror, lsize, loct, i, j;
   MPI_Status status;
/* internal mpi common block
   nproc = number of real or virtual processors obtained
   idproc = processor id                                                */
   ierror = 0;
/* check for error conditions */
/* MPI not initialized        */
   if (nproc <= 0)
      ierror = 1;
/* invalid comm */
   else if (comm != MPI_COMM_WORLD)
      ierror = 2;
/* invalid root */
   else if ((root < 0) || (root >= nproc))
      ierror = 19;
/* invalid count */
   else if (recvcount < 0)
      ierror = 3;
/* handle errors */
   if (ierror) {
      writerrs("MPI_Scatter: ",ierror);
      return ierror;
   }
/* root sends data */
   if (idproc==root) {
/* invalid counts */
      if (sendcount < 0)
         ierror = 3;
/* determine size of data to be sent */
      if ((sendtype==MPI_INT) || (sendtype==MPI_FLOAT))
         lsize = sendcount;
      else if (sendtype==MPI_DOUBLE)
         lsize = 2*sendcount;
/* invalid datatype */
      else {
         lsize = 0;
         ierror = 7;
      }
/* determine size of data to be received */
      if ((recvtype==MPI_INT) || (recvtype==MPI_FLOAT))
         loct = recvcount;
      else if (recvtype==MPI_DOUBLE)
         loct = 2*recvcount;
/* invalid datatype */
      else {
         loct = 0;
         ierror = 7;
      }
/* unequal message length error */
      if (loct != lsize) {
         fprintf(unit2,"Unequal message length, send/receive bytes = %d,%d\n",
                lsize,loct);
         ierror = 22;
      }
/* handle count, datatype and length errors */
      if (ierror) {
         writerrs("MPI_Scatter: ",ierror);
         return ierror;
      }
      for (i = 0; i < nproc; i++) {
         loct = lsize*i;
/* root copies its own data directly */
         if (i==root) {
            for (j = 0; j < lsize; j++)
              ((int *)recvbuf)[j] = ((int *)sendbuf)[j+loct];
         }
/* otherwise, root sends data to other processors */
         else
            ierror = MPI_Send(&((int *)sendbuf)[loct],sendcount,sendtype,i,1,-5);
      }
   }
/* processors other than root receive data from root */
   else
      ierror = MPI_Recv(recvbuf,recvcount,recvtype,root,1,-5,&status);
   return ierror;
}

int MPI_Alltoall(void* sendbuf, int sendcount, MPI_Datatype sendtype,
                 void* recvbuf, int recvcount, MPI_Datatype recvtype,
                 MPI_Comm comm) {
/* send a distinct message from each process to every process
   sendbuf = starting address of send buffer
   sendcount = number of elements in send buffer
   sendtype = datatype of send buffer elements
   recvbuf = address of receive buffer
   recvcount = number of elements for any single receive
   recvtype = datatype of recv buffer elements
   comm = communicator (only MPI_COMM_WORLD currently supported)
   input: sendbuf, sendcount, sendtype, recvcount, recvtype, comm
   output: recvbuf
local data                                                              */
   int ierror, loct, lsize, id, i, j;
   MPI_Request request;
   MPI_Status status;
/* internal mpi common block
   nproc = number of real or virtual processors obtained
   idproc = processor id                                                */
   ierror = 0;
/* check for error conditions */
/* MPI not initialized        */
   if (nproc <= 0)
      ierror = 1;
/* invalid comm */
   else if (comm != MPI_COMM_WORLD)
      ierror = 2;
/* invalid counts */
   else if ((sendcount < 0) || (recvcount < 0))
      ierror = 3;
/* handle errors */
   if (ierror) {
      writerrs("MPI_Alltoall: ",ierror);
      return ierror;
   }
/* determine size of data to be sent */
   if ((sendtype==MPI_INT) || (sendtype==MPI_FLOAT))
      loct = sendcount;
   else if (sendtype==MPI_DOUBLE)
      loct = 2*sendcount;
/* invalid datatype */
   else {
      loct = 0;
      ierror = 7;
   }
/* determine size of data to be received */
   if ((recvtype==MPI_INT) || (recvtype==MPI_FLOAT))
      lsize = recvcount;
   else if (recvtype==MPI_DOUBLE)
      lsize = 2*recvcount;
/* invalid datatype */
   else {
      lsize = 0;
      ierror = 7;
   }
/* unequal message length error */
   if (loct != lsize) {
      fprintf(unit2,"Unequal message length, send/receive bytes = %d,%d\n",
             loct,lsize);
      ierror = 22;
   }
/* handle count, datatype and length errors */
   if (ierror) {
      writerrs("MPI_Alltoall: ",ierror);
      return ierror;
   }
   for (i = 0; i < nproc; i++) {
      id = i - idproc;
      if (id < 0)
         id = id + nproc;
      loct = lsize*id;
/* each node copies its own data directly */
      if (idproc==id) {
         for (j = 0; j < lsize; j++)
            ((int *)recvbuf)[j+loct] = ((int *)sendbuf)[j+loct];
      }
/* otherwise, each node receives data from other nodes */
      else {
         ierror = MPI_Irecv(&((int *)recvbuf)[loct],recvcount,recvtype,id,i+1,-6,
                            &request) ;
         ierror = MPI_Send(&((int *)sendbuf)[loct],sendcount,sendtype,id,i+1,-6);
         ierror = MPI_Wait(&request,&status);
      }
   }
   return ierror;
}

int MPI_Gatherv(void* sendbuf, int sendcount, MPI_Datatype sendtype,
                void* recvbuf, int *recvcounts, int *displs,
                MPI_Datatype recvtype, int root, MPI_Comm comm) {
/* collect individual messages from each process in comm at root
   messages can have different sizes and displacements
   sendbuf = starting address of send buffer
   sendcount = number of elements in send buffer
   sendtype = datatype of send buffer elements
   recvbuf = address of receive buffer
   recvcounts = integer array
   displs = integer array of displacements
   recvtype = datatype of recv buffer elements
   root = rank of receiving process
   comm = communicator (only MPI_COMM_WORLD currently supported)
   input: sendbuf, sendcount, sendtype, recvcounts, displs, recvtype
   input: root, comm
   output: recvbuf
local data                                                              */
   int ierror, loct, lsize, id, i, j;
   MPI_Status status;
/* internal mpi common block
   nproc = number of real or virtual processors obtained
   idproc = processor id                                                */
   ierror = 0;
/* check for error conditions */
/* MPI not initialized        */
   if (nproc <= 0)
      ierror = 1;
/* invalid comm */
   else if (comm != MPI_COMM_WORLD)
      ierror = 2;
/* invalid root */
   else if ((root < 0) || (root >= nproc))
      ierror = 19;
/* invalid count */
   else if (sendcount < 0)
      ierror = 3;
/* handle errors */
   if (ierror) {
      writerrs("MPI_Gatherv: ",ierror);
      return ierror;
   }
/* root receives data */
   if (idproc==root) {
/* invalid counts */
      for (i = 0; i < nproc; i++) {
         if (recvcounts[i] < 0)
            ierror = 3;
      }
/* determine size of data to be sent */
      if ((sendtype==MPI_INT) || (sendtype==MPI_FLOAT))
         loct = 1;
      else if (sendtype==MPI_DOUBLE)
         loct = 2;
/* invalid datatype */
      else {
         ierror = 7;
      }
/* determine size of data to be received */
      if ((recvtype==MPI_INT) || (recvtype==MPI_FLOAT))
         lsize = 1;
      else if (recvtype==MPI_DOUBLE)
         lsize = 2;
/* invalid datatype */
      else {
         ierror = 7;
      }
/* unequal message length error */
      id = lsize*recvcounts[idproc];
      if ((!ierror) && (loct*sendcount != id)) {
         fprintf(unit2,"Unequal self message, send/receive bytes = %d,%d\n",
                loct*sendcount,id);
         ierror = 22;
      }
/* handle count, datatype and length errors */
      if (ierror) {
         writerrs("MPI_Gatherv: ",ierror);
         return ierror;
      }
      for (i = 0; i < nproc; i++) {
         loct = lsize*displs[i];
/* root copies its own data directly */
         if (i==root) {
            for (j = 0; j < lsize*recvcounts[i]; j++)
               ((int *)recvbuf)[j+loct] = ((int *)sendbuf)[j];
         }
/* otherwise, root receives data from other processors */
         else
            ierror = MPI_Recv(&((int *)recvbuf)[loct],recvcounts[i],recvtype,
                              i,1,-7,&status);
      }
   }
/* processors other than root send data to root */
   else
      ierror = MPI_Send(sendbuf,sendcount,sendtype,root,1,-7);
   return ierror;
}

int MPI_Allgatherv(void* sendbuf, int sendcount,
                   MPI_Datatype sendtype, void* recvbuf, int *recvcounts,
                   int *displs, MPI_Datatype recvtype, MPI_Comm comm) {
/* gather individual messages from each process in comm and distribute
   the resulting message to each process.
   messages can have different sizes and displacements
   sendbuf = starting address of send buffer
   sendcount = number of elements in send buffer
   sendtype = datatype of send buffer elements
   recvbuf = address of receive buffer
   recvcounts = integer array
   displs = integer array of displacements
   recvtype = datatype of receive buffer elements
   comm = communicator (only MPI_COMM_WORLD currently supported)
   input: sendbuf, sendcount, sendtype, recvcounts, displs, recvtype
   input: comm
   output: recvbuf
local data                                                              */
   int ierror, i, ierr;
/* internal mpi common block
   nproc = number of real or virtual processors obtained                */
   ierror = 0;
   for (i = 0; i < nproc; i++) {
      ierr = MPI_Gatherv(sendbuf,sendcount,sendtype,recvbuf,recvcounts,displs,
                         recvtype,i,comm);
      if (ierr)
         ierror = ierr;
   }
   return ierror;
}

int MPI_Scatterv(void* sendbuf, int *sendcounts, int *displs,
                 MPI_Datatype sendtype, void* recvbuf, int recvcount,
                 MPI_Datatype recvtype, int root, MPI_Comm comm) {
/* distribute individual messages from root to each process in comm
   messages can have different sizes and displacements
   sendbuf = starting address of send buffer
   sendcounts = integer array
   displs = integer array of displacements
   sendtype = datatype of send buffer elements
   recvbuf = address of receive buffer
   recvcount = number of elements for any single receive
   recvtype = datatype of recv buffer elements
   root = rank of sending process
   comm = communicator (only MPI_COMM_WORLD currently supported)
   input: sendbuf, sendcounts, displs, sendtype, recvcount, recvtype
   input: root, comm
   output: recvbuf
local data                                                              */
   int ierror, lsize, loct, id, i, j;
   MPI_Status status;
/* internal mpi common block
   nproc = number of real or virtual processors obtained
   idproc = processor id                                                */
   ierror = 0;
/* check for error conditions */
/* MPI not initialized        */
   if (nproc <= 0)
      ierror = 1;
/* invalid comm */
   else if (comm != MPI_COMM_WORLD)
      ierror = 2;
/* invalid root */
   else if ((root < 0) || (root >= nproc))
      ierror = 19;
/* invalid count */
   else if (recvcount < 0)
      ierror = 3;
/* handle errors */
   if (ierror) {
      writerrs("MPI_Scatterv: ",ierror);
      return ierror;
   }
/* root sends data */
   if (idproc==root) {
/* invalid counts */
      for (i = 0; i < nproc; i++) {
         if (sendcounts[i] < 0)
            ierror = 3;
      }
/* determine size of data to be sent */
      if ((sendtype==MPI_INT) || (sendtype==MPI_FLOAT))
         lsize = 1;
      else if (sendtype==MPI_DOUBLE)
         lsize = 2;
/* invalid datatype */
      else {
         ierror = 7;
      }
/* determine size of data to be received */
      if ((recvtype==MPI_INT) || (recvtype==MPI_FLOAT))
         loct = 1;
      else if (recvtype==MPI_DOUBLE)
         loct = 2;
/* invalid datatype */
      else {
         ierror = 7;
      }
/* unequal message length error */
      id = lsize*sendcounts[idproc];
      if ((!ierror) && (loct*recvcount != id)) {
         fprintf(unit2,"Unequal self message, send/receive bytes = %d,%d\n",
                id,loct*recvcount);
         ierror = 22;
      }
/* handle count, datatype and length errors */
      if (ierror) {
         writerrs("MPI_Scatterv: ",ierror);
         return ierror;
      }
      for (i = 0; i < nproc; i++) {
         loct = lsize*displs[i];
/* root copies its own data directly */
         if (i==root) {
            for (j = 0; j < lsize*sendcounts[i]; j++)
              ((int *)recvbuf)[j] = ((int *)sendbuf)[j+loct];
         }
/* otherwise, root sends data to other processors */
         else
            ierror = MPI_Send(&((int *)sendbuf)[loct],sendcounts[i],sendtype,
                              i,1,-8);
      }
   }
/* processors other than root receive data from root */
   else
      ierror = MPI_Recv(recvbuf,recvcount,recvtype,root,1,-8,&status);
   return ierror;
}

int MPI_Alltoallv(void* sendbuf, int *sendcounts, int *sdispls,
                  MPI_Datatype sendtype, void* recvbuf, int *recvcounts,
                  int *rdispls, MPI_Datatype recvtype, MPI_Comm comm) {
/* send a distinct message from each process to every process
   messages can have different sizes and displacements
   sendbuf = starting address of send buffer
   sendcounts = integer array
   sdispls = integer array of send displacements
   sendtype = datatype of send buffer elements
   recvbuf = address of receive buffer
   recvcounts = integer array
   rdispls = integer array of receive displacements
   recvtype = datatype of recv buffer elements
   comm = communicator (only MPI_COMM_WORLD currently supported)
   input: sendbuf, sendcount, sendtype, recvcount, recvtype, comm
   output: recvbuf
local data                                                              */
   int ierror, locs, msize, loct, lsize, id, ld, i, j;
   MPI_Request request;
   MPI_Status status;
/* internal mpi common block
   nproc = number of real or virtual processors obtained
   idproc = processor id                                                */
   ierror = 0;
/* check for error conditions */
/* MPI not initialized        */
   if (nproc <= 0)
      ierror = 1;
/* invalid comm */
   else if (comm != MPI_COMM_WORLD)
      ierror = 2;
/* invalid counts */
   for (i = 0; i < nproc; i++) {
      if ((sendcounts[i] < 0) || (recvcounts[i] < 0))
         ierror = 3;
   }
/* handle errors */
   if (ierror) {
      writerrs("MPI_Alltoallv: ",ierror);
      return ierror;
   }
/* determine size of data to be sent */
   if ((sendtype==MPI_INT) || (sendtype==MPI_FLOAT))
      msize = 1;
   else if (sendtype==MPI_DOUBLE)
      msize = 2;
/* invalid datatype */
   else {
      ierror = 7;
   }
/* determine size of data to be received */
   if ((recvtype==MPI_INT) || (recvtype==MPI_FLOAT))
      lsize = 1;
   else if (recvtype==MPI_DOUBLE)
      lsize = 2;
/* invalid datatype */
   else {
      ierror = 7;
   }
/* unequal message length error */
   id = msize*sendcounts[idproc];
   ld = lsize*recvcounts[idproc];
   if ((!ierror) && (id != ld)) {
      fprintf(unit2,"Unequal self message length, send/receive bytes = %d,%d\n",
             id,ld);
      ierror = 22;
   }
/* handle count, datatype and length errors */
   if (ierror) {
      writerrs("MPI_Alltoallv: ",ierror);
      return ierror;
   }
   for (i = 0; i < nproc; i++) {
      id = i - idproc;
      if (id < 0)
         id = id + nproc;
      locs = msize*sdispls[id];
      loct = lsize*rdispls[id];
/* each node copies its own data directly */
      if (idproc==id) {
         for (j = 0; j < lsize*recvcounts[id]; j++)
            ((int *)recvbuf)[j+loct] = ((int *)sendbuf)[j+locs];
      }
/* otherwise, each node receives data from other nodes */
      else {
         ierror = MPI_Irecv(&((int *)recvbuf)[loct],recvcounts[id],recvtype,id,
                            i+1,-9,&request) ;
         ierror = MPI_Send(&((int *)sendbuf)[locs],sendcounts[id],sendtype,id,
                           i+1,-9);
         ierror = MPI_Wait(&request,&status);
      }
   }
   return ierror;
}

int MPI_Reduce_scatter(void* sendbuf, void* recvbuf, int *recvcounts,
                       MPI_Datatype datatype, MPI_Op op, MPI_Comm comm) {
/* applies a reduction operation to the vector sendbuf over the set of
   processes specified by comm and scatters the result according to the
   values in recvcounts
   sendbuf = starting address of send buffer
   recvbuf = starting address of receive buffer
   recvcounts = integer array
   datatype = datatype of elements in input buffer
   op = reduce operation (only max, min and sum currently supported)
   comm = communicator (only MPI_COMM_WORLD currently supported)
   input: sendbuf, recvcounts, datatype, op, comm
   output: recvbuf
local data                                                              */
   int ierror, root = 0, count, lsize, ltmp, i;
   int *displs;
   void *tmpbuf;
/* internal mpi common block
   nproc = number of real or virtual processors obtained
   idproc = processor id                                                */
   ltmp = 4*nproc;
/* allocate a nonrelocatable block of memory */
   displs = (int *)NewPtr(ltmp);
/* memory not available */
   if (!displs) {
      ierror = 21;
      writerrs("MPI_Reduce_scatter: ",ierror);
      return ierror;
   }
   count = 0;
/* determines overall count and displacements */
   for (i = 0; i < nproc; i++) {
      displs[i] = count;
      count = count + recvcounts[i];
   }
/* determine size of temporary buffer */
   if ((datatype==MPI_INT) || (datatype==MPI_FLOAT))
      lsize = 4;
   else if (datatype==MPI_DOUBLE)
      lsize = 8;
/* invalid datatype */
   else {
      ierror = 7;
      writerrs("MPI_Reduce_scatter: ",ierror);
      return ierror;
   }
   ltmp = lsize*count;
/* allocate a nonrelocatable block of memory */
   tmpbuf = NewPtr(ltmp);
/* memory not available */
   if (!tmpbuf) {
      ierror = 21;
      writerrs("MPI_Reduce_scatter: ",ierror);
      return ierror;
   }
   ierror = MPI_Reduce(sendbuf,tmpbuf,count,datatype,op,root,comm);
   ierror = MPI_Scatterv(tmpbuf,recvcounts,displs,datatype,recvbuf,
                         recvcounts[idproc],datatype,root,comm);
/* release nonrelocatable memory block */
   DisposePtr((char *)tmpbuf);
/* release nonrelocatable memory block */
   DisposePtr((char *)displs);
   return ierror;
}

int MPI_Abort(MPI_Comm comm, int errorcode) {
/* force all tasks on an MPI environment to terminate
   comm = communicator (only MPI_COMM_WORLD currently supported)
   errorcode = error code to return to invoking environment
   input: comm, errorcode
local data                                                              */
   int ierror;
/* internal mpi common block
   nproc = number of real or virtual processors obtained                */
/* MPI not initialized        */
   if (nproc <= 0)
      ierror = 1;
/* this is just a temporary patch, have not yet notified everyone else  */
   else
      ierror = MPI_Finalize();
   return ierror;
}

double MPI_Wtime(void) {
/* return an elapsed time on the calling processor in seconds */
   const double tick=1.0/60.0;
/* get current system tick count */
   return (double) (TickCount())*tick;
}

double MPI_Wtick(void) {
/* return the resolution of MPI_Wtime in seconds */
   const double tick=1.0/60.0;
   return tick;
}

int MPI_Type_extent(MPI_Datatype datatype, MPI_Aint *extent) {
/* returns the size of a datatype
   datatype = datatype
   extent = datatype extent
   input: dataype
   output: extent
local data                                                              */
   int ierror;
   ierror = 0;
/* find size of datatype */
   if ((datatype==MPI_INT) || (datatype==MPI_FLOAT))
      *extent = 4;
   else if (datatype==MPI_DOUBLE)
      *extent = 8;
   else if (datatype==MPI_BYTE)
      *extent = 1;
/* invalid datatype */
   else {
      ierror = 7;
      fprintf(unit2,"MPI_Type_extent: Invalid datatype\n");
   }
   return ierror;
}

void writerrs(char *source, int ierror) {
/* this subroutine writes out error descriptions from error codes
   source = source subroutine of error message
   ierror = error indicator
   input: source, ierror
local data                                                         */
   int ierr, fatal=1;
/* check error code and print corresponding message */
   if (ierror==1)
      fprintf(unit2,"%s MPI not initialized\n",source);
   else if (ierror==2)
      fprintf(unit2,"%s Invalid Communicator\n",source);
   else if (ierror==3)
      fprintf(unit2,"%s Invalid count\n",source);
   else if (ierror==4)
      fprintf(unit2,"%s Invalid destination\n",source);
   else if (ierror==5)
      fprintf(unit2,"%s Invalid source\n",source);
   else if (ierror==6)
      fprintf(unit2,"%s Invalid tag\n",source);
   else if (ierror==7)
      fprintf(unit2,"%s Invalid datatype\n",source);
   else if (ierror==12)
      fprintf(unit2,"%s Incomplete read\n",source);
   else if (ierror==16)
      fprintf(unit2,"%s Invalid request handle\n",source);
   else if (ierror==18)
      fprintf(unit2,"%s Mismatched dataype\n",source);
   else if (ierror==19)
      fprintf(unit2,"%s Invalid root\n",source);
   else if (ierror==20)
      fprintf(unit2,"%s Invalid operation\n",source);
   else if (ierror==21)
      fprintf(unit2,"%s Unable to allocate memory\n",source);
/* unlisted error code */
   else
      fprintf(unit2,"%s Error code = %d\n",source,ierror);
/* abort if error is fatal */
   if (fatal) {
      ierr = MPI_Abort(MPI_COMM_WORLD,ierror);
      exit(1);
   }
}

void messwin(int nvp) {
/* this subroutine creates a window for showing MPI message status
   nvp = number of real or virtual processors
   input argument: nvp
local data                                                    */
   Rect wrect;
   static WindowRecord window;
   short iw, is, ix, iy, it;
   GDevice** handle;
   struct GrafPort *wptr;
   int n, i;
   char name[37];
/* internal mpi common block
   nproc = number of real or virtual processors obtained      */
/* common block for message window
   cpptr = pointer to window structure
   crect = current drag region
   nsp = amount of space between boxes
   nbx = size of box
   nds = number of message sizes monitored                    */
/* get handle to main graphics device that carries a menu bar */
   handle = GetMainDevice();
/* get size of screen */
   crect.bottom = (*handle)->gdRect.bottom;
   crect.right = (*handle)->gdRect.right;
   wrect.bottom = crect.bottom - 40;
   wrect.right = crect.right - 12;
/* find which grafPort is currently active */
   GetPort(&wptr);
/* calculate size of window */
   n = imin(nvp,nproc);
   wrect.top = wrect.bottom - 2*(nbx + nsp) - nbx;
   wrect.left = wrect.right - ((nbx + nsp)*imax(n,8) + nsp);
/* add more space for distribution function */
   wrect.top -= (6*nbx + nsp);
/* add more space for user-defined label */
   wrect.top -= nbx;
/* name = label for window */
   strcpy(name," MacMPI");
   name[0] = 6;
/* create a window */
   if (!cpptr)
      cpptr = NewWindow(&window,&wrect,(unsigned char *)name,
                             1,4,(struct GrafPort *)(-1),0,0);
/* activate a GrafPort */
   SetPort(cpptr);
/* keep a rectangular area from being updated
   ValidRect(&cpptr->portRect);
/* calculate clipping region */
   wrect.bottom -= wrect.top;
   wrect.right -= wrect.left;
   wrect.top = 0;
   wrect.left = 0;
/* select color to use in foreground drawing to black */
   BackColor(33);
/* fill rectangle with background pattern */
   EraseRect(&wrect);
/* calculate drag region */
   crect.top = 4;
   crect.left = 4;
   crect.bottom -= 4;
   crect.right -= 4;
/* select color to use in foreground drawing to white */
   ForeColor(30);
/* set dimensions of pen for current Grafport */
   PenSize(1,1);
/* set point size for subsequent text drawing to 12 points */
   TextSize(12);
/* set initial x and y coordinates for label */
   iw = nbx + nsp;
   ix = nsp;
   iy = iw + nbx;
/* write label for processor id */
   for (i = 0; i < n; i++) {
/* convert node number to string */
      sprintf(name,"%2d",i);
/* get width of unformatted text */
      is = TextWidth(name,0,2);
/* set pen location without drawing */
      MoveTo(ix+(nbx-is)/2,iy);
/* draw text from any arbitrary buffer */
      DrawText(name,0,2);
/* update x coordinate */
      ix += iw;
   }
/* write label for message state display */
   strcpy(name,"Send=Green,Receive=Red,Both=Yellow");
/* set point size for subsequent text drawing to 10 points */
   TextSize(10);
   ix = nsp;
   iy = nsp + 3*nbx;
/* set pen location without drawing */
   MoveTo(ix,iy);
/* select color to use in foreground drawing to green */
   ForeColor(341);
/* draw text from any arbitrary buffer */
   DrawText(name,0,11);
/* get width of unformatted text */
   is = TextWidth(name,0,11);
   ix += is;
/* set pen location without drawing */
   MoveTo(ix,iy);
/* select color to use in foreground drawing to red */
   ForeColor(205);
/* draw text from any arbitrary buffer */
   DrawText(name,11,12);
/* get width of unformatted text */
   is = TextWidth(name,11,12);
   ix += is;
/* set pen location without drawing */
   MoveTo(ix,iy);
/* select color to use in foreground drawing to yellow */
   ForeColor(69);
/* draw text from any arbitrary buffer */
   DrawText(name,23,11);
/* select color to use in foreground drawing to white */
   ForeColor(30);
/* set point size for subsequent text drawing to 9 points */
   TextSize(9);
/* set initial x and y coordinates for label */
   it = nbx/4;
   iw = nbx/2 + nsp;
   ix = nsp;
   iy = 8*nbx + 2*nsp;
/* write label for message size, odd numbers only */
   for (i = 0; i < nds; i+=2) {
/* convert node number to string */
      sprintf(name,"%2d",i);
/* get width of unformatted text */
      is = TextWidth(name,0,2);
/* set pen location without drawing */
      MoveTo(ix+(it-is)/2,iy);
/* draw text from any arbitrary buffer */
      DrawText(name,0,2);
/* underline location of half maximum */
      if (i==12) {
         MoveTo(ix+(it-is)/2,iy+3);
         DrawText("__",0,2);
      }
/* update x coordinate */
      ix += iw;
   }
/* write second label */
   strcpy(name,"Log2-Log2 of Number vs. Message Size");
/* set point size for subsequent text drawing to 10 points */
   TextSize(10);
/* set pen location without drawing */
   MoveTo(nsp,9*nbx+2*nsp);
/* draw text from any arbitrary buffer */
   DrawText(name,0,36);
/* activate the GrafPort that was originally active */
   if (wptr)
      SetPort(wptr);
/* display status */
   logmess(0,0,0,0);
   return;
}

void logmess(int idp, int lstat, int lsize, int tag) {
/* this subroutine logs MPI message state change and displays status
   idp = remote processor id
   lstat = (-1,1,-2,2) = (clear send,add send,clear receive,add receive)
   lstat = 0 means display current status for all processors
   lsize = size of message (in bytes)
   lsize = -1 means print out message size distribution function
   tag = message tag
   input argument: idp, lstat, lsize, tag
local data                                                               */
#define NDSIZE               24
   int istat, istyle, i, i1;
/* mstat = number of outstanding sends and receives for each node
   msize = message size distribution function
   nmax = maximum number of messages in display
   lmax = log2 of nmax                                            */
   static int mstat[MAXS][2] = {{0,0}}, msize[NDSIZE] = {0};
   static int lmax = 8, nmax = 256;
/* internal mpi common block
   nproc = number of real or virtual processors obtained
   idproc = processor id                                                 */
/* internal common block for non-blocking messages
   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */
/* check for errors */
   if ((idp < 0) || (idp >= nproc))
      return;
/* print out message size distribution function */
   if (lsize < 0) {
      fprintf(unit2," Message Size Distribution Function\n");
      i1 = 1;
      for (i = 0; i < NDSIZE; i++) {
         fprintf(unit2," Size(bytes) = %d Number = %d\n",i1,msize[i]);
         i1 = 2*i1;
      }
      return;
   }
/* process message size data */
   else if ((lstat < 0) && (lsize > 0)) {
/* increment message size distribution function */
      i1 = imin((int) (log((float) (lsize))/log(2.) + .5),NDSIZE-1);
      msize[i1] += 1;
      if (msize[i1] > nmax) {
/* erase display of distribution function */
         showdism(0,nmax,lmax,0);
         lmax += 1;
         nmax += nmax;
/* redisplay distribution function */
         for (i = 0; i < NDSIZE; i++) {
            showdism(i,msize[i],lmax,1);
         }
      }
/* display distribution function */
      else
         showdism(i1,msize[i1],lmax,1);
   }
   i1 = idp;
/* calculate all current statuses */
   if (lstat==0) {
      for (i = 0; i < nproc; i++) {
         istat = 0;
         if (mstat[i][0] >= 1)
            istat += 1;
         if (mstat[i][1] >= 1)
            istat += 2;
/* differentiate single from multiple sends/receives */
/*       if ((mstat[i][0] > 1) || (mstat[i][1] > 1))
            istat += 3;                              */
/* display status, outline local node                */
         if (i==idproc)
            istyle = 1;
         else
            istyle = 0;
         showmess(i,istat,istyle);
      }
/* display scale */
      showdism(0,msize[0],lmax,0);
/* display current distribution function */
      for (i = 0; i < NDSIZE; i++) {
         showdism(i,msize[i],lmax,1);
      }
      return;
   }
/* add state change to log */
   else if (lstat==1) {
      mstat[i1][0] += 1;
      if (monitor==2)
         fprintf(unit2,"sending: destination= %d size= %d tag= %d\n",
                 idp,lsize,tag);
   }
   else if (lstat==(-1)) {
      mstat[i1][0] -= 1;
      if (monitor==2)
         fprintf(unit2,"sent: destination= %d size= %d tag= %d\n",
                 idp,lsize,tag);
   }
   else if (lstat==2) {
      mstat[i1][1] += 1;
      if (monitor==2)
         fprintf(unit2,"receiving: source= %d size= %d tag= %d\n",
                 idp,lsize,tag);
   }
   else if (lstat==(-2)) {
      mstat[i1][1] -= 1;
      if (monitor==2)
         fprintf(unit2,"received: source= %d size= %d tag= %d\n",
                 idp,lsize,tag);
   }
/* calculate current status */
   istat = 0;
   if (mstat[i1][0] >= 1)
      istat += 1;
   if (mstat[i1][1] >= 1)
      istat += 2;
/* differentiate single from multiple sends/receives */
/* if ((mstat[i1][0] > 1) || (mstat[i1][1] > 1))
      istat += 3;                                    */
/* display status, outline local node */
   if (idp==idproc)
      istyle = 1;
   else
      istyle = 0;
   showmess(idp,istat,istyle);
   return;
#undef NDSIZE
}

void showmess(int idp, int istat, int istyle) {
/* this subroutine shows MPI message status
   idp = remote processor id
   istat = message status = (0,1,2,3) = (none,sending,receiving,both)
   istyle = (0,1) = (no,yes) outline rectangle
   input argument: idp, istat, istyle
local data                                                            */
   Rect wrect;
   struct GrafPort *wptr;
/* icolor = white, green, red, yellow, blue, magenta, cyan, black */
   const int icolor[8] = {30,341,205,69,409,137,273,33};
/* internal common block for message window
   cpptr = pointer to window structure
   nsp = amount of space between boxes
   nbx = size of box                         */
/* check for errors */
   if ((istat < 0) || (istat > 7))
      return;
   if (!cpptr)
      return;
/* find which grafPort is currently active */
   GetPort(&wptr);
/* activate a GrafPort */
   SetPort(cpptr);
/* set rectangle */
   wrect.top = nsp;
   wrect.left = (nbx + nsp)*idp + nsp;
   wrect.bottom = wrect.top + nbx;
   wrect.right = wrect.left + nbx;
/* select color to use in foreground drawing */
   ForeColor(icolor[istat]);
/* draw the outline of a rectangle */
   FrameRect(&wrect);
/* fill rectangle with current pen pattern and mode */
   PaintRect(&wrect);
/* outline rectangle */
   if (istyle) {
/* shrink or expand a rectangle */
      InsetRect(&wrect,-2,-2);
/* draw the outline of a rectangle */
      FrameRect(&wrect);
   }
/* activate the GrafPort that was originally active */
   if (wptr) 
      SetPort(wptr);
   return;
}

void showdism(int ibin,int nbin,int lmax,int istyle) {
/* this subroutine shows distribution of MPI messages
   ibin = bin number for distribution function
   nbin = number of messages in ibin
   lmax = log2 of maximum number of messages in display
   istyle = (0,1) = (erase and rescale,draw) display 
   input argument: ibin, nbin, nmax
local data                                                */
   Rect wrect;
   short iw;
   struct GrafPort *wptr;
   int nscale;
   float scale;
   char name[9];
/* internal common block for message window
   cpptr = pointer to window structure
   nsp = amount of space between boxes
   nbx = size of box
   nds = number of message sizes monitored    */
/* check for errors */
   if (!cpptr)
      return;
/* find which grafPort is currently active */
   GetPort(&wptr);
/* activate a GrafPort */
   SetPort(cpptr);
/* set rectangle for entire distribution */
   iw = nbx/4;
   wrect.bottom = 7*nbx + 2*nsp;
/* select color to use in foreground drawing to white */
   ForeColor(30);
/* erase and rescale display */
   if (!istyle) {
/* select color to use in foreground drawing to black */
      ForeColor(33);
      wrect.top = wrect.bottom - 4*nbx;
      wrect.right = (iw + nsp/2)*nds + nsp/2;
      wrect.left = 0;
/* fill rectangle with background pattern */
      EraseRect(&wrect);
/* select color to use in foreground drawing to white */
      ForeColor(30);
/* set point size for subsequent text drawing to 9 points */
      TextSize(9);
/* convert node number to string */
      sprintf(name,"%2d",lmax);
/* set pen location without drawing */
      MoveTo(0,wrect.top+9);
/* draw text from any arbitrary buffer */
      DrawText(name,0,2);
   }
/* draw display */
   else {
/* calculate size of image */
      scale = (float) (4*nbx)/(((float) (lmax))*log(2.));
      nscale = imin((int) (log((float) (nbin+1))*scale),4*nbx);
/* set rectangle for individual bin */
      wrect.top = wrect.bottom - nscale;
      wrect.right = (iw + nsp/2)*ibin + iw + nsp;
      wrect.left = wrect.right - iw;
/* draw the outline of a rectangle */
      FrameRect(&wrect);
/* fill rectangle with current pen pattern and mode */
      PaintRect(&wrect);
   }
/* activate the GrafPort that was originally active */
   if (wptr)
      SetPort(wptr);
   return;
}

void Logname(char* name) {
/* this subroutine records and displays user-defined label
   name = label to display
local data                                                  */
   Rect wrect;
   short nl;
   struct GrafPort *wptr;
/* internal common block for non-blocking messages
   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */
/* internal common block for message window
   cpptr = pointer to window structure
   nsp = amount of space between boxes
   nbx = size of box                          */
   if (monitor==0)
      return;
   if (monitor==2)
      fprintf(unit2,"%s",name);
/* check for errors */
   if (!cpptr)
      return;
/* find which grafPort is currently active */
   GetPort(&wptr);
/* activate a GrafPort */
   SetPort(cpptr);
/* set rectangle */
   wrect.top = 9*nbx + 2*nsp + 2;
   wrect.left = nsp;
   wrect.bottom = wrect.top + nbx;
   wrect.right = wrect.left + 8*(nbx + nsp);
/* select color to use in foreground drawing to black */
   BackColor(33);
/* fill rectangle with background pattern */
   EraseRect(&wrect);
/* select color to use in foreground drawing to white */
   ForeColor(30);
/* set pen location without drawing */
   MoveTo(wrect.left,wrect.bottom-2);
   nl = imin(36,strlen(name));
/* draw text from any arbitrary buffer */
   DrawText(name,0,nl);
/* activate the GrafPort that was originally active */
   if (wptr)
      SetPort(wptr);
   return;
}

void Set_Mon(int monval) {
/* this subroutine sets new monitor value and corresponding window
   monval = new monitor value                                            */
/* declare internal mpi common block
   nproc = number of real or virtual processors obtained                 */
/* declare common block for non-blocking messages
   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */
/* create or destroy window if MPI has been initialized */
   if (nproc > 0) {
/* open window */
      if ((monitor==0) && (monval > 0))
         messwin(nproc);
/* close window */
      if ((monitor > 0) && (monval < 1))
         delmess();
   }
/* reset monitor value */
   if (monval > 1)
      monitor = 2;
   else if (monval < 1)
      monitor = 0;
   else
      monitor = 1;
   return;
}

void delmess() {
/* this subroutine closes a window for showing MPI message status
/* internal common block for message window
   cpptr = pointer to window structure */
/* remove window from screen; keep WindowRecord */
   if (cpptr)
      CloseWindow(cpptr);
   cpptr = 0;
   return;
}