!################################################################# ! ! User_Output_Common - common settings and tools for user output ! !### macro's ##################################################### ! #define TRACEBACK write (gol,'("in ",a," (",a,", line",i5,")")') rname, __FILE__, __LINE__; call goErr #define IF_NOTOK_RETURN(action) if (status/=0) then; TRACEBACK; action; return; end if #define IF_ERROR_RETURN(action) if (status> 0) then; TRACEBACK; action; return; end if ! #include "tm5.inc" ! !################################################################# module User_Output_Common use GO, only : gol, goErr, goPr implicit none ! --- in/out ----------------------------------- private public :: User_Output_Common_Init public :: User_Output_Common_Done public :: User_Output_Check_Overwrite ! --- const ------------------------------------ ! module name: character(len=*), parameter :: mname = 'User_Output_Common' ! --- local ------------------------------------ ! allow existing files to be overwritten ? logical :: output_overwrite contains ! ==================================================================== subroutine User_Output_Common_Init( status ) use GO, only : TrcFile, Init, Done, ReadRc use global_data, only : rcfile ! --- in/out -------------------------------- integer, intent(out) :: status ! --- const ------------------------------- character(len=*), parameter :: rname = mname//'/User_Output_Common_Init' ! --- local --------------------------------- type(TrcFile) :: rcF ! --- begin --------------------------------- ! open settings: call Init( rcF, rcfile, status ) IF_NOTOK_RETURN(status=1) ! read flag that allows overwriting existing files: call ReadRc( rcF, 'output.overwrite', output_overwrite, status ) IF_NOTOK_RETURN(status=1) ! close rcfile: call Done( rcF, status ) IF_NOTOK_RETURN(status=1) ! ok status = 0 end subroutine User_Output_Common_Init ! *** subroutine User_Output_Common_Done( status ) ! --- in/out -------------------------------- integer, intent(out) :: status ! --- const ------------------------------- character(len=*), parameter :: rname = mname//'/User_Output_Common_Done' ! --- begin --------------------------------- ! ok status = 0 end subroutine User_Output_Common_Done ! *** ! check if file with provided filename already exists; ! if it exists, and output_overwrite flag is .false., ! then return with error status 1; ! otherwise error status 0 subroutine User_Output_Check_Overwrite( filename, status ) ! --- in/out -------------------------------- character(len=*), intent(in) :: filename integer, intent(out) :: status ! --- const ------------------------------- character(len=*), parameter :: rname = mname//'/User_Output_Check_Overwrite' ! --- local --------------------------------- logical :: exist ! --- begin --------------------------------- ! overwriteing existing files not allowed ? if ( .not. output_overwrite ) then ! check presence: inquire( file=trim(filename), exist=exist ) ! and ? if ( exist ) then ! info ... write (gol,'("output file already present :")'); call goErr write (gol,'(" ",a)') trim(filename); call goErr write (gol,'("remove the file, or set in the rcfile the flag")'); call goErr write (gol,'("`output.overwrite` to `T` to overwrite existing files")'); call goErr TRACEBACK; status=1; return end if end if ! ok status = 0 end subroutine User_Output_Check_Overwrite end module User_Output_Common