geogrid/src/module_debug.F

   1 module module_debug
   2
   3 #ifdef _GEOGRID
   4    use parallel_module
   5 #else
   6 #ifdef _METGRID
   7    use parallel_module
   8 #else
   9    integer, parameter :: IO_NODE = 0
  10    integer :: my_proc_id = 0
  11 #endif
  12 #endif
  13
  14    integer, parameter :: QUIET=-100, LOGFILE=-2, DEBUG=0, INFORM=1, WARN=2, ERROR=3, STDOUT=100
  15
  16    integer :: the_debug_level = DEBUG
  17
  18    logical :: have_set_logname = .false.
  19
  20    logical :: continuing_line_logfile = .false.
  21    logical :: continuing_line_debug   = .false.
  22    logical :: continuing_line_inform  = .false.
  23    logical :: continuing_line_warn    = .false.
  24    logical :: continuing_line_error   = .false.
  25    logical :: continuing_line_stdout  = .false.
  26
  27
  28    contains
  29
  30    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  31    ! Name: set_debug_level
  32    !
  33    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  34    subroutine set_debug_level(ilev)
  35
  36       implicit none
  37
  38       ! Arguments
  39       integer, intent(in) :: ilev
  40
  41       the_debug_level = ilev
  42
  43    end subroutine set_debug_level
  44
  45
  46    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  47    ! Name: mprintf
  48    !
  49    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  50    subroutine mprintf(assertion, level, fmtstring, &
  51                       newline, &
  52                       i1, i2, i3, i4, i5, i6, &
  53                       f1, f2, f3, f4, f5, f6, &
  54                       s1, s2, s3, s4, s5, s6, &
  55                       l1, l2, l3, l4, l5, l6)
  56
  57       implicit none
  58
  59       ! Arguments
  60       integer, intent(in) :: level
  61       logical, intent(in) :: assertion
  62       character (len=*), intent(in) :: fmtstring
  63       logical, intent(in), optional :: newline
  64       integer, intent(in), optional :: i1, i2, i3, i4, i5, i6
  65       real, intent(in), optional :: f1, f2, f3, f4, f5, f6
  66       logical, intent(in), optional :: l1, l2, l3, l4, l5, l6
  67       character (len=*), intent(in), optional :: s1, s2, s3, s4, s5, s6
  68
  69       ! Local variables
  70       integer :: idxi, idxf, idxs, idxl, istart, i, iend, ia
  71       real :: fa
  72       logical :: continuing_line, la
  73       character (len=8) :: cur_date
  74       character (len=10) :: cur_time
  75       character (len=10) :: print_date
  76       character (len=12) :: print_time
  77 !BUG: sa should be as long as the largest string length used anywhere in WPS
  78       character (len=1024) :: sa
  79       character (len=1024) :: ctemp
  80
  81       if (.not. have_set_logname) then
  82          write(ctemp,'(a)') 'logfile.log'
  83          call cio_set_log_filename(ctemp,len_trim(ctemp))
  84 #ifdef _GEOGRID
  85          if (nprocs == 1) then
  86             write(ctemp,'(a)') 'geogrid.log'
  87             call cio_set_log_filename(ctemp,len_trim(ctemp))
  88          else
  89             write(ctemp,'(a,i4.4)') 'geogrid.log.',my_proc_id
  90             call cio_set_log_filename(ctemp,len_trim(ctemp))
  91          end if
  92 #endif
  93 #ifdef _METGRID
  94          if (nprocs == 1) then
  95             write(ctemp,'(a)') 'metgrid.log'
  96             call cio_set_log_filename(ctemp,len_trim(ctemp))
  97          else
  98             write(ctemp,'(a,i4.4)') 'metgrid.log.',my_proc_id
  99             call cio_set_log_filename(ctemp,len_trim(ctemp))
 100          end if
 101 #endif
 102 #ifdef _UNGRIB
 103          write(ctemp,'(a)') 'ungrib.log'
 104          call cio_set_log_filename(ctemp,len_trim(ctemp))
 105 #endif
 106          have_set_logname = .true.
 107       end if
 108
 109       idxi = 1
 110       idxf = 1
 111       idxs = 1
 112       idxl = 1
 113       istart = 1
 114       iend = len_trim(fmtstring)
 115
 116 #if (defined _GEOGRID) || (defined _METGRID)
 117       if (assertion .and. (.not. (level == STDOUT .and. my_proc_id /= IO_NODE))) then
 118 #else
 119       if (assertion) then
 120 #endif
 121
 122          ! If this is a debug message give up if level is not high enough
 123          if (level == DEBUG .and. the_debug_level > DEBUG) return
 124
 125          if (level /= STDOUT) then
 126             call date_and_time(date=cur_date,time=cur_time)
 127          end if
 128
 129          if (level == LOGFILE .and. .not.continuing_line_logfile) then
 130             write(print_date,'(a10)') cur_date(1:4)//'-'//cur_date(5:6)//'-'//cur_date(7:8)
 131             write(print_time,'(a12)') cur_time(1:2)//':'//cur_time(3:4)//':'//cur_time(5:10)
 132             write(ctemp,'(a)') print_date//' '//print_time//' --- '
 133             call cio_prints(1,ctemp,len(print_date//' '//print_time//' --- '))
 134          else if (level == DEBUG .and. .not.continuing_line_debug) then
 135             write(print_date,'(a10)') cur_date(1:4)//'-'//cur_date(5:6)//'-'//cur_date(7:8)
 136             write(print_time,'(a12)') cur_time(1:2)//':'//cur_time(3:4)//':'//cur_time(5:10)
 137             write(ctemp,'(a)') print_date//' '//print_time//' --- '
 138             call cio_prints(1,ctemp,len(print_date//' '//print_time//' --- '))
 139             write(ctemp,'(a)') 'DEBUG: '
 140             call cio_prints(1,ctemp,7)
 141          else if (level == INFORM .and. .not.continuing_line_inform) then
 142             write(print_date,'(a10)') cur_date(1:4)//'-'//cur_date(5:6)//'-'//cur_date(7:8)
 143             write(print_time,'(a12)') cur_time(1:2)//':'//cur_time(3:4)//':'//cur_time(5:10)
 144             write(ctemp,'(a)') print_date//' '//print_time//' --- '
 145             call cio_prints(1,ctemp,len(print_date//' '//print_time//' --- '))
 146             write(ctemp,'(a)') 'INFORM: '
 147             if (level >= the_debug_level) &
 148                call cio_prints(0,ctemp,8)
 149             call cio_prints(1,ctemp,8)
 150          else if (level == WARN .and. .not.continuing_line_warn) then
 151             write(print_date,'(a10)') cur_date(1:4)//'-'//cur_date(5:6)//'-'//cur_date(7:8)
 152             write(print_time,'(a12)') cur_time(1:2)//':'//cur_time(3:4)//':'//cur_time(5:10)
 153             write(ctemp,'(a)') print_date//' '//print_time//' --- '
 154             call cio_prints(1,ctemp,len(print_date//' '//print_time//' --- '))
 155             write(ctemp,'(a)') 'WARNING: '
 156             if (level >= the_debug_level) &
 157                call cio_prints(0,ctemp,9)
 158             call cio_prints(1,ctemp,9)
 159          else if (level == ERROR .and. .not.continuing_line_error) then
 160             write(print_date,'(a10)') cur_date(1:4)//'-'//cur_date(5:6)//'-'//cur_date(7:8)
 161             write(print_time,'(a12)') cur_time(1:2)//':'//cur_time(3:4)//':'//cur_time(5:10)
 162             write(ctemp,'(a)') print_date//' '//print_time//' --- '
 163             call cio_prints(1,ctemp,len(print_date//' '//print_time//' --- '))
 164             write(ctemp,'(a)') 'ERROR: '
 165             if (level >= the_debug_level) &
 166                call cio_prints(0,ctemp,7)
 167             call cio_prints(1,ctemp,7)
 168          end if
 169
 170          i = index(fmtstring(istart:iend),'%')
 171          do while (i > 0 .and. i < iend)
 172             i = i + istart - 1
 173             write(ctemp,'(a)') fmtstring(istart:i-1)
 174             if (level >= the_debug_level .and. level /= DEBUG) &
 175                call cio_prints(0,ctemp,i-istart)
 176             if (level /= STDOUT) &
 177                call cio_prints(1,ctemp,i-istart)
 178
 179             if (fmtstring(i+1:i+1) == '%') then
 180                write(ctemp,'(a)') '%'
 181                if (level >= the_debug_level .and. level /= DEBUG) &
 182                   call cio_prints(0,ctemp,1)
 183                if (level /= STDOUT) &
 184                   call cio_prints(1,ctemp,1)
 185
 186             else if (fmtstring(i+1:i+1) == 'i') then
 187                if (idxi == 1 .and. present(i1)) then
 188                   ia = i1
 189                else if (idxi == 2 .and. present(i2)) then
 190                   ia = i2
 191                else if (idxi == 3 .and. present(i3)) then
 192                   ia = i3
 193                else if (idxi == 4 .and. present(i4)) then
 194                   ia = i4
 195                else if (idxi == 5 .and. present(i5)) then
 196                   ia = i5
 197                else if (idxi == 6 .and. present(i6)) then
 198                   ia = i6
 199                end if
 200
 201                if (level >= the_debug_level .and. level /= DEBUG) &
 202                   call cio_printi(0,ia)
 203                if (level /= STDOUT) &
 204                   call cio_printi(1,ia)
 205
 206                idxi = idxi + 1
 207
 208             else if (fmtstring(i+1:i+1) == 'f') then
 209                if (idxf == 1 .and. present(f1)) then
 210                   fa = f1
 211                else if (idxf == 2 .and. present(f2)) then
 212                   fa = f2
 213                else if (idxf == 3 .and. present(f3)) then
 214                   fa = f3
 215                else if (idxf == 4 .and. present(f4)) then
 216                   fa = f4
 217                else if (idxf == 5 .and. present(f5)) then
 218                   fa = f5
 219                else if (idxf == 6 .and. present(f6)) then
 220                   fa = f6
 221                end if
 222
 223                if (level >= the_debug_level .and. level /= DEBUG) &
 224                   call cio_printf(0,fa)
 225                if (level /= STDOUT) &
 226                   call cio_printf(1,fa)
 227
 228                idxf = idxf + 1
 229
 230             else if (fmtstring(i+1:i+1) == 's') then
 231                if (idxs == 1 .and. present(s1)) then
 232                   sa = s1
 233                else if (idxs == 2 .and. present(s2)) then
 234                   sa = s2
 235                else if (idxs == 3 .and. present(s3)) then
 236                   sa = s3
 237                else if (idxs == 4 .and. present(s4)) then
 238                   sa = s4
 239                else if (idxs == 5 .and. present(s5)) then
 240                   sa = s5
 241                else if (idxs == 6 .and. present(s6)) then
 242                   sa = s6
 243                end if
 244
 245                write(ctemp,'(a)') trim(sa)
 246                if (level >= the_debug_level .and. level /= DEBUG) &
 247                   call cio_prints(0,ctemp,len_trim(ctemp))
 248                if (level /= STDOUT) &
 249                   call cio_prints(1,ctemp,len_trim(ctemp))
 250                idxs = idxs + 1
 251
 252             else if (fmtstring(i+1:i+1) == 'l') then
 253                if (idxl == 1 .and. present(l1)) then
 254                   la = l1
 255                else if (idxl == 2 .and. present(l2)) then
 256                   la = l2
 257                else if (idxl == 3 .and. present(l3)) then
 258                   la = l3
 259                else if (idxl == 4 .and. present(l4)) then
 260                   la = l4
 261                else if (idxl == 5 .and. present(l5)) then
 262                   la = l5
 263                else if (idxl == 6 .and. present(l6)) then
 264                   la = l6
 265                end if
 266
 267                if (la) then
 268                   write(ctemp,'(a)') '.TRUE.'
 269                else
 270                   write(ctemp,'(a)') '.FALSE.'
 271                end if
 272                if (level >= the_debug_level .and. level /= DEBUG) &
 273                   call cio_prints(0,ctemp,len_trim(ctemp))
 274                if (level /= STDOUT) &
 275                   call cio_prints(1,ctemp,len_trim(ctemp))
 276                idxl = idxl + 1
 277
 278             end if
 279
 280             istart = i+2
 281             i = index(fmtstring(istart:iend),'%')
 282          end do
 283
 284          continuing_line = .false.
 285          if (present(newline)) then
 286             if (.not.newline) then
 287                continuing_line = .true.
 288             end if
 289          end if
 290
 291          if (continuing_line) then
 292             write(ctemp,'(a)') fmtstring(istart:iend)
 293          else
 294             write(ctemp,'(a)') fmtstring(istart:iend)//achar(10)  ! Add newline character 0xA
 295          end if
 296
 297          if (level == LOGFILE) then
 298             continuing_line_logfile = continuing_line
 299          else if (level == DEBUG) then
 300             continuing_line_debug   = continuing_line
 301          else if (level == INFORM) then
 302             continuing_line_inform  = continuing_line
 303          else if (level == WARN) then
 304             continuing_line_warn    = continuing_line
 305          else if (level == ERROR) then
 306             continuing_line_error   = continuing_line
 307          else if (level == STDOUT) then
 308             continuing_line_stdout  = continuing_line
 309          end if
 310
 311          if (level >= the_debug_level .and. level /= DEBUG) &
 312             call cio_prints(0,ctemp,iend-istart+2)
 313          if (level /= STDOUT) &
 314             call cio_prints(1,ctemp,iend-istart+2)
 315
 316          if (level == ERROR) then
 317 #ifdef _GEOGRID
 318             call parallel_abort()
 319 #endif
 320 #ifdef _METGRID
 321             call parallel_abort()
 322 #endif
 323             stop
 324          end if
 325
 326       end if
 327
 328
 329    end subroutine mprintf
 330
 331 end module module_debug