1! 2! Copyright (C) Quantum ESPRESSO group 3! 4! This file is distributed under the terms of the 5! GNU General Public License. See the file `License' 6! in the root directory of the present distribution, 7! or http://www.gnu.org/copyleft/gpl.txt . 8! 9!---------------------------------------------------------------------------- 10SUBROUTINE errore( calling_routine, message, ierr ) 11 !---------------------------------------------------------------------------- 12 ! 13 ! ... This is a simple routine which writes an error message to output: 14 ! ... if ierr <= 0 it does nothing, 15 ! ... if ierr > 0 it stops. 16 ! 17 ! ... **** Important note for parallel execution *** 18 ! 19 ! ... in parallel execution unit 6 is written only by the first node; 20 ! ... all other nodes have unit 6 redirected to nothing (/dev/null). 21 ! ... As a consequence an error not occurring on the first node 22 ! ... will be invisible. For T3E and ORIGIN machines, this problem 23 ! ... is solved by writing an error message to unit * instead of 6. 24 ! ... Whenever possible (IBM SP machines), we write to the standard 25 ! ... error, unit 0 (the message will appear in the error files 26 ! ... produced by loadleveler). 27 ! 28 USE util_param 29#if defined(__PTRACE) && defined(__INTEL_COMPILER) 30 USE ifcore, ONLY : tracebackqq 31#endif 32 USE mp, ONLY : mp_abort, mp_rank 33 IMPLICIT NONE 34 ! 35 CHARACTER(LEN=*), INTENT(IN) :: calling_routine, message 36 ! the name of the calling calling_routine 37 ! the output message 38 INTEGER, INTENT(IN) :: ierr 39 ! the error flag 40 INTEGER :: crashunit, mpime 41 INTEGER, EXTERNAL :: find_free_unit 42 CHARACTER(LEN=6) :: cerr 43 ! 44 IF( ierr <= 0 ) RETURN 45 ! 46 ! ... the error message is written un the "*" unit 47 ! 48 WRITE( cerr, FMT = '(I6)' ) ierr 49 WRITE( UNIT = *, FMT = '(/,1X,78("%"))' ) 50 WRITE( UNIT = *, FMT = '(5X,"Error in routine ",A," (",A,"):")' ) & 51 TRIM(calling_routine), TRIM(ADJUSTL(cerr)) 52 WRITE( UNIT = *, FMT = '(5X,A)' ) TRIM(message) 53 WRITE( UNIT = *, FMT = '(1X,78("%"),/)' ) 54 ! 55#if defined (__MPI) && defined (__AIX) 56 ! 57 ! ... in the case of ibm machines it is also written on the "0" unit 58 ! ... which is automatically connected to stderr 59 ! 60 WRITE( UNIT = 0, FMT = '(/,1X,78("%"))') 61 WRITE( UNIT = 0, FMT = '(5X,"Error in routine ",A," (",A,"):")' ) & 62 TRIM(calling_routine), TRIM(ADJUSTL(cerr)) 63 WRITE( UNIT = 0, FMT = '(5X,A)' ) TRIM(message) 64 WRITE( UNIT = 0, FMT = '(1X,78("%"),/)' ) 65 ! 66#endif 67 ! 68 WRITE( *, '(" stopping ...")' ) 69 ! 70 FLUSH( stdout ) 71 ! 72#if defined(__PTRACE) 73#if defined(__INTEL_COMPILER) 74 call tracebackqq(user_exit_code=-1) 75#elif __GFORTRAN__ 76#if (__GNUC__>4) || ((__GNUC__==4) && (__GNUC_MINOR__>=8)) 77 call backtrace 78#endif 79#else 80 WRITE( UNIT = 0, FMT = '(5X,A)' ) "Printing strace..." 81 CALL ptrace() 82#endif 83#endif 84! 85#if defined(__MPI) 86 ! 87 mpime = mp_rank(MPI_COMM_WORLD) 88 ! 89 ! .. write the message to a file and close it before exiting 90 ! .. this will prevent loss of information on systems that 91 ! .. do not flush the open streams 92 ! .. added by C.C. 93 ! 94 crashunit = find_free_unit () 95 OPEN( UNIT = crashunit, FILE = crash_file, & 96 POSITION = 'APPEND', STATUS = 'UNKNOWN' ) 97 ! 98 WRITE( UNIT = crashunit, FMT = '(/,1X,78("%"))' ) 99 WRITE( UNIT = crashunit, FMT = '(5X,"task #",I10)' ) mpime 100 WRITE( UNIT = crashunit, & 101 FMT = '(5X,"from ",A," : error #",I10)' ) calling_routine, ierr 102 WRITE( UNIT = crashunit, FMT = '(5X,A)' ) message 103 WRITE( UNIT = crashunit, FMT = '(1X,78("%"),/)' ) 104 ! 105 CLOSE( UNIT = crashunit ) 106 ! 107 ! ... try to exit in a smooth way 108 ! 109 CALL mp_abort(1,MPI_COMM_WORLD) 110 ! 111#endif 112 ! 113 STOP 1 114 ! 115 RETURN 116 ! 117END SUBROUTINE errore 118! 119!---------------------------------------------------------------------- 120SUBROUTINE infomsg( routine, message ) 121 !---------------------------------------------------------------------- 122 ! 123 ! ... This is a simple routine which writes an info message 124 ! ... from a given routine to output. 125 ! 126 USE util_param 127 ! 128 IMPLICIT NONE 129 ! 130 CHARACTER (LEN=*) :: routine, message 131 ! the name of the calling routine 132 ! the output message 133 ! 134! IF ( ionode ) THEN !if not ionode it is redirected to /dev/null anyway 135 ! 136 WRITE( stdout , '(5X,"Message from routine ",A,":")' ) routine 137 WRITE( stdout , '(5X,A)' ) message 138 ! 139! END IF 140 ! 141 RETURN 142 ! 143END SUBROUTINE infomsg 144! 145module error_handler 146 implicit none 147 private 148 149 public :: init_error, add_name, chop_name, error_mem, warning 150 151 type chain 152 character (len=35) :: routine_name 153 type(chain), pointer :: previous_link 154 end type chain 155 156 type(chain), pointer :: routine_chain 157 158contains 159 160 subroutine init_error(routine_name) 161 implicit none 162 character (len=*), intent(in) :: routine_name 163 164 allocate(routine_chain) 165 166 routine_chain%routine_name = routine_name 167 nullify(routine_chain%previous_link) 168 169 return 170 end subroutine init_error 171 172 subroutine add_name(routine_name) 173 implicit none 174 character (len=*), intent(in) :: routine_name 175 type(chain), pointer :: new_link 176 177 allocate(new_link) 178 new_link%routine_name = routine_name 179 new_link%previous_link => routine_chain 180 routine_chain => new_link 181 182 return 183 end subroutine add_name 184 185 subroutine chop_name 186 implicit none 187 type(chain), pointer :: chopped_chain 188 189 chopped_chain => routine_chain%previous_link 190 deallocate(routine_chain) 191 routine_chain => chopped_chain 192 193 return 194 end subroutine chop_name 195 196 recursive subroutine trace_back(error_code) 197 198 implicit none 199 integer :: error_code 200 201 write(unit=*,fmt=*) " Called by ", routine_chain%routine_name 202 if (.not.associated(routine_chain%previous_link)) then 203 write(unit=*,fmt=*) & 204 " +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++" 205 write(unit=*,fmt=*) " " 206 if( error_code > 0 ) then 207 stop 208 else 209 return 210 end if 211 end if 212 213 routine_chain => routine_chain%previous_link 214 call trace_back(error_code) 215 216 end subroutine trace_back 217 218 subroutine error_mem(message,error_code) 219 character (len=*), intent(in) :: message 220 integer, intent(in), optional :: error_code 221 integer :: action_code 222 type(chain), pointer :: save_chain 223 224 if (present(error_code)) then 225 action_code = error_code 226 else 227 action_code = 1 228 end if 229 230 if( action_code /= 0 ) then 231 write(unit=*,fmt=*) " " 232 write(unit=*,fmt=*) & 233 " +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++" 234 235 if( action_code > 0 ) then 236 write(unit=*,fmt=*) " Fatal error in routine `", & 237 trim(routine_chain%routine_name),"': ",message 238 else 239 write(unit=*,fmt=*) " Warning from routine `", & 240 trim(routine_chain%routine_name),"': ",message 241 save_chain => routine_chain 242 end if 243 write(unit=*,fmt=*) & 244 " +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++" 245 routine_chain => routine_chain%previous_link 246 call trace_back(action_code) 247 routine_chain => save_chain 248 end if 249 250 return 251 end subroutine error_mem 252 253 subroutine warning(message) 254 character (len=*), intent(in) :: message 255 call error_mem(message,-1) 256 return 257 end subroutine warning 258 259end module error_handler 260