PROGRAM MPIexample_struct_gather
   IMPLICIT NONE
   INCLUDE "mpif.h"

   TYPE person
      SEQUENCE
      CHARACTER(80) :: Name, Surname
      INTEGER, DIMENSION(3) :: Birth_date
      INTEGER :: Position, Id
   END TYPE person
   
   TYPE(person), dimension(8) :: lteam, team

   REAL :: tempo2, tempo1, tempro
  
   integer :: i, j
!  MPI variables
   CHARACTER(MPI_MAX_PROCESSOR_NAME) :: server
   INTEGER :: ierr, my_rank, numprocs, person_type, ls
   INTEGER :: num_blk, v_len_blk(5), v_head(5), v_el_typ(5)
!
   INTEGER :: num_el, el_type, pair_type, a0, a1
!
   CALL MPI_INIT( ierr )
   CALL MPI_COMM_RANK( MPI_COMM_WORLD, my_rank, ierr )
   CALL MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr )
   CALL MPI_Get_processor_name(server,ls,ierr)
   
   IF ( numprocs /= 4 ) THEN
      WRITE(*,*) "There must be 4 processes!"
      CALL Terminate(my_rank)
   ENDIF
!
!  should be read from an archive
   team(1) = person("John","Dalton",[4,1,1979],0,0)
   team(2) = person("Timothy","Dunlop",[6,5,1981],0,0)
   team(3) = person("Mary","Bond",[12,7,1977],0,0)
   team(4) = person("Helen","Fittipaldi",[1,1,1982],0,0)
   team(5) = person("Jossef","Kongrua",[11,30,1989],0,0)
   team(6) = person("Niky","Red",[2,29,1980],0,0)
   team(7) = person("Nikita","Palmer",[10,18,1988],0,0)
   team(8) = person("Mortimer","Smith",[3,3,1983],0,0)

   j = 0
   do i = 1, 8
      if ( mod(i,numprocs) == my_rank ) then
         j = j+1
         lteam(j) = team(i)
         lteam(j)%Position = my_rank
         lteam(j)%Id = my_rank*100+j
      endif
   enddo

   IF ( my_rank == 0 ) THEN
      CALL CPU_TIME(tempo1)
   ENDIF
 
   num_blk = 5
   v_len_blk = [80,80,3,1,1]
   ! v_head = [0,80,160,172,176]
   
   v_head(1) = 0   
   CALL MPI_Address(team(2)%Name,a0,ierr)
   CALL  MPI_Address(team(2)%Surname,a1,ierr)
   v_head(2) = a1-a0
   CALL  MPI_Address(team(2)%Birth_date,a1,ierr)
   v_head(3) = a1-a0
   CALL  MPI_Address(team(2)%Position,a1,ierr)
   v_head(4) = a1-a0
   CALL  MPI_Address(team(2)%Id,a1,ierr)
   v_head(5) = a1-a0
   v_el_typ = [MPI_CHARACTER,MPI_CHARACTER,MPI_INTEGER, &
      & MPI_INTEGER,MPI_INTEGER]
      
   CALL MPI_Type_struct(num_blk,v_len_blk,v_head,v_el_typ,person_type,ierr)

   CALL MPI_Type_commit(person_type,ierr)

   num_el=2
   call MPI_Type_contiguous (num_el, person_type, pair_type, ierr)
   CALL MPI_Type_commit(pair_type,ierr)

   call MPI_Allgather ( lteam, 1, pair_type, team, 1, pair_type, MPI_COMM_WORLD, ierr )
   
    IF ( my_rank == 0 ) THEN
       do i = 1, 8
           call print_person(team(i))
       enddo
          
       CALL CPU_TIME(tempo2)
   
       tempro =  (tempo2 - tempo1)

       WRITE(*,*) "CPU time is ",tempro
    ENDIF
   CALL Terminate(my_rank)
   STOP
CONTAINS
   SUBROUTINE print_person(p)
      IMPLICIT NONE
      TYPE(person), INTENT(IN) :: p
      
      WRITE(*,"(A,I4,5A,2(I2,A),I4,A,I4)") "Person Id: ",p%Id,",",TRIM(p%Name)," ",TRIM(p%Surname),", born: ", &
         p%Birth_date(1),"-",p%Birth_date(2),"-",p%Birth_date(3)," position: ",p%Position
   END SUBROUTINE print_person
END PROGRAM MPIexample_struct_gather

SUBROUTINE Terminate(p)
   IMPLICIT NONE
   INTEGER, INTENT(IN) :: P
   INCLUDE "mpif.h"
   INTEGER :: ierr
   
   WRITE(*,*) "Process ",p," terminates"
   CALL MPI_Finalize(ierr)
   
   STOP
END SUBROUTINE Terminate