SUBROUTINE message( routine_name, message_identifier, requested_action, & message_level, output_on_pe, file_id, flush ) !------------------------------------------------------------------------------! ! Current revisions: ! ----------------- ! Weblink to error message database changed to new trac server ! ! Former revisions: ! ----------------- ! $Id: message.f90 563 2010-09-30 13:08:44Z gryschka $ ! ! 213 2008-11-13 10:26:18Z raasch ! Initial revision ! ! Description: ! ------------ ! Handling of the different kinds of messages. ! Meaning of formal parameters: ! requested_action: 0 - continue, 1 - abort by stop, 2 - abort by mpi_abort ! message_level: 0 - informative, 1 - warning, 2 - error ! output_on_pe: -1 - all, else - output on specified PE ! file_id: 6 - stdout (*) ! flush: 0 - no action, 1 - flush the respective output buffer !------------------------------------------------------------------------------! USE pegrid USE control_parameters IMPLICIT NONE CHARACTER(LEN=6) :: message_identifier CHARACTER(LEN=*) :: routine_name CHARACTER(LEN=200) :: header_string, information_string_1,information_string_2 INTEGER :: file_id, flush, i, message_level, output_on_pe, requested_action LOGICAL :: do_output, pe_out_of_range do_output = .FALSE. pe_out_of_range = .FALSE. ! print*, '#1' ! !-- Create the complete output string, starting with the message level IF ( message_level == 0 ) THEN header_string = '--- informative message --- ID:' ELSEIF ( message_level == 1 ) THEN header_string = '+++ warning message --- ID:' ELSEIF ( message_level == 2 ) THEN header_string = '+++ error message --- ID:' ELSE WRITE( header_string,'(A,I2)' ) '+++ unknown message level: ', & message_level ENDIF ! print*, '#2' ! !-- Add the message identifier and the generating routine header_string = TRIM( header_string ) // ' ' // message_identifier // & ' generated by routine: ' // TRIM( routine_name ) information_string_1 = 'Further information can be found at' IF(message_identifier(1:2) == 'NC') THEN information_string_2 = 'http://palm.muk.uni-hannover.de/doc' // & '/app/errmsg#NC' ELSE information_string_2 = 'http://palm.muk.uni-hannover.de/doc' // & '/app/errmsg#' // message_identifier END IF ! print*, '#3' ! !-- Output the output string and the corresponding message string which had !-- been already assigned in the calling subroutine. ! !-- First find out if output shall be done on this PE. IF ( output_on_pe == -1 ) THEN do_output = .TRUE. ELSEIF ( myid == output_on_pe ) THEN do_output = .TRUE. ENDIF ! print*, '#4' #if defined( __parallel ) ! !-- In case of illegal pe number output on pe0 IF ( output_on_pe > numprocs-1 ) THEN pe_out_of_range = .TRUE. IF ( myid == 0 ) do_output = .TRUE. ENDIF ! print*, '#5' #endif ! !-- Now do the output IF ( do_output ) THEN ! print*, '#6' IF ( file_id == 6 ) THEN ! !-- Output on stdout WRITE( *, '(A/)' ) TRIM( header_string ) ! print*, '#7' ! !-- Cut message string into pieces and output one piece per line. !-- Remove leading blanks. message_string = ADJUSTL( message_string ) i = INDEX( message_string, '&' ) DO WHILE ( i /= 0 ) WRITE( *, '(4X,A)' ) ADJUSTL( message_string(1:i-1) ) message_string = ADJUSTL( message_string(i+1:) ) i = INDEX( message_string, '&' ) ENDDO WRITE( *, '(4X,A)' ) TRIM( message_string ) ! print*, '#8' WRITE( *, '(4X,A)' ) '' WRITE( *, '(4X,A)' ) TRIM( information_string_1 ) WRITE( *, '(4X,A)' ) TRIM( information_string_2 ) WRITE( *, '(4X,A)' ) '' ELSE ! print*, '#9' ! !-- Output on requested file id (file must have been opened elsewhere!) WRITE( file_id, '(A/)' ) TRIM( header_string ) ! !-- Cut message string into pieces and output one piece per line. !-- Remove leading blanks. message_string = ADJUSTL( message_string ) i = INDEX( message_string, '&' ) DO WHILE ( i /= 0 ) WRITE( file_id, '(4X,A)' ) ADJUSTL( message_string(1:i-1) ) message_string = ADJUSTL( message_string(i+1:) ) i = INDEX( message_string, '&' ) ENDDO WRITE( file_id, '(4X,A)' ) TRIM( message_string ) WRITE( file_id, '(4X,A)' ) '' WRITE( file_id, '(4X,A)' ) TRIM( information_string_1 ) WRITE( file_id, '(4X,A)' ) TRIM( information_string_2 ) WRITE( file_id, '(4X,A)' ) '' ! !-- Flush buffer, if requested IF ( flush == 1 ) CALL local_flush( file_id ) ENDIF ! print*, '#10' IF ( pe_out_of_range ) THEN WRITE ( *, '(A)' ) '+++ WARNING from routine message:' WRITE ( *, '(A,I6,A)' ) ' PE ', output_on_pe, & ' choosed for output is larger ' WRITE ( *, '(A,I6)' ) ' than the maximum number of used PEs', & numprocs-1 WRITE ( *, '(A)' ) ' Output is done on PE0 instead' ENDIF ! print*, '#11' ENDIF ! !-- Abort execution, if requested ! print*, '#12' IF ( requested_action > 0 ) THEN abort_mode = requested_action CALL local_stop ENDIF ! print*, '#13' END SUBROUTINE message