*IF DEF,C80_1A,OR,DEF,C98_1A,OR,DEF,UTILIO,OR,DEF,FLDIO,OR,DEF,RECON UIE3F404.30
C ******************************COPYRIGHT****************************** GTS2F400.5005
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.5006
C GTS2F400.5007
C Use, duplication or disclosure of this code is subject to the GTS2F400.5008
C restrictions as set forth in the contract. GTS2F400.5009
C GTS2F400.5010
C Meteorological Office GTS2F400.5011
C London Road GTS2F400.5012
C BRACKNELL GTS2F400.5013
C Berkshire UK GTS2F400.5014
C RG12 2SZ GTS2F400.5015
C GTS2F400.5016
C If no contract has been raised with this copy of the code, the use, GTS2F400.5017
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.5018
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.5019
C Modelling at the above address. GTS2F400.5020
C ******************************COPYRIGHT****************************** GTS2F400.5021
C GTS2F400.5022
CLL SUBROUTINE IOERROR---------------------------------------- IOERR1A.3
CLL IOERR1A.4
CLL Purpose: Prints out a message after using buffer in/out when IOERR1A.5
CLL either a return code < 0.0 is encountered IOERR1A.6
CLL by UNIT function or value returned by LENGTH IOERR1A.7
CLL differs from length of I/O request. IOERR1A.8
CLL IOERR1A.9
CLL Written by A. Dickinson IOERR1A.10
CLL IOERR1A.11
CLL Model Modification history from model version 3.0: IOERR1A.12
CLL version Date IOERR1A.13
CLL 3.2 13/07/93 Changed CHARACTER*(*) to CHARACTER*(80) for TS150793.234
CLL portability. Author Tracey Smith. TS150793.235
CLL 4.1 12/06/96 Break up write statement. D. Robinson. GDR1F401.48
CLL 4.4 15/10/97 Added code to print the error message to GBC2F404.57
CLL stderr, and call abort in case all the GBC2F404.58
CLL PE's have not detected the error condition. GBC2F404.59
CLL Author: Bob Carruthers, Cray Research GBC2F404.60
CLL 4.5 08/07/98 Print only the leading non-blank GBC1F405.21
CLL characters in 'string' GBC1F405.22
CLL Author: Bob Carruthers, Cray Research GBC1F405.23
CLL IOERR1A.14
CLL Programming standard: Unified Model Documentation Paper No 3 IOERR1A.15
CLL Version No 1 15/1/90 IOERR1A.16
CLL IOERR1A.17
CLL Logical component: E4 IOERR1A.18
CLL IOERR1A.19
CLL System task: F3 IOERR1A.20
CLL IOERR1A.21
CLL Documentation: CFT77 reference manual SR-0018 C Page 9-3 IOERR1A.22
CLL------------------------------------------------------------ IOERR1A.23
C*L Arguments:------------------------------------------------- IOERR1A.24
SUBROUTINE IOERROR(STRING,ERROR,LEN_IO,LEN_IO_REQ) 129,1IOERR1A.25
IOERR1A.26
IMPLICIT NONE IOERR1A.27
IOERR1A.28
INTEGER IOERR1A.29
* LEN_IO ! Number of 64-bit words transferred as registered IOERR1A.30
* ! by LENGTH function IOERR1A.31
*,LEN_IO_REQ ! Number of 64-bit words requested for IOERR1A.32
* ! transfer via BUFFER IN/OUT IOERR1A.33
IOERR1A.34
*IF DEF,T3E GBC2F404.61
character*(*) string GBC2F404.62
*ELSE GBC2F404.63
CHARACTER*(80) STRING ! User provided character string TS150793.236
*ENDIF GBC2F404.64
IOERR1A.37
REAL IOERR1A.38
* ERROR ! Error code returned by UNIT function IOERR1A.39
GBC1F405.24
integer get_char_len ! Returns the length of the string, GBC1F405.25
! excluding trailing blanks GBC1F405.26
IOERR1A.40
C ------------------------------------------------------------- IOERR1A.41
C Workspace usage:--------------------------------------------- IOERR1A.42
C None IOERR1A.43
C ------------------------------------------------------------- IOERR1A.44
C*L External subroutines called:------------------------------- IOERR1A.45
C None IOERR1A.46
C*------------------------------------------------------------- IOERR1A.47
IOERR1A.48
CL Internal structure: none IOERR1A.49
IOERR1A.50
WRITE(6,'('' **FATAL ERROR WHEN READING/WRITING MODEL DUMP**'')') IOERR1A.51
WRITE(6,'('' '',A)') STRING(1:get_char_len(string)) GBC1F405.27
WRITE(6,'('' Error code = '',F6.2)') ERROR GDR1F401.50
WRITE(6,'('' Length requested = '',I9)') LEN_IO_REQ GDR1F401.51
WRITE(6,'('' Length actually transferred = '',I9)') LEN_IO GDR1F401.52
WRITE(6,'('' Fatal error codes are as follows:'')') IOERR1A.55
WRITE(6,'('' -1.0 Mismatch between actual and requested data'', IOERR1A.56
* '' length'')') IOERR1A.57
WRITE(6,'('' 0.0 End-of-file was read'')') IOERR1A.58
WRITE(6,'('' 1.0 Error occurred during read'')') TS220793.1
WRITE(6,'('' 2.0 Other disk malfunction'')') IOERR1A.60
WRITE(6,'('' 3.0 File does not exist'')') IOERR1A.61
WRITE(6,'('' ***********************************************'')') IOERR1A.62
*IF DEF,T3E GBC2F404.65
c GBC2F404.66
write(0,'(//)') GBC2F404.67
WRITE(0,'('' **FATAL ERROR WHEN READING/WRITING MODEL DUMP**'')') GBC2F404.68
WRITE(0,'('' '',A)') STRING(1:get_char_len(string)) GBC1F405.28
WRITE(0,'('' Error code = '',F6.2)') ERROR GBC2F404.70
WRITE(0,'('' Length requested = '',I9)') LEN_IO_REQ GBC2F404.71
WRITE(0,'('' Length actually transferred = '',I9)') LEN_IO GBC2F404.72
WRITE(0,'('' Fatal error codes are as follows:'')') GBC2F404.73
WRITE(0,'('' -1.0 Mismatch between actual and requested data'', GBC2F404.74
* '' length'')') GBC2F404.75
WRITE(0,'('' 0.0 End-of-file was read'')') GBC2F404.76
WRITE(0,'('' 1.0 Error occurred during read'')') GBC2F404.77
WRITE(0,'('' 2.0 Other disk malfunction'')') GBC2F404.78
WRITE(0,'('' 3.0 File does not exist'')') GBC2F404.79
WRITE(0,'('' ***********************************************'')') GBC2F404.80
call abort
('I/O Error') GBC2F404.81
*ENDIF GBC2F404.82
IOERR1A.63
RETURN IOERR1A.64
END IOERR1A.65
*ENDIF IOERR1A.66