! Copyright (c) (2013-2015,2017,2022) Jeremie Burgalat (jeremie.burgalat@univ-reims.fr). ! ! This file is part of SWIFT ! ! 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. ! ! 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. !! file: errors.F90 !! summary: Errors handling source file. !! author: J. Burgalat !! date: 2013-2015,2017,2022 #include "defined.h" MODULE ERRORS !! Error handler module !! !! This module provides a single derived type, [[error(type)]] which is used in all !! other parts of the library in order to handle errors. USE, INTRINSIC :: ISO_C_BINDING USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY : stdout=>OUTPUT_UNIT, stderr=>ERROR_UNIT IMPLICIT NONE PUBLIC PRIVATE :: error_equals,error_equals_int,error_differs,error_differs_int, & msg_length INTEGER, PARAMETER :: msg_length = 250 !! Length of error message. TYPE, PUBLIC :: error !! Define an error !! !! The following derived type represents in the simplest way (I believe) an error which !! stores: !! !! - An integer to numerically identify the error !! - A string (250 chars max) with an appropriate error message !! - A bounded procedure to get a string representation of the error (if bounded !! procedures are supported by the library). !! - internal subroutines for derived type IO WRITE statement (if Derived IO !! subroutines are supported by the library). !! !! error type comes also with two operators ("==", "/=") to compare error type with !! another one or an integer. !! If an error is not initialized explicitly, then it is set to [[errors(module):noerror(variable)]]. CHARACTER(len=msg_length) :: msg = "No error" !! Message associated to the error !! @note !! The message should be short (250 characters maximum) and explicit. INTEGER :: id = 0 !! Numerical identifier of the error !! @note !! The error identifier is used to test the equality/inequality of two error objects. #if HAVE_FTNPROC CONTAINS PROCEDURE, PUBLIC :: to_string => error_to_string !! Get a string representation of the error #endif END TYPE error INTERFACE !! Clean subroutine interface SUBROUTINE clean_callback(err) !! A subroutine that may perform cleaning computation(s) before exit IMPORT error IMPLICIT NONE TYPE(error), INTENT(in) :: err !! An error object with the input error END SUBROUTINE clean_callback END INTERFACE INTERFACE subroutine abort_() bind(C, name="abort") end subroutine END INTERFACE INTERFACE assert !! _Raise_ an assertion. !! !! An assertion can be understood as a development error that should be raised in production mode. MODULE PROCEDURE :: assert_r,assert_w END INTERFACE assert !> error equality operator INTERFACE OPERATOR(==) MODULE PROCEDURE error_equals, error_equals_int END INTERFACE !> error inequality operator INTERFACE OPERATOR(/=) MODULE PROCEDURE error_differs, error_differs_int END INTERFACE !> The no error error ! TYPE(error), PUBLIC, PARAMETER :: noerror = error("No error",0) CONTAINS !=============================================================================== ! error TYPE RELATED METHODS !=============================================================================== FUNCTION error_equals(this, other) RESULT(res) !! Check if two error objects are equivalent TYPE(error), INTENT(in) :: this, & !! The first error object to compare other !! The second error object to compare LOGICAL :: res !! .true. if __this__ and __other__ identifiers are the same, .false. otherwise res = (this%id == other%id) RETURN END FUNCTION error_equals FUNCTION error_equals_int(this, id) RESULT(res) !! Check if an error id is equal to a given integer TYPE(error), INTENT(in) :: this !! An error object reference INTEGER, INTENT(in) :: id !! An integer to compare to __this__ identifier LOGICAL :: res !! .true. if __this__ identifier and __id__ have the same value, .false. otherwise res = (this%id == id) RETURN END FUNCTION error_equals_int FUNCTION error_differs(this, other) RESULT(res) !! Check if two error objects are different TYPE(error), INTENT(in) :: this, & !! The first error object to compare other !! The second error object to compare LOGICAL :: res !! .false. if __this__ and __other__ identifiers are the same, .true. otherwise res = (this%id /= other%id) RETURN END FUNCTION error_differs FUNCTION error_differs_int(this, id) RESULT(res) !! Check if an error id is different from a given integer TYPE(error), INTENT(in) :: this !! An error object reference INTEGER, INTENT(in) :: id !! An integer to compare to __this__ identifier LOGICAL :: res !! .false. if __this__ identifier and __id__ have the same value, .true. otherwise res = (this%id /= id) RETURN END FUNCTION error_differs_int FUNCTION error_to_string(this,progname,as_warning) RESULT(str) !! (simple) String representation of the error !! !! The function returns a very simple formatted string with the error. OBJECT(error), INTENT(in) :: this !! An error object reference CHARACTER(len=*), INTENT(in), OPTIONAL :: progname !! An optional string with the name of the program LOGICAL, INTENT(in), OPTIONAL :: as_warning !! An optional boolean flag to print the message as warning rather than as error (default to .false.). CHARACTER(len=:), ALLOCATABLE :: str !! An allocatable string with the string representation of the error CHARACTER(len=:), ALLOCATABLE :: pref pref = "error: " IF (PRESENT(as_warning)) THEN ; IF (as_warning) pref = "warning: " ; ENDIF IF (PRESENT(progname)) THEN IF (LEN_TRIM(progname) /=0) THEN str = TRIM(progname)//': '//pref//TRIM(this%msg) ELSE str = pref//TRIM(this%msg) ENDIF ELSE str = pref//TRIM(this%msg) ENDIF RETURN END FUNCTION error_to_string SUBROUTINE aborting(err) !! Abort the program with specific exit code !! !! The method prints the message of the given error object and !! stops the program using exit() subroutine. TYPE(error), INTENT(in) :: err !! An error object IF (err /= 0) THEN WRITE(*,'(a)') error_to_string(err) CALL EXIT(err%id) ENDIF END SUBROUTINE aborting SUBROUTINE assert_r(test,reason) !! _Raise_ an assertion. !! !! The method raises an assertion and stops the execution if __test__ is .false. !! !! @note !! If ISO_C_BINDING module is available, the method calls the method abort from the C standard library. Doing so, !! developer is able to debug the source code by getting the backtrace of the execution. !! In other situation, the method simply uses the Fortran STOP statement which makes its usage... useless. LOGICAL, INTENT(in) :: test !! Expression to test. CHARACTER(len=*), INTENT(in) :: reason !! Optional assertion reason. IF (.NOT.test) THEN WRITE(stderr,'(a)') "assertion: "//reason call abort_() ENDIF END SUBROUTINE assert_r SUBROUTINE assert_w(test,where,reason) !! _Raise_ an assertion. !! !! The method raises an assertion and stops the execution if __test__ is .false. !! !! See [[errors(module):assert_r(subroutine)]] remark. LOGICAL, INTENT(in) :: test !! Expression to test. CHARACTER(len=*), INTENT(in) :: where !! Optional _location_ of the assertion. CHARACTER(len=*), INTENT(in) :: reason !! Optional assertion reason. IF (.NOT.test) THEN WRITE(stderr,'(a)') "assertion in "//where//": "//reason call abort_() ENDIF END SUBROUTINE assert_w FUNCTION free_lun() RESULT(lu) !> Get the first free logical unit !! !! The function loops from 7 to 9999 and returns the first free logical unit. !! @note !! According to Fortran standard, the maximum value for a lun is processor !! dependent. I just assume that [7,9999] is a valid range and I believe that !! 9992 files to be opened is far enough for any program ! !! @note !! If you intend to use loggers object from this library, you should keep in !! mind that loggers open files with the first free logical unit. Consequently !! if you need to perform I/O operations you should use this function to get a !! free lun instead of just randomly set a lun ! INTEGER :: lu !! First free logical unit in the range [7,9999] or -1 if no lun is available INTEGER, PARAMETER :: mxlu = 9999 LOGICAL :: notfree lu = 6 ; notfree = .true. DO WHILE(notfree.AND.lu<=mxlu) lu=lu+1 ; INQUIRE(unit=lu,OPENED=notfree) ENDDO IF (lu >= mxlu) lu = -1 END FUNCTION free_lun END MODULE ERRORS