c
c *****************************************************************
c *                                                               *
c *    Copyright (c) Digital Equipment Corporation, 1995          *
c *                                                               *
c *   All Rights Reserved.  Unpublished rights  reserved  under   *
c *   the copyright laws of the United States.                    *
c *                                                               *
c *   The software contained on this media  is  proprietary  to   *
c *   and  embodies  the  confidential  technology  of  Digital   *
c *   Equipment Corporation.  Possession, use,  duplication  or   *
c *   dissemination of the software and media is authorized only  *
c *   pursuant to a valid written license from Digital Equipment  *
c *   Corporation.                                                *
c *                                                               *
c *   RESTRICTED RIGHTS LEGEND   Use, duplication, or disclosure  *
c *   by the U.S. Government is subject to restrictions  as  set  *
c *   forth in Subparagraph (c)(1)(ii)  of  DFARS  252.227-7013,  *
c *   or  in  FAR 52.227-19, as applicable.                       *
c *                                                               *
c *****************************************************************
c
c
c HISTORY
c
C
C Example of some group function and reduction functions in PVM 
C SPMD style program
C
C 11 March 1994 - Creation by P. Papadopoulos (phil@msr.epm.ornl.gov)
C
C 26 August 1994 - Modified to work as an High Performance Fortran
C                  main in the Digital Parallel Software Environment
C
C build via f90 -wsf 2 hpf_gexample.f xxx/libfpvm3.a xx/libgpvm3.a xxx/libpvm3.a
C
      extrinsic(hpf_local) subroutine hpf_gexample(nproc)
       integer, optional, intent(in) :: nproc

      include 'fpvm3.h'


C --- Set Initial and Default Parameters
      integer    DEF_DIMENSION, INITTAG,SUMTAG,PRODTAG
      parameter (DEF_DIMENSION = 50       )
      parameter (INITTAG       = 1000     )
      parameter (SUMTAG        = INITTAG+1)
      parameter (PRODTAG       = INITTAG+2)

      integer mytid, myinst, maxmax, root
      integer dimension, ninst, bufid
      integer tids(32)
      integer nhost, narch, dtid, speed
      integer blksize, nextra, mysrow, i, j, itemp, info
      integer subblock(DEF_DIMENSION,DEF_DIMENSION)
      integer colsum(DEF_DIMENSION)
      real*8  colprod(DEF_DIMENSION)
      character*32 host, arch

C --- External declarations of PVM and User defined reduce function
      external PvmSum 
      external calcprod 

C ---------------- Begin Program -----------------------------------------

C        print*, 'Begin extrinsic'

c     Enroll in PVM and join a group
      call pvmfmytid( mytid )
      
C      print*, 'Enrolled in pvm ',mytid, ' is my tid'

      call pvmfjoingroup( 'matrix', myinst )
      if( info .lt. 0 ) then
        call pvmfperror( 'joingroup: ')
        call pvmfexit( info )
        stop
      endif

C        print*, 'Joined group'

C  The following section of original code is not needed in the PSE
C  environment.  PSE starts a specific number of HPF applications 
C  processes  based on either a compile time constant or the -peers N
C  run time switch. nproc is obtained in the HPF main program and
C  passed in because number_of_processors() will return 1 in an 
C  extrinsic(hpf_local) routine.
C
C  
C  
c     Set matrix size and number of tasks.
C          call pvmfconfig( nhost, narch, dtid, host, arch, speed, info )
C          nproc = 2*nhost
C     
C          if( nproc .gt. 32 ) nproc = 32

C    Determine the number of HPF application instances and
C    set the number of processes (nproc) and host (nhost)
C    variables.

       nhost = nproc

      dimension = DEF_DIMENSION

      if( myinst .eq. 0 ) then              
        print* 
        print*, 'This program demonstrates some group and reduction'
        print*, 'operations in PVM.  The output displays the' 
        print*, 'the product of the first column of a 50x50 Toeplitz'
        print*, 'matrix and the matrix 1-norm. The matrix data is'
        print*, 'distributed among several tasks.  The Toeplitz'
        print*, 'matrix is symmetric with the first row being the'
        print*, 'row vector [1 2 ... n].'
        print* 
        print*, 'There are ',nhost, ' machines in the configuration'
        print*, 'Using ',nproc, ' tasks'
        print* 

