SUBROUTINE PFinc_2UM(nftout,fixhd,len_fixhd, 1,216PF2UM1A.24
& inthd,len_inthd, PF2UM1A.25
& realhd,len_realhd, PF2UM1A.26
& levdepc,len1_levdepc,len2_levdepc, PF2UM1A.27
& rowdepc,len1_rowdepc,len2_rowdepc, PF2UM1A.28
& coldepc,len1_coldepc,len2_coldepc, PF2UM1A.29
& flddepc,len1_flddepc,len2_flddepc, PF2UM1A.30
& extcnst,len_extcnst, PF2UM1A.31
& dumphist,len_dumphist, PF2UM1A.32
& cfi1,len_cfi1, PF2UM1A.33
& cfi2,len_cfi2, PF2UM1A.34
& cfi3,len_cfi3, PF2UM1A.35
& lookup,len1_lookup,len2_lookup, PF2UM1A.36
& p_levels,p_field,p_rows, PF2UM1A.37
& row_length,len_data, PF2UM1A.38
& pp_itemc,pp_pos,n_types, PF2UM1A.39
& pp_len,pp_num,pp_type, PF2UM1A.40
& bl_levels,q_levels, PF2UM1A.41
& len1_lookup_um,len2_lookup_um,fixhd_um, PF2UM1A.42
& len1_lookup_ls,len2_lookup_ls,fixhd_ls, PF2UM1A.43
& akh,bkh,land_points, UIE2F404.173
& scale, UDG7F405.111
*CALL ARGPPX 
PF2UM1A.45
& icode,cmessage,nftin2,nftin3) PF2UM1A.46
PF2UM1A.47
IMPLICIT NONE PF2UM1A.48
! PF2UM1A.49
! Description: PF2UM1A.50
! PF2UM1A.51
! Method: PF2UM1A.52
! PF2UM1A.53
! Current Code Owner: I Edmond PF2UM1A.54
! PF2UM1A.55
! History: PF2UM1A.56
! Version Date Comment PF2UM1A.57
! ------- ---- ------- PF2UM1A.58
! 4.1 15/6/96 Original code. Ian Edmond PF2UM1A.59
! 4.2 Oct. 96 T3E migration: *DEF CRAY removed GSS9F402.82
! S.J.Swarbrick GSS9F402.83
! vn4.4 9/4/97 Call to Cloud Scheme to convert qT -> q UIE2F404.1361
! and thetaL -> theta read in from UIE2F404.1362
! background UM dump. Ian Edmond UIE2F404.1363
! vn4.4 10/4/97 P* is set equal to the UM press on level 1. UIE2F404.1364
! Ian Edmond UIE2F404.1365
! vn4.4 Initialise Crit Rel humidity variable for UIE2F404.1366
! MES dump. Initialise logical controling which UIE2F404.1367
! field the temperature increments are written to. IE UIE2F404.1368
! vn4.4 9/4/97 Code added to establish whether background UIE2F404.1369
! UM dump is a MOSES dump and obtain weights used UIE2F404.1370
! to scale T'. This field is written out to deep soil UIE2F404.1371
! T if background is a MOSES dump, otherwise field UIE2F404.1372
! is written to surface T. UIE2F404.1373
! Code added to replace the extrapolated theta field UIE2F404.1374
! on UM press level 1 with the theta' field on PF UIE2F404.1375
! theta level 1. Ian Edmond UIE2F404.1376
! vn4.4 9/4/97 DATA statement for crit rel humidity changed to UIE2F404.1377
! allow compilation using NAG f90 compiler. UIE2F404.1378
! vn4.4 9/4/97 (1)Character variables changed to CHARACTER*(80) UIE2F404.1379
! (2)Dimension of work2 corrected to allow f90 UIE2F404.1380
! compiled code to run. IEdmond UIE2F404.1381
! vn4.4 30/4/97 Replace the extrapolated theta field on UM UIE2F404.1382
! press level 19 with zero's Ian Edmond UIE2F404.1383
! 4.5 15/04/98 Start-end args added to V_INT_Z. S.D.Mullerworth GSM1F405.542
! 4.5 29/07/98 Optimisation changes for T3E Rewrote **KAPPA UDG5F405.190
! calculations to reduce number of "**"'s and UDG5F405.191
! replaced "**"'s with vector function powr_v UDG5F405.192
! Author D.M. Goddard UDG5F405.193
! 4.5 17/10/97 Use variable heights instead of fields UDG6F405.89
! of constants to store heights. UDG6F405.90
! Author D.M. Goddard UDG6F405.91
! 4.5 10/11/98 Correct data statements initialising UDG6F405.124
! rhcrit and rhcrit_mes. UDG6F405.125
! Author D.M. Goddard UDG6F405.126
! 4.5 27/8/98 Aerosol concentration increments calculated from UDG7F405.107
! log aerosol concentration increment at level one UDG7F405.108
! if log aerosol concentration increment in PF dump UDG7F405.109
! Author D.M. Goddard UDG7F405.110
! PF2UM1A.60
! Code Description: PF2UM1A.61
! Language: FORTRAN 77 + common extensions. PF2UM1A.62
! This code is written to UMDP3 v6 programming standards. PF2UM1A.63
! PF2UM1A.64
! System component covered: <appropriate code> PF2UM1A.65
! System Task: <appropriate code> PF2UM1A.66
! PF2UM1A.67
! Declarations: PF2UM1A.68
! These are of the form:- PF2UM1A.69
! INTEGER ExampleVariable !Description of variable PF2UM1A.70
! PF2UM1A.71
! 1.0 Global variables (*CALLed COMDECKs etc...): PF2UM1A.72
*CALL C_G PF2UM1A.73
*CALL C_R_CP PF2UM1A.74
*CALL RCPARAM PF2UM1A.75
*CALL C_EPSLON PF2UM1A.76
*CALL CLOOKADD PF2UM1A.77
*CALL CSUBMODL PF2UM1A.78
*CALL CPPXREF PF2UM1A.79
*CALL PPXLOOK PF2UM1A.80
PF2UM1A.81
! Subroutine arguments PF2UM1A.82
! Scalar arguments with intent(in): PF2UM1A.83
INTEGER PF2UM1A.84
& nftout ! Unit number of output file PF2UM1A.85
&,len_fixhd ! Length of fixed length header (output) PF2UM1A.86
&,len_inthd ! Length of integer header (output) PF2UM1A.87
&,len_realhd ! Length of real header (output) PF2UM1A.88
&,len2_levdepc ! 2nd dim of lev dep consts (output) PF2UM1A.89
&,len1_levdepc ! 1st dim of lev dep consts (output) PF2UM1A.90
&,len1_rowdepc ! 1st dim of row dep consts (output) PF2UM1A.91
&,len2_rowdepc ! 2nd dim of row dep consts (output) PF2UM1A.92
&,len1_coldepc ! 1st dim of col dep consts (output) PF2UM1A.93
&,len2_coldepc ! 2nd dim of col dep consts (output) PF2UM1A.94
&,len1_flddepc ! 1st dim of field dep consts (output) PF2UM1A.95
&,len2_flddepc ! 2nd dim of field dep consts (output) PF2UM1A.96
&,len_extcnst ! Length of extra constants (output) PF2UM1A.97
&,len_dumphist ! Length of history header (output) PF2UM1A.98
&,len_cfi1 ! Length of index1 on output file PF2UM1A.99
&,len_cfi2 ! Length of index2 on output file PF2UM1A.100
&,len_cfi3 ! Length of index3 on output file PF2UM1A.101
&,len1_lookup ! 1st dim of lookup header (output) PF2UM1A.102
&,len2_lookup ! 2nd dim of lookup header (output) PF2UM1A.103
&,len1_lookup_um ! 1st dim of lookup header (input UM dump) PF2UM1A.104
&,len2_lookup_um ! 2nd dim of lookup header (input UM dump) PF2UM1A.105
&,len1_lookup_ls ! 1st dim of lookup header (input LS dump) PF2UM1A.106
&,len2_lookup_ls ! 2nd dim of lookup header (input LS dump) PF2UM1A.107
&,len_data ! Length of output data (output) PF2UM1A.108
&,start_block ! READHEAD argument PF2UM1A.109
PF2UM1A.110
INTEGER PF2UM1A.111
& p_field ! No of p-points per level (output) PF2UM1A.112
&,land_points ! No of land points UIE2F404.174
&,row_length ! No of points E-W (output) PF2UM1A.113
&,p_rows ! No of P-points N-S (output) PF2UM1A.114
&,p_levels ! No of levels (output) PF2UM1A.115
&,q_levels ! No of wet levels (output) PF2UM1A.116
&,bl_levels ! No of b.l. levels (output) PF2UM1A.117
PF2UM1A.118
INTEGER PF2UM1A.119
& n_types ! No of different field types PF2UM1A.120
PF2UM1A.121
LOGICAL UIE2F404.175
& lmoses UIE2F404.176
! Array arguments with intent(in): PF2UM1A.122
PF2UM1A.123
INTEGER PF2UM1A.124
& fixhd(len_fixhd) PF2UM1A.125
&,fixhd_um(len_fixhd) PF2UM1A.126
&,fixhd_ls(len_fixhd) PF2UM1A.127
&,inthd(len_inthd) PF2UM1A.128
&,cfi1(len_cfi1+1) PF2UM1A.129
&,cfi2(len_cfi2+1) PF2UM1A.130
&,cfi3(len_cfi3+1) PF2UM1A.131
&,lookup(len1_lookup,len2_lookup) PF2UM1A.132
PF2UM1A.133
INTEGER PF2UM1A.134
& pp_len(len2_lookup) !Length PF2UM1A.135
&,pp_num(len2_lookup) !No of fields For each PF2UM1A.136
&,pp_pos(len2_lookup) !Position field type PF2UM1A.137
&,pp_type(len2_lookup) !Real,int,log on output file PF2UM1A.138
&,pp_itemc(len2_lookup) !Item code PF2UM1A.139
PF2UM1A.140
REAL PF2UM1A.141
& realhd(len_realhd) PF2UM1A.142
&,levdepc(1+len1_levdepc*len2_levdepc) PF2UM1A.143
&,rowdepc(1+len1_rowdepc*len2_rowdepc) PF2UM1A.144
&,coldepc(1+len1_coldepc*len2_coldepc) PF2UM1A.145
&,flddepc(1+len1_flddepc*len2_flddepc) PF2UM1A.146
&,heights(1+(p_levels*2+2)*p_field) UDG6F405.92
&,extcnst(len_extcnst+1) PF2UM1A.147
&,dumphist(len_dumphist+1) PF2UM1A.148
PF2UM1A.149
! ErrorStatus PF2UM1A.150
INTEGER PF2UM1A.151
& len_io PF2UM1A.152
&,icode ! Return code; successful=0 PF2UM1A.153
! error > 0 PF2UM1A.154
CHARACTER*80 FILENAME !filename holding namelist UIE2F404.177
CHARACTER*(80) UIE2F404.45
& cmessage ! Error message If icode > 0 PF2UM1A.156
PF2UM1A.157
! Local parameters: PF2UM1A.158
INTEGER p_levels_max ! define max no. of model levels PF2UM1A.159
PARAMETER(p_levels_max=99) ! for Crit RH variable. PF2UM1A.160
PF2UM1A.161
INTEGER Linear ! Linear interpolation used. PF2UM1A.162
PARAMETER(Linear=1) PF2UM1A.163
PF2UM1A.164
INTEGER Cubic ! Cubic interpolation used. PF2UM1A.165
PARAMETER(Cubic=3) PF2UM1A.166
PF2UM1A.167
INTEGER Quintic ! Quintic interpolation used. PF2UM1A.168
PARAMETER(Quintic=5) PF2UM1A.169
PF2UM1A.170
INTEGER hybrid ! Dump type (UM) UIE2F404.1211
PARAMETER(hybrid=1) UIE2F404.1212
UIE2F404.1213
INTEGER len_dummy PF2UM1A.171
PARAMETER(len_dummy=1) PF2UM1A.172
PF2UM1A.173
REAL EarthRadius ! Mean radius of earth in m PF2UM1A.174
PARAMETER(EarthRadius=6371229.) PF2UM1A.175
PF2UM1A.176
REAL L PF2UM1A.177
PARAMETER(L=2000.0) PF2UM1A.178
PF2UM1A.179
REAL CP_OVER_G ! Used in calculation of height of t PF2UM1A.180
PARAMETER(CP_OVER_G=CP/G) ! theta level. PF2UM1A.181
PF2UM1A.182
! Local scalars: PF2UM1A.183
INTEGER PF2UM1A.184
& pos PF2UM1A.185
&,pos1 PF2UM1A.186
&,pos2 PF2UM1A.187
&,pos3 PF2UM1A.188
&,nblp1 ! No of B.L. levs + 1 PF2UM1A.189
&,i,j,k PF2UM1A.190
&,nftin2 PF2UM1A.191
&,nftin3 PF2UM1A.192
*,n_types_ls !No of different field types PF2UM1A.193
*,n_types_um !No of different field types PF2UM1A.194
&,moisture_levs !No of moisture levels in background UM dump UIE2F404.178
&,soil_levs !No of deep soil T levels in background UM dump UIE2F404.179
&,scale !Constant used in calculating aerosol increment UDG7F405.112
UIE2F404.180
PF2UM1A.195
REAL PF2UM1A.196
& press1 !intermediate temporaries used in calc of press PF2UM1A.197
&,press2 !intermediate temporaries used in calc of press PF2UM1A.198
&,pexner1 PF2UM1A.199
&,pexner2 PF2UM1A.200
&,pf_pexner1 PF2UM1A.201
&,pf_pexner2 PF2UM1A.202
&,A PF2UM1A.203
&,del_exner PF2UM1A.204
&,exner_top PF2UM1A.205
&,gl_land_wgt UIE2F404.181
&,gl_sea_wgt UIE2F404.182
&,la_land_wgt UIE2F404.183
&,la_sea_wgt UIE2F404.184
PF2UM1A.206
! Local dynamic arrays: PF2UM1A.207
INTEGER PF2UM1A.208
& lookup_um(len1_lookup_um,len2_lookup_um) PF2UM1A.209
&,lookup_ls(len1_lookup_ls,len2_lookup_ls) PF2UM1A.210
&,dummy(len_dummy,len_dummy) PF2UM1A.211
&,dummy2(len_dummy) PF2UM1A.212
PF2UM1A.213
INTEGER PF2UM1A.214
& pp_len_ls(len2_lookup_ls) !Length PF2UM1A.215
&,pp_num_ls(len2_lookup_ls) !No of fields For each PF2UM1A.216
&,pp_pos_ls(len2_lookup_ls) !Position field type PF2UM1A.217
&,pp_type_ls(len2_lookup_ls) !Real,int,log on output file PF2UM1A.218
&,pp_itemc_ls(len2_lookup_ls) !Item code PF2UM1A.219
&,pp_lsm_ls(len2_lookup_ls) !Land or sea PF2UM1A.220
PF2UM1A.221
INTEGER PF2UM1A.222
* pp_len_um(len2_lookup_um) !Length PF2UM1A.223
*,pp_num_um(len2_lookup_um) !No of fields For each PF2UM1A.224
*,pp_pos_um(len2_lookup_um) !Position field type PF2UM1A.225
*,pp_type_um(len2_lookup_um) !Real,int,log on output file PF2UM1A.226
*,pp_itemc_um(len2_lookup_um) !Item code PF2UM1A.227
*,pp_lsm_um(len2_lookup_um) !Land or sea PF2UM1A.228
PF2UM1A.229
REAL PF2UM1A.230
* work1(p_field*p_levels) PF2UM1A.231
*,work2(p_field*(p_levels+1)) UIE2F404.44
*,work3(p_field*p_levels) PF2UM1A.233
*,work4(p_field*p_levels) PF2UM1A.234
*,work5(p_field*p_levels) PF2UM1A.235
*,pstar_um(p_field) ! Pstar on output grid PF2UM1A.236
*,pstar_ls(p_field) ! Pstar on output grid PF2UM1A.237
*,pfield1(p_field) ! Pressure of individual output level PF2UM1A.238
*,pfield2(p_field) ! Pressure of individual output level PF2UM1A.239
*,pfield3(p_field) ! Pressure of individual output level PF2UM1A.240
*,pfield4(p_field) ! Pressure of individual output level PF2UM1A.241
*,pfield5(p_field) ! Pressure of individual output level PF2UM1A.242
*,pfield6(p_field) ! Pressure of individual output level UIE2F404.185
&,rhcrit(p_levels_max) PF2UM1A.243
&,rhcrit_mes(p_levels_max) UIE2F404.79
&,topog_um(p_field) ! Ancillary field orography PF2UM1A.244
&,akh(p_levels+1) PF2UM1A.245
*IF DEF,VECTLIB PXVECTLB.113
&,a_pexner1(p_field) UDG5F405.195
&,a_pexner2(p_field) UDG5F405.196
&,a_pexner1_kappa(p_field) UDG5F405.197
&,a_pexner2_kappa(p_field) UDG5F405.198
&,a_press1(p_field) UDG5F405.199
&,a_press2(p_field) UDG5F405.200
*ENDIF UDG5F405.201
&,bkh(p_levels+1) PF2UM1A.246
PF2UM1A.247
LOGICAL UIE2F404.186
& lsmask(p_field) UIE2F404.187
PF2UM1A.252
CHARACTER*(80) UIE2F404.46
& f_type_title PF2UM1A.254
PF2UM1A.255
NAMELIST /TWEIGHTS/ GL_LAND_WGT,GL_SEA_WGT,LA_LAND_WGT,LA_SEA_WGT UIE2F404.188
DATA(rhcrit(i),i=1,99)/0.950000,0.900000,97*0.850000/ UDG6F405.127
PF2UM1A.260
DATA(rhcrit_mes(i),i=1,99)/0.916000,0.908000,0.891000,0.891000, UDG6F405.128
& 0.891000,0.875000,0.861000,0.857000, UDG6F405.129
& 0.854000,90*0.850000/ UDG6F405.130
! Function & Subroutine calls: PF2UM1A.261
External buffin,ioerror,setpos,PF_reverse,locate,abort, PF2UM1A.262
& readflds,qsat,ls_cld,vert_interp, PF2UM1A.263
& writflds,writhead PF2UM1A.264
& ,to_land_points, f_type, v_int_z, v_int_zh, UDG5F405.202
& pf_ls_cld, timer, abort_io, get_file UDG5F405.203
PF2UM1A.265
!- End of header PF2UM1A.266
PF2UM1A.267
If (fixhd(4).eq.103)then UDG6F405.131
UDG6F405.132
UDG6F405.133
!----------------------------------------------------------------------- UIE2F404.88
! 0. Reinitialise critical relative humidity if MES dump, UIE2F404.89
! and initialise LOGICAL lmoses UIE2F404.90
!----------------------------------------------------------------------- UIE2F404.91
UIE2F404.92
do i =1, p_levels UIE2F404.94
rhcrit(i) = rhcrit_mes(i) UIE2F404.95
end do UIE2F404.96
End if UIE2F404.97
UIE2F404.98
! Initialise lmoses which controls which field the temperature UIE2F404.99
! increments are written out to. UIE2F404.100
lmoses=.false. UIE2F404.101
PF2UM1A.268
!----------------------------------------------------------------------- PF2UM1A.269
! 1. Find heights of UM background full/half levels for vertical PF2UM1A.270
! linear interpolation of theta' and RH' from PF theta levels. PF2UM1A.271
!----------------------------------------------------------------------- PF2UM1A.272
PF2UM1A.273
! Read Fixed header record of UM dump. PF2UM1A.274
! Move to start of Look Up Table PF2UM1A.275
Call setpos(nftin2,fixhd_um(150)-1,icode) PF2UM1A.276
PF2UM1A.277
! Read in fields from LOOKUP table PF2UM1A.278
Call Buffin(nftin2, PF2UM1A.279
& lookup_um(1,1), PF2UM1A.280
& fixhd_um(151)*fixhd_um(152), PF2UM1A.281
& len_io,A) PF2UM1A.282
PF2UM1A.283
! Check for I/O errors PF2UM1A.284
If(A.ne.-1.0.OR.len_io.ne.fixhd_um(151)*fixhd_um(152)) then PF2UM1A.285
Call ioerror('buffer in of lookup table', PF2UM1A.286
& A,len_io, PF2UM1A.287
& fixhd_um(151)*fixhd_um(152)) PF2UM1A.288
cmessage='pfinc2um: I/O error' PF2UM1A.289
icode=25 PF2UM1A.290
Call abort PF2UM1A.291
End if PF2UM1A.292
PF2UM1A.293
! Read in first UM variables PF2UM1A.294
PF2UM1A.295
! Returns each field code and associated field length in the PF2UM1A.296
! UM dump and a count of the number of fields of each type. PF2UM1A.297
f_type_title='UM data' UIE2F404.47
Call f_type(lookup_um, !(IN) Lookup tables of UM dump. PF2UM1A.299
& len2_lookup_um, !(IN) 2nd dim. of UM lookup table. PF2UM1A.300
& pp_num_um, !(OUT)No of fields for each field t PF2UM1A.301
& n_types_um, !(OUT)No of field types in UM dump. PF2UM1A.302
& pp_len_um, !(OUT)Length of field. PF2UM1A.303
& pp_itemc_um, !(OUT)Item code of field type. PF2UM1A.304
& pp_type_um, !(OUT)Integer/real/timeseries PF2UM1A.305
& pp_pos_um, !(OUT)Pointer to number of field. PF2UM1A.306
& pp_lsm_um, !(OUT)Data stored on land or sea pt PF2UM1A.307
& fixhd_um, PF2UM1A.308
*CALL ARGPPX PF2UM1A.309
& f_type_title) PF2UM1A.310
PF2UM1A.311
! Read THL into array work3 PF2UM1A.312
Do j=1,n_types_um ! loop over variables in NAMELIST PF2UM1A.313
PF2UM1A.314
If (pp_itemc_um(j).eq.stashcode_OD_thetaL) then PF2UM1A.315
PF2UM1A.316
Call locate(pp_itemc_um(j), !(IN)PARAMETER name for STASH PF2UM1A.317
& ! item/section code for thetaL. PF2UM1A.318
& pp_itemc_um, !(IN)Array of item codes. PF2UM1A.319
& n_types_um, !(IN)No. of field types. PF2UM1A.320
& pos) !(OUT)Pos. of thetaL in pp_itemc. PF2UM1A.321
PF2UM1A.322
If (pos.eq.0) then PF2UM1A.323
PF2UM1A.324
write(6,'('' *ERROR* ThetaL (UM dump) not in input file'')') PF2UM1A.325
Call abort PF2UM1A.326
PF2UM1A.327
End if PF2UM1A.328
PF2UM1A.329
CALL TIMER('READFLDS',3) UDG5F405.204
Call readflds(nftin2, !(IN)Unit number of UM dump. PF2UM1A.330
& pp_num_um(j), !(IN)Read thetaL on all press l PF2UM1A.331
& pp_pos_um(pos), !(IN)Field no. in UM dump. PF2UM1A.332
& lookup_um, !(IN)Lookup table of UM dump. PF2UM1A.333
& len1_lookup_um, !(IN)1st dim of Lookup. PF2UM1A.334
& work3, !(OUT)ThetaL read into work3. PF2UM1A.335
& pp_len_um(j), !(IN)No. of p points per level. PF2UM1A.336
& fixhd_um, !(IN)UM Fixed header record. PF2UM1A.337
*CALL ARGPPX PF2UM1A.338
& icode,cmessage) !(IN/OUT)Error flags. PF2UM1A.339
CALL TIMER('READFLDS',4) UDG5F405.205
PF2UM1A.340
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage, PF2UM1A.341
& icode,nftin2) PF2UM1A.342
PF2UM1A.343
Else if (pp_itemc_um(j).eq.stashcode_OD_qT) then PF2UM1A.344
PF2UM1A.345
! Read QT into array work1 PF2UM1A.346
Call locate(pp_itemc_um(j), !(IN)PARAMETER name for STASH PF2UM1A.347
& ! item/section code for qT. PF2UM1A.348
& pp_itemc_um, !(IN)Array of item codes. PF2UM1A.349
& n_types_um, !(IN)No. of field types in input U PF2UM1A.350
& pos) !(OUT)Pos. of qT in pp_itemc_um. PF2UM1A.351
PF2UM1A.352
If (pos.eq.0) then PF2UM1A.353
PF2UM1A.354
write(6,'('' *ERROR* qT (UM dump) not in input file'')') PF2UM1A.355
Call abort PF2UM1A.356
PF2UM1A.357
End if PF2UM1A.358
PF2UM1A.359
CALL TIMER('READFLDS',3) UDG5F405.206
Call readflds(nftin2, !(IN)Unit number of UM dump. PF2UM1A.360
& pp_num_um(j), !(IN)Read qT on all press levs. PF2UM1A.361
& pp_pos_um(pos), !(IN)Field no. in UM dump. PF2UM1A.362
& lookup_um, !(IN)Lookup table of UM dump. PF2UM1A.363
& len1_lookup_um, !(IN)1st dim of Lookup. PF2UM1A.364
& work1, !(OUT)qT read into work1. PF2UM1A.365
& pp_len_um(j), !(IN)No. of p points per level. PF2UM1A.366
& fixhd_um, !(IN)UM Fixed header record. PF2UM1A.367
*CALL ARGPPX PF2UM1A.368
& icode,cmessage) !(IN/OUT)Error flags. PF2UM1A.369
CALL TIMER('READFLDS',4) UDG5F405.207
PF2UM1A.370
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage, PF2UM1A.371
& icode,nftin2) PF2UM1A.372
PF2UM1A.373
Else if (pp_itemc_um(j).eq.stashcode_OD_pstar) then PF2UM1A.374
PF2UM1A.375
Call locate(pp_itemc_um(j), !(IN)PARAMETER name for STASH PF2UM1A.376
& ! item/section code for P*. PF2UM1A.377
& pp_itemc_um, !(IN)Array of item codes. PF2UM1A.378
& n_types_um, !(IN)No. of field types in input U PF2UM1A.379
& pos) !(OUT)Pos. of P* in pp_itemc_um. PF2UM1A.380
PF2UM1A.381
If (pos.eq.0) then PF2UM1A.382
PF2UM1A.383
write(6,'('' *ERROR* P* (LS dump) not in input file'')') PF2UM1A.384
Call abort PF2UM1A.385
PF2UM1A.386
End if PF2UM1A.387
PF2UM1A.388
CALL TIMER('READFLDS',3) UDG5F405.208
Call readflds(nftin2, !(IN)Unit number of UM dump. PF2UM1A.389
& pp_num_um(j), !(IN)Read P* on single level. PF2UM1A.390
& pp_pos_um(pos), !(IN)Field no. in UM dump. PF2UM1A.391
& lookup_um, !(IN)Lookup table of UM dump. PF2UM1A.392
& len1_lookup_um, !(IN)1st dim of Lookup. PF2UM1A.393
& pstar_um, !(OUT)P* read into pstar_um. PF2UM1A.394
& pp_len_um(j), !(IN)No. of p points per level. PF2UM1A.395
& fixhd_um, !(IN)UM Fixed header record. PF2UM1A.396
*CALL ARGPPX PF2UM1A.397
& icode,cmessage) !(IN/OUT)Error flags. PF2UM1A.398
CALL TIMER('READFLDS',4) UDG5F405.209
PF2UM1A.399
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage, PF2UM1A.400
& icode,nftin2) PF2UM1A.401
PF2UM1A.402
! Calculate exner pressure at UM half levels. Read into work2. PF2UM1A.403
Do k = 1,p_levels+1 PF2UM1A.404
pos = (k-1) * pp_len_um(j) PF2UM1A.405
*IF DEF,VECTLIB PXVECTLB.114
Do i = 1,pp_len_um(j) UDG5F405.211
UDG5F405.212
press1 = akh(k)+bkh(k)*pstar_um(i) UDG5F405.213
work2(i+pos) = (press1 / Pref) UDG5F405.214
UDG5F405.215
End do UDG5F405.216
UDG5F405.217
call powr_v(pp_len_um(j),work2(1+pos),kappa,work2(1+pos)) UDG5F405.218
*ELSE UDG5F405.219
Do i = 1,pp_len_um(j) PF2UM1A.406
PF2UM1A.407
press1 = akh(k)+bkh(k)*pstar_um(i) PF2UM1A.408
work2(i+pos) = (press1 / Pref)**kappa PF2UM1A.409
PF2UM1A.410
End do ! i PF2UM1A.411
*ENDIF UDG5F405.220
PF2UM1A.412
End do ! k PF2UM1A.413
PF2UM1A.414
Else if (pp_itemc_um(j).eq.stashcode_OD_orog) then PF2UM1A.415
PF2UM1A.416
Call locate(pp_itemc_um(j), !(IN)PARAMETER name for STASH PF2UM1A.417
& ! item/section code for P*. PF2UM1A.418
& pp_itemc_um, !(IN)Array of item codes. PF2UM1A.419
& n_types_um, !(IN)No. of field types in input U PF2UM1A.420
& pos) !(OUT)Pos. of P* in pp_itemc_um. PF2UM1A.421
PF2UM1A.422
If (pos.eq.0) then PF2UM1A.423
PF2UM1A.424
write(6,'('' *ERROR* OROG (LS dump) not in input file'')') PF2UM1A.425
Call abort PF2UM1A.426
PF2UM1A.427
End if PF2UM1A.428
PF2UM1A.429
CALL TIMER('READFLDS',3) UDG5F405.221
Call readflds(nftin2, !(IN)Unit number of UM dump. PF2UM1A.430
& pp_num_um(j), !(IN)Read orog on single level. PF2UM1A.431
& pp_pos_um(pos), !(IN)Field no. in UM dump. PF2UM1A.432
& lookup_um, !(IN)Lookup table of UM dump. PF2UM1A.433
& len1_lookup_um, !(IN)1st dim of Lookup. PF2UM1A.434
& topog_um, !(OUT)orog read into array topog PF2UM1A.435
& pp_len_um(j), !(IN)No. of p points per level. PF2UM1A.436
& fixhd_um, !(IN)UM Fixed header record. PF2UM1A.437
*CALL ARGPPX PF2UM1A.438
& icode,cmessage) !(IN/OUT)Error flags. PF2UM1A.439
CALL TIMER('READFLDS',4) UDG5F405.222
PF2UM1A.440
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage, PF2UM1A.441
& icode,nftin2) PF2UM1A.442
PF2UM1A.443
! Convert topography into geopotential at surface for input PF2UM1A.444
! to v_int_zh PF2UM1A.445
Do i = 1,pp_len_um(j) PF2UM1A.446
PF2UM1A.447
topog_um(i) = topog_um(i) * G ! G - gravity PF2UM1A.448
PF2UM1A.449
End do ! i PF2UM1A.450
PF2UM1A.451
PF2UM1A.452
End if PF2UM1A.453
PF2UM1A.454
End do ! j PF2UM1A.455
PF2UM1A.456
! Call to cloud scheme 1A enables the conversion of qT -> q UIE2F404.1214
! (work1) and THL -> TH (work3). UIE2F404.1215
UIE2F404.1216
do k =1,q_levels UIE2F404.1217
pos = (k-1) * p_field UIE2F404.1218
UIE2F404.1219
CALL TIMER('pf_ls_cl',3) UDG5F405.223
Call pf_ls_cld(levdepc(k), ! (IN) Full level ak's. UIE2F404.1220
& levdepc(p_levels+k),! (IN) Full level bk's. UIE2F404.1221
& levdepc(k+1), UIE2F404.1222
& levdepc(p_levels+k+1),! (IN) bk's UIE2F404.1223
& pstar_um, ! (IN) P* UIE2F404.1224
& rhcrit(k), ! (IN) Critical relative UIE2F404.1225
& ! humidity from namelist. UIE2F404.1226
& p_field, ! (IN) No. of p points per lev. UIE2F404.1227
& p_field, ! (IN) No. of p points per lev. UIE2F404.1228
& work3(pos+1), ! (IN/OUT) THL -> TH UIE2F404.1229
& work1(pos+1), ! (IN/OUT) qT -> q UIE2F404.1230
& pfield1, ! (OUT) qc (not used) UIE2F404.1231
& hybrid, ! Dump type UIE2F404.1232
& icode) ! (IN/OUT) Error flag. UIE2F404.1233
CALL TIMER('pf_ls_cl',4) UDG5F405.224
UIE2F404.1234
end do UIE2F404.1235
PF2UM1A.457
! 1.2 Find heights of half levels PF2UM1A.458
PF2UM1A.459
! Find heights of half level boundaries: store in heights 1st UDG6F405.93
! field of (horizontal points * no of levels+1). First horizontal PF2UM1A.461
! field is topography (defines theta levels on new vertical grid) PF2UM1A.462
CALL TIMER('v_int_zh',3) UDG5F405.225
Call v_int_zh(work2, !(IN) Exner pressure UM half levs PF2UM1A.463
& work3, !(IN) Theta on UM full levels. UIE2F404.1236
& work1, !(IN) q on UM full levels. UIE2F404.1237
& topog_um, !(IN) Topography. PF2UM1A.466
& heights, !(OUT) Heights of UM half levels. UDG6F405.94
& p_field, !(IN) No. of p points per level. PF2UM1A.468
& p_levels, !(IN) No. of full/pressure levels. PF2UM1A.469
& q_levels) !(IN) No. of wet levels. PF2UM1A.470
CALL TIMER('v_int_zh',4) UDG5F405.226
PF2UM1A.471
! 1.3 Find heights of UM background full levels. PF2UM1A.472
PF2UM1A.473
Do i = 1,p_field PF2UM1A.474
PF2UM1A.475
heights((p_levels+1)*p_field+i) = heights(i) UDG6F405.95
PF2UM1A.477
End do ! i PF2UM1A.478
PF2UM1A.479
! Get ak,bk from level dependent constants PF2UM1A.480
nblp1 = bl_levels + 1 ! BL Reference level for v_int_z PF2UM1A.481
PF2UM1A.482
Do i = 1,p_field PF2UM1A.483
PF2UM1A.484
! Reference pressure of layer centre nblp1. PF2UM1A.485
pfield2(i) = levdepc(nblp1) + PF2UM1A.486
& levdepc(nblp1+p_levels) * pstar_um(i) PF2UM1A.487
PF2UM1A.488
End do ! i PF2UM1A.489
PF2UM1A.490
Do k = 1,p_levels PF2UM1A.491
PF2UM1A.492
! Reference pressure of layer centre (full level) PF2UM1A.493
Do i = 1,p_field PF2UM1A.494
PF2UM1A.495
pfield1(i) = levdepc(k)+ PF2UM1A.496
& levdepc(k+p_levels) * pstar_um(i) PF2UM1A.497
PF2UM1A.498
End do ! i PF2UM1A.499
PF2UM1A.500
pos1 = (p_levels+1) * p_field + k*p_field UDG6F405.96
PF2UM1A.502
! Find heights of full level centres: store in heights 2nd grid UDG6F405.97
! of (horizontal points * no of levels+1). First horizontal PF2UM1A.504
! field is topography. (defines rho levels on new vertical grid PF2UM1A.505
CALL TIMER('v_int_z ',3) UDG5F405.227
Call v_int_z(pfield1, !(IN) Press on full level k. PF2UM1A.506
& pfield2, !(IN) Press on ref lev nblp1. PF2UM1A.507
& pstar_um, !(IN) P* PF2UM1A.508
& work2, !(IN) Exner press on half levs PF2UM1A.509
& work3, !(IN) Theta on full levs. UIE2F404.1239
& work1, !(IN) q on full levels. UIE2F404.1240
& heights(1), !(IN) half level heights. UDG6F405.98
& heights(pos1+1), !(OUT)full level heights. UDG6F405.99
& p_field, !(IN) No. of press points. PF2UM1A.514
& p_levels, !(IN) No. of full levels. PF2UM1A.515
& q_levels, !(IN) No. of wet levels. PF2UM1A.516
& nblp1, PF2UM1A.517
& akh, !(IN) ref lev and half lev PF2UM1A.518
& bkh, ! ak's, bk's. GSM1F405.543
& 1, !(IN) Start-end arguments GSM1F405.544
& p_field) GSM1F405.545
CALL TIMER('v_int_z ',4) UDG5F405.228
PF2UM1A.520
End do ! k PF2UM1A.521
CALL TIMER('Pfinc2UM',3) UDG5F405.229
PF2UM1A.522
! Find the heights of the theta levels on the PF vertical grid. PF2UM1A.523
! Take theta levels as halfway between the pressure levels. PF2UM1A.524
! Top theta level (above top pressure level) is found using PF2UM1A.525
! the hydrostatic equation. PF2UM1A.526
PF2UM1A.527
Do k = 1,p_levels-1 PF2UM1A.528
PF2UM1A.529
pos1 = (p_levels+1) * p_field+p_field*k UDG6F405.100
pos2 = (p_levels+1) * p_field+p_field*(k+1) UDG6F405.101
pos3 = p_field*k PF2UM1A.532
PF2UM1A.533
Do i = 1,p_field PF2UM1A.534
PF2UM1A.535
heights(pos3+i) = (heights(pos1+i) + heights(pos2+i))/2.0 UDG6F405.102
PF2UM1A.537
End do PF2UM1A.538
PF2UM1A.539
End do ! k PF2UM1A.540
PF2UM1A.541
exner_top = (50.0 / Pref)**kappa UDG5F405.230
*IF DEF,VECTLIB PXVECTLB.115
Do i = 1,p_field UDG5F405.232
press1 = levdepc(p_levels-1) UDG5F405.233
& + levdepc(2*p_levels-1) * pstar_um(i) UDG5F405.234
a_pexner1(i) = (press1 / pref) UDG5F405.235
UDG5F405.236
press2 = levdepc(p_levels) UDG5F405.237
& + levdepc(2*p_levels) * pstar_um(i) UDG5F405.238
a_pexner2(i) = (press2 / pref) UDG5F405.239
enddo UDG5F405.240
call powr_v(p_field,a_pexner1,kappa,a_pexner1_kappa) UDG5F405.241
call powr_v(p_field,a_pexner2,kappa,a_pexner2_kappa) UDG5F405.242
UDG5F405.243
Do i = 1,p_field UDG5F405.244
pfield2(i) = (a_pexner2_kappa(i) - a_pexner1_kappa(i)) UDG5F405.245
& / ( ( a_pexner2(i)-a_pexner1(i)) * kappa) UDG5F405.246
enddo UDG5F405.247
UDG5F405.248
call powr_v(p_field,pfield2,(kappa/(kappa-1)),pfield2) UDG5F405.249
UDG5F405.250
Do i = 1,p_field UDG5F405.251
UDG5F405.252
del_exner = pfield2(i) - exner_top UDG5F405.253
heights(pos3+p_field+i) = heights(pos3+i) + cp_over_g * UDG5F405.254
& work3(p_field*(p_levels-1)+i) * del_exner UDG5F405.255
UDG5F405.256
End do UDG5F405.257
*ELSE UDG5F405.258
Do i = 1,p_field PF2UM1A.542
PF2UM1A.543
! Calculation of top theta level using hydrostatic eqn. PF2UM1A.544
! flddepc(pos3+i) contains the heights of the theta surface PF2UM1A.545
! at level 19. PF2UM1A.546
! work3 contains the theta field at full level 19. PF2UM1A.547
! del_exner is the difference in exner pressures at theta PF2UM1A.548
! levels 18 and 19 (taken to have a constant pressure of 50Pa PF2UM1A.549
! and defined only for the purposes of calculating the top PF2UM1A.550
! theta level). PF2UM1A.551
PF2UM1A.553
! Find exner pressures on theta level 18 on PF vertical grid PF2UM1A.554
press1 = levdepc(p_levels-1) PF2UM1A.555
& + levdepc(2*p_levels-1) * pstar_um(i) PF2UM1A.556
pexner1 = (press1 / pref)**kappa PF2UM1A.557
PF2UM1A.558
! Exner pressure at pressure level just above theta level PF2UM1A.559
! of interest on PF vertical grid. PF2UM1A.560
press2 = levdepc(p_levels) PF2UM1A.561
& + levdepc(2*p_levels) * pstar_um(i) PF2UM1A.562
pexner2 = (press2 / pref)**kappa PF2UM1A.563
PF2UM1A.564
! Exner pressures on theta levels of PF vertical grid read int PF2UM1A.565
! pfield for each level separately. PF2UM1A.566
pfield2(i) =(( ( (pexner2 - pexner1) PF2UM1A.567
& / ( (pexner2**(1/kappa) PF2UM1A.568
& - pexner1**(1/kappa) ) * kappa) PF2UM1A.569
& )**(1/(kappa-1))*pref PF2UM1A.570
& ) / Pref)**kappa PF2UM1A.571
PF2UM1A.572
del_exner = pfield2(i) - exner_top PF2UM1A.573
heights(pos3+p_field+i) = heights(pos3+i) + cp_over_g * UDG6F405.103
& work3(p_field*(p_levels-1)+i) * del_exner PF2UM1A.575
PF2UM1A.576
End do PF2UM1A.577
*ENDIF UDG5F405.259
PF2UM1A.578
CALL TIMER('Pfinc2UM',4) UDG5F405.260
PF2UM1A.579
! Reorder the fields storing the heights of the full and PF theta PF2UM1A.580
! level boundaries PF2UM1A.581
CALL TIMER('PF_Rever',3) UDG5F405.261
Call PF_Reverse(heights, !(IN/OUT)Theta and press level UDG6F405.104
& ! heights of 1st UM dum PF2UM1A.583
& row_length, !(IN)No. of columns. PF2UM1A.584
& (p_levels+1)*2,!(IN)No. of theta and press le PF2UM1A.585
& ! an additional level for t PF2UM1A.586
& ! in each height field. PF2UM1A.587
& p_rows, !(IN)No. of rows. PF2UM1A.588
& len_dummy, PF2UM1A.589
& dummy2, PF2UM1A.590
& 0, PF2UM1A.591
& len_dummy, PF2UM1A.592
& len_dummy, PF2UM1A.593
*CALL ARGPPX PF2UM1A.594
& dummy, PF2UM1A.595
& dummy) PF2UM1A.596
CALL TIMER('PF_Rever',4) UDG5F405.262
PF2UM1A.597
UIE2F404.189
! 1.4 Establish whether background UM dump is a MOSES dump UIE2F404.190
! and obtain weights used to scale T'. This field is written UIE2F404.191
! out to deep soil T if background is a MOSES dump, otherwise UIE2F404.192
! field is written to surface T. UIE2F404.193
UIE2F404.194
soil_levs=0 UIE2F404.195
moisture_levs=0 UIE2F404.196
! Whether to add the T' increments to surface temp or to top UIE2F404.197
! level deep soil temp depends the UM dump type. UIE2F404.198
Do i =1,n_types_um UIE2F404.199
If (pp_itemc_um(i) .eq. 20) then UIE2F404.200
soil_levs=pp_num_um(i) UIE2F404.201
Else if (pp_itemc_um(i) .eq. 9) then UIE2F404.202
moisture_levs=pp_num_um(i) UIE2F404.203
End if UIE2F404.204
End do UIE2F404.205
UIE2F404.206
! Background fields are from a MOSES dump if deep soil levels UIE2F404.207
! and the number fields of soil moisture levels in the dump are UIE2F404.208
! the same. UIE2F404.209
If ((soil_levs.ne.0).and.(soil_levs.eq.moisture_levs)) then UIE2F404.210
lmoses=.true. UIE2F404.211
Else UIE2F404.212
lmoses=.false. UIE2F404.213
Endif UIE2F404.214
write(*,*)soil_levs,'soil_levs',moisture_levs,'moisture_levs' UIE2F404.215
UIE2F404.216
! Initialise weights to scale the T' field written out UM T* to UIE2F404.217
! Deep soil T field. UIE2F404.218
gl_land_wgt=0 UIE2F404.219
gl_sea_wgt=0 UIE2F404.220
la_land_wgt=1 UIE2F404.221
la_sea_wgt=0 UIE2F404.222
UIE2F404.223
! Read weights from namelist TWEIGHTS. UIE2F404.224
Call get_file(5,FILENAME,80,icode) UIE2F404.225
OPEN(UNIT=5,FILE=FILENAME,DELIM='APOSTROPHE') PXNAMLST.6
UIE2F404.227
read(5,TWEIGHTS) UIE2F404.228
!----------------------------------------------------------------------- PF2UM1A.599
! 2.0 Calculation of the perturbation to RHt (RHt' = RH') on the PF grid PF2UM1A.600
!----------------------------------------------------------------------- PF2UM1A.601
PF2UM1A.602
! Read in fields from lookup tables of UM and LS dumps. PF2UM1A.603
! Move to start of Look Up Table PF2UM1A.604
Call setpos(nftin3,fixhd_ls(150)-1,icode) PF2UM1A.605
PF2UM1A.606
! Read in fields from LOOKUP table PF2UM1A.607
Call Buffin(nftin3, PF2UM1A.608
& lookup_ls(1,1), PF2UM1A.609
& fixhd_ls(151)*fixhd_ls(152), PF2UM1A.610
& len_io,A) PF2UM1A.611
PF2UM1A.612
! Check for I/O errors PF2UM1A.613
If(A.ne.-1.0.OR.len_io.ne.fixhd_ls(151)*fixhd_ls(152)) then PF2UM1A.614
Call ioerror('buffer in of lookup table', PF2UM1A.615
& A,len_io, PF2UM1A.616
& fixhd_ls(151)*fixhd_ls(152)) PF2UM1A.617
cmessage='pfinc2um: I/O error' PF2UM1A.618
icode=25 PF2UM1A.619
Call abort PF2UM1A.620
End if PF2UM1A.621
PF2UM1A.622
PF2UM1A.623
! Returns each field code and associated field length in the LS PF2UM1A.624
! dump and a count of the number of fields of each type. PF2UM1A.625
f_type_title='LS data' UIE2F404.48
Call f_type(lookup_ls, !(IN) Lookup tables of LS dump. PF2UM1A.627
& len2_lookup_ls, !(IN) 2nd dim. of LS lookup table. PF2UM1A.628
& pp_num_ls, !(OUT)No of fields for each field t PF2UM1A.629
& n_types_ls, !(OUT)No of field types in LS dump. PF2UM1A.630
& pp_len_ls, !(OUT)Length of field. PF2UM1A.631
& pp_itemc_ls, !(OUT)Item code of field type. PF2UM1A.632
& pp_type_ls, !(OUT)Integer/real/timeseries PF2UM1A.633
& pp_pos_ls, !(OUT)Pointer to number of field. PF2UM1A.634
& pp_lsm_ls, !(OUT)Data stored on land or sea pt PF2UM1A.635
& fixhd_ls, ! PF2UM1A.636
*CALL ARGPPX PF2UM1A.637
& f_type_title) PF2UM1A.638
PF2UM1A.639
PF2UM1A.640
! 2.1 Read in LS dump variables PF2UM1A.641
PF2UM1A.642
! Read TH into array work3 UIE2F404.1241
Do j=1,n_types_ls ! loop over variables in NAMELIST PF2UM1A.644
PF2UM1A.645
If (pp_itemc_ls(j).eq.stashcode_OD_theta) then UIE2F404.1242
PF2UM1A.647
Call locate(pp_itemc_ls(j), !(IN)PARAMETER name for STASH PF2UM1A.648
& ! item/section code for thetaL. PF2UM1A.649
& pp_itemc_ls, !(IN)Array of item codes. PF2UM1A.650
& n_types_ls, !(IN)No. of field types in LS dump PF2UM1A.651
& pos) !(OUT)Pos. of thetaL in pp_itemc_l PF2UM1A.652
PF2UM1A.653
If (pos.eq.0) then PF2UM1A.654
PF2UM1A.655
write(6,'('' *ERROR* Theta (LS dump) not in input file'')') UIE2F404.1243
Call abort PF2UM1A.657
PF2UM1A.658
End if PF2UM1A.659
PF2UM1A.660
CALL TIMER('READFLDS',3) UDG5F405.263
Call readflds(nftin3, !(IN)Unit number of input LS du PF2UM1A.661
& pp_num_ls(j), !(IN)Read thetaL on all theta l PF2UM1A.662
& pp_pos_ls(pos), !(IN)Field no. in LS dump. PF2UM1A.663
& lookup_ls, !(IN)Lookup table of LS dump. PF2UM1A.664
& len1_lookup_ls, !(IN)1st dim of Lookup. PF2UM1A.665
& work3, !(OUT)Read theta into array wo UIE2F404.1244
& pp_len_ls(j), !(IN)No. of theta points per le PF2UM1A.667
& fixhd_ls, !(IN)LS Fixed header record. PF2UM1A.668
*CALL ARGPPX PF2UM1A.669
& icode,cmessage) !(IN/OUT)Error flags. PF2UM1A.670
CALL TIMER('READFLDS',4) UDG5F405.264
PF2UM1A.671
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage, PF2UM1A.672
& icode,nftin3) PF2UM1A.673
PF2UM1A.674
! Reorganisation of TH field. UIE2F404.1245
pos1 = pp_pos_ls(pos) PF2UM1A.676
CALL TIMER('PF_Rever',3) UDG5F405.265
Call PF_Reverse(work3, !(IN/OUT) Theta on PF theta levels UIE2F404.1246
& lookup_ls(lbnpt,pos1), !(IN) No. of columns. PF2UM1A.678
& pp_num_ls(j), !(IN) No. of theta levels UIE2F404.1247
& lookup_ls(lbrow,pos1), !(IN) No. of rows PF2UM1A.680
& len_dummy, PF2UM1A.681
& dummy2, PF2UM1A.682
& 0, PF2UM1A.683
& len_dummy, PF2UM1A.684
& len_dummy, PF2UM1A.685
*CALL ARGPPX PF2UM1A.686
& dummy2, PF2UM1A.687
& dummy) PF2UM1A.688
CALL TIMER('PF_Rever',4) UDG5F405.266
PF2UM1A.689
PF2UM1A.690
PF2UM1A.691
Else if (pp_itemc_ls(j).eq.stashcode_OD_q) then UIE2F404.1248
! Read q into array work5 UIE2F404.1249
Call locate(pp_itemc_ls(j), !(IN)PARAMETER name for STASH PF2UM1A.694
& ! item/section code for q. UIE2F404.1250
& pp_itemc_ls, !(IN)Array of item codes. PF2UM1A.696
& n_types_ls, !(IN)No. of field types in LS dump PF2UM1A.697
& pos) !(OUT)Pos. of q in pp_itemc_ls. UIE2F404.1251
PF2UM1A.699
If (pos.eq.0) then PF2UM1A.700
PF2UM1A.701
write(6,'('' *ERROR* q (LS dump) not in input file'')') UIE2F404.1252
Call abort PF2UM1A.703
PF2UM1A.704
End if PF2UM1A.705
PF2UM1A.706
CALL TIMER('READFLDS',3) UDG5F405.267
Call readflds(nftin3, !(IN)Unit number of input LSdump UIE2F404.1253
& pp_num_ls(j), !(IN)Read q on all wet theta lev UIE2F404.1254
& pp_pos_ls(pos), !(IN)Field no. in LS dump. PF2UM1A.709
& lookup_ls, !(IN)Lookup table of LS dump. PF2UM1A.710
& len1_lookup_ls, !(IN)1st dim of Lookup. PF2UM1A.711
& work5, !(OUT)Read q into array work5. UIE2F404.1255
& pp_len_ls(j), !(IN)No. of p points per level. PF2UM1A.713
& fixhd_ls, !(IN)LS Fixed header record. PF2UM1A.714
*CALL ARGPPX PF2UM1A.715
& icode,cmessage) !(IN/OUT)Error flags. PF2UM1A.716
CALL TIMER('READFLDS',4) UDG5F405.268
PF2UM1A.717
PF2UM1A.718
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage, PF2UM1A.719
& icode,nftin3) PF2UM1A.720
PF2UM1A.721
! Reorganisation of q field. UIE2F404.1256
pos1 = pp_pos_ls(pos) PF2UM1A.723
CALL TIMER('PF_Rever',3) UDG5F405.269
Call PF_Reverse(work5, !(IN/OUT) Theta on PF theta levels UIE2F404.1257
& lookup_ls(lbnpt,pos1), !(IN)No. of columns. UIE2F404.1258
& pp_num_ls(j), !(IN)No. of theta levels. UIE2F404.1259
& lookup_ls(lbrow,pos1), !(IN)No. of rows UIE2F404.1260
& len_dummy, PF2UM1A.728
& dummy2, PF2UM1A.729
& 0, PF2UM1A.730
& len_dummy, PF2UM1A.731
& len_dummy, PF2UM1A.732
*CALL ARGPPX PF2UM1A.733
& dummy, PF2UM1A.734
& dummy) PF2UM1A.735
CALL TIMER('PF_Rever',4) UDG5F405.270
PF2UM1A.736
PF2UM1A.737
Else if (pp_itemc_ls(j).eq.stashcode_OD_pstar) then PF2UM1A.738
PF2UM1A.739
Call locate(pp_itemc_ls(j), !(IN)PARAMETER name for STASH PF2UM1A.740
& ! item/section code for P*. PF2UM1A.741
& pp_itemc_ls, !(IN)Array of item codes. PF2UM1A.742
& n_types_ls, !(IN)No. of field types in LS dump PF2UM1A.743
& pos) !(OUT)Pos. of P* in pp_itemc_ls. PF2UM1A.744
PF2UM1A.745
PF2UM1A.746
If (pos.eq.0) then PF2UM1A.747
PF2UM1A.748
write(6,'('' *ERROR* P* (LS dump) not in input file'')') PF2UM1A.749
Call abort PF2UM1A.750
PF2UM1A.751
End if PF2UM1A.752
PF2UM1A.753
CALL TIMER('READFLDS',3) UDG5F405.271
Call readflds(nftin3, !(IN)Unit number of input LS du PF2UM1A.754
& pp_num_ls(j), !(IN)Read q on all wet theta l UIE2F404.1261
& pp_pos_ls(pos), !(IN)Field no. in LS dump. PF2UM1A.756
& lookup_ls, !(IN)Lookup table of LS dump. PF2UM1A.757
& len1_lookup_ls, !(IN)1st dim of Lookup. PF2UM1A.758
& pstar_ls, !(OUT)LS dump P* read into psta PF2UM1A.759
& pp_len_ls(j), !(IN)No. of p points per level. PF2UM1A.760
& fixhd_ls, !(IN)LS Fixed header record. PF2UM1A.761
*CALL ARGPPX PF2UM1A.762
& icode,cmessage) !(IN/OUT)Error flags. PF2UM1A.763
CALL TIMER('READFLDS',4) UDG5F405.272
PF2UM1A.764
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage, PF2UM1A.765
& icode,nftin3) PF2UM1A.766
PF2UM1A.767
! Reorganisation of pstar field. PF2UM1A.768
pos1 = pp_pos_ls(pos) PF2UM1A.769
CALL TIMER('PF_Rever',3) UDG5F405.273
Call PF_Reverse(pstar_ls, !(IN/OUT) Theta on PF theta leve UIE2F404.1262
& lookup_ls(lbnpt,pos1), !(IN)No. of columns. UIE2F404.1263
& pp_num_ls(j), !(IN)No. of theta levels. UIE2F404.1264
& lookup_ls(lbrow,pos1), !(IN) No. of rows PF2UM1A.773
& len_dummy, PF2UM1A.774
& dummy2, PF2UM1A.775
& 0, PF2UM1A.776
& len_dummy, PF2UM1A.777
& len_dummy, PF2UM1A.778
*CALL ARGPPX PF2UM1A.779
& dummy, PF2UM1A.780
& dummy) PF2UM1A.781
CALL TIMER('PF_Rever',4) UDG5F405.274
PF2UM1A.782
PF2UM1A.783
End if PF2UM1A.784
PF2UM1A.785
End do PF2UM1A.786
PF2UM1A.787
PF2UM1A.788
PF2UM1A.789
! 2.3 Read in PF model variables PF2UM1A.790
PF2UM1A.791
! Read in theta' from PF dump. UIE2F404.1265
Call locate(stashcode_OD_thetaL, !(IN)PARAMETER name for STASH PF2UM1A.793
& ! item/section code for theta PF2UM1A.794
& pp_itemc, !(IN)Array of item codes. PF2UM1A.795
& n_types, !(IN)No. of field types. PF2UM1A.796
& pos) !(OUT)Pos. of theta' in pp_item UIE2F404.1266
PF2UM1A.798
If (pos.eq.0) then PF2UM1A.799
PF2UM1A.800
write(6,'('' *ERROR* Theta (PF dump) not in input file'')') UIE2F404.1267
Call abort PF2UM1A.802
PF2UM1A.803
End if PF2UM1A.804
PF2UM1A.805
CALL TIMER('READFLDS',3) UDG5F405.275
Call readflds(nftout, !(IN)Unit number of PF dump. PF2UM1A.806
& p_levels, !(IN)Read theta on all theta lev UIE2F404.1268
& pp_pos(pos), !(IN)Field no. in PF dump. PF2UM1A.808
& lookup, !(IN)Lookup table of PF dump. PF2UM1A.809
& len1_lookup, !(IN)1st dim of Lookup. PF2UM1A.810
& work2, !(OUT)theta' read into work2. UIE2F404.1269
& p_field, !(IN)No. of theta points per level PF2UM1A.812
& fixhd, !(IN)PF Fixed header record. PF2UM1A.813
*CALL ARGPPX PF2UM1A.814
& icode,cmessage) !(IN/OUT)Error flags. PF2UM1A.815
CALL TIMER('READFLDS',4) UDG5F405.276
PF2UM1A.816
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage,icode,nftout) PF2UM1A.817
PF2UM1A.818
! Reorganisation of TH' field. UIE2F404.1270
CALL TIMER('PF_Rever',3) UDG5F405.277
Call PF_Reverse(work2, !(IN/OUT) Theta on PF theta levels UIE2F404.1271
& row_length, !(IN) No. of columns. PF2UM1A.821
& p_levels, !(IN) No. of theta levels. PF2UM1A.822
& p_rows, !(IN) No. of rows. PF2UM1A.823
& len_dummy, PF2UM1A.824
& dummy2, PF2UM1A.825
& 0, PF2UM1A.826
& len_dummy, PF2UM1A.827
& len_dummy, PF2UM1A.828
*CALL ARGPPX PF2UM1A.829
& dummy, PF2UM1A.830
& dummy) PF2UM1A.831
CALL TIMER('PF_Rever',4) UDG5F405.278
PF2UM1A.832
PF2UM1A.833
! Read in q' from PF dump. UIE2F404.1272
Call locate(stashcode_OD_qT, !(IN)PARAMETER name for STASH PF2UM1A.835
& ! item/section code for q'. UIE2F404.1273
& pp_itemc, !(IN)Array of item codes. PF2UM1A.837
& n_types, !(IN)No. of field types. PF2UM1A.838
& pos) !(OUT)Pos. of q' in pp_itemc. UIE2F404.1274
PF2UM1A.840
If (pos.eq.0) then PF2UM1A.841
PF2UM1A.842
write(6,'('' *ERROR* Q (PF dump) not in input file'')') PF2UM1A.843
Call abort PF2UM1A.844
PF2UM1A.845
End if PF2UM1A.846
PF2UM1A.847
CALL TIMER('READFLDS',3) UDG5F405.279
Call readflds(nftout, !(IN)Unit number of PF dump. PF2UM1A.848
& q_levels, !(IN)Read q' on all wet theta lev UIE2F404.1275
& pp_pos(pos), !(IN)Field no. in PF dump. PF2UM1A.850
& lookup, !(IN)Lookup table of PF dump. PF2UM1A.851
& len1_lookup, !(IN)1st dim of Lookup. PF2UM1A.852
& work1, !(OUT) q' read into work1. UIE2F404.1276
& p_field, !(IN)No. of q points per level. UIE2F404.1277
& fixhd, !(IN)PF Fixed header record. PF2UM1A.855
*CALL ARGPPX PF2UM1A.856
& icode,cmessage) !(IN/OUT)Error flags. PF2UM1A.857
CALL TIMER('READFLDS',4) UDG5F405.280
PF2UM1A.858
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage,icode,nftout) PF2UM1A.859
PF2UM1A.860
! Reorganisation of q field. UIE2F404.1278
CALL TIMER('PF_Rever',3) UDG5F405.281
Call PF_Reverse(work1, !(IN/OUT) q on PF theta levels UIE2F404.1279
& row_length, !(IN) No. of columns. PF2UM1A.863
& q_levels, !(IN) No. of theta levels. PF2UM1A.864
& p_rows, !(IN) No. of rows. PF2UM1A.865
& len_dummy, PF2UM1A.866
& dummy2, PF2UM1A.867
& 0, PF2UM1A.868
& len_dummy, PF2UM1A.869
& len_dummy, PF2UM1A.870
*CALL ARGPPX PF2UM1A.871
& dummy, PF2UM1A.872
& dummy) PF2UM1A.873
CALL TIMER('PF_Rever',4) UDG5F405.282
PF2UM1A.874
PF2UM1A.875
! Read in pressure' from PF dump into work4. UIE2F404.1280
Call locate(stashcode_ND_pressure, !(IN)PARAMETER name for STASH PF2UM1A.877
& ! item/section code for press UIE2F404.1281
& pp_itemc, !(IN)Array of item codes. PF2UM1A.879
& n_types, !(IN)No. of field types. PF2UM1A.880
& pos) !(OUT)Pos. of press' in pp_ite PF2UM1A.881
PF2UM1A.882
If (pos.eq.0) then PF2UM1A.883
PF2UM1A.884
write(6,'('' *ERROR* press (PF dump) not in input file'')') PF2UM1A.885
Call abort PF2UM1A.886
PF2UM1A.887
End if PF2UM1A.888
PF2UM1A.889
CALL TIMER('READFLDS',3) UDG5F405.283
Call readflds(nftout, !(IN)Unit number of PF dump. PF2UM1A.890
& p_levels, !(IN)Read press' on al press levs. PF2UM1A.891
& pp_pos(pos), !(IN)Field no. in PF dump. PF2UM1A.892
& lookup, !(IN)Lookup table of PF dump. PF2UM1A.893
& len1_lookup, !(IN)1st dim of Lookup. PF2UM1A.894
& work4, !(OUT) pressure' read into work4. PF2UM1A.895
& p_field, !(IN)No. of p points per level. PF2UM1A.896
& fixhd, !(IN)PF Fixed header record. PF2UM1A.897
*CALL ARGPPX PF2UM1A.898
& icode,cmessage) !(IN/OUT)Error flags. PF2UM1A.899
CALL TIMER('READFLDS',4) UDG5F405.284
PF2UM1A.900
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage,icode,nftout) PF2UM1A.901
PF2UM1A.902
! Reorganisation of pressure field. PF2UM1A.903
Call PF_Reverse(work4, !(IN/OUT) Pressure PF2UM1A.904
& row_length, !(IN) No. of columns. PF2UM1A.905
& p_levels, !(IN) No. of theta levels. PF2UM1A.906
& p_rows, !(IN) No. of rows. PF2UM1A.907
& len_dummy, PF2UM1A.908
& dummy2, PF2UM1A.909
& 0, PF2UM1A.910
& len_dummy, PF2UM1A.911
& len_dummy, PF2UM1A.912
*CALL ARGPPX PF2UM1A.913
& dummy, PF2UM1A.914
& dummy) PF2UM1A.915
PF2UM1A.916
! 2.2 Call to QSAT_VARS enables the calculation of the term PF2UM1A.917
! dln(es)/dT (pfield5) and RH (pfield3) by a call to a modified PF2UM1A.918
! version of QSAT. PF2UM1A.919
PF2UM1A.920
Do k=1,q_levels PF2UM1A.921
pos=(k-1)*p_field PF2UM1A.922
PF2UM1A.923
CALL TIMER('QSAT_VAR',3) UDG5F405.285
Call QSAT_VARS(fixhd_ls, !(IN) Fixed header record of LS dum PF2UM1A.924
& len_fixhd, !(IN) Size of Fixed header rec. PF2UM1A.925
& pstar_ls, !(IN) LS dump P* PF2UM1A.926
& levdepc, !(IN) Level dep. consts.(ak's, bk's PF2UM1A.927
& len1_levdepc, !(IN) 1st dim. of level dep. consts PF2UM1A.928
& len2_levdepc, !(IN) 2nd dim. of level dep. consts PF2UM1A.929
& p_levels, !(IN) No. of pressure levels. PF2UM1A.930
& q_levels, !(IN) No. of wet levels. PF2UM1A.931
& p_field, !(IN) No. of p points. PF2UM1A.932
& k, !(IN) Level PF2UM1A.933
& work3(pos+1), !(IN)Theta on PF theta levels in. PF2UM1A.934
& work5(pos+1), !(IN)q on PF wet theta levels in. PF2UM1A.935
& pfield3, !(OUT)RH on PF wet theta levels. PF2UM1A.936
& pfield5) !(OUT)d ln(es)/d T where es sat. PF2UM1A.937
& ! vapour pressure. PF2UM1A.938
CALL TIMER('QSAT_VAR',4) UDG5F405.286
CALL TIMER('Pfinc2UM',3) UDG5F405.287
PF2UM1A.939
PF2UM1A.940
!2.4 Calculation of the term T'd(lnes)/dT. As d(lnes)/dT is known UIE2F404.1282
! the calculation involves mainly the conversion of theta' -> T'. PF2UM1A.942
! The conversion is done over individual levels enabling PF2UM1A.943
! workspace dimensioned only by the number of p points PF2UM1A.944
! in a single level to be used. PF2UM1A.945
PF2UM1A.946
PF2UM1A.947
! Pressure on theta levels on PF vertical grid read into PF2UM1A.948
! pfield2 for each wet level. PF2UM1A.949
pos = p_field*(k-1) PF2UM1A.950
pos1 = p_field*k PF2UM1A.951
PF2UM1A.952
*IF DEF,VECTLIB PXVECTLB.116
! Exner pressure on current pressure level of LS dump read UDG5F405.289
! into pexner1 using pressure press1. UDG5F405.290
! Exner pressure at pressure level just above theta level UDG5F405.291
! of interest on LS dump (pexner2) found from pressure press2. UDG5F405.292
Do i=1,p_field UDG5F405.293
UDG5F405.294
press1 = levdepc(k)+ levdepc(k+p_levels) * pstar_ls(i) UDG5F405.295
a_press1(i)=press1 UDG5F405.296
a_pexner1(i) = (press1 / pref) UDG5F405.297
UDG5F405.298
press2 = levdepc(k+1) + levdepc(k+1+p_levels) * pstar_ls(i) UDG5F405.299
a_press2(i)=press2 UDG5F405.300
a_pexner2(i) = (press2 / pref) UDG5F405.301
UDG5F405.302
enddo UDG5F405.303
UDG5F405.304
call powr_v(p_field,a_pexner1,kappa,a_pexner1_kappa) UDG5F405.305
call powr_v(p_field,a_pexner2,kappa,a_pexner2_kappa) UDG5F405.306
UDG5F405.307
Do i=1,p_field UDG5F405.308
pfield2(i) = (a_pexner2_kappa(i) - a_pexner1_kappa(i)) UDG5F405.309
& /( (a_pexner2(i) - a_pexner1(i)) * kappa ) UDG5F405.310
enddo UDG5F405.311
UDG5F405.312
call powr_v(p_field,pfield2,kappa/(kappa-1),pfield4) UDG5F405.313
call powr_v(p_field,pfield2,1/(kappa-1),pfield2) UDG5F405.314
UDG5F405.315
Do i=1,p_field UDG5F405.316
UDG5F405.317
pfield2(i) = pfield2(i) * pref UDG5F405.318
UDG5F405.319
pexner1=a_pexner1_kappa(i) UDG5F405.320
pexner2=a_pexner2_kappa(i) UDG5F405.321
UDG5F405.322
pf_pexner1 = kappa * pexner1 * work4(i+pos) / a_press1(i) UDG5F405.323
pf_pexner2 = kappa * pexner2 * work4(i+pos1) / a_press2(i) UDG5F405.324
UDG5F405.325
press1=a_press1(i) UDG5F405.326
press2=a_press2(i) UDG5F405.327
UDG5F405.328
pfield1(i) = ( UDG5F405.329
& ( (pf_pexner2 - pf_pexner1) UDG5F405.330
& / (pexner2 - pexner1) ) UDG5F405.331
& - ( (work4(i+pos1) - work4(i+pos)) UDG5F405.332
& / (press2 - press1) ) UDG5F405.333
& ) * (pfield2(i) / (kappa-1)) UDG5F405.334
UDG5F405.335
pfield5(i) = pfield5(i) * ( work2(i+pos) * pfield4(i) + UDG5F405.336
& kappa * pfield4(i) * work3(i+pos) UDG5F405.337
& * pfield1(i) / pfield2(i) ) UDG5F405.338
UDG5F405.339
If (k.eq.1) then UDG5F405.340
pfield6(i) = ( work2(i+pos) * pfield4(i) + UDG5F405.341
& kappa * pfield4(i) * work3(i+pos) UDG5F405.342
& * pfield1(i) / pfield2(i) ) UDG5F405.343
End if UDG5F405.344
End do ! i UDG5F405.345
*ELSE UDG5F405.346
Do i=1,p_field PF2UM1A.953
PF2UM1A.954
! Exner pressure on current pressure level of LS dump read PF2UM1A.955
! into pexner1 using pressure press1. PF2UM1A.956
press1 = levdepc(k)+ PF2UM1A.957
& levdepc(k+p_levels) * pstar_ls(i) PF2UM1A.958
pexner1 = (press1 / pref)**kappa PF2UM1A.959
PF2UM1A.960
! Exner pressure on current pressure level of PF dump read PF2UM1A.961
! into pf_pexner1 using PF pressure (work4), LS pressure and PF2UM1A.962
! exner pressure. PF2UM1A.963
pf_pexner1 = kappa * pexner1 * work4(i+pos) / press1 PF2UM1A.964
PF2UM1A.965
! Exner pressure at pressure level just above theta level PF2UM1A.966
! of interest on LS dump (pexner2) found from pressure press2. PF2UM1A.967
press2 = levdepc(k+1) + levdepc(k+1+p_levels) * pstar_ls(i) PF2UM1A.968
pexner2 = (press2 / pref)**kappa PF2UM1A.969
PF2UM1A.970
! Exner pressure at pressure level just above theta level PF2UM1A.971
! of interest on PF dump (pf_pexner2) found from PF PF2UM1A.972
! pressure (work4), LS pressure and exner pressure on the PF2UM1A.973
! same pressure level. PF2UM1A.974
pf_pexner2 = kappa * pexner2 * work4(i+pos1) / press2 PF2UM1A.975
PF2UM1A.976
! LS pressure on theta level found from equation ?? - PF2UM1A.977
! documentation paper 154. PF2UM1A.978
pfield2(i) = ( (pexner2 - pexner1) PF2UM1A.979
& /( (pexner2**(1/kappa) PF2UM1A.980
& - pexner1**(1/kappa)) * kappa ) PF2UM1A.981
& )**(1/(kappa-1) PF2UM1A.982
& )*pref PF2UM1A.983
PF2UM1A.984
! Exner pressures on theta levels of LS dump PF2UM1A.985
pfield4(i) = (pfield2(i) / pref)**kappa PF2UM1A.986
PF2UM1A.987
! Pressures on theta levels of PF dump written to pfield1. PF2UM1A.988
pfield1(i) = ( PF2UM1A.989
& ( (pf_pexner2 - pf_pexner1) PF2UM1A.990
& / (pexner2 - pexner1) ) PF2UM1A.991
& - ( (work4(i+pos1) - work4(i+pos)) PF2UM1A.992
& / (press2 - press1) ) PF2UM1A.993
& ) * (pfield2(i) / (kappa-1)) PF2UM1A.994
PF2UM1A.995
! The term T`*d(lnes)/dT on theta levels on PF vertical grid PF2UM1A.996
! is read into pfield5. (d(lnes)/dT (pfield5) * PF temp on the PF2UM1A.997
! level). PF2UM1A.998
pfield5(i) = pfield5(i) * ( work2(i+pos) * pfield4(i) + PF2UM1A.999
& kappa * pfield4(i) * work3(i+pos) PF2UM1A.1000
& * pfield1(i) / pfield2(i) ) PF2UM1A.1001
PF2UM1A.1002
! Store T' (pfield6) at PF level 1 to be written out in UIE2F404.229
& ! section 2.7 to bottom full level on UM dump. UIE2F404.230
If (k.eq.1) then UIE2F404.231
pfield6(i) = ( work2(i+pos) * pfield4(i) + UIE2F404.232
& kappa * pfield4(i) * work3(i+pos) UIE2F404.233
& * pfield1(i) / pfield2(i) ) UIE2F404.234
End if UIE2F404.235
End do ! i PF2UM1A.1003
*ENDIF UDG5F405.347
PF2UM1A.1004
! 2.5 PF Relative humidity on theta levels of PF dump (read PF2UM1A.1005
! into work1) found from LS variables RH (pfield3), q (work5), PF2UM1A.1006
! PF variable q` (work1) and the term T`*d(lnes)/dT (pfield5). PF2UM1A.1007
PF2UM1A.1008
pos = p_field*(k-1) PF2UM1A.1009
PF2UM1A.1010
Do i=1,p_field PF2UM1A.1011
PF2UM1A.1012
If (ABS(work5(i+pos)).gt.1.0E-15) then PF2UM1A.1013
PF2UM1A.1014
! non zero q values PF2UM1A.1015
work1(i+pos) = pfield3(i) PF2UM1A.1016
& * ( (work1(i+pos) / work5(i+pos) ) PF2UM1A.1017
& - pfield5(i)) PF2UM1A.1018
else PF2UM1A.1019
! Assume RH' = 0 when q=0. PF2UM1A.1020
work1(i+pos) = 0.0 PF2UM1A.1021
PF2UM1A.1022
End if PF2UM1A.1023
PF2UM1A.1024
End do PF2UM1A.1025
CALL TIMER('Pfinc2UM',4) UDG5F405.348
PF2UM1A.1026
End do PF2UM1A.1027
PF2UM1A.1028
PF2UM1A.1029
PF2UM1A.1030
! 2.6 Linear interpolation in height from RH on theta levels PF2UM1A.1031
! ,PF vertical grid to RH on full levels, UM model grid. PF2UM1A.1032
UIE2F404.236
! If requested level is below bottom of model, vert_interp UIE2F404.237
! linearly extrapolates the data on the first and second UIE2F404.238
! levels. Therefore storing first level theta' in pfield1 UIE2F404.239
! will enable us to later replace the extrapolated theta UIE2F404.240
! field on UM press level 1 with UIE2F404.241
! the theta' field on PF theta level 1. UIE2F404.242
Do i=1,p_field UIE2F404.243
pfield1(i) = work2(i) UIE2F404.244
End do UIE2F404.245
UIE2F404.246
Do k=1,p_levels ! Loop over pressure levels PF2UM1A.1033
PF2UM1A.1034
pos = (k-1) * p_field PF2UM1A.1035
pos1 = (p_levels+1) * p_field + (k * p_field) UDG6F405.105
PF2UM1A.1037
! Vertically interpolate PF theta' (work2) onto UM grid. PF2UM1A.1038
! Read into work5. UDG6F405.106
PF2UM1A.1040
CALL TIMER('vert_int',3) UDG5F405.349
Call vert_interp(work2, !(IN) theta' on PF theta lev PF2UM1A.1041
& p_field, !(IN) No. of theta points pe PF2UM1A.1042
& p_levels, !(IN) No. of theta levs. PF2UM1A.1043
& heights(pos1+1), !(IN) Heights of UM full lev UDG6F405.107
& heights(p_field+1),!(IN) Heights of theta level UDG6F405.108
& Linear, !(IN) Linear interpolation PF2UM1A.1046
& work5(pos+1)) !(OUT) theta' on full UM lev PF2UM1A.1047
CALL TIMER('vert_int',4) UDG5F405.350
PF2UM1A.1048
End do ! k PF2UM1A.1049
PF2UM1A.1050
Do k=1,p_levels ! Loop over pressure levels PF2UM1A.1051
PF2UM1A.1052
pos = (k-1) * p_field PF2UM1A.1053
pos1 = (p_levels+1)*p_field + (k * p_field) UDG6F405.109
PF2UM1A.1055
If (k.le.q_levels) then PF2UM1A.1056
PF2UM1A.1057
! Interpolate PF RH' (work1) in vertical PF2UM1A.1058
! onto UM grid. Read into work2. UIE2F404.1284
PF2UM1A.1060
CALL TIMER('vert_int',3) UDG5F405.351
Call vert_interp(work1, !(IN) RH' on wet PF theta le PF2UM1A.1061
& p_field, !(IN) No. of p points per le PF2UM1A.1062
& q_levels, !(IN) No. of wet levels. PF2UM1A.1063
& heights(pos1+1), !(IN) Heights of UM full lev UDG6F405.110
& heights(p_field+1),!(IN) Heights of theta lev UDG6F405.111
UDG6F405.112
UDG6F405.113
& Linear, !(IN) Linear interpolation PF2UM1A.1066
& work2(pos+1)) !(OUT) RH' on full UM levels PF2UM1A.1067
CALL TIMER('vert_int',4) UDG5F405.352
End if PF2UM1A.1068
PF2UM1A.1069
End do ! k PF2UM1A.1070
PF2UM1A.1071
UIE2F404.247
! Replace the extrapolated theta field on UM press level 1 with UIE2F404.248
! the theta' field on PF theta level 1. UIE2F404.249
Do i=1,p_field UIE2F404.250
work5(i) = pfield1(i) UIE2F404.251
End do UIE2F404.252
! Replace the extrapolated theta field on UM top pressure level UDG5F405.353
! with zeros UDG5F405.354
Do i=1,p_field UIE2F404.255
work5(i+ (p_levels-1)*p_field) = 0.0 UDG5F405.355
End do UIE2F404.257
UIE2F404.258
! 2.7 Write out T' at UM press level 1 to TSTAR field or to UIE2F404.259
! top deep soil T field if MOSES dump. UIE2F404.260
UIE2F404.261
Call locate(stashcode_OD_mask,!IN PARAMETER name for STASH UIE2F404.262
& !item/sect code for land/sea mask UIE2F404.263
& pp_itemc_um, !IN Array of item codes. UIE2F404.264
& n_types_um, !IN No. of field types. UIE2F404.265
& pos) !OUT Pos. of thetaL in pp_itemc UIE2F404.266
UIE2F404.267
If (pos.eq.0) then UIE2F404.268
UIE2F404.269
write(6,'('' *ERROR* Land/sea mask (PF dump) not in file'')') UIE2F404.270
Call abort UIE2F404.271
UIE2F404.272
End if UIE2F404.273
UIE2F404.274
CALL TIMER('READFLDS',3) UDG5F405.356
Call readflds(nftin2, !(IN)Unit number of PF/output UM du UIE2F404.275
& 1, !(IN)Read land sea mask UIE2F404.276
& pp_pos_um(pos), !(IN)Field no. in PF/output UM dump UIE2F404.277
& lookup_um, !(IN)Lookup table of PF/output UM d UIE2F404.278
& len1_lookup_um, !(IN)1st dim of Lookup. UIE2F404.279
& lsmask, !(IN)Read mask into lsmask UIE2F404.280
& p_field, !(IN)No. of p points per level. UIE2F404.281
& fixhd_um, !(IN)PF Fixed header record. UIE2F404.282
*CALL ARGPPX UIE2F404.283
& icode,cmessage) !(IN/OUT)Error flags. UIE2F404.284
CALL TIMER('READFLDS',4) UDG5F405.357
UIE2F404.285
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage, UIE2F404.286
& icode,nftin2) UIE2F404.287
UIE2F404.288
! Multiply T* or surface soil temp increments over land/sea UIE2F404.289
! for LAM and Global cases separately. UIE2F404.290
Do i=1,p_field UIE2F404.291
If ((fixhd(4).eq.0).and.(lsmask(i))) then UIE2F404.292
pfield6(i) = pfield6(i) * gl_land_wgt UIE2F404.293
Else if ((fixhd(4).eq.0).and..not.(lsmask(i))) then UIE2F404.294
pfield6(i) = pfield6(i) * gl_sea_wgt UIE2F404.295
Else if ((fixhd(4).eq.103).and.(lsmask(i))) then UIE2F404.296
pfield6(i) = pfield6(i) * la_land_wgt UIE2F404.297
Else if ((fixhd(4).eq.103).and..not.(lsmask(i))) then UIE2F404.298
pfield6(i) = pfield6(i) * la_sea_wgt UIE2F404.299
End if UIE2F404.300
End do UIE2F404.301
! UIE2F404.302
UIE2F404.303
If (lmoses) then ! Write temp increment to level 1 deep soil T UIE2F404.304
UIE2F404.305
Call To_Land_Points(pfield6, ! IN PF T' (model grid) UIE2F404.306
& pfield5, ! OUT T' (compressed land points) UIE2F404.307
& lsmask, ! IN Land-sea mask UIE2F404.308
& p_field, ! IN No. of grid points UIE2F404.309
& land_points) ! IN No. of land points UIE2F404.310
UIE2F404.311
Call locate(stashcode_OD_soilT, !IN PARAMETER name for STASH UIE2F404.312
& !item/section code for deep soil T UIE2F404.313
& pp_itemc, !IN Array of item codes. UIE2F404.314
& n_types, !IN No. of field types. UIE2F404.315
& pos) !OUT Pos. of thetaL in pp_itemc UIE2F404.316
UIE2F404.317
CALL TIMER('WRITFLDS',3) UDG5F405.358
Call writflds(nftout, !IN Unit number of PF/output UM du UIE2F404.318
& 1, !IN Write T' on lev 1 of deep soil T UIE2F404.319
& pp_pos(pos), !IN Field no. in PF/output UM dump UIE2F404.320
& lookup, !IN Lookup table of PF/output UM d UIE2F404.321
& len1_lookup, !IN 1st dim of Lookup. UIE2F404.322
& pfield5, !IN T' written from pfield5. UIE2F404.323
& p_field, !IN No. of p points per level. UIE2F404.324
& fixhd, !IN PF Fixed header record. UIE2F404.325
*CALL ARGPPX UIE2F404.326
& icode,cmessage) !(IN/OUT)Error flags. UIE2F404.327
CALL TIMER('WRITFLDS',4) UDG5F405.359
UIE2F404.328
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage,icode,nftout) UIE2F404.329
UIE2F404.330
Else ! Write Temperature increment to T* UIE2F404.331
UIE2F404.332
Call locate(stashcode_OD_tstar, !(IN)PARAMETER name for STASH UIE2F404.333
& ! item/section code for theta UIE2F404.334
& pp_itemc, !(IN)Array of item codes. UIE2F404.335
& n_types, !(IN)No. of field types. UIE2F404.336
& pos) !(OUT)Pos. of thetaL in pp_itemc UIE2F404.337
UIE2F404.338
CALL TIMER('WRITFLDS',3) UDG5F405.360
Call writflds(nftout, !(IN)Unit number of PF/output UM du UIE2F404.339
& 1, !(IN)Write T' on UM surface level. UIE2F404.340
& pp_pos(pos), !(IN)Field no. in PF/output UM dump UIE2F404.341
& lookup, !(IN)Lookup table of PF/output UM d UIE2F404.342
& len1_lookup, !(IN)1st dim of Lookup. UIE2F404.343
& pfield6, !(IN)T' written from pfield6. UIE2F404.344
& p_field, !(IN)No. of p points per level. UIE2F404.345
& fixhd, !(IN)PF Fixed header record. UIE2F404.346
*CALL ARGPPX UIE2F404.347
& icode,cmessage) !(IN/OUT)Error flags. UIE2F404.348
CALL TIMER('WRITFLDS',4) UDG5F405.361
UIE2F404.349
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage,icode,nftout) UIE2F404.350
UIE2F404.351
End if UIE2F404.352
!------------------------------------------------------------------- PF2UM1A.1072
! 3.0 Recalculate q' on the UM grid. PF2UM1A.1073
!------------------------------------------------------------------- PF2UM1A.1074
PF2UM1A.1075
! 3.1 Read in first UM variables PF2UM1A.1076
PF2UM1A.1077
! Returns each field code and associated field length in the PF2UM1A.1078
! UM dump and a count of the number of fields of each type. PF2UM1A.1079
f_type_title='UM data' UIE2F404.49
Call f_type(lookup_um, !(IN) Lookup tables of UM dump. PF2UM1A.1081
& len2_lookup_um, !(IN) 2nd dim. of UM lookup table. PF2UM1A.1082
& pp_num_um, !(OUT)No of fields for each field t PF2UM1A.1083
& n_types_um, !(OUT)No of field types in UM dump. PF2UM1A.1084
& pp_len_um, !(OUT)Length of field. PF2UM1A.1085
& pp_itemc_um, !(OUT)Item code of field type. PF2UM1A.1086
& pp_type_um, !(OUT)Integer/real/timeseries PF2UM1A.1087
& pp_pos_um, !(OUT)Pointer to number of field. PF2UM1A.1088
& pp_lsm_um, !(OUT)Data stored on land or sea pt PF2UM1A.1089
& fixhd_um, PF2UM1A.1090
*CALL ARGPPX PF2UM1A.1091
& f_type_title) PF2UM1A.1092
PF2UM1A.1093
! Read THL into array work3 PF2UM1A.1094
Do j=1,n_types_um ! loop over variables in NAMELIST PF2UM1A.1095
PF2UM1A.1096
If (pp_itemc_um(j).eq.stashcode_OD_thetaL) then PF2UM1A.1097
PF2UM1A.1098
Call locate(pp_itemc_um(j), !(IN)PARAMETER name for STASH PF2UM1A.1099
& ! item/section code for thetaL. PF2UM1A.1100
& pp_itemc_um, !(IN)Array of item codes. PF2UM1A.1101
& n_types_um, !(IN)No. of field types. PF2UM1A.1102
& pos) !(OUT)Pos. of thetaL in pp_itemc. PF2UM1A.1103
PF2UM1A.1104
If (pos.eq.0) then PF2UM1A.1105
PF2UM1A.1106
write(6,'('' *ERROR* ThetaL (UM dump) not in input file'')') PF2UM1A.1107
Call abort PF2UM1A.1108
PF2UM1A.1109
End if PF2UM1A.1110
PF2UM1A.1111
CALL TIMER('READFLDS',3) UDG5F405.362
Call readflds(nftin2, !(IN)Unit number of UM dump. PF2UM1A.1112
& pp_num_um(j), !(IN)Read theta on all press le PF2UM1A.1113
& pp_pos_um(pos), !(IN)Field no. in UM dump. PF2UM1A.1114
& lookup_um, !(IN)Lookup table of UM dump. PF2UM1A.1115
& len1_lookup_um, !(IN)1st dim of Lookup. PF2UM1A.1116
& work3, !(OUT)ThetaL read into work3. UIE2F404.1285
& pp_len_um(j), !(IN)No. of p points per level. PF2UM1A.1118
& fixhd_um, !(IN)UM Fixed header record. PF2UM1A.1119
*CALL ARGPPX PF2UM1A.1120
& icode,cmessage) !(IN/OUT)Error flags. PF2UM1A.1121
CALL TIMER('READFLDS',4) UDG5F405.363
PF2UM1A.1122
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage, PF2UM1A.1123
& icode,nftin2) PF2UM1A.1124
PF2UM1A.1125
Else if (pp_itemc_um(j).eq.stashcode_OD_qT) then PF2UM1A.1126
PF2UM1A.1127
! Read QT into array work1 PF2UM1A.1128
Call locate(pp_itemc_um(j), !(IN)PARAMETER name for STASH PF2UM1A.1129
& ! item/section code for qT. PF2UM1A.1130
& pp_itemc_um, !(IN)Array of item codes. PF2UM1A.1131
& n_types_um, !(IN)No. of field types in input U PF2UM1A.1132
& pos) !(OUT)Pos. of qT in pp_itemc_um. PF2UM1A.1133
PF2UM1A.1134
If (pos.eq.0) then PF2UM1A.1135
PF2UM1A.1136
write(6,'('' *ERROR* qT (UM dump) not in input file'')') PF2UM1A.1137
Call abort PF2UM1A.1138
PF2UM1A.1139
End if PF2UM1A.1140
PF2UM1A.1141
CALL TIMER('READFLDS',3) UDG5F405.364
Call readflds(nftin2, !(IN)Unit number of UM dump. PF2UM1A.1142
& pp_num_um(j), !(IN)Read qT on all press levs. PF2UM1A.1143
& pp_pos_um(pos), !(IN)Field no. in UM dump. PF2UM1A.1144
& lookup_um, !(IN)Lookup table of UM dump. PF2UM1A.1145
& len1_lookup_um, !(IN)1st dim of Lookup. PF2UM1A.1146
& work1, !(OUT)qT read into work1. PF2UM1A.1147
& pp_len_um(j), !(IN)No. of p points per level. PF2UM1A.1148
& fixhd_um, !(IN)UM Fixed header record. PF2UM1A.1149
*CALL ARGPPX PF2UM1A.1150
& icode,cmessage) !(IN/OUT)Error flags. PF2UM1A.1151
CALL TIMER('READFLDS',4) UDG5F405.365
PF2UM1A.1152
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage, PF2UM1A.1153
& icode,nftin2) PF2UM1A.1154
PF2UM1A.1155
Else if (pp_itemc_um(j).eq.stashcode_OD_pstar) then PF2UM1A.1156
PF2UM1A.1157
Call locate(pp_itemc_um(j), !(IN)PARAMETER name for STASH PF2UM1A.1158
& ! item/section code for P*. PF2UM1A.1159
& pp_itemc_um, !(IN)Array of item codes. PF2UM1A.1160
& n_types_um, !(IN)No. of field types in input U PF2UM1A.1161
& pos) !(OUT)Pos. of P* in pp_itemc_um. PF2UM1A.1162
PF2UM1A.1163
If (pos.eq.0) then PF2UM1A.1164
PF2UM1A.1165
write(6,'('' *ERROR* P* (LS dump) not in input file'')') PF2UM1A.1166
Call abort PF2UM1A.1167
PF2UM1A.1168
End if PF2UM1A.1169
PF2UM1A.1170
CALL TIMER('READFLDS',3) UDG5F405.366
Call readflds(nftin2, !(IN)Unit number of UM dump. PF2UM1A.1171
& pp_num_um(j), !(IN)Read P* on single level. PF2UM1A.1172
& pp_pos_um(pos), !(IN)Field no. in UM dump. PF2UM1A.1173
& lookup_um, !(IN)Lookup table of UM dump. PF2UM1A.1174
& len1_lookup_um, !(IN)1st dim of Lookup. PF2UM1A.1175
& pstar_um, !(OUT)P* read into pstar_um. PF2UM1A.1176
& pp_len_um(j), !(IN)No. of p points per level. PF2UM1A.1177
& fixhd_um, !(IN)UM Fixed header record. PF2UM1A.1178
*CALL ARGPPX PF2UM1A.1179
& icode,cmessage) !(IN/OUT)Error flags. PF2UM1A.1180
CALL TIMER('READFLDS',4) UDG5F405.367
PF2UM1A.1181
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage, PF2UM1A.1182
& icode,nftin2) PF2UM1A.1183
PF2UM1A.1184
End if PF2UM1A.1185
PF2UM1A.1186
End do ! j PF2UM1A.1187
PF2UM1A.1188
! Call to cloud scheme 1A enables the conversion of qT -> q UIE2F404.1286
! (work1) and THL -> TH (work3). UIE2F404.1287
UIE2F404.1288
do k =1,q_levels UIE2F404.1289
pos = (k-1) * p_field UIE2F404.1290
UIE2F404.1291
CALL TIMER('pf_ls_cl',3) UDG5F405.368
Call pf_ls_cld(levdepc(k), ! (IN) Full level ak's. UIE2F404.1292
& levdepc(p_levels+k),! (IN) Full level bk's. UIE2F404.1293
& levdepc(k+1), UIE2F404.1294
& levdepc(p_levels+k+1),! (IN) bk's UIE2F404.1295
& pstar_um, ! (IN) P* UIE2F404.1296
& rhcrit(k), ! (IN) Critical relative UIE2F404.1297
& ! humidity from namelist. UIE2F404.1298
& p_field, ! (IN) No. of p points per lev. UIE2F404.1299
& p_field, ! (IN) No. of p points per lev. UIE2F404.1300
& work3(pos+1), ! (IN/OUT) THL -> TH UIE2F404.1301
& work1(pos+1), ! (IN/OUT) qT -> q UIE2F404.1302
& pfield1, ! (OUT) qc (not used) UIE2F404.1303
& hybrid, ! Dump type UIE2F404.1304
& icode) ! (IN/OUT) Error flag. UIE2F404.1305
CALL TIMER('pf_ls_cl',4) UDG5F405.369
UIE2F404.1306
end do UIE2F404.1307
UIE2F404.1308
! 3.2 Call to QSAT_VARS calculates the term dln(es)/dT (pfield4) UIE2F404.1309
! using a modified version of QSAT. PF2UM1A.1190
Do k=1,q_levels PF2UM1A.1191
pos=(k-1)*p_field PF2UM1A.1192
PF2UM1A.1193
CALL TIMER('QSAT_VAR',3) UDG5F405.370
Call QSAT_VARS(fixhd_um, !(IN) Fixed header record of UM du PF2UM1A.1194
& len_fixhd, !(IN) Size of Fixed header rec. PF2UM1A.1195
& pstar_um, !(IN) UM dump P*. PF2UM1A.1196
& levdepc, !(IN) Level dep. consts.(ak's, bk's PF2UM1A.1197
& len1_levdepc, !(IN) 1st dim. of level dep. consts PF2UM1A.1198
& len2_levdepc, !(IN) 2nd dim. of level dep. consts PF2UM1A.1199
& p_levels, !(IN) No. of pressure levels. PF2UM1A.1200
& q_levels, !(IN) No. of wet levels. PF2UM1A.1201
& p_field, !(IN) No. of p points. PF2UM1A.1202
& k, !(IN) Level PF2UM1A.1203
& work3(pos+1), !(IN) Theta on press levs in. PF2UM1A.1204
& work1(pos+1), !(IN) q on wet press levs in. PF2UM1A.1205
& pfield3, !(OUT)RH on PF wet press levels. PF2UM1A.1206
& pfield4) !(OUT)d ln(es)/d T PF2UM1A.1207
CALL TIMER('QSAT_VAR',4) UDG5F405.371
PF2UM1A.1208
! 3.3 Calculation of the term T'd(lnes)/dT on UM grid. PF2UM1A.1209
PF2UM1A.1210
CALL TIMER('Pfinc2UM',3) UDG5F405.372
*IF DEF,VECTLIB PXVECTLB.117
Do i=1,p_field UDG5F405.374
UDG5F405.375
! Pressure field (press1) and exner pressure (pfield2) on UDG5F405.376
! pressure levels of the UM grid. UDG5F405.377
press1 = levdepc(k) + levdepc(k+p_levels) UDG5F405.378
& * pstar_um(i) UDG5F405.379
a_press1(i)=press1 UDG5F405.380
! Exner press on pressure levels of the UM grid. UDG5F405.381
pfield2(i) = (press1 / pref) UDG5F405.382
End do UDG5F405.383
UDG5F405.384
call powr_v(p_field,pfield2,kappa,pfield2) UDG5F405.385
UDG5F405.386
! T'*d(lnes)/dT on full levels on UM grid is read into pfield4 UDG5F405.387
! work5 holds theta' interpolated onto the UM grid and UDG5F405.388
! work4 contains the PF pressure field on UM pressure levels. UDG5F405.389
! work3 holds the background UM theta field. UDG5F405.390
Do i=1,p_field UDG5F405.391
press1=a_press1(i) UDG5F405.392
pfield4(i) = pfield2(i) UDG5F405.393
& * ( work5(i+pos) UDG5F405.394
& + (kappa * work3(i+pos)) UDG5F405.395
& * (work4(i+pos) / press1) UDG5F405.396
& ) * pfield4(i) UDG5F405.397
UDG5F405.398
End do ! i UDG5F405.399
*ELSE UDG5F405.400
Do i=1,p_field PF2UM1A.1211
PF2UM1A.1212
! Pressure field (press1) and exner pressure (pfield2) on PF2UM1A.1213
! pressure levels of the UM grid. PF2UM1A.1214
press1 = levdepc(k) + levdepc(k+p_levels) PF2UM1A.1215
& * pstar_um(i) PF2UM1A.1216
! Exner press on pressure levels of the UM grid. UIE2F404.1310
pfield2(i) = (press1 / pref)**kappa PF2UM1A.1217
PF2UM1A.1218
! T'*d(lnes)/dT on full levels on UM grid is read into pfield4 UIE2F404.1311
! work5 holds theta' interpolated onto the UM grid and PF2UM1A.1220
! work4 contains the PF pressure field on UM pressure levels. PF2UM1A.1221
! work3 holds the background UM theta field. PF2UM1A.1222
pfield4(i) = pfield2(i) PF2UM1A.1223
& * ( work5(i+pos) PF2UM1A.1224
& + (kappa * work3(i+pos)) PF2UM1A.1225
& * (work4(i+pos) / press1) PF2UM1A.1226
& ) * pfield4(i) PF2UM1A.1227
PF2UM1A.1228
End do ! i PF2UM1A.1229
*ENDIF UDG5F405.401
PF2UM1A.1230
! 3.4 Restore increment in specific humidity on full levels UIE2F404.1312
! of background UM dump using background UM dump variables UIE2F404.1313
! q (work1), RH (pfield3), PF variable RH' (work2) and the term PF2UM1A.1233
! T'*d(lnes)/dT (pfield4). Read into work3 UIE2F404.1314
PF2UM1A.1235
Do i=1,p_field PF2UM1A.1236
PF2UM1A.1237
If (pfield3(i).ne.0) then PF2UM1A.1238
PF2UM1A.1239
! Non zero RH values. PF2UM1A.1240
work3(i+pos) = ( PF2UM1A.1241
& (work2(i+pos) / pfield3(i) ) PF2UM1A.1242
& + pfield4(i) PF2UM1A.1243
& ) * work1(i+pos) PF2UM1A.1244
PF2UM1A.1245
else PF2UM1A.1246
PF2UM1A.1247
! Assume q=0 when RH=0. PF2UM1A.1248
work3(i+pos) = 0.0 PF2UM1A.1249
PF2UM1A.1250
End if PF2UM1A.1251
PF2UM1A.1252
End do ! i PF2UM1A.1253
CALL TIMER('Pfinc2UM',4) UDG5F405.402
PF2UM1A.1254
End do ! k PF2UM1A.1255
PF2UM1A.1256
! 3.4 Write out TH from array work5. UIE2F404.1315
Call locate(stashcode_OD_thetaL, !(IN)PARAMETER name for STASH PF2UM1A.1258
& ! item/section code for theta PF2UM1A.1259
& pp_itemc, !(IN)Array of item codes. PF2UM1A.1260
& n_types, !(IN)No. of field types. PF2UM1A.1261
& pos) !(OUT)Pos. of thetaL in pp_itemc PF2UM1A.1262
PF2UM1A.1263
CALL TIMER('WRITFLDS',3) UDG5F405.403
Call writflds(nftout, !(IN)Unit number of PF/output UM du PF2UM1A.1264
& p_levels, !(IN)Write theta' on all press lev UIE2F404.1316
& pp_pos(pos), !(IN)Field no. in PF/output UM dump PF2UM1A.1266
& lookup, !(IN)Lookup table of PF/output UM d PF2UM1A.1267
& len1_lookup, !(IN)1st dim of Lookup. PF2UM1A.1268
& work5, !(IN)theta' written from work6. UIE2F404.1317
& p_field, !(IN)No. of p points per level. PF2UM1A.1270
& fixhd, !(IN)PF Fixed header record. PF2UM1A.1271
*CALL ARGPPX PF2UM1A.1272
& icode,cmessage) !(IN/OUT)Error flags. PF2UM1A.1273
CALL TIMER('WRITFLDS',4) UDG5F405.404
PF2UM1A.1274
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage,icode,nftout) PF2UM1A.1275
PF2UM1A.1276
! Write out q from array work2. UIE2F404.1318
Call locate(stashcode_OD_qT, !(IN)PARAMETER name for STASH PF2UM1A.1278
& ! item/section code for qT. PF2UM1A.1279
& pp_itemc, !(IN)Array of item codes. PF2UM1A.1280
& n_types, !(IN)No. of field types. PF2UM1A.1281
& pos) !(OUT)Pos. of q in pp_itemc. UIE2F404.1319
PF2UM1A.1283
CALL TIMER('WRITFLDS',3) UDG5F405.405
Call writflds(nftout, !(IN)Unit number of PF/output UM du PF2UM1A.1284
& q_levels, !(IN)Write q' on all wet press lev UIE2F404.1320
& pp_pos(pos), !(IN)Field no. in PF/output UM dump PF2UM1A.1286
& lookup, !(IN)Lookup table of PF/output UM d PF2UM1A.1287
& len1_lookup, !(IN)1st dim of Lookup. PF2UM1A.1288
& work3, !(IN)q' written from work2. UIE2F404.1321
& p_field, !(IN)No. of p points per level. PF2UM1A.1290
& fixhd, !(IN)PF Fixed header record. PF2UM1A.1291
*CALL ARGPPX PF2UM1A.1292
& icode,cmessage) !(IN/OUT)Error flags. PF2UM1A.1293
CALL TIMER('WRITFLDS',4) UDG5F405.406
PF2UM1A.1294
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage,icode,nftout) PF2UM1A.1295
PF2UM1A.1296
!--------------------------------------------------------------------- PF2UM1A.1297
! 4.0 P* is not used in the PF dump and must be calculated in order to PF2UM1A.1298
! Increment the pstar field in the UM dump. P* is set equal to the UIE2F404.1095
! pressure on level 1. UIE2F404.1096
!--------------------------------------------------------------------- PF2UM1A.1301
PF2UM1A.1302
PF2UM1A.1357
! 4.3 Write out increments in pstar from array work3. PF2UM1A.1358
Call locate(stashcode_OD_pstar, !(IN)PARAMETER name for STASH PF2UM1A.1359
& ! item/section code for P*. PF2UM1A.1360
& pp_itemc, !(IN)Array of item codes. PF2UM1A.1361
& n_types, !(IN)No. of field types. PF2UM1A.1362
& pos) !(OUT)Pos. of P* in pp_itemc. PF2UM1A.1363
PF2UM1A.1364
CALL TIMER('WRITFLDS',3) UDG5F405.407
Call writflds(nftout, !(IN)Unit number of PF/output UM du PF2UM1A.1365
& 1, !(IN)Write P* on single level. PF2UM1A.1366
& pp_pos(pos), !(IN)Field no. in PF/output UM dump PF2UM1A.1367
& lookup, !(IN)Lookup table of PF/output UM d PF2UM1A.1368
& len1_lookup, !(IN)1st dim of Lookup. PF2UM1A.1369
& work4, !(IN) P* written from work4. UIE2F404.1097
& p_field, !(IN)No. of p points per level. PF2UM1A.1371
& fixhd, !(IN)PF Fixed header record. PF2UM1A.1372
*CALL ARGPPX PF2UM1A.1373
& icode,cmessage) !(IN/OUT)Error flags. PF2UM1A.1374
CALL TIMER('WRITFLDS',4) UDG5F405.408
PF2UM1A.1375
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage,icode,nftout) PF2UM1A.1376
PF2UM1A.1377
!--------------------------------------------------------------------- PF2UM1A.1378
! 5.0 Reorganisation of rows of the u and v fields for the UM grid. PF2UM1A.1379
!--------------------------------------------------------------------- PF2UM1A.1380
PF2UM1A.1381
! Read U into array work5 PF2UM1A.1382
Call locate(stashcode_OD_u, !(IN)PARAMETER name for STASH PF2UM1A.1383
& ! item/section code for U. PF2UM1A.1384
& pp_itemc, !(IN)Array of item codes. PF2UM1A.1385
& n_types, !(IN)No. of field types. PF2UM1A.1386
& pos) !(OUT)Pos. of U in pp_itemc. PF2UM1A.1387
PF2UM1A.1388
If (pos.eq.0) then PF2UM1A.1389
PF2UM1A.1390
write(6,'('' *ERROR* U (PF dump) not in input file'')') PF2UM1A.1391
Call abort PF2UM1A.1392
PF2UM1A.1393
End if PF2UM1A.1394
PF2UM1A.1395
CALL TIMER('READFLDS',3) UDG5F405.409
Call readflds(nftout, !(IN)Unit number of PF dump. PF2UM1A.1396
& p_levels, !(IN)Read U on all press levels. PF2UM1A.1397
& pp_pos(pos), !(IN)Field no. in PF dump. PF2UM1A.1398
& lookup, !(IN)Lookup table of PF dump. PF2UM1A.1399
& len1_lookup, !(IN)1st dim of Lookup. PF2UM1A.1400
& work5, !(OUT)U read into work5. PF2UM1A.1401
& p_field, !(IN)No. of p points per level. PF2UM1A.1402
& fixhd, !(IN)UM Fixed header record. PF2UM1A.1403
*CALL ARGPPX PF2UM1A.1404
& icode,cmessage) !(IN/OUT)Error flags. PF2UM1A.1405
CALL TIMER('READFLDS',4) UDG5F405.410
PF2UM1A.1406
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage,icode,nftout) PF2UM1A.1407
PF2UM1A.1408
! Reorganisation of u field. PF2UM1A.1409
CALL TIMER('PF_Rever',3) UDG5F405.411
Call PF_Reverse(work5, !(IN/OUT) ThetaL on PF theta levels PF2UM1A.1410
& row_length, !(IN) No. of columns. PF2UM1A.1411
& p_levels, !(IN) No. of theta levels. PF2UM1A.1412
& p_rows-1, !(IN) No. of rows. PF2UM1A.1413
& len_dummy, PF2UM1A.1414
& dummy2, PF2UM1A.1415
& 0, PF2UM1A.1416
& len_dummy, PF2UM1A.1417
& len_dummy, PF2UM1A.1418
*CALL ARGPPX PF2UM1A.1419
& dummy, PF2UM1A.1420
& dummy) PF2UM1A.1421
CALL TIMER('PF_Rever',4) UDG5F405.412
PF2UM1A.1422
! Read V into array work4 PF2UM1A.1423
Call locate(stashcode_OD_v, !(IN)PARAMETER name for STASH PF2UM1A.1424
& ! item/section code for V. PF2UM1A.1425
& pp_itemc, !(IN)Array of item codes. PF2UM1A.1426
& n_types, !(IN)No. of field types. PF2UM1A.1427
& pos) !(OUT)Pos. of V in pp_itemc. PF2UM1A.1428
PF2UM1A.1429
If (pos.eq.0) then PF2UM1A.1430
PF2UM1A.1431
write(6,'('' *ERROR* V (PF dump) not in input file'')') PF2UM1A.1432
Call abort PF2UM1A.1433
PF2UM1A.1434
End if PF2UM1A.1435
PF2UM1A.1436
CALL TIMER('READFLDS',3) UDG5F405.413
Call readflds(nftout, !(IN)Unit number of PF dump. PF2UM1A.1437
& p_levels, !(IN)Read V on all press levels PF2UM1A.1438
& pp_pos(pos), !(IN)Field no. in PF dump. PF2UM1A.1439
& lookup, !(IN)Lookup table of PF dump. PF2UM1A.1440
& len1_lookup, !(IN)1st dim of Lookup. PF2UM1A.1441
& work4, !(OUT)V read into work4. PF2UM1A.1442
& p_field, !(IN)No. of p points per level. PF2UM1A.1443
& fixhd, !(IN)UM Fixed header record. PF2UM1A.1444
*CALL ARGPPX PF2UM1A.1445
& icode,cmessage) !(IN/OUT)Error flags. PF2UM1A.1446
CALL TIMER('READFLDS',4) UDG5F405.414
PF2UM1A.1447
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage,icode,nftout) PF2UM1A.1448
PF2UM1A.1449
! Reorganisation of v field. PF2UM1A.1450
CALL TIMER('PF_Rever',3) UDG5F405.415
Call PF_Reverse(work4, !(IN/OUT) ThetaL on PF theta levels PF2UM1A.1451
& row_length, !(IN) No. of columns. PF2UM1A.1452
& p_levels, !(IN) No. of theta levels. PF2UM1A.1453
& p_rows-1, !(IN) No. of rows. PF2UM1A.1454
& len_dummy, PF2UM1A.1455
& dummy2, PF2UM1A.1456
& 0, PF2UM1A.1457
& len_dummy, PF2UM1A.1458
& len_dummy, PF2UM1A.1459
*CALL ARGPPX PF2UM1A.1460
& dummy, PF2UM1A.1461
& dummy) PF2UM1A.1462
CALL TIMER('PF_Rever',4) UDG5F405.416
PF2UM1A.1463
PF2UM1A.1464
PF2UM1A.1465
Call locate(stashcode_OD_u, !(IN)PARAMETER name for STASH PF2UM1A.1466
& ! item/section code for U. PF2UM1A.1467
& pp_itemc, !(IN)Array of item codes. PF2UM1A.1468
& n_types, !(IN)No. of field types. PF2UM1A.1469
& pos) !(OUT)Pos. of U in pp_itemc. PF2UM1A.1470
PF2UM1A.1471
If (pos.eq.0) then PF2UM1A.1472
PF2UM1A.1473
write(6,'('' *ERROR* U (UM dump) not in output file'')') PF2UM1A.1474
Call abort PF2UM1A.1475
PF2UM1A.1476
End if PF2UM1A.1477
PF2UM1A.1478
! Write out u on UM dump positions. PF2UM1A.1479
CALL TIMER('WRITFLDS',3) UDG5F405.417
Call writflds(nftout, !(IN)Unit number of PF/output UM PF2UM1A.1480
& p_levels, !(IN)Write U on pressure levels. PF2UM1A.1481
& pp_pos(pos), !(IN)Field no. in PF/output UM d PF2UM1A.1482
& lookup, !(IN)Lookup table of PF/output U PF2UM1A.1483
& len1_lookup, !(IN)1st dim of Lookup. PF2UM1A.1484
& work5, !(IN)U written from work1. PF2UM1A.1485
& p_field, !(IN)No. of u points per level. PF2UM1A.1486
& fixhd, !(IN)PF Fixed header record. PF2UM1A.1487
*CALL ARGPPX PF2UM1A.1488
& icode,cmessage) !(IN/OUT)Error flags. PF2UM1A.1489
CALL TIMER('WRITFLDS',4) UDG5F405.418
PF2UM1A.1490
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage,icode,nftout) PF2UM1A.1491
PF2UM1A.1492
Call locate(stashcode_OD_v, !(IN)PARAMETER name for STASH PF2UM1A.1493
& ! item/section code for V. PF2UM1A.1494
& pp_itemc, !(IN)Array of item codes. PF2UM1A.1495
& n_types, !(IN)No. of field types. PF2UM1A.1496
& pos) !(OUT)Pos. of V in pp_itemc. PF2UM1A.1497
PF2UM1A.1498
If (pos.eq.0) then PF2UM1A.1499
PF2UM1A.1500
write(6,'('' *ERROR* V (UM dump) not in output file'')') PF2UM1A.1501
Call abort PF2UM1A.1502
PF2UM1A.1503
End if PF2UM1A.1504
PF2UM1A.1505
! Write out v on UM dump positions. PF2UM1A.1506
CALL TIMER('WRITFLDS',3) UDG5F405.419
Call writflds(nftout, !(IN)Unit number of PF/output UM PF2UM1A.1507
& p_levels, !(IN)Write V on pressure levels. PF2UM1A.1508
& pp_pos(pos), !(IN)Field no. in PF/output UM d PF2UM1A.1509
& lookup, !(IN)Lookup table of PF/output U PF2UM1A.1510
& len1_lookup, !(IN)1st dim of Lookup. PF2UM1A.1511
& work4, !(IN)V written from work2. PF2UM1A.1512
& p_field, !(IN)No. of v points per level. PF2UM1A.1513
& fixhd, !(IN)PF Fixed header record. PF2UM1A.1514
*CALL ARGPPX PF2UM1A.1515
& icode,cmessage) !(IN/OUT)Error flags. PF2UM1A.1516
CALL TIMER('WRITFLDS',4) UDG5F405.420
PF2UM1A.1517
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage,icode,nftout) PF2UM1A.1518
PF2UM1A.1519
!--------------------------------------------------------------------- UDG7F405.113
! 6. Calculate Aerosol Increments UDG7F405.114
!--------------------------------------------------------------------- UDG7F405.115
UDG7F405.116
! 6.1 Read log(aerosol concentration increment') at level 1 into pfield2 UDG7F405.117
Call locate(stashcode_OD_aerosol, UDG7F405.118
!(IN)PARAMETER name for STASH UDG7F405.119
! item/section code for aerosol UDG7F405.120
& pp_itemc, !(IN)Array of item codes. UDG7F405.121
& n_types, !(IN)No. of field types. UDG7F405.122
& pos) !(OUT)Pos. of aerosol in pp_itemc. UDG7F405.123
If (pos.ne.0)then UDG7F405.124
Call readflds(nftout, !(IN)Unit number of PF dump UDG7F405.125
& 1, !(IN)Read level 1 UDG7F405.126
! log(aerosol concentration') UDG7F405.127
& pp_pos(pos), !(IN)Field no. in PF dump. UDG7F405.128
& lookup, !(IN)Lookup table of PF dump. UDG7F405.129
& len1_lookup, !(IN)1st dim of Lookup. UDG7F405.130
& pfield2, !(OUT)log(aerosol concentration') UDG7F405.131
! read into pfield2. UDG7F405.132
& p_field, !(IN)No. of p points per level. UDG7F405.133
& fixhd, !(IN)PF Fixed header record. UDG7F405.134
*CALL ARGPPX UDG7F405.135
& icode,cmessage) !(IN/OUT)Error flags. UDG7F405.136
UDG7F405.137
If (icode.ne.0) Call abort_io('PFinc_2UM',cmessage,icode,nftout) UDG7F405.138
UDG7F405.139
! Reorganisation of log(aerosol concentration') field. UDG7F405.140
Call PF_Reverse(pfield2, !(IN/OUT) level 1 UDG7F405.141
! log(aerosol concentration') UDG7F405.142
& row_length, !(IN) No. of columns. UDG7F405.143
& 1, !(IN) Theta level 1 UDG7F405.144
& p_rows, !(IN) No. of rows. UDG7F405.145
& len_dummy, UDG7F405.146
& dummy2, UDG7F405.147
& 0, UDG7F405.148
& len_dummy, UDG7F405.149
& len_dummy, UDG7F405.150
*CALL ARGPPX UDG7F405.151
& dummy, UDG7F405.152
& dummy) UDG7F405.153
UDG7F405.154
! 6.2 Read UM aerosol field into pfield UDG7F405.155
Call locate(stashcode_OD_aerosol, UDG7F405.156
!(IN)PARAMETER name for STASH UDG7F405.157
! item/section code for aerosol UDG7F405.158
& pp_itemc_um,!(IN)Array of item codes. UDG7F405.159
& n_types_um, !(IN)No. of field types. UDG7F405.160
& pos) !(OUT)Pos. of thetaL in pp_itemc. UDG7F405.161
If (pos.ne.0)then UDG7F405.162
Call readflds(nftin2, !(IN)Unit number of UM dump UDG7F405.163
& pp_num_um(pos), ! Read aerosol concentration UDG7F405.164
! on all pressure levels UDG7F405.165
& pp_pos_um(pos), !(IN)Field no. in UM dump. UDG7F405.166
& lookup_um, !(IN)Lookup table of PF dump. UDG7F405.167
& len1_lookup, !(IN)1st dim of Lookup. UDG7F405.168
& work5, !(OUT)aerosol concentration UDG7F405.169
! read into work5. UDG7F405.170
& pp_len_um(pos), !(IN)No. of p points per level. UDG7F405.171
& fixhd_um, !(IN)UM Fixed header record. UDG7F405.172
*CALL ARGPPX UDG7F405.173
& icode,cmessage) !(IN/OUT)Error flags. UDG7F405.174
UDG7F405.175
If (icode.ne.0) UDG7F405.176
& Call abort_io('PFinc_2UM',cmessage,icode,nftout) UDG7F405.177
UDG7F405.178
! 6.3: Calculate Aerosol increment at all boundary layer levels UDG7F405.179
Do k = 1,bl_levels UDG7F405.180
Do i = 1,p_field UDG7F405.181
! Evaluate f operator in pfield3 UDG7F405.182
press1 = levdepc(k)+levdepc(k+p_levels) * pstar_um(i) UDG7F405.183
pfield3(i)=((alog(press1/pstar_um(i))*scale)**2) UDG7F405.184
pfield3(i)=exp(-1.0*pfield3(i)) UDG7F405.185
UDG7F405.186
! Calculate aerosol increment in work4 UDG7F405.187
pos=(k-1)*p_field UDG7F405.188
work4(i+pos)=alog10(work5(i+pos))+pfield3(i)*pfield2(i) UDG7F405.189
work4(i+pos)=10**work4(i+pos)-work5(i+pos) UDG7F405.190
End Do !i UDG7F405.191
End Do !k UDG7F405.192
UDG7F405.193
! 6.4 Initialise aersol increments above boundary layer to zero UDG7F405.194
Do k = bl_levels+1,p_levels UDG7F405.195
Do i = 1,p_field UDG7F405.196
pos=(k-1)*p_field UDG7F405.197
work4(i+pos)=0.0 UDG7F405.198
End Do !i UDG7F405.199
End Do !k UDG7F405.200
UDG7F405.201
! 6.5 Write aerosol increment from work4. UDG7F405.202
Call locate(stashcode_OD_aerosol, UDG7F405.203
!(IN)PARAMETER name for STASH UDG7F405.204
! item/section code for aerosol UDG7F405.205
& pp_itemc, !(IN)Array of item codes. UDG7F405.206
& n_types, !(IN)No. of field types. UDG7F405.207
& pos) !(OUT)Pos. of aerosol in pp_itemc. UDG7F405.208
If (pos.ne.0)then UDG7F405.209
Call writflds(nftout, !(IN)Unit number of PF dump UDG7F405.210
& p_levels, !(IN)write Aerosol increment UDG7F405.211
& ! on all pressure levels UDG7F405.212
& pp_pos(pos), !(IN)Field no. in PF dump. UDG7F405.213
& lookup, !(IN)Lookup table of PF dump. UDG7F405.214
& len1_lookup, !(IN)1st dim of Lookup. UDG7F405.215
& work4, !(IN)Aerosol increment UDG7F405.216
! write from work4 UDG7F405.217
& p_field, !(IN)No. of p points per level. UDG7F405.218
& fixhd, !(IN)PF Fixed header record. UDG7F405.219
*CALL ARGPPX UDG7F405.220
& icode,cmessage) !(IN/OUT)Error flags. UDG7F405.221
UDG7F405.222
If (icode.ne.0) UDG7F405.223
& Call abort_io('PFinc_2UM',cmessage,icode,nftout) UDG7F405.224
UDG7F405.225
Else UDG7F405.226
write(6,'('' *ERROR* Aerosol (UM dump) not in input file'')') UDG7F405.227
call abort UDG7F405.228
End if UDG7F405.229
UDG7F405.230
End if UDG7F405.231
UDG7F405.232
End if UDG7F405.233
UDG7F405.234
!--------------------------------------------------------------------- UDG7F405.235
! 7. Adjust Headers UDG7F405.236
!--------------------------------------------------------------------- UDG7F405.237
UDG7F405.238
UDG7F405.239
UDG7F405.240
UDG7F405.241
UDG7F405.242
UDG7F405.243
UDG7F405.244
! 7.1 Change fixed header and Real constants. PF2UM1A.1520
PF2UM1A.1521
fixhd(3) = 1 ! Indicates hybrid co-ordinates PF2UM1A.1522
fixhd(9) = 2 ! Indicates UM 'B' grid. PF2UM1A.1523
PF2UM1A.1524
! 7.2 Write out changed header information in space of old header PF2UM1A.1525
Call TIMER('WRITHEAD',3) PF2UM1A.1527
PF2UM1A.1529
Call setpos(nftout,0,icode) ! Position at start of file PF2UM1A.1530
PF2UM1A.1531
Call writhead(nftout, PF2UM1A.1532
& fixhd,len_fixhd, PF2UM1A.1533
& inthd,len_inthd, PF2UM1A.1534
& realhd,len_realhd, PF2UM1A.1535
& levdepc,len1_levdepc,len2_levdepc, PF2UM1A.1536
& rowdepc,len1_rowdepc,len2_rowdepc, PF2UM1A.1537
& coldepc,len1_coldepc,len2_coldepc, PF2UM1A.1538
& flddepc,len1_flddepc,len2_flddepc, PF2UM1A.1539
& extcnst,len_extcnst, PF2UM1A.1540
& dumphist,len_dumphist, PF2UM1A.1541
& cfi1,len_cfi1, PF2UM1A.1542
& cfi2,len_cfi2, PF2UM1A.1543
& cfi3,len_cfi3, PF2UM1A.1544
& lookup,len1_lookup,len2_lookup, PF2UM1A.1545
& len_data, PF2UM1A.1546
*CALL ARGPPX PF2UM1A.1547
& start_block, PF2UM1A.1548
& icode,cmessage) PF2UM1A.1549
PF2UM1A.1550
Call TIMER('WRITHEAD',4) PF2UM1A.1552
PF2UM1A.1554
If (icode.ne.0)Call abort_io('PFinc_2UM',cmessage,icode,nftout) PF2UM1A.1555
PF2UM1A.1556
return PF2UM1A.1557
END PF2UM1A.1558
*ENDIF UDG5F405.421