mpl_init_mod.F90

Go to the documentation of this file.

MODULE mpl_init_mod

!**** MPL_INIT - Initialises the Message passing environment

!     Purpose.
!     --------
!     Must be called before any other MPL routine.

!**   Interface.
!     ----------
!        CALL MPL_INIT

!        Input required arguments :
!        -------------------------
!           none

!        Input optional arguments :
!        -------------------------
!           KOUTPUT  -  Level of printing for MPL routines
!                       =0: none
!                       =1: intermediate (default)
!                       =2: full trace
!           KUNIT    -  Fortran Unit to receive printed trace
!           LDINFO   -  = .TRUE.  : Print informative msgs from MPL_INIT (default) 
!                       = .FALSE. : Do not print

!        Output required arguments :
!        -------------------------
!           none

!        Output optional arguments :
!        -------------------------
!           KERROR   -  return error code.     If not supplied, 
!                       MPL_INIT aborts when an error is detected.
!           KPROCS   -  Number of processes which have been initialised
!                       in the MPI_COMM_WORLD communicator
!     Author.
!     -------
!        D.Dent, M.Hamrud     ECMWF

!     Modifications.
!     --------------
!        Original: 2000-09-01
!        R. El Khatib  14-May-2007 Do not propagate environment if NECSX
!        S. Saarinen 04-Oct-2009 Reduced output & redefined MPL_COMM_OML(1)
!        P. Marguinaud 01-Jan-2011 Add LDENV argument
!        R. El Khatib  24-May-2011 Make MPI2 the default expectation.
!        P. Towers     3-Jul-2014 Add call to ec_cray_meminfo
!     ------------------------------------------------------------------

USE parkind1  ,ONLY : jpim     ,jprb
USE oml_mod, ONLY : oml_init, oml_max_threads
USE mpl_mpif
USE mpl_data_module
USE mpl_message_mod
USE mpl_buffer_method_mod
USE mpl_tour_table_mod
USE mpl_locomm_create_mod
USE mpl_arg_mod

IMPLICIT NONE

PUBLIC mpl_init

PRIVATE

CONTAINS 

SUBROUTINE mpl_init(KOUTPUT,KUNIT,KERROR,KPROCS,LDINFO,LDENV)

#ifdef USE_8_BYTE_WORDS
  USE mpi4to8, ONLY : &
    mpi_initialized => mpi_initialized8, mpi_init => mpi_init8, &
    mpi_comm_size => mpi_comm_size8,     mpi_comm_rank => mpi_comm_rank8, &
    mpi_bcast => mpi_bcast8
#endif



INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KOUTPUT,KUNIT
INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KPROCS
LOGICAL,INTENT(IN),OPTIONAL :: LDINFO,LDENV
INTEGER(KIND=JPIM) :: IERROR,IP,ICOMM,IRANK,JNODE,JROC,ISTA
INTEGER(KIND=JPIM) :: IMAX_THREADS, IRET, IROOT, INUM(2), ICOUNT
INTEGER(KIND=JPIM) :: IREQUIRED,IPROVIDED
INTEGER(KIND=JPIM) :: IWORLD_RANK, IWORLD_SIZE
LOGICAL            :: LLABORT=.true., llinfo
INTEGER            :: LLINIT
LOGICAL            :: LLENV
CHARACTER(LEN=12)  :: CL_MBX_SIZE
CHARACTER(LEN=12)  :: CL_ARCH
CHARACTER(LEN=12)  :: CL_TASKSPERNODE
CHARACTER(LEN=1024) :: CLENV
CHARACTER(LEN=20)  :: CL_METHOD,CL_HOST

IF(PRESENT(koutput)) THEN
  mpl_output=max(0,koutput)
ELSE
  mpl_output=1
ENDIF

IF(PRESENT(kunit)) THEN
  mpl_unit=max(0,kunit)
ELSE
  mpl_unit=6
ENDIF

IF(PRESENT(ldinfo)) THEN
  llinfo = ldinfo
ELSE
  llinfo = .true.
ENDIF

IF(PRESENT(ldenv)) THEN
  llenv = ldenv
