1C Copyright 1981-2016 ECMWF. 2C 3C This software is licensed under the terms of the Apache Licence 4C Version 2.0 which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. 5C 6C In applying this licence, ECMWF does not waive the privileges and immunities 7C granted to it by virtue of its status as an intergovernmental organisation 8C nor does it submit to any jurisdiction. 9C 10 11 SUBROUTINE INTLOG(KLEVEL, MESSAGE, KNUM) 12C 13C----> 14C**** INTLOG 15C 16C PURPOSE 17C _______ 18C 19C This routine logs error messages. 20C 21C 22C INTERFACE 23C _________ 24C 25C CALL INTLOG(KLEVEL, MESSAGE, KNUM) 26C 27C 28C Input parameters 29C ________________ 30C 31C KLEVEL - Severity level for reported message 32C = 0 for debug 33C = 1 for information 34C = 2 for warning 35C = 3 for error 36C = 4 for fatal 37C MESSAGE - Message text 38C KNUM - Message number 39C 40C 41C Output parameters 42C ________________ 43C 44C None. 45C 46C 47C Common block usage 48C __________________ 49C 50C LDEBUG in /INTLOGC/ controls display of message 51C = 0 for no display 52C = 1 to display 53C 54C 55C Method 56C ______ 57C 58C Prints message and number if debug flag is 'on'. 59C 60C 61C Externals 62C _________ 63C 64C INTLOGT - sends any ERROR, FATAL or WARN message to the 65C MARS server. 66C 67C 68C Comments 69C ________ 70C 71C LDEBUG is toggled by a call to INTLOGD. 72C 73C 74C AUTHOR 75C ______ 76C 77C J.D.Chambers *ECMWF* Jul 1995 78C 79C 80C MODIFICATIONS 81C _____________ 82C 83C J.D.Chambers *ECMWF* March 1996 84C Prepare error message for MARS server. 85C 86C 87C----< 88C _______________________________________________________ 89C 90 IMPLICIT NONE 91C 92#include "parim.h" 93C 94C Subroutine arguments. 95C 96 INTEGER KLEVEL 97 INTEGER KNUM 98 CHARACTER *(*) MESSAGE 99C 100#include "intlog.h" 101 102#ifdef MPI_DEBUG 103#include "mpif.h" 104#endif 105 106C 107C Local variables. 108C 109 CHARACTER*120 NEWMESS 110 INTEGER NLEV, LOOP 111 CHARACTER*5 TITLE(JP_FATAL+1) 112 DATA TITLE/'DEBUG', 113 X 'INFO ', 114 X 'WARN ', 115 X 'ERROR', 116 X 'FATAL'/ 117 INTEGER ILEN 118 119#ifdef MPI_DEBUG 120 INTEGER my_id, ierr 121 Data my_id /-1/ 122 Save my_id 123#endif 124 125C 126C ------------------------------------------------------------------ 127C* Section 1. Initialise 128C ------------------------------------------------------------------ 129C 130 100 CONTINUE 131C 132C Ensure valid level is used. 133 NLEV = KLEVEL + 1 134 IF ( KLEVEL .GT. JP_FATAL) NLEV = JP_FATAL + 1 135C 136 DO LOOP = 1, 120 137 NEWMESS(LOOP:LOOP) = ' ' 138 ENDDO 139C 140C ------------------------------------------------------------------ 141C* Section 2. Prepare ERROR or FATAL message for MARS server. 142C ------------------------------------------------------------------ 143C 144 200 CONTINUE 145C 146 ILEN = LEN(MESSAGE) 147 IF( ILEN.GT.105 ) ILEN = 105 148 149#ifdef MPI_DEBUG 150 if (my_id.eq.-1) Then 151 call MPI_COMM_RANK (MPI_COMM_WORLD, my_id, ierr) 152 my_id = my_id + 1 153 end if 154#endif 155 156 NEWMESS(1:ILEN) = MESSAGE(1:ILEN) 157 ILEN = ILEN + 1 158 IF(KNUM.NE.JPQUIET) THEN 159 IF( ABS(KNUM).LT.1000 ) THEN 160 WRITE(NEWMESS(ILEN:),'(I4)') KNUM 161 ELSE IF ( ABS(KNUM).LT.100000 ) THEN 162 WRITE(NEWMESS(ILEN:),'(I7)') KNUM 163 ELSE IF ( ABS(KNUM).LT.100000000 ) THEN 164 WRITE(NEWMESS(ILEN:),'(I10)') KNUM 165 ELSE 166 WRITE(NEWMESS(ILEN:),'(I15)') KNUM 167 ENDIF 168 ENDIF 169 170C 171C Send the message 172C 173 IF( KLEVEL.GE.JP_WARN ) CALL INTLOGT(NEWMESS) 174C 175#ifdef MPI_DEBUG 176 IF( LDEBUG ) WRITE(*,9001) my_id,TITLE(NLEV),NEWMESS 177 9001 FORMAT(i4,' INTLOG ',A5,': ',A120) 178#else 179 IF( LDEBUG ) WRITE(*,9001) TITLE(NLEV),NEWMESS 180 9001 FORMAT('INTLOG ',A5,': ',A120) 181 182#endif 183C 184C ------------------------------------------------------------------ 185C* Section 9. Closedown. 186C ------------------------------------------------------------------ 187C 188 900 CONTINUE 189C 190 RETURN 191 END 192