!
!   Roun_struct
!
!   An example of MPI derived data type
!
!
module mpi_stuff
    implicit none
    include 'mpif.h'   

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

    integer :: mpi_type
    integer, parameter :: num_blk=4   ! parameters to define new MPI structure
    integer, dimension(num_blk) :: v_len_blk=[1,1,3,9], v_head = [0,4,8,32], &
                   & v_el_typ=[MPI_INTEGER,MPI_INTEGER,MPI_DOUBLE_PRECISION,MPI_CHARACTER] 
    !
    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 define_mpitype(mpitype,ierr)
       implicit none
       integer, intent(inout) :: mpitype
       integer, intent(out) :: ierr
       
       call MPI_Type_struct( num_blk, v_len_blk, v_head, v_el_typ, mpitype, ierr)
       if ( ierr /= 0 ) return 
       call MPI_Type_commit(mpitype,ierr)
       
       return       
    end subroutine define_mpitype

    subroutine delete_mpitype(mpitype,ierr)
       implicit none
       integer, intent(inout) :: mpitype
       integer, intent(out) :: ierr
       
       call MPI_Type_free(mpitype,ierr)
       return
    end subroutine delete_mpitype
    !
    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_Struct
    use mpi_stuff
    implicit none
    
    integer :: next_proc, msg_tag = 111, prec_proc
    integer :: i, length
    type(heterogeneous) :: given, taken

    call start_mpi()
    call define_mpitype(mpi_type,ierr)

    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
       call MPI_Send(given, 1, mpi_type, next_proc, msg_tag, mpi_world, ierr)
       if ( ierr /= 0 ) then
          write(*,"(A)") "Error MPI_Send"
       end if
    end if

    call MPI_Recv(taken, 1, mpi_type, prec_proc, msg_tag, mpi_world, v_status, ierr)
    if ( ierr /= 0 ) then
       write(*,"(A)") "Error MPI_Recv"
    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)
       call MPI_Send(given, 1, mpi_type, next_proc, msg_tag, mpi_world, ierr)
       if ( ierr /= 0 ) then
          write(*,"(A)") "Error MPI_Send"
       end if
    end if

    call delete_mpitype(mpi_type,ierr)
    
    call mpi_finalize(ierr)
    stop
end program Round_Struct