c*----------------------------------------------------------------------
c* Example of group Reduce, Scatter, and Gather functions - J.M. Donato
c* 
c* This example calculates the sum of squares of the first N integers
c* in three different ways where 
c*
c*   N = (number of processors)*(number of elements per row)
c*
c* Note:  This is obviously not an efficient way to compute the 
c*        sum of squares, but it is a cutesy example and test case.
c*----------------------------------------------------------------------

      program main

      implicit none
      include '../include/fpvm3.h'

      external PvmMin
      external PvmMax
      external PvmSum
      external PvmProduct
      external MaxWithLoc

      integer MAXNDATA, MAXNPROCS, DFLTNDATA, DFLTNPROCS
      character*10 GROUP, TASK_NAME
      parameter (MAXNDATA = 20, MAXNPROCS = 16, 
     &           DFLTNDATA = 5, DFLTNPROCS = 4,
     &           GROUP = 'grp_frsg', TASK_NAME = 'frsg')

      integer myginst, i, j, gsize, count, nprocs, msgtag, datatype,
     &  buffer, info, info_product, info_user,
     &  tids(MAXNPROCS), myrow(MAXNDATA), matrix(MAXNDATA*MAXNPROCS),
     &  midpoint, bigN, Sum1, Sum2, SumSquares, rootginst,
     &  PSum, PartSums(MAXNPROCS), dupls(MAXNDATA)

      double precision values(2)

      data Sum1/0/, Sum2/0/

c*  join the group 
      call PvmfJoinGroup(GROUP, myginst)       
c* I am the first group member, get input, start up copies of myself 
      if ( myginst.eq.0 ) then 

        call PvmfMyTid(tids(1))
        call PvmfParent(i)
        if (i .eq. PvmNoParent) then
            print *, '\ * Example: PVM Reduce, Scatter, and Gather * ',
     &           '\ Number of processors to use (1-', MAXNPROCS,')? : '
            read *, nprocs
            if (nprocs.gt.MAXNPROCS) nprocs = MAXNPROCS
                 print *, ' Number of elements per row to use (1-', 
     &             MAXNDATA, ')? : '
             read *, count
            if (count.gt.MAXNDATA) count = MAXNDATA
        else
            nprocs = DFLTNPROCS
            count = DFLTNDATA
        endif
        print *, ' INPUT values: nprocs = ', nprocs, ', count = ', count

        if ( nprocs.gt.1 ) then 
          call PvmfSpawn(TASK_NAME, PvmDefault, '*', 
     &                   nprocs-1, tids(2), info)

c*  wait until they have all started, then send input values 
          call PvmfGsize(GROUP, gsize)
9000      continue
          if ( gsize.lt.nprocs) then
            call sleep(1) 
            call PvmfGsize(GROUP, gsize)
            go to 9000
          end if

          call PvmfInitsend(PvmDataDefault, buffer)
          call PvmfPack(INTEGER4, nprocs, 1, 1, info)
          call PvmfPack(INTEGER4, count,  1, 1, info)
          msgtag = 17
          call PvmfBcast(GROUP, msgtag, info)
        end if

      else
c*  receive the input values if child node
        msgtag = 17
        call PvmfRecv(-1, msgtag, info)
        call PvmfUnpack(INTEGER4, nprocs, 1, 1, info)
        call PvmfUnpack(INTEGER4, count,  1, 1, info)
      end if
  
c*  determine the group root 
      rootginst = 0

c*  init the matrix values on the root processor 
      if ( myginst.eq.rootginst ) then
        do j=1, nprocs
          do i=1, count
            matrix((j-1)*count + i) = (j-1)*count + i
          end do
        end do
      end if

c*  scatter rows of matrix to each processor 
      msgtag = 19
      call PvmfScatter(myrow, matrix, count, INTEGER4, msgtag, 
     &                 GROUP, rootginst, info)

c*  this should end up squaring each value on each processor 
      do i=1, count
        dupls(i) = myginst*count + i 
      end do
      datatype = INTEGER4
      call PvmProduct(datatype, myrow, dupls, count, info_product)
      if ((myginst.eq.rootginst).and.(info_product.lt.0))
     &    print *, ' ERROR: ', info_product, ' on PvmProduct call '

c*  do partial sum on each proc 
      do i=1, count
        PSum = PSum + myrow(i)
      end do

c*  gather partial sums to the rootginst 
      msgtag = 21
      call PvmfGather(PartSums, PSum, 1, INTEGER4, msgtag, 
     &                GROUP, rootginst, info)

c*  do a global sum over myrow, the result goes to rootginst 
      msgtag = 23
      call PvmfReduce(PvmSum, myrow, count, INTEGER4, msgtag, 
     &                GROUP, rootginst, info)

c*  init values and include location information on each processor 
      midpoint = nprocs/2
      values(1) = -(myginst - midpoint)*(myginst-midpoint) + count
      values(2) = myginst    

c*  use a user-defined function in reduce, send answer to rootginst 
      msgtag = 25
      call PvmfReduce(MaxWithLoc, values, 2, REAL8, 
     &                msgtag, GROUP, rootginst, info_user)

      bigN = nprocs*count
      if (myginst.eq.rootginst) then
c*  Complete the Sum of Squares using different methods 
        do i=1, nprocs
          Sum1 = Sum1 + PartSums(i) 
        end do
        do i=1, count 
          Sum2 = Sum2 + myrow(i)    
        end do
        SumSquares = bigN*(bigN+1)*(2*bigN+1)/6
        if ( (Sum1.eq.SumSquares) .and. (Sum2.eq.SumSquares)) then
          print *, '\ Test OK: Sum of Squares of first ', bigN, 
     &             ' integers is ', Sum1
        else
          print *, '\ ERROR: The Sum of Squares of the first ', bigN, 
     &             ' integers \ was calculated by Sum1 as ', Sum1,
     &             ' and by Sum2 as ', Sum2,
     &             ' for both it should have been ', SumSquares
        end if

        if (info_user.lt.0) 
     &    print *, ' ERROR: ', info_user, ' on User Reduce Function'

        if ((values(1).ne.count) .or. (values(2).ne.midpoint)) then
          print *, ' ERROR: Should have (', count, ', ', midpoint,
     &             '), but have (', values(1), ',', values(2)
        else
          print *, ' Test Ok: Received (', values(1), ',', 
     &              values(2), ') '
        end if

      end if
       

c*  sync up again, leave group, exit pvm 
      call PvmfBarrier(GROUP, nprocs, info)   
      call PvmfLvgroup(GROUP, info)
      call PvmfExit(info)

      stop
      end


c*
c* This function returns the elementwise maximum of two vectors 
c* along with location information.
c*
c* The first num/2 values of x and y are the data values to compare.
c* The second num/2 values of x and y are location information
c* which is kept with the maximum value determined.
c*
c* In the case of a tie in data values, the smaller location 
c* is kept to insure the associativity of the operation.
c*

      subroutine MaxWithLoc(datatype, x, y, num, info)
      implicit none
      integer datatype, num, info
      double precision x(*), y(*)

      include '../include/fpvm3.h'

      integer i, count
      count = num/2

      if (datatype.ne.REAL8) then
        info = PvmBadParam 
        return
      end if

      do i=1, count
        if (y(i).gt.x(i)) then
          x(i)       = y(i)
          x(i+count) = y(i+count)
        elseif (y(i).eq.x(i)) then
          x(i+count) = min(x(i+count), y(i+count))
        end if
      end do

      info = PvmOk
      return
      end


