dc_iounit.f90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright (c) 2000-2026 Gtool Development Group. All rights reserved.
!-----------------------------------------------------------------------
 
module dc_iounit
  implicit none
  private
 
  public:: fileopen
 
  character(*), parameter:: version = &
    & '$Name:  $' // &
    & '$Id: dc_iounit.f90,v 1.1 2009-03-20 09:09:53 morikawa Exp $'
 
  interface fileopen
    module procedure fileopen
  end interface
 
contains
 
  subroutine fileopen( &
    & unit, file, mode, &
    & err )
    use dc_types, only: string, token
    use dc_trace, only: beginsub, endsub
    use dc_error, only: storeerror, dc_noerr, &
      & dc_efilenameempty, dc_ebadfileopmode, dc_enounitnum, &
      & dc_enofileexist, dc_enofileread, dc_enofilewrite
    use dc_present, only: present_and_not_empty
    use dc_string, only: tochar, tolower
    implicit none
    integer, intent(out):: unit
    character(*), intent(in):: file
    character(*), intent(in), optional:: mode
    logical, intent(out), optional:: err
 
    !-----------------------------------
    !  作業変数
    !  Work variables
    integer, parameter:: max_unit = 99
                              ! NAMELIST ファイルをオープンするための
                              ! 装置番号の最大値. Fortran で使用可能な
                              ! 範囲 (0〜99) のうち, 
                              ! 最大値が設定されている.
                              ! 
                              ! Maximum unit number for open of
                              ! NAMELIST file. An maximum
                              ! value within the bounds of available number
                              ! in Fortran (0 - 99) is specified.
    integer, parameter:: min_unit = 0
                              ! NAMELIST ファイルをオープンするための
                              ! 装置番号の最小値. Fortran で使用可能な
                              ! 範囲 (0〜99) のうち, 
                              ! 最小値が設定されている.
                              ! 
                              ! Minimum unit number for open of
                              ! NAMELIST file. An minimum
                              ! value within the bounds of available number
                              ! in Fortran (0 - 99) is specified.
    character(TOKEN):: open_mode
    integer:: unit_work
    logical:: unit_exist_flag, unit_opend_flag
    logical:: file_exist_flag
    integer:: iostat
    integer:: stat
    character(STRING):: cause_c
    character(*), parameter:: subname = 'FileOpen'
  continue
    call beginsub(subname, version)
    stat = dc_noerr
    cause_c = ''
    unit = -1
 
    !-----------------------------------------------------------------
    !  オプショナル引数のチェック
    !  Check optional arguments
    !-----------------------------------------------------------------
    if (present_and_not_empty(mode)) then
      open_mode = mode
    else
      open_mode = 'r'
    end if
    call tolower(open_mode)
 
    !-----------------------------------------------------------------
    !  引数の正当性のチェック
    !  Validation of arguments
    !-----------------------------------------------------------------
    if ( trim(file) == '' ) then
      stat = dc_efilenameempty
      goto 999
    end if
 
    !----------------------------------------------------------------
    !  使用可能な装置番号の探査
    !  Search available unit number
    !----------------------------------------------------------------
    unit_work = max_unit
    do
      inquire(unit=unit_work, exist=unit_exist_flag, opened=unit_opend_flag)
      if (unit_exist_flag .and. .not. unit_opend_flag) then
        exit
      endif
      unit_work = unit_work - 1
      if (unit_work < min_unit) then
        cause_c = tochar(min_unit) // ' - ' // tochar(max_unit)
        stat = dc_enounitnum
        goto 999
      end if
    enddo
 
    !----------------------------------------------------------------
    !  モードの書式のチェック
    !  Check form of mode
    !----------------------------------------------------------------
    select case( trim(open_mode) )
    case ('r', 'w', 'rw', 'a', 'ra')
    case default
      cause_c = open_mode
      stat = dc_ebadfileopmode
      goto 999
    end select
 
    !----------------------------------------------------------------
    !  ファイルの存在のチェック
    !  Check existance of a file
    !----------------------------------------------------------------
    select case( trim(open_mode) )
    case ('r')
      inquire(file=file, exist=file_exist_flag)
      if (.not. file_exist_flag) then
        cause_c = file
        stat = dc_enofileexist
        goto 999
      end if
    end select
 
    !----------------------------------------------------------------
    !  ファイルの読み込み可能のチェック
    !  Check readable of a file
    !----------------------------------------------------------------
    select case( trim(open_mode) )
    case ('r')
      open(unit=unit_work, iostat=iostat, &
        & file=file, status='OLD', action='READ')
      if (.not. iostat == 0) then
        cause_c = file
        stat = dc_enofileread
        goto 999
      end if
      close(unit=unit_work)
    end select
 
    !----------------------------------------------------------------
    !  ファイルの書き込み可能のチェック
    !  Check writable of a file
    !----------------------------------------------------------------
    select case( trim(open_mode) )
    case ('w', 'a', 'rw', 'ra')
      open(unit=unit_work, iostat=iostat, &
        & file=file, status='UNKNOWN', action='WRITE')
      if (.not. iostat == 0) then
        cause_c = file
        stat = dc_enofilewrite
        goto 999
      end if
      close(unit=unit_work)
    end select
 
    !----------------------------------------------------------------
    !  ファイルオープン
    !  Open a file
    !----------------------------------------------------------------
    select case( trim(open_mode) )
    case ('r')
      open(unit=unit_work, file=file, &
        & status='OLD', action='READ')
 
    case ('w')
      open(unit=unit_work, file=file, &
        & status='REPLACE', action='WRITE')
 
    case ('rw')
      open(unit=unit_work, file=file, &
        & status='REPLACE', action='READWRITE')
 
    case ('a')
      open(unit=unit_work, file=file, &
        & status='UNKNOWN', position='APPEND', action='WRITE')
 
    case ('ra')
      open(unit=unit_work, file=file, &
        & status='UNKNOWN', position='APPEND', action='READWRITE')
 
    end select
 
    unit = unit_work
 
999 continue
    call storeerror(stat, subname, err, cause_c)
    call endsub(subname)
  end subroutine fileopen
 
end module dc_iounit