*IF DEF,C70_1A GLW1F404.2
C ******************************COPYRIGHT****************************** GTS2F400.181
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.182
C GTS2F400.183
C Use, duplication or disclosure of this code is subject to the GTS2F400.184
C restrictions as set forth in the contract. GTS2F400.185
C GTS2F400.186
C Meteorological Office GTS2F400.187
C London Road GTS2F400.188
C BRACKNELL GTS2F400.189
C Berkshire UK GTS2F400.190
C RG12 2SZ GTS2F400.191
C GTS2F400.192
C If no contract has been raised with this copy of the code, the use, GTS2F400.193
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.194
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.195
C Modelling at the above address. GTS2F400.196
C ******************************COPYRIGHT****************************** GTS2F400.197
C GTS2F400.198
CLL Subroutine ADDRESS_CHECK -------------------------------------- ADDRCHK1.3
CLL ADDRCHK1.4
CLL Purpose : Check that start addresses of fields read in agree ADDRCHK1.5
CLL with start addresses set up by UI. Called in INITDUMP ADDRCHK1.6
CLL if prognostic fields read in from atmos or ocean dumps. ADDRCHK1.7
CLL ADDRCHK1.8
CLL Model Date Modification history: ADDRCHK1.9
CLL version ADDRCHK1.10
CLL 3.2 25/05/93 New routine. D Robinson ADDRCHK1.11
CLL 3.4 16/6/94 : Change CHARACTER*(*) to CHARACTER*(80) N.Farnon ANF0F304.3
CLL 3.5 May 95 Submodels project. Inserted *CALL CSUBMODL, GSS1F305.140
CLL *CALL CPPXREF, *CALL ARGPPX, *CALL PPXLOOK GSS1F305.141
CLL to pass ppxref lookup arrays to F_TYPE. GSS1F305.142
CLL Modified reference to SI to take account of GSS1F305.143
CLL submodel partitioning. GSS1F305.144
CLL S.J.Swarbrick GSS1F305.145
CLL 4.0 05/01/96 Get Internal identifier from LOOKUP(45) to GDR8F400.40
CLL determine im_index for SI array. D. Robinson GDR8F400.41
CLL 4.1 21/03/96 MPP code : Added MPP_DUMP_ADDR/LEN arguments for GPB0F401.81
CLL use when checking dump addressing against stash GPB0F401.82
CLL addressing. P.Burton GPB0F401.83
CLL 4.1 23/05/96 Remove internal_model from argument list. WRB1F401.1
CLL D. Robinson WRB1F401.2
CLL 4.4 01/09/97 Add helpful message after consistency checks. RTHB. ARB1F404.1
CLL ADDRCHK1.12
CLL Programming Standard : UM documentation paper no. 3 ADDRCHK1.13
CLL version no. 1, dated 15/01/90 ADDRCHK1.14
CLL ADDRCHK1.15
CLL Documentation : None ADDRCHK1.16
CLL ADDRCHK1.17
CLLEND-------------------------------------------------------------- ADDRCHK1.18
C ADDRCHK1.19
C*L Arguments ADDRCHK1.20
ADDRCHK1.21
*IF -DEF,MPP GPB0F401.84
SUBROUTINE ADDRESS_CHECK (LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP, 5,1ADDRCHK1.22
*ELSE GPB0F401.85
SUBROUTINE ADDRESS_CHECK (LOOKUP,MPP_DUMP_ADDR,MPP_DUMP_LEN, 5,1GPB0F401.86
& LEN1_LOOKUP,LEN2_LOOKUP, GPB0F401.87
*ENDIF GPB0F401.88
+ SI,NITEMS,NSECTS,LEN_DATA, ADDRCHK1.23
*CALL ARGPPX 
GSS1F305.146
& ICODE,CMESSAGE) WRB1F401.3
ADDRCHK1.25
IMPLICIT NONE ADDRCHK1.26
ADDRCHK1.27
*CALL CSUBMODL GSS1F305.148
*CALL CPPXREF GSS1F305.149
*CALL PPXLOOK GSS1F305.150
GSS1F305.151
INTEGER ADDRCHK1.28
+ LEN1_LOOKUP ! 1st dimension of lookup table WRB1F401.4
+ ,LEN2_LOOKUP ! 2nd dimension of lookup table ADDRCHK1.30
+ ,LOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) ! Lookup table ADDRCHK1.31
*IF DEF,MPP GPB0F401.89
+ ,MPP_DUMP_ADDR(LEN2_LOOKUP) ! Addresses of fields as GPB0F401.90
! ! calculated in READDUMP. GPB0F401.91
+ ,MPP_DUMP_LEN(LEN2_LOOKUP) ! Lengths of fields as GPB0F401.92
! ! calculated in READDUMP. GPB0F401.93
GPB0F401.94
*ENDIF GPB0F401.95
+ ,LEN_DATA ! Expected length of data ADDRCHK1.32
+ ,NITEMS ! No of stash items ADDRCHK1.33
+ ,NSECTS ! No of stash sections ADDRCHK1.34
! Stash item addresses GSS1F305.154
+ ,SI(NITEMS,0:NSECTS,N_INTERNAL_MODEL) GSS1F305.155
+ ,ICODE ! Return code ADDRCHK1.36
ADDRCHK1.37
CHARACTER*(80) ANF0F304.4
+ CMESSAGE ! Error message ADDRCHK1.39
ADDRCHK1.40
CL Dynamic allocation of arrays for F_TYPE ADDRCHK1.41
INTEGER ADDRCHK1.42
+ PP_NUM (LEN2_LOOKUP) ADDRCHK1.43
+ ,PP_LEN (LEN2_LOOKUP) ADDRCHK1.44
+ ,PP_POS (LEN2_LOOKUP) ADDRCHK1.45
+ ,PP_LS (LEN2_LOOKUP) ADDRCHK1.46
+ ,PP_STASH (LEN2_LOOKUP) ADDRCHK1.47
+ ,PP_TYPE (LEN2_LOOKUP) ADDRCHK1.48
ADDRCHK1.49
CL Local array ADDRCHK1.50
INTEGER FIXHD(256) ! Dummy array until removed from F_TYPE ADDRCHK1.51
ADDRCHK1.52
CL Local variables ADDRCHK1.53
INTEGER ADDRCHK1.54
+ ADDRESS_STASH ADDRCHK1.55
+ ,ADDRESS_LOOKUP ADDRCHK1.56
+ ,ITEM_CODE ADDRCHK1.57
+ ,J ADDRCHK1.58
+ ,LEN ADDRCHK1.59
+ ,N_TYPES ADDRCHK1.60
+ ,SECT_NO ADDRCHK1.61
+ ,im_ident ! Internal model identifier GDR8F400.42
+ ,im_index ! Position of int mod id in INTERNAL_MODEL_LIST GSS1F305.156
&,OLD_STASH ! VALUE OF STASH NUMBER ON PREVIOUS ITERATION OF LOOP ADDRCHK1.62
ADDRCHK1.63
CHARACTER*80 TITLE ADDRCHK1.64
ADDRCHK1.65
CL Subroutines called ADDRCHK1.66
EXTERNAL F_TYPE ADDRCHK1.67
ADDRCHK1.68
C*--------------------------------------------------------------------- ADDRCHK1.69
C ADDRCHK1.70
C SET INITIAL VALUE OF PREVIOUS STASH NUMBER ADDRCHK1.71
C ADDRCHK1.72
OLD_STASH = -1 ADDRCHK1.73
C ADDRCHK1.74
CL Internal Structure ADDRCHK1.75
ADDRCHK1.76
TITLE = 'Prognostic fields' ADDRCHK1.77
C modify f_type later to add len1_lookup and remove fixhd ADDRCHK1.78
CALL F_TYPE (LOOKUP,LEN2_LOOKUP,PP_NUM,N_TYPES,PP_LEN, ADDRCHK1.79
+ PP_STASH,PP_TYPE,PP_POS,PP_LS,FIXHD, GSS1F305.157
*CALL ARGPPX GSS1F305.158
+TITLE) GSS1F305.159
ADDRCHK1.81
DO J=1,N_TYPES ADDRCHK1.82
ADDRCHK1.83
C Get Stash Section no and Item Code ADDRCHK1.84
ITEM_CODE = MOD ( PP_STASH(J),1000) ADDRCHK1.85
SECT_NO = (PP_STASH(J)-ITEM_CODE)/1000 ADDRCHK1.86
GDR8F400.43
! Get im_ident/index for this field GDR8F400.44
im_ident = LOOKUP(45,pp_pos(j)) GDR8F400.45
im_index = INTERNAL_MODEL_INDEX(im_ident) GDR8F400.46
GDR8F400.47
C Get lookup and stash start address ADDRCHK1.88
*IF -DEF,MPP GPB0F401.96
ADDRESS_LOOKUP = LOOKUP(40,PP_POS(J)) ADDRCHK1.89
*ELSE GPB0F401.97
ADDRESS_LOOKUP = MPP_DUMP_ADDR(PP_POS(J)) GPB0F401.98
*ENDIF GPB0F401.99
ADDRESS_STASH = SI(ITEM_CODE,SECT_NO,im_index) GSS1F305.166
ADDRCHK1.91
C Check that they match ADDRCHK1.92
C ADDRCHK1.93
C CHECK THAT START ADDRESSES AGREE FOR FIRST OCCURRANCE ADDRCHK1.94
C OF A NEW STASH CODE: FOR FIXED LENGTH FIELDS THERE ADDRCHK1.95
C IS ONLY ONE ENTRY IN THE PP_STASH ARRAY FOR EACH ADDRCHK1.96
C STASH CODE, BUT FOR PACKED FIELDS (EG OCEAN) ADDRCHK1.97
C EACH LEVEL MIGHT HAVE A DIFFERENT LENGTH AND ADDRCHK1.98
C GENERATE A NEW PP_STASH VALUE. ADDRCHK1.99
C ADDRCHK1.100
IF (ADDRESS_STASH .NE. ADDRESS_LOOKUP .AND. ADDRCHK1.101
& OLD_STASH .NE. PP_STASH(J) ) THEN ADDRCHK1.102
CMESSAGE = 'ADDR_CHK : Mis_match in start addresses' ADDRCHK1.103
WRITE (6,*) ' Stash Sect No ',SECT_NO,' Item No ',ITEM_CODE ADDRCHK1.104
WRITE (6,*) ' Start Address in SI ',ADDRESS_STASH ADDRCHK1.105
WRITE (6,*) ' Start Address in LOOKUP Table ',ADDRESS_LOOKUP ADDRCHK1.106
WRITE (6,*) ' You probably need to RECONFIGURE the start dump' ARB1F404.2
ICODE = 1 ADDRCHK1.107
GO TO 999 ! Return ADDRCHK1.108
ENDIF ADDRCHK1.109
ADDRCHK1.110
C REMEMBER CURRENT VERSOIN OF PP_STASH FOR NEXT TIME THRU LOOP ADDRCHK1.111
OLD_STASH = PP_STASH(J) ADDRCHK1.112
C ADDRCHK1.113
ENDDO ADDRCHK1.114
ADDRCHK1.115
C Check full length ADDRCHK1.116
LEN = 0 ADDRCHK1.117
DO J=1,LEN2_LOOKUP ADDRCHK1.118
*IF -DEF,MPP GPB0F401.100
LEN = LEN + LOOKUP(15,J) ADDRCHK1.119
*ELSE GPB0F401.101
LEN = LEN + MPP_DUMP_LEN(J) GPB0F401.102
*ENDIF GPB0F401.103
ENDDO ADDRCHK1.120
ADDRCHK1.121
IF (LEN .NE. LEN_DATA) THEN ADDRCHK1.122
CMESSAGE = 'ADDR_CHK : Mismatch in length of data' ADDRCHK1.123
WRITE (6,*) ' Length according to LOOKUP table ',LEN ADDRCHK1.124
WRITE (6,*) ' Length set up in D1 array ',LEN_DATA ADDRCHK1.125
WRITE (6,*) ' You probably need to RECONFIGURE the start dump' ARB1F404.3
ICODE = 2 ADDRCHK1.126
GO TO 999 ! Return ADDRCHK1.127
ENDIF ADDRCHK1.128
ADDRCHK1.129
999 RETURN ADDRCHK1.130
END ADDRCHK1.131
*ENDIF ADDRCHK1.132