*IF DEF,C84_1A STLEV1A.2
C ******************************COPYRIGHT****************************** GTS2F400.9631
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.9632
C GTS2F400.9633
C Use, duplication or disclosure of this code is subject to the GTS2F400.9634
C restrictions as set forth in the contract. GTS2F400.9635
C GTS2F400.9636
C Meteorological Office GTS2F400.9637
C London Road GTS2F400.9638
C BRACKNELL GTS2F400.9639
C Berkshire UK GTS2F400.9640
C RG12 2SZ GTS2F400.9641
C GTS2F400.9642
C If no contract has been raised with this copy of the code, the use, GTS2F400.9643
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.9644
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.9645
C Modelling at the above address. GTS2F400.9646
C ******************************COPYRIGHT****************************** GTS2F400.9647
C GTS2F400.9648
CLL Subroutine STLEVELS ----------------------------------------------- STLEV1A.3
CLL STLEV1A.4
CLL Purpose: Generate a level index from STASHrecord and level_lists STLEV1A.5
CLL and number of levels tailored to a particular diagnostic. STLEV1A.6
CLL Also set levels and pseudo-levels information for encoding STLEV1A.7
CLL PPheader details. (This subroutine based on a merger STLEV1A.8
CLL between GEN_INDEX and PP_COMPUTE_LEVEL). STLEV1A.9
CLL New subroutine STLEVELS is based on GEN_INDEX and STLEV1A.10
CLL PP_COMPUTE_LEVEL with merged functionality. STLEV1A.11
CLL A general note as levels list is an integer STLEV1A.12
CLL real values are multiplied by a 1000.0. STLEV1A.13
CLL When computing the real value of the level for the STLEV1A.14
CLL pp header it is necessary to divide by a 1000.0. STLEV1A.15
CLL Levels that are affected by this are theta, pressure and STLEV1A.16
CLL height. S. Anderson. STLEV1A.17
CLL STLEV1A.18
CLL Author: T.Johns TJ140193.97
CLL STLEV1A.20
CLL Tested under compiler: cft77 STLEV1A.21
CLL Tested under OS version: UNICOS 5.1 STLEV1A.22
CLL STLEV1A.23
CLL Model Modification history from model version 3.0: STLEV1A.24
CLL version Date STLEV1A.25
CLL 3.1 14/01/93 Set pseudo_level to 0 not IMDI if no pseudo-level. TJ140193.98
CLL 29/01/93 Correct FORMAT statements. TJ140193.99
CLL 3.1 14/01/93 Include PV levels as levels divided by 1000. MM180193.156
CLL 3.2 19/04/93 Correct roundoff error for LEVEL type conversion. TJ010793.19
CLL 1.0E-10 is added after REAL divide by 1000 (TCJ). TJ010793.20
CLL 4.0 14/12/95 Correct long-standing error in input levels range GRB1F400.94
CLL to output levels list conversion. RTHBarnes. GRB1F400.95
! 4.4 02/12/96 Time mean timeseries added R A Stratton. GRS1F404.249
CLL STLEV1A.26
CLL Programming standard: UM Doc Paper 3, version 2 (7/9/90) STLEV1A.27
CLL STLEV1A.28
CLL Logical components covered : C4? STLEV1A.29
CLL STLEV1A.30
CLL Project task: C4 STLEV1A.31
CLL STLEV1A.32
CLL External documentation : UMDP no C4 STLEV1A.33
CLL STLEV1A.34
C*L Interface and arguments: ------------------------------------------ STLEV1A.35
C STLEV1A.36
SUBROUTINE STLEVELS(stash_control,stash_control_size, 2STLEV1A.37
+ stash_levels,num_stash_levels,num_level_lists, STLEV1A.38
+ stash_pseudo_levels,num_stash_pseudo,num_pseudo_lists, STLEV1A.39
+ max_stash_levs,num_levs_in,num_levs_out,index_size, STLEV1A.40
+ index_lev,level_list, STLEV1A.41
+ lbvcl,ak,bk,level,pseudo_level,ak_lev,bk_lev, STLEV1A.42
+ icode,cmessage) STLEV1A.43
C STLEV1A.44
IMPLICIT NONE STLEV1A.45
C STLEV1A.46
INTEGER STLEV1A.47
& stash_control_size, ! IN size of stash control record STLEV1A.48
& stash_control(stash_control_size),! IN stash control STLEV1A.49
& num_stash_levels, ! IN max. no of hts for a levels list STLEV1A.50
& num_level_lists, ! IN max. no of level lists STLEV1A.51
& stash_levels(num_stash_levels+1,num_level_lists), ! IN STLEV1A.52
C ! lookup table for level lists STLEV1A.53
& num_stash_pseudo,num_pseudo_lists,! IN dims of pseudo_levs STLEV1A.54
& stash_pseudo_levels(num_stash_pseudo+1,num_pseudo_lists), STLEV1A.55
C ! IN lookup table for pseudo-lev lists STLEV1A.56
& max_stash_levs, ! IN max. no of output levels STLEV1A.57
& num_levs_in, ! OUT no of levels in input data STLEV1A.58
& num_levs_out, ! OUT no of levels in output data STLEV1A.59
& index_size, ! OUT no of levels in levels index STLEV1A.60
& index_lev(max_stash_levs), ! OUT index of output level STLEV1A.61
C relative to input level STLEV1A.62
& level_list(max_stash_levs), ! OUT value of model level STLEV1A.63
& pseudo_level(max_stash_levs), ! OUT Value of pseudo levels STLEV1A.64
& lbvcl, ! IN vertical coordinate PP code STLEV1A.65
& icode ! OUT error code STLEV1A.66
REAL STLEV1A.67
& ak(*), ! IN Hybrid Ak value on model levs STLEV1A.68
& bk(*), ! IN Hybrid Bk value on model levs STLEV1A.69
& level(max_stash_levs), ! OUT Value of output levels (real) STLEV1A.70
& ak_lev(max_stash_levs),! OUT Hybrid Ak value on output levs STLEV1A.71
& bk_lev(max_stash_levs) ! OUT Hybrid Bk value on output levs STLEV1A.72
CHARACTER*(*) STLEV1A.73
& cmessage ! OUT error message STLEV1A.74
C*---------------------------------------------------------------------- STLEV1A.75
C Parameters STLEV1A.76
C STLEV1A.77
*CALL STERR 
STLEV1A.78
*CALL STPARAM STLEV1A.79
C STLEV1A.81
C Local variables STLEV1A.82
C STLEV1A.83
INTEGER STLEV1A.84
& index_pseudo_lev(max_stash_levs), ! Pseudo-level 1D index STLEV1A.85
& num_pseudo_in,num_pseudo_out, ! Number of pseudo levs STLEV1A.86
& k2,ml,kl, ! loop counts STLEV1A.87
& NI,NO, ! Number In/Out STLEV1A.88
& indx1, ! index count STLEV1A.89
& ilev, ! Integer level/pseudo-level STLEV1A.90
& what_mean,what_proc ! Meaning and processing code STLEV1A.91
C STLEV1A.92
C First compute the index for physical levels STLEV1A.93
C STLEV1A.94
IF(STASH_CONTROL(st_input_bottom).LT.0) THEN ! Input LEVELS list STLEV1A.95
NI=-STASH_CONTROL(st_input_bottom) STLEV1A.96
NUM_LEVS_IN=STASH_LEVELS(1,NI) STLEV1A.97
IF(STASH_CONTROL(st_output_bottom).LT.0) THEN ! LEVELS LIST out STLEV1A.98
NO=-STASH_CONTROL(st_output_bottom) STLEV1A.99
NUM_LEVS_OUT=STASH_LEVELS(1,NO) STLEV1A.100
INDX1=0 STLEV1A.101
DO ML=1,NUM_LEVS_OUT STLEV1A.102
ilev=STASH_LEVELS(ML+1,NO) ! Level required STLEV1A.103
DO KL=1,NUM_LEVS_IN STLEV1A.104
IF(STASH_LEVELS(KL+1,NI).EQ.ilev) THEN STLEV1A.105
INDX1=INDX1+1 STLEV1A.106
INDEX_LEV(INDX1)=KL ! Relative position of Input to Ou STLEV1A.107
level_list(indx1)=ilev STLEV1A.108
GOTO 400 STLEV1A.109
ENDIF STLEV1A.110
ENDDO STLEV1A.111
ICODE=nonsense STLEV1A.112
WRITE(CMESSAGE,101) 'Output level ',ilev, STLEV1A.113
& ' not found in input levels list' STLEV1A.114
GOTO 999 STLEV1A.115
400 CONTINUE STLEV1A.116
ENDDO STLEV1A.117
ELSE ! Output as a Level range STLEV1A.118
NUM_LEVS_OUT=STASH_CONTROL(st_output_top)- STLEV1A.119
& STASH_CONTROL(st_output_bottom)+1 STLEV1A.120
ilev=STASH_CONTROL(st_output_bottom) !1st output model level STLEV1A.121
DO KL=1,NUM_LEVS_IN STLEV1A.122
IF(STASH_LEVELS(KL+1,NI).EQ.ilev) THEN STLEV1A.123
INDEX_LEV(1)=KL ! Relative posn of Input to the 1st level STLEV1A.124
level_list(1)=ilev STLEV1A.125
GOTO 401 STLEV1A.126
ENDIF STLEV1A.127
ENDDO STLEV1A.128
ICODE=nonsense STLEV1A.129
WRITE(CMESSAGE,101) 'Output bottom model level ',ilev, STLEV1A.130
& ' not found in input levels list' STLEV1A.131
GOTO 999 STLEV1A.132
401 CONTINUE STLEV1A.133
DO KL=2,NUM_LEVS_OUT STLEV1A.134
INDEX_LEV(KL)=INDEX_LEV(KL-1)+1 STLEV1A.135
level_list(kl)=level_list(kl-1)+1 STLEV1A.136
ENDDO STLEV1A.137
ENDIF STLEV1A.138
ELSEIF(STASH_CONTROL(st_input_bottom).EQ.100) THEN !Special level STLEV1A.139
NUM_LEVS_IN=1 STLEV1A.140
NUM_LEVS_OUT=1 STLEV1A.141
INDEX_LEV(1)=1 STLEV1A.142
level_list(1)=1 ! could be worth setting to some nonsense no. STLEV1A.143
ELSE ! Input is Model level range STLEV1A.144
NUM_LEVS_IN=STASH_CONTROL(st_input_top)- STLEV1A.145
& STASH_CONTROL(st_input_bottom)+1 STLEV1A.146
IF(STASH_CONTROL(st_output_bottom).LT.0) THEN ! LEVELS LIST out STLEV1A.147
NO=-STASH_CONTROL(st_output_bottom) STLEV1A.148
NUM_LEVS_OUT=STASH_LEVELS(1,NO) STLEV1A.149
INDX1=0 STLEV1A.150
DO ML=1,NUM_LEVS_OUT STLEV1A.151
ilev=STASH_LEVELS(ML+1,NO) ! Output level reqd STLEV1A.152
DO KL=1,NUM_LEVS_IN STLEV1A.153
IF((STASH_CONTROL(st_input_bottom)+KL-1).EQ.ilev) THEN STLEV1A.154
INDX1=INDX1+1 STLEV1A.155
INDEX_LEV(INDX1)=KL ! Relative posn of output to inpt STLEV1A.156
level_list(INDX1)=ilev GRB1F400.96
GOTO 402 STLEV1A.158
ENDIF STLEV1A.159
ENDDO STLEV1A.160
ICODE=nonsense STLEV1A.161
WRITE(CMESSAGE,101) 'Output model level ',ilev, STLEV1A.162
& ' not in input model level range' STLEV1A.163
GOTO 999 STLEV1A.164
402 CONTINUE STLEV1A.165
ENDDO STLEV1A.166
ELSE ! Output as model level range STLEV1A.167
C Do some consistency checks here to ensure valid processing request STLEV1A.168
C output bottom should be greater or equal to input bottom STLEV1A.169
IF (stash_control(st_output_bottom).lt. STLEV1A.170
+ stash_control(st_input_bottom)) THEN STLEV1A.171
icode=nonsense STLEV1A.172
write(cmessage,103)'bad level spec, bot input>output', STLEV1A.173
+ stash_control(st_input_bottom), STLEV1A.174
+ stash_control(st_output_bottom) STLEV1A.175
goto 999 ! jump to error STLEV1A.176
ELSEIF (stash_control(st_output_top).gt. STLEV1A.177
+ stash_control(st_input_top)) THEN STLEV1A.178
icode=nonsense STLEV1A.179
write(cmessage,103)'bad level spec, top input<output', STLEV1A.180
+ stash_control(st_input_top), STLEV1A.181
+ stash_control(st_output_top) STLEV1A.182
goto 999 ! jump to error STLEV1A.183
ENDIF STLEV1A.184
NUM_LEVS_OUT=STASH_CONTROL(st_output_top)- STLEV1A.185
& STASH_CONTROL(st_output_bottom)+1 STLEV1A.186
INDEX_LEV(1)=STASH_CONTROL(st_output_bottom)- STLEV1A.187
& STASH_CONTROL(st_input_bottom)+1 STLEV1A.188
level_list(1)=stash_control(st_output_bottom) STLEV1A.189
DO kl=2,NUM_LEVS_OUT STLEV1A.190
INDEX_LEV(kl)=INDEX_LEV(kl-1)+1 STLEV1A.191
level_list(kl)=level_list(kl-1)+1 STLEV1A.192
ENDDO STLEV1A.193
ENDIF STLEV1A.194
ENDIF STLEV1A.195
index_size=num_levs_out STLEV1A.196
IF (num_levs_out.gt.num_levs_in) THEN ! things very badly wrong STLEV1A.197
icode=nonsense STLEV1A.198
write(cmessage,103)'asking for num_levs_out>num_levs_in', STLEV1A.199
+ num_levs_out,num_levs_in STLEV1A.200
goto 999 ! jump to return STLEV1A.201
ENDIF STLEV1A.202
C STLEV1A.203
C Next, compute actual (physical) levels for encoding PPheaders STLEV1A.204
C STLEV1A.205
IF (STASH_CONTROL(st_output_bottom).LT.0) THEN ! Levels List ? STLEV1A.206
NO=-STASH_CONTROL(st_output_bottom) ! Index of Levels list STLEV1A.207
C Pressure or Height or Theta levels or PV levels? MM180193.157
IF(LBVCL.EQ.8.OR.LBVCL.EQ.1.OR.LBVCL.EQ.19 MM180193.158
& .OR.LBVCL.EQ.82) THEN MM180193.159
STLEV1A.210
DO ML=1,NUM_LEVS_OUT STLEV1A.211
LEVEL(ML)=REAL(STASH_LEVELS(ML+1,NO))*0.001+1.0E-10 TJ010793.21
ENDDO STLEV1A.213
ELSE STLEV1A.214
DO ML=1,NUM_LEVS_OUT STLEV1A.215
LEVEL(ML)=REAL(STASH_LEVELS(ML+1,NO)) STLEV1A.216
ENDDO STLEV1A.217
ENDIF STLEV1A.218
ELSEIF (STASH_CONTROL(st_output_bottom).EQ.st_special_code) THEN STLEV1A.219
C Special level STLEV1A.220
DO ML=1,NUM_LEVS_OUT STLEV1A.221
LEVEL(ML)=-1.0 STLEV1A.222
ENDDO STLEV1A.223
ELSE STLEV1A.224
DO ML=1,NUM_LEVS_OUT STLEV1A.225
LEVEL(ML)=REAL(STASH_CONTROL(st_output_bottom)+ML-1) STLEV1A.226
ENDDO STLEV1A.227
ENDIF STLEV1A.228
C STLEV1A.229
IF (lbvcl.eq.9) THEN STLEV1A.230
DO ML=1,NUM_LEVS_OUT STLEV1A.231
ilev=INT(LEVEL(ML)) STLEV1A.232
ak_lev(ML)=ak(ilev) STLEV1A.233
bk_lev(ML)=bk(ilev) STLEV1A.234
ENDDO STLEV1A.235
ELSE STLEV1A.236
DO ML=1,NUM_LEVS_OUT STLEV1A.237
ak_lev(ML)=0.0 STLEV1A.238
bk_lev(ML)=0.0 STLEV1A.239
ENDDO STLEV1A.240
ENDIF STLEV1A.241
C STLEV1A.242
C Now reset the number of output levels to 1 if vertical compression is STLEV1A.243
C to be done in SPATIAL. NB: index_lev and level_list need to be filled STLEV1A.244
C with values corresponding to the full range of levels processed. STLEV1A.245
C STLEV1A.246
what_proc=STASH_CONTROL(st_proc_no_code) STLEV1A.247
what_mean=(STASH_CONTROL(st_gridpoint_code)/block_size)*block_size STLEV1A.248
IF(what_mean.EQ.vert_mean_base .OR. what_mean.EQ.global_mean_base STLEV1A.249
& .OR. what_proc.EQ.st_time_series_code STLEV1A.250
& .OR. what_proc.EQ.8 GRS1F404.250
& .OR. what_proc.EQ.st_append_traj_code) num_levs_out=1 STLEV1A.251
C STLEV1A.252
C Next compute the index for pseudo levels, if there are any STLEV1A.253
C STLEV1A.254
IF(STASH_CONTROL(st_pseudo_in).GT.0) THEN ! Input PSEUDO_LEVELS STLEV1A.255
NI=STASH_CONTROL(st_pseudo_in) STLEV1A.256
num_pseudo_in=STASH_PSEUDO_LEVELS(1,NI) STLEV1A.257
IF(STASH_CONTROL(st_pseudo_out).GT.0) THEN ! Output PSEUDO_LEVS STLEV1A.258
NO=STASH_CONTROL(st_pseudo_out) STLEV1A.259
num_pseudo_out=STASH_PSEUDO_LEVELS(1,NO) STLEV1A.260
INDX1=0 STLEV1A.261
DO ML=1,NUM_PSEUDO_OUT STLEV1A.262
ilev=STASH_PSEUDO_LEVELS(ML+1,NO) ! Level required STLEV1A.263
DO KL=1,NUM_PSEUDO_IN STLEV1A.264
IF(STASH_PSEUDO_LEVELS(KL+1,NI).EQ.ilev) THEN STLEV1A.265
INDX1=INDX1+1 STLEV1A.266
INDEX_PSEUDO_LEV(INDX1)=KL STLEV1A.267
pseudo_level(indx1)=ilev STLEV1A.268
GOTO 500 STLEV1A.269
ENDIF STLEV1A.270
ENDDO STLEV1A.271
ICODE=nonsense STLEV1A.272
WRITE(CMESSAGE,101) 'Output pseudo level ',ilev, STLEV1A.273
& ' not found in input levels list' STLEV1A.274
GOTO 999 STLEV1A.275
500 CONTINUE STLEV1A.276
ENDDO STLEV1A.277
ELSE ! Illegal combination STLEV1A.278
ICODE=nonsense STLEV1A.279
WRITE(CMESSAGE,101) 'Input pseudo level list ',NI, STLEV1A.280
& ' has illegal output pseudo levels list' STLEV1A.281
GOTO 999 STLEV1A.282
ENDIF STLEV1A.283
ELSE ! Only levels lists are supported for pseudo levels STLEV1A.284
num_pseudo_out=0 STLEV1A.285
ENDIF STLEV1A.286
C STLEV1A.287
C Next expand the separate indexes and physical levels arrays into STLEV1A.288
C combined arrays if necessary, taking care not to overwrite earlier STLEV1A.289
C parts of the arrays. If no pseudo-levels, set pseudo-level to 0. TJ140193.100
C STLEV1A.291
IF (num_pseudo_out.GT.0) THEN STLEV1A.292
DO K2=num_pseudo_out,1,-1 STLEV1A.293
DO ML=1,num_levs_out STLEV1A.294
INDEX_LEV(ML+(K2-1)*num_levs_out)= STLEV1A.295
& (INDEX_PSEUDO_LEV(K2)-1)*num_levs_in+INDEX_LEV(ML) STLEV1A.296
level(ML+(K2-1)*num_levs_out)=level(ML) STLEV1A.297
ak_lev(ML+(K2-1)*num_levs_out)=ak_lev(ML) STLEV1A.298
bk_lev(ML+(K2-1)*num_levs_out)=bk_lev(ML) STLEV1A.299
ENDDO STLEV1A.300
DO ML=num_levs_out,1,-1 STLEV1A.301
pseudo_level(ML+(K2-1)*num_levs_out)=pseudo_level(K2) STLEV1A.302
ENDDO STLEV1A.303
ENDDO STLEV1A.304
num_levs_out=num_levs_out*num_pseudo_out STLEV1A.305
ELSE STLEV1A.306
DO ML=1,num_levs_out STLEV1A.307
pseudo_level(ML)=0 TJ140193.101
ENDDO STLEV1A.309
ENDIF STLEV1A.310
C STLEV1A.311
999 CONTINUE ! jump here for error return STLEV1A.312
101 FORMAT('STLEVELS : ',a,i6,a) TJ140193.102
103 FORMAT('STLEVELS : >> FATAL ERROR <<',a,2i5) TJ140193.103
RETURN STLEV1A.315
END STLEV1A.316
STLEV1A.317
*ENDIF STLEV1A.318