!===============================================================================
! SVN $Id: shr_file_mod.F90 22436 2010-04-18 05:32:48Z tcraig $
! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/branch_tags/cesm1_0_rel_tags/cesm1_0_rel01_share3_100616/shr/shr_file_mod.F90 $
!===============================================================================
!BOP ===========================================================================
!
! !MODULE: shr_file_mod.F90 --- Module to handle various file utilily functions.
!
! !DESCRIPTION:
!
! Miscilaneous methods to handle file and directory utilities as well as FORTRAN
! unit control. Also put/get local files into/from archival location
!
! File utilites used with CCSM Message passing:
!
! shr_file_stdio is the main example here, it changes the working directory,
! changes stdin and stdout to a given filename.
!
! This is needed because some implementations of MPI with MPMD so that
! each executable can run in a different working directory and redirect
! output to different files.
!
! File name archival convention, eg.
! call shr_file_put(rcode,"foo","mss:/USER/foo",rtpd=3650)
! is extensible -- the existence of the option file name prefix, eg. "mss:",
! and optional arguments, eg. rtpd-3650 can be used to access site-specific
! storage devices. Based on CCM (atmosphere) getfile & putfile routines, but
! intended to be a more extensible, shared code.
!
! !REVISION HISTORY:
! 2006-05-08 E. Kluzek, Add in shr_file_mod and getUnit, freeUnif methods.
! 2000-??-?? B. Kauffman, original version circa 2000
!
! !INTERFACE: ------------------------------------------------------------------
MODULE shr_file_mod 35,4
! !USES:
use shr_kind_mod
! defines kinds
use shr_sys_mod ! system calls
use shr_log_mod, only: s_loglev => shr_log_Level
use shr_log_mod, only: s_logunit => shr_log_Unit
IMPLICIT none
PRIVATE ! By default everything is private to this module
! !PUBLIC TYPES:
! no public types
! !PUBLIC MEMBER FUNCTIONS:
public :: shr_file_put ! Put a file to an archive location
public :: shr_file_get ! Get a file from an archive location
public :: shr_file_queryPrefix ! Get prefix type for a filename
public :: shr_file_getUnit ! Get a logical unit for reading or writing
public :: shr_file_freeUnit ! Free a logical unit
public :: shr_file_stdio ! change dir and stdin and stdout
public :: shr_file_chDir ! change current working directory
public :: shr_file_dirio ! change stdin and stdout
public :: shr_file_chStdIn ! change stdin (attach to a file)
public :: shr_file_chStdOut ! change stdout (attach to a file)
public :: shr_file_setIO ! open a log file from namelist
public :: shr_file_setLogUnit ! Reset the log unit number
public :: shr_file_setLogLevel ! Reset the logging debug level
public :: shr_file_getLogUnit ! Get the log unit number
public :: shr_file_getLogLevel ! Get the logging debug level
! !PUBLIC DATA MEMBERS:
! Integer flags for recognized prefixes on file get/put operations
integer(SHR_KIND_IN), parameter, public :: shr_file_noPrefix = 0 ! no recognized prefix
integer(SHR_KIND_IN), parameter, public :: shr_file_nullPrefix = 1 ! null:
integer(SHR_KIND_IN), parameter, public :: shr_file_cpPrefix = 2 ! cp:
integer(SHR_KIND_IN), parameter, public :: shr_file_mssPrefix = 3 ! mss:
integer(SHR_KIND_IN), parameter, public :: shr_file_hpssPrefix = 4 ! hpss:
!EOP
!--- unit numbers, users can ask for unit numbers from 0 to min, but getUnit
!--- won't give a unit below min, users cannot ask for unit number above max
!--- for backward compatability.
!--- eventually, recommend min as hard lower limit (tcraig, 9/2007)
integer(SHR_KIND_IN),parameter :: shr_file_minUnit = 10 ! Min unit number to give
integer(SHR_KIND_IN),parameter :: shr_file_maxUnit = 99 ! Max unit number to give
logical, save :: UnitTag(0:shr_file_maxUnit) = .false. ! Logical units in use
!===============================================================================
CONTAINS
!===============================================================================
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_file_put -- Put a file to an archival location.
!
! !DESCRIPTION:
! a generic, extensible put-local-file-into-archive routine
! USAGE:
! call shr_file_put(rcode,"foo","/home/user/foo")
! if ( rcode /= 0 ) call shr_sys_abort( "error copying foo" )
! call shr_file_put(rcode,"foo","cp:/home/user/foo",remove=.true.)
! if ( rcode /= 0 ) call shr_sys_abort( "error copying foo" )
! call shr_file_put(rcode,"foo","mss:/USER/foo",rtpd=3650)
! if ( rcode /= 0 ) call shr_sys_abort( "error archiving foo to MSS" )
!
! !INTERFACE: ------------------------------------------------------------------
SUBROUTINE shr_file_put(rcode,loc_fn,rem_fn,passwd,rtpd,async,remove) 2,3
implicit none
! !INPUT/OUTPUT PARAMETERS:
integer(SHR_KIND_IN),intent(out) :: rcode ! return code (non-zero -- error)
character(*), intent(in) :: loc_fn ! local filename
character(*), intent(in) :: rem_fn ! remote filename
character(*), intent(in),optional :: passwd ! password
integer(SHR_KIND_IN),intent(in),optional :: rtpd ! MSS retention period
logical, intent(in),optional :: async ! true <=> asynchronous put
logical, intent(in),optional :: remove ! true <=> rm after put
!EOP
!----- local -----
integer(SHR_KIND_IN) :: rtpd2 ! MSS retention period
logical :: remove2 ! true <=> rm after put
logical :: async2 ! true <=> asynchronous put
character(SHR_KIND_CL) :: passwd2 ! password
character(SHR_KIND_CL) :: rfn ! rem_fn without the destination prefix
character(SHR_KIND_CL) :: cmd ! command sent to system call
integer(SHR_KIND_IN) :: prefix ! remote file prefix type
!----- formats -----
character(*),parameter :: subName = '(shr_file_put) '
character(*),parameter :: F00 = "('(shr_file_put) ',4a)"
character(*),parameter :: F01 = "('(shr_file_put) ',a,i3,2a)"
character(*),parameter :: F02 = "(a,i4)"
!-------------------------------------------------------------------------------
! Notes:
! - On some machines the system call will not return a valid error code
! - when things are sent asynchronously, there probably won't be a error code
! returned.
!-------------------------------------------------------------------------------
remove2 =.false. ; if ( PRESENT(remove )) remove2 = remove
async2 =.true. ; if ( PRESENT(async )) async2 = async
passwd2 = " " ; if ( PRESENT(passwd )) passwd2 = passwd
rtpd2 = 365 ; if ( PRESENT(rtpd )) rtpd2 = rtpd
rcode = 0
if ( trim(rem_fn) == trim(loc_fn) ) then
!------------------------------------------------------
! (remote file name) == (local file name) => do nothing
!------------------------------------------------------
cmd = 'do nothing: remote file = local file = '//trim(loc_fn)
rcode = 0
else if ( prefix == shr_file_cpPrefix .or. prefix == shr_file_noPrefix )then
!------------------------------------------------------
! put via unix cp
!------------------------------------------------------
rfn = rem_fn
if ( rem_fn(1:3) == "cp:") rfn = rem_fn(4:len_trim(rem_fn))
#if defined(CATAMOUNT)
call shr_jlcp(trim(loc_fn),len_trim(loc_fn),trim(rfn),len_trim(rfn),rcode)
if (remove2) call unlink(trim(loc_fn))
if (async2 .and. s_loglev > 0) write(s_logunit,F00) 'Error: asynchronous copy not supported.'
cmd = 'shr_jlcp -f '//trim(loc_fn)//' '//trim(rfn)
rcode = 0
#else
cmd = '/bin/cp -f '//trim(loc_fn)//' '//trim(rfn)
if (remove2) cmd = trim(cmd)//' && /bin/rm -f '//trim(loc_fn)
if (async2 ) cmd = trim(cmd)//' & '
call shr_sys_system(trim(cmd),rcode)
#endif
else if ( prefix == shr_file_mssPrefix )then
!------------------------------------------------------
! put onto NCAR's MSS
!------------------------------------------------------
if (rtpd2 > 9999) rtpd2 = 9999
write(cmd,F02) '/usr/local/bin/msrcp -period ',rtpd2
if (async2 .and. (.not. remove2) ) cmd = trim(cmd)//' -async '
if (len_trim(passwd2) > 0 ) cmd = trim(cmd)//' -wpwd '//trim(passwd)
cmd = trim(cmd)//' '//trim(loc_fn)//' '//trim(rem_fn)
if (remove2) cmd = trim(cmd)//' && /bin/rm -f '//trim(loc_fn)
if (async2 .and. remove2 ) cmd = trim(cmd)//' & '
call shr_sys_system(trim(cmd),rcode)
else if ( prefix == shr_file_hpssPrefix )then
!------------------------------------------------------
! put onto LANL's hpss
!------------------------------------------------------
rcode = -1
cmd = 'rem_fn='//trim(rem_fn)//' loc_fn='//trim(loc_fn)
write(s_logunit,F00) 'ERROR: hpss option not yet implemented'
call shr_sys_abort( subName//'ERROR: hpss option not yet implemented' )
else if ( prefix == shr_file_nullPrefix )then
! do nothing
cmd = "null prefix => no file archival, do nothing"
rcode = 0
end if
if (s_loglev > 0) write(s_logunit,F01) 'rcode =',rcode,' cmd = ', trim(cmd)
END SUBROUTINE shr_file_put
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_file_get -- Get a file from archival location.
!
! !DESCRIPTION:
! a generic, extensible get-local-file-from-archive routine
!
! USAGE:
! call shr_file_get(rcode,"foo","/home/user/foo")
! if ( rcode /= 0 ) call shr_sys_abort( "error getting file foo" )
! call shr_file_get(rcode,"foo","cp:/home/user/foo",remove=.true.)
! if ( rcode /= 0 ) call shr_sys_abort( "error getting file foo" )
! call shr_file_get(rcode,"foo","mss:/USER/foo",clobber=.true.)
! if ( rcode /= 0 ) call shr_sys_abort( "error getting file foo from MSS" )
!
! !INTERFACE: ------------------------------------------------------------------
SUBROUTINE shr_file_get(rcode,loc_fn,rem_fn,passwd,async,clobber) 6,4
implicit none
! !INPUT/OUTPUT PARAMETERS:
integer(SHR_KIND_IN),intent(out) :: rcode ! return code (non-zero means error)
character(*) ,intent(in) :: loc_fn ! local filename
character(*) ,intent(in) :: rem_fn ! remote filename
character(*) ,intent(in),optional :: passwd ! password
logical ,intent(in),optional :: async ! true <=> asynchronous get
logical ,intent(in),optional :: clobber ! true <=> clobber existing file
!EOP
!----- local -----
logical :: async2 ! true <=> asynchronous get
logical :: clobber2 ! true <=> clobber existing file
logical :: exists ! true <=> local file a ready exists
character(SHR_KIND_CL) :: passwd2 ! password
character(SHR_KIND_CL) :: rfn ! rem_fn without the destination prefix
character(SHR_KIND_CL) :: cmd ! command sent to system call
integer(SHR_KIND_IN) :: prefix ! remote file prefix type
!----- formats -----
character(*),parameter :: subName = '(shr_file_get) '
character(*),parameter :: F00 = "('(shr_file_get) ',4a)"
character(*),parameter :: F01 = "('(shr_file_get) ',a,i3,2a)"
!-------------------------------------------------------------------------------
! Notes:
! - On some machines the system call will not return a valid error code
! - When things are sent asynchronously, there probably won't be a error code
! returned.
!-------------------------------------------------------------------------------
passwd2 = " " ; if (PRESENT(passwd )) passwd2 = passwd
async2 = .false. ; if (PRESENT(async )) async2 = async
clobber2 = .false. ; if (PRESENT(clobber)) clobber2 = clobber
rcode = 0
inquire(file=trim(loc_fn),exist=exists)
prefix = shr_file_queryPrefix( rem_fn )
if ( exists .and. .not. clobber2 ) then
!------------------------------------------------------
! (file exists) and (don't clobber) => do nothing
!------------------------------------------------------
cmd = 'do nothing: file exists & no-clobber for '//trim(loc_fn)
rcode = 0
else if ( trim(rem_fn) == trim(loc_fn) ) then
!------------------------------------------------------
! (remote file name) == (local file name) => do nothing
!------------------------------------------------------
cmd = 'do nothing: remote file = local file for '//trim(loc_fn)
rcode = 0
else if ( prefix == shr_file_cpPrefix .or. prefix == shr_file_noPrefix )then
!------------------------------------------------------
! get via unix cp
!------------------------------------------------------
rfn = rem_fn ! remove prefix from this temp file name
if (rem_fn(1:3) == "cp:") rfn = rem_fn(4:len_trim(rem_fn))
#if defined(CATAMOUNT)
call shr_jlcp(trim(rfn),len(trim(rfn)),trim(loc_fn),len(trim(loc_fn)),rcode)
if (async2.and.s_loglev>0) write(s_logunit,F00) 'Error: asynchronous copy not supported.'
cmd = 'shr_jlcp -f '//trim(rfn)//' '//trim(loc_fn)
rcode = 0
#else
cmd = '/bin/cp -f '//trim(rfn)//' '//trim(loc_fn)
if (async2) cmd = trim(cmd)//' & '
call shr_sys_system(trim(cmd),rcode)
#endif
else if ( prefix == shr_file_mssPrefix )then
!------------------------------------------------------
! get from NCAR's MSS
!------------------------------------------------------
cmd = '/usr/local/bin/msrcp '
if (async2) cmd = trim(cmd)//' -async '
cmd = trim(cmd)//' '//trim(rem_fn)//' '//trim(loc_fn)
call shr_sys_system(trim(cmd),rcode)
else if ( prefix == shr_file_hpssPrefix )then
!------------------------------------------------------
! get from LANL's hpss
!------------------------------------------------------
rcode = -1
cmd = 'rem_fn='//trim(rem_fn)//' loc_fn='//trim(loc_fn)
write(s_logunit,F00) 'ERROR: hpss option not yet implemented'
call shr_sys_abort( subName//'ERROR: hpss option not yet implemented' )
else if ( prefix == shr_file_nullPrefix )then
! do nothing
cmd = "null prefix => no file retrieval, do nothing"
rcode = 0
end if
if (s_loglev > 0) write(s_logunit,F01) 'rcode =',rcode,' cmd = ', trim(cmd)
END SUBROUTINE shr_file_get
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_file_queryPrefix -- Get the prefix type from a filepath.
!
! !DESCRIPTION:
!
! !INTERFACE: ------------------------------------------------------------------
integer(SHR_KIND_IN) FUNCTION shr_file_queryPrefix( filepath, prefix ) 6
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*), intent(in) :: filepath ! Input filepath
character(*), intent(out), optional :: prefix ! Output prefix description
!EOP
!----- local -----
!-------------------------------------------------------------------------------
! Notes:
!-------------------------------------------------------------------------------
if ( filepath(1:5) == "null:" )then
shr_file_queryPrefix = shr_file_nullPrefix
if ( present(prefix) ) prefix = "null:"
else if( filepath(1:3) == "cp:" )then
shr_file_queryPrefix = shr_file_cpPrefix
if ( present(prefix) ) prefix = "cp:"
else if( filepath(1:4) == "mss:" )then
shr_file_queryPrefix = shr_file_mssPrefix
if ( present(prefix) ) prefix = "mss:"
else if( filepath(1:5) == "hpss:" )then
shr_file_queryPrefix = shr_file_hpssPrefix
if ( present(prefix) ) prefix = "hpss:"
else
shr_file_queryPrefix = shr_file_noPrefix
if ( present(prefix) ) prefix = ""
end if
END FUNCTION shr_file_queryPrefix
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_file_getUnit -- Get a free FORTRAN unit number
!
! !DESCRIPTION: Get the next free FORTRAN unit number.
!
! !REVISION HISTORY:
! 2005-Dec-14 - E. Kluzek - creation
!
! !INTERFACE: ------------------------------------------------------------------
INTEGER FUNCTION shr_file_getUnit ( unit ) 49,3
implicit none
! !INPUT/OUTPUT PARAMETERS:
integer(SHR_KIND_IN),intent(in),optional :: unit ! desired unit number
!EOP
!----- local -----
integer(SHR_KIND_IN) :: n ! loop index
logical :: opened ! If unit opened or not
!----- formats -----
character(*),parameter :: subName = '(shr_file_getUnit) '
character(*),parameter :: F00 = "('(shr_file_getUnit) ',A,I4,A)"
!-------------------------------------------------------------------------------
! Notes:
!-------------------------------------------------------------------------------
if (present (unit)) then
inquire( unit, opened=opened )
if (unit < 0 .or. unit > shr_file_maxUnit) then
write(s_logunit,F00) 'invalid unit number request:', unit
call shr_sys_abort( 'ERROR: bad input unit number' )
else if (opened .or. UnitTag(unit) .or. unit == 0 .or. unit == 5 &
.or. unit == 6) then
write(s_logunit,F00) 'unit number ', unit, ' is already in use'
call shr_sys_abort( 'ERROR: Input unit number already in use' )
else
shr_file_getUnit = unit
UnitTag (unit) = .true.
return
end if
else
! --- Choose first available unit other than 0, 5, or 6 ------
do n=shr_file_maxUnit, shr_file_minUnit, -1
inquire( n, opened=opened )
if (n == 5 .or. n == 6 .or. opened) then
cycle
end if
if ( .not. UnitTag(n) ) then
shr_file_getUnit = n
UnitTag(n) = .true.
return
end if
end do
end if
call shr_sys_abort( subName//': Error: no available units found' )
END FUNCTION shr_file_getUnit
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_file_freeUnit -- Free up a FORTRAN unit number
!
! !DESCRIPTION: Free up the given unit number
!
! !REVISION HISTORY:
! 2005-Dec-14 - E. Kluzek - creation
!
! !INTERFACE: ------------------------------------------------------------------
SUBROUTINE shr_file_freeUnit ( unit) 29,1
implicit none
! !INPUT/OUTPUT PARAMETERS:
integer(SHR_KIND_IN),intent(in) :: unit ! unit number to be freed
!EOP
!----- local -----
!----- formats -----
character(*), parameter :: subName = '(shr_file_freeUnit) '
character(*), parameter :: F00 = "('(shr_file_freeUnit) ',A,I4,A)"
!-------------------------------------------------------------------------------
! Notes:
!-------------------------------------------------------------------------------
if (unit < 0 .or. unit > shr_file_maxUnit) then
if (s_loglev > 0) write(s_logunit,F00) 'invalid unit number request:', unit
else if (unit == 0 .or. unit == 5 .or. unit == 6) then
call shr_sys_abort( subName//': Error: units 0, 5, and 6 must not be freed' )
else if (UnitTag(unit)) then
UnitTag (unit) = .false.
else
if (s_loglev > 0) write(s_logunit,F00) 'unit ', unit, ' was not in use'
end if
return
END SUBROUTINE shr_file_freeUnit
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_file_stdio -- Change working directory, and redirect stdin/stdout
!
! !DESCRIPTION:
! 1) change the cwd (current working directory) and
! 2) redirect stdin & stdout (units 5 & 6) to named files,
! where the desired cwd & files are specified by namelist file.
!
! Normally this is done to work around limitations in the execution syntax
! of common MPI implementations. For example, SGI's mpirun syntax is not
! flexible enough to allow MPMD models to select different execution
! directories or to redirect stdin & stdout on the command line.
! Such functionality is highly desireable for CCSM purposes.
! ie. mpirun can't handle this:
! unix> cd /usr/tmp/jdoe/csm/case01/atm ; atm < atm.parm > atm.log &
! unix> cd /usr/tmp/jdoe/csm/case01/cpl ; cpl < cpl.parm > cpl.log &
! etc.
!
! ASSUMPTIONS:
! o if the cwd, stdin, or stdout are to be changed, there must be a namelist
! file in the cwd named <model>_stdio.nml where <model> is provided via
! subroutine dummy argument.
!
! !INTERFACE: ------------------------------------------------------------------
SUBROUTINE shr_file_stdio(model) 1,3
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*),intent(in) :: model ! used to construct env varible name
!EOP
!--- formats ---
character(*),parameter :: subName = '(shr_file_stdio) '
character(*),parameter :: F00 = "('(shr_file_stdio) ',4a)"
!-------------------------------------------------------------------------------
! Notes:
!-------------------------------------------------------------------------------
call shr_file_chdir (model) ! changes cwd
call shr_file_chStdOut(model) ! open units 5 & 6 to named files
call shr_file_chStdIn (model) ! open units 5 & 6 to named files
END SUBROUTINE shr_file_stdio
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_file_chdir -- Change working directory.
!
! !DESCRIPTION:
! change the cwd (current working directory), see shr_file_stdio for notes
!
! !INTERFACE: ------------------------------------------------------------------
SUBROUTINE shr_file_chdir(model, rcodeOut) 2,2
! !USES:
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*) ,intent(in) :: model ! used to construct env varible name
integer(SHR_KIND_IN),intent(out),optional :: rcodeOut ! Return error code
!EOP
!--- local ---
character(SHR_KIND_CL) :: dir ! directory to cd to
integer (SHR_KIND_IN) :: rcode ! Return error code
character(SHR_KIND_CL) :: filename ! namelist file to read
!--- formats ---
character(*),parameter :: subName = '(shr_file_chdir) '
character(*),parameter :: F00 = "('(shr_file_chdir) ',4a)"
!-------------------------------------------------------------------------------
! Notes:
!-------------------------------------------------------------------------------
call shr_file_stdioReadNL( model, filename, dirOut=dir, rcodeOut=rcode )
if (dir /= "nochange") then
call shr_sys_chdir(dir ,rcode)
if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename),", changed cwd to ",trim(dir)
else
if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename),", cwd has *not* been changed"
rcode = 1
endif
if ( present(rcodeOut) ) rcodeOut = rcode
END SUBROUTINE shr_file_chdir
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_file_dirio --- Change stdin and stdout.
!
! !DESCRIPTION:
! change the stdin & stdout (units 5 & 6), see shr_file_stdio for notes
!
! !INTERFACE: ------------------------------------------------------------------
SUBROUTINE shr_file_dirio(model) 1,2
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*),intent(in) :: model ! used to construct env varible name
!EOP
!--- local ---
!--- formats ---
character(*),parameter :: subName = '(shr_file_dirio) '
!-------------------------------------------------------------------------------
! Notes:
!
!-------------------------------------------------------------------------------
call shr_file_chStdIn (model)
call shr_file_chStdOut(model)
END SUBROUTINE shr_file_dirio
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_file_chStdIn -- Change stdin
!
! !DESCRIPTION:
! change the stdin (unit 5), see shr_file_stdio for notes
!
! !INTERFACE: ------------------------------------------------------------------
SUBROUTINE shr_file_chStdIn( model, NLFilename, rcodeOut ) 3,1
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*) ,intent(in) :: model ! used to construct env var name
character(SHR_KIND_CL),intent(out),optional :: NLFilename ! open unit 5 to this
integer (SHR_KIND_IN),intent(out),optional :: rcodeOut ! return code
!EOP
!--- local ---
character(SHR_KIND_CL) :: stdin ! open unit 5 to this file
character(SHR_KIND_CL) :: nlfile ! Namelist filename for model to read from
character(SHR_KIND_CL) :: filename ! namelist file to read
integer (SHR_KIND_IN) :: rcode ! return code
!--- formats ---
character(*),parameter :: subName = '(shr_file_chStdIn) '
character(*),parameter :: F00 = "('(shr_file_chStdIn) ',4a)"
!-------------------------------------------------------------------------------
! Notes:
!-------------------------------------------------------------------------------
call shr_file_stdioReadNL( model, filename, stdinOut=stdin, &
nlfileOut=nlfile, rcodeOut=rcode )
if (stdin /= "nochange") then
open(unit=5,file=stdin ,status='UNKNOWN',iostat=rcode)
if ( rcode /= 0 )then
if (s_loglev > 0) &
write(s_logunit,F00) "read ",trim(filename),': error opening file as unit 5:', &
trim(nlfile)
else
if (s_loglev > 0) &
write(s_logunit,F00) "read ",trim(filename),': unit 5 connected to ', &
trim(stdin)
end if
else
if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename), &
': unit 5 has *not* been redirected'
endif
if ( len_trim(nlfile) > 0) then
if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename), &
': read namelist from file:',trim(nlfile)
if ( .not. present(NLFilename) )then
if (s_loglev > 0) write(s_logunit,F00) "error: namelist filename NOT present"
rcode = 7
end if
else
if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename),", "
if ( present(NLFilename) )then
if (s_loglev > 0) write(s_logunit,F00) "error: namelist filename present, but null"
rcode = 8
end if
endif
if ( present(NLFilename) ) NLFilename = nlfile
if ( present(rcodeOut) ) rcodeOut = rcode
END SUBROUTINE shr_file_chStdIn
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_file_stdout -- Change stdout
!
! !DESCRIPTION:
! change the stdout (unit 6), see shr_file_stdio for notes
!
! !INTERFACE: ------------------------------------------------------------------
SUBROUTINE shr_file_chStdOut(model,rcodeOut) 3,2
implicit none
! !INPUT/OUTPUT PARAMETERS:
!--- arguments ---
character(*) ,intent(in) :: model ! used to construct env varible name
integer(SHR_KIND_IN),intent(out),optional :: rcodeOut ! Return error code
!EOP
!--- local ---
character(SHR_KIND_CL) :: filename ! namelist file to read
character(SHR_KIND_CL) :: stdout ! open unit 6 to this file
integer (SHR_KIND_IN) :: rcode ! return code
!--- formats ---
character(*),parameter :: subName = '(shr_file_chStdOut) '
character(*),parameter :: F00 = "('(shr_file_chStdOut) ',4a)"
!-------------------------------------------------------------------------------
! Notes:
!-------------------------------------------------------------------------------
call shr_file_stdioReadNL( model, filename, stdoutOut=stdout, &
rcodeOut=rcode )
if (stdout /= "nochange") then
close(6)
open(unit=6,file=stdout,position='APPEND')
if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename), &
': unit 6 connected to ',trim(stdout)
call shr_sys_flush(s_logunit)
else
if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename), &
': unit 6 has *not* been redirected'
rcode = 1
endif
if ( present(rcodeOut) ) rcodeOut = rcode
END SUBROUTINE shr_file_chStdOut
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_file_stdioReadNL -- read in stdio namelist
!
! !DESCRIPTION:
! Read in the stdio namelist for any given model type. Return any of the
! needed input namelist variables as optional arguments. Return "nochange" in
! dir, stdin, or stdout if shouldn't change.
!
! !INTERFACE: ------------------------------------------------------------------
SUBROUTINE shr_file_stdioReadNL( model, filename, dirOut, stdinOut, stdoutOut, & 3,4
NLFileOut, rcodeOut )
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(*) ,intent(in) :: model ! used to construct env varible name
character(SHR_KIND_CL),intent(out) :: filename ! nml file to read from unit 5
character(SHR_KIND_CL),intent(out),optional :: NLFileOut ! open unit 6 to this file
character(SHR_KIND_CL),intent(out),optional :: dirOut ! directory to cd to
character(SHR_KIND_CL),intent(out),optional :: stdinOut ! open unit 5 to this file
character(SHR_KIND_CL),intent(out),optional :: stdoutOut ! open unit 6 to this file
integer (SHR_KIND_IN),intent(out),optional :: rcodeOut ! return code
!EOP
!--- local ---
logical :: exists ! true iff file exists
character(SHR_KIND_CL) :: dir ! directory to cd to
character(SHR_KIND_CL) :: stdin ! open unit 5 to this file
character(SHR_KIND_CL) :: stdout ! open unit 6 to this file
character(SHR_KIND_CL) :: NLFile ! namelist file to read seperately
integer (SHR_KIND_IN) :: rcode ! return code
integer (SHR_KIND_IN) :: unit ! Unit to read from
namelist / stdio / dir,stdin,stdout,NLFile
!--- formats ---
character(*),parameter :: subName = '(shr_file_stdioReadNL) '
character(*),parameter :: F00 = "('(shr_file_stdioReadNL) ',4a)"
character(*),parameter :: F01 = "('(shr_file_stdioReadNL) ',2a,i6)"
!-------------------------------------------------------------------------------
! Notes:
!
!-------------------------------------------------------------------------------
rcode = 0
dir = "nochange"
stdin = "nochange"
stdout = "nochange"
NLFile = " "
filename = trim(model)//"_stdio.nml" ! eg. file="cpl_stdio.nml"
inquire(file=filename,exist=exists)
if (.not. exists) then
if (s_loglev > 0) write(s_logunit,F00) "file ",trim(filename),&
& " doesn't exist, can not read stdio namelist from it"
rcode = 9
else
unit = shr_file_getUnit()
open (unit,file=filename,action="READ")
read (unit,nml=stdio,iostat=rcode)
close(unit)
call shr_file_freeUnit( unit )
if (rcode /= 0) then
write(s_logunit,F01) 'ERROR: reading ',trim(filename),': iostat=',rcode
call shr_sys_abort(subName//" ERROR reading "//trim(filename) )
end if
endif
if ( len_trim(NLFile) > 0 .and. trim(stdin) /= "nochange" )then
write(s_logunit,F00) "Error: input namelist:"
write(s_logunit,nml=stdio)
call shr_sys_abort(subName//" ERROR trying to both redirect AND "// &
"open namelist filename" )
end if
if ( present(NLFileOut) ) NLFileOut = NLFile
if ( present(dirOut) ) dirOut = dir
if ( present(stdinOut) ) stdinOut = stdin
if ( present(stdoutOut) ) stdoutOut = stdout
if ( present(rcodeOut) ) rcodeOut = rcode
END SUBROUTINE shr_file_stdioReadNL
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_file_setIO -- read in stdio namelist
!
! !DESCRIPTION:
! This opens a namelist file specified as an argument and then opens
! a log file associated with the unit argument. This may be extended
! in the future.
!
! !INTERFACE: ------------------------------------------------------------------
SUBROUTINE shr_file_setIO( nmlfile, funit) 5,3
implicit none
! !INPUT/OUTPUT PARAMETERS:
character(len=*) ,intent(in) :: nmlfile ! namelist filename
integer(SHR_KIND_IN),intent(in) :: funit ! unit number for log file
!EOP
!--- local ---
logical :: exists ! true if file exists
character(SHR_KIND_CL) :: diri ! directory to cd to
character(SHR_KIND_CL) :: diro ! directory to cd to
character(SHR_KIND_CL) :: logfile ! open unit 6 to this file
integer(SHR_KIND_IN) :: unit ! unit number
integer(SHR_KIND_IN) :: rcode ! error code
namelist / modelio / diri,diro,logfile
!--- formats ---
character(*),parameter :: subName = '(shr_file_setIO) '
character(*),parameter :: F00 = "('(shr_file_setIO) ',4a)"
character(*),parameter :: F01 = "('(shr_file_setIO) ',2a,i6)"
!-------------------------------------------------------------------------------
! Notes:
!
!-------------------------------------------------------------------------------
diri = "."
diro = "."
logfile = ""
inquire(file=nmlfile,exist=exists)
if (.not. exists) then
if (s_loglev > 0) write(s_logunit,F00) "file ",trim(nmlfile)," non existant"
return
else
unit = shr_file_getUnit()
open (unit,file=nmlfile,action="READ")
read (unit,nml=modelio,iostat=rcode)
close(unit)
call shr_file_freeUnit( unit )
if (rcode /= 0) then
write(s_logunit,F01) 'ERROR: reading ',trim(nmlfile),': iostat=',rcode
call shr_sys_abort(subName//" ERROR reading "//trim(nmlfile) )
end if
endif
if (len_trim(logfile) > 0) then
open(funit,file=trim(diro)//"/"//trim(logfile))
else
if (s_loglev > 0) write(s_logunit,F00) "logfile not opened"
endif
END SUBROUTINE shr_file_setIO
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_file_setLogUnit -- Set the Log I/O Unit number
!
! !INTERFACE: ------------------------------------------------------------------
SUBROUTINE shr_file_setLogUnit(unit) 19
implicit none
! !INPUT/OUTPUT PARAMETERS:
integer(SHR_KIND_IN),intent(in) :: unit ! new unit number
!EOP
!--- formats ---
character(*),parameter :: subName = '(shr_file_setLogUnit) '
character(*),parameter :: F00 = "('(shr_file_setLogUnit) ',4a)"
!-------------------------------------------------------------------------------
! Notes: Caller must be sure it's a valid unit number
!-------------------------------------------------------------------------------
if (s_loglev > 1 .and. s_logunit-unit /= 0) then
write(s_logunit,*) subName,': reset log unit number from/to ',s_logunit, unit
write( unit,*) subName,': reset log unit number from/to ',s_logunit, unit
endif
s_logunit = unit
END SUBROUTINE shr_file_setLogUnit
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_file_setLogLevel -- Set the Log I/O Unit number
!
! !INTERFACE: ------------------------------------------------------------------
SUBROUTINE shr_file_setLogLevel(newlevel) 11
implicit none
! !INPUT/OUTPUT PARAMETERS:
integer(SHR_KIND_IN),intent(in) :: newlevel ! new log level
!EOP
!--- formats ---
character(*),parameter :: subName = '(shr_file_setLogLevel) '
character(*),parameter :: F00 = "('(shr_file_setLogLevel) ',4a)"
!-------------------------------------------------------------------------------
! Notes:
!-------------------------------------------------------------------------------
if (s_loglev+newlevel > 2 .and. s_loglev-newlevel /= 0) &
write(s_logunit,*) subName,': reset log level from/to ',s_loglev, newlevel
s_loglev = newlevel
END SUBROUTINE shr_file_setLogLevel
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_file_getLogUnit -- Set the Log I/O Unit number
!
! !INTERFACE: ------------------------------------------------------------------
SUBROUTINE shr_file_getLogUnit(unit) 9
implicit none
! !INPUT/OUTPUT PARAMETERS:
integer(SHR_KIND_IN),intent(out) :: unit ! new unit number
!EOP
!--- formats ---
character(*),parameter :: subName = '(shr_file_getLogUnit) '
character(*),parameter :: F00 = "('(shr_file_getLogUnit) ',4a)"
!-------------------------------------------------------------------------------
! Notes:
!-------------------------------------------------------------------------------
unit = s_logunit
END SUBROUTINE shr_file_getLogUnit
!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: shr_file_getLogLevel -- Set the Log I/O Unit number
!
! !INTERFACE: ------------------------------------------------------------------
SUBROUTINE shr_file_getLogLevel(curlevel) 9
implicit none
! !INPUT/OUTPUT PARAMETERS:
integer(SHR_KIND_IN),intent(out) :: curlevel ! new log level
!EOP
!--- formats ---
character(*),parameter :: subName = '(shr_file_getLogLevel) '
character(*),parameter :: F00 = "('(shr_file_getLogLevel) ',4a)"
!-------------------------------------------------------------------------------
! Notes:
!-------------------------------------------------------------------------------
curlevel = s_loglev
END SUBROUTINE shr_file_getLogLevel
!===============================================================================
!===============================================================================
END MODULE shr_file_mod