*IF DEF,C70_1A,OR,DEF,RECON,OR,DEF,UTILIO,OR,DEF,FLDOP GLW1F404.48
C ******************************COPYRIGHT****************************** GTS2F400.8137
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.8138
C GTS2F400.8139
C Use, duplication or disclosure of this code is subject to the GTS2F400.8140
C restrictions as set forth in the contract. GTS2F400.8141
C GTS2F400.8142
C Meteorological Office GTS2F400.8143
C London Road GTS2F400.8144
C BRACKNELL GTS2F400.8145
C Berkshire UK GTS2F400.8146
C RG12 2SZ GTS2F400.8147
C GTS2F400.8148
C If no contract has been raised with this copy of the code, the use, GTS2F400.8149
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.8150
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.8151
C Modelling at the above address. GTS2F400.8152
C ******************************COPYRIGHT****************************** GTS2F400.8153
C GTS2F400.8154
CLL SUBROUTINE READSTM READSTM1.3
CLL PURPOSE TO READ A RECORD FROM THE PRE STASH-MASTERS FILE READSTM1.4
CLL AND RETURN THE PPXREF CODES AND NAME OF A GIVEN DIAGNOSTIC READSTM1.5
CLL TESTED UNDER CFT77 ON OS 5.1 READSTM1.6
CLL READSTM1.7
CLL AUTHOR M.J.CARTER DATE 23/01/92 READSTM1.8
CLL READSTM1.9
CLL MODEL MODIFICATION HISTORY FROM MODEL VERSION 3.0: READSTM1.10
CLL VERSION DATE READSTM1.11
CLL 3.2 13/07/93 Changed CHARACTER*(*) to CHARACTER*(80) for TS150793.240
CLL portability. Author Tracey Smith. TS150793.241
CLL 3.3 26/10/93 M. Carter. Part of an extensive mod that: MC261093.238
CLL 1.Removes the limit on primary STASH item numbers. MC261093.239
CLL 2.Removes the assumption that (section,item) MC261093.240
CLL defines the sub-model. MC261093.241
CLL 3.Thus allows for user-prognostics. MC261093.242
CLL Add read of new record for sub-model type. MC261093.243
CLL 3.4 01/11/94 M.Carter. Change to stash-master file format GMC1F304.1
CLL to allow 4 digits for PP field code. GMC1F304.2
CLL 3.5 13/03/95 Sub-Models Project: GSS1F305.742
CLL Mods which facilitate expansion of PPXREF file to GSS1F305.743
CLL incorporate the entire preSTASHmaster record, and GSS1F305.744
CLL to have "Internal Model no." as an extra dimension GSS1F305.745
CLL in the file (in addition to section,item). GSS1F305.746
CLL S.J.Swarbrick GSS1F305.747
! 4.0 15/12/95 Changed interface : Added Int_Model_no as an ANF5F400.4
! extra argument, rather than using CODES(1) ANF5F400.5
! which can overwrite DNAM due to equivalencing ANF5F400.6
! in MKPPXRF1. P.Burton ANF5F400.7
! 4.1 Apr. 96 Modified to read new format of STASH master files GSS2F401.310
! S.J.Swarbrick GSS2F401.311
! vn4.4 10/4/97 Changes to FORMAT statements to allow UIE2F404.1327
! NAG f90 compiled code to run. Ian Edmond UIE2F404.1328
CLL READSTM1.12
CLL LOGICAL COMPONENT R913 READSTM1.13
CLL READSTM1.14
CLL PROJECT TASK: C4 READSTM1.15
CLL READSTM1.16
CLL PROGRAMMING STANDARD UMDP 4 READSTM1.17
CLL READSTM1.18
CLL EXTERNAL DOCUMENT C4 READSTM1.19
CLL READSTM1.20
CLLEND READSTM1.21
SUBROUTINE READSTM 6GSS1F305.748
& (IMASK,DNAM,CODES,NFT,ICODE,CMESSAGE) GSS2F401.312
IMPLICIT NONE READSTM1.23
READSTM1.24
*CALL CSUBMODL 
GSS1F305.750
*CALL CPPXREF READSTM1.25
*CALL VERSION GSS1F305.751
READSTM1.26
C ARGUMENTS READSTM1.27
INTEGER NFT !IN: UNIT NUMBER STMSTS GSS2F401.313
READSTM1.31
INTEGER ICODE !OUT: RETURN CODE GSS1F305.753
CHARACTER*(80) CMESSAGE !OUT: RETURN MESSAGE IF THERE IS A FAILURE TS150793.242
READSTM1.34
CHARACTER*1 DNAM(PPXREF_CHARLEN) !OUT: VARIABLE NAME FROM RECORD GSS1F305.754
INTEGER CODES(PPXREF_CODELEN) !OUT: PPXREF CODES FROM RECORD READSTM1.36
INTEGER IMASK(20) !OUT: VERSION MASK GSS1F305.755
READSTM1.37
INTEGER IMSK ! Decimal equivalent of binary IMASK GSS2F401.314
INTEGER II !LOCAL: loop mark. READSTM1.38
integer opcod(20) GSS2F401.315
C READSTM1.39
ICODE=0 READSTM1.40
CMESSAGE=' ' READSTM1.41
GSS2F401.316
READ(NFT,2010,END=3100,ERR=3200) GSS1F305.756
& CODES(ppx_model_number) , GSS2F401.317
& CODES(ppx_section_number), GSS2F401.318
& CODES(ppx_item_number) , DNAM GSS2F401.319
2010 FORMAT(2X,3(I5,2X),36A1) GSS2F401.320
GSS2F401.321
IF(CODES(ppx_model_number).EQ.-1) GO TO 9999 GSS2F401.322
GSS2F401.323
READ(NFT,2110,END=3100,ERR=3200) GSS2F401.324
& CODES(ppx_space_code), GSS1F305.760
& CODES(ppx_ptr_code), GSS2F401.325
& CODES(ppx_timavail_code), GSS1F305.761
& CODES(ppx_grid_type), GSS1F305.762
& CODES(ppx_lv_code), GSS1F305.763
& CODES(ppx_lb_code), GSS1F305.764
& CODES(ppx_lt_code), GSS1F305.765
& CODES(ppx_pt_code), GSS1F305.768
& CODES(ppx_pf_code), GSS1F305.769
& CODES(ppx_pl_code), GSS1F305.770
& CODES(ppx_lev_flag) GSS2F401.326
2110 FORMAT(2X,11(I5,2X)) GSS2F401.327
GSS2F401.328
! 20-digit option code read in as 4x5 digit groups GSS2F401.329
READ(NFT,2120,END=3100,ERR=3200) GSS2F401.330
&(opcod(ii),ii=1,20), GSS2F401.331
&(IMASK(II),II=1,20) GSS2F401.332
2120 FORMAT(3X,20(I1),3X,20(I1)) UIE2F404.1330
GSS2F401.334
CODES(ppx_opt_code )= GSS2F401.335
& opcod(20)+opcod(19)*10 +opcod(18)*100 + GSS2F401.336
& opcod(17)*1000+opcod(16)*10000 GSS2F401.337
CODES(ppx_opt_code+1)= GSS2F401.338
& opcod(15)+opcod(14)*10 +opcod(13)*100 + GSS2F401.339
& opcod(12)*1000+opcod(11)*10000 GSS2F401.340
CODES(ppx_opt_code+2)= GSS2F401.341
& opcod(10)+opcod( 9)*10 +opcod( 8)*100 + GSS2F401.342
& opcod( 7)*1000+opcod( 6)*10000 GSS2F401.343
CODES(ppx_opt_code+3)= GSS2F401.344
& opcod( 5)+opcod( 4)*10 +opcod( 3)*100 + GSS2F401.345
& opcod( 2)*1000+opcod( 1)*10000 GSS2F401.346
GSS2F401.347
! Binary version mask was read into array IMASK GSS2F401.348
! Convert version mask to decimal form IMSK GSS2F401.349
IMSK = 0 GSS2F401.350
DO II=20,1,-1 GSS2F401.351
IF((IMASK(II).NE.0).AND.(IMASK(II).NE.1)) THEN GSS2F401.352
WRITE(6,*) 'READSTM: improper IMASK in user diag' GSS2F401.353
WRITE(6,*) 'Model, Section, Item ', GSS2F401.354
& CODES(ppx_model_number) , GSS2F401.355
& CODES(ppx_section_number), GSS2F401.356
& CODES(ppx_item_number) GSS2F401.357
ELSE GSS2F401.358
IF(IMASK(II).EQ.1) THEN GSS2F401.359
IMSK=IMSK+2**(20-II) GSS2F401.360
END IF GSS2F401.361
END IF GSS2F401.362
END DO GSS2F401.363
! Insert decimal value of version mask GSS2F401.364
CODES(ppx_version_mask)=IMSK GSS2F401.365
GSS2F401.366
READ(NFT,2130,END=3100,ERR=3200) GSS2F401.367
& CODES(ppx_data_type), GSS2F401.368
& CODES(ppx_dump_packing), GSS1F305.772
&(CODES(II), GSS2F401.369
& II= ppx_pack_acc, ppx_pack_acc+PPXREF_PACK_PROFS-1) GSS2F401.370
2130 FORMAT(2X,I5,2X,I5,3X,I3,9(2X,I3)) UIE2F404.1329
GSS2F401.372
READ(NFT,2140,END=3100,ERR=3200) GSS2F401.373
& CODES(ppx_rotate_code), GSS2F401.374
& CODES(ppx_field_code), GSS1F305.776
& CODES(ppx_user_code), GSS1F305.777
& CODES(ppx_lbvc_code), GSS2F401.375
& CODES(ppx_base_level), GSS1F305.780
& CODES(ppx_top_level), GSS1F305.781
& CODES(ppx_ref_lbvc_code), GSS1F305.782
& CODES(ppx_cf_levelcode), GSS2F401.376
& CODES(ppx_cf_fieldcode) GSS2F401.377
2140 FORMAT(2X,9(I5,2X)) GSS2F401.378
3100 GO TO 9999 ! Normal completion GSS1F400.1200
3200 WRITE(6,*)' MESSAGE FROM ROUTINE READSTM: ' GSS2F401.379
WRITE(6,*)' ERROR OCCURRED WHILE READING STASHmaster FILE ' GSS2F401.380
CMESSAGE=' READSTM: ERROR READING STASHMASTERS FILE' READSTM1.72
ICODE=2 READSTM1.73
GSS1F305.789
9999 CONTINUE GSS1F305.790
RETURN GSS1F305.791
GSS1F305.792
END READSTM1.76
READSTM1.77
*ENDIF READSTM1.78