source: trunk/LMDZ.TITAN/libf/muphytitan/errors.F90 @ 1862

Last change on this file since 1862 was 1814, checked in by jvatant, 7 years ago

Correct string management within muphy for ifort
JVO

File size: 9.2 KB
RevLine 
[1793]1! Copyright Jérémie Burgalat (2010-2015)
2!
3! burgalat.jeremie@gmail.com
4!
5! This software is a computer program whose purpose is to provide configuration
6! file and command line arguments parsing features to Fortran programs.
7!
8! This software is governed by the CeCILL-B license under French law and
9! abiding by the rules of distribution of free software.  You can  use,
10! modify and/ or redistribute the software under the terms of the CeCILL-B
11! license as circulated by CEA, CNRS and INRIA at the following URL
12! "http://www.cecill.info".
13!
14! As a counterpart to the access to the source code and  rights to copy,
15! modify and redistribute granted by the license, users are provided only
16! with a limited warranty  and the software's author,  the holder of the
17! economic rights,  and the successive licensors  have only  limited
18! liability.
19!
20! In this respect, the user's attention is drawn to the risks associated
21! with loading,  using,  modifying and/or developing or reproducing the
22! software by the user in light of its specific status of free software,
23! that may mean  that it is complicated to manipulate,  and  that  also
24! therefore means  that it is reserved for developers  and  experienced
25! professionals having in-depth computer knowledge. Users are therefore
26! encouraged to load and test the software's suitability as regards their
27! requirements in conditions enabling the security of their systems and/or
28! data to be ensured and,  more generally, to use and operate it in the
29! same conditions as regards security.
30!
31! The fact that you are presently reading this means that you have had
32! knowledge of the CeCILL-B license and that you accept its terms.
33
34!! file: errors.F90
35!! summary: Errors handling source file
36!! author: Burgalat
37!! date: 2013-2015
38
39#include "defined.h"
40
41MODULE ERRORS
42  !! Error handler module
43  !!
44  !! This module provides a single derived type, [[error(type)]] which is used in all
45  !! other parts of the library in order to handle errors.
46  USE, INTRINSIC :: ISO_C_BINDING
47  USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY : stdout=>OUTPUT_UNIT, stderr=>ERROR_UNIT
48
49  IMPLICIT NONE
50
51  PUBLIC
52
53  PRIVATE :: error_equals,error_equals_int,error_differs,error_differs_int, &
54             msg_length
55
56
57  INTEGER, PARAMETER :: msg_length = 250 !! Length of error message.
58
59  TYPE, PUBLIC :: error
60    !! Define an error
61    !!
62    !! The following derived type represents in the simplest way (I believe) an error which
63    !! stores:
64    !!
65    !! - An integer to numerically identify the error
66    !! - A string (250 chars max) with an appropriate error message
67    !! - A bounded procedure to get a string representation of the error (if bounded
68    !!   procedures are supported by the library).
69    !! - internal subroutines for derived type IO WRITE statement (if Derived IO
70    !!   subroutines are supported by the library).
71    !!
72    !! error type comes also with two operators ("==", "/=") to compare error type with
73    !! another one or an integer.
74    !! If an error is not initialized explicitly, then it is set to [[errors(module):noerror(variable)]].
75    CHARACTER(len=msg_length) :: msg = "No error"
76      !! Message associated to the error
77      !! @note
78      !! The message should be short (250 characters maximum) and explicit.
79    INTEGER :: id = 0
80      !! Numerical identifier of the error
81      !! @note
82      !! The error identifier is used to test the equality/inequality of two error objects.
83#if HAVE_FTNPROC
84    CONTAINS
85      PROCEDURE, PUBLIC :: to_string => error_to_string
86#endif
87  END TYPE error
88
89  INTERFACE
90    !! Clean subroutine interface
91    SUBROUTINE clean_callback(err)
92      !! A subroutine that may perform cleaning computation(s) before exit
93      IMPORT error
94      IMPLICIT NONE
95      TYPE(error), INTENT(in) :: err
96        !! An error object with the input error
97    END SUBROUTINE clean_callback
98  END INTERFACE
99
100  INTERFACE
101    subroutine abort_() bind(C, name="abort")
102    end subroutine
103  END INTERFACE
104
105  INTERFACE assert
106    !! _Raise_ an assertion.
107    !!
108    !! An assertion can be understood as a development error that should be raised in production mode.
109    MODULE PROCEDURE :: assert_r,assert_w
110  END INTERFACE assert
111
112  !> error equality operator
113  INTERFACE OPERATOR(==)
114    MODULE PROCEDURE error_equals, error_equals_int
115  END INTERFACE
116
117  !> error inequality operator
118  INTERFACE OPERATOR(/=)
119    MODULE PROCEDURE error_differs, error_differs_int
120  END INTERFACE
121
122  !> The no error error !
123  TYPE(error), PUBLIC, PARAMETER :: noerror = error("No error",0)
124
125  CONTAINS
126
127!===============================================================================
128! error TYPE RELATED METHODS
129!===============================================================================
130
131  FUNCTION error_equals(this, other) RESULT(res)
132    !! Check if two error objects are equivalent
133    TYPE(error), INTENT(in) :: this, & !! The first error object to compare
134                               other   !! The second error object to compare
135    LOGICAL :: res                     !! .true. if __this__ and __other__ identifiers are the same, .false. otherwise
136    res = (this%id == other%id)
137    RETURN
138  END FUNCTION error_equals
139
140  FUNCTION error_equals_int(this, id) RESULT(res)
141    !! Check if an error id is equal to a given integer
142    TYPE(error), INTENT(in) :: this !! An error object reference
143    INTEGER, INTENT(in)     :: id   !! An integer to compare to __this__ identifier
144    LOGICAL :: res                  !! .true. if __this__ identifier and __id__ have the same value, .false. otherwise
145    res = (this%id == id)
146    RETURN
147  END FUNCTION error_equals_int
148
149  FUNCTION error_differs(this, other) RESULT(res)
150    !! Check if two error objects are different
151    TYPE(error), INTENT(in) :: this, & !! The first error object to compare
152                               other   !! The second error object to compare
153    LOGICAL :: res                     !! .false. if __this__ and __other__ identifiers are the same, .true. otherwise
154    res = (this%id /= other%id)
155    RETURN
156  END FUNCTION error_differs
157
158  FUNCTION error_differs_int(this, id) RESULT(res)
159    !! Check if an error id is different from a given integer
160    TYPE(error), INTENT(in) :: this !! An error object reference
161    INTEGER, INTENT(in)     :: id   !! An integer to compare to __this__ identifier
162    LOGICAL :: res                  !! .false. if __this__ identifier and __id__ have the same value, .true. otherwise
163    res = (this%id /= id)
164    RETURN
165  END FUNCTION error_differs_int
166
167  FUNCTION error_to_string(this,progname,as_warning) RESULT(str)
168    !! (simple) String representation of the error
169    !!
170    !! The function returns a very simple formatted string with the error.
171    OBJECT(error), INTENT(in)              :: this
172      !! An error object reference
173    CHARACTER(len=*), INTENT(in), OPTIONAL :: progname
174      !! An optional string with the name of the program
175    LOGICAL, INTENT(in), OPTIONAL          :: as_warning
176      !! An optional boolean flag to print the message as warning rather than as error (default to .false.).
177    CHARACTER(len=:), ALLOCATABLE :: str
178      !! An allocatable string with the string representation of the error
179    CHARACTER(len=:), ALLOCATABLE :: pref
180    pref = "error: "
181    IF (PRESENT(as_warning)) THEN ; IF (as_warning) pref = "warning: " ; ENDIF
182    IF (PRESENT(progname)) THEN
183      IF (LEN_TRIM(progname) /=0) THEN
184        str = TRIM(progname)//': '//pref//TRIM(this%msg)
185      ELSE
186        str = pref//TRIM(this%msg)
187      ENDIF
188    ELSE
189      str = pref//TRIM(this%msg)
190    ENDIF
191    RETURN
192  END FUNCTION error_to_string
193
194  SUBROUTINE aborting(err)
195    !! Abort the program with specific exit code
196    !!
197    !! The method prints the message of the given error object and
198    !! stops the program using exit() subroutine.
199    TYPE(error), INTENT(in) :: err
200      !! An error object
201    IF (err /= 0) THEN
202      WRITE(*,'(a)') error_to_string(err)
[1814]203      CALL EXIT(abs(err%id))
[1793]204    ENDIF
205  END SUBROUTINE aborting
206
207  SUBROUTINE assert_r(test,reason)
208    !! _Raise_ an assertion.
209    !!
210    !! The method raises an assertion and stops the execution if __test__ is .false.
211    !!
212    !! @note
213    !! If ISO_C_BINDING module is available, the method calls the method abort from the C standard library. Doing so,
214    !! developer is able to debug the source code by getting the backtrace of the execution.
215    !! In other situation, the method simply uses the Fortran STOP statement which makes its usage... useless.
216   LOGICAL, INTENT(in)          :: test
217     !! Expression to test.
218   CHARACTER(len=*), INTENT(in) :: reason
219     !! Optional assertion reason.
220   IF (.NOT.test) THEN
221     WRITE(stderr,'(a)') "assertion: "//reason
222     call abort_()
223   ENDIF
224  END SUBROUTINE assert_r
225
226  SUBROUTINE assert_w(test,where,reason)
227    !! _Raise_ an assertion.
228    !!
229    !! The method raises an assertion and stops the execution if __test__ is .false.
230    !!
231    !! See [[errors(module):assert_r(subroutine)] remark.
232    LOGICAL, INTENT(in)         :: test
233     !! Expression to test.
234   CHARACTER(len=*), INTENT(in) :: where
235     !! Optional _location_ of the assertion.
236   CHARACTER(len=*), INTENT(in) :: reason
237     !! Optional assertion reason.
238   IF (.NOT.test) THEN
239     WRITE(stderr,'(a)') "assertion in "//where//": "//reason
240     call abort_()
241   ENDIF
242  END SUBROUTINE assert_w
243
244
245END MODULE ERRORS
246
Note: See TracBrowser for help on using the repository browser.