PROGRAM INPROD
*
* INPROD performs a parallel inner product.
*
* .. External Subroutines ..
EXTERNAL PVMFMYTID, PVMFPARENT, PVMFSPAWN, PVMFEXIT, PVMFINITSEND
EXTERNAL PVMFPACK, PVMFSEND, PVMFRECV, PVMFUNPACK
*
* .. External Functions ..
REAL SDOT, SINPROD
EXTERNAL SDOT, SINPROD
*
* .. Intrinsic Functions ..
INTRINSIC MOD
*
* .. Parameters ..
INTEGER MAXN
PARAMETER( MAXN = 8000 )
INCLUDE 'fpvm3.h'
*
* .. Scalars ..
INTEGER N, MYTID, MYPROC, NPROCS, IBUF, IERR
INTEGER I, J
REAL SIP, PIP
CHARACTER*1 ERRCHAR
LOGICAL ERRCHK
*
* .. Arrays ..
INTEGER TIDS(0:63)
REAL X(MAXN), Y(MAXN)
*
* Enroll in PVM and get my and the master process' task ID number
*
CALL PVMFMYTID(MYTID)
CALL PVMFPARENT(TIDS(0))
*
* If I need to spawn other processes (I am master process)
*
IF (TIDS(0) .EQ. PVMNOPARENT) THEN
*
* Get starting information
*
WRITE(*,*) 'How many processes should participate (1-64)?'
READ(*,*) NPROCS
WRITE(*,2000) MAXN
READ(*,*) N
WRITE(*,*) 'Do you wish to perform error checking?'
READ(*,*) ERRCHAR
ERRCHK = (ERRCHAR.EQ.'Y' .OR. ERRCHAR.EQ.'y')
MYPROC = 0
TIDS(0) = MYTID
*
DO 10 I = 1, NPROCS-1
*
* Spawn process and check for error
*
CALL PVMFSPAWN('sinprod', 0, 'anywhere', 1, TIDS(I), IERR)
IF (IERR .NE. 1) THEN
WRITE(*,*) 'ERROR, could not spawn process #',I,
$ '. Dying . . .'
CALL PVMFEXIT(IERR)
STOP
END IF
*
* Send out startup info
*
CALL PVMFINITSEND(PVMDEFAULT, IBUF)
CALL PVMFPACK(INTEGER4, N, 1, 1, IERR)
CALL PVMFPACK(INTEGER4, I, 1, 1, IERR)
CALL PVMFPACK(INTEGER4, NPROCS, 1, 1, IERR)
CALL PVMFPACK(INTEGER4, ERRCHK, 1, 1, IERR)
CALL PVMFSEND(TIDS(I), 0, IERR)
10 CONTINUE
*
* All other processes should check in with spawning process
*
DO 20 I = 1, NPROCS-1
*
* Recv slave task ID from process number I
*
CALL PVMFRECV(TIDS(I), 1, IBUF)
*
* Unpack and make sure received ID agrees with IDs returned by spawn
*
CALL PVMFUNPACK(INTEGER4, J, 1, 1, IERR)
IF (J .EQ. TIDS(I)) THEN
WRITE(*,1000) MYTID, I, TIDS(I)
ELSE
WRITE(*,*) 'Data corruption during checkin: tid, '//
$ 'should be =', J, TIDS(1)
WRITE(*,*) 'Error during checkin phase, aborting run'
CALL PVMFEXIT(IERR)
STOP
END IF
20 CONTINUE
*
* If I am a process who was spawned by master process
*
ELSE
*
* Receive startup info
*
CALL PVMFRECV(TIDS(0), 0, IBUF)
CALL PVMFUNPACK(INTEGER4, N, 1, 1, IERR)
CALL PVMFUNPACK(INTEGER4, MYPROC, 1, 1, IERR)
CALL PVMFUNPACK(INTEGER4, NPROCS, 1, 1, IERR)
CALL PVMFUNPACK(INTEGER4, ERRCHK, 1, 1, IERR)
*
* Send my task ID back as acknowledgement that process started correctly
*
CALL PVMFINITSEND(0, IBUF)
CALL PVMFPACK(INTEGER4, MYTID, 1, 1, IERR)
CALL PVMFSEND(TIDS(0), 1, IERR)
END IF
*
* Everybody generates same X & Y
*
CALL SGENMAT(N, 1, X, N, TIDS(0), N, NPROCS, N/NPROCS)
CALL SGENMAT(N, 1, Y, N, N/NPROCS, TIDS(0), TIDS(0)/NPROCS,
$ NPROCS*N)
*
* Compute the inner product in parallel
*
PIP = SINPROD(N, X, Y, MYPROC, NPROCS, TIDS)
*
* Perform error checking
*
IF (ERRCHK) THEN
*
* Compute the inner product sequentially
*
SIP = SDOT(N, X, 1, Y, 1)
IF (MYPROC .EQ. 0)
$ WRITE(*,*) '<x,y> is sequential inner product, <x^y^>'//
$ ' is parallel product'
WRITE(*,*) '|<x,y> - <x^,y^>| = ', ABS(SIP - PIP)
END IF
*
IF (MYPROC .EQ. 0) WRITE(*,*) 'DONE INPROD'
CALL PVMFEXIT(IERR)
*
1000 FORMAT(I10,' Successfully spawned process #',I2,', TID =',I10)
2000 FORMAT('Enter the length of vectors to multiply (1 -'I7,'):')
STOP
*
* End program INPROD
*
END
*
REAL FUNCTION SINPROD(N, X, Y, MYPROC, NPROCS, TIDS)
*
* PVM example routine written by Clint Whaley on 6/28/93
*
* .. Scalar Arguments ..
INTEGER N, MYPROC, NPROCS
*
* .. Array Arguments ..
INTEGER TIDS(0:*)
REAL X(*), Y(*)
*
* Purpose
* =======
* Returns the inner product of <y,x>, which is computed in parallel.
*
* Arguments
* =========
*
* N (input) INTEGER
* Number of elements in X and Y.
*
* X (input) REAL, dimension (N)
* 1st vector to multiply.
*
* Y (input) REAL, dimension (N)
* 2nd vector to multiply.
*
* MYPROC (input) INTEGER
* Integer ID between 0 (master) and NPROCS-1
*
* NPROCS (input) INTEGER
* The number of processes working on the problem.
*
* TIDS (input) INTEGER, dimension (NPROCS)
* Array of task IDs (assigned by PVM) of processes.
*
* ======================================================================
*
* .. External Subroutines ..
EXTERNAL PVMFINITSEND, PVMFPACK, PVMFSEND, PVMFRECV
EXTERNAL PVMFUNPACK, PVMFMCAST
*
* .. External Functions ..
REAL SDOT
EXTERNAL SDOT
*
* .. Intrinsic Functions ..
INTRINSIC MOD
*
* .. Parameters ..
INCLUDE 'fpvm3.h'
*
* .. Local Scalars ..
INTEGER LN, IG, IERR, K
REAL STMP, STMP2
*
* Executable Statements
*
* LN is the number of elements to be multiplied locally. Process 0
* handles any extra rows; IG is global index into X & Y.
*
LN = N / NPROCS
IF (MYPROC .EQ. 0) THEN
LN = LN + MOD(N, NPROCS)
IG = 1
ELSE
IG = LN*MYPROC + MOD(N, NPROCS) + 1
END IF
STMP = SDOT(LN, X(IG), 1, Y(IG), 1)
*
* If I am not master, send my part of inner product to master,
* and get back global answer.
*
IF (MYPROC .NE. 0) THEN
CALL PVMFINITSEND(PVMDEFAULT, IERR)
CALL PVMFPACK(REAL4, STMP, 1, 1, IERR)
CALL PVMFSEND(TIDS(0), 100, IERR)
CALL PVMFRECV(TIDS(0), 101, IERR)
CALL PVMFUNPACK(REAL4, STMP, 1, 1, IERR)
*
* If I am master, recv parts of inner product, sum up, and broadcast answer
*
ELSE
DO 10 K = 1, NPROCS-1
CALL PVMFRECV(-1, 100, IERR)
CALL PVMFUNPACK(REAL4, STMP2, 1, 1, IERR)
STMP = STMP + STMP2
10 CONTINUE
CALL PVMFINITSEND(PVMDEFAULT, IERR)
CALL PVMFPACK(REAL4, STMP, 1, 1, IERR)
CALL PVMFMCAST(NPROCS-1, TIDS(1), 101, IERR)
END IF
*
SINPROD = STMP
RETURN
*
* END OF SINPROD
*
END
*
*