|
XBeach
|
00001 00002 00003 ! Module to defer logging to a function that can be set using the set_logger function 00004 00005 module logging_module 00006 00007 use iso_c_utils 00008 use typesandkinds 00009 use typesandkinds, only: slen 00010 use xmpi_module 00011 implicit none 00012 integer,save :: logfileid 00013 integer,save :: errorfileid 00014 integer,save :: warningfileid 00015 !integer,save :: pardatfileid 00016 00017 abstract interface 00018 subroutine ilogger(level, msg) 00019 use iso_c_binding 00020 use iso_c_utils 00021 integer(c_int), value, intent(in) :: level !< severity 00022 character(c_char), intent(in) :: msg(MAXSTRINGLEN) !< c message null terminated 00023 end subroutine ilogger 00024 end interface 00025 00026 00027 procedure(ilogger), pointer :: logging_callback => null() 00028 00029 ! Levels correspond to log4net and log4j 00030 00031 integer, parameter, public :: LEVEL_ALL = 0 00032 integer, parameter, public :: LEVEL_DEBUG = 1 00033 integer, parameter, public :: LEVEL_INFO = 2 00034 integer, parameter, public :: LEVEL_WARN = 3 00035 integer, parameter, public :: LEVEL_ERROR = 4 00036 integer, parameter, public :: LEVEL_FATAL = 5 00037 integer, parameter, public :: LEVEL_OFF = 6 00038 00039 00040 include 'writeloginterface.inc' 00041 00042 contains 00043 subroutine set_logger(c_callback) bind(C, name="set_logger") 00044 !DEC$ ATTRIBUTES DLLEXPORT::set_logger 00045 00046 type(c_funptr), value :: c_callback 00047 00048 ! Set a callback that will be cauled with new messages 00049 00050 call c_f_procpointer(c_callback, logging_callback) 00051 end subroutine set_logger 00052 00053 subroutine logmsg(level, msg) 00054 integer(c_int), intent(in) :: level 00055 character(len=*), intent(in) :: msg 00056 00057 character(c_char) :: c_string(MAXSTRINGLEN) 00058 00059 00060 if (associated(logging_callback)) then 00061 c_string = string_to_char_array(msg) 00062 call logging_callback(level, c_string) 00063 end if 00064 end subroutine logmsg 00065 00066 subroutine start_logfiles(error) 00067 00068 implicit none 00069 00070 integer :: error 00071 00072 if (xmaster) then 00073 00074 logfileid = generate_logfileid() 00075 if (xmaster) open(logfileid, file='XBlog.txt', status='replace') 00076 00077 errorfileid = generate_logfileid() 00078 if (xmaster) open(errorfileid, file='XBerror.txt', status='replace') 00079 00080 warningfileid = generate_logfileid() 00081 if (xmaster) open(warningfileid, file='XBwarning.txt', status='replace') 00082 00083 if (logfileid < 0 .or. errorfileid < 0 .or. warningfileid < 0) error = 1 00084 00085 endif ! xmaster 00086 00087 if (error==1) then 00088 write(*,*) 'Error: not able to open log file. Stopping simulation' 00089 stop 00090 endif 00091 00092 end subroutine start_logfiles 00093 00094 subroutine close_logfiles 00095 00096 if (xmaster) then 00097 close(logfileid ) 00098 close(errorfileid, STATUS='DELETE' ) 00099 close(warningfileid ) 00100 endif 00101 00102 end subroutine close_logfiles 00103 00104 00105 subroutine get_logfileid(lid,eid,wid) 00106 00107 implicit none 00108 integer, intent(out) :: lid,eid,wid 00109 00110 lid = logfileid 00111 eid = errorfileid 00112 wid = warningfileid 00113 00114 endsubroutine get_logfileid 00115 00116 function generate_logfileid() result (tryunit) 00117 00118 implicit none 00119 00120 integer :: tryunit,error 00121 logical :: fileopen 00122 00123 tryunit = 98 00124 fileopen = .true. 00125 error = 0 00126 00127 do while (fileopen) 00128 inquire(tryunit,OPENED=fileopen) 00129 if (fileopen) then 00130 tryunit=tryunit-1 00131 endif 00132 if (tryunit<=10) then 00133 tryunit = -1 00134 fileopen = .false. 00135 return 00136 endif 00137 enddo 00138 00139 end function generate_logfileid 00140 00141 subroutine progress_indicator(initialize,curper,dper,dt) 00142 00143 implicit none 00144 00145 logical,intent(in) :: initialize ! initialize current progress indicator 00146 real*8,intent(in) :: curper ! current percentage done 00147 real*8,intent(in) :: dper ! steps in percentage between output 00148 real*8,intent(in) :: dt ! steps in time (s) between output 00149 ! whichever reached earlier (dper,dt) will determin output 00150 ! internal 00151 real*8,save :: lastper,lastt 00152 real*8 :: tnow 00153 integer*4 :: count,count_rate,count_max 00154 00155 00156 if (initialize) then 00157 lastper = 0.d0 00158 call system_clock (count,count_rate,count_max) 00159 lastt = dble(count)/count_rate 00160 else 00161 call system_clock (count,count_rate,count_max) 00162 tnow = dble(count)/count_rate 00163 if (curper>=lastper+dper .or. tnow>=lastt+dt) then 00164 call writelog('ls','(f0.1,a)',curper,'% done') 00165 if (curper>=lastper+dper) then 00166 lastper = curper-mod(curper,dper) 00167 else 00168 lastper = curper 00169 endif 00170 lastt = tnow 00171 endif 00172 endif 00173 00174 00175 end subroutine progress_indicator 00176 00177 subroutine report_file_read_error(filename) 00178 00179 use xmpi_module, only: halt_program 00180 implicit none 00181 00182 character(*) :: filename 00183 00184 call writelog('lswe','','Error reading file ''',trim(filename),'''') 00185 call writelog('lswe','','Check file for incorrect decimal format,', & 00186 ' doubles instead of integers, line breaks and tab characters') 00187 call halt_program 00188 end subroutine report_file_read_error 00189 00190 subroutine writelog_startup() 00191 00192 use xmpi_module 00193 use typesandkinds, only: slen 00194 implicit none 00195 00196 character(len=8) :: date 00197 character(len=10) :: time 00198 character(len=5) :: zone 00199 00200 ! subversion information 00201 include 'version.def' 00202 00203 ! get current working directory (gcc only) 00204 #ifdef HAVE_CONFIG_H 00205 #include "config.h" 00206 character(slen) :: cwd 00207 call getcwd(cwd) 00208 #endif 00209 00210 include 'version.dat' 00211 00212 call date_and_time(DATE=date, TIME=time, ZONE=zone) 00213 00214 if (xmaster) then 00215 call writelog('ls','','**********************************************************') 00216 call writelog('ls','',' Welcome to XBeach ') 00217 call writelog('ls','',' ') 00218 call writelog('ls','',' version 1.23.5526 XBeachX release') 00219 call writelog('ls','',' date ',trim(Build_Date) ) 00220 call writelog('ls','',' URL: ',trim(Build_URL) ) 00221 call writelog('ls','','**********************************************************') 00222 call writelog('ls','',' ') 00223 call writelog('ls','','Simulation started: YYYYMMDD hh:mm:ss time zone (UTC)') 00224 call writelog('ls','',' '//date //' '//time(1:2)//':'//time(3:4)//':'//time(5:6)//' '//zone) 00225 call writelog('ls','',' ') 00226 #ifdef HAVE_CONFIG_H 00227 call writelog('ls','',' running in: ',cwd) 00228 #endif 00229 call writelog('ls','','General Input Module') 00230 #ifdef USEMPI 00231 call writelog('ls','','MPI version, running on ',xmpi_size,'processes') 00232 #endif 00233 endif 00234 00235 end subroutine writelog_startup 00236 00237 00238 #ifdef USEMPI 00239 subroutine writelog_mpi(mpiboundary,error) 00240 use xmpi_module 00241 00242 implicit none 00243 00244 integer, intent(in) :: error 00245 integer, intent(in) :: mpiboundary 00246 00247 if (xmaster) then 00248 if (error==1) then 00249 call writelog('elws','','Unknown mpi division ',mpiboundary) 00250 call halt_program 00251 elseif (error==2) then 00252 call writelog('elws','','Number of domains specified does not match available number of computation cores ') 00253 call halt_program 00254 elseif (error==3) then 00255 call writelog('elws','','Number of mpi domains in M-direction is greater than nx/4') 00256 call writelog('elws','','XBeach cannot split into separate model domains.') 00257 call writelog('elws','','Reduce number of mpi-domains in M-direction.') 00258 call halt_program 00259 elseif (error==4) then 00260 call writelog('elws','','Number of mpi domains in N-direction is greater than ny/4') 00261 call writelog('elws','','XBeach cannot split into separate model domains.') 00262 call writelog('elws','','Reduce number of mpi-domains in N-direction.') 00263 call halt_program 00264 elseif (error==5) then 00265 call writelog('lws','','Number of mpi domains in M-direction is greater than nx/8') 00266 call writelog('lws','','Reduce number of mpi-domains in M-direction for efficiency.') 00267 elseif (error==6) then 00268 call writelog('lws','','Number of mpi domains in N-direction is greater than ny/8') 00269 call writelog('lws','','Reduce number of mpi-domains in M-direction for efficiency.') 00270 else 00271 call writelog('ls','','processor grid: ',xmpi_m,' X ',xmpi_n) 00272 endif 00273 endif 00274 00275 end subroutine writelog_mpi 00276 #endif 00277 00278 subroutine writelog_finalize(tbegin, n, t, nx, ny, t0, t01) 00279 00280 use xmpi_module 00281 implicit none 00282 00283 integer :: n,nx,ny 00284 real*8 :: tbegin,tend 00285 real*8 :: t,duration,dt,performance 00286 real*8, optional :: t0,t01 00287 00288 #ifdef USEMPI 00289 real*8 :: t1 00290 #endif 00291 00292 if (xmaster) then 00293 00294 call cpu_time(tend) 00295 00296 duration = tend-tbegin 00297 dt = t/n 00298 performance = duration/(nx+1)/(ny+1)/n 00299 00300 call writelog('ls','','Duration : ',duration,' seconds' ) 00301 call writelog('ls','','Timesteps : ',n ) 00302 call writelog('ls','','Average dt : ',dt,' seconds' ) 00303 call writelog('ls','','Unit speed : ',performance,' seconds/1' ) 00304 00305 #ifdef USEMPI 00306 if (present(t0) .and. present(t01)) then 00307 t1 = MPI_Wtime() 00308 call writelog('ls','','MPI timing : procs : ',xmpi_size ) 00309 call writelog('ls','',' seconds : total : ',t1-t0, ' seconds') 00310 call writelog('ls','',' loop : ',t1-t01,' seconds') 00311 endif 00312 #endif 00313 00314 call writelog('ls','','End of program xbeach') 00315 endif 00316 00317 call close_logfiles 00318 ! reset callback 00319 logging_callback => null() 00320 end subroutine writelog_finalize 00321 00322 subroutine writelog_distribute(destination,display) 00323 00324 implicit none 00325 00326 character(*), intent(in) :: destination 00327 character(*), intent(in) :: display 00328 integer :: level 00329 00330 logical :: has_logger 00331 00332 has_logger = associated(logging_callback) 00333 00334 if (xmaster) then 00335 level = 0 00336 if (scan(destination,'s')>0) then 00337 level = 1 00338 end if 00339 if (scan(destination,'l')>0) then 00340 level = 2 00341 if (.not. has_logger) then 00342 ! Don't log to screen if callback is associated 00343 write(6,*) trim(display) 00344 end if 00345 write(logfileid,*) trim(display) 00346 end if 00347 if (scan(destination,'w')>0) then 00348 level = 3 00349 write(0,*) trim(display) 00350 write(warningfileid,*) trim(display) 00351 end if 00352 if (scan(destination,'e')>0) then 00353 level = 4 00354 write(0,*) trim(display) 00355 write(errorfileid,*) trim(display) 00356 end if 00357 call logmsg(level, trim(display)) 00358 endif 00359 00360 end subroutine writelog_distribute 00361 00362 include 'writelog.inc' 00363 00364 end module logging_module 00365
1.7.6.1
