SUBROUTINE GRIB_UM( 1,38UDG2F305.419
*CALL ARGPPX 
UDG2F305.420
& LEN2_LOOKUP,ROW_LENGTH,P_ROWS,P_LEVELS, UDG2F305.421
& BL_LEVELS,SM_LEVELS,ST_LEVELS, UDG3F405.213
& YEAR,MONTH,DAY,HOUR,MINUTE, UDG3F405.214
& N_M_FIELDS,N_S_FIELDS,POS_LSM, UDG3F405.215
& N_SOIL_LEVELS,LSKINTEMP, UDG3F405.216
& ECMWF_SOIL_LEVELS,ECMWF_SOIL_DEPTHS, UDG3F405.217
& NFTIN,NFTOUT,LPSTAR,GRIB_RECORD_START_ADDRESS UDG3F405.218
*,GRIB_RECORD_LENGTH,AK,BK,HYBRID) AD110293.174
GRIB_UM1.42
IMPLICIT NONE GRIB_UM1.43
GRIB_UM1.44
INTEGER GRIB_UM1.45
* LEN2_LOOKUP !No of GRIB fields GRIB_UM1.46
*,ROW_LENGTH !No of points E-W GRIB_UM1.47
*,P_ROWS !No of points N-S GRIB_UM1.48
*,P_LEVELS !No of levels GRIB_UM1.49
*,BL_LEVELS !No of BL levels GRIB_UM1.50
*,SM_LEVELS !No of soil moisture levels UDG3F405.219
*,ST_LEVELS !No of soil temperature levels UDG3F405.220
*,N_M_FIELDS !No of upper level fields GRIB_UM1.51
*,N_S_FIELDS !No of single level fields GRIB_UM1.52
*,N_SOIL_LEVELS !No of soil levels UDG3F405.221
*,YEAR ! GRIB_UM1.53
*,MONTH ! GRIB_UM1.54
*,DAY !> Analysis date & time GRIB_UM1.55
*,HOUR ! GRIB_UM1.56
*,MINUTE ! GRIB_UM1.57
*,NFTIN !Unit no containing GRIB data GRIB_UM1.58
*,NFTOUT !Unit no to which UM dump is written GRIB_UM1.59
*,POS_LSM !Position of LSM among single level fields UDG3F405.222
! in GRIB file. UDG3F405.223
*,GRIB_RECORD_START_ADDRESS(LEN2_LOOKUP) AD110293.175
*,GRIB_RECORD_LENGTH(LEN2_LOOKUP) AD110293.176
GRIB_UM1.61
GRIB_UM1.62
REAL GRIB_UM1.63
* AK(P_LEVELS) !Levels AD110293.177
*,BK(P_LEVELS) !Levels AD110293.178
!,ECMWF_SOIL_LEVELS(N_SOIL_LEVELS) UDG3F405.224
!Array containing ECMWF soil levels UDG3F405.225
!,ECMWF_SOIL_DEPTHS(N_SOIL_LEVELS) UDG3F405.226
!Array containing depth of ECMWF soil layers UDG3F405.227
GRIB_UM1.65
LOGICAL LPSTAR !=T if P STAR in GRIB file UDG3F405.228
!=F if log P STAR in GRIB file UDG3F405.229
LOGICAL LSKINTEMP !=T if GRIB code 235 in GRIB file UDG3F405.230
LOGICAL HYBRID UDG3F405.231
AD110293.181
*CALL CSUBMODL UDG2F305.422
*CALL CPPXREF UDG2F305.424
*CALL PPXLOOK UDG2F305.425
UDG2F305.426
INTEGER EXPPXI ! Function to extract integer UDG2F305.427
! from ppxref file UDG2F305.428
CHARACTER*36 EXPPXC ! Function to extract character string UDG2F305.429
! from ppxref file UDG2F305.430
UDG2F305.431
C---------------------------------------------------------------------- GRIB_UM1.66
C Workspace usage:----------------------------------------------------- GRIB_UM1.67
C GRIB_UM1.68
GRIB_UM1.69
INTEGER GRIB_UM1.70
* LEN_INTHD !Length of integer header GRIB_UM1.71
*,LEN1_LOOKUP !1st dim of LOOKUP array GRIB_UM1.72
*,LEN_REALHD !Length of real header GRIB_UM1.73
*,LEN2_LEVDEPC !2nd dimension of LEVDEPC GRIB_UM1.74
*,LEN2_ROWDEPC !2nd dimension of ROWDEPC GRIB_UM1.75
*,LEN_FIXHD !Length of fixed length header GRIB_UM1.76
*,N_E_FIELDS !No of extra fields written to UM dump GRIB_UM1.77
*,LEN_DUMPH !Length of temp history blockz GRIB_UM1.78
GRIB_UM1.79
GRIB_UM1.80
PARAMETER( GRIB_UM1.81
* LEN_INTHD=29 GRIB_UM1.82
*,LEN1_LOOKUP=64 GRIB_UM1.83
*,LEN_REALHD=30 GRIB_UM1.84
*,LEN2_LEVDEPC=20 AD200593.5
*,LEN2_ROWDEPC=3 GRIB_UM1.86
*,LEN_FIXHD=256 GRIB_UM1.87
*,N_E_FIELDS=4 GRIB_UM1.88
*,LEN_DUMPH=2048) GRIB_UM1.89
GRIB_UM1.90
INTEGER GRIB_UM1.91
& FIXHD(LEN_FIXHD), GRIB_UM1.92
& INTHD(LEN_INTHD), GRIB_UM1.93
& LOOKUP(64,1000) GRIB_UM1.94
GRIB_UM1.95
REAL GRIB_UM1.96
& REALHD(LEN_REALHD), GRIB_UM1.97
& LEVDEPC(1+P_LEVELS*LEN2_LEVDEPC), GRIB_UM1.98
& ROWDEPC(1+ROW_LENGTH*LEN2_ROWDEPC), GRIB_UM1.99
& RLOOKUP(64,1000) GRIB_UM1.100
GRIB_UM1.101
EQUIVALENCE (RLOOKUP,LOOKUP) GRIB_UM1.102
GRIB_UM1.103
GRIB_UM1.111
REAL GRIB_UM1.112
* T(ROW_LENGTH*P_ROWS) !Temperature GRIB_UM1.113
*,Q(ROW_LENGTH*P_ROWS) !Specific humidity GRIB_UM1.114
*,RH(ROW_LENGTH*P_ROWS) !Relative humidity GRIB_UM1.115
*,TH(ROW_LENGTH*P_ROWS) !Potential temperature GRIB_UM1.116
*,SAT(ROW_LENGTH*P_ROWS) !Sat specific humidity GRIB_UM1.117
*,PSTAR(ROW_LENGTH*P_ROWS) !Pstar AD110293.183
*,P(ROW_LENGTH*P_ROWS) !Pressure GRIB_UM1.118
GRIB_UM1.119
LOGICAL GRIB_UM1.120
* LAND_SEA(ROW_LENGTH*P_ROWS) !Land/sea mask GRIB_UM1.121
*,SEA_ICE(ROW_LENGTH*P_ROWS) !Sea ice mask GRIB_UM1.122
GRIB_UM1.123
INTEGER GRIB_UM1.124
* PP_LEN(LEN2_LOOKUP) !Length | GRIB_UM1.125
*,PP_NUM(LEN2_LOOKUP) !No of fields| For each GRIB_UM1.126
*,PP_POS(LEN2_LOOKUP) !Position | field type GRIB_UM1.127
*,PP_TYPE(LEN2_LOOKUP) !Real,int,log| on output file GRIB_UM1.128
*,PP_ITEMC(LEN2_LOOKUP) !Item code | GRIB_UM1.129
&,PP_LS(LEN2_LOOKUP) !Land or sea GRIB_UM1.130
GRIB_UM1.131
C---------------------------------------------------------------------- GRIB_UM1.132
C External subroutines called:----------------------------------------- GRIB_UM1.133
EXTERNAL DECODE,SETPOS8,BUFFIN8,WRITHEAD,WRITFLDS,F_TYPE UDG3F400.153
EXTERNAL SETFHEAD,ABORT_IO,READFLDS GDG0F401.657
GRIB_UM1.137
C*--------------------------------------------------------------------- GRIB_UM1.138
C Define local variables:---------------------------------------------- GRIB_UM1.139
REAL GRIB_UM1.140
* A,PRESS,THREF,AL10000 GRIB_UM1.141
GRIB_UM1.145
INTEGER GRIB_UM1.146
* ICODE ! Return code; successful=0; error > 0 GRIB_UM1.147
*,DUMMY ! Dummy argument to WRITHEAD GRIB_UM1.148
*,I,N,K,J,L,M ! Integer indices GRIB_UM1.149
*,LEN_IO ! Actual length of data read by BUFIN GRIB_UM1.150
*,IPOS GRIB_UM1.151
*,START_BLOCK GRIB_UM1.152
*,LL GRIB_UM1.153
*,N_TYPES GRIB_UM1.154
*,POSQ,POST,POSO,POSP AD110293.184
*,P_FIELD ! No of points along a level GRIB_UM1.158
*,INDEX_POS(1000)! Index used to make multilevel fields contiguous GRIB_UM1.159
INTEGER DISK_ADDRESS !Current rounded disk address UDG7F404.3
INTEGER NUMBER_OF_DATA_WORDS_ON_DISK UDG7F404.4
INTEGER NUMBER_OF_DATA_WORDS_IN_MEMORY UDG7F404.5
GRIB_UM1.160
CHARACTER*256 GRIB_UM1.161
* CMESSAGE !OUT Error message if ICODE > 0 GRIB_UM1.162
GRIB_UM1.163
INTEGER LRECL_BYTES,LRECL_WORDS GRIB_UM1.164
PARAMETER (LRECL_BYTES=2048 GRIB_UM1.165
* ,LRECL_WORDS=LRECL_BYTES/8) GRIB_UM1.166
GRIB_UM1.167
CHARACTER*80 F_TYPE_TITLE UDG3F400.154
CHARACTER*1 CHAR2(LRECL_BYTES) UDG3F404.16
UDG3F404.17
*CALL TYPGRIB UDG3F404.18
CHARACTER*1 CHAR3(LEN_MAX) UDG3F404.19
INTEGER ICHAR3(LEN_MAX) ! INTEGER EQUIVALENT OF CHAR3 UDG3F404.20
EQUIVALENCE (CHAR3(1),ICHAR3(1)) UDG3F404.21
GRIB_UM1.171
C---------------------------------------------------------------------- GRIB_UM1.178
C Constants from comdecks:--------------------------------------------- GRIB_UM1.179
*CALL C_R_CP GRIB_UM1.180
*CALL C_G GRIB_UM1.181
*CALL C_MDI GRIB_UM1.182
*CALL CLOOKADD GRIB_UM1.183
*CALL C_0_DG_C GRIB_UM1.184
UDG3F404.22
*CALL CGRIB UDG3F400.156
C---------------------------------------------------------------------- GRIB_UM1.185
GRIB_UM1.186
DUMMY=1 GRIB_UM1.187
GRIB_UM1.188
C---------------------------------------------------------------------- GRIB_UM1.189
C Initialise fixed length header GRIB_UM1.190
C---------------------------------------------------------------------- GRIB_UM1.191
GRIB_UM1.192
CALL SETFHEAD(FIXHD GRIB_UM1.193
*,LEN_FIXHD GRIB_UM1.194
*,LEN_INTHD GRIB_UM1.195
*,LEN_REALHD GRIB_UM1.196
*,P_LEVELS,LEN2_LEVDEPC GRIB_UM1.197
*,P_ROWS,LEN2_ROWDEPC DR101293.5
*,0,0 GRIB_UM1.199
*,0,0 GRIB_UM1.200
*,0 GRIB_UM1.201
*,LEN_DUMPH GRIB_UM1.202
*,0,0,0 GRIB_UM1.203
&,LEN1_LOOKUP,LEN2_LOOKUP+N_E_FIELDS UDG3F405.232
&,(LEN2_LOOKUP+N_E_FIELDS)*ROW_LENGTH*P_ROWS UDG3F405.233
*,0 GRIB_UM1.206
*,YEAR,MONTH,DAY,HOUR,MINUTE GRIB_UM1.207
*,0 GRIB_UM1.208
*,YEAR,MONTH,DAY,HOUR,MINUTE GRIB_UM1.209
*,8,1,3,0,1,IMDI,IMDI,1,1,IMDI,IMDI GRIB_UM1.210
*,IPOS) GRIB_UM1.211
FIXHD(12)=405 UDG3F405.234
FIXHD(9)=2 AD200593.6
C-------------------------------------------------------------- GRIB_UM1.213
C Initialise integer constants record GRIB_UM1.214
C-------------------------------------------------------------- GRIB_UM1.215
GRIB_UM1.216
DO I=1,LEN_INTHD GRIB_UM1.217
INTHD(I)=IMDI GRIB_UM1.218
ENDDO GRIB_UM1.219
GRIB_UM1.220
INTHD(6)=ROW_LENGTH GRIB_UM1.221
INTHD(7)=P_ROWS GRIB_UM1.222
INTHD(8)=P_LEVELS GRIB_UM1.223
INTHD(9)=P_LEVELS GRIB_UM1.224
! IF(LMOSES)THEN UDG3F405.235
INTHD(10)=4 UDG3F405.236
! ELSE UDG3F405.237
! INTHD(10)=3 UDG3F405.238
! END IF UDG3F405.239
INTHD(13)=BL_LEVELS GRIB_UM1.226
INTHD(18)=1 GRIB_UM1.227
GRIB_UM1.228
C-------------------------------------------------------------- GRIB_UM1.229
C Initialise real constants GRIB_UM1.230
C-------------------------------------------------------------- GRIB_UM1.231
GRIB_UM1.232
DO I=1,LEN_REALHD GRIB_UM1.233
REALHD(I)=RMDI GRIB_UM1.234
ENDDO GRIB_UM1.235
REALHD(1)=360./ROW_LENGTH GRIB_UM1.236
REALHD(2)=180./(P_ROWS-1) GRIB_UM1.237
REALHD(3)=90.0 GRIB_UM1.238
REALHD(4)=0.0 GRIB_UM1.239
REALHD(5)=90.0 GRIB_UM1.240
REALHD(6)=00.0 GRIB_UM1.241
GRIB_UM1.242
C-------------------------------------------------------------- GRIB_UM1.243
C Initialise level dependent constants GRIB_UM1.244
C-------------------------------------------------------------- GRIB_UM1.245
GRIB_UM1.246
DO I=1,LEN2_LEVDEPC*P_LEVELS GRIB_UM1.247
LEVDEPC(I)=RMDI GRIB_UM1.248
ENDDO GRIB_UM1.249
GRIB_UM1.250
DO I=1,P_LEVELS GRIB_UM1.251
LEVDEPC(I)=AK(I) GRIB_UM1.252
LEVDEPC(I+P_LEVELS)=BK(I) AD110293.189
LEVDEPC(I+2*P_LEVELS)=0. GRIB_UM1.254
LEVDEPC(I+3*P_LEVELS)=0. GRIB_UM1.255
PRESS=AK(I)+100000.*BK(I) AD110293.190
IF(PRESS.GT.10000.)THEN GRIB_UM1.257
THREF=300. GRIB_UM1.258
ELSEIF(PRESS.LT.100.)THEN GRIB_UM1.259
THREF=400. GRIB_UM1.260
ELSE GRIB_UM1.261
AL10000=ALOG(10000.) GRIB_UM1.262
THREF=300.+100.*(AL10000-ALOG(PRESS))/(AL10000-ALOG(100.)) GRIB_UM1.263
ENDIF GRIB_UM1.264
LEVDEPC(I+4*P_LEVELS) GRIB_UM1.265
* =THREF/(PRESS*1.E-5)**KAPPA GRIB_UM1.266
ENDDO GRIB_UM1.274
GRIB_UM1.275
LEVDEPC(1 + 5*P_LEVELS) = 0.1 UDG3F405.240
LEVDEPC(2 + 5*P_LEVELS) = 0.25 UDG3F405.241
LEVDEPC(3 + 5*P_LEVELS) = 0.65 UDG3F405.242
LEVDEPC(4 + 5*P_LEVELS) = 2.0 UDG3F405.243
GRIB_UM1.280
C-------------------------------------------------------------- GRIB_UM1.281
C Initialise row dependent constants GRIB_UM1.282
C-------------------------------------------------------------- GRIB_UM1.283
C SET FILTER WAVE VALUES TO MAX VALUES GRIB_UM1.284
DO I=1,P_LEVELS GRIB_UM1.285
ROWDEPC(I)=ROW_LENGTH GRIB_UM1.286
ROWDEPC(I+P_LEVELS)=ROW_LENGTH GRIB_UM1.287
ENDDO GRIB_UM1.288
GRIB_UM1.289
C-------------------------------------------------------------- GRIB_UM1.290
C Initialise addresses and lengths in LOOKUP prior to I/O GRIB_UM1.291
C-------------------------------------------------------------- GRIB_UM1.292
GRIB_UM1.293
GRIB_UM1.294
DO N=1,LEN2_LOOKUP+N_E_FIELDS UDG3F405.244
GRIB_UM1.296
DO J=1,LEN1_LOOKUP GRIB_UM1.297
LOOKUP(J,N)=0 GRIB_UM1.298
ENDDO GRIB_UM1.299
GRIB_UM1.300
C DATA TIME YEAR,DAY,MONTH,HOUR,MINUTE GRIB_UM1.301
LOOKUP(LBYR,N)=YEAR GRIB_UM1.302
LOOKUP(LBMON,N)=MONTH GRIB_UM1.303
LOOKUP(LBDAT,N)=DAY GRIB_UM1.304
LOOKUP(LBHR,N)=HOUR GRIB_UM1.305
LOOKUP(LBMIN,N)=MINUTE GRIB_UM1.306
LOOKUP(LBYRD,N)=YEAR GRIB_UM1.307
LOOKUP(LBMOND,N)=MONTH GRIB_UM1.308
LOOKUP(LBDATD,N)=DAY GRIB_UM1.309
LOOKUP(LBHRD,N)=HOUR GRIB_UM1.310
LOOKUP(LBMIND,N)=MINUTE GRIB_UM1.311
GRIB_UM1.312
C NO OF POINTS ALONG A LATITUDE GRIB_UM1.313
LOOKUP(LBNPT,N)=ROW_LENGTH GRIB_UM1.314
C NO OF POINTS ALONG A MERIDIAN GRIB_UM1.315
LOOKUP(LBROW,N)=P_ROWS GRIB_UM1.316
C FIELD LENGTH GRIB_UM1.317
LOOKUP(LBLREC,N)=ROW_LENGTH*P_ROWS GRIB_UM1.318
C ADDRESS GRIB_UM1.319
LOOKUP(NADDR,N)=IPOS GRIB_UM1.320
IPOS=IPOS+LOOKUP(15,N) GRIB_UM1.321
C TYPE GRIB_UM1.322
LOOKUP(DATA_TYPE,N)=1 GRIB_UM1.323
C PACK GRIB_UM1.324
*IF DEF,CRAY GDR8F405.65
LOOKUP(LBPACK,N)=2 ! 32 bit packing GDR8F405.66
*ELSE GDR8F405.67
LOOKUP(LBPACK,N)=0 ! No packing GDR8F405.68
*ENDIF GDR8F405.69
LOOKUP(LBREL,N)=2 ! Header release number UDG3F400.157
! Internal model number GDG0F401.658
LOOKUP(45,N)=1 GDG0F401.659
C GRID RESOLUTION AND POSITION GRIB_UM1.326
RLOOKUP(BPLAT,N)=90. GRIB_UM1.327
RLOOKUP(BPLON,N)=0. GRIB_UM1.328
RLOOKUP(BDY,N)=-REALHD(2) GRIB_UM1.329
RLOOKUP(BZY,N)=REALHD(3)+REALHD(2) GRIB_UM1.330
RLOOKUP(BZX,N)=REALHD(4)-REALHD(1) GRIB_UM1.331
RLOOKUP(BDX,N)=REALHD(1) GRIB_UM1.332
LOOKUP(BMDI,N)=RMDI ! Missing data indicator UDG3F400.158
ENDDO GRIB_UM1.333
GRIB_UM1.334
C Index to make multilevel fields contiguous on disk GRIB_UM1.335
DO J=1,N_S_FIELDS GRIB_UM1.336
INDEX_POS(J)=J GRIB_UM1.337
ENDDO GRIB_UM1.338
UDG3F405.245
IF(ST_LEVELS.GT.0)THEN UDG3F405.246
DO J=1,ST_LEVELS UDG3F405.247
INDEX_POS(N_S_FIELDS+J)= UDG3F405.248
& N_S_FIELDS+J UDG3F405.249
END DO UDG3F405.250
END IF UDG3F405.251
IF(SM_LEVELS.GT.0)THEN UDG3F405.252
DO J=1,SM_LEVELS UDG3F405.253
INDEX_POS(ST_LEVELS+N_S_FIELDS+J)= UDG3F405.254
& ST_LEVELS+N_S_FIELDS+J UDG3F405.255
END DO UDG3F405.256
END IF UDG3F405.257
UDG3F405.258
IF(HYBRID)THEN AD110293.192
AD110293.193
DO I=1,N_M_FIELDS GRIB_UM1.340
DO J=1,P_LEVELS AD110293.194
INDEX_POS(P_LEVELS*(I-1)+ST_LEVELS+SM_LEVELS UDG3F405.259
& +N_S_FIELDS+P_LEVELS-J+1) UDG3F405.260
& =(J-1)*N_M_FIELDS+ST_LEVELS+SM_LEVELS+N_S_FIELDS+I UDG3F405.261
ENDDO AD110293.197
ENDDO GRIB_UM1.343
AD110293.198
ELSE AD110293.199
AD110293.200
DO I=1,N_M_FIELDS AD110293.201
DO J=1,P_LEVELS AD110293.202
INDEX_POS(P_LEVELS*(I-1)+ST_LEVELS+SM_LEVELS+J+N_S_FIELDS) UDG3F405.262
& =(J-1)*N_M_FIELDS+ST_LEVELS+SM_LEVELS+N_S_FIELDS+I UDG3F405.263
ENDDO AD110293.205
ENDDO AD110293.206
AD110293.207
ENDIF AD110293.208
C WRITE(6,*)INDEX_POS GRIB_UM1.345
WRITE(6,*)INDEX_POS UDG3F405.264
UDG7F404.6
LOOKUP(LBPACK,POS_LSM)=0 UDG3F405.265
UDG3F405.266
! Reset the disk addresses and lengths for well formed I/O UDG7F404.8
CALL SET_DUMPFILE_ADDRESS(FIXHD,LEN_FIXHD, UDG7F404.9
& LOOKUP,LEN1_LOOKUP, UDG7F404.10
& LEN2_LOOKUP+N_E_FIELDS, UDG7F404.11
& NUMBER_OF_DATA_WORDS_IN_MEMORY, UDG7F404.12
& NUMBER_OF_DATA_WORDS_ON_DISK, UDG7F404.13
& DISK_ADDRESS) UDG7F404.14
UDG7F404.15
C-------------------------------------------------------------- GRIB_UM1.347
C Read in data, decode, initialise LOOKUP(42) & write out data GRIB_UM1.348
C-------------------------------------------------------------- GRIB_UM1.349
GRIB_UM1.350
write(6,*) 'ECMWF soil levels' UDG3F405.267
do l=1,4 UDG3F405.268
write(6,*) l,ecmwf_soil_levels(l) UDG3F405.269
end do UDG3F405.270
DO N=1,LEN2_LOOKUP AD110293.209
GRIB_UM1.358
CALL SETPOS8(NFTIN,GRIB_RECORD_START_ADDRESS(INDEX_POS(N))) AD110293.210
CALL BUFFIN8(NFTIN,CHAR3,GRIB_RECORD_LENGTH(INDEX_POS(N)) AD110293.211
x ,LEN_IO,A) AD110293.212
GRIB_UM1.365
C Decode grib headers UDG3F400.159
LEN_FP=ROW_LENGTH*P_ROWS UDG3F400.160
JLEN=LEN_IO UDG3F400.161
CALL DECODE(FPDATA,FPWORK,LEN_FP,NUM_FP, UDG3F400.162
! VERT_COORDS,LEN_VERT,NUM_VERT, UDG3F400.163
! BITMAP,LEN_BITMAP,NUM_BITMAP, UDG3F400.164
! QUASI,LEN_Q,NUM_Q,WIDTH,WORD_SIZE, UDG3F400.165
! BLOCK0,BLOCK1,BLOCK2,BLOCK3,BLOCK4, UDG3F400.166
! BLOCKR,ICHAR3,JLEN,POSN,WORD,OFF,ERROR, UDG3F404.23
! WORK_INT1,WORK_INT2,WORK_RE1,IERR_UNIT,MSGLVL) UDG3F404.24
GRIB_UM1.375
C-------------------------------------------------------------- GRIB_UM1.376
C Initialise ITEM CODE in LOOKUP for each field GRIB_UM1.377
C-------------------------------------------------------------- GRIB_UM1.378
GRIB_UM1.379
GRIB_UM1.380
C ITEM CODE GRIB_UM1.381
LL=0 GRIB_UM1.382
DO L=1,N_CODES GRIB_UM1.383
IF(BLOCK1(5).EQ.GRIB_CODE(L))LL=L UDG3F400.169
ENDDO GRIB_UM1.385
IF(LL.EQ.0)THEN GRIB_UM1.386
WRITE(6,'(''*ERROR* GRIB CODE NOT RECOGNISED'',I6)')BLOCK1(5) UDG3F400.170
ENDIF GRIB_UM1.389
LOOKUP(ITEM_CODE,N)=ITEM_C(LL) GRIB_UM1.390
IF(.NOT.LSKINTEMP.AND.BLOCK1(5).EQ.139)THEN UDG3F405.271
LOOKUP(ITEM_CODE,N)=24 UDG3F405.272
LSKINTEMP=.TRUE. UDG3F405.273
END IF UDG3F405.274
GRIB_UM1.391
GRIB_UM1.392
C-------------------------------------------------------------- GRIB_UM1.393
C Write out each field GRIB_UM1.394
C-------------------------------------------------------------- GRIB_UM1.395
GRIB_UM1.396
IF(LOOKUP(ITEM_CODE,N).EQ.30)THEN GRIB_UM1.397
C Land-sea mask as logical GRIB_UM1.398
LOOKUP(DATA_TYPE,N)=3 GRIB_UM1.399
LOOKUP(LBPACK,N)=0 AD110293.215
DO L=1,LOOKUP(LBLREC,N) GRIB_UM1.400
LAND_SEA(L)=.TRUE. GRIB_UM1.401
IF(FPDATA(L).EQ.0.)LAND_SEA(L)=.FALSE. GRIB_UM1.402
ENDDO GRIB_UM1.403
CALL WRITFLDS(NFTOUT,1,N,LOOKUP,LEN1_LOOKUP, GDG0F401.660
& LAND_SEA,LOOKUP(LBLREC,N),FIXHD, GDG0F401.661
*CALL ARGPPX GDG0F401.662
& ICODE,CMESSAGE) GDG0F401.663
ELSEIF(LOOKUP(ITEM_CODE,N).EQ.1)THEN UDG3F405.297
!Surface pressure UDG3F405.298
IF(.NOT.LPSTAR)THEN UDG3F405.299
! Log(PSTAR). Convert to PSTAR UDG3F405.300
DO I=1, LOOKUP(LBLREC,N) UDG3F405.301
PSTAR(I)=EXP(FPDATA(I)) UDG3F405.302
END DO UDG3F405.303
CALL WRITFLDS(NFTOUT,1,N,LOOKUP,LEN1_LOOKUP, UDG3F405.304
& PSTAR,LOOKUP(LBLREC,N),FIXHD, UDG3F405.305
*CALL ARGPPX UDG3F405.306
& ICODE,CMESSAGE) UDG3F405.307
ELSE UDG3F405.308
CALL WRITFLDS(NFTOUT,1,N,LOOKUP,LEN1_LOOKUP, UDG3F405.309
& FPDATA,LOOKUP(LBLREC,N),FIXHD, UDG3F405.310
*CALL ARGPPX UDG3F405.311
& ICODE,CMESSAGE) UDG3F405.312
END IF UDG3F405.313
ELSE GRIB_UM1.406
C Other fields are type real GRIB_UM1.407
CALL WRITFLDS(NFTOUT,1,N,LOOKUP,LEN1_LOOKUP, GDG0F401.664
& FPDATA,LOOKUP(LBLREC,N),FIXHD, GDG0F401.665
*CALL ARGPPX GDG0F401.666
& ICODE,CMESSAGE) GDG0F401.667
ENDIF GRIB_UM1.410
IF(ICODE.NE.0)CALL ABORT_IO('GRIB_UM',CMESSAGE,ICODE,NFTOUT) GRIB_UM1.411
GRIB_UM1.412
ENDDO GRIB_UM1.413
GRIB_UM1.414
C--------------------------------------------------------------- GRIB_UM1.415
C Analyse characteristics of output dump GRIB_UM1.416
C--------------------------------------------------------------- GRIB_UM1.417
GRIB_UM1.418
F_TYPE_TITLE='Decoded GRIB fields' UDG3F400.171
CALL F_TYPE(LOOKUP,LEN2_LOOKUP,PP_NUM,N_TYPES, UDG3F400.172
& PP_LEN,PP_ITEMC,PP_TYPE,PP_POS,PP_LS,FIXHD, UDG3F400.173
*CALL ARGPPX UDG3F400.174
& F_TYPE_TITLE) UDG3F400.175
C--------------------------------------------------------------- GRIB_UM1.423
C Convert relative humidity to specific humidity and T to TH GRIB_UM1.424
C--------------------------------------------------------------- GRIB_UM1.425
GRIB_UM1.426
IF(LPSTAR)THEN UDG3F405.275
C Pstar UDG3F405.276
CALL LOCATE(1,PP_ITEMC,N_TYPES,POSP) UDG3F405.277
IF (POSP.EQ.0) THEN UDG3F405.278
write(6,*)' ERROR in SUBROUTINE GRIB_UM' UDG3F405.279
write(6,*)' P STAR is not in grib file' UDG3F405.280
CALL ABORT UDG3F405.281
ENDIF UDG3F405.282
ELSE UDG3F405.283
C Log pstar UDG3F405.284
CALL LOCATE(1,PP_ITEMC,N_TYPES,POSP) UDG3F405.285
IF (POSP.EQ.0) THEN UDG3F405.286
write(6,*)' ERROR in SUBROUTINE GRIB_UM' UDG3F405.287
write(6,*)' LOG P STAR is not in grib file' UDG3F405.288
CALL ABORT UDG3F405.289
ENDIF UDG3F405.290
ENDIF UDG3F405.291
DR101293.11
C R.H. (pressure levs) or Q (hybrid levs) AD110293.218
CALL LOCATE(10,PP_ITEMC,N_TYPES,POSQ) GRIB_UM1.428
IF (POSQ.EQ.0) THEN DR101293.12
write(6,*)' ERROR in SUBROUTINE GRIB_UM' DR101293.13
write(6,*)' RH or Q is not in grib file' DR101293.14
CALL ABORT DR101293.15
ENDIF DR101293.16
DR101293.17
C T GRIB_UM1.429
CALL LOCATE(4,PP_ITEMC,N_TYPES,POST) GRIB_UM1.430
IF (POST.EQ.0) THEN DR101293.18
write(6,*)' ERROR in SUBROUTINE GRIB_UM' DR101293.19
write(6,*)' Temperature is not in grib file' DR101293.20
CALL ABORT DR101293.21
ENDIF DR101293.22
DR101293.23
C PHI STAR GRIB_UM1.431
CALL LOCATE(33,PP_ITEMC,N_TYPES,POSO) GRIB_UM1.432
IF (POSO.EQ.0) THEN UDG3F405.292
write(6,*)' ERROR in SUBROUTINE GRIB_UM' UDG3F405.293
write(6,*)' PHISTAR is not in grib file' UDG3F405.294
CALL ABORT UDG3F405.295
ENDIF UDG3F405.296
GRIB_UM1.433
P_FIELD=ROW_LENGTH*P_ROWS GRIB_UM1.434
AD110293.219
C Read in Pstar AD110293.220
AD110293.221
CALL READFLDS(NFTOUT,1,PP_POS(POSP),LOOKUP,LEN1_LOOKUP, GDG0F401.668
& PSTAR,P_FIELD,FIXHD, GDG0F401.669
*CALL ARGPPX GDG0F401.670
& ICODE,CMESSAGE) GDG0F401.671
IF(ICODE.NE.0)CALL ABORT_IO('GRIB_UM',CMESSAGE,ICODE,NFTOUT) AD110293.224
GRIB_UM1.435
DO K=1,P_LEVELS GRIB_UM1.436
GRIB_UM1.437
C Read in T and convert to TH GRIB_UM1.438
GRIB_UM1.439
CALL READFLDS(NFTOUT,1,PP_POS(POST)+K-1,LOOKUP,LEN1_LOOKUP, UDG8F404.3
& T,P_FIELD,FIXHD, GDG0F401.673
*CALL ARGPPX GDG0F401.674
& ICODE,CMESSAGE) GDG0F401.675
IF(ICODE.NE.0)CALL ABORT_IO('GRIB_UM',CMESSAGE,ICODE,NFTOUT) GRIB_UM1.442
GRIB_UM1.443
DO I=1,P_FIELD GRIB_UM1.444
P(I)=LEVDEPC(K)+PSTAR(I)*LEVDEPC(K+P_LEVELS) AD110293.225
TH(I)=T(I)*(PREF/P(I))**KAPPA GSS9F402.78
ENDDO GRIB_UM1.450
GRIB_UM1.451
C Write out TH GRIB_UM1.452
GRIB_UM1.453
CALL WRITFLDS(NFTOUT,1,PP_POS(POST)+K-1,LOOKUP,LEN1_LOOKUP, GDG0F401.676
& TH,P_FIELD,FIXHD, GDG0F401.677
*CALL ARGPPX GDG0F401.678
& ICODE,CMESSAGE) GDG0F401.679
IF(ICODE.NE.0)CALL ABORT_IO('GRIB_UM',CMESSAGE,ICODE,NFTOUT) GRIB_UM1.456
GRIB_UM1.457
GRIB_UM1.458
IF(.NOT.HYBRID)THEN AD110293.228
C Read in R.H. and convert to Q GRIB_UM1.459
GRIB_UM1.460
CALL READFLDS(NFTOUT,1,PP_POS(POSQ)+K-1,LOOKUP,LEN1_LOOKUP, GDG0F401.680
& RH,P_FIELD,FIXHD, GDG0F401.681
*CALL ARGPPX GDG0F401.682
& ICODE,CMESSAGE) GDG0F401.683
IF(ICODE.NE.0)CALL ABORT_IO('GRIB_UM',CMESSAGE,ICODE,NFTOUT) GRIB_UM1.463
GRIB_UM1.464
CALL QSAT(SAT,T,P,P_FIELD) GRIB_UM1.468
DO I=1,P_FIELD GRIB_UM1.469
Q(I)=RH(I)*.01*SAT(I) GRIB_UM1.470
ENDDO GRIB_UM1.471
GRIB_UM1.472
C Write out Q GRIB_UM1.473
GRIB_UM1.474
CALL WRITFLDS(NFTOUT,1,PP_POS(POSQ)+K-1,LOOKUP,LEN1_LOOKUP, GDG0F401.684
& Q,P_FIELD,FIXHD, GDG0F401.685
*CALL ARGPPX GDG0F401.686
& ICODE,CMESSAGE) GDG0F401.687
IF(ICODE.NE.0)CALL ABORT_IO('GRIB_UM',CMESSAGE,ICODE,NFTOUT) GRIB_UM1.477
GRIB_UM1.478
ENDIF AD110293.229
AD110293.230
ENDDO GRIB_UM1.479
GRIB_UM1.480
C Read in surface geopotential and convert to orographic height GRIB_UM1.481
IF(POSO.NE.0)THEN GRIB_UM1.482
GRIB_UM1.483
CALL READFLDS(NFTOUT,1,PP_POS(POSO),LOOKUP,LEN1_LOOKUP, GDG0F401.688
& T,P_FIELD,FIXHD, GDG0F401.689
*CALL ARGPPX GDG0F401.690
& ICODE,CMESSAGE) GDG0F401.691
IF(ICODE.NE.0)CALL ABORT_IO('GRIB_UM',CMESSAGE,ICODE,NFTOUT) GRIB_UM1.486
GRIB_UM1.487
DO I=1,P_FIELD GRIB_UM1.488
T(I)=T(I)/G GRIB_UM1.489
ENDDO GRIB_UM1.490
GRIB_UM1.491
C Write out orography GRIB_UM1.492
GRIB_UM1.493
CALL WRITFLDS(NFTOUT,1,PP_POS(POSO),LOOKUP,LEN1_LOOKUP, GDG0F401.692
& T,P_FIELD,FIXHD, GDG0F401.693
*CALL ARGPPX GDG0F401.694
& ICODE,CMESSAGE) GDG0F401.695
IF(ICODE.NE.0)CALL ABORT_IO('GRIB_UM',CMESSAGE,ICODE,NFTOUT) GRIB_UM1.496
GRIB_UM1.497
ENDIF GRIB_UM1.522
GRIB_UM1.523
C-------------------------------------------------------------- UDG3F405.314
C Interpolate soil fields onto model levels UDG3F405.315
C-------------------------------------------------------------- UDG3F405.316
IF(ST_LEVELS.NE.0)THEN UDG3F405.317
! Interpolate Soil Temperature Fields UDG3F405.318
CALL SOIL_INTERP(NFTOUT,20,N_TYPES,P_FIELD,FIXHD, UDG3F405.319
& LEN1_LOOKUP,LEN2_LOOKUP,LOOKUP, UDG3F405.320
& ECMWF_SOIL_LEVELS,ECMWF_SOIL_DEPTHS, UDG3F405.321
& LEVDEPC(1+5*P_LEVELS), UDG3F405.322
& N_SOIL_LEVELS,PP_ITEMC,PP_POS, UDG3F405.323
*CALL ARGPPX UDG3F405.324
& ICODE,CMESSAGE) UDG3F405.325
END IF UDG3F405.326
IF(SM_LEVELS.NE.0)THEN UDG3F405.327
! Interpolate Soil Moisture Fields UDG3F405.328
CALL SOIL_INTERP(NFTOUT,9,N_TYPES,P_FIELD,FIXHD, UDG3F405.329
& LEN1_LOOKUP,LEN2_LOOKUP,LOOKUP, UDG3F405.330
& ECMWF_SOIL_LEVELS,ECMWF_SOIL_DEPTHS, UDG3F405.331
& LEVDEPC(1+5*P_LEVELS), UDG3F405.332
& N_SOIL_LEVELS,PP_ITEMC,PP_POS, UDG3F405.333
*CALL ARGPPX UDG3F405.334
& ICODE,CMESSAGE) UDG3F405.335
END IF UDG3F405.336
UDG3F405.337
C-------------------------------------------------------------- GRIB_UM1.524
C Process extra fields GRIB_UM1.525
C-------------------------------------------------------------- GRIB_UM1.526
GRIB_UM1.527
C Read in Tstar and determine sea ice points GRIB_UM1.528
CALL LOCATE(24,PP_ITEMC,N_TYPES,POST) GRIB_UM1.529
IF (POST.EQ.0) THEN DR101293.24
write(6,*)' ERROR in SUBROUTINE GRIB_UM' DR101293.25
write(6,*)' T STAR is not in grib file' DR101293.26
CALL ABORT DR101293.27
ENDIF DR101293.28
DR101293.29
CALL READFLDS(NFTOUT,1,PP_POS(POST),LOOKUP,LEN1_LOOKUP, GDG0F401.700
& T,P_FIELD,FIXHD, GDG0F401.701
*CALL ARGPPX GDG0F401.702
& ICODE,CMESSAGE) GDG0F401.703
IF(ICODE.NE.0)CALL ABORT_IO('GRIB_UM',CMESSAGE,ICODE,NFTOUT) GRIB_UM1.532
DO I=1,P_FIELD GRIB_UM1.533
SEA_ICE(I)=.FALSE. GRIB_UM1.534
IF(T(I).LE.TFS.AND..NOT.LAND_SEA(I))SEA_ICE(I)=.TRUE. GRIB_UM1.535
ENDDO GRIB_UM1.536
GRIB_UM1.537
C Sea ice fraction GRIB_UM1.538
LOOKUP(ITEM_CODE,LEN2_LOOKUP+1)=31 GRIB_UM1.539
GRIB_UM1.540
DO I=1,P_FIELD GRIB_UM1.541
T(I)=0. GRIB_UM1.542
IF(SEA_ICE(I))T(I)=1. GRIB_UM1.543
ENDDO GRIB_UM1.544
GRIB_UM1.545
CALL WRITFLDS(NFTOUT,1,LEN2_LOOKUP+1,LOOKUP,LEN1_LOOKUP, GDG0F401.704
& T,P_FIELD,FIXHD, GDG0F401.705
*CALL ARGPPX GDG0F401.706
& ICODE,CMESSAGE) GDG0F401.707
IF(ICODE.NE.0)CALL ABORT_IO('GRIB_UM',CMESSAGE,ICODE,NFTOUT) GRIB_UM1.548
GRIB_UM1.549
C B.L. Depth GRIB_UM1.550
LOOKUP(ITEM_CODE,LEN2_LOOKUP+2)=25 GRIB_UM1.551
GRIB_UM1.552
DO I=1,P_FIELD GRIB_UM1.553
T(I)=1000. GRIB_UM1.554
ENDDO GRIB_UM1.555
GRIB_UM1.556
CALL WRITFLDS(NFTOUT,1,LEN2_LOOKUP+2,LOOKUP,LEN1_LOOKUP, GDG0F401.708
& T,P_FIELD,FIXHD, GDG0F401.709
*CALL ARGPPX GDG0F401.710
& ICODE,CMESSAGE) GDG0F401.711
IF(ICODE.NE.0)CALL ABORT_IO('GRIB_UM',CMESSAGE,ICODE,NFTOUT) GRIB_UM1.559
GRIB_UM1.560
C Convective cloud condensed water path GRIB_UM1.561
LOOKUP(ITEM_CODE,LEN2_LOOKUP+3)=16 GRIB_UM1.562
GRIB_UM1.563
DO I=1,P_FIELD GRIB_UM1.564
T(I)=1. GRIB_UM1.565
ENDDO GRIB_UM1.566
GRIB_UM1.567
CALL WRITFLDS(NFTOUT,1,LEN2_LOOKUP+3,LOOKUP,LEN1_LOOKUP, GDG0F401.712
& T,P_FIELD,FIXHD, GDG0F401.713
*CALL ARGPPX GDG0F401.714
& ICODE,CMESSAGE) GDG0F401.715
IF(ICODE.NE.0)CALL ABORT_IO('GRIB_UM',CMESSAGE,ICODE,NFTOUT) GRIB_UM1.570
GRIB_UM1.571
C Ice Depth GRIB_UM1.572
LOOKUP(ITEM_CODE,LEN2_LOOKUP+4)=32 GRIB_UM1.573
GRIB_UM1.574
DO I=1,P_FIELD/2 GRIB_UM1.575
T(I)=0. GRIB_UM1.576
IF(SEA_ICE(I))T(I)=2. GRIB_UM1.577
ENDDO GRIB_UM1.578
DO I=P_FIELD/2+1,P_FIELD GRIB_UM1.579
T(I)=0. GRIB_UM1.580
IF(SEA_ICE(I))T(I)=1. GRIB_UM1.581
ENDDO GRIB_UM1.582
GRIB_UM1.583
CALL WRITFLDS(NFTOUT,1,LEN2_LOOKUP+4,LOOKUP,LEN1_LOOKUP, GDG0F401.716
& T,P_FIELD,FIXHD, GDG0F401.717
*CALL ARGPPX GDG0F401.718
& ICODE,CMESSAGE) GDG0F401.719
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTOUT) GRIB_UM1.586
GRIB_UM1.587
GRIB_UM1.588
C-------------------------------------------------------------- GRIB_UM1.589
C Write out header GRIB_UM1.590
C-------------------------------------------------------------- GRIB_UM1.591
CALL SETPOS(NFTOUT,0,ICODE) GTD0F400.83
GRIB_UM1.593
CALL WRITHEAD(NFTOUT,FIXHD,LEN_FIXHD, GDG0F401.720
& INTHD,LEN_INTHD, GDG0F401.721
& REALHD,LEN_REALHD, GDG0F401.722
& LEVDEPC,P_LEVELS,LEN2_LEVDEPC, GDG0F401.723
& ROWDEPC,ROW_LENGTH,LEN2_ROWDEPC, GDG0F401.724
& DUMMY,DUMMY,DUMMY, GDG0F401.725
& DUMMY,DUMMY,DUMMY, GDG0F401.726
& DUMMY,DUMMY, GDG0F401.727
& T,LEN_DUMPH, GDG0F401.728
& DUMMY,DUMMY, GDG0F401.729
& DUMMY,DUMMY, GDG0F401.730
& DUMMY,DUMMY, GDG0F401.731
& LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP+N_E_FIELDS, UDG3F405.338
& (LEN2_LOOKUP+N_E_FIELDS)*ROW_LENGTH*P_ROWS, UDG3F405.339
*CALL ARGPPX GDG0F401.734
& START_BLOCK,ICODE,CMESSAGE) GDG0F401.735
GRIB_UM1.609
IF(ICODE.NE.0)CALL ABORT_IO('GRIB_UM',CMESSAGE,ICODE,NFTOUT) GRIB_UM1.610
GRIB_UM1.611
CALL SETPOS(NFTOUT,0,ICODE) GTD0F400.84
GRIB_UM1.613
RETURN GRIB_UM1.614
END GRIB_UM1.615
GRIB_UM1.616
*ENDIF GRIB_UM1.617