module module_debug integer, parameter :: IO_NODE = 0 integer :: my_proc_id = 0 integer, parameter :: QUIET=-100, LOGFILE=-2, DEBUG=0, INFORM=1, WARN=2, ERROR=3, STDOUT=100 integer :: the_debug_level = DEBUG logical :: have_set_logname = .false. logical :: continuing_line_logfile = .false. logical :: continuing_line_debug = .false. logical :: continuing_line_inform = .false. logical :: continuing_line_warn = .false. logical :: continuing_line_error = .false. logical :: continuing_line_stdout = .false. contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: set_debug_level ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine set_debug_level(ilev) implicit none ! Arguments integer, intent(in) :: ilev the_debug_level = ilev end subroutine set_debug_level !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Name: mprintf ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine mprintf(assertion, level, fmtstring, & newline, & i1, i2, i3, i4, i5, i6, & f1, f2, f3, f4, f5, f6, & s1, s2, s3, s4, s5, s6) implicit none ! Arguments integer, intent(in) :: level logical, intent(in) :: assertion character (len=*), intent(in) :: fmtstring logical, intent(in), optional :: newline integer, intent(in), optional :: i1, i2, i3, i4, i5, i6 real, intent(in), optional :: f1, f2, f3, f4, f5, f6 character (len=*), intent(in), optional :: s1, s2, s3, s4, s5, s6 ! Local variables integer :: idxi, idxf, idxs, istart, i, iend, ia real :: fa logical :: continuing_line character (len=8) :: cur_date character (len=10) :: cur_time character (len=10) :: print_date character (len=12) :: print_time !BUG: sa should be as long as the largest string length used anywhere in WPS character (len=1024) :: sa character (len=1024) :: ctemp if (.not. have_set_logname) then write(ctemp,'(a)') 'logfile.log' call cio_set_log_filename(ctemp,len_trim(ctemp)) have_set_logname = .true. end if idxi = 1 idxf = 1 idxs = 1 istart = 1 iend = len_trim(fmtstring) if (assertion) then ! If this is a debug message give up if level is not high enough if (level == DEBUG .and. the_debug_level > DEBUG) return if (level /= STDOUT) then call date_and_time(date=cur_date,time=cur_time) end if if (level == LOGFILE .and. .not.continuing_line_logfile) then write(print_date,'(a10)') cur_date(1:4)//'-'//cur_date(5:6)//'-'//cur_date(7:8) write(print_time,'(a12)') cur_time(1:2)//':'//cur_time(3:4)//':'//cur_time(5:10) write(ctemp,'(a)') print_date//' '//print_time//' --- ' call cio_prints(1,ctemp,len(print_date//' '//print_time//' --- ')) else if (level == DEBUG .and. .not.continuing_line_debug) then write(print_date,'(a10)') cur_date(1:4)//'-'//cur_date(5:6)//'-'//cur_date(7:8) write(print_time,'(a12)') cur_time(1:2)//':'//cur_time(3:4)//':'//cur_time(5:10) write(ctemp,'(a)') print_date//' '//print_time//' --- ' call cio_prints(1,ctemp,len(print_date//' '//print_time//' --- ')) write(ctemp,'(a)') 'DEBUG: ' call cio_prints(1,ctemp,7) else if (level == INFORM .and. .not.continuing_line_inform) then write(print_date,'(a10)') cur_date(1:4)//'-'//cur_date(5:6)//'-'//cur_date(7:8) write(print_time,'(a12)') cur_time(1:2)//':'//cur_time(3:4)//':'//cur_time(5:10) write(ctemp,'(a)') print_date//' '//print_time//' --- ' call cio_prints(1,ctemp,len(print_date//' '//print_time//' --- ')) write(ctemp,'(a)') 'INFORM: ' if (level >= the_debug_level) & call cio_prints(0,ctemp,8) call cio_prints(1,ctemp,8) else if (level == WARN .and. .not.continuing_line_warn) then write(print_date,'(a10)') cur_date(1:4)//'-'//cur_date(5:6)//'-'//cur_date(7:8) write(print_time,'(a12)') cur_time(1:2)//':'//cur_time(3:4)//':'//cur_time(5:10) write(ctemp,'(a)') print_date//' '//print_time//' --- ' call cio_prints(1,ctemp,len(print_date//' '//print_time//' --- ')) write(ctemp,'(a)') 'WARNING: ' if (level >= the_debug_level) & call cio_prints(0,ctemp,9) call cio_prints(1,ctemp,9) else if (level == ERROR .and. .not.continuing_line_error) then write(print_date,'(a10)') cur_date(1:4)//'-'//cur_date(5:6)//'-'//cur_date(7:8) write(print_time,'(a12)') cur_time(1:2)//':'//cur_time(3:4)//':'//cur_time(5:10) write(ctemp,'(a)') print_date//' '//print_time//' --- ' call cio_prints(1,ctemp,len(print_date//' '//print_time//' --- ')) write(ctemp,'(a)') 'ERROR: ' if (level >= the_debug_level) & call cio_prints(0,ctemp,7) call cio_prints(1,ctemp,7) end if i = index(fmtstring(istart:iend),'%') do while (i > 0 .and. i < iend) i = i + istart - 1 write(ctemp,'(a)') fmtstring(istart:i-1) if (level >= the_debug_level .and. level /= DEBUG) & call cio_prints(0,ctemp,i-istart) if (level /= STDOUT) & call cio_prints(1,ctemp,i-istart) if (fmtstring(i+1:i+1) == '%') then write(ctemp,'(a)') '%' if (level >= the_debug_level .and. level /= DEBUG) & call cio_prints(0,ctemp,1) if (level /= STDOUT) & call cio_prints(1,ctemp,1) else if (fmtstring(i+1:i+1) == 'i') then if (idxi == 1 .and. present(i1)) then ia = i1 else if (idxi == 2 .and. present(i2)) then ia = i2 else if (idxi == 3 .and. present(i3)) then ia = i3 else if (idxi == 4 .and. present(i4)) then ia = i4 else if (idxi == 5 .and. present(i5)) then ia = i5 else if (idxi == 6 .and. present(i6)) then ia = i6 end if if (level >= the_debug_level .and. level /= DEBUG) & call cio_printi(0,ia) if (level /= STDOUT) & call cio_printi(1,ia) idxi = idxi + 1 else if (fmtstring(i+1:i+1) == 'f') then if (idxf == 1 .and. present(f1)) then fa = f1 else if (idxf == 2 .and. present(f2)) then fa = f2 else if (idxf == 3 .and. present(f3)) then fa = f3 else if (idxf == 4 .and. present(f4)) then fa = f4 else if (idxf == 5 .and. present(f5)) then fa = f5 else if (idxf == 6 .and. present(f6)) then fa = f6 end if if (level >= the_debug_level .and. level /= DEBUG) & call cio_printf(0,fa) if (level /= STDOUT) & call cio_printf(1,fa) idxf = idxf + 1 else if (fmtstring(i+1:i+1) == 's') then if (idxs == 1 .and. present(s1)) then sa = s1 else if (idxs == 2 .and. present(s2)) then sa = s2 else if (idxs == 3 .and. present(s3)) then sa = s3 else if (idxs == 4 .and. present(s4)) then sa = s4 else if (idxs == 5 .and. present(s5)) then sa = s5 else if (idxs == 6 .and. present(s6)) then sa = s6 end if write(ctemp,'(a)') trim(sa) if (level >= the_debug_level .and. level /= DEBUG) & call cio_prints(0,ctemp,len_trim(sa)) if (level /= STDOUT) & call cio_prints(1,ctemp,len_trim(sa)) idxs = idxs + 1 end if istart = i+2 i = index(fmtstring(istart:iend),'%') end do continuing_line = .false. if (present(newline)) then if (.not.newline) then continuing_line = .true. end if end if if (continuing_line) then write(ctemp,'(a)') fmtstring(istart:iend) else write(ctemp,'(a)') fmtstring(istart:iend)//achar(10) ! Add newline character 0xA end if if (level == LOGFILE) then continuing_line_logfile = continuing_line else if (level == DEBUG) then continuing_line_debug = continuing_line else if (level == INFORM) then continuing_line_inform = continuing_line else if (level == WARN) then continuing_line_warn = continuing_line else if (level == ERROR) then continuing_line_error = continuing_line else if (level == STDOUT) then continuing_line_stdout = continuing_line end if if (level >= the_debug_level .and. level /= DEBUG) & call cio_prints(0,ctemp,iend-istart+2) if (level /= STDOUT) & call cio_prints(1,ctemp,iend-istart+2) if (level == ERROR) then stop end if end if end subroutine mprintf end module module_debug