Line data    Source code

       1             : #include "logging.h"
       2             : !> \file mo_message.f90
       3             : !> \brief \copybrief mo_message
       4             : !> \details \copydetails mo_message
       5             : 
       6             : !> \brief Write out concatenated strings
       7             : !> \details Write out several strings concatenated on standard out or a given unit, either advancing or not.
       8             : !> \author Matthias Cuntz, Sebastian Mueller
       9             : !> \date Jul 2011, Dec 2019
      10             : !> \copyright Copyright 2005-\today, the CHS Developers, Sabine Attinger: All rights reserved.
      11             : !! FORCES is released under the LGPLv3+ license \license_note
      12             : MODULE mo_message
      13             : 
      14             :   use mo_logging
      15             :   USE mo_constants, ONLY : nout, nerr
      16             : 
      17             :   IMPLICIT NONE
      18             : 
      19             :   PRIVATE
      20             : 
      21             :   PUBLIC :: message         ! versatile routine to write out strings in file or on screen
      22             :   PUBLIC :: error_message   ! write error message to ERROR_UNIT and call stop 1
      23             : 
      24             :   logical, public, save :: show_msg = .true. !< global control switch to show normal messages
      25             :   logical, public, save :: show_err = .true. !< global control switch to show error messages
      26             : 
      27             :   ! ------------------------------------------------------------------
      28             : 
      29             : CONTAINS
      30             : 
      31          12 :   function process_arguments(t01, t02, t03, t04, t05, t06, t07, t08, t09, t10, t11, t12, t13, t14, t15, t16) result(outString)
      32             : 
      33             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t01
      34             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t02
      35             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t03
      36             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t04
      37             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t05
      38             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t06
      39             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t07
      40             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t08
      41             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t09
      42             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t10
      43             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t11
      44             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t12
      45             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t13
      46             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t14
      47             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t15
      48             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t16
      49             : 
      50             :     CHARACTER(len = 32000) :: outString
      51             : 
      52          12 :     outString = ''
      53             :     ! start from back so that trim does not remove user desired blanks
      54           0 :     if (present(t16)) outString = t16 // trim(outString)
      55          12 :     if (present(t15)) outString = t15 // trim(outString)
      56          12 :     if (present(t14)) outString = t14 // trim(outString)
      57          12 :     if (present(t13)) outString = t13 // trim(outString)
      58          12 :     if (present(t12)) outString = t12 // trim(outString)
      59          12 :     if (present(t11)) outString = t11 // trim(outString)
      60          12 :     if (present(t10)) outString = t10 // trim(outString)
      61          12 :     if (present(t09)) outString = t09 // trim(outString)
      62          12 :     if (present(t08)) outString = t08 // trim(outString)
      63          12 :     if (present(t07)) outString = t07 // trim(outString)
      64          12 :     if (present(t06)) outString = t06 // trim(outString)
      65          12 :     if (present(t05)) outString = t05 // trim(outString)
      66          12 :     if (present(t04)) outString = t04 // trim(outString)
      67          12 :     if (present(t03)) outString = t03 // trim(outString)
      68          12 :     if (present(t02)) outString = t02 // trim(outString)
      69          12 :     if (present(t01)) outString = t01 // trim(outString)
      70             : 
      71          12 :   end function process_arguments
      72             : 
      73             : 
      74             :   !> \brief Write out an error message to stdout
      75          22 :   SUBROUTINE message(t01, t02, t03, t04, t05, t06, t07, t08, t09, t10, t11, t12, t13, t14, t15, t16, &
      76             :     uni, advance, show, reset_format)
      77             : 
      78             :     IMPLICIT NONE
      79             : 
      80             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t01  !< optional string arguments
      81             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t02  !< optional string arguments
      82             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t03  !< optional string arguments
      83             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t04  !< optional string arguments
      84             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t05  !< optional string arguments
      85             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t06  !< optional string arguments
      86             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t07  !< optional string arguments
      87             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t08  !< optional string arguments
      88             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t09  !< optional string arguments
      89             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t10  !< optional string arguments
      90             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t11  !< optional string arguments
      91             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t12  !< optional string arguments
      92             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t13  !< optional string arguments
      93             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t14  !< optional string arguments
      94             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t15  !< optional string arguments
      95             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t16  !< optional string arguments
      96             :     INTEGER, INTENT(IN), OPTIONAL :: uni  !< Unit to write to (default: stdout)
      97             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: advance  !< add linebreak after message, default: 'yes', else 'no'
      98             :     LOGICAL, INTENT(IN), OPTIONAL :: show  !< control if message should be shown (show_msg as default)
      99             :     LOGICAL, INTENT(IN), OPTIONAL :: reset_format  !< Reset formatting (default: .false.)
     100             : 
     101             :     CHARACTER(len = 32000) :: outString
     102             :     CHARACTER(len = 10) :: format_string
     103             :     INTEGER :: uni_
     104             :     CHARACTER(len = 3) :: advance_
     105             :     logical :: reset_format_, show_
     106             : 
     107          22 :     show_ = show_msg
     108          10 :     if ( present(show) ) show_ = show
     109             :     ! short circuit if message should not be shown
     110          22 :     if (.not. show_ ) return
     111             : 
     112          12 :     uni_ = nout
     113          12 :     advance_ = 'yes'
     114          12 :     reset_format_ = .false.
     115          12 :     if ( present(uni) ) uni_ = uni
     116          12 :     if ( present(advance) ) advance_ = advance
     117          12 :     if ( present(reset_format) ) reset_format_ = reset_format
     118             : 
     119         182 :     outString = process_arguments(t01, t02, t03, t04, t05, t06, t07, t08, t09, t10, t11, t12, t13, t14, t15, t16)
     120             : 
     121          12 :     if ( reset_format_ ) then
     122           0 :       format_string = ""
     123           0 :       call stput(format_string, "0")
     124           0 :       outString = trim(format_string) // outString
     125             :     end if
     126             : 
     127          12 :     write(uni_, '(a)', advance = advance_) trim(outString)
     128             : 
     129          34 :   END SUBROUTINE message
     130             : 
     131             :   !> \brief Write out an error message to stderr and call stop 1.
     132           0 :   SUBROUTINE error_message(t01, t02, t03, t04, t05, t06, t07, t08, t09, t10, t11, t12, t13, t14, t15, t16, &
     133             :     uni, advance, show, raise, reset_format)
     134             : 
     135             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t01  !< optional string arguments
     136             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t02  !< optional string arguments
     137             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t03  !< optional string arguments
     138             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t04  !< optional string arguments
     139             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t05  !< optional string arguments
     140             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t06  !< optional string arguments
     141             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t07  !< optional string arguments
     142             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t08  !< optional string arguments
     143             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t09  !< optional string arguments
     144             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t10  !< optional string arguments
     145             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t11  !< optional string arguments
     146             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t12  !< optional string arguments
     147             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t13  !< optional string arguments
     148             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t14  !< optional string arguments
     149             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t15  !< optional string arguments
     150             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: t16  !< optional string arguments
     151             :     INTEGER, INTENT(IN), OPTIONAL :: uni  !< Unit to write to (default: stderr)
     152             :     CHARACTER(len = *), INTENT(IN), OPTIONAL :: advance  !< add linebreak after message, default: 'yes', else 'no'
     153             :     LOGICAL, INTENT(IN), OPTIONAL :: show  !< control if message should be shown (show_err as default)
     154             :     LOGICAL, INTENT(IN), OPTIONAL :: raise  !< control if an exception is raised with error code 1 (.true. as default)
     155             :     LOGICAL, INTENT(IN), OPTIONAL :: reset_format  !< Reset formatting (default: .false.)
     156             : 
     157             :     INTEGER :: uni_
     158             :     logical :: show_, raise_
     159             : 
     160           0 :     show_ = show_err
     161           0 :     raise_ = .true.
     162           0 :     uni_ = nerr
     163           0 :     if ( present(show) ) show_ = show
     164           0 :     if ( present(raise) ) raise_ = raise
     165           0 :     if (present(uni) ) uni_ = uni
     166             : 
     167           0 :     call message(t01, t02, t03, t04, t05, t06, t07, t08, t09, t10, t11, t12, t13, t14, t15, t16, uni_, advance, show_, reset_format)
     168           0 :     if ( raise_ ) stop 1
     169             : 
     170          22 :   END SUBROUTINE error_message
     171             : 
     172             : END MODULE mo_message