C
C Basic Parallel functionality using the MPI harness
C NMH NOV 1997.
C Notes:
C temp buffers must be allocated dynamically
C Can't use F90 as the mpif.h is for F77
C MPI is documented to work with F77 only.
C
C Cludges:
C DGSUM COMMON BLOCK WASTES LIM021 REALS AS BUFFER FOR SUM
C REQU: BY MPI_ALL_REDUCE
C Non-standard:
C INCLUDE
C DO, ENDDO
C 
C 
C***./ ADD NAME=GSUM
C
      SUBROUTINE GSUM(Y,N)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C Explicit declarations - one day !!
      Integer buffer_size,N, Nproc
      Integer start, i, j, length, ierr
      Double Precision buff,Y
      Parameter( buffer_size = 256 * 256 )
C
      PARAMETER (LIMPAR=50,LIMPRN=200,LIMFTN=100,LIMTOL=50,LIMINF=200)
      COMMON/PARINF/PAR(LIMPAR),LPRINT(LIMPRN),IUNIT(LIMFTN),
     *ITOL(LIMTOL),INF(LIMINF),ITIT(20),IIN,IOUT,NERROR
      COMMON/PARAL1/NPROC,NNPROC,IAM,MPOINT,ITASK
C
      Dimension buff( 1:buffer_size )
      Dimension Y(N)
C
      INCLUDE "mpif.h"
C
C GSUM performed in 1/2 Megabyte chunks
C
      IF(NPROC .EQ. 1) RETURN
C
      start = 1
C
      Do While( start .le. n )
C
         length = Min( buffer_size, n - start + 1 )
C
         IERR=0
         CALL MPI_ALLREDUCE( Y( start ), BUFF, length, 
     +        MPI_DOUBLE_PRECISION, MPI_SUM,
     $        MPI_COMM_WORLD, IERR)
         IF( IERR .NE. 0 ) THEN
            CALL ERRNIC(0,IERR,'GSUM ','MPI_ALL_REDUCE FAILED IERR = ')
         ENDIF
C
         DO I=1, length
            Y( start + I - 1 )=BUFF(I)
         ENDDO
C
         start = start + buffer_size
C
      End Do
C
      RETURN
      END
C
C***./ ADD NAME=INITPP
C
      SUBROUTINE INITPP
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      Character*5 suffix
C
      INCLUDE "mpif.h"
C
      PARAMETER (LIMPAR=50,LIMPRN=200,LIMFTN=100,LIMTOL=50,LIMINF=200)
      COMMON/PARINF/PAR(LIMPAR),LPRINT(LIMPRN),IUNIT(LIMFTN),
     *ITOL(LIMTOL),INF(LIMINF),ITIT(20),IIN,IOUT,NERROR
      COMMON/PARAL1/NPROC,NNPROC,IAM,MPOINT,ITASK
C
      suffix = '     '
C
      IIN=88
      IOUT=89
      NERROR=0
      MPOINT=0
      CALL SECOND(FT)
C
      CALL MPI_INIT(IERR)
      CALL MPI_COMM_RANK(MPI_COMM_WORLD, IAM, IERR)
      CALL MPI_COMM_SIZE(MPI_COMM_WORLD, NPROC, IERR)
C
      NNPROC = -NPROC
      OPEN(UNIT=IIN,FILE='INPUT',FORM='FORMATTED')
      OPEN(UNIT=IOUT,FILE='OUTPUT',FORM='FORMATTED')
      OPEN(UNIT=NERROR,FILE='ERROR',FORM='FORMATTED')
      WRITE(NERROR,*) 'PROCESS ',IAM,' OF ',NPROC,' WORKING'
      RETURN
      END
C***./ ADD NAME=STOPPE
      SUBROUTINE STOPPE
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      Include "mpif.h"
C... ERROR EXIT
      CALL TIMVRS('ERR ')
      CALL MPI_Abort(mpi_comm_world,1,ierr)
      STOP
      END
C***./ ADD NAME=STOPPP
      SUBROUTINE STOPPP
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      include "mpif.h"
      CALL TIMVRS('END ')
      CALL TREPOR
      CALL MPI_Finalize(ierr)
      STOP
      END
C***./ ADD NAME=IGPVAL
      SUBROUTINE IGPVAL
C IMPLEMENTS A GLOBAL POINTER
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/PARAL1/NPROC,NNPROC,IAM,MPOINT,ITASK
C NO NXTVAL SERVER IN MPI-1 => USE NON-DYNAMIC ASSIGNEMENTS
      MPOINT=MPOINT+NPROC
      RETURN
      END
C***./ ADD NAME=IGPRST
      SUBROUTINE IGPRST
C RESETS THE GLOBAL POINTER
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/PARAL1/NPROC,NNPROC,IAM,MPOINT,ITASK
      MPOINT = -IAM
      RETURN
      END
C***./ ADD NAME = TREPOR
      SUBROUTINE TREPOR
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/PARAL1/NPROC,NNPROC,IAM,MPOINT,ITASK
      INCLUDE 'mpif.h'
C
      DIMENSION ISTATUS(MPI_STATUS_SIZE)
      CALL SECOND(TEND)
      IF(IAM.NE.0) THEN
C       CALL SND(MSGN,TEND,LREAL,0,1)
       IERR=0
       CALL MPI_SEND(TEND,1,MPI_DOUBLE_PRECISION,0,99,
     $      MPI_COMM_WORLD,IERR)
      ELSE
       WRITE(IOUT,100) IAM,TEND
       TTEND=TEND
       DO I=1,NPROC-1
C        CALL RCV(MSGN,TEND,LREAL,LENMES,-1,NODEF,1)
        IERR=0
        CALL MPI_RECV(TEND,1,MPI_DOUBLE_PRECISION,I,99,
     $         MPI_COMM_WORLD,ISTATUS,IERR)      
        WRITE(IOUT,100) I,TEND
        TTEND=TTEND+TEND
       ENDDO
      WRITE(IOUT,101)TTEND
      ENDIF
      RETURN
100   FORMAT('NODE',I5,' CPU TIME =',F14.3)
101   FORMAT('    TOTAL CPU TIME =',F14.3)
      END