ELSE
  llenv = .true.
ENDIF

! If LMPLUSERCOMM is not set use MPI_COMM_WORLD
IF(lmplusercomm) THEN
   mpl_comm = mplusercomm
ELSE
   mpl_comm = mpi_comm_world
ENDIF

IF(mpl_numproc /= -1) THEN
!!  We do not want this extra message
!!  CALL MPL_MESSAGE(CDMESSAGE=' MPL_INIT CALLED MULTIPLE TIMES ')
  IF(PRESENT(kerror)) THEN
    kerror=0
  ENDIF
  IF(PRESENT(kprocs)) THEN
    kprocs=mpl_numproc
  ENDIF
  RETURN
ENDIF

CALL mpi_initialized(llinit, iret)

IF (llinit == 0) THEN

  CALL get_environment_variable('ARCH',cl_arch)

#ifndef OPS_COMPILE
#ifdef RS6K
  IF(cl_arch(1:10)=='ibm_power6')THEN
!   write(0,*)'POWER6: CALLING EC_BIND BEFORE MPI_INIT'
    CALL ec_bind()
  ENDIF
#endif
#endif

#ifndef MPI1
  irequired = mpi_thread_multiple
  iprovided = mpi_thread_single
  CALL mpi_init_thread(irequired,iprovided,ierror)
  lthsafempi = (iprovided >= irequired)
#else
  CALL mpi_init(ierror)
  lthsafempi = .false.
#endif

#ifndef OPS_COMPILE
#ifdef RS6K
  IF(cl_arch(1:10)=='ibm_power4')THEN
!   write(0,*)'POWER5: CALLING EC_BIND AFTER MPI_INIT'
    CALL ec_bind()
  ENDIF
#endif
#endif

  linitmpi_via_mpl = .true.
!  CALL ec_mpi_atexit() ! ifsaux/support/endian.c: to make sure MPI_FINALIZE gets called

ELSE
  ierror = 0
ENDIF

IF(PRESENT(kerror)) THEN
  kerror=ierror
ELSE
  IF(ierror /= 0) THEN
    CALL mpl_message(ierror,cdmessage=' MPL_INIT ERROR ',ldabort=llabort)
  ENDIF
ENDIF

CALL mpi_comm_size(mpl_comm,mpl_numproc,ierror)

IF(PRESENT(kprocs)) THEN
  kprocs=mpl_numproc
ENDIF

ALLOCATE (mpl_ids(mpl_numproc))
DO ip=1,mpl_numproc
  mpl_ids(ip)=ip
ENDDO

CALL mpi_comm_rank(mpl_comm, irank, ierror)
mpl_rank=irank+1

llinfo = llinfo .AND. (mpl_rank <= 1)

IF (llinfo) THEN
   IF(lmplusercomm) THEN
      WRITE(mpl_unit,'(A)')'MPL_INIT : LMPLUSERCOMM used'
      WRITE(mpl_unit,'(A,I8)')'Communicator : ',mpl_comm
   ELSE
      WRITE(mpl_unit,'(A)')'MPL_INIT : LMPLUSERCOMM not used'
      WRITE(mpl_unit,'(A,I8)')'Communicator : ',mpl_comm
   ENDIF
ENDIF

#ifndef NECSX

!-- Propagate environment variables & argument lists
!   Here we have to be careful and use MPI_BCAST directly (not MPL_BROADCAST) since
!   1) MPL_BUFFER_METHOD has not been called
!   2) MPL_COMM_OML has not been initialized since it is possible that only the 
!      master proc knows the # of threads (i.e. OMP_NUM_THREADS may be set only for master)

! Do not propagate on nec machine because the environment variables could be mpi-task-specific.

