!===============================================================================
! CVS $Id: shr_sys_mod.F90,v 1.2.4.2 2004/04/28 23:44:15 eaton Exp $
! CVS $Source: /fs/cgd/csm/models/CVS.REPOS/shared/csm_share/shr/shr_sys_mod.F90,v $
! CVS $Name: cam3_0_brnchT_release01 $
!===============================================================================


MODULE shr_sys_mod 11,2

   use shr_kind_mod, only: SHR_KIND_IN, SHR_KIND_R8, SHR_KIND_I8  ! defines real & integer kinds
   use shr_mpi_mod          ! MPI layer

   implicit none

! PUBLIC: Public interfaces

   private
   public :: shr_sys_system, shr_sys_chdir, &
             shr_sys_getenv, shr_sys_flush, &
             shr_sys_abort , shr_sys_irtc,  &
             shr_sys_sleep 

CONTAINS

!===============================================================================


SUBROUTINE shr_sys_system(str,rcode) 5,1

   IMPLICIT none

   !----- arguments ---
   character(len=*)    ,intent(in)  :: str    ! system/shell command string
   integer(SHR_KIND_IN),intent(out) :: rcode  ! function return error code

#if (defined CRAY) || (defined UNICOSMP)
   !----- functions -----
   integer(SHR_KIND_IN),external    :: ishell ! function to envoke shell command
#endif
#if (defined OSF1 || defined SUNOS || defined LINUX)
   !----- functions -----
   integer(SHR_KIND_IN),external    :: system ! function to envoke shell command
#endif

!-------------------------------------------------------------------------------
! PURPOSE: an architecture independant system call
!-------------------------------------------------------------------------------

#if (defined CRAY) || (defined UNICOSMP)
   rcode=ishell(str)
#endif

#if (defined IRIX64 || defined NEC_SX)
   rcode = 0
   call system(str)
#endif

#if (defined AIX)
   call system(str,rcode)
#endif

#if (defined OSF1 || defined SUNOS || defined LINUX)
   rcode = system(str)
#endif

#if (!defined CRAY && !defined IRIX64 && !defined AIX && !defined OSF1 && !defined SUNOS && !defined LINUX && !defined NEC_SX && !defined UNICOSMP)
   write(*,*) '(shr_sys_system) ERROR: no implementation for this architecture'
   call shr_sys_abort('no system routine on this machine')
#endif

END SUBROUTINE shr_sys_system

!===============================================================================


SUBROUTINE shr_sys_chdir(path, rcode) 1,1

   IMPLICIT none

   !----- arguments -----
   character(len=*)    ,intent(in)  :: path    ! chdir to this dir
   integer(SHR_KIND_IN),intent(out) :: rcode   ! return code

   !----- local -----
   integer(SHR_KIND_IN)             :: lenpath ! length of path
#if (defined AIX || defined OSF1 || defined SUNOS || defined LINUX || defined NEC_SX)
   integer(SHR_KIND_IN),external    :: chdir   ! AIX system call
#endif

!-------------------------------------------------------------------------------
! PURPOSE: an architecture independant system call
!-------------------------------------------------------------------------------

   lenpath=len_trim(path)

#if (defined IRIX64 || defined CRAY || defined UNICOSMP)
   call pxfchdir(path, lenpath, rcode)
#endif

