! Multi-Process Handshaking utility
! to facilitate a plug & play style programming on
! using multiple component executables.
! Written by Yun (Helen) He and Chris Ding, NERSC/LBNL.

      module MPH_comm
      implicit none
      include 'mpif.h'

      integer istatus(MPI_STATUS_SIZE), ierr 
      integer max_num_comps, maxProcs_comp
      parameter (max_num_comps=20)     ! maximum number of components
      parameter (maxProcs_comp=128)   ! maximum number of procs per components

      type Acomponent
         character*16 name          ! component name
         integer num_process        ! number of processors 
         integer process_list(maxProcs_comp) 
                                    ! global processor_id, increasing order
      end type Acomponent           
          
      type (Acomponent) :: components(max_num_comps) ! allocate components
      integer MPI_Acomponent

      integer icomp, icomp2    ! category to create sub communicators
      integer key              ! order in same communicator
      integer myWorld          ! communicator for this component
      integer myProc           ! my rank in this component
      integer totProcs         ! total processor for this component
      integer myProc_global    ! my rank in the whole world
      integer totProcs_global  ! total processor for the whole world

      integer COMM_master    ! communicator for submaster of each component
    
      character*16 myName
      character*16 component_names(max_num_comps)
      integer total_components 
 
      contains

!--------------- subroutine MPH_setup (comp_name, comm_world) ---------

      subroutine MPH_setup (comp_name, comm_world)
      
      character*(*) comp_name
      integer comm_world

      myName = comp_name
      call MPH_init ()
      call MPH_local ()
      call MPH_global ()
      call MPI_COMM_DUP (myWorld, comm_world, ierr)

      end subroutine MPH_setup

!--------------- subroutine MPH_init () ------------
	
      subroutine MPH_init ()

      integer iblock(3), idisp(3), itype(3)
      call MPI_COMM_RANK (MPI_COMM_WORLD, myProc_global, ierr)
      call MPI_COMM_SIZE (MPI_COMM_WORLD, totProcs_global, ierr)

      total_components = read_list("components.in", "COMPONENT_LIST",  
     &                             component_names, max_num_comps)

! create a new MPI data type MPI_Acomponent

      iblock(1) = 16
      iblock(2) = 1
      iblock(3) = maxProcs_comp
      idisp(1) = 0
      idisp(2) = 16
      idisp(3) = 20
      itype(1) = MPI_CHARACTER
      itype(2) = MPI_INTEGER
      itype(3) = MPI_INTEGER
      call MPI_TYPE_STRUCT (3,iblock,idisp,itype,MPI_Acomponent,ierr)
      call MPI_TYPE_COMMIT (MPI_Acomponent, ierr)

      end subroutine MPH_init


!--------------- subroutine MPH_local () ------------

! local hand-shaking

      subroutine MPH_local ()

      icomp = find_name (myName, component_names, total_components)
      key = 0
      call MPI_COMM_SPLIT (MPI_COMM_WORLD, icomp, key, myWorld, ierr)

! setup myWorld, myProc, totProcs
      call MPI_COMM_RANK (myWorld, myProc, ierr)
      call MPI_COMM_SIZE (myWorld, totProcs, ierr)

      components(icomp)%name = myName
      components(icomp)%num_process = totProcs

! gather processor ids to 0th proc in this component.
      call MPI_GATHER (myProc_global, 1, MPI_INTEGER,  
     &                 components(icomp)%process_list, 1, MPI_INTEGER,  
     &                 0, myWorld, ierr)

! broadcast the process_list to all process in this component
! so that every processor has the complete component structure
!      call MPI_BCAST (components(icomp)%process_list, totProcs, 
!     &                MPI_INTEGER, 0, myWorld, ierr)

      end subroutine MPH_local 


!--------------- subroutine MPH_global () ------------

! global hand-shaking among root processors of each component.

      subroutine MPH_global ()
      integer sendtag, recvtag, i

