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 CONTAINS
8 
9   LOGICAL FUNCTION wrf_at_debug_level ( level )
10     IMPLICIT NONE
11     INTEGER , INTENT(IN) :: level
12     wrf_at_debug_level = ( level .LE. wrf_debug_level )
13     RETURN
14   END FUNCTION wrf_at_debug_level
15 
16   SUBROUTINE init_module_wrf_error
17   END SUBROUTINE init_module_wrf_error
18 
19 END MODULE module_wrf_error
20 
21 SUBROUTINE wrf_message( str )
22   IMPLICIT NONE
23   CHARACTER*(*) str
24 #if defined( DM_PARALLEL ) && ! defined( STUBMPI) && (DA_CORE != 1)
25   ! wrfvar does not want information messages going to stderr stream
26   write(0,*) TRIM(str)
27 #endif
28   print*, TRIM(str)
29 END SUBROUTINE wrf_message
30 
31 ! intentionally write to stderr only
32 SUBROUTINE wrf_message2( str )
33   IMPLICIT NONE
34   CHARACTER*(*) str
35   write(0,*) str
36 END SUBROUTINE wrf_message2
37 
38 SUBROUTINE wrf_error_fatal3( file_str, line, str )
39   USE module_wrf_error
40   IMPLICIT NONE
41   CHARACTER*(*) file_str
42   INTEGER , INTENT (IN) :: line  ! only print file and line if line > 0
43   CHARACTER*(*) str
44   CHARACTER*256 :: line_str
45 
46   write(line_str,'(i6)') line
47 #if defined( DM_PARALLEL ) && ! defined( STUBMPI )
48   CALL wrf_message( '-------------- FATAL CALLED ---------------' )
49   ! only print file and line if line is positive
50   IF ( line > 0 ) THEN
51     CALL wrf_message( 'FATAL CALLED FROM FILE:  '//file_str//'  LINE:  '//TRIM(line_str) )
52   ENDIF
53   CALL wrf_message( str )
54   CALL wrf_message( '-------------------------------------------' )
55 #else
56   CALL wrf_message2( '-------------- FATAL CALLED ---------------' )
57   ! only print file and line if line is positive
58   IF ( line > 0 ) THEN
59     CALL wrf_message( 'FATAL CALLED FROM FILE:  '//file_str//'  LINE:  '//TRIM(line_str) )
60   ENDIF
61   CALL wrf_message2( str )
62   CALL wrf_message2( '-------------------------------------------' )
63 #endif
64   CALL wrf_abort
65 END SUBROUTINE wrf_error_fatal3
66 
67 SUBROUTINE wrf_error_fatal( str )
68   USE module_wrf_error
69   IMPLICIT NONE
70   CHARACTER*(*) str
71   CALL wrf_error_fatal3 ( ' ', 0, str )
72 END SUBROUTINE wrf_error_fatal
73 
74 ! Check to see if expected value == actual value
75 ! If not, print message and exit.  
76 SUBROUTINE wrf_check_error( expected, actual, str, file_str, line )
77   USE module_wrf_error
78   IMPLICIT NONE
79   INTEGER , INTENT (IN) :: expected
80   INTEGER , INTENT (IN) :: actual
81   CHARACTER*(*) str
82   CHARACTER*(*) file_str
83   INTEGER , INTENT (IN) :: line
84   CHARACTER (LEN=512)   :: rc_str
85   CHARACTER (LEN=512)   :: str_with_rc
86 
87   IF ( expected .ne. actual ) THEN
88     WRITE (rc_str,*) '  Routine returned error code = ',actual
89     str_with_rc = TRIM(str // rc_str)
90     CALL wrf_error_fatal3 ( file_str, line, str_with_rc )
91   ENDIF
92 END SUBROUTINE wrf_check_error
93 
94