*IF DEF,HPRT HPRINT1.2
C ******************************COPYRIGHT****************************** GTS2F400.4015
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.4016
C GTS2F400.4017
C Use, duplication or disclosure of this code is subject to the GTS2F400.4018
C restrictions as set forth in the contract. GTS2F400.4019
C GTS2F400.4020
C Meteorological Office GTS2F400.4021
C London Road GTS2F400.4022
C BRACKNELL GTS2F400.4023
C Berkshire UK GTS2F400.4024
C RG12 2SZ GTS2F400.4025
C GTS2F400.4026
C If no contract has been raised with this copy of the code, the use, GTS2F400.4027
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.4028
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.4029
C Modelling at the above address. GTS2F400.4030
C ******************************COPYRIGHT****************************** GTS2F400.4031
C GTS2F400.4032
CLL Routine: HPRINT------------------------------------------------- HPRINT1.3
CLL HPRINT1.4
CLL Purpose: Master routine for printing out summary reports from HPRINT1.5
CLL History File records. HPRINT1.6
CLL HPRINT1.7
CLL Also updates model resubmit job parameters from latest HPRINT1.8
CLL history block information HPRINT1.9
CLL HPRINT1.10
CLL Tested under compiler: cft77 HPRINT1.11
CLL Tested under OS version: UNICOS 5.0 HPRINT1.12
CLL HPRINT1.13
CLL Author: A.Sangster HPRINT1.14
CLL HPRINT1.15
CLL Model Modification history from model version 3.0: HPRINT1.16
CLL version date HPRINT1.17
CLL AD050293.206
CLL 3.1 05/02/93 Portable Fortran unit no assigns AD050293.207
CLL Author: A. Dickinson Reviewer: R. Stratton AD050293.208
CLL HPRINT1.18
CLL Programming standard: UM Doc Paper 3, draft version 3 (15/1/90) HPRINT1.19
CLL HPRINT1.20
CLL Logical components covered: H5 HPRINT1.21
CLL HPRINT1.22
CLL Project task: H HPRINT1.23
CLL HPRINT1.24
CLL Documentation: Unified Model Documentation Paper HPRINT1.25
CLL H- History Bricks HPRINT1.26
CLL Version 5 18/6/90 HPRINT1.27
CLL HPRINT1.28
C*L Interface and arguments HPRINT1.29
C HPRINT1.30
PROGRAM HPRINT ,8HPRINT1.31
C HPRINT1.32
IMPLICIT NONE HPRINT1.33
C* HPRINT1.34
C HPRINT1.35
C Common blocks HPRINT1.36
C HPRINT1.37
*CALL CSUBMODL 
GGH0F305.1
*CALL CHSUNITS GGH0F305.2
*CALL CHISTORY HPRINT1.38
C HPRINT1.39
C*L EXTERNAL subroutines called HPRINT1.40
EXTERNAL INITCHST,PRINTHST,READHIST,WRITRSUB,EREPORT,ABORT HPRINT1.41
EXTERNAL GET_FILE AD050293.210
C* HPRINT1.42
C HPRINT1.43
C Local variables HPRINT1.44
C HPRINT1.45
INTEGER ICODE, !)Work- Return codes from called routines HPRINT1.46
* IABORT, !) HPRINT1.47
* ICOUNT, ! Work- History record counter HPRINT1.48
* HIST_UNIT, ! Work- History file unit number HPRINT1.49
* RSUB_UNIT ! Work- Resubmit parameter file unit no. HPRINT1.50
* ,NO_OF_RECORDS !No of records user wants printed GGH0F305.3
C HPRINT1.51
CHARACTER*256 CMESSAGE ! Work- Return message if failure occured HPRINT1.52
CHARACTER*80 FILENAME AD050293.209
C HPRINT1.53
LOGICAL HPRINT1.54
*LONG, ! If true, print out expanded history report HPRINT1.55
*LAST_RECORD ! If true, process last history record only HPRINT1.56
C ! If false, process all history records HPRINT1.57
C HPRINT1.58
PARAMETER(HIST_UNIT=10) HPRINT1.59
PARAMETER(RSUB_UNIT=7) HPRINT1.60
C HPRINT1.61
NAMELIST/PRINTOPT/ HPRINT1.62
*LONG,LAST_RECORD,NO_OF_RECORDS GGH0F305.4
CL HPRINT1.64
CL 0. Set default values and read namelist input HPRINT1.65
CL HPRINT1.66
ICOUNT=0 HPRINT1.67
ICODE=0 HPRINT1.68
LONG = .TRUE. HPRINT1.69
LAST_RECORD = .TRUE. HPRINT1.70
NO_OF_RECORDS = 100 GGH0F305.5
CMESSAGE='HPRINT : Problem reading namelist PRINTOPT' HPRINT1.71
READ(5,PRINTOPT,END=50,ERR=999) HPRINT1.72
50 CONTINUE HPRINT1.73
CL HPRINT1.74
CL 1. Set common block area to zero or blank HPRINT1.75
CL HPRINT1.76
CALL INITCHST HPRINT1.77
CL HPRINT1.78
CL 2. Read History file and loop through records HPRINT1.79
CL HPRINT1.80
IF(.NOT. LAST_RECORD) THEN HPRINT1.81
C HPRINT1.82
C Process each record in turn HPRINT1.83
C HPRINT1.84
CALL GET_FILE(HIST_UNIT,FILENAME,80,ICODE) GTD0F400.158
OPEN(HIST_UNIT,FILE=FILENAME,FORM='FORMATTED',IOSTAT=ICODE, PXNAMLST.2
& DELIM='APOSTROPHE') PXNAMLST.3
C HPRINT1.87
C Check for error HPRINT1.88
C HPRINT1.89
IF(ICODE .GT.0)THEN HPRINT1.90
CMESSAGE='HPRINT : Failed in OPEN of history file' HPRINT1.91
GOTO 999 HPRINT1.92
ELSEIF(ICODE .LT. 0)THEN HPRINT1.93
WRITE(6,*)'HPRINT : Warning message on OPEN of history file' GIE0F403.260
WRITE(6,*)'IOSTAT= ',ICODE GIE0F403.261
ENDIF HPRINT1.96
C HPRINT1.97
REWIND(HIST_UNIT) HPRINT1.98
C HPRINT1.99
100 READ(HIST_UNIT,NLIHISTO,END=200,ERR=200) GGH0F305.7
READ(HIST_UNIT,NLCHISTO) GGH0F305.8
READ(HIST_UNIT,NLIHISTG) GGH0F305.9
READ(HIST_UNIT,NLCHISTG) GGH0F305.10
READ(HIST_UNIT,NLCFILES) GGH0F305.11
C HPRINT1.104
C Check for error HPRINT1.105
C HPRINT1.106
IF(ICODE .GT.0)THEN HPRINT1.107
CMESSAGE='HPRINT : Failed in READ of history file' HPRINT1.108
GOTO 999 HPRINT1.109
ELSEIF(ICODE .LT. 0)THEN HPRINT1.110
WRITE(6,*)'HPRINT : Warning message on READ of history file' GIE0F403.262
WRITE(6,*)'IOSTAT= ',ICODE GIE0F403.263
ENDIF HPRINT1.113
C HPRINT1.114
C HPRINT1.115
ICOUNT=ICOUNT+1 HPRINT1.116
CALL PRINTHST(ICOUNT,LONG) HPRINT1.117
IF (ICOUNT .EQ. (NO_OF_RECORDS - 1)) GOTO 200 GGH0F305.12
C HPRINT1.118
GOTO 100 HPRINT1.119
200 CONTINUE HPRINT1.120
ELSE HPRINT1.121
C HPRINT1.122
C Process last record only HPRINT1.123
C HPRINT1.124
CALL READHIST(HIST_UNIT,ICODE,CMESSAGE) HPRINT1.125
IF(ICODE .GT. 0)GOTO 999 HPRINT1.126
C HPRINT1.127
LONG = .TRUE. HPRINT1.128
C HPRINT1.129
CALL PRINTHST(ICOUNT,LONG) HPRINT1.130
C HPRINT1.131
ENDIF HPRINT1.132
CL HPRINT1.133
CL 3. Update resubmit file with current model resubmit information HPRINT1.134
CL in history file HPRINT1.135
CL HPRINT1.136
CALL WRITRSUB(RSUB_UNIT,ICODE,CMESSAGE) HPRINT1.137
IF(ICODE .GT. 0)GOTO 999 HPRINT1.138
CL HPRINT1.139
CL 4.0 Normal exit HPRINT1.140
CL HPRINT1.141
STOP HPRINT1.142
CL HPRINT1.143
CL 4.1 Output error message if problem HPRINT1.144
CL HPRINT1.145
999 CONTINUE HPRINT1.146
IF (ICODE.EQ.0) ICODE=1 HPRINT1.147
CALL EREPORT(ICODE,CMESSAGE) HPRINT1.148
CALL ABORT HPRINT1.149
STOP HPRINT1.150
END HPRINT1.151
*ENDIF HPRINT1.152