Skip to main content
deleted 1 character in body
Source Link

If you want to share access to one or more files that are known beforehand, a possible way is to make each file into a singleton, all and to pack all of them in a module. I illustrate the principle below, after rewriting your code in modern fortran. The example incorporates many feature that should be considered for a production code. Of course, the implementation should be adapted to your real code.

If you want to share access to one or more files that are known beforehand, a possible way is to make each file into a singleton, all to pack all of them in a module. I illustrate the principle below, after rewriting your code in modern fortran. The example incorporates many feature that should be considered for a production code. Of course, the implementation should be adapted to your real code.

If you want to share access to one or more files that are known beforehand, a possible way is to make each file into a singleton and to pack all of them in a module. I illustrate the principle below, after rewriting your code in modern fortran. The example incorporates many feature that should be considered for a production code. Of course, the implementation should be adapted to your real code.

added 162 characters in body
Source Link

For an introduction to the simple syntax of modern Fortran, I suggest the following quick modern Fortran tutorial.

For an introduction to the simple syntax of modern Fortran, I suggest the following quick modern Fortran tutorial.

Source Link

If you want to share access to one or more files that are known beforehand, a possible way is to make each file into a singleton, all to pack all of them in a module. I illustrate the principle below, after rewriting your code in modern fortran. The example incorporates many feature that should be considered for a production code. Of course, the implementation should be adapted to your real code.

module mod_output
  use, intrinsic :: iso_fortran_env, only : ERROR_UNIT
  implicit none
  private

  character(len=*), parameter :: MSG_NEW = 'Neue Datei ist geoeffnet'
  character(len=*), parameter :: MSG_DEL = 'Alte Dateil ist geloest '

  integer, public , parameter :: DIR_ID  = 1
  integer, public , parameter :: FILE_ID = 2

  !.. Singleton
  type, private :: class_output
     character(len=:), allocatable :: Directory
     character(len=:), allocatable :: FileName
     integer                       :: unitID      = 0
     logical                       :: opened      =.FALSE.
   contains
     procedure, public :: set     => class_output_set
     procedure, public :: getUnit => class_output_getUnit
     procedure, public :: open    => class_output_open
     procedure, public :: isSet   => class_output_isSet
     procedure, public :: close   => class_output_close
  end type class_output
  !*** some examples:
  type(class_output), public :: output_1
  type(class_output), public :: output_2
  integer, parameter, public :: SIZE_OUTPUT_LIST=10
  type(class_output), public :: outputList(SIZE_OUTPUT_LIST)
  
contains

  subroutine class_output_set(self,fieldID,strn)
    implicit none
    class(class_output), intent(inout) :: self
    integer            , intent(in)    :: fieldID
    character(len=*)   , intent(in)    :: strn
    select case ( fieldID )
    case ( DIR_ID  )
       self%Directory = trim(adjustl(strn))
    case ( FILE_ID )
       self%FileName  = trim(adjustl(strn))
    end select
  end subroutine class_output_set
    
  logical function class_output_isSet(self) result( isSet )
    implicit none
    class(class_output), intent(in) :: self
    isSet = allocated( self%Directory ) .and. allocated( self%FileName )
  end function class_output_isSet
    
  subroutine class_output_open(self)
    implicit none
    class(class_output), intent(inout) :: self
    character(len=:), allocatable :: path, msg
    character(len=100)            :: iomsg
    logical                       :: exists
    integer                       :: uid, iostat
    if( .not. self%IsSet() )then
       write(ERROR_UNIT) " output file not set"
       error stop
    end if
    call execute_command_line("mkdir -p "//trim(self%Directory))
    path = trim(self%Directory) // trim(self%FileName)
    inquire( file = path, exist = exists )
    if(exists)then
       msg = MSG_DEL
    else
       msg = MSG_NEW
    endif
    open(newunit = uid   , &
         file    = path  , &
         action  ="write", &
         iostat  = iostat, &
         iomsg   = iomsg )
    if( iostat /= 0 )then
       write(ERROR_UNIT,"(a)") iomsg
       error stop
    endif
    write(uid,"(a,x,i0)") msg, uid
    self%unitID = uid
    self%opened = .TRUE.
  end subroutine class_output_open

  subroutine class_output_close(self)
    implicit none
    class(class_output), intent(inout) :: self
    character(len=100) :: iomsg
    integer            :: iostat
    close(self%unitID  , &
         iostat= iostat, &
         iomsg = iomsg )
    if( iostat /= 0 )then
       write(ERROR_UNIT,"(a)") iomsg
       error stop
    endif
  end subroutine class_output_close

  integer function class_output_getUnit(self) result( uid )
    implicit none
    class(class_output), intent(inout) :: self
    if(.not.self%Opened)then
       write(ERROR_UNIT,"(a)") "Attempt to access unit of closed file"
       error stop
    endif
    uid = self%unitID 
  end function class_output_getUnit

end module mod_output

Then your main program would look like this

program main
  !.. the other outputs can be initialized and used as well.
  !   If the different files have constant directory and filename
  !   they may be specified in mod_output and initialized collectively
  !   by an init routine at the beginning of the main program
  use mod_output
  implicit none
  integer, parameter :: int_vector(3) = [1,2,3] 
  call output_1%Set(  DIR_ID, "sediment/"   )
  call output_1%Set( FILE_ID, "advect1.dat" )
  call output_1%Open()
  CALL bdexch( int_vector, size(int_vector) )
  call output_1%Close()
end program main

subroutine bdexch( ivec, n )
  use mod_output, only : output_1
  implicit none
  integer, intent(in) :: ivec(n), n
  integer :: uid
  uid = output_1%getUnit()
  write(uid,"(a,*(x,i0))") 'bdexch schreibt', ivec + 10
end subroutine bdexch