IF (mpl_numproc > 1 .AND. llenv) THEN
  iroot = 0
  !-- Progate environment variables
  inum(1) = 0 ! The number of environment variables
  inum(2) = 0 ! Do not (=0) or do (=1) overwrite if particular environment variable already exists (0 = default)
  IF (mpl_rank == 1) THEN ! Master proc inquires
    CALL ec_numenv(inum(1))        ! ../support/env.c
    CALL ec_overwrite_env(inum(2)) ! ../support/env.c
  ENDIF
  ! The following broadcast does not use "mailbox" nor attached buffer, both potentially yet to be allocated
  CALL mpi_bcast(inum(1),2,int(mpi_integer),iroot,mpl_comm,ierror)
  icount = len(clenv)
  DO ip=1,inum(1)
    IF (mpl_rank == 1) CALL ec_strenv(ip,clenv)
    ! The following broadcast does not use "mailbox" nor attached buffer, both potentially yet to be allocated
    CALL mpi_bcast(clenv,icount,int(mpi_byte),iroot,mpl_comm,ierror)
    IF (mpl_rank > 1) THEN
      IF (inum(2) == 1) THEN
        CALL ec_putenv(clenv) ! ../support/env.c ; Unconditionally overwrite, even if already exists
      ELSE
        CALL ec_putenv_nooverwrite(clenv) ! ../support/env.c ; Do not overwrite, if exists
      ENDIF
    ENDIF
  ENDDO
  !-- Redo some env. variables (see ../utilities/fnecsx.c)
  CALL ec_envredo()
  !-- Propagate argument list (all under the bonnet using MPL_ARG_MOD-module)
  inum = mpl_iargc()
ENDIF

#endif

CALL oml_init()
imax_threads = oml_max_threads()
ALLOCATE(mpl_comm_oml(imax_threads))

IF (lmplusercomm) THEN
   mpl_comm_oml(1) = mplusercomm
   ista = 2
ELSE
   ista = 1
ENDIF

DO ip=ista,imax_threads
  CALL mpl_locomm_create(mpl_numproc,mpl_comm_oml(ip))
ENDDO
mpl_comm = mpl_comm_oml(1) ! i.e. not necessary MPI_COMM_WORLD anymore

#ifdef VPP
mpl_method=jp_blocking_standard
mpl_mbx_size=4000000
cl_mbx_size=' '
CALL get_environment_variable('VPP_MBX_SIZE',cl_mbx_size)
IF(cl_mbx_size == ' ') THEN
  CALL get_environment_variable('MPL_MBX_SIZE',cl_mbx_size)
ENDIF
IF(cl_mbx_size /= ' ') THEN
  READ(cl_mbx_size,*) mpl_mbx_size
ENDIF
IF (llinfo) WRITE(mpl_unit,'(A)')'MPL_INIT : MPL_METHOD=JP_BLOCKING_STANDARD'
IF (llinfo) WRITE(mpl_unit,'(A,I12)')'MPL_INIT : MAILBOX SIZE=',mpl_mbx_size
lusehlmpi = .false.

!#elif defined (LINUX)
!MPL_METHOD=JP_BLOCKING_STANDARD
!MPL_MBX_SIZE=4000000
!CL_MBX_SIZE=' '
!CALL GET_ENVIRONMENT_VARIABLE('VPP_MBX_SIZE',CL_MBX_SIZE)
!IF(CL_MBX_SIZE == ' ') THEN
!  CALL GET_ENVIRONMENT_VARIABLE('MPL_MBX_SIZE',CL_MBX_SIZE)
!ENDIF
!IF(CL_MBX_SIZE /= ' ') THEN
!  READ(CL_MBX_SIZE,*) MPL_MBX_SIZE
!ENDIF
!IF (LLINFO) WRITE(MPL_UNIT,'(A)')'MPL_INIT : MPL_METHOD=JP_BLOCKING_STANDARD'
!IF (LLINFO) WRITE(MPL_UNIT,'(A,I12)')'MPL_INIT : MAILBOX SIZE=',MPL_MBX_SIZE
!LUSEHLMPI = .FALSE.

#else
cl_method=' '
CALL get_environment_variable('MPL_METHOD',cl_method)
IF (cl_method == 'JP_BLOCKING_STANDARD' ) THEN
  mpl_method=jp_blocking_standard
ELSE
  mpl_method=jp_blocking_buffered
ENDIF
mpl_mbx_size=1000000
cl_mbx_size=' '
CALL get_environment_variable('MPL_MBX_SIZE',cl_mbx_size)
IF (cl_mbx_size /= ' ') THEN
  READ(cl_mbx_size,*) mpl_mbx_size
