From b24d92a099de93e8f88a3866e8024b4d09dfaaba Mon Sep 17 00:00:00 2001
From: Philippe WAUTELET <philippe.wautelet@aero.obs-mip.fr>
Date: Wed, 8 Apr 2020 11:59:48 +0200
Subject: [PATCH] Philippe 08/04/2020: add multiline Print_msg
---
src/LIB/SURCOUCHE/src/mode_msg.f90 | 174 ++++++++++++++++++++++++-----
1 file changed, 145 insertions(+), 29 deletions(-)
diff --git a/src/LIB/SURCOUCHE/src/mode_msg.f90 b/src/LIB/SURCOUCHE/src/mode_msg.f90
index 6532afab8..ed9314bf2 100644
--- a/src/LIB/SURCOUCHE/src/mode_msg.f90
+++ b/src/LIB/SURCOUCHE/src/mode_msg.f90
@@ -1,4 +1,4 @@
-!MNH_LIC Copyright 2017-2019 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC Copyright 2017-2020 CNRS, Meteo-France and Universite Paul Sabatier
!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
!MNH_LIC for details. version 1.
@@ -9,16 +9,61 @@
! P. Wautelet 27/02/2019: module extracted from mode_io.f90
! P. Wautelet 04/04/2019: force write on stderr for all processes in print_msg if abort
! P. Wautelet 02/07/2019: flush messages also for files opened with newunit (logical unit can be negative)
+! P. Wautelet 08/04/2020: add multiline Print_msg
!-----------------------------------------------------------------
-MODULE MODE_MSG
-!
-USE MODD_IO, ONLY: NVERB_FATAL, NVERB_ERROR, NVERB_WARNING, NVERB_INFO, NVERB_DEBUG
-!
-IMPLICIT NONE
-!
-CONTAINS
-!
-SUBROUTINE PRINT_MSG(KVERB,HDOMAIN,HSUBR,HMSG)
+module mode_msg
+
+use modd_io, only: NVERB_FATAL, NVERB_ERROR, NVERB_WARNING, NVERB_INFO, NVERB_DEBUG
+
+implicit none
+
+integer, parameter :: NMSGLGTMAX = 100 ! Maximum length for a message
+integer, parameter :: NMSGLLINEMAX = 10 ! Maximum number of lines for a message
+
+character(len=NMSGLGTMAX), dimension(NMSGLLINEMAX) :: cmnhmsg = ''
+
+interface Print_msg
+ module procedure Print_msg_1line, Print_msg_multi_cmnhmsg, Print_msg_multi
+end interface Print_msg
+
+
+contains
+
+subroutine Print_msg_1line( kverb, hdomain, hsubr, hmsg )
+ integer, intent(in) :: kverb !Verbosity level
+ character(len=*), intent(in) :: hdomain !Domain/category of message
+ character(len=*), intent(in) :: hsubr !Subroutine/function name
+ character(len=*), intent(in) :: hmsg !Message
+
+ call Print_msg_multi( kverb, hdomain, hsubr, [hmsg] )
+
+end subroutine Print_msg_1line
+
+
+subroutine Print_msg_multi_cmnhmsg( kverb, hdomain, hsubr )
+
+ integer, intent(in) :: kverb !Verbosity level
+ character(len=*), intent(in) :: hdomain !Domain/category of message
+ character(len=*), intent(in) :: hsubr !Subroutine/function name
+
+ integer :: ilines
+
+ !Find the last non empty line
+ ilines = size( cmnhmsg )
+ do while ( len_trim( cmnhmsg(ilines) ) == 0 )
+ ilines = ilines - 1
+ end do
+
+ call Print_msg_multi( kverb, hdomain, hsubr, cmnhmsg(1 : ilines) )
+
+ !Empty the message buffer
+ !This is necessary especially if the next call contain a shorter message
+ cmnhmsg(1 : ilines) = ''
+
+end subroutine Print_msg_multi_cmnhmsg
+
+
+subroutine Print_msg_multi( KVERB, HDOMAIN, HSUBR, HMSG )
!
USE ISO_FORTRAN_ENV, ONLY: ERROR_UNIT, OUTPUT_UNIT
!
@@ -26,20 +71,24 @@ USE MODD_CONF, ONLY: CPROGRAM
USE MODD_IO, ONLY: NIO_VERB, NIO_ABORT_LEVEL, NGEN_VERB, NGEN_ABORT_LEVEL, &
LVERB_OUTLST, LVERB_STDOUT, LVERB_ALLPRC, TFILE_OUTPUTLISTING
USE MODD_LUNIT, ONLY: TLUOUT0
-USE MODD_VAR_ll, ONLY: IP, NMNH_COMM_WORLD
+USE MODD_VAR_ll, ONLY: IP, NMNH_COMM_WORLD, NPROC
!
use modi_tools_c
!
-INTEGER, INTENT(IN) :: KVERB !Verbosity level
-CHARACTER(LEN=*),INTENT(IN) :: HDOMAIN !Domain/category of message
-CHARACTER(LEN=*),INTENT(IN) :: HSUBR !Subroutine/function name
-CHARACTER(LEN=*),INTENT(IN) :: HMSG !Message
+INTEGER, INTENT(IN) :: KVERB !Verbosity level
+CHARACTER(LEN=*), INTENT(IN) :: HDOMAIN !Domain/category of message
+CHARACTER(LEN=*), INTENT(IN) :: HSUBR !Subroutine/function name
+CHARACTER(LEN=*), dimension(:), INTENT(IN) :: HMSG !Message
!
-CHARACTER(LEN=8) :: YPRC
+character(len=2) :: ysz
+CHARACTER(LEN=2) :: YPRC
CHARACTER(LEN=9) :: YPRE
CHARACTER(LEN=30) :: YSUBR
+character(len=:), allocatable :: yformat
INTEGER :: IERR, IMAXVERB,IABORTLEVEL
INTEGER :: ILU
+integer :: ji
+integer :: ilines
LOGICAL :: GWRITE_OUTLST,GWRITE_STDOUT
!
!Determine if the process will write
@@ -80,7 +129,9 @@ SELECT CASE(HDOMAIN)
END SELECT
!
IF (KVERB>IMAXVERB) RETURN
-!
+
+ilines = size( hmsg )
+
SELECT CASE(KVERB)
CASE(NVERB_FATAL)
YPRE='FATAL: '
@@ -97,16 +148,81 @@ SELECT CASE(KVERB)
IF (GWRITE_OUTLST) WRITE(UNIT=ILU, FMT=*) 'ERROR: PRINT_MSG: wrong verbosity level'
END SELECT
!
-WRITE(YPRC,'( I8 )') IP-1
-!
YSUBR=TRIM(HSUBR)//':'
-IF (LVERB_ALLPRC) THEN
- IF (GWRITE_STDOUT) WRITE(UNIT=OUTPUT_UNIT,FMT="(A8,': ',A9,A30,A)") ADJUSTL(YPRC),YPRE,YSUBR,HMSG
- IF (GWRITE_OUTLST) WRITE(UNIT=ILU, FMT="(A8,': ',A9,A30,A)") ADJUSTL(YPRC),YPRE,YSUBR,HMSG
-ELSE
- IF (GWRITE_STDOUT) WRITE(UNIT=OUTPUT_UNIT,FMT="(A9,A30,A)") YPRE,YSUBR,HMSG
- IF (GWRITE_OUTLST) WRITE(UNIT=ILU, FMT="(A9,A30,A)") YPRE,YSUBR,HMSG
-END IF
+
+if ( ilines < 10 ) then
+ ysz = 'I1'
+else if ( ilines < 100 ) then
+ ysz = 'I2'
+else if ( ilines < 1000 ) then
+ ysz = 'I3'
+else
+ ysz = 'I4'
+end if
+
+if ( lverb_allprc ) then
+ if ( nproc < 10 ) then
+ yprc = 'I1'
+ else if ( nproc < 100 ) then
+ yprc = 'I2'
+ else if ( nproc < 1000 ) then
+ yprc = 'I3'
+ else if ( nproc < 10000 ) then
+ yprc = 'I4'
+ else if ( nproc < 100000 ) then
+ yprc = 'I5'
+ else if ( nproc < 1000000 ) then
+ yprc = 'I6'
+ else if ( nproc < 10000000 ) then
+ yprc = 'I7'
+ else
+ yprc = 'I8'
+ end if
+
+ if ( gwrite_stdout ) then
+ if ( ilines == 1 ) then
+ yformat = '(' // yprc // ','': '',a9,a30,a)'
+ Write( unit = output_unit, fmt = yformat ) ip, ypre, ysubr, hmsg
+ else
+ yformat = '(' // yprc // ','': '',a9,a30,' // ysz // ',''/'',' // ysz // ','': '',a)'
+ do ji = 1, ilines
+ Write( unit = output_unit, fmt = yformat ) ip, ypre, ysubr, ji, ilines, Trim( hmsg(ji) )
+ end do
+ end if
+ end if
+ if ( gwrite_outlst ) then
+ if ( ilines == 1 ) then
+ yformat = '(' // yprc // ','': '',a9,a30,a)'
+ Write( unit = ilu, fmt = yformat) ip, ypre, ysubr, hmsg
+ else
+ yformat = '(' // yprc // ','': '',a9,a30,' // ysz // ',''/'',' // ysz // ','': '',a)'
+ do ji = 1, ilines
+ Write( unit = ilu, fmt = yformat) ip, ypre, ysubr, ji, ilines, Trim( hmsg(ji) )
+ end do
+ end if
+ end if
+else
+ if ( gwrite_stdout ) then
+ if ( ilines == 1 ) then
+ Write( unit = output_unit, fmt = "(a9,a30,a)" ) ypre, ysubr, Trim( hmsg(1) )
+ else
+ yformat = '(a9,a30,' // ysz // ',''/'',' // ysz // ','': '',a)'
+ do ji = 1, ilines
+ Write(unit = output_unit, fmt = yformat ) ypre, ysubr, ji, ilines, Trim( hmsg(ji) )
+ end do
+ end if
+ end if
+ if ( gwrite_outlst ) then
+ if ( ilines == 1 ) then
+ Write( unit = ilu, fmt = "(a9,a30,a)") ypre, ysubr, Trim( hmsg(1) )
+ else
+ yformat = '(a9,a30,' // ysz // ',''/'',' // ysz // ','': '',a)'
+ do ji = 1, ilines
+ Write( unit = ilu, fmt = yformat) ypre, ysubr, ji, ilines, Trim( hmsg(ji) )
+ end do
+ end if
+ end if
+end if
!
IF (KVERB<=IABORTLEVEL) THEN
IF (GWRITE_STDOUT) WRITE(UNIT=OUTPUT_UNIT,FMT=*) 'ABORT asked by application '//TRIM(CPROGRAM)
@@ -130,6 +246,6 @@ IF (KVERB<=IABORTLEVEL) THEN
CALL ABORT
END IF
!
-END SUBROUTINE PRINT_MSG
-!
-END MODULE MODE_MSG
+end subroutine Print_msg_multi
+
+end module mode_msg
--
GitLab