frame/module_wrf_error.F

   1 !WRF:DRIVER_LAYER:UTIL
   2 !
   3
   4 MODULE module_wrf_error
   5   INTEGER           :: wrf_debug_level = 0
   6   CHARACTER*256     :: wrf_err_message
   7
   8   ! LOGICAL silence -- if TRUE (non-zero), this MPI rank does not send
   9   !   messages via wrf_message, end_timing, wrf_debug, atm_announce,
  10   !   cmp_announce, non-fatal glob_abort, or the like.  If FALSE, this
  11   !   MPI rank DOES send messages.  Regardless of this setting, fatal
  12   !   errors (wrf_error_fatal or fatal glob_aborts) and anything sent to
  13   !   write or print will be sent.
  14 #if defined(DM_PARALLEL)
  15   integer, save :: silence=0
  16 #else
  17   integer, PARAMETER :: silence=0 ! Per-rank silence requires MPI
  18 #endif
  19
  20   ! LOGICAL buffered -- if TRUE, messages are buffered via clog_write.
  21   !   Once the buffer is full, messages are sent to stdout.  This does
  22   !   not apply to WRF_MESSAGE2, WRF_ERROR_FATAL, or anything sent to
  23   !   write or print.  The buffering implementation will not write
  24   !   partial lines, and buffer size is specified via namelist (see
  25   !   init_module_wrf_error).
  26   !   If FALSE, messages are send directly to WRITE.
  27   !
  28   !   This must be enabled at compile time by setting $WRF_LOG_BUFFERING
  29
  30 #if defined(WRF_LOG_BUFFERING)
  31   integer :: buffered=0
  32 #else
  33   integer, PARAMETER :: buffered=0 ! buffering disabled at compile time
  34 #endif
  35
  36   ! LOGICAL stderrlog -- if TRUE, messages are sent to stderr via
  37   !   write(0,...).  If FALSE, messages are not sent to stderr.
  38   !   This is set to FALSE automatically when buffering is enabled.
  39
  40   ! Defaults: Non-MPI configurations turn OFF stderr.
  41   !    MPI configurations turn ON stderr.
  42
  43 #if defined( DM_PARALLEL ) && ! defined( STUBMPI )
  44   integer :: stderrlog=1 ! 1/T = send to write(0,...) if buffered=0
  45 #else
  46   integer :: stderrlog=0 ! 1/T = send to write(0,...) if buffered=0
  47 #endif
  48
  49   INTEGER, PARAMETER :: wrf_log_flush=0, wrf_log_set_buffer_size=1, &
  50                         wrf_log_write=2
  51
  52   !NOTE: Make sure silence, buffered and stderrlog defaults here match
  53   ! the namelist defaults in init_module_wrf_error.
  54
  55 ! min_allowed_buffer_size: requested buffer sizes smaller than this
  56 ! will simply result in disabling of log file buffering.  This number
  57 ! should be larger than any line WRF prints frequently.  If you set it
  58 ! too small, the buffering code will still work.  However, any line
  59 ! that is larger than the buffer may result in two writes: one for
  60 ! the message and one for the end-of-line character at the end (if the
  61 ! message didn't already have one).
  62   integer, parameter :: min_allowed_buffer_size=200
  63
  64 !$OMP THREADPRIVATE (wrf_err_message)
  65 CONTAINS
  66
  67 ! ------------------------------------------------------------------------------
  68
  69   LOGICAL FUNCTION wrf_at_debug_level ( level )
  70     IMPLICIT NONE
  71     INTEGER , INTENT(IN) :: level
  72     wrf_at_debug_level = ( level .LE. wrf_debug_level )
  73     RETURN
  74   END FUNCTION wrf_at_debug_level
  75
  76 ! ------------------------------------------------------------------------------
  77
  78   SUBROUTINE init_module_wrf_error(on_io_server)
  79     IMPLICIT NONE
  80     LOGICAL,OPTIONAL,INTENT(IN) :: on_io_server
  81 #if defined(DM_PARALLEL)
  82     LOGICAL, EXTERNAL :: wrf_dm_on_monitor
  83 #endif
  84     LOGICAL :: compute_tasks_silent
  85     LOGICAL :: io_servers_silent
  86     INTEGER :: buffer_size,iostat,stderr_logging
  87     namelist /logging/ buffer_size,compute_tasks_silent, &
  88                        io_servers_silent,stderr_logging
  89
  90     ! MAKE SURE THE NAMELIST DEFAULTS MATCH THE DEFAULT VALUES
  91     ! AT THE MODULE LEVEL
  92
  93     ! Default: original behavior.  No buffering, all ranks talk
  94     compute_tasks_silent=.false.
  95     io_servers_silent=.false.
  96     buffer_size=0
  97
  98     ! MPI configurations default to stderr logging.
  99     ! Non-MPI does not log to stderr.  (Note that fatal errors always
 100     ! are sent to both stdout and stderr regardless of config.)
 101 #if defined( DM_PARALLEL ) && ! defined( STUBMPI )
 102     stderr_logging=1
 103 #else
 104     stderr_logging=0
 105 #endif
 106 500 format(A)
 107     ! Open namelist.input using the same unit used by module_io_wrf
 108     ! since we know nobody else will use that unit:
 109     OPEN(unit=27, file="namelist.input", form="formatted", status="old")
 110     READ(27,nml=logging,iostat=iostat)
 111     if(iostat /= 0) then
 112 #if (DA_CORE!=1)
 113        CALL wrf_debug ( 1 , 'Namelist logging not found in namelist.input. ' )
 114        CALL wrf_debug ( 1 , ' --> Using registry defaults for variables in logging.' )
 115 #else
 116        write(0,*) 'Namelist logging not found in namelist.input. Using registry defaults for variables in logging.'
 117        write(6,*) 'Namelist logging not found in namelist.input. Using registry defaults for variables in logging.'
 118 #endif
 119 #      ifdef _WIN32
 120           FLUSH(0)
 121 #      endif
 122        close(27)
 123        return
 124     endif
 125     CLOSE(27)
 126
 127 #if defined(WRF_LOG_BUFFERING)
 128     ! Forbid small buffers.  See the comment above for min_allowed_buffer_size:
 129     if(buffer_size>=min_allowed_buffer_size) then
 130        call wrf_log_action(wrf_log_set_buffer_size,buffer_size,' ')
 131        buffered=1
 132     else
 133        buffered=0
 134     endif
 135 #else
 136     if(buffer_size>=min_allowed_buffer_size) then
 137        write(0,500) 'Forcing disabling of buffering due to compile-time configuration.'
 138        write(6,500) 'Forcing disabling of buffering due to compile-time configuration.'
 139     endif
 140 #endif
 141
 142     stderrlog=stderr_logging
 143     if(buffered/=0 .and. stderrlog/=0) then
 144        write(0,500) 'Disabling stderr logging since buffering is enabled.'
 145        write(6,500) 'Disabling stderr logging since buffering is enabled.'
 146 #      ifdef _WIN32
 147           FLUSH(0)
 148 #      endif
 149        stderrlog=0
 150     endif
 151
 152 #if defined(DM_PARALLEL)
 153     silence=0
 154     if(present(on_io_server)) then
 155        if(on_io_server) then
 156           if(io_servers_silent) &
 157                silence=1
 158           return
 159        endif
 160     endif
 161     if(compute_tasks_silent) then
 162        if(wrf_dm_on_monitor()) then
 163           silence=0
 164        else
 165           silence=1
 166        endif
 167     endif
 168 #endif
 169   END SUBROUTINE init_module_wrf_error
 170
 171 END MODULE module_wrf_error
 172
 173 ! ------------------------------------------------------------------------------
 174 ! ------------------------  GLOBAL SCOPE SUBROUTINES  --------------------------
 175 ! ------------------------------------------------------------------------------
 176 #if defined(WRF_LOG_BUFFERING)
 177 SUBROUTINE wrf_log_action( act,int,str )
 178   ! The underlying clog.c is not thread-safe, so this wrapper subroutine
 179   ! ensures that only one thread accesses clog.c at a time.
 180
 181   ! NOTE: This routine only exists if WRF_LOG_BUFFERING is defined at
 182   ! compile time.
 183   use module_wrf_error
 184   implicit none
 185   integer, intent(in) :: int,act
 186   character(*), intent(in) :: str
 187 !$OMP CRITICAL(wrf_log_action_critical)
 188   if(act==wrf_log_flush) then
 189      call clog_flush(int)
 190   elseif(act==wrf_log_set_buffer_size) then
 191      call clog_set_buffer_len(int)
 192   elseif(act==wrf_log_write) then
 193      call clog_write(int,str)
 194   endif
 195 !$OMP END CRITICAL(wrf_log_action_critical)
 196 END SUBROUTINE wrf_log_action
 197 #endif
 198 ! ------------------------------------------------------------------------------
 199
 200 ! wrf_message: ordinary message
 201 !   Write to stderr if stderrlog=T to ensure immediate output
 202 !   Write to stdout for buffered output.
 203 SUBROUTINE wrf_message( str )
 204 #ifdef ESMFIO
 205   USE ESMF
 206 #endif
 207   use module_wrf_error, only: silence, buffered, stderrlog, wrf_log_write
 208   IMPLICIT NONE
 209
 210   CHARACTER*(*) str
 211   if(silence/=0) return
 212   if(buffered/=0) then
 213 #if defined(WRF_LOG_BUFFERING)
 214      call wrf_log_action(wrf_log_write,len_trim(str),str)
 215 #endif
 216   else
 217 !$OMP MASTER
 218      if(stderrlog/=0) then
 219 300     format(A)
 220         write(0,300) trim(str)
 221 # ifdef _WIN32
 222   FLUSH(0)
 223 # endif
 224      endif
 225      print 300,trim(str)
 226 !$OMP END MASTER
 227   endif
 228
 229 #ifdef ESMFIO
 230   CALL ESMF_LogWrite(TRIM(str),ESMF_LOGMSG_INFO)
 231 #endif
 232 END SUBROUTINE wrf_message
 233
 234 ! ------------------------------------------------------------------------------
 235
 236 ! Intentionally write to stderr only
 237 ! This is set to stderr, even in silent mode, because
 238 ! it is used for potentially fatal error or warning messages and
 239 ! we want the message to get to the log file before any crash
 240 ! or MPI_Abort happens.
 241 SUBROUTINE wrf_message2( str )
 242 #ifdef ESMFIO
 243   USE ESMF
 244 #endif
 245   IMPLICIT NONE
 246   CHARACTER*(*) str
 247 !$OMP MASTER
 248 400 format(A)
 249   write(0,400) str
 250 # ifdef _WIN32
 251   FLUSH(0)
 252 # endif
 253 !$OMP END MASTER
 254 #ifdef ESMFIO
 255   CALL ESMF_LogWrite(TRIM(str),ESMF_LOGMSG_INFO)
 256 #endif
 257 END SUBROUTINE wrf_message2
 258
 259 ! ------------------------------------------------------------------------------
 260
 261 SUBROUTINE wrf_error_fatal3( file_str, line, str )
 262   USE module_wrf_error
 263 #ifdef ESMFIO
 264 ! 5.2.0r  USE ESMF_Mod
 265   USE ESMF
 266 #endif
 267   IMPLICIT NONE
 268   CHARACTER*(*) file_str
 269   INTEGER , INTENT (IN) :: line  ! only print file and line if line > 0
 270   CHARACTER*(*) str
 271   CHARACTER*256 :: line_str
 272
 273   write(line_str,'(i6)') line
 274
 275   ! Fatal errors are printed to stdout and stderr regardless of
 276   ! any &logging namelist settings.
 277
 278   CALL wrf_message( '-------------- FATAL CALLED ---------------' )
 279   ! only print file and line if line is positive
 280   IF ( line > 0 ) THEN
 281     CALL wrf_message( 'FATAL CALLED FROM FILE:  '//file_str//'  LINE:  '//TRIM(line_str) )
 282   ENDIF
 283   CALL wrf_message( str )
 284   CALL wrf_message( '-------------------------------------------' )
 285
 286   force_stderr: if(stderrlog==0) then
 287   CALL wrf_message2( '-------------- FATAL CALLED ---------------' )
 288   ! only print file and line if line is positive
 289   IF ( line > 0 ) THEN
 290         CALL wrf_message2( 'FATAL CALLED FROM FILE:  '//file_str//'  LINE:  '//TRIM(line_str) )
 291   ENDIF
 292      CALL wrf_message2( trim(str) )
 293   CALL wrf_message2( '-------------------------------------------' )
 294   endif force_stderr
 295
 296   ! Flush all streams.
 297   flush(6)
 298 #if defined(WRF_LOG_BUFFERING)
 299   if(buffered/=0) call wrf_log_action(wrf_log_flush,1,' ')
 300 # endif
 301   flush(0)
 302
 303 #ifdef ESMFIO
 304 ! 5.2.0r  CALL esmf_finalize(terminationflag=ESMF_ABORT)
 305   CALL esmf_finalize(endflag=ESMF_END_ABORT)
 306 #endif
 307
 308 #ifdef TRACEBACKQQ
 309   CALL tracebackqq
 310 #endif
 311   CALL wrf_abort
 312 END SUBROUTINE wrf_error_fatal3
 313
 314 ! ------------------------------------------------------------------------------
 315
 316 SUBROUTINE wrf_error_fatal( str )
 317   USE module_wrf_error
 318   IMPLICIT NONE
 319   CHARACTER*(*) str
 320   CALL wrf_error_fatal3 ( ' ', 0, str )
 321 END SUBROUTINE wrf_error_fatal
 322
 323 ! ------------------------------------------------------------------------------
 324
 325 ! Check to see if expected value == actual value
 326 ! If not, print message and exit.
 327 SUBROUTINE wrf_check_error( expected, actual, str, file_str, line )
 328   USE module_wrf_error
 329   IMPLICIT NONE
 330   INTEGER , INTENT (IN) :: expected
 331   INTEGER , INTENT (IN) :: actual
 332   CHARACTER*(*) str
 333   CHARACTER*(*) file_str
 334   INTEGER , INTENT (IN) :: line
 335   CHARACTER (LEN=512)   :: rc_str
 336   CHARACTER (LEN=512)   :: str_with_rc
 337
 338   IF ( expected .ne. actual ) THEN
 339     WRITE (rc_str,*) '  Routine returned error code = ',actual
 340     str_with_rc = TRIM(str // rc_str)
 341     CALL wrf_error_fatal3 ( file_str, line, str_with_rc )
 342   ENDIF
 343 END SUBROUTINE wrf_check_error
 344
 345 ! ------------------------------------------------------------------------------
 346
 347 !  Some compilers do not yet support the entirety of the Fortran 2003 standard.
 348 !  This is a small patch to pick up the two most common events.  Most xlf
 349 !  compilers have an extension fflush.  That is available here.  For other older
 350 !  compilers with no flush capability at all, we just stub it out completely.
 351 !  These CPP ifdefs are defined in the configure file.
 352
 353 #ifdef USE_FFLUSH
 354 SUBROUTINE flush ( iunit )
 355   IMPLICIT NONE
 356   INTEGER :: iunit
 357   CALL fflush ( iunit )
 358 END SUBROUTINE flush
 359 #endif
 360
 361 #ifdef NO_FLUSH_SUPPORT
 362 SUBROUTINE flush ( iunit )
 363   IMPLICIT NONE
 364   INTEGER :: iunit
 365   RETURN
 366 END SUBROUTINE flush
 367 #endif
 368
 369
 370