SUBROUTINE message( routine_name, message_identifier, requested_action, & message_level, output_on_pe, file_id, flush ) !--------------------------------------------------------------------------------! ! This file is part of PALM. ! ! PALM is free software: you can redistribute it and/or modify it under the terms ! of the GNU General Public License as published by the Free Software Foundation, ! either version 3 of the License, or (at your option) any later version. ! ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY ! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR ! A PARTICULAR PURPOSE. See the GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License along with ! PALM. If not, see . ! ! Copyright 1997-2014 Leibniz Universitaet Hannover !--------------------------------------------------------------------------------! ! ! Current revisions: ! ----------------- ! ! ! Former revisions: ! ----------------- ! $Id: message.f90 1403 2014-05-09 14:52:24Z witha $ ! ! 1402 2014-05-09 14:25:13Z raasch ! formatting of messages modified ! ! 1384 2014-05-02 14:31:06Z raasch ! routine location_message added ! ! 1320 2014-03-20 08:40:49Z raasch ! ONLY-attribute added to USE-statements, ! kind-parameters added to all INTEGER and REAL declaration statements, ! revision history before 2012 removed, ! comment fields (!:) to be used for variable explanations added to ! all variable declaration statements ! ! 1036 2012-10-22 13:43:42Z raasch ! code put under GPL (PALM 3.9) ! ! 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 control_parameters, & ONLY: abort_mode, message_string USE kinds USE pegrid IMPLICIT NONE CHARACTER(LEN=6) :: message_identifier !: CHARACTER(LEN=*) :: routine_name !: CHARACTER(LEN=200) :: header_string !: CHARACTER(LEN=200) :: information_string_1 !: CHARACTER(LEN=200) :: information_string_2 !: INTEGER(iwp) :: file_id !: INTEGER(iwp) :: flush !: INTEGER(iwp) :: i !: INTEGER(iwp) :: message_level !: INTEGER(iwp) :: output_on_pe !: INTEGER(iwp) :: requested_action !: LOGICAL :: do_output !: LOGICAL :: pe_out_of_range !: do_output = .FALSE. pe_out_of_range = .FALSE. ! !-- 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 ! !-- 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/wiki/doc' // & '/app/errmsg#NC' ELSE information_string_2 = 'http://palm.muk.uni-hannover.de/wiki/doc' // & '/app/errmsg#' // message_identifier END IF ! !-- 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 #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 #endif ! !-- Now do the output IF ( do_output ) THEN IF ( file_id == 6 ) THEN ! !-- Output on stdout WRITE( *, '(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( *, '(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 ) WRITE( *, '(4X,A)' ) '' WRITE( *, '(4X,A)' ) TRIM( information_string_1 ) WRITE( *, '(4X,A)' ) TRIM( information_string_2 ) WRITE( *, '(4X,A)' ) '' ELSE ! !-- 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 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 ENDIF ! !-- Abort execution, if requested IF ( requested_action > 0 ) THEN abort_mode = requested_action CALL local_stop ENDIF END SUBROUTINE message SUBROUTINE location_message( location, advance ) !------------------------------------------------------------------------------! ! Description: ! ------------ ! Prints out the given location on stdout !------------------------------------------------------------------------------! USE, INTRINSIC :: ISO_FORTRAN_ENV, & ONLY : OUTPUT_UNIT USE pegrid, & ONLY : myid IMPLICIT NONE CHARACTER(LEN=*) :: location !: text to be output on stdout LOGICAL :: advance !: switch for advancing/noadvancing I/O IF ( myid == 0 ) THEN IF ( advance ) THEN WRITE ( OUTPUT_UNIT, '(6X,''--- '',A)' ) TRIM( location ) ELSE WRITE ( OUTPUT_UNIT, '(6X,''... '',A)', ADVANCE='NO' ) & TRIM( location ) ENDIF CALL local_flush( OUTPUT_UNIT ) ENDIF END SUBROUTINE location_message