#if (defined AIX)
   rcode=chdir(%ref(path(1:lenpath)//'\0'))
#endif

#if (defined OSF1 || defined SUNOS || defined LINUX || defined NEC_SX)
   rcode=chdir(path(1:lenpath))
#endif

#if (!defined CRAY && !defined IRIX64 && !defined AIX && !defined OSF1 && !defined SUNOS && !defined LINUX && !defined NEC_SX && !defined UNICOSMP)
   write(*,*) '(shr_sys_chdir) ERROR: no implementation for this architecture'
   call shr_sys_abort('no implementation of chdir for this machine')
#endif

END SUBROUTINE shr_sys_chdir

!===============================================================================


SUBROUTINE shr_sys_getenv(name, val, rcode) 4,1

   IMPLICIT none

   !----- arguments -----
   character(len=*)    ,intent(in)  :: name    ! env var name
   character(len=*)    ,intent(out) :: val     ! env var value
   integer(SHR_KIND_IN),intent(out) :: rcode   ! return code

   !----- local -----
   integer(SHR_KIND_IN)             :: lenname ! length of env var name
   integer(SHR_KIND_IN)             :: lenval  ! length of env var value
   character(len=512)               :: tmpval  ! temporary env var value

!-------------------------------------------------------------------------------
! PURPOSE: an architecture independant system call
!-------------------------------------------------------------------------------

   lenname=len_trim(name)

#if (defined IRIX64 || defined CRAY || defined UNICOSMP)
   call pxfgetenv(name, lenname, val, lenval, rcode)
#endif

#if (defined AIX || defined OSF1 || defined SUNOS || defined LINUX || defined NEC_SX)
   call getenv(trim(name),tmpval)
   val=trim(tmpval)
   rcode = 0
   if (len_trim(val) ==  0 ) rcode = 1
   if (len_trim(val) > 512 ) rcode = 2
#endif

#if (!defined CRAY && !defined IRIX64 && !defined AIX && !defined OSF1 && !defined SUNOS && !defined LINUX && !defined NEC_SX && !defined UNICOSMP)
   write(*,*) '(shr_sys_getenv) ERROR: no implementation for this architecture'
   call shr_sys_abort('no implementation of getenv for this machine')
#endif

END SUBROUTINE shr_sys_getenv

!===============================================================================


SUBROUTINE shr_sys_flush(unit) 17

   IMPLICIT none

   !----- arguments -----
   integer(SHR_KIND_IN) :: unit  ! flush output buffer for this unit

!-------------------------------------------------------------------------------
! PURPOSE: an architecture independant system call
!-------------------------------------------------------------------------------

#if (defined IRIX64 || defined CRAY || defined OSF1 || defined SUNOS || defined LINUX || defined NEC_SX || defined UNICOSMP)
   call flush(unit)
#endif
#if (defined AIX)
   call flush_(unit)
#endif

#if (!defined CRAY && !defined IRIX64 && !defined AIX && !defined OSF1 && !defined SUNOS && !defined LINUX && !defined NEC_SX && !defined UNICOSMP)
   write(*,*) '(shr_sys_flush) WARNING: no implementation for this architecture'
#endif

END SUBROUTINE shr_sys_flush

!===============================================================================


SUBROUTINE shr_sys_abort(string,rcode) 14,8

   IMPLICIT none

   character*(*),optional :: string    ! error message string
   integer(SHR_KIND_IN),optional :: rcode   ! error code

   !----- local -----
   integer(SHR_KIND_IN) :: ierr
   logical              :: flag

   !----- i/o formats -----
   character(len=*),parameter :: F00 = "('(shr_sys_abort) ',a)"

!-------------------------------------------------------------------------------
! PURPOSE: consistent stopping mechanism
!-------------------------------------------------------------------------------

   call shr_sys_flush(6)
   if (len_trim(string) > 0) write(6,F00) 'ERROR: '//trim(string)
   write(6,F00) 'WARNING: calling shr_mpi_abort() and stopping'
   call shr_sys_flush(6)
   call shr_mpi_initialized(flag)
   if (flag) then
     if (present(string).and.present(rcode)) then
       call shr_mpi_abort(trim(string),rcode)
     elseif (present(string)) then
       call shr_mpi_abort(trim(string))
     elseif (present(rcode)) then
       call shr_mpi_abort(rcode=rcode)
     else
       call shr_mpi_abort()
     endif
   endif
   call shr_sys_flush(6)
   call abort()
   stop

END SUBROUTINE shr_sys_abort

!===============================================================================


integer(SHR_KIND_I8) FUNCTION shr_sys_irtc( rate ) 6

   IMPLICIT none
   !----- optional output argument -----
   integer(SHR_KIND_I8), optional :: rate

   !----- local -----
   integer(SHR_KIND_IN)          :: count
   integer(SHR_KIND_IN)          :: count_rate
   integer(SHR_KIND_IN)          :: count_max

   integer(SHR_KIND_IN),save :: last_count = -1
   integer(SHR_KIND_I8),save :: count_offset = 0

!-------------------------------------------------------------------------------
! emulates Cray/SGI irtc function (returns clock tick since last reboot)
!-------------------------------------------------------------------------------
   call system_clock(count=count,count_rate=count_rate, count_max=count_max)
   if ( present(rate) ) rate = count_rate
   shr_sys_irtc = count
!
! System clock is a 24-hour clock, so must check each time pass over midnight
!
   if ( last_count /= -1 )then
     if ( count < last_count ) count_offset = count_offset + count_max
   end if
   shr_sys_irtc = shr_sys_irtc + count_offset
   last_count = count

END FUNCTION shr_sys_irtc

!===============================================================================


SUBROUTINE shr_sys_sleep(sec) 1,1

   IMPLICIT none

   !----- input -----
   real   (shr_kind_r8),intent(in) :: sec  ! number of seconds to sleep

   !----- local -----
   integer(shr_kind_in) :: isec   ! integer number of seconds
   integer(shr_kind_in) :: rcode  ! return code
   character(len=90) :: sleep_var

   !----- i/o formats -----
   character(len=*),parameter :: F00 = "('sleep ',i8 )"

   save

!-------------------------------------------------------------------------------
! PURPOSE: Sleep for approximately sec seconds
!-------------------------------------------------------------------------------

   isec = nint(sec)

   if (isec < 0) then
      write(6,*) 'ERROR: seconds must be > 0, sec=',sec
   else if (isec == 0) then
!     Don't consider this an error and don't call system sleep
   else
      write(sleep_var,FMT=F00) isec
      call shr_sys_system( sleep_var, rcode )
   endif

END SUBROUTINE shr_sys_sleep

!===============================================================================

END MODULE shr_sys_mod