ecearth3/sources/tm5mp/base/go_system.F90

!###############################################################################
!
! NAME
!   GO_System  -  machine and/or compiler specific stuff
!
!
! DESCRIPTION
!
!   The module GO_System provides some basic constants for the
!   current compiler. In addition, some interfaces are defined
!   to routines for system calls, setting of exit statuses etc, 
!   which are non-standard Fortran, but often provided by the
!   vendor of the compiler. 
!   Since both constants and system routines differ from compiler
!   to compiler, this GO module is available in a number of copies,
!   each valid for a single compiler. If for some compiler a 
!   certain constant or system routine could not be filled,
!   a dummy value is used or a warning is issued.
!
!   The following system routines are defined:
!
!    o call goSystem( command, status )
!        Perform a system command, return exit status.
!
!    o call goExit( status )
!        Stop execution, set the exit status.
!
!    o call goArgCount( narg, status )
!        Count number of command line arguments.
!
!    o call goGetArg( nr, value, status )
!        Returns command line argument 'nr' in character string 'value'.
!
!    o call goSleep( nsec, status )
!        Wait for some seconds.
!
!
! GFORTRAN
!
!   Online manual:
!
!     gcc.gnu.org/onlinedocs/
!       (choose version)
!
!   Macro's defined from version 4.3.5 onwards
!   (section "Preprocessing and conditional compilation" in the manual):
!
!     __GFORTRAN__
!     __GNUC__, __GNUC_MINOR__, __GNUC_PATCHLEVEL__ 
!
!   According to the manual, this should work to list all defined macro's,
!   but when tested it only seemd to work with gcc:
!
!     gfortran -dM test.F90
!
!
! INTEL FORTRAN COMPILER
!
!   Online manual:
!
!       www.intel.com
!         Sitemap, Software, Find Product : Intel Compilers
!           Select 'Product Documentation' from the side menu
!             Intel Fortran Compiler 11.1 User and Reference Guides
!             (http://software.intel.com/sites/products/documentation/hpc/compilerpro/en-us/fortran/lin/compiler_f/index.htm)
!               Language Reference
!
!   Macro's defined:
!
!     __INTEL_COMPILER     ! evaluates to version number
!
!
! IBM XLF COMPILER
!
!   Online manuals are there but hard to locate; therefore some hints:
!
!     Language Reference - XL Fortran for AIX, V12.1
!       Service and utility procedures
!         General service and utility procedures
!
!   For the macro definitions, see:
!
!     XL C/C++ Compiler Reference Version 10.1
!       Compiler Predefined Macros
!         Macros indicating the XL C/C++ compiler product
!
!   Use '__IBMC__' rather than __xlc__ since the first evaluates
!   to a single integer number which can be tested with:
!     #if __IBMC__ == 1010
!   while the later evaluates to string like '10.1.0.4' .
!              
!   Compilation on ECMWF systems fails during linking because 'Exit_'
!   and 'Sleep_' could not be found. Although these are the standard names
!   according to the Compiler Reference, the ECMWF implementation only
!   recoqnizes 'Exit' and 'Sleep' (thus without underscores).
!   Adding the flag '-qnoextname' solves this, but induces a failure in
!   linking the HDF4 library. Therefore, a macro '__ecmwf__' should be
!   defined to distuinguish between XLF implementations at ECMWF and
!   at other institutes.
!
!
!###############################################################################
!
#define TRACEBACK write (gol,'("in ",a," (line",i5,")")') __FILE__, __LINE__; call goErr
#define IF_NOTOK_RETURN(action) if (status/=0) then; TRACEBACK; action; return; end if
#define IF_ERROR_RETURN(action) if (status >0) then; TRACEBACK; action; return; end if
!
!###############################################################################

module GO_System

  use GO_Print, only : gol, goPr, goErr
  
  implicit none

  ! --- in/out ------------------------------
  
  private
  
  public   ::  goSystem
  public   ::  goExit
  public   ::  goArgCount, goGetArg
  public   ::  goSleep
  
  public   ::  pathsep
  
  
  ! --- const ---------------------------------
  
  ! module name
  character(len=*), parameter  ::  mname = 'GO_System'
  
  ! path seperation:
  character(len=1), parameter  ::  pathsep = '/'
    

contains



  ! ############################################################################
  ! ###
  ! ### goSystem
  ! ###
  ! ############################################################################


  ! Execute a system command, return exit status.
  
  subroutine goSystem( command, status )
  
#ifdef __INTEL_COMPILER
    use IFPort, only : System
    use IFPort, only : iErrNo, E2BIG, ENOENT, ENOEXEC, ENOMEM
#endif
  
    ! --- in/out -----------------------------------------------
    
    character(len=*), intent(in)       ::  command
    integer, intent(inout)             ::  status
    
    ! --- const ------------------------------------------------
    
    character(len=*), parameter  ::  rname = mname//'/goSystem'
    
    ! --- local --------------------------------------------------
    
#ifdef __INTEL_COMPILER
    integer(4)     ::  stat
    integer(4)     ::  errno
#endif

    ! --- begin --------------------------------------------------
    
#ifdef __INTEL_COMPILER

    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ! Intel Compiler
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    !
    ! From manual:
    !   
    !   Intel Fortran Compiler 11.1 User and Reference Guides
    !     Language Reference
    !       A to Z Reference
    !         System
    !
    stat = System( command )
    
    ! trap errors in ifort system command
    if ( stat == -1 ) then
      write (gol,'("error in call to IFort Portability command `system`:")'); call goErr
      errno = iErrNo()
      select case ( errno )
        case ( E2BIG )
          write (gol,'("  ",a)') 'The argument list is too long.'; call goErr
        case ( ENOENT )
          write (gol,'("  ",a)') 'The command interpreter cannot be found.'; call goErr
        case ( ENOEXEC )
          write (gol,'("  ",a)') 'The command interpreter file has an invalid format and is not executable.'; call goErr
        case ( ENOMEM )
          write (gol,'("  ",a)') 'Not enough system resources are available to execute the command.'; call goErr
        case default
          write (gol,'("  unknown iErrNo ",i)') errno; call goErr
      end select
      TRACEBACK; status=stat; return
    end if
    
    ! if the shell command exit status is 'n',
    ! then the number returned by 'system' is 256 * n
    status = stat / 256

#else
#ifdef __GFORTRAN__ 

    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ! GNU Fortran Compiler
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    !
    ! From manual:
    !
    !   gcc.gnu.org/onlinedocs/
    !     GCC 4.3.5 GNU Fortran 95 Manual
    !       6. Intrinsic Prodedures
    !         204. SYSTEM - Execute a shell command
    !
    call System( command, status )

#else
#ifdef __IBMC__ 

    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ! IBM XL Fortran Compiler
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    !
    ! From manual:
    !
    !   Language Reference - XL Fortran for AIX, V12.1
    !     Intrinsic Procedures
    !
    call System( command, status )

#else

    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ! error ...
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    !write (gol,'("could not evaluate system command : ",a)') trim(command); call goErr
    !write (gol,'("subroutine not implemented for this compiler")'); call goErr
    !TRACEBACK; status=1; return

    ! try this, often works:
    call System( command, status )

#endif
#endif
#endif
  
  end subroutine goSystem
  
  
  ! ############################################################################
  ! ###
  ! ### goExit
  ! ###
  ! ############################################################################


  ! Stop execution, set exit status.
  
  subroutine goExit( status )
  
#ifdef __IBMC__
    use XLFUtility, only : Exit_
#endif

    ! --- in/out --------------------------------------------
    
    integer, intent(in)    ::  status
    
    ! --- const ------------------------------------------------
    
    character(len=*), parameter  ::  rname = mname//'/goExit'
    
    ! --- begin --------------------------------------------
    
#ifdef __INTEL_COMPILER

    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ! Intel compiler
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    !
    ! From manual:
    !   
    !   Intel Fortran Compiler 11.1 User and Reference Guides
    !     Language Reference
    !       A to Z Reference
    !         Exit Subroutine
    !
    call Exit( status )

#else
#ifdef __GFORTRAN__
    
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ! GNU Fortran compiler
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    !
    ! From manual:
    !
    !   gcc.gnu.org/onlinedocs/
    !     GCC 4.3.5 GNU Fortran 95 Manual
    !       6. Intrinsic Prodedures
    !         6.66. EXIT - Exit the program with status.
    !
    call Exit( status )
    
#else
#ifdef __IBMC__
    
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ! IBM XLF compiler
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    !
    ! From manual:
    !
    !   Language Reference - XL Fortran for AIX, V12.1
    !     Service and utility procedures
    !       General service and utility procedures
    !
#ifdef __ecmwf__
    call Exit( status )
#else
    call Exit_( status )
#endif
    
#else

    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ! error ...
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    !write (gol,'("subroutine not implemented for this compiler")'); call goErr
    
    !! this is an emergency, so for one time, the Fortran stop is allowed ...
    !stop 'Fortran STOP in GO_System/goExit'

    ! try this, often works:
    call Exit( status )

#endif
#endif
#endif
  
  end subroutine goExit


  ! ############################################################################
  ! ###
  ! ### goArgCount
  ! ###
  ! ############################################################################


  ! Return number of command line arguments
  
  subroutine goArgCount( narg, status )
  
    ! --- in/out --------------------------------------------
    
    integer, intent(out)    ::  narg
    integer, intent(out)    ::  status

    ! --- const ------------------------------------------------
    
    character(len=*), parameter  ::  rname = mname//'/goArgCount'
!***ABUTZ:2012-04-12@imkpcabu
    integer                      ::  iargc

    ! --- begin -------------------------------------------------
    
#ifdef __INTEL_COMPILER

    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ! Intel Compiler
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    !
    ! From manual:
    !   
    !   Intel Fortran Compiler 11.1 User and Reference Guides
    !     Language Reference
    !       A to Z Reference
    !         Command_Argument_Count
    !
    narg = Command_Argument_Count()
    
#else
#ifdef __GFORTRAN__

    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ! GNU Fortran Compiler
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    !
    ! From manual:
    !
    !   gcc.gnu.org/onlinedocs/
    !     GCC 4.3.5 GNU Fortran 95 Manual
    !       6. Intrinsic Prodedures
    !         6.42. COMMAND_ARGUMENT_COUNT - Get number of command line arguments
    !
    narg = Command_Argument_Count()
    
#else
#ifdef __IBMC__
    
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ! IBM XLF compiler
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    !
    ! From manual:
    !
    !   Language Reference - XL Fortran for AIX, V12.1
    !     Intrinsic Procedures
    !
    narg = Command_Argument_Count()
    
#else

    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ! error ...
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    !! always assign something ...
    !narg = -1

    !write (gol,'("subroutine not implemented for this compiler")'); call goErr
    !TRACEBACK; status=1; return
    
    ! try this, often works:
    narg = iArgC()

#endif
#endif
#endif

    ! ok
    status = 0
  
  end subroutine goArgCount
  
  
  ! ############################################################################
  ! ###
  ! ### goGetArg
  ! ###
  ! ############################################################################



  ! Return a command line argument
  
  subroutine goGetArg( pos, value, status )

    ! --- in/out --------------------------------------------------
    
    integer, intent(in)             ::  pos
    character(len=*), intent(out)   ::  value
    integer, intent(inout)          ::  status
    
    ! --- const ------------------------------------------------
    
    character(len=*), parameter  ::  rname = mname//'/goGetArg'
    
    ! --- local -----------------------------------------------------
    
    integer     ::  n
    
    ! --- begin -----------------------------------------------------

#ifdef __INTEL_COMPILER

    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ! Intel Compiler
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    !
    ! From manual:
    !   
    !   Intel Fortran Compiler 11.1 User and Reference Guides
    !     Language Reference
    !       A to Z Reference
    !         Get_Command_Argument
    !
    ! Following the F2003 standard:
    call Get_Command_Argument( pos, value=value, status=status )
    
#else
#ifdef __GFORTRAN__

    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ! GNU Fortran Compiler
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    !
    ! From manual:
    !
    !   gcc.gnu.org/onlinedocs/
    !
    !     GCC 4.3.5 GNU Fortran 95 Manual
    !       6. Intrinsic Prodedures
    !         6.87. GET_COMMAND_ARGUMENT - Get command line arguments
    !                 call Get_Command_Argument( pos, value )
    !
    !     GCC 4.4.4 GNU Fortran 95 Manual
    !       7. Intrinsic Prodedures
    !         7.89. GET_COMMAND_ARGUMENT - Get command line arguments
    !                 call Get_Command_Argument( pos [,value, length, status] )
    !
#ifdef __GNUC____GNUC_MINOR____GNUC_PATCHLEVEL__ == 435
    ! up to version 4.3.5 :
    call Get_Command_Argument( pos, value )
    ! no status returned ...
    status = 0
#else
    ! Following the F2003 standard from v4.4.4 onwards:
    call Get_Command_Argument( pos, value=value, status=status )
#endif

#else
#ifdef __IBMC__
    
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ! IBM XLF compiler
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    !
    ! From manual:
    !
    !   Language Reference - XL Fortran for AIX, V12.1
    !     Intrinsic Procedures
    !
    ! Following the F2003 standard:
    call Get_Command_Argument( pos, value=value, status=status )
    
#else

    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ! error ...
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    !! use arguments to avoid compilation warnings:
    !status = pos
    !! always assign something ...
    !value = '?'
    
    !write (gol,'("subroutine not implemented for this compiler")'); call goErr
    !TRACEBACK; status=1; return

    ! try this, often works:
    call GetArg( pos, value )
    ! no status returned ...
    status = 0

#endif
#endif
#endif
  
  end subroutine goGetArg
  
  
  ! ############################################################################
  ! ###
  ! ### goSleep
  ! ###
  ! ############################################################################


  ! wait some seconds ...
  
  subroutine goSleep( nsec, status )

#ifdef __INTEL_COMPILER
    use IFPort, only : Sleep
#endif
#ifdef __IBMC__
    use XLFUtility, only : Sleep_
#endif

    ! --- in/out --------------------------------------------------
    
    integer, intent(in)             ::  nsec
    integer, intent(out)            ::  status
    
    ! --- const ------------------------------------------------
    
    character(len=*), parameter  ::  rname = mname//'/goSleep'
    
    ! --- begin -----------------------------------------------------

#ifdef __INTEL_COMPILER

    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ! Intel Compiler
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    !
    ! From manual:
    !   
    !   Intel Fortran Compiler 11.1 User and Reference Guides
    !     Language Reference
    !       A to Z Reference
    !         Sleep
    !
    call Sleep( nsec )

#else
#ifdef __GFORTRAN__

    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ! GNU Fortran Compiler
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    !
    ! From manual:
    !
    !   gcc.gnu.org/onlinedocs/
    !     GCC 4.3.5 GNU Fortran 95 Manual
    !       6. Intrinsic Prodedures
    !         6.195. SLEEP - Sleep for the specified number of seconds
    !   
    call Sleep( nsec )

#else
#ifdef __IBMC__
    
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ! IBM XLF compiler
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    !
    ! From manual:
    !
    !   Language Reference - XL Fortran for AIX, V12.1
    !     Service and utility procedures
    !       General service and utility procedures
    !
#ifdef __ecmwf__
    call Sleep( nsec )
#else
    call Sleep_( nsec )
#endif
    
#else

    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ! error ...
    ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    !write (gol,'("subroutine not implemented for this compiler")'); call goErr
    !TRACEBACK; status=1; return
    
    ! try this, often works:
    call Sleep( nsec )

#endif
#endif
#endif

    ! ok
    status = 0
  
  end subroutine goSleep
  
  
end module GO_System


!! ######################################################################
!! ###
!! ### test
!! ###
!! ######################################################################
!!
!!  gfortran -o test.x go_fu.F90 go_print.F90 go_system.F90 && ./test.x a bc ; echo $?
!!
!!  ifort -o test.x go_fu.F90 go_print.F90 go_system.F90 && ./test.x a bc ; echo $?
!!
!!  xlf -qnoextname -o test.x go_fu.F90 go_print.F90 go_system.F90 && ./test.x a bc ; echo $?
!!
!!  xlf -qnoextname -o test.x -WF,-D__ecmwf__ go_fu.F90 go_print.F90 go_system.F90 && ./test.x a bc ; echo $?
!!
!#define IF_NOTOK_STOP if (status/=0) then; TRACEBACK; stop; end if
!!
!program test
!
!  use GO_Print, only : gol, goPr, goErr
!  use GO_System, only : goArgCount, goGetArg, goExit, goSleep, goSystem
!  
!  implicit none
!  
!  character(len=*), parameter  ::  rname = 'test'
!  
!  integer             ::  status
!  integer             ::  n, i
!  character(len=32)   ::  val
!  character(len=32)   ::  command
!  
!  print *, 'begin'
!
!  print *, ''
!  print *, 'Test value of predefined macros:'
!#ifdef __GFORTRAN__
!  print *, '  __GFORTRAN__          : ', __GFORTRAN__
!  print *, '  __GNUC__              : ', __GNUC__
!  print *, '  __GNUC_MINOR__        : ', __GNUC_MINOR__
!  print *, '  __GNUC_PATCHLEVEL__   : ', __GNUC_PATCHLEVEL__
!#else
!  print *, '  __GFORTRAN__          : undefined'
!#endif
!#ifdef __INTEL_COMPILER
!  print *, '  __INTEL_COMPILER      : ', __INTEL_COMPILER
!#else
!  print *, '  __INTEL_COMPILER      : undefined'
!#endif
!#ifdef __IBMC__
!  print *, '  __IBMC__              : ', __IBMC__
!#else
!  print *, '  __IBMC__              : undefined'
!#endif
!
!  print *, ''
!  print *, 'number of arguments ...'
!  call goArgCount( n, status )
!  IF_NOTOK_STOP
!  print *, n
!  
!  print *, 'get arguments ...'
!  do i = 1, n
!    print *, '  argument ', i, ' ...'
!    call goGetArg( i, val, status )
!    IF_NOTOK_STOP
!    print *, '"'//trim(val)//'"'
!  end do
!  
!  command = '/bin/ls -l'
!  print *, ''
!  print *, 'call system command : ', trim(command)
!  call goSystem( command, status )
!  IF_NOTOK_STOP
!  
!  n = 2
!  print *, ''
!  print *, 'wait ', n, ' seconds ...'
!  call goSleep( n, status )
!  IF_NOTOK_STOP
!  
!  status = 23
!  print *, ''
!  print *, 'exit with status ', status, ' ...'
!  call goExit( status )
!  
!  print *, 'end'
!
!end program test