! create a MPI communicator COMM_master for all submasters
! arrange the rank of the submasters in COMM_master by their icomp
! i.e., their rank of the component model in "components.in" 
      if (myProc == 0) then
         icomp2 = 1
      else
         icomp2 = 2
      endif
      key = icomp
      call MPI_COMM_SPLIT (MPI_COMM_WORLD,icomp2,key,COMM_master,ierr)

! gather Acomponents to 0th proc in COMM_master
      if (myProc == 0) then
         call MPI_GATHER (components(icomp), 1, MPI_Acomponent,
     &                    components, 1, MPI_Acomponent,
     &                    0, COMM_master, ierr)

! 0th proc in COMM_master broadcast Acomponents to all submasters
         call MPI_BCAST (components, total_components,
     &                   MPI_Acomponent, 0, COMM_master, ierr)
      endif

! submaster broadcast AComponents to all process in the components
      call MPI_BCAST (components, total_components,
     &                MPI_Acomponent, 0, myWorld, ierr)

! everybody lists the complete info
      write(*,*)'I am proc ', myProc, ' in ', myName, 
     &          ' , which is proc ', myProc_global, ' in global_world' 
      write(*,*)'infos I have for all proc of all components are:'
      do i = 1, total_components
         write(*,*)'   ', components(i)%name
         write(*,*)'   ', components(i)%num_process
         write(*,*)'   ', components(i)%process_list(1:8)  ! partial list
      enddo

      end subroutine MPH_global


!--- function MPH_global_id (comp_name, local_id) -----

      integer function MPH_global_id (comp_name, local_id)

      character*(*) comp_name
      integer local_id, temp

! then find out the component rank
      temp = find_name (comp_name, component_names, total_components)

! process_list starts from 1, while proc rank starts from 0
      MPH_global_id = components(temp) % process_list(local_id+1)

      end function MPH_global_id


! -------subroutine comm_join (comp_name1, comp_name2, comm_joined) ---

      subroutine comm_join (comp_name1, comp_name2, comm_joined)

      character*(*) comp_name1, comp_name2
      integer temp1, temp2
      integer comm_joined

      temp1 = find_name (comp_name1, component_names, total_components)
      temp2 = find_name (comp_name2, component_names, total_components)

! the order of two components does matter: first one has lower ranks in 
! the new joined communicator, and second one has higher ranks.

      if (icomp == temp1 .or. icomp == temp2) then
         icomp2 = 1
         if (icomp == temp1) then
            key = myProc
         else
            key = totProcs_global + myProc
         endif
      else
         icomp2 = 2
         key = 0
      endif

      call MPI_COMM_SPLIT (MPI_COMM_WORLD,icomp2,key,comm_joined,ierr)

      end subroutine comm_join

! --------------- function read_list(filename, namelist, num) ------------

      integer function read_list (filename, filetag, namelist, num)
      integer i, num
      character*(*) filename, filetag
      character*16 namelist(num), firstline, temp

      open(10, file=filename, status='unknown')
      read(10, '(a16)', end=200) firstline
      if (firstline .ne. filetag) then
         print *, 'ERROR: filetag inconsistent', filename
         print *, 'ERROR: ', filetag, '!=', firstline
         stop
      endif

      read(10, '(a16)', end=200) temp
      if (temp .ne. 'BEGIN') then
         print *, 'ERROR: no BEGIN in ', filename
         stop
      endif

      do i = 1, num
         read(10, '(a16)', end=100) temp
         if (temp .ne. 'END') then
             namelist(i) = temp
         else
             goto 200
         endif
      enddo

100   print *, 'ERROR: no END in ', filename
      stop

200   read_list = i - 1

      return
      end function read_list

      
!---------- function find_name(name, namelist, num) ------------

      integer function find_name(name, namelist, num)

! find name in component_names
      character*(*) name
      integer i, num
      character*16 namelist(num)

      do i = 1, num
         if (name == namelist(i)) then
!            print *, i, name, namelist(i)
            goto 100
         endif
      enddo

! name is not found
      find_name = -1
      print *, "ERROR: ", name, " not found in components.in"
      stop

100   find_name = i
      return
      end function find_name 

      end module MPH_comm
