*IF DEF,HRES HRESET1.2
C ******************************COPYRIGHT****************************** GTS2F400.4033
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.4034
C GTS2F400.4035
C Use, duplication or disclosure of this code is subject to the GTS2F400.4036
C restrictions as set forth in the contract. GTS2F400.4037
C GTS2F400.4038
C Meteorological Office GTS2F400.4039
C London Road GTS2F400.4040
C BRACKNELL GTS2F400.4041
C Berkshire UK GTS2F400.4042
C RG12 2SZ GTS2F400.4043
C GTS2F400.4044
C If no contract has been raised with this copy of the code, the use, GTS2F400.4045
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.4046
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.4047
C Modelling at the above address. GTS2F400.4048
C ******************************COPYRIGHT****************************** GTS2F400.4049
C GTS2F400.4050
CLL Routine: HRESET--------------------------------------------------- HRESET1.3
CLL HRESET1.4
CLL Purpose: To ensure only have current and previous history records HRESET1.5
CLL in permanent history file in operational runs. HRESET1.6
CLL HRESET1.7
CLL Tested under compiler: cft77 HRESET1.8
CLL Tested under OS version: UNICOS 5.0 HRESET1.9
CLL HRESET1.10
CLL Author: A.Sangster HRESET1.11
CLL HRESET1.12
CLL Model Modification history from model version 3.0: HRESET1.13
CLL version date HRESET1.14
CLL AD050293.70
CLL 3.1 05/02/93 Portable Fortran unit no assigns AD050293.71
CLL Author: A. Dickinson Reviewer: R. Stratton AD050293.72
CLL 3.4 22/12/94 Change H_SECT2 to length 3, like H_SECT. RTHBarnes. GSS1F304.1492
CLL 3.5 16/05/95 Sub-models stage 1: namelist history file. RTHBarnes URB1F305.14
CLL 4.0 03/11/95 Further mods for new history file structure. RTHB GRB3F400.11
CLL HRESET1.15
CLL Programming standard: UM Doc Paper 3, draft version 3 (15/1/90) HRESET1.16
CLL HRESET1.17
CLL Logical components covered: F2 HRESET1.18
CLL HRESET1.19
CLL Project task: F HRESET1.20
CLL HRESET1.21
CLL Documentation: Unified Model Documentation Paper HRESET1.22
CLL H- History Bricks HRESET1.23
CLL HRESET1.26
CLL HRESET1.27
C HRESET1.28
C*L Interface and arguments HRESET1.29
C HRESET1.30
PROGRAM HRESET ,2HRESET1.31
C HRESET1.32
IMPLICIT NONE HRESET1.33
C* HRESET1.34
C HRESET1.35
CL Common blocks HRESET1.36
C HRESET1.37
*CALL CSUBMODL 
URB1F305.15
*CALL CHSUNITS URB1F305.16
*CALL CHISTORY HRESET1.38
C HRESET1.39
C*L EXTERNAL subroutines called HRESET1.40
C HRESET1.41
EXTERNAL EREPORT,ABORT,GET_FILE AD050293.73
C* HRESET1.43
C HRESET1.44
C Local variables HRESET1.45
C HRESET1.46
INTEGER ICODE,IABORT ! Work- Return codes from called routines HRESET1.47
CHARACTER*256 CMESSAGE ! Work- Return message if failure occured HRESET1.48
CHARACTER*80 FILENAME AD050293.74
INTEGER I ! Work- Loop counter HRESET1.49
INTEGER ICOUNT ! Work- History record counter HRESET1.50
CL HRESET1.51
CL 1. Set common block areas to zero or blank HRESET1.67
CL HRESET1.68
DO 6 I=1,NUNITS HRESET1.89
MODEL_FT_UNIT(I)=' ' HRESET1.90
6 CONTINUE URB1F305.17
CL HRESET1.113
CL 2. Count number of records in permanent history file HRESET1.114
CL and position to start of second last record. HRESET1.115
CL No action if only 2 or less records in file. HRESET1.116
CL HRESET1.117
CALL GET_FILE(PHIST_UNIT,FILENAME,80,ICODE) GTD0F400.159
OPEN(PHIST_UNIT,FILE=FILENAME,FORM='FORMATTED',IOSTAT=ICODE, PXNAMLST.4
& DELIM='APOSTROPHE') PXNAMLST.5
C HRESET1.120
C Check for error HRESET1.121
C HRESET1.122
IF(ICODE .GT.0)THEN HRESET1.123
CMESSAGE='HRESET : Failed in OPEN of permanent history file' HRESET1.124
GOTO 999 HRESET1.125
ELSEIF(ICODE .LT. 0)THEN HRESET1.126
WRITE(6,*)'HRESET : Warning message on OPEN of permanent history GIE0F403.264
* file' HRESET1.128
WRITE(6,*)'IOSTAT= ',ICODE GIE0F403.265
ENDIF HRESET1.130
C HRESET1.131
REWIND(PHIST_UNIT) HRESET1.132
ICOUNT=0 HRESET1.133
READ(PHIST_UNIT,NLIHISTO,END=100,ERR=200) GRB3F400.12
READ(PHIST_UNIT,NLCHISTO,END=100,ERR=200) GRB3F400.13
READ(PHIST_UNIT,NLIHISTG,END=100,ERR=200) GRB3F400.14
READ(PHIST_UNIT,NLCHISTG,END=100,ERR=200) GRB3F400.15
READ(PHIST_UNIT,NLCFILES,END=100,ERR=200) GRB3F400.16
go to 300 GRB3F400.17
C HRESET1.135
C Check for error HRESET1.136
C HRESET1.137
100 continue URB1F305.24
CMESSAGE='HRESET : Unexpected end in 1st READ of permanent histo GRB3F400.18
&ry file' GRB3F400.19
ICODE = 100 GRB3F400.20
go to 999 GRB3F400.21
200 continue GRB3F400.22
CMESSAGE='HRESET : Error in 1st READ of permanent history file' GRB3F400.23
ICODE = 200 GRB3F400.24
go to 999 GRB3F400.25
C HRESET1.146
300 continue GRB3F400.26
ICOUNT=ICOUNT+1 HRESET1.147
CL HRESET1.154
CL 3. Read next records URB1F305.25
CL HRESET1.156
READ(PHIST_UNIT,NLIHISTO,END=400,ERR=500) GRB3F400.27
READ(PHIST_UNIT,NLCHISTO,END=400,ERR=500) GRB3F400.28
READ(PHIST_UNIT,NLIHISTG,END=400,ERR=500) GRB3F400.29
READ(PHIST_UNIT,NLCHISTG,END=400,ERR=500) GRB3F400.30
READ(PHIST_UNIT,NLCFILES,END=400,ERR=500) GRB3F400.31
go to 600 GRB3F400.32
C HRESET1.161
C Check for error HRESET1.162
C HRESET1.163
400 continue GRB3F400.33
WRITE(6,*)' HRESET : End of file - only one set of history records GIE0F403.266
&present' GRB3F400.35
icode = 0 GRB3F400.36
go to 999 GRB3F400.37
500 continue GRB3F400.38
CMESSAGE='HRESET : Error in 2nd READ of permanent history file' GRB3F400.39
ICODE = 500 GRB3F400.40
go to 999 GRB3F400.41
C GRB3F400.42
600 continue GRB3F400.43
C HRESET1.173
CL HRESET1.191
CL 4. Use ENDFILE to truncate phist file to 2 sets of records ARB0F404.21
CL HRESET1.193
ENDFILE (PHIST_UNIT,IOSTAT=ICODE) ARB0F404.22
if (icode.ne.0) go to 700 ARB0F404.23
go to 999 GRB3F400.48
C HRESET1.199
C Check for error HRESET1.200
C HRESET1.201
700 continue GRB3F400.49
CMESSAGE='HRESET : Error in ENDFILE trying to reduce history file ARB0F404.24
&to 2 sets of records' GRB3F400.51
ICODE = 700 GRB3F400.52
999 CONTINUE HRESET1.230
CL HRESET1.231
CL 5. Output error message if problem HRESET1.232
CL HRESET1.233
IABORT=ICODE HRESET1.234
IF(ICODE .NE. 0) CALL EREPORT(ICODE,CMESSAGE) HRESET1.235
CL HRESET1.236
CL 6. Close and stop and abort if problem HRESET1.237
CL HRESET1.238
CLOSE(PHIST_UNIT) HRESET1.239
IF(IABORT .GT. 0)CALL ABORT HRESET1.240
STOP HRESET1.241
END HRESET1.242
*ENDIF HRESET1.243