CESM_Driver: shr_sys_mod.F90 Source File

00001 !===============================================================================
00002 ! SVN $Id: shr_sys_mod.F90 20941 2010-02-11 07:05:43Z erik $
00003 ! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/branch_tags/cesm1_0_rel_tags/cesm1_0_rel01_share3_100616/shr/shr_sys_mod.F90 $
00004 !===============================================================================
00005 
00006 MODULE shr_sys_mod
00007 
00008    use shr_kind_mod  ! defines real & integer kinds
00009    use shr_mpi_mod   ! wraps MPI layer
00010    use shr_log_mod, only: s_loglev  => shr_log_Level
00011    use shr_log_mod, only: s_logunit => shr_log_Unit
00012 
00013    implicit none
00014 
00015 ! PUBLIC: Public interfaces
00016 
00017    private
00018 
00019    public :: shr_sys_system  ! make a system call
00020    public :: shr_sys_chdir   ! change current working dir
00021    public :: shr_sys_getenv  ! get an environment variable
00022    public :: shr_sys_abort   ! abort a program
00023    public :: shr_sys_irtc    ! returns real-time clock tick
00024    public :: shr_sys_sleep   ! have program sleep for a while
00025    public :: shr_sys_flush   ! flush an i/o buffer
00026 
00027 !===============================================================================
00028 CONTAINS
00029 !===============================================================================
00030 
00031 !===============================================================================
00032 !===============================================================================
00033 
00034 SUBROUTINE shr_sys_system(str,rcode)
00035 
00036    IMPLICIT none
00037 
00038    !----- arguments ---
00039    character(*)        ,intent(in)  :: str    ! system/shell command string
00040    integer(SHR_KIND_IN),intent(out) :: rcode  ! function return error code
00041 
00042    !----- functions -----
00043 #if (defined CRAY) || (defined UNICOSMP)
00044    integer(SHR_KIND_IN),external    :: ishell ! function to envoke shell command
00045 #endif
00046 #if (defined OSF1 || defined SUNOS || (defined LINUX && !defined __G95__) || (defined LINUX && !defined CATAMOUNT))
00047    integer(SHR_KIND_IN),external    :: system ! function to envoke shell command
00048 #endif
00049 
00050    !----- local -----
00051 #if (defined CATAMOUNT)
00052    character(2*SHR_KIND_CL) :: file1            ! one or two filenames
00053    character(  SHR_KIND_CL) :: file2            ! 2nd file name
00054    integer(SHR_KIND_IN)     :: iloc             ! index/location within a string
00055 #endif
00056 
00057    !----- formats -----
00058    character(*),parameter :: subName =   '(shr_sys_system) '
00059    character(*),parameter :: F00     = "('(shr_sys_system) ',4a)"
00060 
00061 !-------------------------------------------------------------------------------
00062 ! PURPOSE: an architecture independant system call
00063 ! NOTE: 
00064 ! - for Catamount (Cray, pheonix at ORNL) there is no system call -- workarounds 
00065 !   exist only for simple "rm" and "cp" commands
00066 !-------------------------------------------------------------------------------
00067 
00068 
00069 #if (defined CRAY) || (defined UNICOSMP)
00070    rcode=ishell(str)
00071 #endif
00072 
00073 #if (defined IRIX64 || defined NEC_SX)
00074    rcode = 0
00075    call system(str)
00076 #endif
00077 
00078 #if (defined AIX)
00079    call system(str,rcode)
00080 #endif
00081 
00082 #if (defined OSF1 || defined SUNOS || defined LINUX && !defined CATAMOUNT || defined __G95__)
00083    rcode = system(str)
00084 #endif
00085 
00086 #if (!defined CRAY && !defined IRIX64 && !defined AIX && !defined OSF1 && !defined SUNOS && !defined LINUX && !defined NEC_SX && !defined UNICOSMP && !defined __G95__)
00087    write(s_logunit,F00) 'ERROR: no implementation for this architecture'
00088    call shr_sys_abort(subName//'no implementation for this architecture')
00089 #endif
00090 
00091 #if (defined CATAMOUNT)
00092    if (str(1:3) == 'rm ') then
00093       call unlink(str(4:))
00094       if (s_loglev > 0) write(s_logunit,F00) 'CATAMOUNT unlink ',trim(str(4:))
00095       rcode = 0
00096    elseif (str(1:3) == 'mv ') then
00097       file1 = str(4:)
00098       iloc = index(file1,' ') + 3
00099       if (iloc < 6) then
00100          if (s_loglev > 0) write(s_logunit,*) 'CATAMOUNT mv error ',trim(str),iloc
00101          rcode = -1
00102       else
00103          file1 = str(4:iloc)
00104          file2 = str(iloc+1:)
00105          call rename(trim(file1),trim(file2))
00106          if (s_loglev > 0) write(s_logunit,F00) 'CATAMOUNT rename ',trim(file1)," ",trim(file2)
00107          rcode = 0
00108       endif
00109    else
00110       rcode = -1
00111    endif
00112 #endif
00113 
00114 END SUBROUTINE shr_sys_system
00115 
00116 !===============================================================================
00117 !===============================================================================
00118 
00119 SUBROUTINE shr_sys_chdir(path, rcode)
00120 
00121    IMPLICIT none
00122 
00123    !----- arguments -----
00124    character(*)        ,intent(in)  :: path    ! chdir to this dir
00125    integer(SHR_KIND_IN),intent(out) :: rcode   ! return code
00126 
00127    !----- local -----
00128    integer(SHR_KIND_IN)             :: lenpath ! length of path
00129 #if (defined AIX || defined OSF1 || defined SUNOS || (defined LINUX && !defined __G95__) || defined NEC_SX)
00130    integer(SHR_KIND_IN),external    :: chdir   ! AIX system call
00131 #endif
00132 
00133    !----- formats -----
00134    character(*),parameter :: subName =   '(shr_sys_chdir) '
00135    character(*),parameter :: F00     = "('(shr_sys_chdir) ',4a)"
00136 
00137 !-------------------------------------------------------------------------------
00138 ! PURPOSE: an architecture independant system call
00139 !-------------------------------------------------------------------------------
00140 
00141    lenpath=len_trim(path)
00142 
00143 #if (defined IRIX64 || defined CRAY || defined UNICOSMP)
00144    call pxfchdir(path, lenpath, rcode)
00145 #endif
00146 
00147 #if (defined AIX)
00148    rcode=chdir(%ref(path(1:lenpath)//'\0'))
00149 #endif
00150 
00151 #if (defined OSF1 || defined SUNOS || defined LINUX || defined NEC_SX || defined __G95__)
00152    rcode=chdir(path(1:lenpath))
00153 #endif
00154 
00155 #if (!defined CRAY && !defined IRIX64 && !defined AIX && !defined OSF1 && !defined SUNOS && !defined LINUX && !defined NEC_SX && !defined UNICOSMP && !defined __G95__)
00156    write(s_logunit,F00) 'ERROR: no implementation for this architecture'
00157    call shr_sys_abort('no implementation of chdir for this machine')
00158 #endif
00159 
00160 END SUBROUTINE shr_sys_chdir
00161 
00162 !===============================================================================
00163 !===============================================================================
00164 
00165 SUBROUTINE shr_sys_getenv(name, val, rcode)
00166 
00167    IMPLICIT none
00168 
00169    !----- arguments -----
00170    character(*)        ,intent(in)  :: name    ! env var name
00171    character(*)        ,intent(out) :: val     ! env var value
00172    integer(SHR_KIND_IN),intent(out) :: rcode   ! return code
00173 
00174    !----- local -----
00175    integer(SHR_KIND_IN)             :: lenname ! length of env var name
00176    integer(SHR_KIND_IN)             :: lenval  ! length of env var value
00177    character(SHR_KIND_CL)           :: tmpval  ! temporary env var value
00178 
00179    !----- formats -----
00180    character(*),parameter :: subName =   '(shr_sys_getenv) '
00181    character(*),parameter :: F00     = "('(shr_sys_getenv) ',4a)"
00182 
00183 !-------------------------------------------------------------------------------
00184 ! PURPOSE: an architecture independant system call
00185 !-------------------------------------------------------------------------------
00186 
00187    lenname=len_trim(name)
00188 
00189 #if (defined IRIX64 || defined CRAY || defined UNICOSMP)
00190    call pxfgetenv(name, lenname, val, lenval, rcode)
00191 #endif
00192 
00193 #if (defined AIX || defined OSF1 || defined SUNOS || defined LINUX || defined NEC_SX || defined __G95__)
00194    call getenv(trim(name),tmpval)
00195    val=trim(tmpval)
00196    rcode = 0
00197    if (len_trim(val) ==  0         ) rcode = 1
00198    if (len_trim(val) >  SHR_KIND_CL) rcode = 2
00199 #endif
00200 
00201 #if (!defined CRAY && !defined IRIX64 && !defined AIX && !defined OSF1 && !defined SUNOS && !defined LINUX && !defined NEC_SX && !defined UNICOSMP && !defined __G95__)
00202    write(s_logunit,F00) 'ERROR: no implementation for this architecture'
00203    call shr_sys_abort('no implementation of getenv for this machine')
00204 #endif
00205 
00206 END SUBROUTINE shr_sys_getenv
00207 
00208 !===============================================================================
00209 !===============================================================================
00210 
00211 SUBROUTINE shr_sys_abort(string,rc)
00212 
00213    IMPLICIT none
00214 
00215    character(*)        ,optional :: string  ! error message string
00216    integer(SHR_KIND_IN),optional :: rc      ! error code
00217 
00218    !----- local -----
00219    integer(SHR_KIND_IN) :: ierr
00220    logical              :: flag
00221 
00222    !----- formats -----
00223    character(*),parameter :: subName =   '(shr_sys_abort) '
00224    character(*),parameter :: F00     = "('(shr_sys_abort) ',4a)"
00225 
00226 !-------------------------------------------------------------------------------
00227 ! PURPOSE: consistent stopping mechanism
00228 !-------------------------------------------------------------------------------
00229 
00230    call shr_sys_flush(s_logunit)
00231    if (len_trim(string) > 0) write(s_logunit,F00) 'ERROR: '//trim(string)
00232    write(s_logunit,F00) 'WARNING: calling shr_mpi_abort() and stopping'
00233    call shr_sys_flush(s_logunit)
00234    call shr_mpi_initialized(flag)
00235    if (flag) then
00236      if (present(string).and.present(rc)) then
00237        call shr_mpi_abort(trim(string),rc)
00238      elseif (present(string)) then
00239        call shr_mpi_abort(trim(string))
00240      elseif (present(rc)) then
00241        call shr_mpi_abort(rcode=rc)
00242      else
00243        call shr_mpi_abort()
00244      endif
00245    endif
00246    call shr_sys_flush(s_logunit)
00247    call abort()
00248    stop
00249 
00250 END SUBROUTINE shr_sys_abort
00251 
00252 !===============================================================================
00253 !===============================================================================
00254 
00255 integer(SHR_KIND_I8) FUNCTION shr_sys_irtc( rate )
00256 
00257    IMPLICIT none
00258 
00259    !----- arguments -----
00260    integer(SHR_KIND_I8), optional :: rate
00261 
00262    !----- local -----
00263    integer(SHR_KIND_IN)      :: count
00264    integer(SHR_KIND_IN)      :: count_rate
00265    integer(SHR_KIND_IN)      :: count_max
00266    integer(SHR_KIND_IN),save :: last_count   = -1
00267    integer(SHR_KIND_I8),save :: count_offset =  0
00268 
00269    !----- formats -----
00270    character(*),parameter :: subName =   '(shr_sys_irtc) '
00271    character(*),parameter :: F00     = "('(shr_sys_irtc) ',4a)"
00272 
00273 !-------------------------------------------------------------------------------
00274 ! emulates Cray/SGI irtc function (returns clock tick since last reboot)
00275 !-------------------------------------------------------------------------------
00276 
00277    call system_clock(count=count,count_rate=count_rate, count_max=count_max)
00278    if ( present(rate) ) rate = count_rate
00279    shr_sys_irtc = count
00280 
00281    !--- adjust for clock wrap-around ---
00282    if ( last_count /= -1 ) then
00283      if ( count < last_count ) count_offset = count_offset + count_max
00284    end if
00285    shr_sys_irtc = shr_sys_irtc + count_offset
00286    last_count   = count
00287 
00288 END FUNCTION shr_sys_irtc
00289 
00290 !===============================================================================
00291 !===============================================================================
00292 
00293 SUBROUTINE shr_sys_sleep(sec)
00294 
00295    IMPLICIT none
00296 
00297    !----- arguments -----
00298    real   (SHR_KIND_R8),intent(in) :: sec  ! number of seconds to sleep
00299 
00300    !----- local -----
00301    integer(SHR_KIND_IN) :: isec   ! integer number of seconds
00302    integer(SHR_KIND_IN) :: rcode  ! return code
00303    character(90)        :: str    ! system call string
00304 
00305    !----- formats -----
00306    character(*),parameter :: subName =   '(shr_sys_sleep) '
00307    character(*),parameter :: F00     = "('(shr_sys_sleep) ',4a)"
00308    character(*),parameter :: F10     = "('sleep ',i8 )"
00309 
00310 !-------------------------------------------------------------------------------
00311 ! PURPOSE: Sleep for approximately sec seconds
00312 !-------------------------------------------------------------------------------
00313 
00314    isec = nint(sec)
00315 
00316    if (isec < 0) then
00317       if (s_loglev > 0) write(s_logunit,F00) 'ERROR: seconds must be > 0, sec=',sec
00318    else if (isec == 0) then
00319       ! Don't consider this an error and don't call system sleep
00320    else
00321 #if defined(CATAMOUNT)
00322       call sleep(isec)
00323 #else
00324       write(str,FMT=F10) isec
00325       call shr_sys_system( str, rcode )
00326 #endif
00327    endif
00328 
00329 END SUBROUTINE shr_sys_sleep
00330 
00331 !===============================================================================
00332 !===============================================================================
00333 
00334 SUBROUTINE shr_sys_flush(unit)
00335 
00336    IMPLICIT none
00337 
00338    !----- arguments -----
00339    integer(SHR_KIND_IN) :: unit  ! flush output buffer for this unit
00340 
00341    !----- formats -----
00342    character(*),parameter :: subName =   '(shr_sys_flush) '
00343    character(*),parameter :: F00     = "('(shr_sys_flush) ',4a)"
00344 
00345 !-------------------------------------------------------------------------------
00346 ! PURPOSE: an architecture independant system call
00347 !-------------------------------------------------------------------------------
00348 
00349 #if (defined IRIX64 || defined CRAY || defined OSF1 || defined SUNOS || defined LINUX || defined NEC_SX || defined UNICOSMP || defined __G95__)
00350    call flush(unit)
00351 #endif
00352 #if (defined AIX)
00353    call flush_(unit)
00354 #endif
00355 
00356 #if (!defined CRAY && !defined IRIX64 && !defined AIX && !defined OSF1 && !defined SUNOS && !defined LINUX && !defined NEC_SX && !defined UNICOSMP && !defined __G95__)
00357    if (s_loglev > 0) write(s_logunit,F00) 'WARNING: no implementation for this architecture'
00358 #endif
00359 
00360 END SUBROUTINE shr_sys_flush
00361 
00362 !===============================================================================
00363 !===============================================================================
00364 
00365 END MODULE shr_sys_mod