*IF DEF,C70_1A,OR,DEF,FLDIO,OR,DEF,UTILHIST GLW1F404.20
CLL Routine: EREPORT -------------------------------------------------- EREPORT1.2
C ******************************COPYRIGHT****************************** GTS2F400.2503
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.2504
C GTS2F400.2505
C Use, duplication or disclosure of this code is subject to the GTS2F400.2506
C restrictions as set forth in the contract. GTS2F400.2507
C GTS2F400.2508
C Meteorological Office GTS2F400.2509
C London Road GTS2F400.2510
C BRACKNELL GTS2F400.2511
C Berkshire UK GTS2F400.2512
C RG12 2SZ GTS2F400.2513
C GTS2F400.2514
C If no contract has been raised with this copy of the code, the use, GTS2F400.2515
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.2516
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.2517
C Modelling at the above address. GTS2F400.2518
C ******************************COPYRIGHT****************************** GTS2F400.2519
C GTS2F400.2520
CLL EREPORT1.3
CLL Purpose: Reports error exit code and message at end of model run. EREPORT1.4
CLL EREPORT1.5
CLL Tested under compiler: cft77 EREPORT1.6
CLL Tested under OS version: UNICOS 5.1 EREPORT1.7
CLL EREPORT1.8
CLL Author: T.C.Johns EREPORT1.9
CLL EREPORT1.10
CLL Model Modification history from model version 3.0: EREPORT1.11
CLL version Date EREPORT1.12
CLL 3.4 10/10/94 Minor simplification of output format statements. GRR3F304.1
CLL R.Rawlins. GRR3F304.2
CLL 4.4 15/10/97 Added code to print the error message to GBC2F404.25
CLL stderr, and call abort in case all the GBC2F404.26
CLL PE's have not detected the error condition. GBC2F404.27
CLL Author: Bob Carruthers, Cray Research GBC2F404.28
CLL 4.5 08/07/98 Print only the leading non-blank GBC1F405.10
CLL characters in 'cmessage' GBC1F405.11
CLL Author: Bob Carruthers, Cray Research GBC1F405.12
CLL 4.5 26/08/98 Changed resetting of ICODE (A Van der Wal) GAV0F405.104
CLL EREPORT1.13
CLL Programming standard: UM Doc Paper 1, version 1 (15/1/90) EREPORT1.14
CLL EREPORT1.15
CLL Logical components covered: C0 EREPORT1.16
CLL EREPORT1.17
CLL Project task: C0 EREPORT1.18
CLL EREPORT1.19
CLL External documentation: On-line UM document C0 - The top-level EREPORT1.20
CLL control system EREPORT1.21
CLL EREPORT1.22
CLL ------------------------------------------------------------------- EREPORT1.23
C*L Interface and arguments: ------------------------------------------ EREPORT1.24
C EREPORT1.25
SUBROUTINE EREPORT (ICODE,CMESSAGE) 10,2EREPORT1.26
IMPLICIT NONE EREPORT1.27
INTEGER ICODE ! In - Error code from model EREPORT1.28
*IF DEF,T3E GBC2F404.29
character*(*) cmessage GBC2F404.30
*ELSE GBC2F404.31
CHARACTER*256 CMESSAGE ! In - Error message from model EREPORT1.29
*ENDIF GBC2F404.32
GBC1F405.13
integer get_char_len ! Returns the length of the string, GBC1F405.14
! excluding trailing blanks GBC1F405.15
C EREPORT1.30
C*---------------------------------------------------------------------- EREPORT1.31
C Local variables EREPORT1.32
C EREPORT1.33
CL---------------------------------------------------------------------- EREPORT1.34
CL 1. Write informative message summarising completion state of model EREPORT1.35
CL EREPORT1.36
*IF DEF,T3E GBC2F404.33
integer len_message, i, j GBC2F404.34
c GBC2F404.35
len_message=get_char_len
(cmessage) GBC1F405.16
c GBC2F404.37
write(6,1000) GBC2F404.38
if(icode.lt.0) write(6,1010) icode GBC2F404.39
if(icode.gt.0) write(6,1020) icode GBC2F404.40
c GBC2F404.41
write(0,1000) GBC2F404.42
if(icode.lt.0) write(0,1010) icode GBC2F404.43
if(icode.gt.0) write(0,1020) icode GBC2F404.44
c GBC2F404.45
do i=1, len_message, 80 GBC2F404.46
j=min(len_message, i+79) GBC2F404.47
write(6,'(a)') cmessage(i:j) GBC2F404.48
write(0,'(a)') cmessage(i:j) GBC2F404.49
end do GBC2F404.50
write(6,1000) GBC2F404.51
write(0,1000) GBC2F404.52
call flush(6,i) GBC2F404.53
call abort('T3E Hard Abort') GBC2F404.54
*ELSE GBC2F404.55
WRITE(6,1000) EREPORT1.37
IF (ICODE.LT.0) WRITE(6,1010) ICODE, GBC1F405.17
2 CMESSAGE(1:get_char_len(cmessage)) GBC1F405.18
IF (ICODE.GT.0) WRITE(6,1020) ICODE, GBC1F405.19
2 CMESSAGE(1:get_char_len(cmessage)) GBC1F405.20
WRITE(6,1000) EREPORT1.40
*ENDIF GBC2F404.56
CL 1.1 Reset error code EREPORT1.41
IF (ICODE.LT.0) ICODE=0 GAV0F405.105
C EREPORT1.43
1000 FORMAT(" ****************************************", EREPORT1.44
& "*****************************************") EREPORT1.45
1010 FORMAT(" Model completed with warning code - ",I4, GRR3F304.5
& " Routine and message:-",(/A80)) GRR3F304.6
1020 FORMAT(" Model aborted with error code - ",I4, GRR3F304.7
& " Routine and message:-",(/A80)) GRR3F304.8
RETURN EREPORT1.50
CL---------------------------------------------------------------------- EREPORT1.51
END EREPORT1.52
*ENDIF GLW1F404.21