*IF DEF,C80_1A,OR,DEF,UTILIO,OR,DEF,RECON UIE3F404.35
C ******************************COPYRIGHT****************************** GTS2F400.6121
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.6122
C GTS2F400.6123
C Use, duplication or disclosure of this code is subject to the GTS2F400.6124
C restrictions as set forth in the contract. GTS2F400.6125
C GTS2F400.6126
C Meteorological Office GTS2F400.6127
C London Road GTS2F400.6128
C BRACKNELL GTS2F400.6129
C Berkshire UK GTS2F400.6130
C RG12 2SZ GTS2F400.6131
C GTS2F400.6132
C If no contract has been raised with this copy of the code, the use, GTS2F400.6133
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.6134
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.6135
C Modelling at the above address. GTS2F400.6136
C ******************************COPYRIGHT****************************** GTS2F400.6137
C GTS2F400.6138
CLL SUBROUTINE NEWPACK:-------------------------------------- NEWPAC1A.3
CLL NEWPAC1A.4
CLL Purpose: Packing codes stored in LOOKUP(21,K) & LOOKUP(39,K) NEWPAC1A.5
CLL are changed from pre vn2.8 values to NEWPAC1A.6
CLL specification required at release 2.8 NEWPAC1A.7
CLL NEWPAC1A.8
CLL Written by A. Dickinson 28/08/92 NEWPAC1A.9
CLL NEWPAC1A.10
CLL Model Modification history from model version 3.0: NEWPAC1A.11
CLL version Date NEWPAC1A.12
CLL 3.2 13/07/93 Tidyied up integer declararions TS150793.249
CLL NEWPAC1A.13
CLL Programming standard : NEWPAC1A.14
CLL NEWPAC1A.15
CLL Logical components covered : NEWPAC1A.16
CLL NEWPAC1A.17
CLL Project task : NEWPAC1A.18
CLL NEWPAC1A.19
CLL Documentation: UM Documentation Paper F3 NEWPAC1A.20
CLL NEWPAC1A.21
CLLEND ----------------------------------------------------------------- NEWPAC1A.22
C NEWPAC1A.23
SUBROUTINE NEWPACK 1NEWPAC1A.24
1(LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP) NEWPAC1A.25
NEWPAC1A.26
IMPLICIT NONE NEWPAC1A.27
NEWPAC1A.28
INTEGER TS150793.250
1 LEN1_LOOKUP TS150793.251
1,LEN2_LOOKUP TS150793.252
1,LOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) TS150793.253
TS150793.254
NEWPAC1A.33
INTEGER NEWPAC1A.34
1 N1 NEWPAC1A.35
1,N2 NEWPAC1A.36
1,N3 NEWPAC1A.37
1,K NEWPAC1A.38
NEWPAC1A.39
DO K=1,LEN2_LOOKUP NEWPAC1A.40
N1=0 NEWPAC1A.41
N2=0 NEWPAC1A.42
N3=0 NEWPAC1A.43
IF(LOOKUP(21,K).EQ.-2)N1=2 NEWPAC1A.44
C Ocean field packed using index array NEWPAC1A.45
IF(LOOKUP(21,K).GT.9.AND.LOOKUP(21,K).LT.100)THEN NEWPAC1A.46
N2=1 NEWPAC1A.47
N3=LOOKUP(21,K)-10 NEWPAC1A.48
ENDIF NEWPAC1A.49
C Ocean field compressed using bit mask NEWPAC1A.50
IF(LOOKUP(21,K).GT.99)THEN NEWPAC1A.51
N2=2 NEWPAC1A.52
N3=LOOKUP(21,K)-100 NEWPAC1A.53
ENDIF NEWPAC1A.54
C Real field stored at land pts NEWPAC1A.55
IF(LOOKUP(39,K).EQ.4)THEN NEWPAC1A.56
LOOKUP(39,K)=1 NEWPAC1A.57
N2=2 NEWPAC1A.58
N3=1 NEWPAC1A.59
ENDIF NEWPAC1A.60
C Integer field stored at land pts NEWPAC1A.61
IF(LOOKUP(39,K).EQ.5)THEN NEWPAC1A.62
LOOKUP(39,K)=2 NEWPAC1A.63
N2=2 NEWPAC1A.64
N3=1 NEWPAC1A.65
ENDIF NEWPAC1A.66
NEWPAC1A.67
LOOKUP(21,K)=100*N3+10*N2+N1 NEWPAC1A.68
ENDDO NEWPAC1A.69
NEWPAC1A.70
RETURN NEWPAC1A.71
END NEWPAC1A.72
*ENDIF NEWPAC1A.73