*IF DEF,PICK URB0F401.1
C ******************************COPYRIGHT****************************** GTS2F400.12151
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.12152
C GTS2F400.12153
C Use, duplication or disclosure of this code is subject to the GTS2F400.12154
C restrictions as set forth in the contract. GTS2F400.12155
C GTS2F400.12156
C Meteorological Office GTS2F400.12157
C London Road GTS2F400.12158
C BRACKNELL GTS2F400.12159
C Berkshire UK GTS2F400.12160
C RG12 2SZ GTS2F400.12161
C GTS2F400.12162
C If no contract has been raised with this copy of the code, the use, GTS2F400.12163
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.12164
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.12165
C Modelling at the above address. GTS2F400.12166
C ******************************COPYRIGHT****************************** GTS2F400.12167
C GTS2F400.12168
CLL Routine: WRITHIST WRITHIS1.3
CLL WRITHIS1.4
CLL Purpose: To prepend the contents of History common blocks to GRB1F305.714
CLL the beginning of the history file input. GRB1F305.715
CLL WRITHIS1.7
CLL Tested under compiler: cft77 WRITHIS1.8
CLL Tested under OS version: UNICOS 5.0 WRITHIS1.9
CLL WRITHIS1.10
CLL Author: A.Sangster WRITHIS1.11
CLL WRITHIS1.12
CLL Model Modification history from model version 3.0: WRITHIS1.13
CLL version date WRITHIS1.14
CLL AD050293.143
CLL 3.1 05/02/93 Portable Fortran unit no assigns AD050293.144
CLL Author: A. Dickinson Reviewer: R. Stratton AD050293.145
CLL 3.2 13/07/93 Changed CHARACTER*(*) to CHARACTER*(80) for TS150793.216
CLL portability. Author Tracey Smith. TS150793.217
CLL 3.5 06/04/95 Sub-Models stage 1: revise History and Control file GRB1F305.716
CLL contents. RTHBarnes. GRB1F305.717
CLL 4.0 18/10/95 Add ICODE error return to GET_FILE call. RTHBarnes GRB2F400.1
CLL 4.1 01/05/96 Correct *IF DEF - remove CONTROL & COMB. RTHBarnes URB0F401.2
!LL 4.5 05/06/98 Add DELIM='APOSTROPHE' to OPEN statement so that GRB1F405.63
!LL History file is written in correct form from GRB1F405.64
!LL Fujitsu. RBarnes@ecmwf.int GRB1F405.65
CLL WRITHIS1.15
CLL Programming standard: UM Doc Paper 3, draft version 3 (15/1/90) WRITHIS1.16
CLL WRITHIS1.17
CLL Logical components covered: H4 WRITHIS1.18
CLL WRITHIS1.19
CLL Project task: H WRITHIS1.20
CLL WRITHIS1.21
CLL Documentation: Unified Model Documentation Paper WRITHIS1.22
CLL H- History Bricks WRITHIS1.23
CLL WRITHIS1.25
C WRITHIS1.26
C*L Interface and arguments: WRITHIS1.27
C WRITHIS1.28
SUBROUTINE WRITHIST 1,2WRITHIS1.29
* ( UNITHIST,UNITCOPY,ICODE,CMESSAGE ) GRB1F305.718
C WRITHIS1.31
IMPLICIT NONE WRITHIS1.32
C WRITHIS1.33
INTEGER UNITHIST ! In - History file unit GRB1F305.719
INTEGER UNITCOPY ! In - unit no. for copy of old history file GRB1F305.720
INTEGER ICODE ! Out - Return code from routine WRITHIS1.35
CHARACTER*80 CMESSAGE ! Out - Return message if failure occured GRB1F305.721
C* WRITHIS1.37
C WRITHIS1.38
CL Common blocks WRITHIS1.39
C WRITHIS1.40
*CALL CSUBMODL 
GRB1F305.722
*CALL CHSUNITS GRB1F305.723
*CALL CHISTORY WRITHIS1.41
C WRITHIS1.42
CHARACTER*80 FILENAME GRB1F305.724
CHARACTER*8 NLNAME GRB1F305.725
C*L EXTERNAL subroutines called WRITHIS1.43
EXTERNAL GET_FILE AD050293.147
C* WRITHIS1.45
CL WRITHIS1.46
CL 1. Open history file and rewind GRB1F305.726
CL WRITHIS1.48
CALL GET_FILE(UNITHIST,FILENAME,80,ICODE) GTD0F400.170
*IF -DEF,FUJITSU GRB1F405.66
OPEN(UNITHIST,FILE=FILENAME,FORM='FORMATTED',IOSTAT=ICODE, PXNAMLST.22
& DELIM='APOSTROPHE') PXNAMLST.23
*ELSE GRB1F405.67
OPEN(UNITHIST,FILE=FILENAME,FORM='FORMATTED', GRB1F405.68
& DELIM='APOSTROPHE',IOSTAT=ICODE) GRB1F405.69
*ENDIF GRB1F405.70
C WRITHIS1.51
C Check for error WRITHIS1.52
C WRITHIS1.53
IF(ICODE .GT.0)THEN WRITHIS1.54
CMESSAGE='WRITHIST: Failed in OPEN of permanent history file' WRITHIS1.55
GOTO 999 WRITHIS1.56
ELSEIF(ICODE .LT. 0)THEN WRITHIS1.57
WRITE(6,*)'WRITHIST: Warning message on OPEN of permanent history GIE0F403.689
* file' WRITHIS1.59
WRITE(6,*)'IOSTAT= ',ICODE GIE0F403.690
ENDIF WRITHIS1.61
C WRITHIS1.62
REWIND(UNITHIST) WRITHIS1.63
CL GRB1F305.728
CL 2. Write new record as first record of history file GRB1F305.729
CL GRB1F305.730
NLNAME = 'NLIHISTO' GRB1F305.731
WRITE(UNITHIST,NLIHISTO,ERR=200) GRB1F305.732
NLNAME = 'NLCHISTO' GRB1F305.733
WRITE(UNITHIST,NLCHISTO,ERR=200) GRB1F305.734
NLNAME = 'NLIHISTG' GRB1F305.735
WRITE(UNITHIST,NLIHISTG,ERR=200) GRB1F305.736
NLNAME = 'NLCHISTG' GRB1F305.737
WRITE(UNITHIST,NLCHISTG,ERR=200) GRB1F305.738
NLNAME = 'NLCFILES' GRB1F305.739
WRITE(UNITHIST,NLCFILES,ERR=200) GRB1F305.740
go to 199 GRB1F305.741
C GRB1F305.742
C Check for error GRB1F305.743
C GRB1F305.744
! Write error GRB1F305.745
200 continue GRB1F305.746
ICODE = 2 GRB1F305.747
CMESSAGE='WRITHIST: Write ERROR on history file for namelist'// GRB1F305.748
& NLNAME GRB1F305.749
go to 999 GRB1F305.750
199 continue GRB1F305.751
CL GRB1F305.752
CL 2. Open copy of old history file and rewind GRB1F305.753
CL GRB1F305.754
CALL GET_FILE(UNITCOPY,FILENAME,80,ICODE) GRB2F400.2
*IF -DEF,FUJITSU GRB1F405.71
OPEN(UNITCOPY,FILE=FILENAME,FORM='FORMATTED',IOSTAT=ICODE, PXNAMLST.24
& DELIM='APOSTROPHE') PXNAMLST.25
*ELSE GRB1F405.72
OPEN(UNITCOPY,FILE=FILENAME,FORM='FORMATTED', GRB1F405.73
& DELIM='APOSTROPHE',IOSTAT=ICODE) GRB1F405.74
*ENDIF GRB1F405.75
C WRITHIS1.65
C Check for error WRITHIS1.66
C WRITHIS1.67
IF(ICODE .GT.0)THEN WRITHIS1.68
CMESSAGE='WRITHIST: Failed in OPEN of copy of old history file' GRB1F305.757
GOTO 999 WRITHIS1.70
ELSEIF(ICODE .LT. 0)THEN WRITHIS1.71
WRITE(6,*)'WRITHIST:Warning message on OPEN of copy of old history GIE0F403.691
*y file' GRB1F305.759
WRITE(6,*)'IOSTAT= ',ICODE GIE0F403.692
ENDIF WRITHIS1.75
C WRITHIS1.76
REWIND(UNITCOPY) GRB1F305.760
CL WRITHIS1.79
CL 3. Read each record of old and write to new permanent history file GRB1F305.761
CL WRITHIS1.81
250 continue GRB1F305.762
NLNAME = 'NLIHISTO' GRB1F305.763
READ (UNITCOPY,NLIHISTO,END=100,ERR=300) GRB1F305.764
WRITE(UNITHIST,NLIHISTO,ERR=400) GRB1F305.765
NLNAME = 'NLCHISTO' GRB1F305.766
READ (UNITCOPY,NLCHISTO,END=100,ERR=300) GRB1F305.767
WRITE(UNITHIST,NLCHISTO,ERR=400) GRB1F305.768
NLNAME = 'NLIHISTG' GRB1F305.769
READ (UNITCOPY,NLIHISTG,END=100,ERR=300) GRB1F305.770
WRITE(UNITHIST,NLIHISTG,ERR=400) GRB1F305.771
NLNAME = 'NLCHISTG' GRB1F305.772
READ (UNITCOPY,NLCHISTG,END=100,ERR=300) GRB1F305.773
WRITE(UNITHIST,NLCHISTG,ERR=400) GRB1F305.774
NLNAME = 'NLCFILES' GRB1F305.775
READ (UNITCOPY,NLCFILES,END=100,ERR=300) GRB1F305.776
WRITE(UNITHIST,NLCFILES,ERR=400) GRB1F305.777
go to 250 GRB1F305.778
C WRITHIS1.87
C Check for error WRITHIS1.88
C WRITHIS1.89
! End-of-file GRB1F305.779
100 continue GRB1F305.780
IF (NLNAME .eq. 'NLIHISTO') THEN ! expected end-of-file URB0F401.3
WRITE(6,*)'Copied old history records to new phist file completed' GIE0F403.693
go to 999 GRB1F305.786
ELSE ! unexpected end-of-file URB0F401.4
ICODE = 1 GRB1F305.788
CMESSAGE='WRITHIST: End of file in READ from history file for name GRB1F305.789
&list '//NLNAME GRB1F305.790
go to 999 GRB1F305.791
END IF GRB1F305.792
! Read error GRB1F305.793
300 continue GRB1F305.794
ICODE = 3 GRB1F305.795
CMESSAGE='WRITHIST: Read ERROR on history file for namelist'// GRB1F305.796
& NLNAME GRB1F305.797
go to 999 GRB1F305.798
! Write error GRB1F305.799
400 continue GRB1F305.800
ICODE = 4 GRB1F305.801
CMESSAGE='WRITHIST: Write ERROR on history file for namelist'// GRB1F305.802
& NLNAME GRB1F305.803
C WRITHIS1.99
999 CONTINUE WRITHIS1.100
CL WRITHIS1.101
CL 3. Close and return WRITHIS1.102
CL WRITHIS1.103
CLOSE(UNITHIST) WRITHIS1.104
RETURN WRITHIS1.105
END WRITHIS1.106
*ENDIF WRITHIS1.107