mpl_arg_mod.F90

Go to the documentation of this file.

MODULE mpl_arg_mod

!**** MPL_GETARG : A substitute for GETARG for MPL applications
!     MPL_IARGC  : A substitute for function IARGC for MPL applications

!     Purpose.
!     --------
!     MPL-task#1 calls getarg until iargc() arguments read
!     or until the argument is a terminating argument
!     Then arguments are passed on to other processors
!     If MPL has not been initialized, it will be done now.

!**   Interface.
!     ----------
!        CALL MPL_GETARG(KARG, CDARG)

!        Input required arguments :
!        -------------------------
!           KARG     -  The argument number requested (INTEGER(4))
!                       Range : [ 0 .. MPL_IARGC() ]

!        Output required arguments :
!        ---------------------------
!           CDARG    -  Return argument value (CHARACTER(LEN=*))
!
!**   Interface.
!     ----------
!        INUM_ARGS = MPL_IARGC()
!
!     where INUM_ARGS is INTEGER(4)

!     Author.
!     -------
!        S.Saarinen, G.Mozdzynski  ECMWF

!     Modifications.
!     --------------
!        Original: 2006-03-15

USE parkind1  ,ONLY : jpim
USE mpl_mpif
USE mpl_data_module, ONLY : mpl_numproc,linitmpi_via_mpl,lmplusercomm,mplusercomm


#ifdef NAG
USE f90_unix_env, ONLY: getarg, iargc
#endif

IMPLICIT NONE

PRIVATE

CHARACTER(LEN=10), SAVE :: cl_terminate = '-^' ! terminating argument

INTEGER(KIND=JPIM), PARAMETER :: jp_arglen = 1024
CHARACTER(LEN=JP_ARGLEN), ALLOCATABLE, SAVE :: cl_args(:)
INTEGER(KIND=JPIM), SAVE :: n_args = -1

PUBLIC :: mpl_getarg
PUBLIC :: mpl_iargc
PUBLIC :: mpl_arg_set_cl_terminate
PUBLIC :: mpl_arg_get_cl_terminate

CONTAINS

SUBROUTINE mpl_arg_set_cl_terminate(CDTERM)
CHARACTER(LEN=*), INTENT(IN) :: CDTERM
cl_terminate = cdterm
END SUBROUTINE mpl_arg_set_cl_terminate

SUBROUTINE mpl_arg_get_cl_terminate(CDTERM)
CHARACTER(LEN=*), INTENT(OUT) :: CDTERM
cdterm = cl_terminate
END SUBROUTINE mpl_arg_get_cl_terminate

SUBROUTINE init_args()

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

INTEGER(KIND=JPIM) :: IARGS
INTEGER(KIND=JPIM) :: IERROR, IROOT, ICOUNT
INTEGER(KIND=JPIM) :: IRANK, INUMPROC, IRET, J
#ifndef NAG
INTEGER(KIND=JPIM) :: IARGC
#endif
INTEGER(KIND=JPIM) :: IARGC_C
CHARACTER(LEN=LEN(CL_TERMINATE)) :: ENV_CL_TERMINATE
CHARACTER(LEN=JP_ARGLEN) :: CLARG0
LOGICAL LLCARGS
INTEGER LLINIT
INTEGER(KIND=JPIM) :: ICOMM

IF (n_args == -1) THEN
  IF (mpl_numproc == -1) THEN
    ! This is complicated, but I hope it works:
    ! MPI has not yet been initialized, when this routines was called.
    ! Initialize MPI, but NOT via MPL_INIT to avoid recursion in MPL_IARGC()
    ! However, must pretend that MPL_INIT has actually initialized it, but 
    ! MPL_NUMPROC will not be set
    CALL mpi_initialized(llinit,iret)
    IF (llinit == 0) THEN
      CALL mpi_init(ierror)
      linitmpi_via_mpl = .true.
      CALL ec_mpi_atexit() ! ifsaux/support/endian.c: to make sure MPI_FINALIZE gets called
    ENDIF
  ENDIF

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

  CALL mpi_comm_size(icomm,inumproc,ierror)
  CALL mpi_comm_rank(icomm,irank,ierror)
  irank=irank+1

  IF (irank == 1 .OR. inumproc == 1) THEN
    CALL get_environment_variable('MPL_CL_TERMINATE',env_cl_terminate)
    IF (env_cl_terminate /= ' ') cl_terminate = env_cl_terminate
    iargs = iargc()
    llcargs = (iargs < 0) ! Should be true for non-F90 main programs
    IF (llcargs) THEN
      iargs = iargc_c()
      llcargs = (iargs >= 0)
      CALL getarg_c(0,clarg0) ! The executable name (see ifsaux/support/cargs.c)
    ELSE
      CALL putarg_info(iargs, trim(cl_terminate)) ! (see ifsaux/support/cargs.c)
      CALL getarg(0,clarg0)                       ! The executable name (normal F90 way)
      CALL putarg_c(0,trim(clarg0))               ! (see ifsaux/support/cargs.c)
    ENDIF
    IF (iargs < 0) iargs = 0
    ALLOCATE(cl_args(0:iargs))
    n_args = 0
    cl_args(0) = clarg0
    DO j=1,iargs ! Other args (repeat until end of loop or terminating argument found)
      IF (llcargs) THEN
        CALL getarg_c(j,cl_args(j))
      ELSE
        CALL getarg(j,cl_args(j))
        CALL putarg_c(j,trim(cl_args(j)))
      ENDIF
      IF (cl_args(j) == cl_terminate) EXIT
      n_args = n_args + 1
    ENDDO
  ENDIF

  IF (inumproc > 1) THEN
    iroot = 0
    iargs = 0
    IF (irank == 1) iargs = n_args
    ! The following broadcast does not use "mailbox" nor attached buffer, both potentially yet to be allocated
    CALL mpi_bcast(iargs,1,mpi_integer,iroot,icomm,ierror)
    icount = jp_arglen
    IF (irank > 1) ALLOCATE(cl_args(0:iargs))
    IF (irank > 1) CALL putarg_info(iargs, trim(cl_terminate))
    DO j=0,iargs
     ! The following broadcast does not use "mailbox" nor attached buffer, both potentially yet to be allocated
      CALL mpi_bcast(cl_args(j),icount,mpi_byte,iroot,icomm,ierror)
      IF (irank > 1) CALL putarg_c(j,trim(cl_args(j)))
    ENDDO
    IF (irank > 1) n_args = iargs
  ENDIF
ENDIF
END SUBROUTINE init_args

SUBROUTINE mpl_getarg(KARG, CDARG)
INTEGER(KIND=JPIM), INTENT(IN) :: KARG
CHARACTER(LEN=*), INTENT(OUT)  :: CDARG
#ifndef NAG
INTEGER(KIND=JPIM) :: IARGC
#endif
IF (n_args == -1) CALL init_args()
IF (karg >= 0 .AND. karg <= n_args) THEN
  cdarg = cl_args(karg)
ELSE
  cdarg = ' '
ENDIF
END SUBROUTINE mpl_getarg

FUNCTION mpl_iargc() RESULT(IRET)
INTEGER(KIND=JPIM) :: IRET
IF (n_args == -1) CALL init_args()
iret = n_args
END FUNCTION mpl_iargc

END MODULE mpl_arg_mod