CESM_Driver: shr_file_mod.F90 Source File

00001 !===============================================================================
00002 ! SVN $Id: shr_file_mod.F90 22436 2010-04-18 05:32:48Z tcraig $
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_file_mod.F90 $
00004 !===============================================================================
00005 !BOP ===========================================================================
00006 !
00007 ! !MODULE: shr_file_mod.F90 --- Module to handle various file utilily functions.
00008 !
00009 ! !DESCRIPTION:
00010 !
00011 ! Miscilaneous methods to handle file and directory utilities as well as FORTRAN
00012 ! unit control. Also put/get local files into/from archival location
00013 !
00014 ! File utilites used with CCSM Message passing:
00015 !
00016 ! shr_file_stdio is the main example here, it changes the working directory, 
00017 !                changes stdin and stdout to a given filename.
00018 !
00019 ! This is needed because some implementations of MPI with MPMD so that
00020 ! each executable can run in a different working directory and redirect
00021 ! output to different files.
00022 !
00023 ! File name archival convention, eg.
00024 !    call shr_file_put(rcode,"foo","mss:/USER/foo",rtpd=3650)
00025 ! is extensible -- the existence of the option file name prefix, eg. "mss:", 
00026 ! and optional arguments, eg. rtpd-3650 can be used to access site-specific 
00027 ! storage devices.  Based on CCM (atmosphere) getfile & putfile routines, but
00028 ! intended to be a more extensible, shared code.
00029 ! 
00030 ! !REVISION HISTORY:
00031 !   2006-05-08 E. Kluzek, Add in shr_file_mod and getUnit, freeUnif methods.
00032 !   2000-??-?? B. Kauffman, original version circa 2000
00033 !
00034 ! !INTERFACE: ------------------------------------------------------------------
00035 
00036 MODULE shr_file_mod
00037 
00038 ! !USES:
00039 
00040    use shr_kind_mod  ! defines kinds
00041    use shr_sys_mod   ! system calls
00042    use shr_log_mod, only: s_loglev  => shr_log_Level
00043    use shr_log_mod, only: s_logunit => shr_log_Unit
00044    
00045    IMPLICIT none
00046 
00047    PRIVATE           ! By default everything is private to this module
00048    
00049 ! !PUBLIC TYPES:               
00050    
00051    ! no public types
00052 
00053 ! !PUBLIC MEMBER FUNCTIONS:
00054 
00055    public :: shr_file_put          ! Put a file to an archive location
00056    public :: shr_file_get          ! Get a file from an archive location
00057    public :: shr_file_queryPrefix  ! Get prefix type for a filename
00058    public :: shr_file_getUnit      ! Get a logical unit for reading or writing
00059    public :: shr_file_freeUnit     ! Free a logical unit
00060    public :: shr_file_stdio        ! change dir and stdin and stdout
00061    public :: shr_file_chDir        ! change current working directory
00062    public :: shr_file_dirio        ! change stdin and stdout
00063    public :: shr_file_chStdIn      ! change stdin  (attach to a file)
00064    public :: shr_file_chStdOut     ! change stdout (attach to a file)
00065    public :: shr_file_setIO        ! open a log file from namelist
00066    public :: shr_file_setLogUnit   ! Reset the log unit number
00067    public :: shr_file_setLogLevel  ! Reset the logging debug level
00068    public :: shr_file_getLogUnit   ! Get the log unit number
00069    public :: shr_file_getLogLevel  ! Get the logging debug level
00070 
00071 ! !PUBLIC DATA MEMBERS:
00072 
00073    ! Integer flags for recognized prefixes on file get/put operations
00074    integer(SHR_KIND_IN), parameter, public :: shr_file_noPrefix      = 0 ! no recognized prefix
00075    integer(SHR_KIND_IN), parameter, public :: shr_file_nullPrefix    = 1 ! null:
00076    integer(SHR_KIND_IN), parameter, public :: shr_file_cpPrefix      = 2 ! cp:
00077    integer(SHR_KIND_IN), parameter, public :: shr_file_mssPrefix     = 3 ! mss:
00078    integer(SHR_KIND_IN), parameter, public :: shr_file_hpssPrefix    = 4 ! hpss:
00079 
00080 !EOP
00081    !--- unit numbers, users can ask for unit numbers from 0 to min, but getUnit
00082    !--- won't give a unit below min, users cannot ask for unit number above max
00083    !--- for backward compatability.  
00084    !--- eventually, recommend min as hard lower limit (tcraig, 9/2007)
00085    integer(SHR_KIND_IN),parameter :: shr_file_minUnit = 10      ! Min unit number to give
00086    integer(SHR_KIND_IN),parameter :: shr_file_maxUnit = 99      ! Max unit number to give
00087    logical, save :: UnitTag(0:shr_file_maxUnit) = .false. ! Logical units in use
00088 
00089 !===============================================================================
00090 CONTAINS
00091 !===============================================================================
00092 
00093 !===============================================================================
00094 !BOP ===========================================================================
00095 !
00096 ! !IROUTINE: shr_file_put -- Put a file to an archival location.
00097 !
00098 ! !DESCRIPTION:
00099 !    a generic, extensible put-local-file-into-archive routine
00100 ! USAGE:
00101 !    call shr_file_put(rcode,"foo","/home/user/foo")
00102 !    if ( rcode /= 0 ) call shr_sys_abort( "error copying foo" )
00103 !    call shr_file_put(rcode,"foo","cp:/home/user/foo",remove=.true.)
00104 !    if ( rcode /= 0 ) call shr_sys_abort( "error copying foo" )
00105 !    call shr_file_put(rcode,"foo","mss:/USER/foo",rtpd=3650)
00106 !    if ( rcode /= 0 ) call shr_sys_abort( "error archiving foo to MSS" )
00107 !
00108 ! !INTERFACE: ------------------------------------------------------------------  
00109 
00110 SUBROUTINE shr_file_put(rcode,loc_fn,rem_fn,passwd,rtpd,async,remove)
00111 
00112    implicit none
00113 
00114 ! !INPUT/OUTPUT PARAMETERS:
00115 
00116    integer(SHR_KIND_IN),intent(out)         :: rcode  ! return code (non-zero -- error)
00117    character(*),        intent(in)          :: loc_fn ! local filename
00118    character(*),        intent(in)          :: rem_fn ! remote filename
00119    character(*),        intent(in),optional :: passwd ! password
00120    integer(SHR_KIND_IN),intent(in),optional :: rtpd   ! MSS retention period
00121    logical,             intent(in),optional :: async  ! true <=> asynchronous put
00122    logical,             intent(in),optional :: remove ! true <=> rm after put
00123 
00124 !EOP
00125 
00126    !----- local -----  
00127    integer(SHR_KIND_IN)   :: rtpd2    ! MSS retention period
00128    logical                :: remove2  ! true <=> rm after put
00129    logical                :: async2   ! true <=> asynchronous put
00130    character(SHR_KIND_CL) :: passwd2  ! password
00131    character(SHR_KIND_CL) :: rfn      ! rem_fn without the destination prefix
00132    character(SHR_KIND_CL) :: cmd      ! command sent to system call
00133    integer(SHR_KIND_IN)   :: prefix   ! remote file prefix type
00134 
00135    !----- formats -----
00136    character(*),parameter :: subName = '(shr_file_put) '
00137    character(*),parameter :: F00 =   "('(shr_file_put) ',4a)"
00138    character(*),parameter :: F01 =   "('(shr_file_put) ',a,i3,2a)"
00139    character(*),parameter :: F02 =   "(a,i4)"
00140 
00141 !-------------------------------------------------------------------------------
00142 ! Notes: 
00143 ! - On some machines the system call will not return a valid error code
00144 ! - when things are sent asynchronously, there probably won't be a error code
00145 !   returned.
00146 !-------------------------------------------------------------------------------
00147 
00148    remove2 =.false. ; if ( PRESENT(remove )) remove2 = remove
00149    async2  =.true.  ; if ( PRESENT(async  )) async2  = async
00150    passwd2 = " "    ; if ( PRESENT(passwd )) passwd2 = passwd
00151    rtpd2   = 365    ; if ( PRESENT(rtpd   )) rtpd2   = rtpd
00152    rcode   = 0
00153 
00154    if ( trim(rem_fn) == trim(loc_fn) ) then
00155       !------------------------------------------------------
00156       ! (remote file name) == (local file name) => do nothing
00157       !------------------------------------------------------
00158       cmd = 'do nothing: remote file = local file = '//trim(loc_fn)
00159       rcode = 0
00160    else if ( prefix == shr_file_cpPrefix .or. prefix == shr_file_noPrefix )then
00161       !------------------------------------------------------
00162       ! put via unix cp
00163       !------------------------------------------------------
00164       rfn = rem_fn
00165       if ( rem_fn(1:3) == "cp:") rfn = rem_fn(4:len_trim(rem_fn))
00166 #if defined(CATAMOUNT)
00167       call shr_jlcp(trim(loc_fn),len_trim(loc_fn),trim(rfn),len_trim(rfn),rcode)
00168       if (remove2) call unlink(trim(loc_fn))
00169       if (async2 .and. s_loglev > 0) write(s_logunit,F00) 'Error: asynchronous copy not supported.'
00170       cmd = 'shr_jlcp -f '//trim(loc_fn)//' '//trim(rfn)
00171       rcode = 0
00172 #else
00173       cmd = '/bin/cp -f '//trim(loc_fn)//' '//trim(rfn)
00174       if (remove2) cmd = trim(cmd)//' && /bin/rm -f '//trim(loc_fn)
00175       if (async2 ) cmd = trim(cmd)//' & '
00176       call shr_sys_system(trim(cmd),rcode)
00177 #endif
00178    else if ( prefix == shr_file_mssPrefix )then
00179       !------------------------------------------------------
00180       ! put onto NCAR's MSS
00181       !------------------------------------------------------
00182       if (rtpd2 > 9999) rtpd2 = 9999
00183       write(cmd,F02) '/usr/local/bin/msrcp -period ',rtpd2
00184       if (async2 .and. (.not. remove2) ) cmd = trim(cmd)//' -async '
00185       if (len_trim(passwd2) > 0 ) cmd = trim(cmd)//' -wpwd '//trim(passwd)
00186       cmd = trim(cmd)//' '//trim(loc_fn)//' '//trim(rem_fn)
00187       if (remove2) cmd = trim(cmd)//' && /bin/rm -f '//trim(loc_fn)
00188       if (async2 .and. remove2 ) cmd = trim(cmd)//' & '
00189       call shr_sys_system(trim(cmd),rcode)
00190    else if ( prefix == shr_file_hpssPrefix )then
00191       !------------------------------------------------------
00192       ! put onto LANL's hpss
00193       !------------------------------------------------------
00194       rcode = -1
00195       cmd = 'rem_fn='//trim(rem_fn)//' loc_fn='//trim(loc_fn)
00196       write(s_logunit,F00) 'ERROR: hpss option not yet implemented'
00197       call shr_sys_abort( subName//'ERROR: hpss option not yet implemented' )
00198    else if ( prefix == shr_file_nullPrefix )then
00199       ! do nothing
00200       cmd = "null prefix => no file archival, do nothing"
00201       rcode = 0
00202    end if
00203 
00204    if (s_loglev > 0) write(s_logunit,F01) 'rcode =',rcode,' cmd = ', trim(cmd)
00205 
00206 END SUBROUTINE shr_file_put
00207 
00208 !===============================================================================
00209 !BOP ===========================================================================
00210 !
00211 ! !IROUTINE: shr_file_get -- Get a file from archival location.
00212 !
00213 ! !DESCRIPTION:
00214 !    a generic, extensible get-local-file-from-archive routine
00215 !
00216 ! USAGE:
00217 !    call shr_file_get(rcode,"foo","/home/user/foo")
00218 !    if ( rcode /= 0 ) call shr_sys_abort( "error getting file foo" )
00219 !    call shr_file_get(rcode,"foo","cp:/home/user/foo",remove=.true.)
00220 !    if ( rcode /= 0 ) call shr_sys_abort( "error getting file foo" )
00221 !    call shr_file_get(rcode,"foo","mss:/USER/foo",clobber=.true.)
00222 !    if ( rcode /= 0 ) call shr_sys_abort( "error getting file foo from MSS" )
00223 !
00224 ! !INTERFACE: ------------------------------------------------------------------  
00225 
00226 SUBROUTINE shr_file_get(rcode,loc_fn,rem_fn,passwd,async,clobber)
00227 
00228    implicit none
00229 
00230 ! !INPUT/OUTPUT PARAMETERS:
00231 
00232    integer(SHR_KIND_IN),intent(out)         :: rcode   ! return code (non-zero means error)
00233    character(*)        ,intent(in)          :: loc_fn  ! local filename
00234    character(*)        ,intent(in)          :: rem_fn  ! remote filename
00235    character(*)        ,intent(in),optional :: passwd  ! password
00236    logical             ,intent(in),optional :: async   ! true <=> asynchronous get
00237    logical             ,intent(in),optional :: clobber ! true <=> clobber existing file
00238 
00239 !EOP
00240 
00241    !----- local -----
00242    logical                :: async2   ! true <=> asynchronous get
00243    logical                :: clobber2 ! true <=> clobber existing file
00244    logical                :: exists   ! true <=> local file a ready exists
00245    character(SHR_KIND_CL) :: passwd2  ! password
00246    character(SHR_KIND_CL) :: rfn      ! rem_fn without the destination prefix
00247    character(SHR_KIND_CL) :: cmd      ! command sent to system call
00248    integer(SHR_KIND_IN)   :: prefix   ! remote file prefix type
00249 
00250    !----- formats -----
00251    character(*),parameter :: subName = '(shr_file_get) '
00252    character(*),parameter :: F00 =   "('(shr_file_get) ',4a)"
00253    character(*),parameter :: F01 =   "('(shr_file_get) ',a,i3,2a)"
00254 
00255 !-------------------------------------------------------------------------------
00256 ! Notes: 
00257 ! - On some machines the system call will not return a valid error code
00258 ! - When things are sent asynchronously, there probably won't be a error code
00259 !   returned.
00260 !-------------------------------------------------------------------------------
00261 
00262    passwd2  = " "     ; if (PRESENT(passwd )) passwd2  = passwd
00263    async2   = .false. ; if (PRESENT(async  )) async2   = async
00264    clobber2 = .false. ; if (PRESENT(clobber)) clobber2 = clobber
00265    rcode    = 0
00266 
00267    inquire(file=trim(loc_fn),exist=exists)
00268    prefix = shr_file_queryPrefix( rem_fn )
00269 
00270    if ( exists .and. .not. clobber2 ) then
00271       !------------------------------------------------------
00272       ! (file exists) and (don't clobber) => do nothing
00273       !------------------------------------------------------
00274       cmd = 'do nothing: file exists & no-clobber for '//trim(loc_fn)
00275       rcode = 0
00276    else if ( trim(rem_fn) == trim(loc_fn) ) then
00277       !------------------------------------------------------
00278       ! (remote file name) == (local file name) => do nothing
00279       !------------------------------------------------------
00280       cmd = 'do nothing: remote file = local file for '//trim(loc_fn)
00281       rcode = 0
00282    else if ( prefix == shr_file_cpPrefix .or. prefix == shr_file_noPrefix )then
00283       !------------------------------------------------------
00284       ! get via unix cp
00285       !------------------------------------------------------
00286       rfn = rem_fn  ! remove prefix from this temp file name
00287       if (rem_fn(1:3) == "cp:") rfn = rem_fn(4:len_trim(rem_fn))
00288 #if defined(CATAMOUNT)
00289       call shr_jlcp(trim(rfn),len(trim(rfn)),trim(loc_fn),len(trim(loc_fn)),rcode)
00290       if (async2.and.s_loglev>0) write(s_logunit,F00) 'Error: asynchronous copy not supported.'
00291       cmd = 'shr_jlcp -f '//trim(rfn)//' '//trim(loc_fn)
00292       rcode = 0
00293 #else
00294       cmd = '/bin/cp -f '//trim(rfn)//' '//trim(loc_fn)
00295       if (async2) cmd = trim(cmd)//' & '
00296       call shr_sys_system(trim(cmd),rcode)
00297 #endif
00298    else if ( prefix == shr_file_mssPrefix )then
00299       !------------------------------------------------------
00300       ! get from NCAR's MSS
00301       !------------------------------------------------------
00302       cmd = '/usr/local/bin/msrcp '
00303       if (async2)   cmd = trim(cmd)//' -async '
00304       cmd = trim(cmd)//' '//trim(rem_fn)//' '//trim(loc_fn)
00305       call shr_sys_system(trim(cmd),rcode)
00306    else if ( prefix == shr_file_hpssPrefix )then
00307       !------------------------------------------------------
00308       ! get from LANL's hpss
00309       !------------------------------------------------------
00310       rcode = -1
00311       cmd = 'rem_fn='//trim(rem_fn)//' loc_fn='//trim(loc_fn)
00312       write(s_logunit,F00) 'ERROR: hpss option not yet implemented'
00313       call shr_sys_abort( subName//'ERROR: hpss option not yet implemented' )
00314    else if ( prefix == shr_file_nullPrefix )then
00315       ! do nothing
00316       cmd = "null prefix => no file retrieval, do nothing"
00317       rcode = 0
00318    end if
00319 
00320    if (s_loglev > 0) write(s_logunit,F01) 'rcode =',rcode,' cmd = ', trim(cmd)
00321 
00322 END SUBROUTINE shr_file_get
00323 
00324 !===============================================================================
00325 !BOP ===========================================================================
00326 !
00327 ! !IROUTINE: shr_file_queryPrefix -- Get the prefix type from a filepath.
00328 !
00329 ! !DESCRIPTION:
00330 !    
00331 ! !INTERFACE: ------------------------------------------------------------------  
00332 
00333 integer(SHR_KIND_IN) FUNCTION shr_file_queryPrefix( filepath, prefix )
00334 
00335    implicit none
00336 
00337 ! !INPUT/OUTPUT PARAMETERS:
00338 
00339    character(*), intent(in)            :: filepath ! Input filepath
00340    character(*), intent(out), optional :: prefix   ! Output prefix description
00341 
00342 !EOP
00343 
00344    !----- local -----
00345 
00346 !-------------------------------------------------------------------------------
00347 ! Notes: 
00348 !-------------------------------------------------------------------------------
00349 
00350    if (     filepath(1:5) == "null:" )then
00351       shr_file_queryPrefix = shr_file_nullPrefix
00352       if ( present(prefix) ) prefix = "null:"
00353    else if( filepath(1:3) == "cp:" )then
00354       shr_file_queryPrefix = shr_file_cpPrefix
00355       if ( present(prefix) ) prefix = "cp:"
00356    else if( filepath(1:4) == "mss:" )then
00357       shr_file_queryPrefix = shr_file_mssPrefix
00358       if ( present(prefix) ) prefix = "mss:"
00359    else if( filepath(1:5) == "hpss:" )then
00360       shr_file_queryPrefix = shr_file_hpssPrefix
00361       if ( present(prefix) ) prefix = "hpss:"
00362    else
00363       shr_file_queryPrefix = shr_file_noPrefix
00364       if ( present(prefix) ) prefix = ""
00365    end if
00366 
00367 END FUNCTION shr_file_queryPrefix
00368 
00369 !===============================================================================
00370 !BOP ===========================================================================
00371 !
00372 ! !IROUTINE: shr_file_getUnit -- Get a free FORTRAN unit number
00373 !
00374 ! !DESCRIPTION: Get the next free FORTRAN unit number.
00375 !
00376 ! !REVISION HISTORY:
00377 !     2005-Dec-14 - E. Kluzek - creation
00378 !
00379 ! !INTERFACE: ------------------------------------------------------------------  
00380 
00381 INTEGER FUNCTION shr_file_getUnit ( unit )
00382 
00383    implicit none
00384 
00385 ! !INPUT/OUTPUT PARAMETERS:
00386 
00387    integer(SHR_KIND_IN),intent(in),optional :: unit ! desired unit number
00388 
00389 !EOP
00390 
00391    !----- local -----
00392    integer(SHR_KIND_IN)   :: n      ! loop index
00393    logical                :: opened ! If unit opened or not
00394 
00395    !----- formats -----
00396    character(*),parameter :: subName = '(shr_file_getUnit) '
00397    character(*),parameter :: F00   = "('(shr_file_getUnit) ',A,I4,A)"
00398 
00399 !-------------------------------------------------------------------------------
00400 ! Notes:
00401 !-------------------------------------------------------------------------------
00402 
00403    if (present (unit)) then
00404       inquire( unit, opened=opened )
00405       if (unit < 0 .or. unit > shr_file_maxUnit) then
00406          write(s_logunit,F00) 'invalid unit number request:', unit
00407          call shr_sys_abort( 'ERROR: bad input unit number' )
00408       else if (opened .or. UnitTag(unit) .or. unit == 0 .or. unit == 5 &
00409                .or. unit == 6) then
00410          write(s_logunit,F00) 'unit number ', unit, ' is already in use'
00411          call shr_sys_abort( 'ERROR: Input unit number already in use' )
00412       else
00413          shr_file_getUnit = unit
00414          UnitTag (unit)   = .true.
00415          return
00416       end if
00417 
00418    else
00419       ! --- Choose first available unit other than 0, 5, or 6  ------
00420       do n=shr_file_maxUnit, shr_file_minUnit, -1
00421          inquire( n, opened=opened )
00422          if (n == 5 .or. n == 6 .or. opened) then
00423             cycle
00424          end if
00425          if ( .not. UnitTag(n) ) then
00426             shr_file_getUnit = n
00427             UnitTag(n)       = .true.
00428             return
00429          end if
00430       end do
00431    end if
00432 
00433    call shr_sys_abort( subName//': Error: no available units found' )
00434 
00435 END FUNCTION shr_file_getUnit
00436 
00437 !===============================================================================
00438 !BOP ===========================================================================
00439 !
00440 ! !IROUTINE: shr_file_freeUnit -- Free up a FORTRAN unit number
00441 !
00442 ! !DESCRIPTION: Free up the given unit number
00443 !
00444 ! !REVISION HISTORY:
00445 !     2005-Dec-14 - E. Kluzek - creation
00446 !
00447 ! !INTERFACE: ------------------------------------------------------------------  
00448 
00449 SUBROUTINE shr_file_freeUnit ( unit)
00450 
00451    implicit none
00452 
00453 ! !INPUT/OUTPUT PARAMETERS:
00454 
00455    integer(SHR_KIND_IN),intent(in) :: unit  ! unit number to be freed
00456 
00457 !EOP
00458 
00459    !----- local -----
00460 
00461    !----- formats -----
00462    character(*), parameter :: subName = '(shr_file_freeUnit) '
00463    character(*), parameter :: F00 =   "('(shr_file_freeUnit) ',A,I4,A)"
00464 
00465 !-------------------------------------------------------------------------------
00466 ! Notes:
00467 !-------------------------------------------------------------------------------
00468 
00469    if (unit < 0 .or. unit > shr_file_maxUnit) then
00470       if (s_loglev > 0) write(s_logunit,F00) 'invalid unit number request:', unit
00471    else if (unit == 0 .or. unit == 5 .or. unit == 6) then
00472       call shr_sys_abort( subName//': Error: units 0, 5, and 6 must not be freed' )
00473    else if (UnitTag(unit)) then
00474       UnitTag (unit) = .false.
00475    else
00476       if (s_loglev > 0) write(s_logunit,F00) 'unit ', unit, ' was not in use'
00477    end if
00478 
00479    return
00480 
00481 END SUBROUTINE shr_file_freeUnit
00482 
00483 !===============================================================================
00484 !BOP ===========================================================================
00485 !
00486 ! !IROUTINE: shr_file_stdio -- Change working directory, and redirect stdin/stdout
00487 !
00488 ! !DESCRIPTION:
00489 !   1) change the cwd (current working directory) and 
00490 !   2) redirect stdin & stdout (units 5 & 6) to named files,
00491 !   where the desired cwd & files are specified by namelist file.
00492 !
00493 !   Normally this is done to work around limitations in the execution syntax
00494 !   of common MPI implementations.  For example, SGI's mpirun syntax is not 
00495 !   flexible enough to allow MPMD models to select different execution
00496 !   directories or to redirect stdin & stdout on the command line.  
00497 !   Such functionality is highly desireable for CCSM purposes.  
00498 !   ie. mpirun can't handle this:
00499 !   unix> cd /usr/tmp/jdoe/csm/case01/atm ; atm < atm.parm > atm.log &
00500 !   unix> cd /usr/tmp/jdoe/csm/case01/cpl ; cpl < cpl.parm > cpl.log &
00501 !   etc.
00502 !
00503 ! ASSUMPTIONS:
00504 ! o if the cwd, stdin, or stdout are to be changed, there must be a namelist
00505 !   file in the cwd named <model>_stdio.nml  where <model> is provided via
00506 !   subroutine dummy argument. 
00507 !
00508 ! !INTERFACE: ------------------------------------------------------------------  
00509 
00510 SUBROUTINE shr_file_stdio(model)
00511 
00512    implicit none
00513 
00514 ! !INPUT/OUTPUT PARAMETERS:
00515 
00516    character(*),intent(in) :: model ! used to construct env varible name
00517 
00518 !EOP
00519 
00520    !--- formats ---
00521    character(*),parameter :: subName = '(shr_file_stdio) '
00522    character(*),parameter :: F00   = "('(shr_file_stdio) ',4a)"
00523 
00524 !-------------------------------------------------------------------------------
00525 ! Notes:
00526 !-------------------------------------------------------------------------------
00527 
00528    call shr_file_chdir   (model) ! changes cwd
00529    call shr_file_chStdOut(model) ! open units 5 & 6 to named files
00530    call shr_file_chStdIn (model) ! open units 5 & 6 to named files
00531  
00532 END SUBROUTINE shr_file_stdio
00533 
00534 !===============================================================================
00535 !BOP ===========================================================================
00536 !
00537 ! !IROUTINE: shr_file_chdir -- Change working directory.
00538 !
00539 ! !DESCRIPTION:
00540 !   change the cwd (current working directory), see shr_file_stdio for notes
00541 !
00542 ! !INTERFACE: ------------------------------------------------------------------  
00543 
00544 SUBROUTINE shr_file_chdir(model, rcodeOut)
00545 
00546 ! !USES:
00547 
00548    implicit none
00549 
00550 ! !INPUT/OUTPUT PARAMETERS:
00551 
00552    character(*)        ,intent(in)           :: model    ! used to construct env varible name
00553    integer(SHR_KIND_IN),intent(out),optional :: rcodeOut ! Return error code
00554 
00555 !EOP
00556 
00557    !--- local ---
00558    character(SHR_KIND_CL) :: dir      ! directory to cd to
00559    integer  (SHR_KIND_IN) :: rcode    ! Return error code
00560    character(SHR_KIND_CL) :: filename ! namelist file to read
00561 
00562    !--- formats ---
00563    character(*),parameter :: subName = '(shr_file_chdir) '
00564    character(*),parameter :: F00 =   "('(shr_file_chdir) ',4a)"
00565 
00566 !-------------------------------------------------------------------------------
00567 ! Notes:
00568 !-------------------------------------------------------------------------------
00569 
00570    call shr_file_stdioReadNL( model, filename, dirOut=dir, rcodeOut=rcode )
00571    if (dir /= "nochange") then
00572       call shr_sys_chdir(dir ,rcode)
00573       if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename),", changed cwd to ",trim(dir)
00574    else
00575       if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename),", cwd has *not* been changed"
00576       rcode = 1
00577    endif
00578    if ( present(rcodeOut) ) rcodeOut = rcode
00579  
00580 END SUBROUTINE shr_file_chdir
00581 
00582 !===============================================================================
00583 !BOP ===========================================================================
00584 !
00585 ! !IROUTINE: shr_file_dirio --- Change stdin and stdout.
00586 !
00587 ! !DESCRIPTION:
00588 !   change the stdin & stdout (units 5 & 6), see shr_file_stdio for notes
00589 !
00590 ! !INTERFACE: ------------------------------------------------------------------  
00591 
00592 SUBROUTINE shr_file_dirio(model)
00593 
00594    implicit none
00595 
00596 ! !INPUT/OUTPUT PARAMETERS:
00597 
00598    character(*),intent(in) :: model ! used to construct env varible name
00599 
00600 !EOP
00601 
00602    !--- local ---
00603 
00604    !--- formats ---
00605    character(*),parameter :: subName = '(shr_file_dirio) '
00606 
00607 !-------------------------------------------------------------------------------
00608 ! Notes:
00609 !
00610 !-------------------------------------------------------------------------------
00611 
00612    call shr_file_chStdIn (model)
00613    call shr_file_chStdOut(model)
00614  
00615 END SUBROUTINE shr_file_dirio
00616 
00617 !===============================================================================
00618 !BOP ===========================================================================
00619 !
00620 ! !IROUTINE: shr_file_chStdIn -- Change stdin
00621 !
00622 ! !DESCRIPTION:
00623 !   change the stdin (unit 5), see shr_file_stdio for notes
00624 !
00625 ! !INTERFACE: ------------------------------------------------------------------  
00626 
00627 SUBROUTINE shr_file_chStdIn( model, NLFilename, rcodeOut )
00628 
00629    implicit none
00630 
00631 ! !INPUT/OUTPUT PARAMETERS:
00632 
00633    character(*)          ,intent(in)           :: model      ! used to construct env var name
00634    character(SHR_KIND_CL),intent(out),optional :: NLFilename ! open unit 5 to this
00635    integer  (SHR_KIND_IN),intent(out),optional :: rcodeOut   ! return code
00636 
00637 !EOP
00638 
00639    !--- local ---
00640    character(SHR_KIND_CL) :: stdin    ! open unit 5 to this file
00641    character(SHR_KIND_CL) :: nlfile   ! Namelist filename for model to read from
00642    character(SHR_KIND_CL) :: filename ! namelist file to read
00643    integer  (SHR_KIND_IN) :: rcode    ! return code
00644 
00645    !--- formats ---
00646    character(*),parameter :: subName = '(shr_file_chStdIn) '
00647    character(*),parameter :: F00   = "('(shr_file_chStdIn) ',4a)"
00648 
00649 !-------------------------------------------------------------------------------
00650 ! Notes:
00651 !-------------------------------------------------------------------------------
00652 
00653    call shr_file_stdioReadNL( model, filename, stdinOut=stdin, &
00654                               nlfileOut=nlfile, rcodeOut=rcode )
00655    if (stdin  /= "nochange") then
00656       open(unit=5,file=stdin ,status='UNKNOWN',iostat=rcode)
00657       if ( rcode /= 0 )then
00658          if (s_loglev > 0) &
00659             write(s_logunit,F00) "read ",trim(filename),': error opening file as unit 5:', &
00660                       trim(nlfile)
00661       else
00662          if (s_loglev > 0) &
00663             write(s_logunit,F00) "read ",trim(filename),': unit 5 connected to ', &
00664                       trim(stdin)
00665       end if
00666    else
00667       if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename), &
00668          ': unit 5 has *not* been redirected'
00669    endif
00670    if ( len_trim(nlfile) > 0) then
00671       if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename), &
00672          ': read namelist from file:',trim(nlfile)
00673       if ( .not. present(NLFilename) )then
00674          if (s_loglev > 0) write(s_logunit,F00) "error: namelist filename NOT present"
00675          rcode = 7
00676       end if
00677    else
00678       if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename),", "
00679       if ( present(NLFilename) )then
00680          if (s_loglev > 0) write(s_logunit,F00) "error: namelist filename present, but null"
00681          rcode = 8
00682       end if
00683    endif
00684    if ( present(NLFilename) ) NLFilename = nlfile
00685    if ( present(rcodeOut)   ) rcodeOut   = rcode
00686  
00687 END SUBROUTINE shr_file_chStdIn
00688 
00689 !===============================================================================
00690 !BOP ===========================================================================
00691 !
00692 ! !IROUTINE: shr_file_stdout -- Change stdout
00693 !
00694 ! !DESCRIPTION:
00695 !   change the stdout (unit 6), see shr_file_stdio for notes
00696 !
00697 ! !INTERFACE: ------------------------------------------------------------------  
00698 
00699 SUBROUTINE shr_file_chStdOut(model,rcodeOut)
00700 
00701    implicit none
00702 
00703 ! !INPUT/OUTPUT PARAMETERS:
00704    !--- arguments ---
00705    character(*)        ,intent(in)           :: model    ! used to construct env varible name
00706    integer(SHR_KIND_IN),intent(out),optional :: rcodeOut ! Return error code
00707 !EOP
00708 
00709    !--- local ---
00710    character(SHR_KIND_CL) :: filename ! namelist file to read
00711    character(SHR_KIND_CL) :: stdout   ! open unit 6 to this file
00712    integer  (SHR_KIND_IN) :: rcode    ! return code
00713 
00714    !--- formats ---
00715    character(*),parameter :: subName = '(shr_file_chStdOut) '
00716    character(*),parameter :: F00   = "('(shr_file_chStdOut) ',4a)"
00717 
00718 !-------------------------------------------------------------------------------
00719 ! Notes:
00720 !-------------------------------------------------------------------------------
00721 
00722    call shr_file_stdioReadNL( model, filename, stdoutOut=stdout, &
00723                               rcodeOut=rcode )
00724    if (stdout /= "nochange") then
00725       close(6)
00726       open(unit=6,file=stdout,position='APPEND')
00727       if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename),  &
00728          ': unit 6 connected to ',trim(stdout)
00729       call shr_sys_flush(s_logunit)
00730    else
00731       if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename),  &
00732          ': unit 6 has *not* been redirected'
00733       rcode = 1
00734    endif
00735  
00736    if ( present(rcodeOut)   ) rcodeOut = rcode
00737  
00738 END SUBROUTINE shr_file_chStdOut
00739 
00740 !===============================================================================
00741 !BOP ===========================================================================
00742 !
00743 ! !IROUTINE: shr_file_stdioReadNL -- read in stdio namelist
00744 !
00745 ! !DESCRIPTION:
00746 !   Read in the stdio namelist for any given model type. Return any of the
00747 ! needed input namelist variables as optional arguments. Return "nochange" in
00748 ! dir, stdin, or stdout if shouldn't change.
00749 !
00750 ! !INTERFACE: ------------------------------------------------------------------  
00751 
00752 SUBROUTINE shr_file_stdioReadNL( model, filename, dirOut, stdinOut, stdoutOut, &
00753                                  NLFileOut, rcodeOut )
00754 
00755    implicit none
00756 
00757 ! !INPUT/OUTPUT PARAMETERS:
00758 
00759    character(*)          ,intent(in)           :: model     ! used to construct env varible name
00760    character(SHR_KIND_CL),intent(out)          :: filename  ! nml file to read from unit 5
00761    character(SHR_KIND_CL),intent(out),optional :: NLFileOut ! open unit 6 to this file
00762    character(SHR_KIND_CL),intent(out),optional :: dirOut    ! directory to cd to
00763    character(SHR_KIND_CL),intent(out),optional :: stdinOut  ! open unit 5 to this file
00764    character(SHR_KIND_CL),intent(out),optional :: stdoutOut ! open unit 6 to this file
00765    integer  (SHR_KIND_IN),intent(out),optional :: rcodeOut  ! return code
00766 
00767 !EOP
00768 
00769    !--- local ---
00770    logical                :: exists   ! true iff file exists
00771    character(SHR_KIND_CL) :: dir      ! directory to cd to
00772    character(SHR_KIND_CL) :: stdin    ! open unit 5 to this file
00773    character(SHR_KIND_CL) :: stdout   ! open unit 6 to this file
00774    character(SHR_KIND_CL) :: NLFile   ! namelist file to read seperately
00775    integer  (SHR_KIND_IN) :: rcode    ! return code
00776    integer  (SHR_KIND_IN) :: unit     ! Unit to read from
00777 
00778    namelist / stdio / dir,stdin,stdout,NLFile
00779 
00780    !--- formats ---
00781    character(*),parameter :: subName = '(shr_file_stdioReadNL) '
00782    character(*),parameter :: F00   = "('(shr_file_stdioReadNL) ',4a)"
00783    character(*),parameter :: F01   = "('(shr_file_stdioReadNL) ',2a,i6)"
00784 
00785 !-------------------------------------------------------------------------------
00786 ! Notes:
00787 !
00788 !-------------------------------------------------------------------------------
00789 
00790    rcode  = 0
00791    dir    = "nochange"
00792    stdin  = "nochange"
00793    stdout = "nochange"
00794    NLFile = " "
00795 
00796    filename = trim(model)//"_stdio.nml"  ! eg. file="cpl_stdio.nml"
00797    inquire(file=filename,exist=exists)
00798 
00799    if (.not. exists) then
00800       if (s_loglev > 0) write(s_logunit,F00) "file ",trim(filename),& 
00801       & " doesn't exist, can not read stdio namelist from it"
00802       rcode = 9
00803    else
00804       unit = shr_file_getUnit()
00805       open (unit,file=filename,action="READ")
00806       read (unit,nml=stdio,iostat=rcode)
00807       close(unit)
00808       call shr_file_freeUnit( unit )
00809       if (rcode /= 0) then
00810          write(s_logunit,F01) 'ERROR: reading ',trim(filename),': iostat=',rcode
00811          call shr_sys_abort(subName//" ERROR reading "//trim(filename) )
00812       end if
00813    endif
00814    if ( len_trim(NLFile) > 0 .and. trim(stdin) /= "nochange" )then
00815       write(s_logunit,F00) "Error: input namelist:"
00816       write(s_logunit,nml=stdio)
00817       call shr_sys_abort(subName//" ERROR trying to both redirect AND "// &
00818                          "open namelist filename" )
00819    end if
00820    if ( present(NLFileOut) ) NLFileOut = NLFile
00821    if ( present(dirOut)    ) dirOut    = dir
00822    if ( present(stdinOut)  ) stdinOut  = stdin
00823    if ( present(stdoutOut) ) stdoutOut = stdout
00824    if ( present(rcodeOut)  ) rcodeOut  = rcode
00825  
00826 END SUBROUTINE shr_file_stdioReadNL
00827 
00828 !===============================================================================
00829 !BOP ===========================================================================
00830 !
00831 ! !IROUTINE: shr_file_setIO -- read in stdio namelist
00832 !
00833 ! !DESCRIPTION:
00834 !   This opens a namelist file specified as an argument and then opens
00835 !   a log file associated with the unit argument.  This may be extended
00836 !   in the future.
00837 !
00838 ! !INTERFACE: ------------------------------------------------------------------  
00839 
00840 SUBROUTINE shr_file_setIO( nmlfile, funit)
00841 
00842    implicit none
00843 
00844 ! !INPUT/OUTPUT PARAMETERS:
00845 
00846    character(len=*)    ,intent(in)  :: nmlfile  ! namelist filename
00847    integer(SHR_KIND_IN),intent(in)  :: funit    ! unit number for log file
00848 
00849 !EOP
00850 
00851    !--- local ---
00852    logical                :: exists   ! true if file exists
00853    character(SHR_KIND_CL) :: diri     ! directory to cd to
00854    character(SHR_KIND_CL) :: diro     ! directory to cd to
00855    character(SHR_KIND_CL) :: logfile  ! open unit 6 to this file
00856    integer(SHR_KIND_IN)   :: unit     ! unit number
00857    integer(SHR_KIND_IN)   :: rcode    ! error code
00858 
00859    namelist / modelio / diri,diro,logfile
00860 
00861    !--- formats ---
00862    character(*),parameter :: subName = '(shr_file_setIO) '
00863    character(*),parameter :: F00   = "('(shr_file_setIO) ',4a)"
00864    character(*),parameter :: F01   = "('(shr_file_setIO) ',2a,i6)"
00865 
00866 !-------------------------------------------------------------------------------
00867 ! Notes:
00868 !
00869 !-------------------------------------------------------------------------------
00870 
00871    diri = "."
00872    diro = "."
00873    logfile = ""
00874 
00875    inquire(file=nmlfile,exist=exists)
00876 
00877    if (.not. exists) then
00878       if (s_loglev > 0) write(s_logunit,F00) "file ",trim(nmlfile)," non existant"
00879       return
00880    else
00881       unit = shr_file_getUnit()
00882       open (unit,file=nmlfile,action="READ")
00883       read (unit,nml=modelio,iostat=rcode)
00884       close(unit)
00885       call shr_file_freeUnit( unit )
00886       if (rcode /= 0) then
00887          write(s_logunit,F01) 'ERROR: reading ',trim(nmlfile),': iostat=',rcode
00888          call shr_sys_abort(subName//" ERROR reading "//trim(nmlfile) )
00889       end if
00890    endif
00891 
00892    if (len_trim(logfile) > 0) then
00893       open(funit,file=trim(diro)//"/"//trim(logfile))
00894    else
00895       if (s_loglev > 0) write(s_logunit,F00) "logfile not opened"
00896    endif
00897 
00898 END SUBROUTINE shr_file_setIO
00899 
00900 !===============================================================================
00901 !BOP ===========================================================================
00902 !
00903 ! !IROUTINE: shr_file_setLogUnit -- Set the Log I/O Unit number
00904 !
00905 ! !INTERFACE: ------------------------------------------------------------------  
00906 
00907 SUBROUTINE shr_file_setLogUnit(unit)
00908 
00909    implicit none
00910 
00911 ! !INPUT/OUTPUT PARAMETERS:
00912 
00913    integer(SHR_KIND_IN),intent(in) :: unit     ! new unit number
00914 
00915 !EOP
00916 
00917    !--- formats ---
00918    character(*),parameter :: subName = '(shr_file_setLogUnit) '
00919    character(*),parameter :: F00   = "('(shr_file_setLogUnit) ',4a)"
00920 
00921 !-------------------------------------------------------------------------------
00922 ! Notes: Caller must be sure it's a valid unit number
00923 !-------------------------------------------------------------------------------
00924 
00925    if (s_loglev > 1 .and. s_logunit-unit /= 0) then
00926       write(s_logunit,*) subName,': reset log unit number from/to ',s_logunit, unit
00927       write(     unit,*) subName,': reset log unit number from/to ',s_logunit, unit
00928    endif
00929 
00930    s_logunit = unit
00931  
00932 END SUBROUTINE shr_file_setLogUnit
00933 
00934 !===============================================================================
00935 !BOP ===========================================================================
00936 !
00937 ! !IROUTINE: shr_file_setLogLevel -- Set the Log I/O Unit number
00938 !
00939 ! !INTERFACE: ------------------------------------------------------------------  
00940 
00941 SUBROUTINE shr_file_setLogLevel(newlevel)
00942 
00943    implicit none
00944 
00945 ! !INPUT/OUTPUT PARAMETERS:
00946 
00947    integer(SHR_KIND_IN),intent(in) :: newlevel     ! new log level
00948 
00949 !EOP
00950 
00951    !--- formats ---
00952    character(*),parameter :: subName = '(shr_file_setLogLevel) '
00953    character(*),parameter :: F00   = "('(shr_file_setLogLevel) ',4a)"
00954 
00955 !-------------------------------------------------------------------------------
00956 ! Notes: 
00957 !-------------------------------------------------------------------------------
00958 
00959    if (s_loglev+newlevel > 2 .and. s_loglev-newlevel /= 0) &
00960       write(s_logunit,*) subName,': reset log level from/to ',s_loglev, newlevel
00961 
00962    s_loglev = newlevel
00963  
00964 END SUBROUTINE shr_file_setLogLevel
00965 
00966 !===============================================================================
00967 !BOP ===========================================================================
00968 !
00969 ! !IROUTINE: shr_file_getLogUnit -- Set the Log I/O Unit number
00970 !
00971 ! !INTERFACE: ------------------------------------------------------------------  
00972 
00973 SUBROUTINE shr_file_getLogUnit(unit)
00974 
00975    implicit none
00976 
00977 ! !INPUT/OUTPUT PARAMETERS:
00978 
00979    integer(SHR_KIND_IN),intent(out) :: unit     ! new unit number
00980 
00981 !EOP
00982 
00983    !--- formats ---
00984    character(*),parameter :: subName = '(shr_file_getLogUnit) '
00985    character(*),parameter :: F00   = "('(shr_file_getLogUnit) ',4a)"
00986 
00987 !-------------------------------------------------------------------------------
00988 ! Notes: 
00989 !-------------------------------------------------------------------------------
00990 
00991    unit = s_logunit
00992  
00993 END SUBROUTINE shr_file_getLogUnit
00994 
00995 !===============================================================================
00996 !BOP ===========================================================================
00997 !
00998 ! !IROUTINE: shr_file_getLogLevel -- Set the Log I/O Unit number
00999 !
01000 ! !INTERFACE: ------------------------------------------------------------------  
01001 
01002 SUBROUTINE shr_file_getLogLevel(curlevel)
01003 
01004    implicit none
01005 
01006 ! !INPUT/OUTPUT PARAMETERS:
01007 
01008    integer(SHR_KIND_IN),intent(out) :: curlevel     ! new log level
01009 
01010 !EOP
01011 
01012    !--- formats ---
01013    character(*),parameter :: subName = '(shr_file_getLogLevel) '
01014    character(*),parameter :: F00   = "('(shr_file_getLogLevel) ',4a)"
01015 
01016 !-------------------------------------------------------------------------------
01017 ! Notes: 
01018 !-------------------------------------------------------------------------------
01019 
01020    curlevel = s_loglev
01021  
01022 END SUBROUTINE shr_file_getLogLevel
01023 
01024 !===============================================================================
01025 !===============================================================================
01026 
01027 END MODULE shr_file_mod