*IF DEF,CONTROL,OR,DEF,SETUP,OR,DEF,COMB TEMPHIS1.2
C ******************************COPYRIGHT****************************** GTS2F400.10081
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.10082
C GTS2F400.10083
C Use, duplication or disclosure of this code is subject to the GTS2F400.10084
C restrictions as set forth in the contract. GTS2F400.10085
C GTS2F400.10086
C Meteorological Office GTS2F400.10087
C London Road GTS2F400.10088
C BRACKNELL GTS2F400.10089
C Berkshire UK GTS2F400.10090
C RG12 2SZ GTS2F400.10091
C GTS2F400.10092
C If no contract has been raised with this copy of the code, the use, GTS2F400.10093
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.10094
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.10095
C Modelling at the above address. GTS2F400.10096
C ******************************COPYRIGHT****************************** GTS2F400.10097
C GTS2F400.10098
CLL Routine : TEMPHIST ------------------------------------------------- TEMPHIS1.3
CLL TEMPHIS1.4
CLL Purpose :Write current contents of history common block to temporary TEMPHIS1.5
CLL or interim history file - overwriting previous record TEMPHIS1.6
CLL TEMPHIS1.7
CLL Tested under compiler: cft77 TEMPHIS1.8
CLL Tested under OS version: UNICOS 5.0 TEMPHIS1.9
CLL TEMPHIS1.10
CLL Author: A.B.SANGSTER Date: 20 January 1990 TEMPHIS1.11
CLL TEMPHIS1.12
CLL Model Modification history from model version 3.0: TEMPHIS1.13
CLL version date TEMPHIS1.14
CLL AD050293.129
CLL 3.1 05/02/93 Portable Fortran unit no assigns AD050293.130
CLL Author: A. Dickinson Reviewer: R. Stratton AD050293.131
CLL 3.2 13/07/93 Changed CHARACTER*(*) to CHARACTER*(80) for TS150793.201
CLL portability. Author Tracey Smith. TS150793.202
CLL 3.5 06/04/95 Sub-Models stage 1: revise History and Control file GRB1F305.677
CLL contents. RTHBarnes. GRB1F305.678
!LL 4.5 05/05/98 Add DELIM='APOSTROPHE' to OPEN statement so that GRB1F405.55
!LL History file is written in correct form from GRB1F405.56
!LL Fujitsu. RBarnes@ecmwf.int GRB1F405.57
CLL TEMPHIS1.15
CLL Programming standard: UM Doc Paper 3, draft version 3 (15/1/90) TEMPHIS1.16
CLL TEMPHIS1.17
CLL Logical components covered: H3,H40 TEMPHIS1.18
CLL TEMPHIS1.19
CLL Project task: H TEMPHIS1.20
CLL TEMPHIS1.21
CLL Documentation: Unified Model Documentation Paper TEMPHIS1.22
CLL H- History Bricks TEMPHIS1.23
CLL TEMPHIS1.25
C*L Interface and arguments: TEMPHIS1.26
C TEMPHIS1.27
SUBROUTINE TEMPHIST 7,1TEMPHIS1.28
* ( UNITHIST,ICODE,CMESSAGE ) TEMPHIS1.29
C TEMPHIS1.30
IMPLICIT NONE TEMPHIS1.31
C TEMPHIS1.32
INTEGER UNITHIST ! In - Temporary history file unit GRB1F305.679
INTEGER ICODE ! Out - Return code from routine TEMPHIS1.34
CHARACTER*80 CMESSAGE ! Out - Return message if failure occured GRB1F305.680
C* TEMPHIS1.36
C TEMPHIS1.37
CL Common blocks TEMPHIS1.38
C TEMPHIS1.39
*CALL CSUBMODL 
GRB1F305.681
*CALL CHSUNITS GRB1F305.682
*CALL CHISTORY TEMPHIS1.40
C TEMPHIS1.41
CHARACTER *80 FILENAME GRB1F305.683
CHARACTER *8 NLNAME GRB1F305.684
C*L EXTERNAL subroutines called TEMPHIS1.42
EXTERNAL GET_FILE AD050293.133
C* TEMPHIS1.44
C TEMPHIS1.45
CL TEMPHIS1.46
CL 1. Open, rewind and write a new record TEMPHIS1.47
CL TEMPHIS1.48
CALL GET_FILE(UNITHIST,FILENAME,80,ICODE) GTD0F400.168
*IF -DEF,FUJITSU GRB1F405.58
OPEN(UNITHIST,FILE=FILENAME,FORM='FORMATTED',IOSTAT=ICODE, PXNAMLST.19
& DELIM='APOSTROPHE') PXNAMLST.20
*ELSE GRB1F405.59
OPEN(UNITHIST,FILE=FILENAME,FORM='FORMATTED', GRB1F405.60
& DELIM='APOSTROPHE',IOSTAT=ICODE) GRB1F405.61
*ENDIF GRB1F405.62
C TEMPHIS1.50
C Check for error TEMPHIS1.51
C TEMPHIS1.52
IF(ICODE .GT.0)THEN TEMPHIS1.53
CMESSAGE='TEMPHIST: Failed in OPEN of history file' TEMPHIS1.54
GOTO 999 TEMPHIS1.55
ELSEIF(ICODE .LT. 0)THEN TEMPHIS1.56
WRITE(6,*)'TEMPHIST: Warning message on OPEN of history file' GIE0F403.642
WRITE(6,*)'IOSTAT= ',ICODE GIE0F403.643
ENDIF TEMPHIS1.59
C TEMPHIS1.60
REWIND(UNITHIST) TEMPHIS1.61
GRB1F305.686
NLNAME = 'NLIHISTO' GRB1F305.687
WRITE(UNITHIST,NLIHISTO,ERR=200) GRB1F305.688
NLNAME = 'NLCHISTO' GRB1F305.689
WRITE(UNITHIST,NLCHISTO,ERR=200) GRB1F305.690
NLNAME = 'NLIHISTG' GRB1F305.691
WRITE(UNITHIST,NLIHISTG,ERR=200) GRB1F305.692
NLNAME = 'NLCHISTG' GRB1F305.693
WRITE(UNITHIST,NLCHISTG,ERR=200) GRB1F305.694
NLNAME = 'NLCFILES' GRB1F305.695
WRITE(UNITHIST,NLCFILES,ERR=200) GRB1F305.696
GRB1F305.697
go to 999 GRB1F305.698
C TEMPHIS1.66
C Check for error TEMPHIS1.67
C TEMPHIS1.68
! Write error GRB1F305.699
200 continue GRB1F305.700
ICODE = 2 GRB1F305.701
CMESSAGE='TEMPHIST: Write ERROR on history file for namelist'// GRB1F305.702
& NLNAME GRB1F305.703
C TEMPHIS1.76
999 CONTINUE TEMPHIS1.77
CL TEMPHIS1.78
CL 2. Close and return TEMPHIS1.79
CL TEMPHIS1.80
CLOSE(UNITHIST) TEMPHIS1.81
RETURN TEMPHIS1.82
END TEMPHIS1.83
*ENDIF TEMPHIS1.84