!----- AGPL --------------------------------------------------------------------
!
! Copyright (C) Stichting Deltares, 2015.
!
! This file is part of Delft3D (D-Flow Flexible Mesh component).
!
! Delft3D is free software: you can redistribute it and/or modify
! it under the terms of the GNU Affero General Public License as
! published by the Free Software Foundation version 3.
!
! Delft3D is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU Affero General Public License for more details.
!
! You should have received a copy of the GNU Affero General Public License
! along with Delft3D. If not, see .
!
! contact: delft3d.support@deltares.nl
! Stichting Deltares
! P.O. Box 177
! 2600 MH Delft, The Netherlands
!
! All indications and logos of, and references to, "Delft3D",
! "D-Flow Flexible Mesh" and "Deltares" are registered trademarks of Stichting
! Deltares, and remain the property of Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
! $Id: xbeach_filefunctions.F90 43271 2015-11-26 14:17:50Z kleczek $
! $HeadURL: https://repos.deltares.nl/repos/ds/trunk/additional/unstruc/src/xbeach_filefunctions.F90 $
module m_xbeach_filefunctions
!! Contains logging functions and file administration functions
!! Merge of logging_module and filefunctions_module
use m_xbeach_typesandkinds
implicit none
integer,save :: logfileid
integer,save :: errorfileid
integer,save :: warningfileid
interface check_file_length
module procedure check_file_length_1D
module procedure check_file_length_2D
module procedure check_file_length_3D
end interface check_file_length
procedure(distributeloginterface), pointer :: distributelog => null()
abstract interface
subroutine distributeloginterface(code,message,len)
implicit none
integer, intent(in) :: code
integer, intent(in) :: len
character(*),intent(in) :: message
end subroutine distributeloginterface
end interface
!
! Options for destiantion in writelog
! 's' = screen
! 'l' = log file
! 'e' = error file
! 'w' = warning file
!
! Combinations also allowed, f.i.
! 'le' = log file and error file
! 'el' ditto
! 'sel' = screen, log file and error file
!
interface writelog
module procedure writelog_a
module procedure writelog_aa
module procedure writelog_ai
module procedure writelog_ia
module procedure writelog_aaa
module procedure writelog_aaaa
module procedure writelog_aai
module procedure writelog_aii
module procedure writelog_aaai
module procedure writelog_aaia
module procedure writelog_aia
module procedure writelog_aiaa
module procedure writelog_aiaaa
module procedure writelog_aiai
module procedure writelog_aiaia
module procedure writelog_aaiai
module procedure writelog_aaaiai
module procedure writelog_aiafa
module procedure writelog_aiafaf
module procedure writelog_aiaiai
module procedure writelog_aiaiaia
module procedure writelog_aiaiaf
module procedure writelog_aiaiafa
module procedure writelog_iiiii
module procedure writelog_af
module procedure writelog_aaf
module procedure writelog_afa
module procedure writelog_afaf
module procedure writelog_afafa
module procedure writelog_aaaf
module procedure writelog_aafa
module procedure writelog_afaaa
module procedure writelog_aafaf
module procedure writelog_aaafaf
module procedure writelog_afafafaf
module procedure writelog_illll
module procedure writelog_fa
module procedure writelog_afaiaaa
end interface writelog
contains
subroutine start_logfiles(error)
use m_xbeach_errorhandling
use m_partitioninfo
implicit none
integer :: error
logfileid = generate_logfileid()
if ( jampi.eq.0 ) then
open(logfileid, file='XBlog.txt', status='replace')
errorfileid = generate_logfileid()
open(errorfileid, file='XBerror.txt', status='replace')
warningfileid = generate_logfileid()
open(warningfileid, file='XBwarning.txt', status='replace')
else
open(logfileid, file='XBlog'//'_'//sdmn//'.txt', status='replace')
errorfileid = generate_logfileid()
open(errorfileid, file='XBerror'//'_'//sdmn//'.txt', status='replace')
warningfileid = generate_logfileid()
open(warningfileid, file='XBwarning'//'_'//sdmn//'.txt', status='replace')
end if
if (logfileid < 0 .or. errorfileid < 0 .or. warningfileid < 0) error = 1
if (error==1) then
write(*,*) 'Error: not able to open log file. Stopping simulation'
call xbeach_errorhandler
endif
end subroutine start_logfiles
subroutine close_logfiles
close(logfileid )
close(errorfileid, STATUS='DELETE' )
close(warningfileid )
end subroutine close_logfiles
subroutine get_logfileid(lid,eid,wid)
implicit none
integer, intent(out) :: lid,eid,wid
lid = logfileid
eid = errorfileid
wid = warningfileid
endsubroutine get_logfileid
function generate_logfileid() result (tryunit)
implicit none
integer :: tryunit,error
logical :: fileopen
tryunit = 98
fileopen = .true.
error = 0
do while (fileopen)
inquire(tryunit,OPENED=fileopen)
if (fileopen) then
tryunit=tryunit-1
endif
if (tryunit<=10) then
tryunit = -1
fileopen = .false.
return
endif
enddo
end function generate_logfileid
subroutine progress_indicator(initialize,curper,dper,dt)
implicit none
logical,intent(in) :: initialize ! initialize current progress indicator
real*8,intent(in) :: curper ! current percentage done
real*8,intent(in) :: dper ! steps in percentage between output
real*8,intent(in) :: dt ! steps in time (s) between output
! whichever reached earlier (dper,dt) will determin output
! internal
real*8,save :: lastper,lastt
real*8 :: tnow
integer*4 :: count,count_rate,count_max
if (initialize) then
lastper = 0.d0
call system_clock (count,count_rate,count_max)
lastt = dble(count)/count_rate
else
call system_clock (count,count_rate,count_max)
tnow = dble(count)/count_rate
if (curper>=lastper+dper .or. tnow>=lastt+dt) then
call writelog('ls','(f0.1,a)',curper,'% done')
if (curper>=lastper+dper) then
lastper = curper-mod(curper,dper)
else
lastper = curper
endif
lastt = tnow
endif
endif
end subroutine progress_indicator
subroutine report_file_read_error(filename)
use m_xbeach_errorhandling
implicit none
character(*) :: filename
call writelog('lswe','','Error reading file ''',trim(filename),'''')
call writelog('lswe','','Check file for incorrect decimal format, line breaks and tab characters')
call xbeach_errorhandler
end subroutine report_file_read_error
subroutine writelog_startup()
implicit none
character(len=8) :: date
character(len=10) :: time
character(len=5) :: zone
! get current working directory (gcc only)
#ifdef HAVE_CONFIG_H
#include "config.h"
character(slen) :: cwd
call getcwd(cwd)
#endif
call date_and_time(DATE=date, TIME=time, ZONE=zone)
call writelog('ls','','**********************************************************')
call writelog('ls','',' Welcome to XBeach - DFLOW FM version ')
call writelog('ls','',' ')
call writelog('ls','','**********************************************************')
call writelog('ls','',' ')
call writelog('ls','','Simulation started: YYYYMMDD hh:mm:ss time zone (UTC)')
call writelog('ls','',' '//date //' '//time(1:2)//':'//time(3:4)//':'//time(5:6)//' '//zone)
call writelog('ls','',' ')
#ifdef HAVE_CONFIG_H
call writelog('ls','',' running in: ',cwd)
#endif
call writelog('ls','','General Input Module')
end subroutine writelog_startup
subroutine writelog_finalize(tbegin, n, t, nx, ny, t0, t01)
implicit none
integer :: n,nx,ny
real*8 :: tbegin,tend
real*8 :: t,duration,dt,performance
real*8, optional :: t0,t01
call cpu_time(tend)
duration = tend-tbegin
dt = t/n
performance = duration/(nx+1)/(ny+1)/n
call writelog('ls','','Duration : ',duration,' seconds' )
call writelog('ls','','Timesteps : ',n )
call writelog('ls','','Average dt : ',dt,' seconds' )
call writelog('ls','','Unit speed : ',performance,' seconds/1' )
call writelog('ls','','End of program xbeach')
call close_logfiles
end subroutine writelog_finalize
subroutine writelog_distribute(destination,display)
implicit none
character(*) :: destination
character(slen) :: display
integer :: level
level = -1
if (scan(destination,'s')>0) then
level = 3
end if
if (scan(destination,'l')>0) then
level = 2
write(6,*) trim(display)
write(logfileid,*) trim(display)
end if
if (scan(destination,'w')>0) then
level = 1
write(0,*) trim(display)
write(warningfileid,*) trim(display)
end if
if (scan(destination,'e')>0) then
level = 0
write(0,*) trim(display)
write(errorfileid,*) trim(display)
end if
if (associated(distributelog)) then
call distributelog(level,trim(display), len(trim(display)))
endif
end subroutine writelog_distribute
subroutine writelog_a(destination,form,message_char)
implicit none
character(*),intent(in) :: form,message_char
character(*),intent(in) :: destination
character(slen) :: display
if (form=='') then
write(display,*)trim(message_char)
else
write(display,form)trim(message_char)
endif
call writelog_distribute(destination, display)
end subroutine writelog_a
subroutine writelog_aa(destination,form,message_char1,message_char2)
implicit none
character(*),intent(in) :: form,message_char1,message_char2
character(*),intent(in) :: destination
character(slen) :: display
if (form=='') then
write(display,*) message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
trim(message_char2)
else
write(display,form) message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
trim(message_char2)
endif
call writelog_distribute(destination, display)
end subroutine writelog_aa
subroutine writelog_ai(destination,form,message_char,message_int)
implicit none
character(*),intent(in) :: form,message_char
character(*),intent(in) :: destination
integer,intent(in) :: message_int
character(slen) :: display
if (form=='') then
write(display,*)message_char(1:min(len(message_char),len_trim(message_char)+1)), &
message_int
else
write(display,form)message_char(1:min(len(message_char),len_trim(message_char)+1)), &
message_int
endif
call writelog_distribute(destination, display)
end subroutine writelog_ai
subroutine writelog_ia(destination,form,mint1,mchar1)
implicit none
character(*),intent(in) :: form,mchar1
character(*),intent(in) :: destination
integer,intent(in) :: mint1
character(slen) :: display
if (form=='') then
write(display,*)mint1,trim(mchar1)
else
write(display,form)mint1,trim(mchar1)
endif
call writelog_distribute(destination, display)
end subroutine writelog_ia
subroutine writelog_aaa(destination,form,message_char1,message_char2,message_char3)
implicit none
character(*),intent(in) :: form,message_char1,message_char2,message_char3
character(*),intent(in) :: destination
character(slen) :: display
if (form=='') then
write(display,*)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
trim(message_char3)
else
write(display,form)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
trim(message_char3)
endif
call writelog_distribute(destination, display)
end subroutine writelog_aaa
subroutine writelog_aaaa(destination,form,message_char1,message_char2,message_char3,message_char4)
implicit none
character(*),intent(in) :: form,message_char1,message_char2,message_char3,message_char4
character(*),intent(in) :: destination
character(slen) :: display
if (form=='') then
write(display,*)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_char3(1:min(len(message_char3),len_trim(message_char3)+1)), &
trim(message_char4)
else
write(display,form)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_char3(1:min(len(message_char3),len_trim(message_char3)+1)), &
trim(message_char4)
endif
call writelog_distribute(destination, display)
end subroutine writelog_aaaa
subroutine writelog_aai(destination,form,message_char1,message_char2,message_int)
implicit none
character(*),intent(in) :: form,message_char1,message_char2
character(*),intent(in) :: destination
integer,intent(in) :: message_int
character(slen) :: display
if (form=='') then
write(display,*)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_int
else
write(display,form)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_int
endif
call writelog_distribute(destination, display)
end subroutine writelog_aai
subroutine writelog_aii(destination,form,message_char1,message_int1,message_int2)
implicit none
character(*),intent(in) :: form,message_char1
character(*),intent(in) :: destination
integer,intent(in) :: message_int1,message_int2
character(slen) :: display
if (form=='') then
write(display,*)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_int1,message_int2
else
write(display,form)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_int1,message_int2
endif
call writelog_distribute(destination, display)
end subroutine writelog_aii
subroutine writelog_aia(destination,form,message_char1b,message_intb,message_char2b)
implicit none
character(*),intent(in) :: form,message_char1b,message_char2b
character(*),intent(in) :: destination
integer,intent(in) :: message_intb
character(slen) :: display
if (form=='') then
write(display,*)message_char1b(1:min(len(message_char1b),len_trim(message_char1b)+1)), &
message_intb,trim(message_char2b)
else
write(display,form)message_char1b(1:min(len(message_char1b),len_trim(message_char1b)+1)), &
message_intb,trim(message_char2b)
endif
call writelog_distribute(destination, display)
end subroutine writelog_aia
subroutine writelog_aaai(destination,form,message_char1,message_char2,message_char3,message_int)
implicit none
character(*),intent(in) :: form,message_char1,message_char2,message_char3
character(*),intent(in) :: destination
integer,intent(in) :: message_int
character(slen) :: display
if (form=='') then
write(display,*)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_char3(1:min(len(message_char3),len_trim(message_char3)+1)), &
message_int
else
write(display,form)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_char3(1:min(len(message_char3),len_trim(message_char3)+1)), &
message_int
endif
call writelog_distribute(destination, display)
end subroutine writelog_aaai
subroutine writelog_aaia(destination,formb,message_char1b,message_char2b,message_int,message_char3b)
implicit none
character(*),intent(in) :: formb,message_char1b,message_char2b,message_char3b
character(*),intent(in) :: destination
integer,intent(in) :: message_int
character(slen) :: display
if (formb=='') then
write(display,*)message_char1b(1:min(len(message_char1b),len_trim(message_char1b)+1)), &
message_char2b(1:min(len(message_char2b),len_trim(message_char2b)+1)), &
message_int,trim(message_char3b)
else
write(display,formb)message_char1b(1:min(len(message_char1b),len_trim(message_char1b)+1)), &
message_char2b(1:min(len(message_char2b),len_trim(message_char2b)+1)), &
message_int,trim(message_char3b)
endif
call writelog_distribute(destination, display)
end subroutine writelog_aaia
subroutine writelog_aiaa(destination,form,message_char1b,message_intb,message_char2b,message_char3b)
implicit none
character(*),intent(in) :: form,message_char1b,message_char2b,message_char3b
character(*),intent(in) :: destination
integer,intent(in) :: message_intb
character(slen) :: display
if (form=='') then
write(display,*)message_char1b(1:min(len(message_char1b),len_trim(message_char1b)+1)), &
message_intb, &
message_char2b(1:min(len(message_char2b),len_trim(message_char2b)+1)), &
trim(message_char3b)
else
write(display,form)message_char1b(1:min(len(message_char1b),len_trim(message_char1b)+1)), &
message_intb, &
message_char2b(1:min(len(message_char2b),len_trim(message_char2b)+1)), &
trim(message_char3b)
endif
call writelog_distribute(destination, display)
end subroutine writelog_aiaa
subroutine writelog_aiaaa(destination,form,message_char1b,message_intb,message_char2b,message_char3b,message_char4b)
implicit none
character(*),intent(in) :: form,message_char1b,message_char2b,message_char3b,message_char4b
character(*),intent(in) :: destination
integer,intent(in) :: message_intb
character(slen) :: display
if (form=='') then
write(display,*)message_char1b(1:min(len(message_char1b),len_trim(message_char1b)+1)), &
message_intb, &
message_char2b(1:min(len(message_char2b),len_trim(message_char2b)+1)), &
message_char3b(1:min(len(message_char3b),len_trim(message_char3b)+1)), &
trim(message_char4b)
else
write(display,form)message_char1b(1:min(len(message_char1b),len_trim(message_char1b)+1)), &
message_intb, &
message_char2b(1:min(len(message_char2b),len_trim(message_char2b)+1)), &
message_char3b(1:min(len(message_char3b),len_trim(message_char3b)+1)), &
trim(message_char4b)
endif
call writelog_distribute(destination, display)
end subroutine writelog_aiaaa
subroutine writelog_aiai(destination,form,message_char1,message_int1,message_char2,message_int2)
implicit none
character(*),intent(in) :: form,message_char1,message_char2
character(*),intent(in) :: destination
integer,intent(in) :: message_int1,message_int2
character(slen) :: display
if (form=='') then
write(display,*)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_int1, &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_int2
else
write(display,form)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_int1, &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_int2
endif
call writelog_distribute(destination, display)
end subroutine writelog_aiai
subroutine writelog_aiaia(destination,form,mc1,mi1,mc2,mi2,mc3)
implicit none
character(*),intent(in) :: form,mc1,mc2,mc3
character(*),intent(in) :: destination
integer,intent(in) :: mi1,mi2
character(slen) :: display
if (form=='') then
write(display,*)mc1(1:min(len(mc1),len_trim(mc1)+1)), &
mi1, &
mc2(1:min(len(mc2),len_trim(mc2)+1)), &
mi2, &
trim(mc3)
else
write(display,form)mc1(1:min(len(mc1),len_trim(mc1)+1)), &
mi1, &
mc2(1:min(len(mc2),len_trim(mc2)+1)), &
mi2, &
trim(mc3)
endif
call writelog_distribute(destination, display)
end subroutine writelog_aiaia
subroutine writelog_aaiai(destination,form,message_char1,message_char2,message_i1,message_char3,message_i2)
implicit none
character(*),intent(in) :: form,message_char1,message_char2,message_char3
character(*),intent(in) :: destination
integer*4,intent(in) :: message_i1,message_i2
character(slen) :: display
if (form=='') then
write(display,*)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_i1, &
message_char3(1:min(len(message_char3),len_trim(message_char3)+1)), &
message_i2
else
write(display,form)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_i1, &
message_char3(1:min(len(message_char3),len_trim(message_char3)+1)), &
message_i2
endif
call writelog_distribute(destination, display)
end subroutine writelog_aaiai
subroutine writelog_aaaiai(destination,form,message_char1,message_char2,message_char3,message_i1,message_char4,message_i2)
implicit none
character(*),intent(in) :: form,message_char1,message_char2,message_char3,message_char4
character(*),intent(in) :: destination
integer*4,intent(in) :: message_i1,message_i2
character(slen) :: display
if (form=='') then
write(display,*)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_char3(1:min(len(message_char3),len_trim(message_char3)+1)), &
message_i1, &
message_char4(1:min(len(message_char4),len_trim(message_char4)+1)), &
message_i2
else
write(display,form)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_char3(1:min(len(message_char3),len_trim(message_char3)+1)), &
message_i1, &
message_char4(1:min(len(message_char4),len_trim(message_char4)+1)), &
message_i2
endif
call writelog_distribute(destination, display)
end subroutine writelog_aaaiai
subroutine writelog_aiafa(destination,form,mc1,mi1,mc2,mf1,mc3)
implicit none
character(*),intent(in) :: form,mc1,mc2,mc3
character(*),intent(in) :: destination
integer*4,intent(in) :: mi1
real*8,intent(in) :: mf1
character(slen) :: display
if (form=='') then
write(display,*)mc1(1:min(len(mc1),len_trim(mc1)+1)), &
mi1, &
mc2(1:min(len(mc2),len_trim(mc2)+1)), &
mf1,trim(mc3)
else
write(display,form)mc1(1:min(len(mc1),len_trim(mc1)+1)), &
mi1, &
mc2(1:min(len(mc2),len_trim(mc2)+1)), &
mf1,trim(mc3)
endif
call writelog_distribute(destination, display)
end subroutine writelog_aiafa
subroutine writelog_aiafaf(destination,form,mc1,mi1,mc2,mf1,mc3,mf2)
implicit none
character(*),intent(in) :: form,mc1,mc2,mc3
character(*),intent(in) :: destination
integer*4,intent(in) :: mi1
real*8,intent(in) :: mf1,mf2
character(slen) :: display
if (form=='') then
write(display,*)mc1(1:min(len(mc1),len_trim(mc1)+1)), &
mi1, &
mc2(1:min(len(mc2),len_trim(mc2)+1)), &
mf1, &
mc3(1:min(len(mc3),len_trim(mc3)+1)), &
mf2
else
write(display,form)mc1(1:min(len(mc1),len_trim(mc1)+1)), &
mi1, &
mc2(1:min(len(mc2),len_trim(mc2)+1)), &
mf1, &
mc3(1:min(len(mc3),len_trim(mc3)+1)), &
mf2
endif
call writelog_distribute(destination, display)
end subroutine writelog_aiafaf
subroutine writelog_aiaiai(destination,form,message_char1,message_i1,message_char2,message_i2,message_char3,message_i3)
implicit none
character(*),intent(in) :: form,message_char1,message_char2,message_char3
character(*),intent(in) :: destination
integer*4,intent(in) :: message_i1,message_i2,message_i3
character(slen) :: display
if (form=='') then
write(display,*)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_i1, &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_i2, &
message_char3(1:min(len(message_char3),len_trim(message_char3)+1)), &
message_i3
else
write(display,form)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_i1, &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_i2, &
message_char3(1:min(len(message_char3),len_trim(message_char3)+1)), &
message_i3
endif
call writelog_distribute(destination, display)
end subroutine writelog_aiaiai
subroutine writelog_aiaiaia(destination,form,mc1,message_i1,mc2,message_i2,mc3,message_i3, &
mc4)
implicit none
character(*),intent(in) :: form,mc1,mc2,mc3,mc4
character(*),intent(in) :: destination
integer*4,intent(in) :: message_i1,message_i2,message_i3
character(slen) :: display
if (form=='') then
write(display,*)mc1(1:min(len(mc1),len_trim(mc1)+1)), &
message_i1, &
mc2(1:min(len(mc2),len_trim(mc2)+1)), &
message_i2, &
mc3(1:min(len(mc3),len_trim(mc3)+1)), &
message_i3,trim(mc4)
else
write(display,form)mc1(1:min(len(mc1),len_trim(mc1)+1)), &
message_i1, &
mc2(1:min(len(mc2),len_trim(mc2)+1)), &
message_i2, &
mc3(1:min(len(mc3),len_trim(mc3)+1)), &
message_i3,trim(mc4)
endif
call writelog_distribute(destination, display)
end subroutine writelog_aiaiaia
subroutine writelog_aiaiaf(destination,form,mc1,mi1,mc2,mi2,mc3,mf1)
implicit none
character(*),intent(in) :: form,mc1,mc2,mc3
character(*),intent(in) :: destination
integer*4,intent(in) :: mi1,mi2
real*8,intent(in) :: mf1
character(slen) :: display
if (form=='') then
write(display,*)mc1(1:min(len(mc1),len_trim(mc1)+1)), &
mi1, &
mc2(1:min(len(mc2),len_trim(mc2)+1)), &
mi2, &
mc3(1:min(len(mc3),len_trim(mc3)+1)), &
mf1
else
write(display,form)mc1(1:min(len(mc1),len_trim(mc1)+1)), &
mi1, &
mc2(1:min(len(mc2),len_trim(mc2)+1)), &
mi2, &
mc3(1:min(len(mc3),len_trim(mc3)+1)), &
mf1
endif
call writelog_distribute(destination, display)
end subroutine writelog_aiaiaf
subroutine writelog_aiaiafa(destination,form,mc1,mi1,mc2,mi2,mc3,mf1,mc4)
implicit none
character(*),intent(in) :: form,mc1,mc2,mc3,mc4
character(*),intent(in) :: destination
integer*4,intent(in) :: mi1,mi2
real*8,intent(in) :: mf1
character(slen) :: display
if (form=='') then
write(display,*)mc1(1:min(len(mc1),len_trim(mc1)+1)), &
mi1, &
mc2(1:min(len(mc2),len_trim(mc2)+1)), &
mi2, &
mc3(1:min(len(mc3),len_trim(mc3)+1)), &
mf1,trim(mc4)
else
write(display,form)mc1(1:min(len(mc1),len_trim(mc1)+1)), &
mi1, &
mc2(1:min(len(mc2),len_trim(mc2)+1)), &
mi2, &
mc3(1:min(len(mc3),len_trim(mc3)+1)), &
mf1,trim(mc4)
endif
call writelog_distribute(destination, display)
end subroutine writelog_aiaiafa
subroutine writelog_iiiii(destination,form,mi1,mi2,mi3,mi4,mi5)
implicit none
character(*),intent(in) :: form
character(*),intent(in) :: destination
integer*4,intent(in) :: mi1,mi2,mi3,mi4,mi5
character(slen) :: display
if (form=='') then
write(display,*)mi1,mi2,mi3,mi4,mi5
else
write(display,form)mi1,mi2,mi3,mi4,mi5
endif
call writelog_distribute(destination, display)
end subroutine writelog_iiiii
subroutine writelog_af(destination,form,message_char1,message_f1)
implicit none
character(*),intent(in) :: form, message_char1
character(*),intent(in) :: destination
real*8,intent(in) :: message_f1
character(slen) :: display
if (form=='') then
write(display,*)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_f1
else
write(display,form)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_f1
endif
call writelog_distribute(destination, display)
end subroutine writelog_af
subroutine writelog_aaf(destination,form,message_char1,message_char2,message_f1)
implicit none
character(*),intent(in) :: form,message_char1,message_char2
character(*),intent(in) :: destination
real*8,intent(in) :: message_f1
character(slen) :: display
if (form=='') then
write(display,*)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_f1
else
write(display,form)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_f1
endif
call writelog_distribute(destination, display)
end subroutine writelog_aaf
subroutine writelog_afa(destination,form,mc1,mf1,mc2)
implicit none
character(*),intent(in) :: form,mc1,mc2
character(*),intent(in) :: destination
real*8,intent(in) :: mf1
character(slen) :: display
if (form=='') then
write(display,*)mc1(1:min(len(mc1),len_trim(mc1)+1)), &
mf1,trim(mc2)
else
write(display,form)mc1(1:min(len(mc1),len_trim(mc1)+1)), &
mf1,trim(mc2)
endif
call writelog_distribute(destination, display)
end subroutine writelog_afa
subroutine writelog_afaf(destination,form,message_char1,message_f1,message_char2,message_f2)
implicit none
character(*),intent(in) :: form,message_char1,message_char2
character(*),intent(in) :: destination
real*8,intent(in) :: message_f1,message_f2
character(slen) :: display
if (form=='') then
write(display,*)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_f1, &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_f2
else
write(display,form)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_f1, &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_f2
endif
call writelog_distribute(destination, display)
end subroutine writelog_afaf
subroutine writelog_afafa(destination,form,mc1,mf1,mc2,mf2,mc3)
implicit none
character(*),intent(in) :: form,mc1,mc2,mc3
character(*),intent(in) :: destination
real*8,intent(in) :: mf1,mf2
character(slen) :: display
if (form=='') then
write(display,*)mc1(1:min(len(mc1),len_trim(mc1)+1)), &
mf1, &
mc2(1:min(len(mc2),len_trim(mc2)+1)), &
mf2,trim(mc3)
else
write(display,form)mc1(1:min(len(mc1),len_trim(mc1)+1)), &
mf1, &
mc2(1:min(len(mc2),len_trim(mc2)+1)), &
mf2,trim(mc3)
endif
call writelog_distribute(destination, display)
end subroutine writelog_afafa
subroutine writelog_aaaf(destination,form,message_char1,message_char2,message_char3,message_f1)
implicit none
character(*),intent(in) :: form,message_char1,message_char2,message_char3
character(*),intent(in) :: destination
real*8,intent(in) :: message_f1
character(slen) :: display
if (form=='') then
write(display,*)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_char3(1:min(len(message_char3),len_trim(message_char3)+1)), &
message_f1
else
write(display,form)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_char3(1:min(len(message_char3),len_trim(message_char3)+1)), &
message_f1
endif
call writelog_distribute(destination, display)
end subroutine writelog_aaaf
subroutine writelog_aafa(destination,form,message_char1b,message_char2b,message_f1b,message_char3b)
implicit none
character(*),intent(in) :: form,message_char1b,message_char2b,message_char3b
character(*),intent(in) :: destination
real*8,intent(in) :: message_f1b
character(slen) :: display
if (form=='') then
write(display,*)message_char1b(1:min(len(message_char1b),len_trim(message_char1b)+1)), &
message_char2b(1:min(len(message_char2b),len_trim(message_char2b)+1)), &
message_f1b,trim(message_char3b)
else
write(display,form)message_char1b(1:min(len(message_char1b),len_trim(message_char1b)+1)), &
message_char2b(1:min(len(message_char2b),len_trim(message_char2b)+1)), &
message_f1b,trim(message_char3b)
endif
call writelog_distribute(destination, display)
end subroutine writelog_aafa
subroutine writelog_afaaa(destination,form,mc1a,mfa,mc2a,mc3a,mc4a)
implicit none
character(*),intent(in) :: form,mc1a,mc2a,mc3a,mc4a
character(*),intent(in) :: destination
real*8,intent(in) :: mfa
character(slen) :: display
if (form=='') then
write(display,*)mc1a(1:min(len(mc1a),len_trim(mc1a)+1)), &
mfa, &
mc2a(1:min(len(mc2a),len_trim(mc2a)+1)), &
mc3a(1:min(len(mc3a),len_trim(mc3a)+1)), &
trim(mc4a)
else
write(display,form)mc1a(1:min(len(mc1a),len_trim(mc1a)+1)), &
mfa, &
mc2a(1:min(len(mc2a),len_trim(mc2a)+1)), &
mc3a(1:min(len(mc3a),len_trim(mc3a)+1)), &
trim(mc4a)
endif
call writelog_distribute(destination, display)
end subroutine writelog_afaaa
subroutine writelog_aafaf(destination,form,message_char1,message_char2,message_f1,message_char3,message_f2)
implicit none
character(*),intent(in) :: form,message_char1,message_char2,message_char3
character(*),intent(in) :: destination
real*8,intent(in) :: message_f1,message_f2
character(slen) :: display
if (form=='') then
write(display,*)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_f1, &
message_char3(1:min(len(message_char3),len_trim(message_char3)+1)), &
message_f2
else
write(display,form)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_f1, &
message_char3(1:min(len(message_char3),len_trim(message_char3)+1)), &
message_f2
endif
call writelog_distribute(destination, display)
end subroutine writelog_aafaf
subroutine writelog_aaafaf(destination,form,message_char1,message_char2,message_char3,message_f1,message_char4,message_f2)
implicit none
character(*),intent(in) :: form,message_char1,message_char2,message_char3,message_char4
character(*),intent(in) :: destination
real*8,intent(in) :: message_f1,message_f2
character(slen) :: display
if (form=='') then
write(display,*)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_char3(1:min(len(message_char3),len_trim(message_char3)+1)), &
message_f1, &
message_char4(1:min(len(message_char4),len_trim(message_char4)+1)), &
message_f2
else
write(display,form)message_char1(1:min(len(message_char1),len_trim(message_char1)+1)), &
message_char2(1:min(len(message_char2),len_trim(message_char2)+1)), &
message_char3(1:min(len(message_char3),len_trim(message_char3)+1)), &
message_f1, &
message_char4(1:min(len(message_char4),len_trim(message_char4)+1)), &
message_f2
endif
call writelog_distribute(destination, display)
end subroutine writelog_aaafaf
subroutine writelog_afafafaf(destination,form,mc1,mf1,mc2,mf2,mc3,mf3,mc4,mf4)
implicit none
character(*),intent(in) :: form,mc1,mc2,mc3,mc4
character(*),intent(in) :: destination
real*8,intent(in) :: mf1,mf2,mf3,mf4
character(slen) :: display
if (form=='') then
write(display,*)mc1(1:min(len(mc1),len_trim(mc1)+1)), &
mf1, &
mc2(1:min(len(mc2),len_trim(mc2)+1)), &
mf2, &
mc3(1:min(len(mc3),len_trim(mc3)+1)), &
mf3, &
mc4(1:min(len(mc4),len_trim(mc4)+1)), &
mf4
else
write(display,form)mc1(1:min(len(mc1),len_trim(mc1)+1)), &
mf1, &
mc2(1:min(len(mc2),len_trim(mc2)+1)), &
mf2, &
mc3(1:min(len(mc3),len_trim(mc3)+1)), &
mf3, &
mc4(1:min(len(mc4),len_trim(mc4)+1)), &
mf4
endif
call writelog_distribute(destination, display)
end subroutine writelog_afafafaf
subroutine writelog_illll(destination,form,mi1,ml1,ml2,ml3,ml4)
implicit none
character(*),intent(in) :: form
character(*),intent(in) :: destination
integer*4,intent(in) :: mi1
logical,intent(in) :: ml1,ml2,ml3,ml4
character(slen) :: display
if (form=='') then
write(display,*)mi1,ml1,ml2,ml3,ml4
else
write(display,form)mi1,ml1,ml2,ml3,ml4
endif
call writelog_distribute(destination, display)
end subroutine writelog_illll
subroutine writelog_fa(destination,form,mf1,mc1)
implicit none
character(*),intent(in) :: form, mc1
character(*),intent(in) :: destination
real*8,intent(in) :: mf1
character(slen) :: display
if (form=='') then
write(display,*)mf1,trim(mc1)
else
write(display,form)mf1,trim(mc1)
endif
call writelog_distribute(destination, display)
end subroutine writelog_fa
subroutine writelog_afaiaaa(destination,form,mc1,mf1,mc2,mi1,mc3,mc4,mc5)
implicit none
character(*),intent(in) :: form, mc1,mc2,mc3,mc4,mc5
character(*),intent(in) :: destination
real*8,intent(in) :: mf1
integer,intent(in) :: mi1
character(slen) :: display
if (form=='') then
write(display,*)mc1(1:min(len(mc1),len_trim(mc1)+1)), &
mf1, &
mc2(1:min(len(mc2),len_trim(mc2)+1)), &
mi1, &
mc3(1:min(len(mc3),len_trim(mc3)+1)), &
mc4(1:min(len(mc4),len_trim(mc4)+1)), &
trim(mc5)
else
write(display,form)mc1(1:min(len(mc1),len_trim(mc1)+1)), &
mf1, &
mc2(1:min(len(mc2),len_trim(mc2)+1)), &
mi1, &
mc3(1:min(len(mc3),len_trim(mc3)+1)), &
mc4(1:min(len(mc4),len_trim(mc4)+1)), &
trim(mc5)
endif
call writelog_distribute(destination, display)
end subroutine writelog_afaiaaa
subroutine assignlogdelegate_internal(fPtr)
use iso_c_binding
type(c_funptr), VALUE :: fPtr
integer :: i
distributelog => null()
if (c_associated(fPtr)) then
call c_f_procpointer (fPtr, distributelog )
endif
end subroutine assignlogdelegate_internal
integer function create_new_fid()
use m_xbeach_errorhandling
implicit none
integer :: fileunit
fileunit = -1 ! temporary
fileunit = create_new_fid_generic()
if (fileunit==-1) then
call writelog('les','','Serious problem: not enough free unit ids to create new file')
call xbeach_errorhandler
endif
create_new_fid = fileunit
end function create_new_fid
subroutine check_file_exist(filename,exist,forceclose)
use m_xbeach_errorhandling
implicit none
character(*) :: filename
logical,intent(out),optional :: exist
logical,intent(in), optional :: forceclose
logical :: endsim
integer :: error
if (present(forceclose)) then
endsim = forceclose
else
endsim = .true.
endif
error = 0
call check_file_exist_generic(filename,error)
if (error==1 .and. endsim) then
call writelog('sle','','File ''',trim(filename),''' not found. Terminating simulation')
call xbeach_errorhandler
endif
if (present(exist)) then
if (error==1) then
exist = .false.
else
exist = .true.
endif
endif
end subroutine check_file_exist
subroutine check_file_length_1D(fname,d1)
use m_xbeach_errorhandling
implicit none
character(*) :: fname
integer, intent(in) :: d1
integer :: fid,iost
integer :: i
real,dimension(:),allocatable :: dat
allocate(dat(d1))
fid = create_new_fid()
open(fid,file=trim(fname))
read(fid,*,iostat=iost)(dat(i),i=1,d1)
if (iost .ne. 0) then
call writelog('sle','','Error processing file ''',trim(fname),'''. File may be too short or contains invalid values.', &
' Terminating simulation' )
call xbeach_errorhandler()
endif
close(fid)
deallocate(dat)
end subroutine check_file_length_1D
subroutine check_file_length_2D(fname,d1,d2)
use m_xbeach_errorhandling
implicit none
character(*) :: fname
integer, intent(in) :: d1,d2
integer :: fid,iost
integer :: i,j
real,dimension(:,:),allocatable :: dat
allocate(dat(d1,d2))
fid = create_new_fid()
open(fid,file=trim(fname))
read(fid,*,iostat=iost)((dat(i,j),i=1,d1),j=1,d2)
if (iost .ne. 0) then
call writelog('sle','','Error processing file ''',trim(fname),'''. File may be too short or contains invalid values.', &
' Terminating simulation')
call xbeach_errorhandler()
endif
close(fid)
deallocate(dat)
end subroutine check_file_length_2D
subroutine check_file_length_3D(fname,d1,d2,d3)
use m_xbeach_errorhandling
implicit none
character(*) :: fname
integer, intent(in) :: d1,d2,d3
integer :: fid,iost
integer :: i,j,k
real,dimension(:,:,:),allocatable :: dat
allocate(dat(d1,d2,d3))
fid = create_new_fid()
open(fid,file=trim(fname))
read(fid,*,iostat=iost)(((dat(i,j,k),i=1,d1),j=1,d2),k=1,d3)
if (iost .ne. 0) then
call writelog('esl','Error processing file ''',trim(fname),'''. File may be too short or contains invalid values.', &
' Terminating simulation')
call xbeach_errorhandler()
endif
close(fid)
deallocate(dat)
end subroutine check_file_length_3D
subroutine checkbcfilelength(tstop,instat,filename,filetype,nonh)
use m_xbeach_errorhandling
IMPLICIT NONE
type fileinfo
character(slen) :: fname
integer :: nlines
end type
real*8, intent(in) :: tstop
character(slen), intent(in):: instat
character(slen) :: filename,dummy
character(slen) :: testc
character(len=1) :: ch
integer :: i,ier=0,nlines,filetype,fid,nlocs,ifid,fid2
real*8 :: t,dt,total,d1,d2,d3,d4,d5
type(fileinfo),dimension(:),allocatable :: bcfiles
logical,intent(in),optional :: nonh
logical :: lnonh
if (present(nonh)) then
lnonh=nonh
else
lnonh = .false.
endif
ier = 0
fid = create_new_fid()
open(fid,file=trim(filename))
i=0
do while (ier==0)
read(fid,'(a)',iostat=ier)ch
if (ier==0)i=i+1
enddo
nlines=i
rewind(fid)
! test for multiple locations setting
read(fid,*,iostat=ier)testc
if (ier .ne. 0) then
call report_file_read_error(filename)
endif
if (trim(testc)=='LOCLIST') then
nlocs = nlines-1
allocate(bcfiles(nlocs))
do ifid = 1,nlocs
read(fid,*,iostat=ier)d1,d2,bcfiles(ifid)%fname
if (ier .ne. 0) then
call report_file_read_error(filename)
endif
call check_file_exist(trim(bcfiles(ifid)%fname))
fid2 = create_new_fid()
open(fid2,file=trim(bcfiles(ifid)%fname))
i=0
ier = 0
do while (ier==0)
read(fid2,'(a)',iostat=ier)ch
if (ier==0)i=i+1
enddo
close(fid2)
bcfiles(ifid)%nlines=i
enddo
else
nlocs = 1
allocate(bcfiles(1))
bcfiles(1)%fname = filename
bcfiles(1)%nlines = nlines
endif
close(fid)
do ifid=1,nlocs
fid = create_new_fid()
open(fid,file=trim(bcfiles(ifid)%fname))
if (trim(instat)=='jons' .or. trim(instat)=='swan' .or. trim(instat)=='vardens') then
read(fid,*,iostat=ier)testc
if (ier .ne. 0) then
call report_file_read_error(bcfiles(ifid)%fname)
endif
if (trim(testc)=='FILELIST') then
filetype = 1
bcfiles(ifid)%nlines=bcfiles(ifid)%nlines-1
else
filetype = 0
endif
elseif (trim(instat)=='stat_table' .or. trim(instat)=='jons_table') then
filetype = 2
elseif (trim(instat)=='reuse') then
filetype = 3
endif
total=0.d0
i=0
select case (filetype)
case(0)
total=2.d0*tstop
case(1)
do while (total