|
CP2K 2.4 (Revision 12889)
|
00001 !-----------------------------------------------------------------------------! 00002 ! CP2K: A general program to perform molecular dynamics simulations ! 00003 ! Copyright (C) 2000 - 2013 CP2K developers group ! 00004 !-----------------------------------------------------------------------------! 00005 00006 ! ***************************************************************************** 00018 MODULE termination 00019 00020 USE cp_para_types, ONLY: cp_para_env_type 00021 USE f77_blas 00022 USE kinds, ONLY: default_path_length 00023 USE machine, ONLY: default_output_unit,& 00024 m_flush_internal 00025 USE message_passing, ONLY: mp_abort 00026 USE timings, ONLY: print_stack 00027 00028 IMPLICIT NONE 00029 00030 PRIVATE 00031 00032 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'termination' 00033 00034 INTEGER :: error_unit = default_output_unit 00035 00036 PUBLIC :: print_message,& 00037 set_error_unit,& 00038 stop_memory,& 00039 stop_program,& 00040 stop_read,& 00041 stop_write 00042 00043 INTERFACE stop_memory 00044 MODULE PROCEDURE stop_allocate,& 00045 stop_deallocate 00046 END INTERFACE 00047 00048 CONTAINS 00049 00050 ! ***************************************************************************** 00067 SUBROUTINE print_message(message,output_unit,declev,before,after) 00068 00069 CHARACTER(LEN=*), INTENT(IN) :: message 00070 INTEGER, INTENT(IN) :: output_unit 00071 INTEGER, INTENT(IN), OPTIONAL :: declev, before, after 00072 00073 INTEGER :: blank_lines_after, blank_lines_before, decoration_level, i, 00074 ibreak, ipos1, ipos2, maxrowlen, msglen, nrow, rowlen 00075 00076 IF (PRESENT(after)) THEN 00077 blank_lines_after = MAX(after,0) 00078 ELSE 00079 blank_lines_after = 1 00080 END IF 00081 00082 IF (PRESENT(before)) THEN 00083 blank_lines_before = MAX(before,0) 00084 ELSE 00085 blank_lines_before = 1 00086 END IF 00087 00088 IF (PRESENT(declev)) THEN 00089 decoration_level = MAX(declev,0) 00090 ELSE 00091 decoration_level = 0 00092 END IF 00093 00094 IF (decoration_level == 0) THEN 00095 rowlen = 78 00096 ELSE 00097 rowlen = 70 00098 END IF 00099 00100 msglen = LEN_TRIM(message) 00101 00102 ! Calculate number of rows 00103 00104 nrow = msglen/(rowlen + 1) + 1 00105 00106 ! Calculate appropriate row length 00107 00108 rowlen = MIN(msglen,rowlen) 00109 00110 ! Generate the blank lines before the message 00111 00112 DO i=1,blank_lines_before 00113 WRITE (UNIT=output_unit,FMT="(A)") "" 00114 END DO 00115 00116 ! Scan for the longest row 00117 00118 ipos1 = 1 00119 ipos2 = rowlen 00120 maxrowlen = 0 00121 00122 DO 00123 IF (ipos2 < msglen) THEN 00124 i = INDEX(message(ipos1:ipos2)," ",BACK=.TRUE.) 00125 IF (i == 0) THEN 00126 ibreak = ipos2 00127 ELSE 00128 ibreak = ipos1 + i - 2 00129 END IF 00130 ELSE 00131 ibreak = ipos2 00132 END IF 00133 00134 maxrowlen = MAX(maxrowlen,ibreak - ipos1 + 1) 00135 00136 ipos1 = ibreak + 2 00137 ipos2 = MIN(msglen,ipos1 + rowlen - 1) 00138 00139 ! When the last row is processed, exit loop 00140 00141 IF (ipos1 > msglen) EXIT 00142 00143 END DO 00144 00145 ! Generate the first set of star rows 00146 00147 IF (decoration_level > 1) THEN 00148 DO i=1,decoration_level-1 00149 WRITE (UNIT=output_unit,FMT="(T2,A)") REPEAT("*",maxrowlen+8) 00150 END DO 00151 END IF 00152 00153 ! Break long messages 00154 00155 ipos1 = 1 00156 ipos2 = rowlen 00157 00158 DO 00159 IF (ipos2 < msglen) THEN 00160 i = INDEX(message(ipos1:ipos2)," ",BACK=.TRUE.) 00161 IF (i == 0) THEN 00162 ibreak = ipos2 00163 ELSE 00164 ibreak = ipos1 + i - 2 00165 END IF 00166 ELSE 00167 ibreak = ipos2 00168 END IF 00169 00170 IF (decoration_level == 0) THEN 00171 WRITE (UNIT=output_unit,FMT="(T2,A)") message(ipos1:ibreak) 00172 ELSE IF (decoration_level > 0) THEN 00173 WRITE (UNIT=output_unit,FMT="(T2,A)")& 00174 "*** "//message(ipos1:ibreak)//REPEAT(" ",ipos1+maxrowlen-ibreak)//"***" 00175 END IF 00176 00177 ipos1 = ibreak + 2 00178 ipos2 = MIN(msglen,ipos1 + rowlen - 1) 00179 00180 ! When the last row is processed, exit loop 00181 00182 IF (ipos1 > msglen) EXIT 00183 END DO 00184 00185 ! Generate the second set star rows 00186 00187 IF (decoration_level > 1) THEN 00188 DO i=1,decoration_level-1 00189 WRITE (UNIT=output_unit,FMT="(T2,A)") REPEAT("*",maxrowlen+8) 00190 END DO 00191 END IF 00192 00193 ! Generate the blank lines after the message 00194 00195 DO i=1,blank_lines_after 00196 WRITE (UNIT=output_unit,FMT="(A)") "" 00197 END DO 00198 00199 END SUBROUTINE print_message 00200 00201 ! ***************************************************************************** 00207 SUBROUTINE set_error_unit(lunit) 00208 INTEGER, INTENT(IN) :: lunit 00209 00210 CHARACTER(LEN=*), PARAMETER :: routineN = 'set_error_unit', 00211 routineP = moduleN//':'//routineN 00212 00213 error_unit = lunit 00214 00215 END SUBROUTINE set_error_unit 00216 00217 ! ***************************************************************************** 00232 SUBROUTINE stop_allocate(routineN,moduleN,line_number,object,memory,para_env) 00233 00234 CHARACTER(LEN=*), INTENT(IN) :: routineN, moduleN 00235 INTEGER, INTENT(IN) :: line_number 00236 CHARACTER(LEN=*), INTENT(IN) :: object 00237 INTEGER, INTENT(IN) :: memory 00238 TYPE(cp_para_env_type), OPTIONAL, 00239 POINTER :: para_env 00240 00241 CHARACTER(LEN=default_path_length) :: message 00242 00243 IF (memory == 0) THEN 00244 message = "The memory allocation for the data object <"//TRIM(object)//& 00245 "> failed" 00246 ELSE 00247 WRITE (message,"(A,I0,A)")& 00248 "The memory allocation for the data object <"//TRIM(object)//& 00249 "> failed. The requested memory size is ",memory/1024," KB" 00250 END IF 00251 00252 IF (PRESENT(para_env)) THEN 00253 CALL stop_program(TRIM(routineN),TRIM(moduleN),line_number,TRIM(message),& 00254 para_env) 00255 ELSE 00256 CALL stop_program(TRIM(routineN),TRIM(moduleN),line_number,TRIM(message)) 00257 END IF 00258 00259 END SUBROUTINE stop_allocate 00260 00261 ! ***************************************************************************** 00274 SUBROUTINE stop_deallocate(routineN,moduleN,line_number,object,para_env) 00275 00276 CHARACTER(LEN=*), INTENT(IN) :: routineN, moduleN 00277 INTEGER, INTENT(IN) :: line_number 00278 CHARACTER(LEN=*), INTENT(IN) :: object 00279 TYPE(cp_para_env_type), OPTIONAL, 00280 POINTER :: para_env 00281 00282 CHARACTER(LEN=default_path_length) :: message 00283 00284 message = "The memory deallocation for the data object <"//TRIM(object)//& 00285 "> failed" 00286 00287 IF (PRESENT(para_env)) THEN 00288 CALL stop_program(TRIM(routineN),TRIM(moduleN),line_number,TRIM(message),& 00289 para_env) 00290 ELSE 00291 CALL stop_program(TRIM(routineN),TRIM(moduleN),line_number,TRIM(message)) 00292 END IF 00293 00294 END SUBROUTINE stop_deallocate 00295 00296 ! ***************************************************************************** 00304 SUBROUTINE stop_program(routineN,moduleN,line_number,error_message,& 00305 para_env) 00306 00307 CHARACTER(LEN=*), INTENT(IN) :: routineN, moduleN 00308 INTEGER, INTENT(IN) :: line_number 00309 CHARACTER(LEN=*), INTENT(IN) :: error_message 00310 TYPE(cp_para_env_type), OPTIONAL, 00311 POINTER :: para_env 00312 00313 CHARACTER(LEN=3*default_path_length) :: message 00314 LOGICAL :: ionode 00315 00316 IF (PRESENT(para_env)) THEN 00317 ionode = para_env%ionode 00318 ELSE 00319 ionode = .TRUE. 00320 END IF 00321 00322 ! Print the error message 00323 00324 IF (ionode) THEN 00325 message = "ERROR in "//TRIM(routineN)//& 00326 " (MODULE "//TRIM(moduleN)//")" 00327 CALL print_message(message,error_unit,2,2,0) 00328 CALL print_message(error_message,error_unit,1,1,0) 00329 WRITE (UNIT=message,FMT="(A,I0,A)")& 00330 "Program stopped at line number ",line_number,& 00331 " of MODULE "//TRIM(moduleN) 00332 CALL print_message(message,error_unit,1,1,0) 00333 CALL print_stack(error_unit) 00334 CALL m_flush_internal(default_output_unit) 00335 CALL m_flush_internal(error_unit) 00336 CALL mp_abort() 00337 END IF 00338 00339 END SUBROUTINE stop_program 00340 00341 ! ***************************************************************************** 00353 SUBROUTINE stop_read(routineN,moduleN,line_number,object,unit_number,& 00354 para_env) 00355 00356 CHARACTER(LEN=*), INTENT(IN) :: routineN, moduleN 00357 INTEGER, INTENT(IN) :: line_number 00358 CHARACTER(LEN=*), INTENT(IN) :: object 00359 INTEGER, INTENT(IN) :: unit_number 00360 TYPE(cp_para_env_type), OPTIONAL, 00361 POINTER :: para_env 00362 00363 CHARACTER(LEN=2*default_path_length) :: message 00364 CHARACTER(LEN=default_path_length) :: file_name 00365 LOGICAL :: file_exists 00366 00367 INQUIRE (UNIT=unit_number,EXIST=file_exists) 00368 IF (file_exists) THEN 00369 INQUIRE (UNIT=unit_number,NAME=file_name) 00370 WRITE (UNIT=message,FMT="(A)")& 00371 "An error occurred reading data object <"//TRIM(ADJUSTL(object))//& 00372 "> from file <"//TRIM(ADJUSTL(file_name))//">" 00373 ELSE 00374 WRITE (UNIT=message,FMT="(A,I0,A)")& 00375 "Could not read data object <"//TRIM(ADJUSTL(object))//& 00376 "> from logical unit ",unit_number,". The I/O unit does not exist." 00377 END IF 00378 00379 IF (PRESENT(para_env)) THEN 00380 CALL stop_program(TRIM(routineN),TRIM(moduleN),line_number,TRIM(message),& 00381 para_env) 00382 ELSE 00383 CALL stop_program(TRIM(routineN),TRIM(moduleN),line_number,TRIM(message)) 00384 END IF 00385 00386 END SUBROUTINE stop_read 00387 00388 ! ***************************************************************************** 00400 SUBROUTINE stop_write(routineN,moduleN,line_number,object,unit_number,& 00401 para_env) 00402 00403 CHARACTER(LEN=*), INTENT(IN) :: routineN, moduleN 00404 INTEGER, INTENT(IN) :: line_number 00405 CHARACTER(LEN=*), INTENT(IN) :: object 00406 INTEGER, INTENT(IN) :: unit_number 00407 TYPE(cp_para_env_type), OPTIONAL, 00408 POINTER :: para_env 00409 00410 CHARACTER(LEN=2*default_path_length) :: message 00411 CHARACTER(LEN=default_path_length) :: file_name 00412 LOGICAL :: file_exists 00413 00414 INQUIRE (UNIT=unit_number,EXIST=file_exists) 00415 IF (file_exists) THEN 00416 INQUIRE (UNIT=unit_number,NAME=file_name) 00417 WRITE (UNIT=message,FMT="(A)")& 00418 "An error occurred writing data object <"//TRIM(ADJUSTL(object))//& 00419 "> to file <"//TRIM(ADJUSTL(file_name))//">" 00420 ELSE 00421 WRITE (UNIT=message,FMT="(A,I0,A)")& 00422 "Could not write data object <"//TRIM(ADJUSTL(object))//& 00423 "> to logical unit ",unit_number,". The I/O unit does not exist." 00424 END IF 00425 00426 IF (PRESENT(para_env)) THEN 00427 CALL stop_program(TRIM(routineN),TRIM(moduleN),line_number,TRIM(message),& 00428 para_env) 00429 ELSE 00430 CALL stop_program(TRIM(routineN),TRIM(moduleN),line_number,TRIM(message)) 00431 END IF 00432 00433 END SUBROUTINE stop_write 00434 00435 END MODULE termination
1.7.3