! $Id: message.f90 4452 2015-01-29 14:42:02Z idculv $ !****s* Messages/message * ! ! NAME ! message - Issue an information / warning / error message. ! --> BASED ON MARQUARDT COLLECTION LIBRARY ROUTINE ! ! SYNOPSIS ! use ropp_utils ! ... ! call message(msgtype, msgtext) ! ... ! ! DESCRIPTION ! This subroutine prints an error message. For fatal errors, the program ! is aborted, and an exit status is set. The output will look like this: ! ! MESSAGE_TYPE (//): ! Text of the message, which might have multiple lines of text. ! ! where the MESSAGE_TYPE is determined by the value of the msgtype argument. ! Fatal error messages result in termination of the program. ! ! INPUTS ! int msgtype The msgtype of the message which can be msg_cont, msg_info, ! msg_warn, msg_error or msg_fatal (as defined in the ! module messages). The following values are supported: ! ! msg_cont This will continue the previous message ! (and provides a way to build up multi ! line informational or warning messages). ! msg_info Informational message; message starts with ! 'INFO:' ! msg_warn Warning message; message starts with ! 'WARNING:' ! msg_error Error message; message starts with ! 'ERROR:' ! msg_fatal Fatal error message; message starts with ! 'FATAL ERROR:' ! ! For fatal errors, the program will terminate with an ! an error code msg_exit_fatal (3)] if the Fortran compiler ! supports a 'call exit(n)'. ! ! char* msgtext Message to be printed. This is a text string which may have ! embedded C-style control characters. The supported ones are: ! \n newline; use for multi-line messages ! \t tabulator ! \' single and... ! \" ...double hyphens ! \a terminal bell (i.e., a 'beep') ! \b backspace ! \\ backslash ! ! OUTPUT ! Text is printed to stdout or stderr. ! ! NOTES ! The MESSAGE_TYPE qualifiers in the first line of the message are determined ! by the value of the msgtype parameter; use one of the parameters provided in ! the module messages (as described above). The additional qualifiers after ! the main one can be set via the additional routines message_set_program(), ! message_set_routine() and message_set_addinfo(). If those qualifiers are ! set to ' ', they will not be printed. Similar *_set_* routines exist to ! enquire about the current setting of the additional qualifiers. ! ! Multiline texts can be generated by adding '\n' for line breaks with a ! single call to message. Note, however, that the routine prints three blanks ! in front of the error text; for multiline error messages, these must be ! added manually after the '\n'. An alternative way to create non-fatal ! multiline messages is to use the routine repeatedly with the 'msg_cont' ! msgtype parameter to write out individual lines. ! ! The exit status in case of fatal errors is msg_exit_fatal (3). ! ! SEE ALSO ! assert ! message_set_program ! message_get_program ! message_set_routine ! message_get_routine ! message_set_addinfo ! message_get_addinfo ! ! AUTHOR ! C. Marquardt, Darmstadt, Germany ! ! COPYRIGHT ! ! Copyright (c) 2005 Christian Marquardt ! ! All rights reserved. ! ! Permission is hereby granted, free of charge, to any person obtaining ! a copy of this software and associated documentation files (the ! "Software"), to deal in the Software without restriction, including ! without limitation the rights to use, copy, modify, merge, publish, ! distribute, sublicense, and/or sell copies of the Software, and to ! permit persons to whom the Software is furnished to do so, subject to ! the following conditions: ! ! The above copyright notice and this permission notice shall be ! included in all copies or substantial portions of the Software as well ! as in supporting documentation. ! ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ! EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ! MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ! NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE ! LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION ! OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION ! WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ! !**** !-------------------------------------------------------------------------- ! 1. Simple version !-------------------------------------------------------------------------- subroutine message(msgtype, msgtext) ! Declarations ! ------------ use messages, not_this => message implicit none interface function get_io_unit() result(unit) implicit none integer :: unit end function get_io_unit end interface integer, intent(in) :: msgtype character (len=*), intent(in) :: msgtext integer :: idx character (len= 2000) :: post, xmsgtext character (len= 80) :: ropp_msg_mode integer :: logFileLrn character (len=*), parameter :: logStrPrepend = ' ROPP ' ! Read ROPP_MSG_MODE environment variable to set msg_MODE level ! (default: NormalMode) and initialise exit status to OK. IF (.NOT. msg_MODE_READ) THEN CALL GETENV( "ROPP_MSG_MODE", ropp_msg_mode) SELECT CASE (TRIM(ropp_msg_mode)) CASE ("QuietMode") msg_MODE = QuietMode CASE ("NormalMode") msg_MODE = NormalMode CASE ("VerboseMode") msg_MODE = VerboseMode CASE DEFAULT msg_MODE = NormalMode END SELECT msg_MODE_READ = .true. msg_EXIT_STATUS = msg_exit_ok ENDIF ! Set names of program and routine ! -------------------------------- if (len_trim(msg_program) == 0) then if (len_trim(msg_routine) == 0) then if (len_trim(msg_addinfo) == 0) then post = ':' else post = ' (' // trim(msg_addinfo) // '):' endif else if (len_trim(msg_addinfo) == 0) then post = ' (from ' // trim(msg_routine) // '):' else post = ' (from ' // trim(msg_routine) // '/' // & trim(msg_addinfo) // '):' endif endif else if (len_trim(msg_routine) == 0) then if (len_trim(msg_addinfo) == 0) then post = ' (from ' // trim(msg_program) // '):' else post = ' (from ' // trim(msg_program) // '/' // & trim(msg_addinfo) // '):' endif else if (len_trim(msg_addinfo) == 0) then post = ' (from ' // trim(msg_program) // '/' // & trim(msg_routine) // '):' else post = ' (from ' // trim(msg_program) // '/' // & trim(msg_routine) // '/' // & trim(msg_addinfo) // '):' endif endif endif if (msg_logFile(1:1) /= ' ') then ! ----------------------------------- ! Ignore control characters in msgtext ! ----------------------------------- xmsgtext = msgtext do idx = INDEX(trim(xmsgtext),'\a') if(idx == 0) exit xmsgtext(idx:idx+1) = achar(32) enddo do idx = INDEX(trim(xmsgtext),'\b') if(idx == 0) exit xmsgtext(idx:idx+1) = achar(32) enddo do idx = INDEX(trim(xmsgtext),'\t') if(idx == 0) exit xmsgtext(idx:idx+1) = achar(32) enddo do idx = INDEX(trim(xmsgtext),'\n') if(idx == 0) exit xmsgtext(idx:idx+1) = achar(32) enddo do idx = INDEX(trim(xmsgtext), "\'") if(idx == 0) exit xmsgtext(idx:idx+1) = achar(32) enddo do idx = INDEX(trim(xmsgtext),'\"') if(idx == 0) exit xmsgtext(idx:idx+1) = achar(32) enddo do idx = INDEX(trim(xmsgtext),'\\') if(idx == 0) exit xmsgtext(idx:idx+1) = achar(32) enddo ! ----------------- ! Log error message ! ----------------- logFileLrn = get_io_unit() open(logFileLrn, file=msg_logFile, status='unknown', position='append') select case(msgtype) case(msg_cont) IF (msg_MODE >= NormalMode) & write(logFileLrn, '(a)') logStrPrepend // ' ' // trim(xmsgtext) case(msg_diag) IF (msg_MODE == VerboseMode) & write(logFileLrn, '(a)') logStrPrepend // '...' // trim(post) // & ' ' // trim(xmsgtext) case(msg_info) write(logFileLrn, '(a)') logStrPrepend // 'INFO' // trim(post) // & ' ' // trim(xmsgtext) case(msg_warn) msg_EXIT_STATUS = max(msg_EXIT_STATUS, msg_exit_warn) IF (msg_MODE >= NormalMode) THEN write(logFileLrn, '(a)') logStrPrepend // 'WARNING' // trim(post) // & ' ' // trim(xmsgtext) ENDIF case(msg_error) msg_EXIT_STATUS = max(msg_EXIT_STATUS, msg_exit_error) IF (msg_MODE >= QuietMode) THEN write(logFileLrn, '(a)') logStrPrepend // 'ERROR' // trim(post) // & ' ' // trim(xmsgtext) ENDIF case(msg_fatal) msg_EXIT_STATUS = max(msg_EXIT_STATUS, msg_exit_fatal) IF (msg_MODE >= QuietMode) THEN write(logFileLrn, '(a)') logStrPrepend // 'FATAL ERROR' // & trim(post) // ' ' // trim(xmsgtext) ENDIF close(logFileLrn) call exit(msg_EXIT_STATUS) case(msg_noin) IF (msg_MODE >= NormalMode) & write(logFileLrn, '(a)') logStrPrepend // trim(xmsgtext) end select close(logFileLrn) return else ! ----------------------------------- ! Handle control characters in msgtext ! ----------------------------------- xmsgtext = msgtext do idx = INDEX(trim(xmsgtext),'\a') if(idx == 0) exit xmsgtext(idx:idx+1) = achar(07) enddo do idx = INDEX(trim(xmsgtext),'\b') if(idx == 0) exit xmsgtext(idx:idx+1) = achar(08) enddo do idx = INDEX(trim(xmsgtext),'\t') if(idx == 0) exit xmsgtext(idx:idx+1) = achar(09) enddo do idx = INDEX(trim(xmsgtext),'\n') if(idx == 0) exit xmsgtext(idx:idx+1) = achar(10) enddo do idx = INDEX(trim(xmsgtext), "\'") if(idx == 0) exit xmsgtext(idx:idx+1) = achar(39) enddo do idx = INDEX(trim(xmsgtext),'\"') if(idx == 0) exit xmsgtext(idx:idx+1) = achar(34) enddo do idx = INDEX(trim(xmsgtext),'\\') if(idx == 0) exit xmsgtext(idx:idx+1) = achar(92) enddo ! ------------------- ! Print error message ! ------------------- select case(msgtype) case(msg_cont) IF (msg_MODE >= NormalMode) & write(stdout, '(a)') ' ' // trim(xmsgtext) case(msg_diag) IF (msg_MODE == VerboseMode) & write(stdout, '(a)') '...' // trim(post) // ' ' // trim(xmsgtext) case(msg_info) IF (msg_MODE >= NormalMode) & write(stdout, '(a)') 'INFO' // trim(post) // ' ' // trim(xmsgtext) case(msg_warn) msg_EXIT_STATUS = max(msg_EXIT_STATUS, msg_exit_warn) IF (msg_MODE >= NormalMode) THEN write(stdout, '(a)') ' ' write(stdout, '(a)') 'WARNING' // trim(post) // ' ' // trim(xmsgtext) ENDIF case(msg_error) msg_EXIT_STATUS = max(msg_EXIT_STATUS, msg_exit_error) IF (msg_MODE >= QuietMode) THEN write(stderr, '(a)') ' ' write(stderr, '(a)') 'ERROR' // trim(post) // ' ' // trim(xmsgtext) ENDIF case(msg_fatal) msg_EXIT_STATUS = max(msg_EXIT_STATUS, msg_exit_fatal) IF (msg_MODE >= QuietMode) THEN write(stderr, '(a)') ' ' write(stderr, '(a)') 'FATAL ERROR' // trim(post) // ' ' // & trim(xmsgtext) write(stderr, '(a)') ' ' ENDIF call exit(msg_EXIT_STATUS) case(msg_noin) IF (msg_MODE >= NormalMode) & write(stdout, '(a)') trim(xmsgtext) end select end if end subroutine message