*IF DEF,C80_1A,OR,DEF,UTILIO,OR,DEF,FLDC,OR,DEF,FLDOP UIE3F404.46
C ******************************COPYRIGHT****************************** GTS2F400.7669
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.7670
C GTS2F400.7671
C Use, duplication or disclosure of this code is subject to the GTS2F400.7672
C restrictions as set forth in the contract. GTS2F400.7673
C GTS2F400.7674
C Meteorological Office GTS2F400.7675
C London Road GTS2F400.7676
C BRACKNELL GTS2F400.7677
C Berkshire UK GTS2F400.7678
C RG12 2SZ GTS2F400.7679
C GTS2F400.7680
C If no contract has been raised with this copy of the code, the use, GTS2F400.7681
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.7682
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.7683
C Modelling at the above address. GTS2F400.7684
C ******************************COPYRIGHT****************************** GTS2F400.7685
C GTS2F400.7686
CLL SUBROUTINE PR_LOOK---------------------------------------- PRLOOK1A.3
CLL PRLOOK1A.4
CLL Purpose: Prints out Kth 64-word PP header PRLOOK1A.5
CLL PRLOOK1A.6
CLL AD, DR <- programmer of some or all of previous code or changes PRLOOK1A.7
CLL PRLOOK1A.8
CLL Model Modification history from model version 3.0: PRLOOK1A.9
CLL version Date PRLOOK1A.10
CLL AD050293.55
CLL 3.1 05/02/93 Trap use of user defined PPXREF file AD050293.56
CLL Author: A. Dickinson Reviewer: R. Stratton AD050293.57
! 3.5 27/06/95 Submodels project. Replace call to RDPPXRF by UDG2F305.435
! call to GETPPX UDG2F305.436
! Author D.M.Goddard Reviewer S Swarbrick UDG2F305.437
CLL 4.0 12/09/95 Change NPERIODS to LBUSER, LBUSER to LBPLEV GAB1F400.153
CLL as changes in CLOOKADD and PPHEAD1A. GAB1F400.154
CLL (Andrew Brady) GAB1F400.155
CLL 4.0 12/10/95 Chg. FORMAT, as last LBUSER is now MODEL_CODE. RTHB GRB1F400.89
! 4.0 24/08/95 Add dummy argument in call to GETPPX_REC UDG7F400.360
! Author D.M.Goddard Reviewer S Swarbrick UDG7F400.361
! 4.1 18/06/96 Changes to cope with changes in STASH addressing GDG0F401.1099
! Author D.M. Goddard. GDG0F401.1100
CLL System component: R30/W30 PRLOOK1A.12
CLL PRLOOK1A.13
CLL System task: F3 PRLOOK1A.14
CLL PRLOOK1A.15
CLL Programming standard: Unified Model Documentation Paper No 3 PRLOOK1A.16
CLL Version No 1 15/1/90 PRLOOK1A.17
CLL PRLOOK1A.18
CLL Documentation: Unified Model Documentation Paper No F3 PRLOOK1A.19
CLL Version No 5 9/2/90 PRLOOK1A.20
CLL PRLOOK1A.21
CLL------------------------------------------------------------ PRLOOK1A.22
C*L Arguments:------------------------------------------------- PRLOOK1A.23
SUBROUTINE PR_LOOK( 24,1GDG0F401.1101
*CALL ARGPPX 
GDG0F401.1102
& LOOKUP,RLOOKUP,LEN1_LOOKUP,K) GDG0F401.1103
PRLOOK1A.25
IMPLICIT NONE PRLOOK1A.26
PRLOOK1A.27
INTEGER LEN1_LOOKUP ! IN First dimension of Look Up Table PRLOOK1A.28
INTEGER K ! IN Field number in Look Up Table PRLOOK1A.29
INTEGER PRLOOK1A.30
* LOOKUP(LEN1_LOOKUP,*) ! IN Integer equivalence of PP LOOKUP PRLOOK1A.31
REAL PRLOOK1A.32
* RLOOKUP(LEN1_LOOKUP,*) ! IN Real equivalence of PP LOOKUP PRLOOK1A.33
PRLOOK1A.34
CHARACTER*36 EXPPXC GDG0F401.1104
GDG0F401.1105
C ------------------------------------------------------------- PRLOOK1A.35
C Workspace usage:--------------------------------------------- PRLOOK1A.36
C None PRLOOK1A.37
C ------------------------------------------------------------- PRLOOK1A.38
C*L External subroutines called:------------------------------- PRLOOK1A.39
EXTERNAL ABORT_IO ,EXPPXC GDG0F401.1106
C*------------------------------------------------------------- PRLOOK1A.41
C Comdecks: ------------------------------------------------------------ PRLOOK1A.42
*CALL CSUBMODL GDG0F401.1107
*CALL CPPXREF GDG0F401.1108
*CALL PPXLOOK GDG0F401.1109
*CALL CLOOKADD PRLOOK1A.45
PRLOOK1A.46
! Local variables:--------------------------------------------- UDG2F305.439
INTEGER ICODE !Error code UDG2F305.440
INTEGER ITEM !STASH item number UDG2F305.441
INTEGER SECTION !STASH section number UDG2F305.442
INTEGER MODEL !Internal model number UDG2F305.443
INTEGER I !Index UDG2F305.444
UDG7F400.372
CHARACTER*36 PHRASE !Character part of PPXREF record UDG2F305.448
CHARACTER*80 CMESSAGE !Error message UDG2F305.449
UDG2F305.450
UDG2F305.453
!-------------------------------------------------------------------- UDG2F305.454
UDG2F305.455
PRLOOK1A.64
CL Write time and field type PRLOOK1A.65
ITEM=MOD(LOOKUP(42,K),1000) PRLOOK1A.66
SECTION=(LOOKUP(42,K)-ITEM)/1000 PRLOOK1A.67
MODEL=LOOKUP(45,K) UDG2F305.456
ICODE = 0 GDG0F401.1110
PHRASE=EXPPXC(MODEL,SECTION,ITEM, GDG0F401.1111
*CALL ARGPPX GDG0F401.1112
& ICODE,CMESSAGE) GDG0F401.1113
IF(ICODE.NE.0)THEN PRLOOK1A.70
PHRASE='NON-STANDARD FIELD' GDG0F401.1114
ENDIF PRLOOK1A.72
PRLOOK1A.73
WRITE(6,100) K,LOOKUP(LBHR,K),LOOKUP(LBMIN,K),LOOKUP(LBDAT,K), PRLOOK1A.74
* LOOKUP(LBMON,K),LOOKUP(LBYR,K),LOOKUP(LBDAY,K),LOOKUP(LBHRD,K), PRLOOK1A.75
* LOOKUP(LBMIND,K),LOOKUP(LBDATD,K),LOOKUP(LBMOND,K), PRLOOK1A.76
& LOOKUP(LBYRD,K),LOOKUP(LBDAYD,K),PHRASE UDG2F305.459
PRLOOK1A.78
100 FORMAT(' FIELD NO.', I3, PRLOOK1A.79
* ' VALID AT: ', 2I2.2,'Z ON ',2(I2.2,'/'),I4.4,' DAY',I6, PRLOOK1A.80
* ' DATA TIME: ', 2I2.2,'Z ON ',2(I2.2,'/'),I4.4,' DAY',I6, 4X,A) PRLOOK1A.81
PRLOOK1A.82
CL Rest of header PRLOOK1A.83
WRITE(6,200) (LOOKUP(I,K),I=13,45),(RLOOKUP(I,K),I=46,64) PRLOOK1A.84
200 FORMAT( ' LBTIM LBFT LBLREC LBCODE LBHEM LBROW LBNPT', PRLOOK1A.85
* ' LBEXT LBPACK LBREL LBFC LBCFC LBPROC', PRLOOK1A.86
* ' LBVC LBRVC LBEXP LBBEGIN LBNREC'/ PRLOOK1A.87
* 1X, 18I7, / ,' LBPROJ LBTYP LBLEV LBRSVD LBRSVD LBRSVD', PRLOOK1A.88
* ' LBRSVD LBSRCE DATA_TYPE NADDR LBUSER ITEM_CODE LBPLEV GAB1F400.156
& LBUSER MODEL_CODE',/,1X,9I7,6I10,/,5X,'BRSVD(1)',4X, GRB1F400.90
& 'BRSVD(2)',4X,'BRSVD(3)',4X,'BRSVD(4)', GRB1F400.91
* 6X, 'BDATUM', 8X, 'BACC', 8X, 'BLEV', 7X, 'BRLEV', 7X, 'BHLEV',/ PRLOOK1A.92
* 1X, 1P, 9E12.4, /, PRLOOK1A.93
* 7X, 'BHRLEV', 7X, 'BPLAT', 7X, 'BPLON', 8X, 'BGOR', 9X, 'BZY', PRLOOK1A.94
* 9X, 'BDY', 9X, 'BZX', 9X, 'BDX', 8X, 'BMDI', 8X, 'BMKS',/, PRLOOK1A.95
* 1X, 1P, 10E12.4) PRLOOK1A.96
PRLOOK1A.97
WRITE(6,'('' '')') PRLOOK1A.98
RETURN PRLOOK1A.99
END PRLOOK1A.100
PRLOOK1A.101
*ENDIF PRLOOK1A.102