ENDIF
IF (cl_method == 'JP_BLOCKING_STANDARD' ) THEN
  IF (llinfo) WRITE(mpl_unit,'(A)')'MPL_INIT : MPL_METHOD=JP_BLOCKING_STANDARD'
ELSE
  IF (llinfo) WRITE(mpl_unit,'(A)')'MPL_INIT : MPL_METHOD=JP_BLOCKING_BUFFERED'
ENDIF
!IF (LLINFO) WRITE(MPL_UNIT,'(A,I12)')'MPL_INIT : MAILBOX SIZE=',MPL_MBX_SIZE

CALL mpl_buffer_method(kmp_type=mpl_method,kmbx_size=mpl_mbx_size,ldinfo=llinfo)
lusehlmpi = .true.
#endif

#ifdef LINUX
CALL mpi_comm_rank (mpi_comm_world, iworld_rank, ierror)
CALL mpi_comm_size (mpi_comm_world, iworld_size, ierror)
CALL linux_bind (iworld_rank, iworld_size)
#endif

!!!! If you are not at ECMWF this may need changing!!!!
CALL get_environment_variable('EC_TASKS_PER_NODE',cl_taskspernode)
IF (cl_taskspernode(1:1) == ' ' ) THEN
   CALL get_environment_variable('HOST',cl_host)
   IF (cl_host(1:2) == 'c1') THEN
      mpl_ncpu_per_node=64
   ELSEIF(cl_host(1:3) == 'hpc') THEN
      mpl_ncpu_per_node=32
   ELSEIF(cl_host(1:2) == 'cc') THEN
      mpl_ncpu_per_node=24
   ELSE
      mpl_ncpu_per_node=1
      IF(llinfo) WRITE(mpl_unit,'(A)')'MPL_INIT CAUTION: MPL_NCPU_PER_NODE=1'
   ENDIF
ELSE
   READ(cl_taskspernode,*) mpl_ncpu_per_node  
ENDIF
mpl_max_task_per_node=max(1, mpl_ncpu_per_node/imax_threads)
lfullnodes=mod(mpl_numproc,mpl_max_task_per_node) == 0
mpl_nnodes=(mpl_numproc-1)/mpl_max_task_per_node+1
ALLOCATE(mpl_task_per_node(mpl_nnodes))
ALLOCATE(mpl_node(mpl_numproc))
ALLOCATE(mpl_node_tasks(mpl_nnodes,mpl_max_task_per_node))
mpl_node_tasks(:,:)=-99
icount=0
DO jnode=1,mpl_nnodes
  DO jroc=1,mpl_max_task_per_node
    icount=icount+1
    IF (icount<=mpl_numproc) THEN
       mpl_node(icount)=jnode
       mpl_task_per_node(jnode) = jroc
       mpl_node_tasks(jnode,jroc) = icount
    ENDIF
  ENDDO
ENDDO
mpl_mynode=(mpl_rank-1)/mpl_max_task_per_node+1
!WRITE(MPL_UNIT,*) 'MPL_INIT : NCPU_PER_NODE,MPL_MAX_TASK_PER_NODE,MPL_NNODES,MPL_MYNODE ',&
! & MPL_NCPU_PER_NODE,MPL_MAX_TASK_PER_NODE,MPL_NNODES,MPL_MYNODE
!WRITE(MPL_UNIT,*) 'MPL_INIT : MPL_NODE_TASKS(MPL_MYNODE,1:MPL_TASK_PER_NODE(MPL_MYNODE)) ', &
! & MPL_NODE_TASKS(MPL_MYNODE,1:MPL_TASK_PER_NODE(MPL_MYNODE))

ALLOCATE(mpl_opponent(mpl_numproc+1))
CALL mpl_tour_table(mpl_opponent)

#ifdef _CRAYFTN
  CALL ec_cray_meminfo(-1,"mpl_init",mpl_comm)
#endif

RETURN
END SUBROUTINE mpl_init

END MODULE mpl_init_mod