C   PSE has already started nproc copies so the following code is not needed.
C
c       Start up more copies of myself
C        if(nproc  .gt.  1)  then
C          call pvmfspawn( 'gexample', PVMDEFAULT, '*', 
C     >                    nproc -1, tids, ninst ) 
C          if( ninst .lt. nproc-1 ) then
C            print*, 'Trouble in spawn. Check tids'
C            print*, tids
C            call pvmflvgroup( 'matrix', info )
C            call pvmfexit( info )
C          endif  
C        endif  

      endif  

c     Wait till everyone has joined the group before computing
      call pvmfbarrier( 'matrix', nproc, info )

c     Broadcast input data to all members
      if( myinst .eq. 0 ) then              
        call pvmfinitsend( PVMDEFAULT, bufid )
        call pvmfpack(INTEGER4, nproc, 1, 1, info) 
        call pvmfpack(INTEGER4, dimension, 1, 1, info )
        call pvmfbcast( 'matrix', INITTAG ,info ) 
      else
        call pvmfrecv( -1, INITTAG, info )
        call pvmfunpack( INTEGER4, nproc, 1, 1 ,info)
        call pvmfunpack( INTEGER4, dimension, 1, 1, info)
      endif  

C     Map matrix rows to processors --       
      blksize =  dimension/nproc 
      nextra =   mod(dimension, nproc) 
      if( myinst .lt.  nextra ) then 
         mysrow = 1 + (blksize + 1) * myinst  
         blksize = blksize + 1 
      else
         mysrow = 1+ (blksize + 1)*(nextra) + blksize*(myinst - nextra)
      endif 
      if( mysrow .gt. dimension)  then  
        blksize = 0
      endif 
    
C     Assign data to this subblock.  The entries below make the entire matrix
C     a symmetric Toeplitz matrix (i.e. diagonals are of constant value)  
      do j=1, dimension
        do i=1, blksize
          subblock(i,j) = abs(mysrow + i - j) 
        end do
      end do

C     Locally compute the sum of each column and put into colsum  
      do j=1, dimension
        colsum(j) = 0
        colprod(j) = 1.0
      end do 
      do j=1, dimension
        do i=1,blksize
          itemp =  abs ( subblock(i,j) )
          colsum(j) = colsum(j) + itemp
          colprod(j) = colprod(j) * itemp
        end do
      end do

C     Get global sum by calling reduce using PvmSum 
      root = 0
      call pvmfreduce( PvmSum, colsum, dimension, INTEGER4, SUMTAG,
     >                 'matrix', root, info) 

c     Here is example of supplying a user-defined OP to reduce
      call pvmfreduce( calcprod, colprod, dimension, REAL8, PRODTAG,
     >                 'matrix', root, info) 

c     Root prints out result
      if( myinst .eq. root ) then
        maxmax = 0
        do j=1,dimension
          maxmax = max(colsum(j),maxmax)
        end do
        write(6,*) ' The 1-Norm is ', maxmax 
        write(6,1000)  dimension
        write(6,*) ' The product of column 1 is', colprod(1)
        write(6,1001) dimension
      endif  
1000  format(' (Should be the sum of the first ', I3, ' integers)')
1001  format(' (Should be ', I3, ' factorial)')

c     Problem done. Be sure all members have finished computation before exit.
      call pvmfbarrier( 'matrix', nproc, info)
      call pvmflvgroup( 'matrix', info)
      call pvmfexit( info )
      return
c      end
        
      end subroutine hpf_gexample

c----------------------------------------------------------------------------
C *** Example of a User-defined Reduction Function ***/
C
      subroutine calcprod( datatype, x, y, num, info )
      integer datatype
      real*8 x(num), y(num)
      integer num, info
  
      integer i
      do i=1,num
         x(i) = x(i) * y(i)
      end do
      return
      end subroutine calcprod

        program main

        integer nproc
        
        nproc = number_of_processors()

        print*, 'There are ',nproc, ' processor in the configuration'
        
        call hpf_gexample(nproc)
 
        end program main
