program matmat_log
!
!*******************************************************************************
!
!! MATMAT_LOG uses MPI to multiply two matrices, with logging.
!
!
!  Discussion:
!
!    This is the simple self-scheduling version.
!
!  Reference:
!
!    Gropp, Lusk, Skjellum,
!    Using MPI,
!    Portable Parallel Programming with the Message-Passing Interface,
!    MIT Press, 1997.
!
!    Snir, Otto, Huss-Lederman, Walker, Dongarra,
!    MPI - The Complete Reference,
!    Volume 1, The MPI Core,
!    second edition,
!    MIT Press, 1998.
!
!  Modified:
!
!    11 February 2000
!
  implicit none
!
  include 'mpif.h'

  integer, parameter :: MAX_ACOLS = 1000
  integer, parameter :: MAX_AROWS = 20
  integer, parameter :: MAX_BCOLS = 20
!
  double precision a(MAX_AROWS,MAX_ACOLS)
  integer acols
  double precision ans(MAX_ACOLS)
  integer anstype
  integer arows
  double precision b(MAX_ACOLS,MAX_BCOLS)
  integer bcols
  integer brows
  double precision buffer(MAX_ACOLS)
  double precision c(MAX_AROWS,MAX_BCOLS)
  integer ccols
  integer crows
  integer donetype
  integer i
  integer ierr
  integer j
  integer master
  integer myid
  integer numprocs
  integer numrcvd
  integer numsent
  integer row
  integer sender
  double precision starttime
  double precision stoptime
  integer status(MPI_STATUS_SIZE)
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'MATMAT_LOG'
  write ( *, '(a)' ) '  A program using MPI,'
  write ( *, '(a)' ) '  to multiply two matrices.'
  write ( *, '(a)' ) ' '

  call mpi_init ( ierr )

  call mpi_comm_rank ( MPI_COMM_WORLD, myid, ierr )

  write ( *, '(a)' ) ' '
  write ( *, '(a,i6,a)' ) 'Process ', myid, ' is active.'

  call mpi_comm_size ( MPI_COMM_WORLD, numprocs, ierr )

  if ( numprocs < 2 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'MATMAT_LOG - Fatal error!'
    write ( *, '(a)' ) '  Must have at least 2 processes!'
    call mpi_abort ( MPI_COMM_WORLD, 1 )
    stop
  end if

  write ( *, '(a)' ) ' '
  write ( *, '(a,i6)' ) 'Number of process is ', numprocs

  master = 0

  arows = 10
  acols = 20
  brows = 20
  bcols = 10
  crows = arows
  ccols = bcols

  call mpe_init_log ( )
!
!  The master process initializes and then dispatches A and B.
!
  if ( myid == master ) then

    call mpe_describe_state ( 1, 2, 'Bcast', 'red:vlines3' )
    call mpe_describe_state ( 3, 4, 'Compute', 'blue:gray3' )
    call mpe_describe_state ( 5, 6, 'Send', 'green:light_gray' )
    call mpe_describe_state ( 7, 8, 'Recv', 'yellow:gray' )

    do i = 1, acols
      a(i,1:arows) = i
    end do

    do j = 1, bcols
      b(1:brows,j) = j
    end do

    numsent = 0
    numrcvd = 0
!
!  Send a row of A to each other process, tagged with the row number.
!
    do i = 1, numprocs-1

      buffer(1:acols) = a(i,1:acols)

      call mpe_log_event ( 5, i, 'send', ierr )

      call mpi_send ( buffer, acols, MPI_DOUBLE_PRECISION, i, i, &
        MPI_COMM_WORLD, ierr )

      call mpe_log_event ( 6, i, 'sent', ierr )

      numsent = numsent + 1

    end do
     
    do i = 1, crows

      call mpe_log_event ( 7, i, 'recv', ierr )

      call mpi_recv ( ans, ccols, MPI_DOUBLE_PRECISION, MPI_ANY_SOURCE, &
        MPI_ANY_TAG, MPI_COMM_WORLD, status, ierr )

      sender = status(MPI_SOURCE)
      anstype = status(MPI_TAG)

      call mpe_log_event ( 8, i, 'recvd', ierr )

      c(anstype,1:ccols) = ans(1:ccols)

      if ( numsent < arows ) then

        buffer(1:acols) = a(numsent+1,1:acols)

        call mpe_log_event ( 5, i, 'send', ierr )

        call mpi_send ( buffer, acols, MPI_DOUBLE_PRECISION, sender, &
          numsent+1, MPI_COMM_WORLD, ierr )

        call mpe_log_event ( 6, i, 'sent', ierr )

        numsent = numsent + 1

      else

        call mpe_log_event ( 5, 0, 'send', ierr )

        call mpi_send ( 1.0, 1, MPI_DOUBLE_PRECISION, sender, 0, &
          MPI_COMM_WORLD, ierr )

        call mpe_log_event ( 6, 0, 'sent', ierr )

      end if

    end do
! 
!  Print out the answer.
!
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'Initial 5 x 5 block of product:'
    write ( *, '(a)' ) ' '

    do i = 1, min ( arows, 5 )
      write ( *, '(5g14.6)' ) ( c(i,j), j = 1, min ( bcols, 5 ) )
    end do
!
!  Each slave process receives B,
!  then computes rows of C until receiving the "DONE" message.
!
  else

    call mpe_log_event ( 1, 0, "bstart" )

    do i = 1, bcols

      call mpi_bcast ( b(1,i), brows, MPI_DOUBLE_PRECISION, master, &
        MPI_COMM_WORLD, ierr )

    end do

    call mpe_log_event ( 2, 0, "bend" )

    call mpe_log_event ( 7, 0, "recv" )

    do

      call mpi_recv ( buffer, acols, MPI_DOUBLE_PRECISION, master, &
        MPI_ANY_TAG, MPI_COMM_WORLD, status, ierr )

      if ( status(MPI_TAG) == 0 ) then
        exit
      end if

      row = status(MPI_TAG)

      call mpe_log_event ( 8, row, "recvd" )

      call mpe_log_event ( 3, row, "compute" )

      do j = 1, bcols
        ans(j) = dot_product ( buffer(1:acols), b(1:acols,j) )
      end do

      call mpe_log_event ( 4, row, "computed" )

      call mpe_log_event ( 5, row, "send" )

      call mpi_send ( ans, bcols, MPI_DOUBLE_PRECISION, master, row, &
        MPI_COMM_WORLD, ierr )

      call mpe_log_event ( 6, row, "sent" )

    end do

  end if
!
!  End of execution.
!
  call mpe_finish_log ( 'matmat_log.log' )

  call mpi_finalize ( ierr )

  stop
end