source: palm/trunk/SOURCE/message.f90 @ 1054

 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 <http://www.gnu.org/licenses/>.
!
! Copyright 1997-2012  Leibniz University Hannover
!--------------------------------------------------------------------------------!
!
! Current revisions:
! -----------------
! 
!
! Former revisions:
! -----------------
! $Id: message.f90 1037 2012-10-22 14:10:22Z hoffmann $
!
! 1036 2012-10-22 13:43:42Z raasch
! code put under GPL (PALM 3.9)
!
! 746 2011-08-18 21:14:48Z letzel
! 'wiki' inserted into weblink path to error message database
! 
! 563 2010-09-30 13:08:44Z raasch
! Weblink to error message database changed to new trac server
!
! 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/wiki/doc' // &
                              '/app/errmsg#NC'
    ELSE
       information_string_2 = 'http://palm.muk.uni-hannover.de/wiki/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