source: trunk/LMDZ.PLUTO/libf/muphypluto/swift_errors.F90 @ 3590

Last change on this file since 3590 was 3560, checked in by debatzbr, 5 weeks ago

Addition of the microphysics model in moments.

File size: 9.8 KB
Line 
1! Copyright (c) Jeremie Burgalat (2013-2022)
2! Contributor: Jeremie Burgalat (jeremie.burgalat@univ-reims.fr).
3!
4! This file is part of SWIFT
5!
6! Permission is hereby granted, free of charge, to any person obtaining a copy of
7! this software and associated documentation files (the "Software"), to deal in
8! the Software without restriction, including without limitation the rights to
9! use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
10! the Software, and to permit persons to whom the Software is furnished to do so,
11! subject to the following conditions:
12!
13! The above copyright notice and this permission notice shall be included in all
14! copies or substantial portions of the Software.
15!
16! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
17! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
18! FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
19! COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
20! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
21! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
22
23!! File:    swift_errors.F90
24!! Summary: Errors handling source file.
25!! Author:  J. Burgalat
26!! Date:    2013-2022
27
28#include "swift_defined.h"
29
30MODULE SWIFT_ERRORS
31  !! Error handler module
32  !!
33  !! This module provides a single derived type, [[error(type)]] which is used in all
34  !! other parts of the library in order to handle errors.
35  USE, INTRINSIC :: ISO_C_BINDING
36  USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY : stdout=>OUTPUT_UNIT, stderr=>ERROR_UNIT
37
38  IMPLICIT NONE
39
40  PUBLIC
41
42  PRIVATE :: error_equals,error_equals_int,error_differs,error_differs_int, &
43             msg_length
44
45
46  INTEGER, PARAMETER :: msg_length = 250 !! Length of error message.
47
48  TYPE, PUBLIC :: error
49    !! Define an error
50    !!
51    !! The following derived type represents in the simplest way (I believe) an error which
52    !! stores:
53    !!
54    !! - An integer to numerically identify the error
55    !! - A string (250 chars max) with an appropriate error message
56    !! - A bounded procedure to get a string representation of the error (if bounded
57    !!   procedures are supported by the library).
58    !! - internal subroutines for derived type IO WRITE statement (if Derived IO
59    !!   subroutines are supported by the library).
60    !!
61    !! error type comes also with two operators ("==", "/=") to compare error type with
62    !! another one or an integer.
63    !! If an error is not initialized explicitly, then it is set to [[errors(module):noerror(variable)]].
64    CHARACTER(len=msg_length) :: msg = "No error"
65      !! Message associated to the error
66      !! @note
67      !! The message should be short (250 characters maximum) and explicit.
68    INTEGER :: id = 0
69      !! Numerical identifier of the error
70      !! @note
71      !! The error identifier is used to test the equality/inequality of two error objects.
72#if HAVE_FTNPROC
73    CONTAINS
74      PROCEDURE, PUBLIC :: to_string => error_to_string
75        !! Get a string representation of the error
76#endif
77  END TYPE error
78
79  INTERFACE
80    !! Clean subroutine interface
81    SUBROUTINE clean_callback(err)
82      !! A subroutine that may perform cleaning computation(s) before exit
83      IMPORT error
84      IMPLICIT NONE
85      TYPE(error), INTENT(in) :: err
86        !! An error object with the input error
87    END SUBROUTINE clean_callback
88  END INTERFACE
89
90  INTERFACE
91    subroutine abort_() bind(C, name="abort")
92    end subroutine
93  END INTERFACE
94
95  INTERFACE assert
96    !! _Raise_ an assertion.
97    !!
98    !! An assertion can be understood as a development error that should be raised in production mode.
99    MODULE PROCEDURE :: assert_r,assert_w
100  END INTERFACE assert
101
102  !> error equality operator
103  INTERFACE OPERATOR(==)
104    MODULE PROCEDURE error_equals, error_equals_int
105  END INTERFACE
106
107  !> error inequality operator
108  INTERFACE OPERATOR(/=)
109    MODULE PROCEDURE error_differs, error_differs_int
110  END INTERFACE
111
112  !> The no error error !
113  TYPE(error), PUBLIC, PARAMETER :: noerror = error("No error",0)
114
115  CONTAINS
116
117!===============================================================================
118! error TYPE RELATED METHODS
119!===============================================================================
120
121  FUNCTION error_equals(this, other) RESULT(res)
122    !! Check if two error objects are equivalent
123    TYPE(error), INTENT(in) :: this, & !! The first error object to compare
124                               other   !! The second error object to compare
125    LOGICAL :: res                     !! .true. if __this__ and __other__ identifiers are the same, .false. otherwise
126    res = (this%id == other%id)
127    RETURN
128  END FUNCTION error_equals
129
130  FUNCTION error_equals_int(this, id) RESULT(res)
131    !! Check if an error id is equal to a given integer
132    TYPE(error), INTENT(in) :: this !! An error object reference
133    INTEGER, INTENT(in)     :: id   !! An integer to compare to __this__ identifier
134    LOGICAL :: res                  !! .true. if __this__ identifier and __id__ have the same value, .false. otherwise
135    res = (this%id == id)
136    RETURN
137  END FUNCTION error_equals_int
138
139  FUNCTION error_differs(this, other) RESULT(res)
140    !! Check if two error objects are different
141    TYPE(error), INTENT(in) :: this, & !! The first error object to compare
142                               other   !! The second error object to compare
143    LOGICAL :: res                     !! .false. if __this__ and __other__ identifiers are the same, .true. otherwise
144    res = (this%id /= other%id)
145    RETURN
146  END FUNCTION error_differs
147
148  FUNCTION error_differs_int(this, id) RESULT(res)
149    !! Check if an error id is different from a given integer
150    TYPE(error), INTENT(in) :: this !! An error object reference
151    INTEGER, INTENT(in)     :: id   !! An integer to compare to __this__ identifier
152    LOGICAL :: res                  !! .false. if __this__ identifier and __id__ have the same value, .true. otherwise
153    res = (this%id /= id)
154    RETURN
155  END FUNCTION error_differs_int
156
157  FUNCTION error_to_string(this,progname,as_warning) RESULT(str)
158    !! (simple) String representation of the error
159    !!
160    !! The function returns a very simple formatted string with the error.
161    OBJECT(error), INTENT(in)              :: this
162      !! An error object reference
163    CHARACTER(len=*), INTENT(in), OPTIONAL :: progname
164      !! An optional string with the name of the program
165    LOGICAL, INTENT(in), OPTIONAL          :: as_warning
166      !! An optional boolean flag to print the message as warning rather than as error (default to .false.).
167    CHARACTER(len=:), ALLOCATABLE :: str
168      !! An allocatable string with the string representation of the error
169    CHARACTER(len=:), ALLOCATABLE :: pref
170    pref = "error: "
171    IF (PRESENT(as_warning)) THEN ; IF (as_warning) pref = "warning: " ; ENDIF
172    IF (PRESENT(progname)) THEN
173      IF (LEN_TRIM(progname) /=0) THEN
174        str = TRIM(progname)//': '//pref//TRIM(this%msg)
175      ELSE
176        str = pref//TRIM(this%msg)
177      ENDIF
178    ELSE
179      str = pref//TRIM(this%msg)
180    ENDIF
181    RETURN
182  END FUNCTION error_to_string
183
184  SUBROUTINE aborting(err)
185    !! Abort the program with specific exit code
186    !!
187    !! The method prints the message of the given error object and
188    !! stops the program using exit() subroutine.
189    TYPE(error), INTENT(in) :: err
190      !! An error object
191    IF (err /= 0) THEN
192      WRITE(*,'(a)') error_to_string(err)
193      CALL EXIT(err%id)
194    ENDIF
195  END SUBROUTINE aborting
196
197  SUBROUTINE assert_r(test,reason)
198    !! _Raise_ an assertion.
199    !!
200    !! The method raises an assertion and stops the execution if __test__ is .false.
201    !!
202    !! @note
203    !! If ISO_C_BINDING module is available, the method calls the method abort from the C standard library. Doing so,
204    !! developer is able to debug the source code by getting the backtrace of the execution.
205    !! In other situation, the method simply uses the Fortran STOP statement which makes its usage... useless.
206   LOGICAL, INTENT(in)          :: test
207     !! Expression to test.
208   CHARACTER(len=*), INTENT(in) :: reason
209     !! Optional assertion reason.
210   IF (.NOT.test) THEN
211     WRITE(stderr,'(a)') "assertion: "//reason
212     call abort_()
213   ENDIF
214  END SUBROUTINE assert_r
215
216  SUBROUTINE assert_w(test,where,reason)
217    !! _Raise_ an assertion.
218    !!
219    !! The method raises an assertion and stops the execution if __test__ is .false.
220    !!
221    !! See [[errors(module):assert_r(subroutine)]] remark.
222    LOGICAL, INTENT(in)         :: test
223     !! Expression to test.
224   CHARACTER(len=*), INTENT(in) :: where
225     !! Optional _location_ of the assertion.
226   CHARACTER(len=*), INTENT(in) :: reason
227     !! Optional assertion reason.
228   IF (.NOT.test) THEN
229     WRITE(stderr,'(a)') "assertion in "//where//": "//reason
230     call abort_()
231   ENDIF
232  END SUBROUTINE assert_w
233
234  FUNCTION free_lun() RESULT(lu)
235    !> Get the first free logical unit
236    !!
237    !! The function loops from 7 to 9999 and returns the first free logical unit.
238    !! @note
239    !! According to Fortran standard, the maximum value for a lun is processor
240    !! dependent. I just assume that [7,9999] is a valid range and I believe that
241    !! 9992 files to be opened is far enough for any program !
242    !! @note
243    !! If you intend to use loggers object from this library, you should keep in
244    !! mind that loggers open files with the first free logical unit. Consequently
245    !! if you need to perform I/O operations you should use this function to get a
246    !! free lun instead of just randomly set a lun !
247    INTEGER :: lu
248      !! First free logical unit in the range [7,9999]  or -1 if no lun is available
249    INTEGER, PARAMETER :: mxlu = 9999
250    LOGICAL :: notfree
251    lu = 6 ; notfree = .true.
252    DO WHILE(notfree.AND.lu<=mxlu)
253      lu=lu+1 ; INQUIRE(unit=lu,OPENED=notfree)
254    ENDDO
255    IF (lu >= mxlu) lu = -1
256  END FUNCTION free_lun
257
258END MODULE SWIFT_ERRORS
Note: See TracBrowser for help on using the repository browser.