*IF DEF,C80_1A,OR,DEF,UTILIO,OR,DEF,RECON,OR,DEF,FLDOP UIE3F404.1
C ******************************COPYRIGHT****************************** GTS2F400.1
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.2
C GTS2F400.3
C Use, duplication or disclosure of this code is subject to the GTS2F400.4
C restrictions as set forth in the contract. GTS2F400.5
C GTS2F400.6
C Meteorological Office GTS2F400.7
C London Road GTS2F400.8
C BRACKNELL GTS2F400.9
C Berkshire UK GTS2F400.10
C RG12 2SZ GTS2F400.11
C GTS2F400.12
C If no contract has been raised with this copy of the code, the use, GTS2F400.13
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.14
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.15
C Modelling at the above address. GTS2F400.16
C ******************************COPYRIGHT****************************** GTS2F400.17
C GTS2F400.18
CLL Subroutine ABORT_IO----------------------------------------------- ABORT1A.3
CLL ABORT1A.4
CLL Purpose: Prints out message and stops execution of program. ABORT1A.5
CLL Called if ICODE .NE. 0 ABORT1A.6
CLL ABORT1A.7
CLL Written by A. Dickinson ABORT1A.8
CLL ABORT1A.9
CLL Model Modification history from model version 3.0: ABORT1A.10
CLL version Date ABORT1A.11
CLL 3.2 13/07/93 Changed CHARACTER*(*) to CHARACTER*(80) for TS150793.1
CLL portability. Author: Tracey Smith TS150793.2
!LL 4.1 23/05/96 Added MPP abort code - one PE calling ABORT GPB0F401.12
!LL will cause all others to abort P.Burton GPB0F401.13
CLL 4.4 15/10/97 Added code to print the error messages GBC2F404.1
CLL to stderr as well as the unit 6 GBC2F404.2
CLL Author: Bob Carruthers, Cray Research GBC2F404.3
CLL 4.5 08/07/98 Print only the leading non-blank GBC1F405.1
CLL characters in 'cmessage' GBC1F405.2
CLL Author: Bob Carruthers, Cray Research GBC1F405.3
CLL ABORT1A.12
CLL Logical component number: E5 ABORT1A.13
CLL ABORT1A.14
CLL External Documentation: None ABORT1A.15
CLL ABORT1A.16
CLLEND ABORT1A.17
C*L Arguments:-------------------------------------------------------- ABORT1A.18
ABORT1A.19
SUBROUTINE ABORT_IO(STRING,CMESSAGE,ICODE,NFT) 99,1ABORT1A.20
ABORT1A.21
IMPLICIT NONE ABORT1A.22
ABORT1A.23
INTEGER ABORT1A.24
* ICODE !IN Code returned by UM routines ABORT1A.25
*,NFT !IN Unit no being processed ABORT1A.26
ABORT1A.27
*IF DEF,T3E GBC2F404.4
character*(*) GBC2F404.5
*ELSE GBC2F404.6
CHARACTER*80 TS150793.3
*ENDIF GBC2F404.7
* STRING !IN Subroutine name and position ABORT1A.29
*,CMESSAGE!IN Message returned by UM routines ABORT1A.30
GPB0F401.14
GBC1F405.4
integer get_char_len ! Returns the length of the string, GBC1F405.5
! excluding trailing blanks GBC1F405.6
*IF DEF,MPP GPB0F401.15
*CALL PARVARS 
GPB0F401.16
*ENDIF GPB0F401.17
C---------------------------------------------------------------------- ABORT1A.31
ABORT1A.32
CL Internal structure: None ABORT1A.33
ABORT1A.34
*IF DEF,MPP GPB0F401.18
*IF DEF,T3E GBC2F404.8
write(0,*) 'Processor ',mype,' calling ABORT' GBC2F404.9
*ELSE GBC2F404.10
WRITE(6,*) 'Processor ',mype,' calling ABORT' GPB0F401.19
*ENDIF GBC2F404.11
*ENDIF GPB0F401.20
*IF DEF,T3E GBC2F404.12
write(0,'('' Error detected in subroutine '',A)')STRING GBC2F404.13
*ELSE GBC2F404.14
WRITE(6,'('' Error detected in subroutine '',A)')STRING ABORT1A.35
*ENDIF GBC2F404.15
IF(NFT.NE.0)THEN ABORT1A.36
*IF DEF,T3E GBC2F404.16
write(0,'('' while doing I/O on unit'',I3)')NFT GBC2F404.17
*ELSE GBC2F404.18
WRITE(6,'('' while doing I/O on unit'',I3)')NFT ABORT1A.37
*ENDIF GBC2F404.19
ENDIF ABORT1A.38
*IF DEF,T3E GBC2F404.20
WRITE(6,'(A)')CMESSAGE(1:get_char_len(cmessage)) GBC1F405.7
write(0,'(A)')CMESSAGE(1:get_char_len(cmessage)) GBC1F405.8
*ELSE GBC2F404.23
WRITE(6,'(1X,A80)')CMESSAGE(1:get_char_len(cmessage)) GBC1F405.9
*ENDIF GBC2F404.24
WRITE(6,'('' ICODE='',I6)')ICODE ABORT1A.40
*IF DEF,MPP GPB0F401.21
CALL GC_ABORT(mype,nproc,CMESSAGE) GPB0F401.22
*ENDIF GPB0F401.23
CALL ABORT ABORT1A.41
STOP ABORT1A.42
END ABORT1A.43
ABORT1A.44
*ENDIF ABORT1A.45