
! Multi-Process Handshaking utility
! to facilitate a plug & play style programming using single executable.
! each processor could execute more than one component model (processor
! overlap) in any flexible way (any order).
! Written by Yun (Helen) He and Chris Ding, NERSC/LBNL, December 2000.


      module MPH_module
      implicit none
      include 'mpif.h'

      public
      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 comp

      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 local_world(max_num_comps) ! communicator for each component
      integer local_proc_id(max_num_comps) ! proc id in each component
      integer local_totProcs(max_num_comps) ! total processor for each component
      integer global_proc_id     ! proc id in the whole world
      integer global_totProcs    ! total processor for the whole world
      integer COMM_master    ! communicator for submaster of each component
      integer total_components 
      character*16 component_names(max_num_comps)
      integer low_proc_limit(max_num_comps)
      integer up_proc_limit(max_num_comps)
   
      private MPI_Acomponent, components
      private local_world, local_proc_id, global_proc_id
      private local_totProcs, global_totProcs, COMM_master
      private total_components, component_names
      private low_proc_limit, up_proc_limit

      contains 


!---- subroutine MPH_setup_SE_overlap (model1, model2, ...) ------

      subroutine MPH_setup_SE_overlap (model1, model2, model3, model4,
     &           model5, model6, model7, model8, model9, model10)

      character*(*),optional:: model1, model2, model3, model4, model5
      character*(*),optional:: model6, model7, model8, model9, model10
      integer id, i

      call MPH_init ()
      call MPH_local ()
      call MPH_global ()

      end subroutine MPH_setup_SE_overlap


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

      integer iblock(3), idisp(3), itype(3)

      call MPI_INIT (ierr)
      call MPI_COMM_RANK (MPI_COMM_WORLD, global_proc_id, ierr)
      call MPI_COMM_SIZE (MPI_COMM_WORLD, global_totProcs, ierr)

      total_components = MPH_read_list("processors_map.in",
     &              "PROCESSORS_MAP", component_names,   
     &              low_proc_limit, up_proc_limit, max_num_comps,
     &              local_totProcs)

! 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 () ------------

      subroutine MPH_local ()
      integer id, i, color, key

! setup local_world, local_proc_id, local_totProcs
      do id = 1, total_components
         if (low_proc_limit(id) .le. global_proc_id .and.
     &       global_proc_id .le. up_proc_limit(id)) then
            color = 1
         else
            color = 2
         endif
         key = 0
         call MPI_COMM_SPLIT (MPI_COMM_WORLD, color, key,
     &                        local_World(id), ierr)
         call MPI_COMM_RANK(local_world(id),local_proc_id(id),ierr)
      enddo

      end subroutine MPH_local 


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

      subroutine MPH_global ()
      integer id, i

! record Acomponent for each component
      do id = 1, total_components
         components(id)%name = component_names(id)
         components(id)%num_process = local_totProcs(id)
         do i = low_proc_limit(id), up_proc_limit(id)
            components(id)%process_list(i-low_proc_limit(id)+1)=i
         enddo
      enddo

! everybody lists the complete info
      do id = 1, total_components
         if (low_proc_limit(id) .le. global_proc_id .and.
     &       global_proc_id .le. up_proc_limit(id)) then
            write(*,*)'I am proc ', local_proc_id(id), ' in ',
     &           component_names(id), ' , which is proc ',
     &           global_proc_id, ' 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:9)
            enddo
         endif
      enddo

      end subroutine MPH_global


!--- function PE_in_component (name, comm) -----

      logical function PE_in_component (name, comm)
      character*(*) name
      integer id, comm

      id = MPH_find_name(name, component_names, total_components)
      if (low_proc_limit(id) .le. global_proc_id .and.
     &    global_proc_id .le. up_proc_limit(id)) then
         comm = local_world(id)
         PE_in_component = .true.
      else
         PE_in_component = .false.
      endif

      end function PE_in_component 


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

      integer function MPH_global_id (name, local_id)

      character*(*) name
      integer local_id, temp

! then find out the component rank
      temp = MPH_find_name (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 MPH_comm_join (name1, name2, comm_joined) ---

      subroutine MPH_comm_join (name1, name2, comm_joined)
      integer id1, id2

      character*(*) name1, name2
      integer comm_joined, color, key
      logical con1, con2

      id1 = MPH_find_name(name1,component_names,total_components)
      id2 = MPH_find_name(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.

      con1 = (low_proc_limit(id1) .le. global_proc_id) .and.
     &       (global_proc_id .le. up_proc_limit(id1))
      con2 = (low_proc_limit(id2) .le. global_proc_id).and.
     &       (global_proc_id .le. up_proc_limit(id2))
 
      if (con1 .or. con2) then
         color = 1
         if (con1) then 
            key = local_proc_id(id1)
         else
            key = global_totProcs + local_proc_id(id2)
         endif
      else
         color = 2
         key = 0
      endif

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

      end subroutine MPH_comm_join


! --- function MPH_read_list (filename, filetag, namelist, low, up, num) ---

      integer function MPH_read_list (filename, filetag, namelist,  
     &                            low, up, num, local_num)
      integer i, num
      character*(*) filename, filetag
      character*16 namelist(num), firstline, temp
      integer itemp1, itemp2
      integer low(num), up(num), local_num(num)

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

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

      do i = 1, num
         read(10, *, err=300, end=400) temp, itemp1, itemp2
         if (temp .eq. "END") goto 500
         namelist(i) = temp
         low(i) = itemp1
         up(i) = itemp2
         local_num(i) = itemp2 - itemp1 + 1
      enddo

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

200   print *, 'ERROR: no BEGIN in ', filename
      stop

300   if (temp .eq. "END") then
         goto 500
      else
         print *, 'ERROR: either: no END in ', filename
         print *, '       or: does not provide correct format as'
         print *, '           in input example: ocean 11 18'
         stop
      endif

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

500   MPH_read_list = i - 1

      return
      end function MPH_read_list

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

      integer function MPH_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
      MPH_find_name = -1
      print *, "ERROR: ", name, " not found in processors_map.in"
      stop

100   MPH_find_name = i
      return
      end function MPH_find_name 


! ---- some inquiry functions----------------------------------------------

      character*16 function MPH_myName(id)
         integer id
         MPH_myName = component_names (id)
      end function MPH_myName

      character*16 function MPH_component_name(id)
         integer id
         MPH_component_name = component_names (id)
      end function  MPH_component_name

      integer function MPH_total_components()
         MPH_total_components = total_components
      end function MPH_total_components

      integer function MPH_local_proc_id(id)
         integer id
         MPH_local_proc_id = local_proc_id(id)
      end function MPH_local_proc_id

      integer function MPH_global_proc_id()
         MPH_global_proc_id = global_proc_id
      end function MPH_global_proc_id

      integer function MPH_local_world(id)
         integer id
         MPH_local_world = local_world(id)
      end function MPH_local_world

      integer function MPH_low_proc_limit(id)
         integer id
         MPH_low_proc_limit = low_proc_limit(id)
      end function MPH_low_proc_limit

      integer function MPH_up_proc_limit(id)
         integer id
         MPH_up_proc_limit = up_proc_limit(id)
      end function MPH_up_proc_limit

      end module MPH_module

