!
!   Round_pack 
!   
!   Example of communicating heterogeneous data using MPI_Pack/Unpack    
!
!
module mpi_stuff
    implicit none
    include 'mpif.h'   

    type heterogeneous   ! data structure to be sent
       integer :: a, b
       real(8), dimension(3) :: v
       character(9) :: str
    end type heterogeneous    

    integer, parameter :: buffer_size=42
    character(buffer_size) :: buffer
    !
    integer, dimension(MPI_STATUS_SIZE) :: v_status
    integer ::  ierr, proc_rank, mpi_procs = 0, mpi_world
    character(MPI_MAX_PROCESSOR_NAME) :: processor_name
    !
contains
    subroutine start_mpi()
        implicit none
        integer :: namelen
        
        if (mpi_procs.gt.0) return
        call mpi_init(ierr)
        mpi_world = MPI_COMM_WORLD
        call mpi_comm_rank(mpi_world, proc_rank, ierr)
        call mpi_comm_size(mpi_world, mpi_procs, ierr)
        call MPI_Get_processor_name(processor_name,namelen, ierr)
        if ( namelen > 9 ) processor_name=processor_name(1:9)
        return
    end subroutine start_mpi
    !
    subroutine pack_data(lbuffer, buffer, sbuffer, dataval, ierr)
       implicit none
       integer, intent(inout) :: lbuffer
       integer, intent(in) :: sbuffer
       character(sbuffer), intent(inout) :: buffer
       type(heterogeneous), intent(in) :: dataval
       integer, intent(out) :: ierr

       call MPI_Pack(dataval%a, 1, MPI_INTEGER, buffer, sbuffer, lbuffer, MPI_COMM_WORLD, ierr);
       if ( ierr /= 0 ) return
       call MPI_Pack(dataval%b, 1, MPI_INTEGER, buffer, sbuffer, lbuffer, MPI_COMM_WORLD, ierr);
       if ( ierr /= 0 ) return
       call MPI_Pack(dataval%v, 3, MPI_DOUBLE_PRECISION, buffer, sbuffer, lbuffer, MPI_COMM_WORLD, ierr);
       if ( ierr /= 0 ) return
       call MPI_Pack(dataval%str, 9, MPI_CHARACTER, buffer, sbuffer, lbuffer, MPI_COMM_WORLD, ierr);
     
       return
    end subroutine pack_data
    !
    subroutine unpack_data(lbuffer, buffer, sbuffer, dataval, ierr)
       implicit none
       integer, intent(inout) :: lbuffer
       integer, intent(in) :: sbuffer
       character(sbuffer), intent(in) :: buffer
       type(heterogeneous), intent(out) :: dataval
       integer, intent(out) :: ierr

       call MPI_UnPack(buffer, sbuffer, lbuffer, dataval%a, 1, MPI_INTEGER, MPI_COMM_WORLD,ierr);
       if ( ierr /= 0 ) return
       call MPI_UnPack(buffer, sbuffer, lbuffer, dataval%b, 1, MPI_INTEGER, MPI_COMM_WORLD,ierr);
       if ( ierr /= 0 ) return
       call MPI_UnPack(buffer, sbuffer, lbuffer, dataval%v, 3, MPI_DOUBLE_PRECISION, MPI_COMM_WORLD,ierr);
       if ( ierr /= 0 ) return
       call MPI_UnPack(buffer, sbuffer, lbuffer, dataval%str, 9, MPI_CHARACTER, MPI_COMM_WORLD, ierr);
     
       return
    end subroutine unpack_data
    !
    subroutine initialize_data(given)
       implicit none
       type(heterogeneous), intent(out) :: given
       
       integer :: i
       
       given%a = proc_rank; given%b = 0
       do i = 1, 3
          given%v(i) = i
       end do
       given%str = processor_name
       
       write(*,"(A,I4,A,2I6,3(F4.1,1X),A)") " Processor ",proc_rank," initialized data: ", given%a, given%b, &
          & given%v, given%str
          
       return
    end subroutine initialize_data
    !
    subroutine update_data(given, taken)
       implicit none
       type(heterogeneous), intent(out) :: given
       type(heterogeneous), intent(in) :: taken
       
       integer :: i

       write(*,"(A,I4,A,2I6,3(F4.1,1X),A)") " Processor ",proc_rank," received: ", taken%a, taken%b, &
          & taken%v, taken%str
       given%a = proc_rank; given%b = taken%b + 1
       do i = 1, 3
          given%v(i) = taken%v(i) + i;
       end do
       given%str = taken%str
       
       return
    end subroutine update_data

    !
end module mpi_stuff
!
!   Example program: round robin
!
program Round_Pack
    use mpi_stuff
    implicit none
    
    integer :: next_proc, msg_tag = 111, prec_proc
    integer :: i, length
    type(heterogeneous) :: given, taken

    call start_mpi()

    next_proc = mod(proc_rank+1, mpi_procs)
    prec_proc = mod(mpi_procs+proc_rank-1, mpi_procs)
    
    call initialize_data(given)
      
    if (proc_rank.eq.0) then
       length = 0
       call pack_data(length, buffer, buffer_size, given, ierr) 
       if ( ierr /= 0 ) then
          write(*,"(A)") "Error pack_data"
       end if
       
       call MPI_Send(buffer, length, MPI_PACKED, next_proc, msg_tag, mpi_world, ierr)
       if ( ierr /= 0 ) then
          write(*,"(A)") "Error MPI_Send"
       end if
    end if
    
    length=41
    call MPI_Recv(buffer, length, MPI_PACKED, prec_proc, msg_tag, mpi_world, v_status, ierr)
    if ( ierr /= 0 ) then
       write(*,"(A)") "Error MPI_Recv"
    end if
        
    length = 0
    call unpack_data(length, buffer, buffer_size, taken, ierr)
    if ( ierr /= 0 ) then
       write(*,"(A)") "Error unpack_data"
    end if
    if ( proc_rank == 0 ) then
       write(*,"(A,I4,A,2I6,3(F4.1,1X),A)") " Processor ",proc_rank," received: ", taken%a, taken%b, &
          & taken%v, taken%str
    else
       call update_data(given,taken)
       length = 0
       call pack_data(length, buffer, buffer_size, given, ierr)
       if ( ierr /= 0 ) then
          write(*,"(A)") "Error pack_data"
       end if
       call MPI_Send(buffer, length, MPI_PACKED, next_proc, msg_tag, mpi_world, ierr)
       if ( ierr /= 0 ) then
          write(*,"(A)") "Error MPI_Send"
       end if
    end if

    call mpi_finalize(ierr)
    stop
end program Round_Pack