[1682] | 1 | !> @file message.f90 |
---|
[4677] | 2 | !--------------------------------------------------------------------------------------------------! |
---|
[2696] | 3 | ! This file is part of the PALM model system. |
---|
[1036] | 4 | ! |
---|
[4677] | 5 | ! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General |
---|
| 6 | ! Public License as published by the Free Software Foundation, either version 3 of the License, or |
---|
| 7 | ! (at your option) any later version. |
---|
[1036] | 8 | ! |
---|
[4677] | 9 | ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the |
---|
| 10 | ! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General |
---|
| 11 | ! Public License for more details. |
---|
[1036] | 12 | ! |
---|
[4677] | 13 | ! You should have received a copy of the GNU General Public License along with PALM. If not, see |
---|
| 14 | ! <http://www.gnu.org/licenses/>. |
---|
[1036] | 15 | ! |
---|
[4828] | 16 | ! Copyright 1997-2021 Leibniz Universitaet Hannover |
---|
[4677] | 17 | !--------------------------------------------------------------------------------------------------! |
---|
[1036] | 18 | ! |
---|
[484] | 19 | ! Current revisions: |
---|
[213] | 20 | ! ----------------- |
---|
[4578] | 21 | ! |
---|
| 22 | ! |
---|
[1321] | 23 | ! Former revisions: |
---|
| 24 | ! ----------------- |
---|
| 25 | ! $Id: message.f90 4828 2021-01-05 11:21:41Z moh.hefny $ |
---|
[4677] | 26 | ! file re-formatted to follow the PALM coding standard |
---|
| 27 | ! |
---|
| 28 | ! 4580 2020-06-29 07:54:21Z raasch |
---|
[4580] | 29 | ! bugfix for aborts in case of nested runs |
---|
[4677] | 30 | ! |
---|
[4580] | 31 | ! 4578 2020-06-25 15:43:32Z gronemeier |
---|
[4578] | 32 | ! bugfix : do not save input values from last call of routines debug_message and location_message |
---|
| 33 | ! changes: layout changes according to PALM coding standards |
---|
| 34 | ! |
---|
| 35 | ! 4536 2020-05-17 17:24:13Z raasch |
---|
[4536] | 36 | ! location message format changed |
---|
[4578] | 37 | ! |
---|
[4536] | 38 | ! 4360 2020-01-07 11:25:50Z suehring |
---|
[4182] | 39 | ! Corrected "Former revisions" section |
---|
[4578] | 40 | ! |
---|
[4182] | 41 | ! 4097 2019-07-15 11:59:11Z suehring |
---|
[4097] | 42 | ! Avoid overlong lines - limit is 132 characters per line |
---|
[4578] | 43 | ! |
---|
[4097] | 44 | ! 3987 2019-05-22 09:52:13Z kanani |
---|
[3987] | 45 | ! Improved formatting of job logfile output, |
---|
| 46 | ! changed output of DEBUG file |
---|
[4578] | 47 | ! |
---|
[3987] | 48 | ! 3885 2019-04-11 11:29:34Z kanani |
---|
[4677] | 49 | ! Changes related to global restructuring of location messages and introduction of additional debug |
---|
| 50 | ! messages |
---|
[4578] | 51 | ! |
---|
[3885] | 52 | ! 3655 2019-01-07 16:51:22Z knoop |
---|
[3248] | 53 | ! Minor formating changes |
---|
[1321] | 54 | ! |
---|
[4182] | 55 | ! 213 2008-11-13 10:26:18Z raasch |
---|
| 56 | ! Initial revision |
---|
| 57 | ! |
---|
[213] | 58 | ! Description: |
---|
| 59 | ! ------------ |
---|
[1682] | 60 | !> Handling of the different kinds of messages. |
---|
| 61 | !> Meaning of formal parameters: |
---|
| 62 | !> requested_action: 0 - continue, 1 - abort by stop, 2 - abort by mpi_abort |
---|
[1764] | 63 | !> 3 - abort by mpi_abort using MPI_COMM_WORLD |
---|
[1682] | 64 | !> message_level: 0 - informative, 1 - warning, 2 - error |
---|
| 65 | !> output_on_pe: -1 - all, else - output on specified PE |
---|
| 66 | !> file_id: 6 - stdout (*) |
---|
[1808] | 67 | !> flush_file: 0 - no action, 1 - flush the respective output buffer |
---|
[4677] | 68 | !--------------------------------------------------------------------------------------------------! |
---|
| 69 | SUBROUTINE message( routine_name, message_identifier, requested_action, message_level, & |
---|
| 70 | output_on_pe, file_id, flush_file ) |
---|
[4578] | 71 | |
---|
[4677] | 72 | USE control_parameters, & |
---|
[1320] | 73 | ONLY: abort_mode, message_string |
---|
| 74 | |
---|
| 75 | USE kinds |
---|
| 76 | |
---|
[213] | 77 | USE pegrid |
---|
| 78 | |
---|
[4677] | 79 | USE pmc_interface, & |
---|
[1764] | 80 | ONLY: cpl_id, nested_run |
---|
| 81 | |
---|
[213] | 82 | IMPLICIT NONE |
---|
| 83 | |
---|
[1682] | 84 | CHARACTER(LEN=6) :: message_identifier !< |
---|
[1764] | 85 | CHARACTER(LEN=20) :: nest_string !< nest id information |
---|
[1682] | 86 | CHARACTER(LEN=*) :: routine_name !< |
---|
| 87 | CHARACTER(LEN=200) :: header_string !< |
---|
[3987] | 88 | CHARACTER(LEN=200) :: header_string_2 !< for message ID and routine name |
---|
[1682] | 89 | CHARACTER(LEN=200) :: information_string_1 !< |
---|
| 90 | CHARACTER(LEN=200) :: information_string_2 !< |
---|
[213] | 91 | |
---|
[1682] | 92 | INTEGER(iwp) :: file_id !< |
---|
[1808] | 93 | INTEGER(iwp) :: flush_file !< |
---|
[1682] | 94 | INTEGER(iwp) :: i !< |
---|
| 95 | INTEGER(iwp) :: message_level !< |
---|
| 96 | INTEGER(iwp) :: output_on_pe !< |
---|
| 97 | INTEGER(iwp) :: requested_action !< |
---|
[213] | 98 | |
---|
[1682] | 99 | LOGICAL :: do_output !< |
---|
| 100 | LOGICAL :: pe_out_of_range !< |
---|
[213] | 101 | |
---|
| 102 | |
---|
| 103 | do_output = .FALSE. |
---|
| 104 | pe_out_of_range = .FALSE. |
---|
| 105 | |
---|
| 106 | ! |
---|
[1764] | 107 | !-- In case of nested runs create the nest id informations |
---|
| 108 | IF ( nested_run ) THEN |
---|
| 109 | WRITE( nest_string, '(1X,A,I2.2)' ) 'from nest-id ', cpl_id |
---|
| 110 | ELSE |
---|
| 111 | nest_string = '' |
---|
| 112 | ENDIF |
---|
| 113 | ! |
---|
[213] | 114 | !-- Create the complete output string, starting with the message level |
---|
| 115 | IF ( message_level == 0 ) THEN |
---|
[4677] | 116 | header_string = '--- informative message' // TRIM(nest_string) // ' ---' |
---|
[213] | 117 | ELSEIF ( message_level == 1 ) THEN |
---|
[3987] | 118 | header_string = '+++ warning message' // TRIM(nest_string) // ' ---' |
---|
[213] | 119 | ELSEIF ( message_level == 2 ) THEN |
---|
[3987] | 120 | header_string = '+++ error message' // TRIM(nest_string) // ' ---' |
---|
[213] | 121 | ELSE |
---|
[4677] | 122 | WRITE( header_string,'(A,I2)' ) '+++ unknown message level' // & |
---|
| 123 | TRIM(nest_string) // ': ', message_level |
---|
[213] | 124 | ENDIF |
---|
| 125 | |
---|
| 126 | ! |
---|
| 127 | !-- Add the message identifier and the generating routine |
---|
[4677] | 128 | header_string_2 = 'ID: ' // message_identifier // & |
---|
[3987] | 129 | ' generated by routine: ' // TRIM( routine_name ) |
---|
[4578] | 130 | |
---|
[311] | 131 | information_string_1 = 'Further information can be found at' |
---|
[4677] | 132 | IF ( message_identifier(1:2) == 'NC' ) THEN |
---|
| 133 | information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc/app/errmsg#NC' |
---|
[311] | 134 | ELSE |
---|
[4677] | 135 | information_string_2 = 'http://palm.muk.uni-hannover.de/trac/wiki/doc/app/errmsg#' // & |
---|
| 136 | message_identifier |
---|
[1764] | 137 | ENDIF |
---|
[213] | 138 | |
---|
[4578] | 139 | |
---|
[213] | 140 | ! |
---|
[4677] | 141 | !-- Output the output string and the corresponding message string which had been already assigned in |
---|
| 142 | !-- the calling subroutine. |
---|
[213] | 143 | ! |
---|
| 144 | !-- First find out if output shall be done on this PE. |
---|
| 145 | IF ( output_on_pe == -1 ) THEN |
---|
| 146 | do_output = .TRUE. |
---|
| 147 | ELSEIF ( myid == output_on_pe ) THEN |
---|
| 148 | do_output = .TRUE. |
---|
| 149 | ENDIF |
---|
| 150 | #if defined( __parallel ) |
---|
| 151 | ! |
---|
| 152 | !-- In case of illegal pe number output on pe0 |
---|
| 153 | IF ( output_on_pe > numprocs-1 ) THEN |
---|
| 154 | pe_out_of_range = .TRUE. |
---|
| 155 | IF ( myid == 0 ) do_output = .TRUE. |
---|
| 156 | ENDIF |
---|
| 157 | #endif |
---|
| 158 | |
---|
| 159 | ! |
---|
| 160 | !-- Now do the output |
---|
| 161 | IF ( do_output ) THEN |
---|
[1402] | 162 | |
---|
[213] | 163 | IF ( file_id == 6 ) THEN |
---|
| 164 | ! |
---|
| 165 | !-- Output on stdout |
---|
[3987] | 166 | WRITE( *, '(16X,A)' ) TRIM( header_string ) |
---|
| 167 | WRITE( *, '(20X,A)' ) TRIM( header_string_2 ) |
---|
[213] | 168 | ! |
---|
| 169 | !-- Cut message string into pieces and output one piece per line. |
---|
| 170 | !-- Remove leading blanks. |
---|
| 171 | message_string = ADJUSTL( message_string ) |
---|
| 172 | i = INDEX( message_string, '&' ) |
---|
| 173 | DO WHILE ( i /= 0 ) |
---|
[3987] | 174 | WRITE( *, '(20X,A)' ) ADJUSTL( message_string(1:i-1) ) |
---|
[213] | 175 | message_string = ADJUSTL( message_string(i+1:) ) |
---|
| 176 | i = INDEX( message_string, '&' ) |
---|
| 177 | ENDDO |
---|
[3987] | 178 | WRITE( *, '(20X,A)' ) '' |
---|
| 179 | WRITE( *, '(20X,A)' ) TRIM( message_string ) |
---|
| 180 | WRITE( *, '(20X,A)' ) '' |
---|
[4578] | 181 | WRITE( *, '(20X,A)' ) TRIM( information_string_1 ) |
---|
| 182 | WRITE( *, '(20X,A)' ) TRIM( information_string_2 ) |
---|
[3987] | 183 | WRITE( *, '(20X,A)' ) '' |
---|
[213] | 184 | |
---|
| 185 | ELSE |
---|
| 186 | ! |
---|
| 187 | !-- Output on requested file id (file must have been opened elsewhere!) |
---|
| 188 | WRITE( file_id, '(A/)' ) TRIM( header_string ) |
---|
| 189 | ! |
---|
| 190 | !-- Cut message string into pieces and output one piece per line. |
---|
| 191 | !-- Remove leading blanks. |
---|
| 192 | message_string = ADJUSTL( message_string ) |
---|
| 193 | i = INDEX( message_string, '&' ) |
---|
| 194 | DO WHILE ( i /= 0 ) |
---|
| 195 | WRITE( file_id, '(4X,A)' ) ADJUSTL( message_string(1:i-1) ) |
---|
| 196 | message_string = ADJUSTL( message_string(i+1:) ) |
---|
| 197 | i = INDEX( message_string, '&' ) |
---|
| 198 | ENDDO |
---|
| 199 | WRITE( file_id, '(4X,A)' ) TRIM( message_string ) |
---|
[335] | 200 | WRITE( file_id, '(4X,A)' ) '' |
---|
[4578] | 201 | WRITE( file_id, '(4X,A)' ) TRIM( information_string_1 ) |
---|
| 202 | WRITE( file_id, '(4X,A)' ) TRIM( information_string_2 ) |
---|
[335] | 203 | WRITE( file_id, '(4X,A)' ) '' |
---|
[213] | 204 | ! |
---|
| 205 | !-- Flush buffer, if requested |
---|
[1808] | 206 | IF ( flush_file == 1 ) FLUSH( file_id ) |
---|
[213] | 207 | ENDIF |
---|
| 208 | |
---|
| 209 | IF ( pe_out_of_range ) THEN |
---|
[226] | 210 | WRITE ( *, '(A)' ) '+++ WARNING from routine message:' |
---|
[4677] | 211 | WRITE ( *, '(A,I6,A)' ) ' PE ', output_on_pe, ' choosed for output is larger ' |
---|
| 212 | WRITE ( *, '(A,I6)' ) ' than the maximum number of used PEs', numprocs-1 |
---|
[213] | 213 | WRITE ( *, '(A)' ) ' Output is done on PE0 instead' |
---|
| 214 | ENDIF |
---|
| 215 | |
---|
| 216 | ENDIF |
---|
| 217 | |
---|
| 218 | ! |
---|
| 219 | !-- Abort execution, if requested |
---|
| 220 | IF ( requested_action > 0 ) THEN |
---|
| 221 | abort_mode = requested_action |
---|
[4580] | 222 | ! |
---|
[4677] | 223 | !-- Since nested runs always use MPI_ABORT, let only the PE which output a message initiate the |
---|
| 224 | !-- abort. Others just wait. |
---|
[4580] | 225 | IF ( nested_run .AND. requested_action == 1 .AND. .NOT. do_output ) THEN |
---|
| 226 | #if defined( __parallel ) |
---|
| 227 | CALL MPI_BARRIER( comm2d, ierr ) |
---|
| 228 | #endif |
---|
| 229 | ELSE |
---|
| 230 | CALL local_stop |
---|
| 231 | ENDIF |
---|
[213] | 232 | ENDIF |
---|
| 233 | |
---|
[226] | 234 | END SUBROUTINE message |
---|
[1384] | 235 | |
---|
| 236 | |
---|
[3885] | 237 | !--------------------------------------------------------------------------------------------------! |
---|
[1384] | 238 | ! Description: |
---|
| 239 | ! ------------ |
---|
[1682] | 240 | !> Prints out the given location on stdout |
---|
[3885] | 241 | !--------------------------------------------------------------------------------------------------! |
---|
| 242 | SUBROUTINE location_message( location, message_type ) |
---|
[1384] | 243 | |
---|
[3885] | 244 | USE, INTRINSIC :: ISO_FORTRAN_ENV, & |
---|
[1764] | 245 | ONLY: OUTPUT_UNIT |
---|
[1402] | 246 | |
---|
[4578] | 247 | USE pegrid, & |
---|
| 248 | ONLY: myid |
---|
[1384] | 249 | |
---|
[3885] | 250 | USE pmc_interface, & |
---|
[3241] | 251 | ONLY: cpl_id |
---|
[1764] | 252 | |
---|
[1384] | 253 | IMPLICIT NONE |
---|
| 254 | |
---|
[4578] | 255 | CHARACTER(LEN=*) :: location !< text to be output on stdout |
---|
| 256 | CHARACTER(LEN=60) :: location_trimmed !< trimmed text to be output on stdout |
---|
| 257 | CHARACTER(LEN=*) :: message_type !< type of message; supported values: 'start', 'finished' |
---|
| 258 | CHARACTER(LEN=10) :: message_type_string !< formatted message-type string for output |
---|
| 259 | CHARACTER(LEN=8) :: system_time !< formatted system clock time |
---|
| 260 | CHARACTER(LEN=10) :: time !< current time of system |
---|
| 261 | |
---|
[1764] | 262 | ! |
---|
| 263 | !-- Output for nested runs only on the root domain |
---|
| 264 | IF ( cpl_id /= 1 ) RETURN |
---|
[1384] | 265 | |
---|
| 266 | IF ( myid == 0 ) THEN |
---|
[3885] | 267 | ! |
---|
| 268 | !-- Get system time for debug info output (helpful to estimate the required computing time for |
---|
[4578] | 269 | !-- specific parts of code) |
---|
[3885] | 270 | CALL date_and_time( TIME=time ) |
---|
[4578] | 271 | system_time = time(1:2) // ':' // time(3:4) // ':' // time(5:6) |
---|
[3885] | 272 | ! |
---|
[4578] | 273 | !-- Write message-type string depending on message_type |
---|
| 274 | message_type_string = REPEAT( '-', 10 ) |
---|
| 275 | IF ( TRIM( message_type ) == 'start' ) & |
---|
| 276 | message_type_string(2:) = TRIM( message_type ) // '----' |
---|
| 277 | IF ( TRIM( message_type ) == 'finished' ) & |
---|
| 278 | message_type_string(2:) = TRIM( message_type ) // '-' |
---|
[3885] | 279 | ! |
---|
[4578] | 280 | !-- Trim location text to a maximum of 60 chars |
---|
| 281 | !-- Note: if the length is set within the write format, the string is right-aligned; to trim and |
---|
| 282 | !-- left-align the output, we need to use this detour |
---|
| 283 | WRITE( location_trimmed, '(A)' ) ADJUSTL( TRIM( location ) ) |
---|
[3987] | 284 | ! |
---|
[3885] | 285 | !-- Write and flush debug location or info message to file |
---|
[4578] | 286 | WRITE( OUTPUT_UNIT, 200 ) system_time, message_type_string, TRIM( location_trimmed ) |
---|
[1808] | 287 | FLUSH( OUTPUT_UNIT ) |
---|
[3885] | 288 | ! |
---|
| 289 | !-- Message formats |
---|
[4578] | 290 | 200 FORMAT ( 3X, A, 3x, A, 3X, A ) |
---|
[3885] | 291 | |
---|
[1384] | 292 | ENDIF |
---|
| 293 | |
---|
| 294 | END SUBROUTINE location_message |
---|
[3246] | 295 | |
---|
| 296 | |
---|
[3885] | 297 | !--------------------------------------------------------------------------------------------------! |
---|
| 298 | ! Description: |
---|
| 299 | ! ------------ |
---|
| 300 | !> Prints out the given debug information to unit 9 (DEBUG files in temporary directory) |
---|
| 301 | !> for each PE on each domain. |
---|
| 302 | !--------------------------------------------------------------------------------------------------! |
---|
| 303 | SUBROUTINE debug_message( debug_string, message_type ) |
---|
| 304 | |
---|
| 305 | USE control_parameters, & |
---|
[3987] | 306 | ONLY: time_since_reference_point |
---|
[3885] | 307 | |
---|
| 308 | IMPLICIT NONE |
---|
| 309 | |
---|
[4578] | 310 | CHARACTER(LEN=*) :: debug_string !< debug message to be output to debug_output_unit |
---|
| 311 | CHARACTER(LEN=*) :: message_type !< type of message; supported values: 'start', 'end', 'info' |
---|
| 312 | CHARACTER(LEN=7) :: message_type_string !< formatted message-type string for output |
---|
| 313 | CHARACTER(LEN=8) :: system_time !< formatted system clock time |
---|
| 314 | CHARACTER(LEN=10) :: time !< current time of system |
---|
[3885] | 315 | |
---|
| 316 | INTEGER, PARAMETER :: debug_output_unit = 9 |
---|
| 317 | |
---|
| 318 | ! |
---|
| 319 | !-- Get system time for debug info output (helpful to estimate the required computing time for |
---|
[4578] | 320 | !-- specific parts of code) |
---|
[3885] | 321 | CALL date_and_time( TIME=time ) |
---|
[4578] | 322 | system_time = time(1:2) // ':' // time(3:4) // ':' // time(5:6) |
---|
[3885] | 323 | ! |
---|
[4578] | 324 | !-- Write message-type string depending on message_type |
---|
| 325 | message_type_string = REPEAT( '-', 7 ) |
---|
| 326 | IF ( TRIM( message_type ) == 'start' ) message_type_string(2:) = TRIM( message_type ) // '-' |
---|
| 327 | IF ( TRIM( message_type ) == 'end' ) message_type_string(2:) = TRIM( message_type ) // '---' |
---|
| 328 | IF ( TRIM( message_type ) == 'info' ) message_type_string(2:) = TRIM( message_type ) // '--' |
---|
[3885] | 329 | ! |
---|
| 330 | !-- Write and flush debug location or info message to file |
---|
[4578] | 331 | WRITE( debug_output_unit, 201 ) system_time, time_since_reference_point, & |
---|
| 332 | message_type_string, TRIM( debug_string ) |
---|
[3885] | 333 | FLUSH( debug_output_unit ) |
---|
| 334 | ! |
---|
| 335 | !-- Message formats |
---|
[3987] | 336 | 201 FORMAT ( 'System time: ', A, ' | simulated time (s): ', F12.3, ' | ', A, ' ', A ) |
---|
[3885] | 337 | |
---|
| 338 | END SUBROUTINE debug_message |
---|
| 339 | |
---|
| 340 | |
---|
[4677] | 341 | !--------------------------------------------------------------------------------------------------! |
---|
[3246] | 342 | ! Description: |
---|
| 343 | ! ------------ |
---|
[3247] | 344 | !> Abort routine for failures durin reading of namelists |
---|
[4677] | 345 | !--------------------------------------------------------------------------------------------------! |
---|
[3246] | 346 | SUBROUTINE parin_fail_message( location, line ) |
---|
| 347 | |
---|
[4677] | 348 | USE control_parameters, & |
---|
[3246] | 349 | ONLY: message_string |
---|
| 350 | |
---|
[3247] | 351 | USE kinds |
---|
| 352 | |
---|
[3246] | 353 | IMPLICIT NONE |
---|
| 354 | |
---|
| 355 | CHARACTER(LEN=*) :: location !< text to be output on stdout |
---|
| 356 | CHARACTER(LEN=*) :: line |
---|
| 357 | |
---|
[3247] | 358 | CHARACTER(LEN=80) :: line_dum |
---|
| 359 | |
---|
| 360 | INTEGER(iwp) :: line_counter |
---|
| 361 | |
---|
| 362 | line_dum = ' ' |
---|
| 363 | line_counter = 0 |
---|
| 364 | |
---|
| 365 | REWIND( 11 ) |
---|
[3248] | 366 | DO WHILE ( INDEX( line_dum, TRIM(line) ) == 0 ) |
---|
| 367 | READ ( 11, '(A)', END=20 ) line_dum |
---|
| 368 | line_counter = line_counter + 1 |
---|
[3247] | 369 | ENDDO |
---|
| 370 | |
---|
[4677] | 371 | 20 WRITE( message_string, '(A,I3,A)' ) 'Error(s) in NAMELIST '// TRIM(location) // & |
---|
| 372 | '&Reading fails on line ', line_counter, ' at&' // line |
---|
[3248] | 373 | CALL message( 'parin', 'PA0271', 1, 2, 0, 6, 0 ) |
---|
[3246] | 374 | |
---|
| 375 | END SUBROUTINE parin_fail_message |
---|