*IF DEF,PICK PICKUP1.2
C ******************************COPYRIGHT****************************** GTS2F400.7237
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.7238
C GTS2F400.7239
C Use, duplication or disclosure of this code is subject to the GTS2F400.7240
C restrictions as set forth in the contract. GTS2F400.7241
C GTS2F400.7242
C Meteorological Office GTS2F400.7243
C London Road GTS2F400.7244
C BRACKNELL GTS2F400.7245
C Berkshire UK GTS2F400.7246
C RG12 2SZ GTS2F400.7247
C GTS2F400.7248
C If no contract has been raised with this copy of the code, the use, GTS2F400.7249
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.7250
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.7251
C Modelling at the above address. GTS2F400.7252
C ******************************COPYRIGHT****************************** GTS2F400.7253
C GTS2F400.7254
CLL Routine: PICKUP--------------------------------------------------- PICKUP1.3
CLL PICKUP1.4
CLL Purpose: To prepend the temporary history file record to the URB1F305.34
CLL beginning of the permanent history file URB1F305.35
CLL PICKUP1.7
CLL + other functions that will be added later PICKUP1.8
CLL PICKUP1.9
CLL Tested under compiler: cft77 PICKUP1.10
CLL Tested under OS version: UNICOS 5.0 PICKUP1.11
CLL PICKUP1.12
CLL Author: A.Sangster PICKUP1.13
CLL PICKUP1.14
CLL Model Modification history from model version 3.0: PICKUP1.15
CLL version date PICKUP1.16
CLL 3.1 1/02/93 : Added comdeck CHSUNITS to define NUNITS for RS030293.67
CLL extra i/o RS030293.68
CLL 3.5 03/05/95 Sub-models stage 1: History/control files. RTHBarnes URB1F305.36
CLL PICKUP1.17
CLL Programming standard: UM Doc Paper 3, draft version 3 (15/1/90) PICKUP1.18
CLL PICKUP1.19
CLL Logical components covered:E2 PICKUP1.20
CLL PICKUP1.21
CLL Project task: E PICKUP1.22
CLL PICKUP1.23
CLL Documentation: Unified Model Documentation Paper PICKUP1.24
CLL H- History Bricks PICKUP1.25
CLL Version 5 18/6/90 PICKUP1.26
CLL PICKUP1.27
C PICKUP1.28
C*L Interface and arguments PICKUP1.29
C PICKUP1.30
PROGRAM PICKUP ,4PICKUP1.31
C PICKUP1.32
IMPLICIT NONE PICKUP1.33
C* PICKUP1.34
C PICKUP1.35
CL Common blocks PICKUP1.36
C PICKUP1.37
*CALL CSUBMODL 
URB1F305.37
*CALL CHSUNITS RS030293.69
*CALL CHISTORY URB1F305.38
C PICKUP1.40
C*L EXTERNAL subroutines called PICKUP1.41
EXTERNAL INITCHST,READHIST,WRITHIST,EREPORT,ABORT PICKUP1.42
C* PICKUP1.43
C PICKUP1.44
C Local variables PICKUP1.45
C PICKUP1.46
INTEGER ICODE,IABORT ! Work- Return codes from called routines PICKUP1.47
INTEGER CHIST_UNIT ! Unit no. to which old history file is URB1F305.39
! ! copied in script qspickup URB1F305.40
CHARACTER*256 CMESSAGE ! Work- Return message if failure occured PICKUP1.48
CL PICKUP1.49
CL 1. Set common block area to zero or blank PICKUP1.50
CL PICKUP1.51
CALL INITCHST PICKUP1.52
CL PICKUP1.53
CL 2. Read temporary history file records URB1F305.41
CL PICKUP1.55
CALL READHIST(THIST_UNIT,ICODE,CMESSAGE) PICKUP1.56
IF(ICODE .GT. 0) GOTO 999 PICKUP1.57
CL PICKUP1.58
CL 3. Prepend temporary history records to beginning of URB1F305.42
CL permanent history file URB1F305.43
CL PICKUP1.60
RUN_HIST_TYPE='Permanent' PICKUP1.61
CHIST_UNIT = 9 ! Must check this against script qspickup URB1F305.44
CALL WRITHIST(PHIST_UNIT,CHIST_UNIT,ICODE,CMESSAGE) URB1F305.45
IF(ICODE .GT. 0) GOTO 999 PICKUP1.63
999 CONTINUE PICKUP1.64
CL PICKUP1.65
CL 4. Output error message if problem PICKUP1.66
CL PICKUP1.67
IABORT=ICODE PICKUP1.68
IF(ICODE .NE. 0) CALL EREPORT(ICODE,CMESSAGE) PICKUP1.69
CL PICKUP1.70
CL 5. Stop and abort if problem PICKUP1.71
CL PICKUP1.72
IF(IABORT .GT. 0)CALL ABORT PICKUP1.73
STOP PICKUP1.74
END PICKUP1.75
*ENDIF PICKUP1.76