SUBROUTINE INIT_LS( 1,151INITLS1A.24
& nftout, INITLS1A.25
& fixhd,len_fixhd, INITLS1A.26
& inthd,len_inthd, INITLS1A.27
& realhd,len_realhd, INITLS1A.28
& levdepc,len1_levdepc,len2_levdepc, INITLS1A.29
& rowdepc,len1_rowdepc,len2_rowdepc, INITLS1A.30
& coldepc,len1_coldepc,len2_coldepc, INITLS1A.31
& flddepc,len1_flddepc,len2_flddepc, INITLS1A.32
& extcnst,len_extcnst, INITLS1A.33
& dumphist,len_dumphist, INITLS1A.34
& cfi1,len_cfi1, INITLS1A.35
& cfi2,len_cfi2, INITLS1A.36
& cfi3,len_cfi3, INITLS1A.37
& lookup,len1_lookup,len2_lookup, INITLS1A.38
& p_levels,q_levels,bl_levels, INITLS1A.39
& p_field,p_rows,row_length, INITLS1A.40
& n_types,pp_itemc,pp_pos, INITLS1A.41
& pp_len,pp_num,pp_type, INITLS1A.42
& akh,bkh, INITLS1A.43
& len_data, INITLS1A.44
*CALL ARGPPX 
INITLS1A.45
& icode,cmessage) INITLS1A.46
INITLS1A.47
IMPLICIT NONE INITLS1A.48
! INITLS1A.49
! Description: INITLS1A.50
! Convert from standard (original UM) vertical grid with pressure/ INITLS1A.51
! sigma as vertical co-ordinate to new dynamics with (Charney-Phillips) INITLS1A.52
! vertical staggering and radius as vertical co-ordinate. INITLS1A.53
! Produce a dump with old UM variables plus new derived variables INITLS1A.54
! on new dynamics vertical grid. INITLS1A.55
! All comments concerning half and full levels are with respect to INITLS1A.56
! the original UM vertical grid definition. INITLS1A.57
! Original grid: all prognostic variables on full levels, level=1/2 at INITLS1A.58
! surface. INITLS1A.59
! Charney-Phillips grid: theta,q,w on 'theta' levels, level=0 at surfac INITLS1A.60
! pressure,density,u,v on 'press' levels. INITLS1A.61
! INITLS1A.62
! Method: INITLS1A.63
! INITLS1A.64
! Current Code Owner: I Edmond INITLS1A.65
! INITLS1A.66
! History: INITLS1A.67
! Version Date Comment INITLS1A.68
! ------- ---- ------- INITLS1A.69
! 4.1 03/96 New deck introduced at vn4.1. Ian Edmond INITLS1A.70
! 4.2 Oct. 96 T3E migration: *DEF CRAY removed GSS9F402.79
! S.J.Swarbrick GSS9F402.80
! vn4.4 9/4/97 DATA statement for crit rel humidity changed to UIE2F404.1347
! allow compilation using NAG f90 compiler UIE2F404.1348
! vn4.4 9/4/97 CMESSAGE changed to CHARACTER*(80) to run code UIE2F404.1349
! compiled using NAG f90. IEdmond UIE2F404.1350
! vn4.4 9/4/97 Initialise Crit Rel humidity variable for UIE2F404.1351
! MES dump. Ian Edmond UIE2F404.1352
! vn4.4 9/4/97 Change stash codes from thetaL and qT to UIE2F404.1353
! theta and q that LS data is written out to. IE UIE2F404.1354
! vn4.4 Reset top level w to zero. (b.c) Ian Edmond UIE2F404.1355
! vn4.4 9/4/97 Changes to calculate theta and q on LS grid UIE2F404.1356
! See UMDP107. Ian Edmond UIE2F404.1357
! vn4.4 10/4/97 Changes to incorporate routine POLAR_ROW_ADJ UIE2F404.1358
! to recalculate polar row u using geometric UIE2F404.1359
! wind across the pole. Ian Edmond UIE2F404.1360
! 4.5 15/04/98 Start-end args added to V_INT_Z. S.D.Mullerworth GSM1F405.546
! 4.5 29/07/98 Optimisation changes for T3E Rewrote **KAPPA UDG5F405.80
! calculations to reduce number of "**"'s and UDG5F405.81
! replaced "**"'s with vector function powr_v UDG5F405.82
! Author D.M. Goddard UDG5F405.83
! 4.5 10/11/98 Correct data statements initialising UDG6F405.114
! rhcrit and rhcrit_mes. UDG6F405.115
! Author D.M. Goddard UDG6F405.116
! INITLS1A.71
! Code Description: INITLS1A.72
! Language: FORTRAN 77 + common extensions. INITLS1A.73
! This code is written to UMDP3 v6 programming standards. INITLS1A.74
! INITLS1A.75
! System component covered: <appropriate code> INITLS1A.76
! System Task: <appropriate code> INITLS1A.77
! INITLS1A.78
! Declarations: INITLS1A.79
! These are of the form:- INITLS1A.80
! INTEGER ExampleVariable !Description of variable INITLS1A.81
! INITLS1A.82
! 1.0 Global variables (*CALLed COMDECKs etc...): INITLS1A.83
*CALL C_PI INITLS1A.84
*CALL C_G INITLS1A.85
*CALL C_R_CP INITLS1A.86
*CALL RCPARAM INITLS1A.87
*CALL C_EPSLON INITLS1A.88
*CALL CLOOKADD INITLS1A.89
*CALL CSUBMODL INITLS1A.90
*CALL CPPXREF INITLS1A.91
*CALL PPXLOOK INITLS1A.92
*CALL PARPARM UDG3F402.780
*CALL PARCOMM UDG3F402.781
INITLS1A.93
! Subroutine arguments INITLS1A.94
! Scalar arguments with intent(in): INITLS1A.95
INTEGER INITLS1A.96
& nftout ! Unit number of input UM dump /output LS dump. INITLS1A.97
&,len_fixhd ! Length of fixed length header (output) INITLS1A.98
&,len_inthd ! Length of integer header (output) INITLS1A.99
&,len_realhd ! Length of real header (output) INITLS1A.100
&,len2_levdepc ! 2nd dim of lev dep consts (output) INITLS1A.101
&,len1_levdepc ! ist dim of lev dep consts (output) INITLS1A.102
&,len1_rowdepc ! 1st dim of row dep consts (output) INITLS1A.103
&,len2_rowdepc ! 2nd dim of row dep consts (output) INITLS1A.104
&,len1_coldepc ! 1st dim of col dep consts (output) INITLS1A.105
&,len2_coldepc ! 2nd dim of col dep consts (output) INITLS1A.106
&,len1_flddepc ! 1st dim of field dep consts (output) INITLS1A.107
&,len2_flddepc ! 2nd dim of field dep consts (output) INITLS1A.108
&,len_extcnst ! Length of extra constants (output) INITLS1A.109
&,len_dumphist ! Length of history header (output) INITLS1A.110
&,len_cfi1 ! Length of index1 on output file INITLS1A.111
&,len_cfi2 ! Length of index2 on output file INITLS1A.112
&,len_cfi3 ! Length of index3 on output file INITLS1A.113
&,len1_lookup ! 1st dim of lookup header (output) INITLS1A.114
&,len2_lookup ! 2nd dim of lookup header (output) INITLS1A.115
&,len_data ! Length of output data (output) INITLS1A.116
&,start_block ! Readhead argument INITLS1A.117
INITLS1A.118
INTEGER INITLS1A.119
& p_field ! No of p-points per level (output) INITLS1A.120
&,row_length ! No of points E-W (output) INITLS1A.121
&,p_rows ! No of P-points N-S (output) INITLS1A.122
&,p_levels ! No of levels (output) INITLS1A.123
&,q_levels ! No of wet levels (output) INITLS1A.124
&,bl_levels ! No of b.l. levels (output) INITLS1A.125
INITLS1A.126
INTEGER INITLS1A.127
& n_types ! No of different field types on output file INITLS1A.128
INITLS1A.129
! Array arguments with intent(in): INITLS1A.130
INTEGER INITLS1A.131
& fixhd(256) ! Fixed length header INITLS1A.132
&,inthd(len_inthd) ! Integer header INITLS1A.133
&,cfi1(len_cfi1+1) ! Compressed field index no 1 INITLS1A.134
&,cfi2(len_cfi2+1) ! Compressed field index no 2 INITLS1A.135
&,cfi3(len_cfi3+1) ! Compressed field index no 3 INITLS1A.136
&,lookup(len1_lookup,len2_lookup) ! PP lookup tables INITLS1A.137
INITLS1A.138
INTEGER INITLS1A.139
& pp_len(len2_lookup) ! Length INITLS1A.140
&,pp_num(len2_lookup) ! No of fields For each INITLS1A.141
&,pp_pos(len2_lookup) ! Position field type INITLS1A.142
&,pp_type(len2_lookup) ! Real,int,log on output file INITLS1A.143
&,pp_itemc(len2_lookup) ! item code INITLS1A.144
INITLS1A.145
REAL INITLS1A.146
& realhd(len_realhd) ! Real header! INITLS1A.147
&,levdepc(1+len1_levdepc*len2_levdepc) ! Lev dep consts INITLS1A.148
&,rowdepc(1+len1_rowdepc*len2_rowdepc) ! Row dep consts INITLS1A.149
&,coldepc(1+len1_coldepc*len2_coldepc) ! Col dep consts INITLS1A.150
&,flddepc(1+len1_flddepc*len2_flddepc) ! Field dep consts INITLS1A.151
&,extcnst(len_extcnst+1) ! Extra constants INITLS1A.152
&,dumphist(len_dumphist+1) ! History block INITLS1A.153
INITLS1A.154
REAL INITLS1A.155
& akh(p_levels+1) ! Half level As for output levels INITLS1A.156
&,bkh(p_levels+1) ! Half level Bs for output levels INITLS1A.157
INITLS1A.158
! Scalar arguments with intent(InOut): INITLS1A.159
INITLS1A.160
! Array arguments with intent(InOut): INITLS1A.161
INITLS1A.162
! Scalar arguments with intent(out): INITLS1A.163
INITLS1A.164
! Array arguments with intent(out): INITLS1A.165
INITLS1A.166
! ErrorStatus INITLS1A.167
INTEGER INITLS1A.168
& len_io INITLS1A.169
&,icode ! Return code; successful=0 INITLS1A.170
! error > 0 INITLS1A.171
CHARACTER*(80) UIE2F404.33
& cmessage ! Error message If icode > 0 INITLS1A.173
INITLS1A.174
INITLS1A.175
! Local parameters: INITLS1A.176
INTEGER p_levels_max ! define max no. of model levels INITLS1A.177
PARAMETER(p_levels_max=99) ! for Crit RH variable. INITLS1A.178
INITLS1A.179
INTEGER convergence ! No. of iterations needed to approx. INITLS1A.180
PARAMETER(convergence=8) ! thetaL from theta on CP grid. INITLS1A.181
INITLS1A.182
INTEGER Linear ! Linear interpolation used. INITLS1A.183
PARAMETER(Linear=1) INITLS1A.184
INITLS1A.185
INTEGER Cubic ! Cubic interpolation used. INITLS1A.186
PARAMETER(Cubic=3) INITLS1A.187
INITLS1A.188
INTEGER Quintic ! Linear interpolation used. INITLS1A.189
PARAMETER(Quintic=5) INITLS1A.190
INITLS1A.191
INTEGER hybrid INITLS1A.192
PARAMETER(hybrid=1) INITLS1A.193
INITLS1A.194
INTEGER radial INITLS1A.195
PARAMETER(radial=5) INITLS1A.196
INITLS1A.197
REAL EarthRadius ! Mean radius of earth in metres. INITLS1A.198
PARAMETER(EarthRadius=6371229.) INITLS1A.199
INITLS1A.200
REAL L_over_cp ! Latent heat somewhere between the INITLS1A.201
PARAMETER(L_over_cp=2000.0)! values of latent heat of condensati INITLS1A.202
! and freezing of water / specific he INITLS1A.203
! capacity of dry air. INITLS1A.204
INITLS1A.205
REAL CP_OVER_G ! Used in calculation of height of to INITLS1A.206
PARAMETER(CP_OVER_G=CP/G) ! theta level. INITLS1A.207
INITLS1A.208
! Local scalars: INITLS1A.209
INTEGER INITLS1A.210
& pos ! Positions in work arrays,pp_itemc INITLS1A.211
&,pos1 ! and field dep consts. INITLS1A.212
&,pos2 ! INITLS1A.213
&,pos3 ! INITLS1A.214
&,nblp1 ! No of B.L. levs + 1 INITLS1A.215
&,n_fields ! No of fields per type on output file INITLS1A.216
&,pplen ! Length of field. INITLS1A.217
&,i,j,k ! Loop indices. INITLS1A.218
&,position INITLS1A.219
INITLS1A.220
! These variables required for the ARGFLDPT argument list which is INITLS1A.221
! used in the call to QT_POS_CTL INITLS1A.222
*CALL TYPFLDPT INITLS1A.223
INITLS1A.224
INTEGER U_FIELD ! This is required for the ARGFLDPT INITLS1A.225
! ! argument list. It will just be set equal INITLS1A.226
! ! to P_FIELD (the value is not actually INITLS1A.227
! ! used by QT_POS_CTL, but is required INITLS1A.228
! ! to set up the ARGFLDPT variables) INITLS1A.229
INITLS1A.230
REAL INITLS1A.231
& press1 ! INITLS1A.232
&,press2 ! Intermediate temporaries used in calc of pressure INITLS1A.233
&,pexner1 ! and exner pressure on pressure and theta levels. INITLS1A.234
&,pexner2 ! INITLS1A.235
&,thv ! Temporary storage space of single thetaV value. INITLS1A.236
&,A INITLS1A.237
&,latitude_step_inverse INITLS1A.238
&,inc INITLS1A.239
&,prev_inc INITLS1A.240
&,max_inc INITLS1A.241
INITLS1A.244
INITLS1A.249
LOGICAL INITLS1A.250
& umtwo ! FALSE - Indicates reconfiguration of the 1st UM dump INITLS1A.251
! to generate the linearisation state. INITLS1A.252
! TRUE - Indicates reconfiguration of the 2nd UM dump INITLS1A.253
! required for the calculation of the PF state. INITLS1A.254
INITLS1A.255
! Local dynamic arrays: INITLS1A.256
INTEGER INITLS1A.257
& fixhd_um1(256) INITLS1A.258
INITLS1A.259
REAL INITLS1A.260
& work1(p_field*p_levels) ! INITLS1A.261
&,work2(p_field*p_levels) ! Work space used for INITLS1A.262
&,work3(p_field*p_levels) ! both UM and PF variables. INITLS1A.263
&,work4(p_field*p_levels) ! INITLS1A.264
&,work5(p_field*(p_levels+1)) UIE2F404.803
&,flddepc_um1(1+len1_flddepc*len2_flddepc) ! Field dependent INITLS1A.266
& ! constants of the 1st UM dump used onl INITLS1A.267
& ! when logical umtwo is set TRUE. INITLS1A.268
&,pfield1(p_field) ! Pressure of individual output level INITLS1A.269
&,pfield2(p_field) ! Pressure of individual output level INITLS1A.270
&,pfield3(p_field) ! Work space INITLS1A.271
&,pfield4(p_field) ! Work space INITLS1A.272
&,pstar(p_field) ! Pstar on output grid INITLS1A.273
&,bl_coefft(p_field) ! INITLS1A.274
&,rhcrit(p_levels_max) INITLS1A.275
&,rhcrit_mes(p_levels_max) UIE2F404.102
*IF DEF,VECTLIB PXVECTLB.27
&,a_pexner1(p_field) UDG5F405.85
&,a_pexner2(p_field) UDG5F405.86
&,a_pexner1_kappa(p_field) UDG5F405.87
&,a_pexner2_kappa(p_field) UDG5F405.88
*ENDIF UDG5F405.89
INITLS1A.276
DATA(rhcrit(i),i=1,99)/0.950000,0.900000,97*0.850000/ UDG6F405.117
INITLS1A.281
DATA(rhcrit_mes(i),i=1,99)/0.916000,0.908000,0.891000,0.891000, UDG6F405.118
& 0.891000,0.875000,0.861000,0.857000, UDG6F405.119
& 0.854000,90*0.850000/ UDG6F405.120
! Function & Subroutine calls: INITLS1A.282
External buffin,ioerror,setpos,PF_Reverse,locate,abort, INITLS1A.283
& readflds,v_int_z,v_int_zh,qsat, INITLS1A.284
& PF_LS_CLD,RC_INIT_W,Cu_hgt,Cv_hgt,writflds, INITLS1A.285
& writhead,vert_interp INITLS1A.286
INITLS1A.287
!- End of header INITLS1A.288
INITLS1A.289
! Set up the variables in the ARGFLDPT argument list, required INITLS1A.290
! for the call to QT_POS_CTL later in this routine. INITLS1A.291
INITLS1A.292
U_FIELD=P_FIELD INITLS1A.293
*CALL SETFLDPT INITLS1A.294
INITLS1A.295
!--------------------------------------------------- INITLS1A.296
! Reinitialise critical relative humidity if MES dump. UIE2F404.111
If (fixhd(4).eq.103)then UDG6F405.121
UDG6F405.122
UDG6F405.123
do i =1, p_levels UIE2F404.113
rhcrit(i) = rhcrit_mes(i) UIE2F404.114
end do UIE2F404.115
End if UIE2F404.116
INITLS1A.297
! Open background UM dump to obtain height field in which to INITLS1A.298
! interpolate VAR LS dump prognostics onto. INITLS1A.299
Call file_open(22,'LS_CFILE',8,0,0,icode) INITLS1A.300
If (icode.eq.0) then INITLS1A.301
umtwo=.true. INITLS1A.302
write(*,*) INITLS1A.303
& 'dump being interpolated onto the levs of background dump' INITLS1A.304
Else INITLS1A.305
umtwo=.false. INITLS1A.306
write(*,*)'Reconfiguring background dump' INITLS1A.307
End if INITLS1A.308
INITLS1A.309
write(*,*)'UMTWO=',umtwo INITLS1A.310
!----------------------------------------------------------------------- INITLS1A.311
! 1. Read fixed header information of 2nd UM dump. INITLS1A.312
!----------------------------------------------------------------------- INITLS1A.313
INITLS1A.314
INITLS1A.315
If (umtwo) then !Code for conversion of 2nd UM dump->LS dump only INITLS1A.316
INITLS1A.317
! 1.1 Buffer in fixed length header record INITLS1A.318
Call buffin(22,fixhd_um1(1),256,len_io,A) INITLS1A.319
INITLS1A.320
! Check for I/O errors INITLS1A.321
If (A.ne.-1.0.or.len_io.ne.256)then INITLS1A.322
INITLS1A.323
Call ioerror('buffer in of fixed length header',A,len_io, INITLS1A.324
& 256) INITLS1A.325
cmessage='INIT_LS: I/O error' INITLS1A.326
icode = 1 INITLS1A.327
INITLS1A.328
return INITLS1A.329
End if INITLS1A.330
INITLS1A.331
! 1.2 Buffer in fields of constants array: flddepc_um1 holds INITLS1A.332
! the full level height fields of UM1 and thus vertical INITLS1A.333
! coordinate definitions of the LS grid. INITLS1A.334
INITLS1A.335
If (fixhd_um1(125).gt.0.and.len1_flddepc.ne.0) then INITLS1A.336
INITLS1A.337
Call setpos(22,fixhd_um1(125)-1,icode) INITLS1A.338
Call buffin(22, INITLS1A.339
& flddepc_um1(1), INITLS1A.340
& fixhd_um1(126)*fixhd_um1(127), INITLS1A.341
& len_io,A) INITLS1A.342
INITLS1A.343
! Check for i/O errors INITLS1A.344
If (A.ne.-1.0 INITLS1A.345
& .or.len_io.ne.fixhd_um1(126)*fixhd_um1(127) ) then INITLS1A.346
INITLS1A.347
Call ioerror('buffer in of field dependent constants', INITLS1A.348
& A,len_io,fixhd_um1(126)*fixhd_um1(127) ) INITLS1A.349
INITLS1A.350
cmessage='INIT_LS: I/O error' INITLS1A.351
icode = 1 INITLS1A.352
INITLS1A.353
return INITLS1A.354
End if INITLS1A.355
INITLS1A.356
! Reverse ordering of height field from PF to UM format. INITLS1A.357
Call PF_Reverse(flddepc_um1, !(IN/OUT)Theta and press level INITLS1A.358
& ! heights of 1st UM dum INITLS1A.359
& row_length, !(IN)No. of columns. INITLS1A.360
& (p_levels+1)*2,!(IN)No. of theta and press le INITLS1A.361
& ! an additional level for t INITLS1A.362
& ! in each height field. INITLS1A.363
& p_rows, !(IN)No. of rows. INITLS1A.364
& len_realhd, INITLS1A.365
& realhd, INITLS1A.366
& 0, INITLS1A.367
& len1_lookup, INITLS1A.368
& len2_lookup, INITLS1A.369
*CALL ARGPPX INITLS1A.370
& lookup, INITLS1A.371
& lookup) INITLS1A.372
INITLS1A.373
End if INITLS1A.374
INITLS1A.375
End if ! umtwo INITLS1A.376
INITLS1A.377
!----------------------------------------------------------------------- INITLS1A.378
! 2. Find heights of model full levels for 1st set radius co-ords INITLS1A.379
!----------------------------------------------------------------------- INITLS1A.380
INITLS1A.381
! 2.1 Read THL and QT, topography and initialise Exner p. INITLS1A.382
INITLS1A.383
Call Locate(stashcode_OD_pstar,! Intent(IN) PARAMETER name for INITLS1A.384
& ! STASH item/section code for P*. INITLS1A.385
& pp_itemc, ! Intent(IN) Array of item codes. INITLS1A.386
& n_types, ! Intent(IN) No. of field types. INITLS1A.387
& pos) ! Intent(OUT) Position of P* INITLS1A.388
& ! in pp_itemc. INITLS1A.389
If (pos.eq.0) then INITLS1A.390
INITLS1A.391
write(6,'('' *ERROR* Pstar (old dump) not in output file'')') INITLS1A.392
Call abort INITLS1A.393
INITLS1A.394
End if INITLS1A.395
INITLS1A.396
Call Readflds(nftout, !(IN)Unit no of I/P UM O/P LS dump. INITLS1A.397
& 1, !(IN)Read one level of data. INITLS1A.398
& pp_pos(pos), !(IN)Field no. in UM dump. INITLS1A.399
& lookup, !(IN)Lookup table of output LS dump. INITLS1A.400
& len1_lookup, !(IN)1st dim of Lookup. INITLS1A.401
& pstar, !(OUT)Read P* into array pstar. INITLS1A.402
& p_field, !(IN)No. of p points per level. INITLS1A.403
& fixhd, !(IN)Fixed header record of LS dump. INITLS1A.404
*CALL ARGPPX INITLS1A.405
& icode,cmessage)!(IN/OUT)Error flags. INITLS1A.406
INITLS1A.407
If (icode.ne.0) Call abort_io('INIT_LS',cmessage,icode,nftout) INITLS1A.408
INITLS1A.409
! Calculate exner pressure at UM half levels. Read into work5. INITLS1A.410
Do k = 1,p_levels+1 INITLS1A.411
pos=p_field*(k-1) UIE2F404.804
INITLS1A.412
*IF DEF,VECTLIB PXVECTLB.28
Do i = 1,p_field UDG5F405.91
UDG5F405.92
press1=akh(k)+bkh(k)*pstar(i) UDG5F405.93
work5(i+pos) = (press1 / Pref) UDG5F405.94
UDG5F405.95
End do ! i UDG5F405.96
UDG5F405.97
call powr_v(p_field,work5(1+pos),kappa,work5(1+pos)) UDG5F405.98
*ELSE UDG5F405.99
Do i = 1,p_field INITLS1A.413
INITLS1A.414
press1=akh(k)+bkh(k)*pstar(i) INITLS1A.415
work5(i+pos) = (press1 / Pref)**kappa UIE2F404.805
End do ! i INITLS1A.421
*ENDIF UDG5F405.100
INITLS1A.422
End do ! k INITLS1A.423
INITLS1A.424
Call Locate(stashcode_OD_theta,! Intent(IN) PARAMETER name for UIE2F404.154
& ! STASH item/sect. code for THL. INITLS1A.426
& pp_itemc, ! Intent(IN) Array of item codes. INITLS1A.427
& n_types, ! Intent(IN) No. of field types. INITLS1A.428
& pos) ! Intent(OUT) Position of thetaL INITLS1A.429
& ! in pp_itemc. INITLS1A.430
INITLS1A.431
If (pos.eq.0) then INITLS1A.432
INITLS1A.433
write(6,'('' *ERROR* ThetaL (old dump) not in output file'')') INITLS1A.434
Call abort INITLS1A.435
INITLS1A.436
End if INITLS1A.437
INITLS1A.438
Call Readflds(nftout, !(IN)Unit no of I/P UM O/P LS dump. INITLS1A.439
& p_levels, !(IN)No. of full/pressure levels. INITLS1A.440
& pp_pos(pos), !(IN)Field no. in UM dump. INITLS1A.441
& lookup, !(IN)Lookup table of output LS dump INITLS1A.442
& len1_lookup, !(IN)1st dim of Lookup. INITLS1A.443
& work1, !(OUT)Read THL into array work1. INITLS1A.444
& p_field, !(IN)No. of p points per level. INITLS1A.445
& fixhd, !(IN)Fixed header record of LS dump INITLS1A.446
*CALL ARGPPX INITLS1A.447
& icode,cmessage) !(IN/OUT)Error flags. INITLS1A.448
If (icode.ne.0) Call abort_io('INIT_LS',cmessage,icode,nftout) INITLS1A.450
INITLS1A.451
Call Locate(stashcode_OD_q, ! Intent(IN) PARAMETER name for UIE2F404.155
& ! STASH item/sect. code for qT. INITLS1A.453
& pp_itemc, ! Intent(IN) Array of item codes. INITLS1A.454
& n_types, ! Intent(IN) No. of field types. INITLS1A.455
& pos) ! Intent(OUT) Position of qT. INITLS1A.456
& ! in pp_itemc. INITLS1A.457
INITLS1A.458
INITLS1A.459
If (pos.eq.0) then INITLS1A.460
INITLS1A.461
write(6,'('' *ERROR* qT (old dump) not in output file'')') INITLS1A.462
Call abort INITLS1A.463
INITLS1A.464
End if INITLS1A.465
INITLS1A.466
Call Readflds(nftout, !(IN)Unit no of I/P UM O/P LS dump. INITLS1A.467
& q_levels, !(IN)Read qT on all full levels. INITLS1A.468
& pp_pos(pos), !(IN)Field no. in UM dump. INITLS1A.469
& lookup, !(IN)Lookup table of output LS dump INITLS1A.470
& len1_lookup, !(IN)1st dim of Lookup. INITLS1A.471
& work2, !(OUT)Read qT into array work2. INITLS1A.472
& p_field, !(IN)No. of p points per level. INITLS1A.473
& fixhd, !(IN)Fixed header record of LS dump INITLS1A.474
*CALL ARGPPX INITLS1A.475
& icode,cmessage) !(IN/OUT)Error flags. INITLS1A.476
INITLS1A.477
If (icode.ne.0) Call abort_io('INIT_LS',cmessage,icode,nftout) INITLS1A.478
INITLS1A.479
INITLS1A.480
Call Locate(stashcode_OD_orog, ! Intent(IN) PARAMETER name for INITLS1A.481
& ! STASH item/sect. code for orog INITLS1A.482
& pp_itemc, ! Intent(IN) Array of item codes. INITLS1A.483
& n_types, ! Intent(IN) No. of field types. INITLS1A.484
& pos) ! Intent(OUT) Position of qT. INITLS1A.485
& ! in pp_itemc. INITLS1A.486
INITLS1A.487
If (pos.eq.0) then INITLS1A.488
INITLS1A.489
write(6,'('' *ERROR* OROG (old dump) not in output file'')') INITLS1A.490
Call abort INITLS1A.491
INITLS1A.492
End if INITLS1A.493
INITLS1A.494
Call Readflds(nftout, !(IN)Unit no of I/P UM O/P LS dump. INITLS1A.495
& 1, !(IN)Read orog on single level. INITLS1A.496
& pp_pos(pos), !(IN)Field no. in UM dump. INITLS1A.497
& lookup, !(IN)Lookup table of output LS dump. INITLS1A.498
& len1_lookup, !(IN)1st dim of Lookup. INITLS1A.499
& pfield3, !(OUT)Read topography to array topog INITLS1A.500
& p_field, !(IN)No. of p points per level. INITLS1A.501
& fixhd, !(IN)Fixed header record of LS dump. INITLS1A.502
*CALL ARGPPX INITLS1A.503
& icode,cmessage) !(IN/OUT)Error flags. INITLS1A.504
INITLS1A.505
If (icode.ne.0) Call abort_io('INIT_LS',cmessage,icode,nftout) INITLS1A.506
INITLS1A.507
! Convert topography into geopotential at surface for input INITLS1A.508
! to v_int_zh INITLS1A.509
Do i = 1,p_field INITLS1A.510
INITLS1A.511
pfield3(i) = pfield3(i) * G ! G - gravity INITLS1A.512
INITLS1A.513
End do ! i INITLS1A.514
INITLS1A.515
! Call to cloud scheme 1A enables the conversion of qT -> q UIE2F404.1098
! (work2) and THL -> TH (work1). UIE2F404.1099
UIE2F404.1100
do k =1,q_levels UIE2F404.1101
pos = (k-1) * p_field UIE2F404.1102
UIE2F404.1103
Call pf_ls_cld(levdepc(k), ! (IN) Full level ak's. UIE2F404.1104
& levdepc(p_levels+k),! (IN) Full level bk's. UIE2F404.1105
& levdepc(k+1), UIE2F404.1106
& levdepc(p_levels+k+1),! (IN) bk's UIE2F404.1107
& pstar, ! (IN) P* UIE2F404.1108
& rhcrit(k), ! (IN) Critical relative UIE2F404.1109
& ! humidity from namelist. UIE2F404.1110
& p_field, ! (IN) No. of p points per lev. UIE2F404.1111
& p_field, ! (IN) No. of p points per lev. UIE2F404.1112
& work1(pos+1), ! (IN/OUT) THL -> TH UIE2F404.1113
& work2(pos+1), ! (IN/OUT) qT -> q UIE2F404.1114
& pfield1, ! (OUT) qc (not used) UIE2F404.1115
& hybrid, ! Dump type UIE2F404.1116
& icode) ! (IN/OUT) Error flag. UIE2F404.1117
UIE2F404.1118
end do UIE2F404.1119
UIE2F404.1120
! 2.2 Find heights of half levels INITLS1A.516
INITLS1A.517
! Find heights of half level boundaries: store in flddepc 1st INITLS1A.518
! field of (horizontal points * no of levels+1). First horizontal INITLS1A.519
! field is topography (defines theta levels on new vertical grid) INITLS1A.520
Call v_int_zh(work5, !(IN) Exner pressure UM half levs INITLS1A.521
& work1, !(IN) Theta on UM full levels. UIE2F404.1121
& work2, !(IN) q on UM full levels. UIE2F404.1122
& pfield3, !(IN) Topography. INITLS1A.524
& flddepc, !(OUT) Heights of UM half levels. INITLS1A.525
& p_field, !(IN) No. of p points per level. INITLS1A.526
& p_levels, !(IN) No. of full/pressure levels. INITLS1A.527
& q_levels) !(IN) No. of wet levels. INITLS1A.528
INITLS1A.529
INITLS1A.530
! 2.3 Write out half levels (flddepc) for the interpolation of bl INITLS1A.531
! stress coefft from half levels of UM grid onto theta levels lat INITLS1A.532
Call Locate(stashcode_ND_w, ! Intent(IN) PARAMETER name for INITLS1A.533
& ! STASH item/sect. code for w INITLS1A.534
& ! - Use space reserved for w INITLS1A.535
& ! in LS dump for temp storage INITLS1A.536
& pp_itemc, ! Intent(IN) Array of item co INITLS1A.537
& n_types, ! Intent(IN) No. of field typ INITLS1A.538
& pos) ! Intent(OUT) Position of w INITLS1A.539
& ! in pp_itemc. INITLS1A.540
INITLS1A.541
Call Writflds(nftout, !(IN) Unit no of O/P LS dump. INITLS1A.542
& p_levels, !(IN) Write all half levels. INITLS1A.543
& pp_pos(pos), !(IN) Field no. in LS dump. INITLS1A.544
& lookup, !(IN) Lookup table of output LS dump. INITLS1A.545
& len1_lookup, !(IN) 1st dim of Lookup. INITLS1A.546
& flddepc(p_field+1), !(IN) Write half levs from fldd INITLS1A.547
& p_field, !(IN) No. of p points per level. INITLS1A.548
& fixhd, !(IN) Fixed header record of LS dump. INITLS1A.549
*CALL ARGPPX INITLS1A.550
& icode,cmessage) !(IN/OUT) Error flags. INITLS1A.551
INITLS1A.552
If (icode.ne.0) Call abort_io('INIT_LS',cmessage,icode,nftout) INITLS1A.553
INITLS1A.554
! 2.4 Find heights of model full levels for 2nd set radius INITLS1A.555
! co-ords. INITLS1A.556
INITLS1A.557
Do i = 1,p_field INITLS1A.558
INITLS1A.559
flddepc(len1_flddepc+i) = flddepc(i) INITLS1A.560
INITLS1A.561
End do ! i INITLS1A.562
INITLS1A.563
! Get ak,bk from level dependent constants INITLS1A.564
nblp1 = bl_levels + 1 ! BL Reference level for v_int_z INITLS1A.565
INITLS1A.566
Do i = 1,p_field INITLS1A.567
INITLS1A.568
! Reference pressure of layer centre nblp1. INITLS1A.569
pfield2(i) = levdepc(nblp1) + INITLS1A.570
& levdepc(nblp1+p_levels) * pstar(i) INITLS1A.571
INITLS1A.572
End do ! i INITLS1A.573
INITLS1A.574
Do k = 1,p_levels INITLS1A.575
INITLS1A.576
! Reference pressure of layer centre (full level) INITLS1A.577
Do i = 1,p_field INITLS1A.578
INITLS1A.579
pfield1(i) = levdepc(k)+ INITLS1A.580
& levdepc(k+p_levels) * pstar(i) INITLS1A.581
INITLS1A.582
End do ! i INITLS1A.583
INITLS1A.584
pos1 = len1_flddepc + k*p_field INITLS1A.585
INITLS1A.586
! Find heights of full level centres: store in flddepc 2nd gri INITLS1A.587
! of (horizontal points * no of levels+1). First horizontal INITLS1A.588
! field is topography. (defines rho levels on new vertical grid INITLS1A.589
Call v_int_z(pfield1, !(IN) Press on full level k. INITLS1A.590
& pfield2, !(IN) Press on ref lev nblp1. INITLS1A.591
& pstar, !(IN) P* INITLS1A.592
& work5, !(IN) Exner press on half levs. INITLS1A.593
& work1, !(IN) Theta on full levs. UIE2F404.1123
& work2, !(IN) q on full levels. UIE2F404.1124
& flddepc(1), !(IN) half level heights. INITLS1A.596
& flddepc(pos1+1), !(OUT)full level heights. INITLS1A.597
& p_field, !(IN) No. of press points. INITLS1A.598
& p_levels, !(IN) No. of full levels. INITLS1A.599
& q_levels, !(IN) No. of wet levels. INITLS1A.600
& nblp1,akh,bkh, !(IN) ref lev and half lev GSM1F405.547
& 1,p_field) !(IN) range to calculate GSM1F405.548
INITLS1A.603
End do ! k INITLS1A.604
INITLS1A.605
!----------------------------------------------------------------------- INITLS1A.606
! 3. In order to preserve closeness to precipitation, RHt is treated INITLS1A.607
! exactly. We therefore interpolate RHt linearly in height from the INITLS1A.608
! B->C grid. Thus conversion of q -> RHt on the UM grid is necessary UIE2F404.1125
!----------------------------------------------------------------------- INITLS1A.612
INITLS1A.613
! 3.1 Conversion of q -> RHt on the UM grid. UIE2F404.1126
INITLS1A.615
Do k = 1,q_levels UIE2F404.1127
pos = p_field*(k -1) UIE2F404.1128
INITLS1A.618
*IF DEF,VECTLIB PXVECTLB.29
Do i = 1,p_field UDG5F405.102
UDG5F405.103
! Exner pressure on full level UDG5F405.104
a_pexner1(i) = (levdepc(k) + levdepc(k+p_levels) UDG5F405.105
& * pstar(i) ) / Pref UDG5F405.106
End do UDG5F405.107
UDG5F405.108
call powr_v(p_field,a_pexner1,kappa,a_pexner1) UDG5F405.109
UDG5F405.110
Do i = 1,p_field UDG5F405.111
! Find Tv from theta and the full level exner pressure. UDG5F405.112
UDG5F405.113
! Read temperature into work1 UDG5F405.114
work1(pos+i) = work1(pos+i) * a_pexner1(i) UDG5F405.115
*ELSE UDG5F405.116
Do i = 1,p_field INITLS1A.619
INITLS1A.620
! Exner pressure on full level INITLS1A.622
pexner1 = ( (levdepc(k) + INITLS1A.623
& levdepc(k+p_levels) * pstar(i) ) / Pref INITLS1A.624
& )**kappa INITLS1A.625
INITLS1A.626
! Find Tv from theta and the full level exner pressure. UIE2F404.1129
INITLS1A.639
! Read temperature into work1 UIE2F404.1130
work1(pos+i) = work1(pos+i) * pexner1 UIE2F404.1131
*ENDIF UDG5F405.117
INITLS1A.691
! Full level press read into pfield1 UIE2F404.1132
pfield1(i) = levdepc(k) + levdepc(k+p_levels) * pstar(i) INITLS1A.692
INITLS1A.693
! Calc. Tv from T using defn for thetaV (Tv). UIE2F404.1133
work1(pos+i) = work1(pos+i)* UIE2F404.1134
& (1.0 + c_virtual * work2(pos+i)) UIE2F404.1135
UIE2F404.1136
End do ! i INITLS1A.694
INITLS1A.695
! Saturated vapour pressure qs for a single level read into INITLS1A.696
! work4. (Temperature (work1) retained from the previous cal UIE2F404.1137
! to Cloud scheme 1A) INITLS1A.698
Call qsat(work3(pos+1), ! (OUT) qs on full level k. UIE2F404.1138
& work1(pos+1), ! (IN) Tv on full lev UIE2F404.1139
& pfield1, ! (IN) Full level press UIE2F404.1140
& p_field) ! (IN) No. of points per level. UIE2F404.1141
INITLS1A.703
! By definition, RHv = q/qs(Tv). UIE2F404.1142
Do i = 1,p_field UIE2F404.1143
INITLS1A.707
work3(pos+i) = work2(pos+i) / work3(pos+i) UIE2F404.1144
INITLS1A.709
End do ! i INITLS1A.710
End do ! k INITLS1A.711
INITLS1A.712
INITLS1A.720
! 3.2 Calculate thetaV on theta levels from the hydrostatic eqn. INITLS1A.721
INITLS1A.722
Do k = 1,p_levels-1 INITLS1A.723
pos=(k -1) * p_field INITLS1A.724
pos1=len1_flddepc + k * p_field INITLS1A.725
INITLS1A.726
*IF DEF,VECTLIB PXVECTLB.30
Do i = 1,p_field UDG5F405.119
UDG5F405.120
! Exner pressure on full levels. Read into pfield1 UDG5F405.121
pfield1(i) = ((levdepc(k) + UDG5F405.122
& levdepc(k+p_levels) * pstar(i)) / Pref) UDG5F405.123
UDG5F405.124
! Exner pressure on level just above pfield1. Read into pfield2 UDG5F405.125
pfield2(i) = ((levdepc(k+1) + UDG5F405.126
& levdepc(k+1+p_levels) * pstar(i)) / Pref) UDG5F405.127
Enddo UDG5F405.128
UDG5F405.129
call powr_v(p_field,pfield1,kappa,pfield1) UDG5F405.130
call powr_v(p_field,pfield2,kappa,pfield2) UDG5F405.131
UDG5F405.132
Do i = 1,p_field UDG5F405.133
*ELSE UDG5F405.134
Do i = 1,p_field INITLS1A.727
INITLS1A.728
! Exner pressure on full levels. Read into pfield1 INITLS1A.729
pfield1(i) = ((levdepc(k) + INITLS1A.730
& levdepc(k+p_levels) * pstar(i)) / Pref)**kappa INITLS1A.731
INITLS1A.732
! Exner pressure on level just above pfield1. Read into pfield2 INITLS1A.733
pfield2(i) = ((levdepc(k+1) + INITLS1A.734
& levdepc(k+1+p_levels) * pstar(i)) / Pref)**kappa INITLS1A.735
*ENDIF UDG5F405.135
INITLS1A.736
! ThetaV read into work1. INITLS1A.737
work1(pos+i) = -(G/CP) INITLS1A.738
& * ( (flddepc(pos1+i+p_field) ! full level hgt k INITLS1A.739
& - flddepc(pos1+i) ) ! full level hgt k+1 INITLS1A.740
& / (pfield2(i) - pfield1(i)) ) INITLS1A.741
INITLS1A.742
End do ! i INITLS1A.743
End do ! k INITLS1A.744
INITLS1A.745
! Fudge - Let the top level thetaV be equal to the values in 2nd INITLS1A.746
! last level INITLS1A.747
Do i = 1,p_field INITLS1A.748
INITLS1A.749
work1(pos+p_field+i) = work1(pos+i) INITLS1A.750
INITLS1A.751
End do ! i INITLS1A.752
INITLS1A.753
! 3.3 Find the heights of the theta levels on the PF vertical gri INITLS1A.754
! Take theta levels as halfway between the pressure levels. INITLS1A.755
! Top theta level height taken as that of top half level. UIE2F404.806
INITLS1A.758
Do k = 1,p_levels-1 INITLS1A.759
INITLS1A.760
pos1 = len1_flddepc+p_field*k INITLS1A.761
pos2 = len1_flddepc+p_field*(k+1) INITLS1A.762
pos3 = p_field*k INITLS1A.763
INITLS1A.764
Do i = 1,p_field INITLS1A.765
INITLS1A.766
flddepc(pos3+i) = (flddepc(pos1+i) + flddepc(pos2+i))/2.0 INITLS1A.767
INITLS1A.768
End do INITLS1A.769
INITLS1A.770
End do ! k INITLS1A.771
INITLS1A.772
INITLS1A.789
! 3.4 Interpolation in height from RHv on full levels (work3) UIE2F404.1145
! to RHv on theta levels on PF model grid.(work4) UIE2F404.1146
INITLS1A.790
! Initialise the first dry pressure level RHv to zero. UIE2F404.1147
Do i= 1,p_field UIE2F404.1148
work3(q_levels *p_field +i) = 0.0 UIE2F404.1149
End do UIE2F404.1150
INITLS1A.793
Do k = 1,q_levels+1 ! Loop over levels UIE2F404.1151
pos = (k -1) * p_field INITLS1A.795
pos1 = len1_flddepc + p_field INITLS1A.796
pos2 = k * p_field INITLS1A.797
INITLS1A.798
Call vert_interp(work3, !(IN) RHv on press levs UIE2F404.1152
& p_field, !(IN) No. of points per lev UIE2F404.1153
& q_levels+1, !(IN) No. of levels. UIE2F404.1154
& flddepc(pos2+1), !(IN) theta level heights INITLS1A.802
& flddepc(pos1+1), !(IN) press level heights INITLS1A.803
& Linear, !(IN) Linear interpolation INITLS1A.804
& work2(pos+1)) !(OUT)RHv on theta levels. UIE2F404.1155
INITLS1A.806
End do ! k INITLS1A.807
INITLS1A.808
! Reset the first dry theta level RHv to zero. UIE2F404.1156
Do i= 1,p_field UIE2F404.1157
work2(q_levels *p_field +i) = 0.0 UIE2F404.1158
End do UIE2F404.1159
UIE2F404.1160
INITLS1A.809
! Write out THv from array work1 for calculating density*r*r late INITLS1A.810
Call Locate(stashcode_ND_densityrr, ! Intent(IN) PARAMETER name f INITLS1A.811
& ! STASH item/sect. code for r INITLS1A.812
& ! - Use space reserved for rh INITLS1A.813
& ! in LS dump for temp storage INITLS1A.814
& pp_itemc, ! Intent(IN) Array of item co INITLS1A.815
& n_types, ! Intent(IN) No. of field typ INITLS1A.816
& pos) ! Intent(OUT) Position of rho INITLS1A.817
& ! in pp_itemc. INITLS1A.818
INITLS1A.819
Call Writflds(nftout, !(IN) Unit no of O/P LS dump. INITLS1A.820
& p_levels, !(IN) Write THv on all theta levels. INITLS1A.821
& pp_pos(pos), !(IN) Field no. in LS dump. INITLS1A.822
& lookup, !(IN) Lookup table of output LS dump. INITLS1A.823
& len1_lookup, !(IN) 1st dim of Lookup. INITLS1A.824
& work1, !(IN) Write THv from work1. INITLS1A.825
& p_field, !(IN) No. of p points per level. INITLS1A.826
& fixhd, !(IN) Fixed header record of LS dump. INITLS1A.827
*CALL ARGPPX INITLS1A.828
& icode,cmessage) !(IN/OUT) Error flags. INITLS1A.829
INITLS1A.830
If (icode.ne.0) Call abort_io('INIT_LS',cmessage,icode,nftout) INITLS1A.831
INITLS1A.832
! 3.5 Given RHv and thetaV we can determine theta,q from UIE2F404.1161
! the calculation of sat. qv and from the defn of thetav UIE2F404.1162
INITLS1A.836
! Find exner pressures on theta levels on PF vertical grid. INITLS1A.837
Do k = 1,q_levels ! Loop over theta levels. UIE2F404.1163
pos = p_field*(k -1) INITLS1A.839
INITLS1A.840
*IF DEF,VECTLIB PXVECTLB.31
Do i = 1,p_field UDG5F405.137
UDG5F405.138
! Exner pressure at pressure level just below theta level UDG5F405.139
! of interest on PF vertical grid. UDG5F405.140
press1 = levdepc(k) + levdepc(k+p_levels) * pstar(i) UDG5F405.141
a_pexner1(i) = (press1 / Pref) UDG5F405.142
UDG5F405.143
! Exner pressure at pressure level just above theta level UDG5F405.144
! of interest on PF vertical grid. UDG5F405.145
press2 = levdepc(k+1) + levdepc(k+1+p_levels) * pstar(i) UDG5F405.146
a_pexner2(i) = (press2 / Pref) UDG5F405.147
enddo UDG5F405.148
call powr_v(p_field,a_pexner1,kappa,a_pexner1_kappa) UDG5F405.149
call powr_v(p_field,a_pexner2,kappa,a_pexner2_kappa) UDG5F405.150
UDG5F405.151
Do i = 1,p_field UDG5F405.152
UDG5F405.153
! Pressures on theta levels of PF vertical grid read into UDG5F405.154
! pfield1 for each level separately. See working paper 154. UDG5F405.155
pfield1(i) = (a_pexner2_kappa(i) - a_pexner1_kappa(i)) UDG5F405.156
& / ( (a_pexner2(i) UDG5F405.157
& - a_pexner1(i) ) * kappa ) UDG5F405.158
enddo UDG5F405.159
call powr_v(p_field,pfield1,(kappa/(kappa-1)),pfield4) UDG5F405.160
call powr_v(p_field,pfield1,(1/(kappa-1)),pfield1) UDG5F405.161
UDG5F405.162
Do i = 1,p_field UDG5F405.163
pfield1(i) = pfield1(i) * pref UDG5F405.164
pos=p_field*(k-1) UDG5F405.165
UDG5F405.166
work3(pos+i)=work1(pos+i)*pfield4(i) UDG5F405.167
UDG5F405.168
End do ! i UDG5F405.169
*ELSE UDG5F405.170
Do i = 1,p_field INITLS1A.841
INITLS1A.842
! Exner pressure at pressure level just below theta level INITLS1A.843
! of interest on PF vertical grid. INITLS1A.844
press1 = levdepc(k) + levdepc(k+p_levels) * pstar(i) INITLS1A.845
pexner1 = (press1 / Pref)**kappa INITLS1A.846
INITLS1A.847
! Exner pressure at pressure level just above theta level INITLS1A.848
! of interest on PF vertical grid. INITLS1A.849
press2 = levdepc(k+1) + levdepc(k+1+p_levels) * pstar(i) INITLS1A.850
pexner2 = (press2 / Pref)**kappa INITLS1A.851
INITLS1A.852
! Pressures on theta levels of PF vertical grid read into INITLS1A.853
! pfield1 for each level separately. See working paper 154. INITLS1A.854
pfield1(i) = ( (pexner2 - pexner1) INITLS1A.855
& / ( (pexner2**(1/kappa) INITLS1A.856
& - pexner1**(1/kappa) ) * kappa ) INITLS1A.857
& )**(1/(kappa-1)) * Pref INITLS1A.858
INITLS1A.859
! Exner pressures (pfield4) on theta levels on PF vertical gri INITLS1A.860
pfield4(i) = ( pfield1(i) / Pref )**kappa INITLS1A.861
INITLS1A.862
End do ! i INITLS1A.863
Do i = 1,p_field INITLS1A.880
pos=p_field*(k-1) UIE2F404.1164
INITLS1A.881
work3(pos+i)=work1(pos+i)*pfield4(i) UIE2F404.1165
INITLS1A.903
End do ! i INITLS1A.904
*ENDIF UDG5F405.171
INITLS1A.905
! Corresponding saturated vapour pressure for a single level INITLS1A.906
Call qsat(work4(pos+1), ! (OUT) qs(Tv) on PF theta level UIE2F404.1166
& work3(pos+1), ! (IN) Tv on PF theta level UIE2F404.1167
& pfield1, ! (IN) Pressures on theta level INITLS1A.909
& p_field) ! (IN) No. of p points. INITLS1A.1092
INITLS1A.1093
Do i = 1,p_field INITLS1A.1094
pos=p_field*(k-1) UIE2F404.1168
INITLS1A.1095
! Recalculate q on PF theta levels from RHv and qs(Tv) UIE2F404.1169
work3(pos+i)=work2(pos+i)*work4(pos+i) UIE2F404.1170
INITLS1A.1098
! Recalculate TH from defn of THv. UIE2F404.1171
work1(pos+i)=work1(pos+i)/(1.0+c_virtual*work3(pos+i)) UIE2F404.1172
INITLS1A.1106
End do ! i UIE2F404.1173
End do INITLS1A.1107
INITLS1A.1108
! 3.6 Replace TH,q in output dump UIE2F404.1174
INITLS1A.1110
If (umtwo) then INITLS1A.1111
INITLS1A.1112
! Interpolation of theta/q on theta levels of 2nd UM dump onto UIE2F404.1175
! theta levels of 1st dump. INITLS1A.1114
Do k = 1,p_levels ! Loop over levels INITLS1A.1115
pos = (k -1)*p_field INITLS1A.1116
pos1 = k*p_field INITLS1A.1117
INITLS1A.1118
Call vert_interp(work1, !(IN) theta on 2nd dump UIE2F404.1176
& p_field, !(IN) No. of points per l INITLS1A.1120
& p_levels, !(IN) No. of wet levels. UIE2F404.1177
& flddepc_um1(pos1+1),!(IN) theta level heights INITLS1A.1122
& ! of 1st UM dump. INITLS1A.1123
& flddepc(p_field+1), !(IN) theta level heights INITLS1A.1124
& ! of 2nd UM dump. INITLS1A.1125
& Linear, !(IN) Linear interpolatio INITLS1A.1126
& work2(pos+1)) !(OUT)theta on 1st dump UIE2F404.1178
& ! theta levels. INITLS1A.1128
INITLS1A.1129
If (k.le.q_levels) then INITLS1A.1130
INITLS1A.1131
Call vert_interp(work3, !(IN)q on 2nd dump lev UIE2F404.1179
& p_field, !(IN)No. of points per INITLS1A.1133
& q_levels, !(IN)No. of q levels. INITLS1A.1134
& flddepc_um1(pos1+1),!(IN)theta level height INITLS1A.1135
& ! of 1st UM dump. INITLS1A.1136
& flddepc(p_field+1), !(IN)theta level height INITLS1A.1137
& ! of 2nd UM dump. INITLS1A.1138
& Linear, !(IN)Linear interpolati INITLS1A.1139
& work4(pos+1)) !(OUT)q on 1st dump le UIE2F404.1180
INITLS1A.1141
End if INITLS1A.1142
INITLS1A.1143
End do ! k INITLS1A.1144
INITLS1A.1145
Call Locate(stashcode_OD_theta, ! Intent(IN) PARAMETER name for UIE2F404.1181
& ! STASH item/sect. code for the INITLS1A.1147
& pp_itemc, ! Intent(IN) Array of item code INITLS1A.1148
& n_types, ! Intent(IN) No. of field types INITLS1A.1149
& pos) ! Intent(OUT) Position of theta INITLS1A.1150
& ! in pp_itemc. INITLS1A.1151
INITLS1A.1152
! Reorganisation of TH field for LS storage. UIE2F404.1182
Call PF_Reverse(work2, !(IN/OUT) Theta on PF theta levels UIE2F404.1183
& row_length, !(IN) No. of columns. INITLS1A.1155
& p_levels, !(IN) No. of theta levels. INITLS1A.1156
& p_rows, !(IN) No. of rows. INITLS1A.1157
& len_realhd, INITLS1A.1158
& realhd, INITLS1A.1159
& pp_pos(pos), INITLS1A.1160
& len1_lookup, INITLS1A.1161
& len2_lookup, INITLS1A.1162
*CALL ARGPPX INITLS1A.1163
& lookup, INITLS1A.1164
& lookup) INITLS1A.1165
INITLS1A.1166
! Write out TH from array work2. UIE2F404.1184
Call Writflds(nftout, !(IN) Unit no of O/P LS dump. INITLS1A.1169
& p_levels, !(IN) Write TH on all theta levels. UIE2F404.1185
& pp_pos(pos), !(IN) Field no. in LS dump. INITLS1A.1171
& lookup, !(IN) Lookup table of output LS dump. INITLS1A.1172
& len1_lookup, !(IN) 1st dim of Lookup. INITLS1A.1173
& work2, !(IN) Write TH from work2. UIE2F404.1186
& p_field, !(IN) No. of p points per level. INITLS1A.1175
& fixhd, !(IN) Fixed header record of LS dump. INITLS1A.1176
*CALL ARGPPX INITLS1A.1177
& icode,cmessage) !(IN/OUT) Error flags. INITLS1A.1178
INITLS1A.1179
If (icode.ne.0) Call abort_io('INIT_LS',cmessage, INITLS1A.1180
& icode,nftout) INITLS1A.1181
INITLS1A.1182
Call Locate(stashcode_OD_q, ! Intent(IN) PARAMETER name for UIE2F404.1187
& ! STASH item/sect. code for q. UIE2F404.1188
& pp_itemc, ! Intent(IN) Array of item codes. INITLS1A.1185
& n_types, ! Intent(IN) No. of field types. INITLS1A.1186
& pos) ! Intent(OUT) Position of q UIE2F404.1189
& ! in pp_itemc. INITLS1A.1188
INITLS1A.1189
! Reorganistion of q field. UIE2F404.1190
Call PF_Reverse(work4, !(IN/OUT) q on PF theta levels UIE2F404.1191
& row_length, !(IN) No. of columns. INITLS1A.1192
& q_levels, !(IN) No. of wet theta levels. UIE2F404.1192
& p_rows, !(IN) No. of rows. INITLS1A.1194
& len_realhd, INITLS1A.1195
& realhd, INITLS1A.1196
& pp_pos(pos), INITLS1A.1197
& len1_lookup, INITLS1A.1198
& len2_lookup, INITLS1A.1199
*CALL ARGPPX INITLS1A.1200
& lookup, INITLS1A.1201
& lookup) INITLS1A.1202
INITLS1A.1203
! Write out q from array work4. UIE2F404.1193
Call Writflds(nftout, !(IN) Unit number of LS dump. INITLS1A.1205
& q_levels, !(IN) Write q on all wet theta levs UIE2F404.1194
& pp_pos(pos), !(IN) Field no. in LS dump. INITLS1A.1207
& lookup, !(IN) Lookup table of LS dump. INITLS1A.1208
& len1_lookup, !(IN) 1st dim of Lookup. INITLS1A.1209
& work4, !(IN) Write q from work4. UIE2F404.1195
& p_field, !(IN) No. of p points per level. INITLS1A.1211
& fixhd, !(IN) Fixed header record of LS dump. INITLS1A.1212
*CALL ARGPPX INITLS1A.1213
& icode,cmessage) !(IN/OUT) Error flags. INITLS1A.1214
INITLS1A.1215
If (icode.ne.0) Call abort_io('INIT_LS',cmessage, INITLS1A.1216
& icode,nftout) INITLS1A.1217
INITLS1A.1218
Else INITLS1A.1219
INITLS1A.1220
Call Locate(stashcode_OD_theta, ! Intent(IN) PARAMETER name for UIE2F404.1196
& ! STASH item/sect. code for the INITLS1A.1222
& pp_itemc, ! Intent(IN) Array of item code INITLS1A.1223
& n_types, ! Intent(IN) No. of field types INITLS1A.1224
& pos) ! Intent(OUT) Position of theta INITLS1A.1225
& ! in pp_itemc. INITLS1A.1226
! Reorganisation of TH field for LS storage. UIE2F404.1197
Call PF_Reverse(work1, !(IN/OUT) Theta on PF theta levels UIE2F404.1198
& row_length, !(IN) No. of columns. INITLS1A.1230
& p_levels, !(IN) No. of theta levels. INITLS1A.1231
& p_rows, !(IN) No. of rows. INITLS1A.1232
& len_realhd, INITLS1A.1233
& realhd, INITLS1A.1234
& pp_pos(pos), INITLS1A.1235
& len1_lookup, INITLS1A.1236
& len2_lookup, INITLS1A.1237
*CALL ARGPPX INITLS1A.1238
& lookup, INITLS1A.1239
& lookup) INITLS1A.1240
! Write out TH from array work1. UIE2F404.1199
Call Writflds(nftout, !(IN) Unit number of output LS dump. INITLS1A.1243
& p_levels, !(IN) Write TH on all theta levels. UIE2F404.1200
& pp_pos(pos), !(IN) Field no. in LS dump. INITLS1A.1245
& lookup, !(IN) Lookup table of output LS dump INITLS1A.1246
& len1_lookup, !(IN) 1st dim of Lookup. INITLS1A.1247
& work1, !(IN) Write TH from work1. UIE2F404.1201
& p_field, !(IN) No. of p points per level. INITLS1A.1249
& fixhd, !(IN) Fixed header record of LS dump INITLS1A.1250
*CALL ARGPPX INITLS1A.1251
& icode,cmessage) !(IN/OUT) Error flags. INITLS1A.1252
INITLS1A.1253
If (icode.ne.0) Call abort_io('INIT_LS',cmessage, INITLS1A.1254
& icode,nftout) INITLS1A.1255
INITLS1A.1256
Call Locate(stashcode_OD_q, ! Intent(IN) PARAMETER name for UIE2F404.1202
& ! STASH item/sect. code for q. UIE2F404.1203
& pp_itemc, ! Intent(IN) Array of item codes. INITLS1A.1259
& n_types, ! Intent(IN) No. of field types. INITLS1A.1260
& pos) ! Intent(OUT) Position of q UIE2F404.1204
& ! in pp_itemc. INITLS1A.1262
INITLS1A.1263
! Reorganistion of q field. UIE2F404.1205
Call PF_Reverse(work3, !(IN/OUT) q on PF theta levels! UIE2F404.1206
& row_length, !(IN) No. of columns. INITLS1A.1266
& q_levels, !(IN) No. of wet theta levels. UIE2F404.1207
& p_rows, !(IN) No. of rows. INITLS1A.1268
& len_realhd, INITLS1A.1269
& realhd, INITLS1A.1270
& pp_pos(pos), INITLS1A.1271
& len1_lookup, INITLS1A.1272
& len2_lookup, INITLS1A.1273
*CALL ARGPPX INITLS1A.1274
& lookup, INITLS1A.1275
& lookup) INITLS1A.1276
INITLS1A.1277
! Write out q from array work3. UIE2F404.1208
Call Writflds(nftout, !(IN) Unit number of LS dump. INITLS1A.1279
& q_levels, !(IN) Write q on all wet theta levs UIE2F404.1209
& pp_pos(pos), !(IN) Field no. in LS dump. INITLS1A.1281
& lookup, !(IN) Lookup table of LS dump. INITLS1A.1282
& len1_lookup, !(IN) 1st dim of Lookup. INITLS1A.1283
& work3, !(IN) Write q from work3. UIE2F404.1210
& p_field, !(IN) No. of p points per level. INITLS1A.1285
& fixhd, !(IN) Fixed header record of LS dump INITLS1A.1286
*CALL ARGPPX INITLS1A.1287
& icode,cmessage) !(IN/OUT) Error flags. INITLS1A.1288
INITLS1A.1289
If (icode.ne.0) Call abort_io('INIT_LS',cmessage, INITLS1A.1290
& icode,nftout) INITLS1A.1291
INITLS1A.1292
End if ! umtwo INITLS1A.1293
INITLS1A.1294
INITLS1A.1295
!----------------------------------------------------------------------- INITLS1A.1296
!4.0 Initialise pressure on full levels. Initialise prognostic INITLS1A.1297
! density*r*r on full levels written to the LS dump and on theta INITLS1A.1298
! levels used (along with density*r*r on full levels) in the INITLS1A.1299
! initialisation of prognostic variable w in section 5. INITLS1A.1300
!----------------------------------------------------------------------- INITLS1A.1301
INITLS1A.1302
! 4.1 Calculation of density*r*r on full levels and on theta leve INITLS1A.1303
! First recover thetaV on pressure levels written to LS storage e INITLS1A.1304
Call Locate(stashcode_ND_densityrr, !Intent(IN) PARAMETER name fo INITLS1A.1305
& !STASH item/sect. code for rh INITLS1A.1306
& pp_itemc, !Intent(IN) Array of item cod INITLS1A.1307
& n_types, !Intent(IN) No. of field type INITLS1A.1308
& pos) !Intent(OUT) Position of thet INITLS1A.1309
& !in pp_itemc. INITLS1A.1310
INITLS1A.1311
If (pos.eq.0) then INITLS1A.1312
INITLS1A.1313
write(6,'(''*ERROR* DENSITY (new dump) not in output file'')') INITLS1A.1314
Call abort INITLS1A.1315
INITLS1A.1316
End if INITLS1A.1317
INITLS1A.1318
! ThetaV on theta levels read into work3. INITLS1A.1319
Call Readflds(nftout, !(IN)Unit number of LS dump. INITLS1A.1320
& p_levels, !(IN)Read thetaV on all theta levs. INITLS1A.1321
& pp_pos(pos), !(IN)Field no. in UM dump. INITLS1A.1322
& lookup, !(IN)Lookup table of LS dump. INITLS1A.1323
& len1_lookup, !(IN)1st dim of Lookup. INITLS1A.1324
& work3, !(OUT)Read thetaV into array work3. INITLS1A.1325
& p_field, !(IN)No. of p points per level. INITLS1A.1326
& fixhd, !(IN)Fixed header record of LS dump INITLS1A.1327
*CALL ARGPPX INITLS1A.1328
& icode,cmessage) !(IN/OUT)Error flags. INITLS1A.1329
INITLS1A.1330
If (icode.ne.0) Call abort_io('INIT_LS',cmessage, INITLS1A.1331
& icode,nftout) INITLS1A.1332
INITLS1A.1333
! Linear interpolation of thetaV from theta levels onto pressure INITLS1A.1334
! levels. ThetaV on 1st theta level set equal to those on the 1st INITLS1A.1335
! pressure level. INITLS1A.1336
Do i = 1,p_field INITLS1A.1337
INITLS1A.1338
pfield2(i) = work3(i) INITLS1A.1339
INITLS1A.1340
End do ! i INITLS1A.1341
INITLS1A.1342
Do k =2,p_levels INITLS1A.1343
pos = (k -1) * p_field INITLS1A.1344
pos2 = k * p_field INITLS1A.1345
pos1 = (k * p_field) + len1_flddepc INITLS1A.1346
INITLS1A.1347
Do i = 1,p_field INITLS1A.1348
INITLS1A.1349
thv = work3(pos+i) INITLS1A.1350
INITLS1A.1351
! ThetaV on pressure level k INITLS1A.1352
work3(i+pos) = ( work3(i+pos) - pfield2(i) ) INITLS1A.1353
& * ( (flddepc(pos1+i) - flddepc(pos+i) ) INITLS1A.1354
& /(flddepc(pos2+i) - flddepc(pos+i) ) ) INITLS1A.1355
& + pfield2(i) INITLS1A.1356
INITLS1A.1357
pfield2(i) = thv INITLS1A.1358
INITLS1A.1359
End do ! i INITLS1A.1360
End do ! k INITLS1A.1361
INITLS1A.1362
! Obtain density on theta and pressure levels. INITLS1A.1363
Do k = 1,p_levels INITLS1A.1364
pos = (k -1) * p_field INITLS1A.1365
pos2 = k * p_field INITLS1A.1366
pos1 = (k * p_field) + len1_flddepc INITLS1A.1367
INITLS1A.1368
Do i = 1,p_field INITLS1A.1369
INITLS1A.1370
! Reference pressure of layer centre (full level) INITLS1A.1371
work1(i+pos) = levdepc(k) + INITLS1A.1372
& levdepc(k+p_levels) * pstar(i) INITLS1A.1373
INITLS1A.1374
! Pressure on level above reference pressure. INITLS1A.1375
pfield1(i) = levdepc(k+1) + INITLS1A.1376
& levdepc(k+1+p_levels) * pstar(i) INITLS1A.1377
INITLS1A.1378
*IF DEF,VECTLIB PXVECTLB.32
! Exner pressure on full level UDG5F405.173
a_pexner1(i) = (work1(i+pos) / Pref) UDG5F405.174
! Exner pressure on full level above UDG5F405.175
a_pexner2(i) = (pfield1(i) / Pref) UDG5F405.176
enddo UDG5F405.177
UDG5F405.178
call powr_v(p_field,a_pexner1,kappa,a_pexner1) UDG5F405.179
call powr_v(p_field,a_pexner2,kappa,a_pexner2) UDG5F405.180
UDG5F405.181
Do i = 1,p_field UDG5F405.182
UDG5F405.183
pexner1=a_pexner1(i) UDG5F405.184
pexner2=a_pexner2(i) UDG5F405.185
*ELSE UDG5F405.186
! Exner pressure on full level INITLS1A.1379
pexner1 = (work1(i+pos) / Pref)**kappa INITLS1A.1380
INITLS1A.1381
! Exner pressure on full level above INITLS1A.1382
pexner2 = (pfield1(i) / Pref)**kappa INITLS1A.1383
*ENDIF UDG5F405.187
UDG5F405.188
INITLS1A.1384
! Density=press(work1)*r*r/(exner(pexner1)*thetaV(work3)*R) INITLS1A.1385
work4(i+pos) = work1(i+pos) INITLS1A.1386
& * ( flddepc(i + pos1) + EarthRadius ) INITLS1A.1387
& * ( flddepc(i + pos1) + EarthRadius ) INITLS1A.1388
& / ( pexner1 * work3(i+pos) * R ) INITLS1A.1389
INITLS1A.1390
! Density on theta levels read into work5 INITLS1A.1391
INITLS1A.1392
work5(i+pos) = ( pfield1(i) - work1(i+pos) ) UIE2F404.1093
& * ( flddepc(i+pos2) + EarthRadius ) INITLS1A.1394
& * ( flddepc(i+pos2) + EarthRadius ) INITLS1A.1395
& / ( (pexner2-pexner1) * work3(i+pos) * CP ) INITLS1A.1396
INITLS1A.1397
End do ! i INITLS1A.1398
End do ! k INITLS1A.1399
INITLS1A.1400
Do i = 1,p_field INITLS1A.1401
INITLS1A.1402
! Top level density set to zero. INITLS1A.1403
work5(i+p_field*(p_levels-1)) = 0.0 UIE2F404.1094
INITLS1A.1405
End do ! i INITLS1A.1406
INITLS1A.1407
If (umtwo) then !Code for conversion of 2nd UM dump->LS dump only INITLS1A.1408
INITLS1A.1409
! 4.2 Interpolation in height of log pressure(work1) and density INITLS1A.1410
! on full levels in the second UM dump to the positions in the INITLS1A.1411
! first UM dump. INITLS1A.1412
INITLS1A.1413
Do k = 1,p_levels INITLS1A.1414
pos=(k -1)*p_field INITLS1A.1415
INITLS1A.1416
Do i = 1,p_field INITLS1A.1417
INITLS1A.1418
work1(pos+i) = LOG( work1(pos+i) ) INITLS1A.1419
INITLS1A.1420
End do ! i INITLS1A.1421
End do ! k INITLS1A.1422
INITLS1A.1423
Do k = 1,p_levels INITLS1A.1424
pos = (k -1)*p_field INITLS1A.1425
pos1 = len1_flddepc + k*p_field INITLS1A.1426
pos2 = len1_flddepc + p_field + 1 INITLS1A.1427
INITLS1A.1428
Call vert_interp(work1, !(IN)log press on 2nd dum INITLS1A.1429
& p_field, !(IN)No. of points per le INITLS1A.1430
& p_levels, !(IN)No. of p levels. INITLS1A.1431
& flddepc_um1(pos1+1),!(IN)Full level heights INITLS1A.1432
& ! of 1st UM dump. INITLS1A.1433
& flddepc(pos2), !(IN)Full level heights INITLS1A.1434
& ! of 2nd UM dump. INITLS1A.1435
& Linear, !(IN)Linear interpolation INITLS1A.1436
& work3(pos+1)) !(OUT)log press on 1st du INITLS1A.1437
& ! levels. INITLS1A.1438
INITLS1A.1439
Call vert_interp(work4, !(IN)density on press INITLS1A.1440
& ! levels of 2nd UM dum INITLS1A.1441
& p_field, !(IN)No. of points per le INITLS1A.1442
& p_levels, !(IN)No. of p levels. INITLS1A.1443
& flddepc_um1(pos1+1),!(IN)Full level heights INITLS1A.1444
& ! of 1st UM dump. INITLS1A.1445
& flddepc(pos2), !(IN)Full level heights INITLS1A.1446
& ! of 2nd UM dump. INITLS1A.1447
& Linear, !(IN)Linear interpolation INITLS1A.1448
& work2(pos+1)) !(OUT)density on press INITLS1A.1449
& ! levels of 1st UM dump INITLS1A.1450
INITLS1A.1451
End do ! k INITLS1A.1452
INITLS1A.1453
Do k = 1,p_levels INITLS1A.1454
pos=(k -1)*p_field INITLS1A.1455
INITLS1A.1456
Do i = 1,p_field INITLS1A.1457
INITLS1A.1458
! Read pressure on levels of 1st dump back into work1 INITLS1A.1459
work1(pos+i) = EXP( work3(pos+i) ) INITLS1A.1460
INITLS1A.1461
End do ! i INITLS1A.1462
End do ! k INITLS1A.1463
INITLS1A.1464
! 4.3 Write density on p levels and pressure field to LS storage INITLS1A.1465
INITLS1A.1466
Call Locate(stashcode_ND_densityrr, ! Intent(IN) PARAMETER name INITLS1A.1467
& ! STASH item/sect. code for INITLS1A.1468
& pp_itemc, ! Intent(IN) Array of item c INITLS1A.1469
& n_types, ! Intent(IN) No. of field ty INITLS1A.1470
& pos) ! Intent(OUT) Position of rh INITLS1A.1471
& ! in pp_itemc. INITLS1A.1472
INITLS1A.1473
If (pos.eq.0) then INITLS1A.1474
INITLS1A.1475
write(6,'('' *ERROR* Density not in output file'')') INITLS1A.1476
Call abort INITLS1A.1477
INITLS1A.1478
End if INITLS1A.1479
INITLS1A.1480
! Reorganisation of density*r*r field for LS storage. INITLS1A.1481
Call PF_Reverse(work2, !(IN/OUT) Density on press levs INITLS1A.1482
& row_length, !(IN) No. of columns. INITLS1A.1483
& p_levels, !(IN) No. of p levels. INITLS1A.1484
& p_rows, !(IN) No. of rows. INITLS1A.1485
& len_realhd, INITLS1A.1486
& realhd, INITLS1A.1487
& pp_pos(pos), INITLS1A.1488
& len1_lookup, INITLS1A.1489
& len2_lookup, INITLS1A.1490
*CALL ARGPPX INITLS1A.1491
& lookup, INITLS1A.1492
& lookup) INITLS1A.1493
INITLS1A.1494
! Write density*r*r from array work2 INITLS1A.1495
! Write densityrr unpacked to the output LS dump - Solution INITLS1A.1496
! adopted by the VAR conversion routines for those fields which INITLS1A.1497
! are of order of magnitude 10^9 and more. INITLS1A.1498
Call Writflds(nftout, !(IN) Unit number of LS dump. INITLS1A.1499
& p_levels, !(IN) Write density on all p levs. INITLS1A.1500
& pp_pos(pos), !(IN) Field no. in LS dump. INITLS1A.1501
& lookup, !(IN) Lookup table of LS dump. INITLS1A.1502
& len1_lookup, !(IN) 1st dim of Lookup. INITLS1A.1503
& work2, !(IN) Write density from work2 INITLS1A.1504
& p_field, !(IN) No. of p points per level. INITLS1A.1505
& fixhd, !(IN) LS Fixed header record. INITLS1A.1506
*CALL ARGPPX INITLS1A.1507
& icode,cmessage) !(IN/OUT) Error flags. INITLS1A.1508
INITLS1A.1509
If (icode.ne.0) Call abort_io('INIT_LS',cmessage, INITLS1A.1510
& icode,nftout) INITLS1A.1511
INITLS1A.1512
else INITLS1A.1513
INITLS1A.1514
! 4.4 If 1st UM dump then write density on p levels and pressure INITLS1A.1515
! field directly to LS storage. INITLS1A.1516
INITLS1A.1517
Call Locate(stashcode_ND_densityrr, ! Intent(IN) PARAMETER name INITLS1A.1518
& ! STASH item/sect. code for INITLS1A.1519
& pp_itemc, ! Intent(IN) Array of item c INITLS1A.1520
& n_types, ! Intent(IN) No. of field ty INITLS1A.1521
& pos) ! Intent(OUT) Position of rh INITLS1A.1522
& ! in pp_itemc. INITLS1A.1523
INITLS1A.1524
If (pos.eq.0) then INITLS1A.1525
INITLS1A.1526
write(6,'('' *ERROR* Density not in output file'')') INITLS1A.1527
Call abort INITLS1A.1528
INITLS1A.1529
End if INITLS1A.1530
INITLS1A.1531
! Reorganisation of density*r*r field for LS storage. INITLS1A.1532
Call PF_Reverse(work4, !(IN/OUT) Density on press levs INITLS1A.1533
& row_length, !(IN) No. of columns. INITLS1A.1534
& p_levels, !(IN) No. of p levels. INITLS1A.1535
& p_rows, !(IN) No. of rows. INITLS1A.1536
& len_realhd, INITLS1A.1537
& realhd, INITLS1A.1538
& pp_pos(pos), INITLS1A.1539
& len1_lookup, INITLS1A.1540
& len2_lookup, INITLS1A.1541
*CALL ARGPPX INITLS1A.1542
& lookup, INITLS1A.1543
& lookup) INITLS1A.1544
INITLS1A.1545
! Write density*r*r from array work4 INITLS1A.1546
Call Writflds(nftout, !(IN) Unit number of LS dump. INITLS1A.1547
& p_levels, !(IN) Write density on all p levs. INITLS1A.1548
& pp_pos(pos), !(IN) Field no. in LS dump. INITLS1A.1549
& lookup, !(IN) Lookup table of LS dump. INITLS1A.1550
& len1_lookup, !(IN) 1st dim of Lookup. INITLS1A.1551
& work4, !(IN) Write density from work4 INITLS1A.1552
& p_field, !(IN) No. of p points per level. INITLS1A.1553
& fixhd, !(IN) LS Fixed header record. INITLS1A.1554
*CALL ARGPPX INITLS1A.1555
& icode,cmessage) !(IN/OUT) Error flags. INITLS1A.1556
INITLS1A.1557
If (icode.ne.0) Call abort_io('INIT_LS',cmessage, INITLS1A.1558
& icode,nftout) INITLS1A.1559
INITLS1A.1560
! Reorganisation of density*r*r field back into UM format for INITLS1A.1561
! the calculation of prognostic w. INITLS1A.1562
Call PF_Reverse(work4, !(IN/OUT)Density on press levs INITLS1A.1563
& row_length, !(IN) No. of columns. INITLS1A.1564
& p_levels, !(IN) No. of p levels. INITLS1A.1565
& p_rows, !(IN) No. of rows. INITLS1A.1566
& len_realhd, INITLS1A.1567
& realhd, INITLS1A.1568
& 0, INITLS1A.1569
& len1_lookup, INITLS1A.1570
& len2_lookup, INITLS1A.1571
*CALL ARGPPX INITLS1A.1572
& lookup, INITLS1A.1573
& lookup) INITLS1A.1574
INITLS1A.1575
End if ! umtwo INITLS1A.1576
INITLS1A.1577
! Write reference pressure of layer centres (full levels) to LS INITLS1A.1578
! dump. INITLS1A.1579
Call Locate(stashcode_ND_pressure,! Intent(IN) PARAMETER name for INITLS1A.1580
& ! STASH item/sect. code for pre INITLS1A.1581
& pp_itemc, ! Intent(IN) Array of item code INITLS1A.1582
& n_types, ! Intent(IN) No. of field types INITLS1A.1583
& pos) ! Intent(OUT) Position of press INITLS1A.1584
& ! field in pp_itemc. INITLS1A.1585
INITLS1A.1586
! Reorganisation of pressure field for LS storage. INITLS1A.1587
Call PF_Reverse(work1, !(IN/OUT) Pressure INITLS1A.1588
& row_length, !(IN) No. of columns. INITLS1A.1589
& p_levels, !(IN) No. of p levels. INITLS1A.1590
& p_rows, !(IN) No. of rows. INITLS1A.1591
& len_realhd, INITLS1A.1592
& realhd, INITLS1A.1593
& pp_pos(pos), INITLS1A.1594
& len1_lookup, INITLS1A.1595
& len2_lookup, INITLS1A.1596
*CALL ARGPPX INITLS1A.1597
& lookup, INITLS1A.1598
& lookup) INITLS1A.1599
INITLS1A.1600
Call Writflds(nftout, !(IN) Unit number of LS dump. INITLS1A.1601
& p_levels, !(IN) Write pressure on all p levs INITLS1A.1602
& pp_pos(pos), !(IN) Field no. in LS dump. INITLS1A.1603
& lookup, !(IN) Lookup table of LS dump. INITLS1A.1604
& len1_lookup, !(IN) 1st dim of Lookup. INITLS1A.1605
& work1, !(IN) Write pressure from work1 INITLS1A.1606
& p_field, !(IN) No. of p points per level. INITLS1A.1607
& fixhd, !(IN) LS Fixed header record. INITLS1A.1608
*CALL ARGPPX INITLS1A.1609
& icode,cmessage) !(IN/OUT) Error flags. INITLS1A.1610
INITLS1A.1611
!----------------------------------------------------------------------- INITLS1A.1612
! 5.0 Initialise the surface stress and the boundary layer stress INITLS1A.1613
! coefficients on theta levels of PF vertical grid. INITLS1A.1614
!----------------------------------------------------------------------- INITLS1A.1615
INITLS1A.1616
Do j = 1,n_types INITLS1A.1617
INITLS1A.1618
! 5.1 Store surface boundary layer stress coefft as coefft1*r*r INITLS1A.1619
If (pp_itemc(j).eq.stashcode_ND_BLcoeft1) then INITLS1A.1620
INITLS1A.1621
n_fields=pp_num(j) INITLS1A.1622
INITLS1A.1623
Call Locate(pp_itemc(j), ! Intent(IN) PARAMETER name for INITLS1A.1624
& ! STASH item/sect. code for surface INITLS1A.1625
& ! boundary layer stress coefficient. INITLS1A.1626
& pp_itemc, ! Intent(IN) Array of item codes. INITLS1A.1627
& n_types, ! Intent(IN) No. of field types. INITLS1A.1628
& pos) ! Intent(OUT) Position of variable. INITLS1A.1629
& ! field in pp_itemc. INITLS1A.1630
INITLS1A.1631
If (pos.eq.0) then INITLS1A.1632
INITLS1A.1633
write(6,'('' *ERROR* surface BL coefft not in O/P file'')') INITLS1A.1634
Call abort INITLS1A.1635
INITLS1A.1636
End if INITLS1A.1637
INITLS1A.1638
Call Readflds(nftout, !(IN)Unit number of LS dump. INITLS1A.1639
& n_fields, !(IN)Read variable on surface lev. INITLS1A.1640
& pp_pos(pos), !(IN)Field no. in UM dump. INITLS1A.1641
& lookup, !(IN)Lookup table of LS dump. INITLS1A.1642
& len1_lookup, !(IN)1st dim of Lookup. INITLS1A.1643
& bl_coefft, !(OUT)Read variable into array INITLS1A.1644
& ! bl_coefft. INITLS1A.1645
& pp_len(j), !(IN)No. of p points per level. INITLS1A.1646
& fixhd, !(IN)LS Fixed header record. INITLS1A.1647
*CALL ARGPPX INITLS1A.1648
& icode,cmessage) !(IN/OUT)Error flags. INITLS1A.1649
INITLS1A.1650
If (icode.ne.0) Call abort_io('CONTROL',cmessage, INITLS1A.1651
& icode,nftout) INITLS1A.1652
INITLS1A.1653
! Multiply the surface boundary layer stress coefficient read INITLS1A.1654
! into bl_coefft by (topography + EarthRadius)**2 INITLS1A.1655
Do i = 1,pp_len(j) INITLS1A.1656
INITLS1A.1657
bl_coefft(i) = bl_coefft(i) INITLS1A.1658
& * ( flddepc(i) + EarthRadius ) INITLS1A.1659
& * ( flddepc(i) + EarthRadius ) INITLS1A.1660
INITLS1A.1661
End do ! i INITLS1A.1662
INITLS1A.1663
Call Locate(pp_itemc(j), ! Intent(IN) PARAMETER name for INITLS1A.1664
& ! STASH item/sect. code for coefft. INITLS1A.1665
& pp_itemc, ! Intent(IN) Array of item codes. INITLS1A.1666
& n_types, ! Intent(IN) No. of field types. INITLS1A.1667
& pos) ! Intent(OUT) Position of coefft INITLS1A.1668
& ! field in pp_itemc. INITLS1A.1669
INITLS1A.1670
Call PF_Reverse(bl_coefft, !(IN/OUT) Surface bdy layer coeff INITLS1A.1671
& row_length, !(IN) No. of columns. INITLS1A.1672
& n_fields, !(IN) Single level field. INITLS1A.1673
& p_rows, !(IN) No. of p rows. INITLS1A.1674
& len_realhd, INITLS1A.1675
& realhd, INITLS1A.1676
& pp_pos(pos), INITLS1A.1677
& len1_lookup, INITLS1A.1678
& len2_lookup, INITLS1A.1679
*CALL ARGPPX INITLS1A.1680
& lookup, INITLS1A.1681
& lookup) INITLS1A.1682
INITLS1A.1683
Call Writflds(nftout, !(IN) Unit number of LS dump. INITLS1A.1684
& n_fields, !(IN) Write coefft on single level INITLS1A.1685
& pp_pos(pos), !(IN) Field no. in LS dump. INITLS1A.1686
& lookup, !(IN) Lookup table of LS dump. INITLS1A.1687
& len1_lookup, !(IN) 1st dim of Lookup. INITLS1A.1688
& bl_coefft, !(IN) Write variable from coefft INITLS1A.1689
& pp_len(j), !(IN) No. of p points per level. INITLS1A.1690
& fixhd, !(IN) LS Fixed header record. INITLS1A.1691
*CALL ARGPPX INITLS1A.1692
& icode,cmessage) !(IN/OUT) Error flags. INITLS1A.1693
INITLS1A.1694
If (icode.ne.0) Call abort_io('INIT_LS',cmessage, INITLS1A.1695
& icode,nftout) INITLS1A.1696
INITLS1A.1697
Else if (pp_itemc(j).eq.stashcode_ND_BLcoeft2) then INITLS1A.1698
INITLS1A.1699
! 5.2 Store boundary layer stress coefficient as coefft2*r*r INITLS1A.1700
n_fields=pp_num(j) INITLS1A.1701
INITLS1A.1702
Call Locate(pp_itemc(j), ! Intent(IN) PARAMETER name for INITLS1A.1703
& ! STASH item/sect. code for INITLS1A.1704
& ! boundary layer stress coefficient. INITLS1A.1705
& pp_itemc, ! Intent(IN) Array of item codes. INITLS1A.1706
& n_types, ! Intent(IN) No. of field types. INITLS1A.1707
& pos) ! Intent(OUT) Position of variable. INITLS1A.1708
& ! field in pp_itemc. INITLS1A.1709
INITLS1A.1710
If (pos.eq.0) then INITLS1A.1711
INITLS1A.1712
write(6,'('' *ERROR* BL stress coefft not in O/P file'')') INITLS1A.1713
Call abort INITLS1A.1714
INITLS1A.1715
End if INITLS1A.1716
INITLS1A.1717
Call Readflds(nftout, !(IN)Unit no of I/P UM O/P LS dump INITLS1A.1718
& n_fields, !(IN)Read variable on boundary INITLS1A.1719
& ! theta levels. INITLS1A.1720
& pp_pos(pos), !(IN)Field no. in UM dump. INITLS1A.1721
& lookup, !(IN)Lookup table of output LS dum INITLS1A.1722
& len1_lookup, !(IN)1st dim of Lookup. INITLS1A.1723
& work1, !(OUT)Read variable into work1 INITLS1A.1724
& pp_len(j), !(IN)No. of p points per level. INITLS1A.1725
& fixhd, !(IN)Fixed header record of LS dum INITLS1A.1726
*CALL ARGPPX INITLS1A.1727
& icode,cmessage) !(IN/OUT)Error flags. INITLS1A.1728
INITLS1A.1729
If (icode.ne.0) Call abort_io('INIT_LS',cmessage, INITLS1A.1730
& icode,nftout) INITLS1A.1731
INITLS1A.1732
! Set half level 5 boundary layer stress coefficients to zero INITLS1A.1733
! Interpolate bdy layer stress coefficients on half levels 4 INITLS1A.1734
! and 5 to find values on theta level 4. INITLS1A.1735
Do i = 1,p_field INITLS1A.1736
work1(i+4*p_field) = 0.0 INITLS1A.1737
End do INITLS1A.1738
INITLS1A.1739
! First recover half levels written to LS storage earlier. INITLS1A.1740
Call Locate(stashcode_ND_w,!Intent(IN) PARAMETER name for INITLS1A.1741
& !STASH item/sect. code for w. INITLS1A.1742
& pp_itemc, !Intent(IN) Array of item codes. INITLS1A.1743
& n_types, !Intent(IN) No. of field types. INITLS1A.1744
& pos) !Intent(OUT) Temporary position of INITLS1A.1745
& ! half levs in pp_itemc. INITLS1A.1746
INITLS1A.1747
! Half levels read into work3. INITLS1A.1748
Call Readflds(nftout, !(IN)Unit number of LS dump. INITLS1A.1749
& p_levels, !(IN)Read all half levs. INITLS1A.1750
& pp_pos(pos), !(IN)Field no. in LS dump. INITLS1A.1751
& lookup, !(IN)Lookup table of LS dump. INITLS1A.1752
& len1_lookup, !(IN)1st dim of Lookup. INITLS1A.1753
& work3, !(OUT)Read half levs into work3. INITLS1A.1754
& p_field, !(IN)No. of p points per level. INITLS1A.1755
& fixhd, !(IN)Fixed header record of LS d INITLS1A.1756
*CALL ARGPPX INITLS1A.1757
& icode,cmessage)!(IN/OUT)Error flags. INITLS1A.1758
INITLS1A.1759
If (icode.ne.0) Call abort_io('INIT_LS',cmessage, INITLS1A.1760
& icode,nftout) INITLS1A.1761
INITLS1A.1762
! Interpolation of boundary layer stress coefficient from half INITLS1A.1763
! levels of UM grid onto theta levels of PF grid. INITLS1A.1764
Do k = 1,n_fields ! Loop over levels INITLS1A.1765
pos1=(k -1)*p_field INITLS1A.1766
pos2=k*p_field INITLS1A.1767
INITLS1A.1768
Call vert_interp(work1, !(IN) Bdy layer stress coefft INITLS1A.1769
& ! on UM half levels. INITLS1A.1770
& p_field, !(IN) No. of points per lev INITLS1A.1771
& n_fields+1, !(IN) No. of press levels. INITLS1A.1772
& flddepc(pos2+1),!(IN) theta levels of PF grid. INITLS1A.1773
& work3, !(IN) half levels of UM grid. INITLS1A.1774
& Linear, !(IN) Linear interpolation INITLS1A.1775
& work2(pos1+1)) !(OUT) Bdy layer stress coefft INITLS1A.1776
& ! on PF theta levels. INITLS1A.1777
INITLS1A.1778
End do ! k INITLS1A.1779
INITLS1A.1780
! Multiply the boundary layer stress coefficient read into INITLS1A.1781
! work2 by the heights of the theta levels on the PF vertical INITLS1A.1782
! grid. INITLS1A.1783
Do k = 1,n_fields INITLS1A.1784
pos=(k-1)*pp_len(j) INITLS1A.1785
INITLS1A.1786
Do i = 1,pp_len(j) INITLS1A.1787
INITLS1A.1788
work2(pos+i) = work2(pos+i) INITLS1A.1789
& * ( flddepc(i+k*p_field) + EarthRadius ) INITLS1A.1790
& * ( flddepc(i+k*p_field) + EarthRadius ) INITLS1A.1791
INITLS1A.1792
End do ! i INITLS1A.1793
End do! k INITLS1A.1794
INITLS1A.1795
If (umtwo) then INITLS1A.1796
INITLS1A.1797
! Interpolation of boundary layer stress coefficient from INITLS1A.1798
! theta levels of 2nd UM dump onto 1st UM dump. INITLS1A.1799
Do k = 1,n_fields ! Loop over levels INITLS1A.1800
pos1 = (k - 1)*p_field INITLS1A.1801
pos2 = k*p_field INITLS1A.1802
INITLS1A.1803
Call vert_interp(work2, !(IN)Bdy layer stress INITLS1A.1804
& ! coefft on PF theta level INITLS1A.1805
& p_field, !(IN)No. of points per lev INITLS1A.1806
& p_levels, !(IN)No. of press levels. INITLS1A.1807
& flddepc_um1(pos2+1),!(IN)PF Theta levels INITLS1A.1808
& !of 1st dump. INITLS1A.1809
& flddepc(p_field+1), !(IN)PF Theta levs of INITLS1A.1810
& ! 2nd dump. INITLS1A.1811
& Linear, !(IN)Linear interpolation INITLS1A.1812
& work1(pos1+1)) !(OUT)2nd dump's bdy layer INITLS1A.1813
& ! stress coefft on PF thet INITLS1A.1814
& ! levels of 1st dump. INITLS1A.1815
INITLS1A.1816
End do ! k INITLS1A.1817
INITLS1A.1818
INITLS1A.1819
Call Locate(pp_itemc(j), ! Intent(IN) PARAMETER name for INITLS1A.1820
& ! STASH item/sect. code for bdy INITLS1A.1821
& ! layer coefficient. INITLS1A.1822
& pp_itemc, ! Intent(IN) Array of item codes. INITLS1A.1823
& n_types, ! Intent(IN) No. of field types. INITLS1A.1824
& pos) ! Intent(OUT) Position of coefft. INITLS1A.1825
& ! field in pp_itemc. INITLS1A.1826
INITLS1A.1827
INITLS1A.1828
Call PF_Reverse(work1, !(IN/OUT) Bdy layer coefft. INITLS1A.1829
& row_length,!(IN) No. of columns. INITLS1A.1830
& n_fields, !(IN) No. of bdy layer theta lev INITLS1A.1831
& p_rows, !(IN) No. of p rows. INITLS1A.1832
& len_realhd, INITLS1A.1833
& realhd, INITLS1A.1834
& pp_pos(pos), INITLS1A.1835
& len1_lookup, INITLS1A.1836
& len2_lookup, INITLS1A.1837
*CALL ARGPPX INITLS1A.1838
& lookup, INITLS1A.1839
& lookup) INITLS1A.1840
INITLS1A.1841
Call Writflds(nftout, !(IN) Unit number of LS dump. INITLS1A.1842
& n_fields, !(IN) Write bdy layer coefft on INITLS1A.1843
& ! bdy theta levs. INITLS1A.1844
& pp_pos(pos),!(IN) Field no. in LS dump. INITLS1A.1845
& lookup, !(IN) Lookup table of LS dump. INITLS1A.1846
& len1_lookup,!(IN) 1st dim of Lookup. INITLS1A.1847
& work1, !(IN) Write variable from work1 INITLS1A.1848
& pp_len(j), !(IN) No. of p points per level. INITLS1A.1849
& fixhd, !(IN) LS fixed header record. INITLS1A.1850
*CALL ARGPPX INITLS1A.1851
& icode,cmessage)!(IN/OUT) Error flags. INITLS1A.1852
INITLS1A.1853
If (icode.NE.0) Call abort_io('CONTROL',cmessage, INITLS1A.1854
& icode,nftout) INITLS1A.1855
INITLS1A.1856
Else INITLS1A.1857
INITLS1A.1858
Call Locate(pp_itemc(j), ! Intent(IN) PARAMETER name for INITLS1A.1859
& ! STASH item/sect. code for bdy INITLS1A.1860
& ! layer coefficient. INITLS1A.1861
& pp_itemc, ! Intent(IN) Array of item codes. INITLS1A.1862
& n_types, ! Intent(IN) No. of field types. INITLS1A.1863
& pos) ! Intent(OUT) Position of coefft. INITLS1A.1864
& ! field in pp_itemc. INITLS1A.1865
INITLS1A.1866
Call PF_Reverse(work2, !(IN/OUT) Bdy layer coefft. INITLS1A.1867
& row_length,!(IN) No. of columns. INITLS1A.1868
& n_fields, !(IN) No. of bdy layer theta lev INITLS1A.1869
& p_rows, !(IN) No. of p rows. INITLS1A.1870
& len_realhd, INITLS1A.1871
& realhd, INITLS1A.1872
& pp_pos(pos), INITLS1A.1873
& len1_lookup, INITLS1A.1874
& len2_lookup, INITLS1A.1875
*CALL ARGPPX INITLS1A.1876
& lookup, INITLS1A.1877
& lookup) INITLS1A.1878
INITLS1A.1879
Call Writflds(nftout, !(IN) Unit number of LS dump. INITLS1A.1880
& n_fields, !(IN) Write bdy layer coefft on INITLS1A.1881
& ! bdy theta levs. INITLS1A.1882
& pp_pos(pos),!(IN) Field no. in LS dump. INITLS1A.1883
& lookup, !(IN) Lookup table of LS dump. INITLS1A.1884
& len1_lookup,!(IN) 1st dim of Lookup. INITLS1A.1885
& work2, !(IN) Write variable from work2 INITLS1A.1886
& pp_len(j), !(IN) No. of p points per level. INITLS1A.1887
& fixhd, !(IN) LS fixed header record. INITLS1A.1888
*CALL ARGPPX INITLS1A.1889
& icode,cmessage)!(IN/OUT) Error flags. INITLS1A.1890
INITLS1A.1891
If (icode.ne.0) Call abort_io('CONTROL',cmessage, INITLS1A.1892
& icode,nftout) INITLS1A.1893
INITLS1A.1894
End if !umtwo INITLS1A.1895
INITLS1A.1896
End if INITLS1A.1897
INITLS1A.1898
End do ! j INITLS1A.1899
INITLS1A.1900
!----------------------------------------------------------------------- INITLS1A.1901
! 6. Initialise prognostic variables for new dynamics scheme: INITLS1A.1902
! w, u, v, pressure INITLS1A.1903
!----------------------------------------------------------------------- INITLS1A.1904
INITLS1A.1905
INITLS1A.1906
! 6.1 Initialise w on half levels INITLS1A.1907
INITLS1A.1908
! Read U into array work3 INITLS1A.1909
Call Locate(stashcode_ND_u, ! Intent(IN) PARAMETER name for INITLS1A.1910
& ! STASH item/sect. code for u. INITLS1A.1911
& pp_itemc, ! Intent(IN) Array of item codes. INITLS1A.1912
& n_types, ! Intent(IN) No. of field types. INITLS1A.1913
& pos) ! Intent(OUT) Position of u INITLS1A.1914
& ! field in pp_itemc. INITLS1A.1915
INITLS1A.1916
If (pos.eq.0) then INITLS1A.1917
INITLS1A.1918
write(6,'('' *ERROR* U (old dump) not in output file'')') INITLS1A.1919
Call abort INITLS1A.1920
INITLS1A.1921
End if INITLS1A.1922
INITLS1A.1923
Call Readflds(nftout, !(IN)Unit number of LS dump. INITLS1A.1924
& p_levels, !(IN)Read u on all press levels. INITLS1A.1925
& pp_pos(pos), !(IN)Field no. in UM dump. INITLS1A.1926
& lookup, !(IN)Lookup table of LS dump. INITLS1A.1927
& len1_lookup, !(IN)1st dim of Lookup. INITLS1A.1928
& work3, !(OUT)Read u into array work3. INITLS1A.1929
& p_field, !(IN)No. of p points per level. INITLS1A.1930
& fixhd, !(IN)LS Fixed header record. INITLS1A.1931
*CALL ARGPPX INITLS1A.1932
& icode,cmessage) !(IN/OUT)Error flags. INITLS1A.1933
INITLS1A.1934
If (icode.ne.0) Call abort_io('INIT_LS',cmessage, INITLS1A.1935
& icode,nftout) INITLS1A.1936
INITLS1A.1937
! Read V into array work1 INITLS1A.1938
Call Locate(stashcode_ND_v, ! Intent(IN) PARAMETER name for INITLS1A.1939
& ! STASH item/sect. code for v. INITLS1A.1940
& pp_itemc, ! Intent(IN) Array of item codes. INITLS1A.1941
& n_types, ! Intent(IN) No. of field types. INITLS1A.1942
& pos) ! Intent(OUT) Position of v INITLS1A.1943
& ! field in pp_itemc. INITLS1A.1944
INITLS1A.1945
If (pos.eq.0) then INITLS1A.1946
INITLS1A.1947
write(6,'('' *ERROR* V (old dump) not in output file'')') INITLS1A.1948
Call abort INITLS1A.1949
INITLS1A.1950
End if INITLS1A.1951
INITLS1A.1952
Call Readflds(nftout, !(IN)Unit number of LS dump. INITLS1A.1953
& p_levels, !(IN)Read v on all press levels. INITLS1A.1954
& pp_pos(pos), !(IN)Field no. in UM dump. INITLS1A.1955
& lookup, !(IN)Lookup table of LS dump. INITLS1A.1956
& len1_lookup, !(IN)1st dim of Lookup. INITLS1A.1957
& work1, !(OUT)Read v into array work1. INITLS1A.1958
& p_field, !(IN)No. of p points per level. INITLS1A.1959
& fixhd, !(IN)LS Fixed header record. INITLS1A.1960
*CALL ARGPPX INITLS1A.1961
& icode,cmessage) !(IN/OUT)Error flags. INITLS1A.1962
INITLS1A.1963
If (icode.ne.0) Call abort_io('INIT_LS',cmessage,icode,nftout) INITLS1A.1964
INITLS1A.1965
! Radius coordinate is used in the initialisation of W. INITLS1A.1966
Do k = 1,p_levels*2+2 INITLS1A.1967
pos = (k -1)*p_field INITLS1A.1968
INITLS1A.1969
Do i = 1,p_field INITLS1A.1970
INITLS1A.1971
! Radius coordinate is found from heights of theta and INITLS1A.1972
! pressure levels. INITLS1A.1973
flddepc(pos+i) = flddepc(pos+i) + EarthRadius INITLS1A.1974
INITLS1A.1975
End do ! i INITLS1A.1976
End do ! k INITLS1A.1977
INITLS1A.1978
INITLS1A.1979
! Initialise vertical velocity prognostic on theta levels on INITLS1A.1980
! PF vertical grid. INITLS1A.1981
pos = len1_flddepc+p_field INITLS1A.1982
pos1 = p_field INITLS1A.1983
INITLS1A.1984
Call RC_INIT_W(row_length, !(IN) No. of columns. INITLS1A.1985
& p_rows, !(IN) No. of rows. INITLS1A.1986
& p_levels, !(IN) No. of press levels. INITLS1A.1987
& realhd(3), !(IN) Latitude(deg) of 1st point INITLS1A.1988
& realhd(4), !(IN) Longitude(deg) of 1st point INITLS1A.1989
& realhd(2), !(IN) Latitude(deg) grid spacing INITLS1A.1990
& realhd(1), !(IN) Longitude(deg) grid spacing INITLS1A.1991
& work5, !(IN) density on theta levels. INITLS1A.1992
& work4, !(IN) density on pressure levels. INITLS1A.1993
& work3, !(IN) U field INITLS1A.1994
& work1, !(IN) V field INITLS1A.1995
& work2, !(OUT) W field INITLS1A.1996
& flddepc(pos1+1),!(IN) radius of vertical INITLS1A.1997
& ! co-ord on w levs INITLS1A.1998
& flddepc(pos+1), !(IN) radius of vertical INITLS1A.1999
& ! co-ord on p levels INITLS1A.2000
& (fixhd(4).eq.0),!(IN) .TRUE. if Global grid. INITLS1A.2001
& icode) !(OUT) Error code. INITLS1A.2002
INITLS1A.2003
! Heights of theta and pressure levels are stored in the fields INITLS1A.2004
! of constants of the LS dump. INITLS1A.2005
Do k = 1,p_levels*2+2 INITLS1A.2006
pos = (k -1)*p_field INITLS1A.2007
INITLS1A.2008
Do i = 1,p_field INITLS1A.2009
INITLS1A.2010
flddepc(pos+i) = flddepc(pos+i) - EarthRadius INITLS1A.2011
INITLS1A.2012
End do ! i INITLS1A.2013
End do ! k INITLS1A.2014
INITLS1A.2015
If (umtwo) then INITLS1A.2016
INITLS1A.2017
! Interpolation of w on theta levels of 2nd UM dump onto INITLS1A.2018
! theta levels of 1st dump. INITLS1A.2019
Do k = 1,p_levels ! Loop over levels INITLS1A.2020
pos=k*p_field INITLS1A.2021
pos1=(k-1)*p_field UIE2F404.807
INITLS1A.2022
Call vert_interp(work2, !(IN) w on theta levels INITLS1A.2023
& ! of 2nd UM dump. INITLS1A.2024
& p_field, !(IN)No. of points per lev INITLS1A.2025
& p_levels, !(IN)No. of theta levels. INITLS1A.2026
& flddepc_um1(pos+1),!(IN)Theta level heights INITLS1A.2027
& ! of 1st UM dump. INITLS1A.2028
& flddepc(p_field+1),!(IN)Theta level heights INITLS1A.2029
& ! of 2nd UM dump. INITLS1A.2030
& Linear, !(IN)Linear interpolation INITLS1A.2031
& work5(1+pos1)) !(OUT)w on theta levels UIE2F404.808
& ! levels of 1st UM dump. INITLS1A.2033
INITLS1A.2034
! Reset top level w to zero. (b.c) UIE2F404.65
If (k .eq. p_levels) then UIE2F404.66
UIE2F404.67
do i=1,p_field UIE2F404.68
work5(pos1+i) = 0.0 UIE2F404.69
end do UIE2F404.70
UIE2F404.71
End if UIE2F404.72
End do ! k INITLS1A.2035
INITLS1A.2036
! Write W to dump from array work2 INITLS1A.2037
Call Locate(stashcode_ND_w, ! Intent(IN) PARAMETER name for INITLS1A.2038
& ! STASH item/sect. code for w. INITLS1A.2039
& pp_itemc, ! Intent(IN) Array of item codes. INITLS1A.2040
& n_types, ! Intent(IN) No. of field types. INITLS1A.2041
& pos) ! Intent(OUT) Position of w INITLS1A.2042
& ! field in pp_itemc. INITLS1A.2043
INITLS1A.2044
If (pos.eq.0) then INITLS1A.2045
INITLS1A.2046
write(6,'('' *ERROR* W (new dump) not in output file'')') INITLS1A.2047
Call abort INITLS1A.2048
INITLS1A.2049
End if INITLS1A.2050
INITLS1A.2051
! Reorganisation of W field for LS storage. INITLS1A.2052
Call PF_Reverse(work5, !(IN/OUT) W INITLS1A.2053
& row_length, !(IN) No. of columns. INITLS1A.2054
& p_levels, !(IN) No. of p levels. INITLS1A.2055
& p_rows, !(IN) No. of rows. INITLS1A.2056
& len_realhd, INITLS1A.2057
& realhd, INITLS1A.2058
& pp_pos(pos), INITLS1A.2059
& len1_lookup, INITLS1A.2060
& len2_lookup, INITLS1A.2061
*CALL ARGPPX INITLS1A.2062
& lookup, INITLS1A.2063
& lookup) INITLS1A.2064
INITLS1A.2065
Call Writflds(nftout, !(IN) Unit number of LS dump. INITLS1A.2066
& p_levels, !(IN) Write w on all theta levels. INITLS1A.2067
& pp_pos(pos), !(IN) Field no. in LS dump. INITLS1A.2068
& lookup, !(IN) Lookup table of LS dump. INITLS1A.2069
& len1_lookup, !(IN) 1st dim of Lookup. INITLS1A.2070
& work5, !(IN) Write w from work5 INITLS1A.2071
& p_field, !(IN) No. of p points per level. INITLS1A.2072
& fixhd, !(IN) LS Fixed header record. INITLS1A.2073
*CALL ARGPPX INITLS1A.2074
& icode,cmessage) !(IN/OUT) Error flags. INITLS1A.2075
INITLS1A.2076
If (icode.ne.0) Call abort_io('INIT_LS',cmessage, INITLS1A.2077
& icode,nftout) INITLS1A.2078
INITLS1A.2079
Else INITLS1A.2080
INITLS1A.2081
! Write W to dump from array work5 INITLS1A.2082
Call Locate(stashcode_ND_w, ! Intent(IN) PARAMETER name for INITLS1A.2083
& ! STASH item/sect. code for w. INITLS1A.2084
& pp_itemc, ! Intent(IN) Array of item codes. INITLS1A.2085
& n_types, ! Intent(IN) No. of field types. INITLS1A.2086
& pos) ! Intent(OUT) Position of w INITLS1A.2087
& ! field in pp_itemc. INITLS1A.2088
INITLS1A.2089
If (pos.eq.0) then INITLS1A.2090
INITLS1A.2091
write(6,'('' *ERROR* W (new dump) not in output file'')') INITLS1A.2092
Call abort INITLS1A.2093
INITLS1A.2094
End if INITLS1A.2095
INITLS1A.2096
! Reorganisation of W field for LS storage. INITLS1A.2097
Call PF_Reverse(work2, !(IN/OUT) W INITLS1A.2098
& row_length, !(IN) No. of columns. INITLS1A.2099
& p_levels, !(IN) No. of p levels. INITLS1A.2100
& p_rows, !(IN) No. of rows. INITLS1A.2101
& len_realhd, INITLS1A.2102
& realhd, INITLS1A.2103
& pp_pos(pos), INITLS1A.2104
& len1_lookup, INITLS1A.2105
& len2_lookup, INITLS1A.2106
*CALL ARGPPX INITLS1A.2107
& lookup, INITLS1A.2108
& lookup) INITLS1A.2109
INITLS1A.2110
Call Writflds(nftout, !(IN) Unit number of LS dump. INITLS1A.2111
& p_levels, !(IN) Write w on all theta levels. INITLS1A.2112
& pp_pos(pos), !(IN) Field no. in LS dump. INITLS1A.2113
& lookup, !(IN) Lookup table of LS dump. INITLS1A.2114
& len1_lookup, !(IN) 1st dim of Lookup. INITLS1A.2115
& work2, !(IN) Write w from work2 INITLS1A.2116
& p_field, !(IN) No. of p points per level. INITLS1A.2117
& fixhd, !(IN) LS Fixed header record. INITLS1A.2118
*CALL ARGPPX INITLS1A.2119
& icode,cmessage) !(IN/OUT) Error flags. INITLS1A.2120
INITLS1A.2121
If (icode.ne.0) Call abort_io('INIT_LS',cmessage, INITLS1A.2122
& icode,nftout) INITLS1A.2123
INITLS1A.2124
End if ! umtwo INITLS1A.2125
INITLS1A.2126
! 6.2 Initialise velocity components u,v on pressure levels on INITLS1A.2127
! PF vertical grid. INITLS1A.2128
INITLS1A.2129
If (umtwo) then ! Code for conversion of 2nd UM dump only. INITLS1A.2130
INITLS1A.2131
UIE2F404.809
! The second UM dump u and v data is transferred onto the first UIE2F404.810
! UM dump points: UIE2F404.811
UIE2F404.812
Do k=1,p_levels UIE2F404.813
pos = len1_flddepc+p_field UIE2F404.814
pos1 = (p_field-row_length)*(k-1) UIE2F404.815
! Cv_hgt calculates the height at each v point for the second UIE2F404.816
! UM dump by linear interpolation of the heights of the pressure UIE2F404.817
! levels. Use work2 to hold the height of each v point. UIE2F404.818
Call Cv_hgt(flddepc(pos+1), !(IN) Pressure level heights of UIE2F404.819
& work2(pos1+1), !(OUT)Heights of v field UIE2F404.820
& p_field, !(IN) No. of p points. UIE2F404.821
& p_levels, !(IN) No. of press levels. UIE2F404.822
& k, UIE2F404.823
& row_length, !(IN) No. of columns. UIE2F404.824
& (fixhd(4).eq.103)) !(IN) Equatorial lat-lon LAM gri UIE2F404.825
UIE2F404.826
! Cv_hgt calculates the height at each v point for the first UIE2F404.827
! UM dump. Read into work4. UIE2F404.828
Call Cv_hgt(flddepc_um1(pos+1),!(IN) Pressure level heights of UIE2F404.829
& work4(pos1+1), !(OUT)Heights of v field UIE2F404.830
& p_field, !(IN) No. of p points. UIE2F404.831
& p_levels, !(IN) No. of press levels. UIE2F404.832
& k, UIE2F404.833
& row_length, !(IN) No. of columns. UIE2F404.834
& (fixhd(4).eq.103)) !(IN) Equatorial lat-lon LAM gri UIE2F404.835
UIE2F404.836
End do UIE2F404.837
! Interpolation of v(work1) from the second UM dump to the UIE2F404.838
! first UM dump points. UIE2F404.839
UIE2F404.840
Do k = 1,p_levels ! Loop over pressure levels UIE2F404.841
pos=(k -1)*(p_field-row_length) UIE2F404.842
UIE2F404.843
Call vert_interp(work1, !(IN) v (2nd dump) UIE2F404.844
& p_field-row_length, !(IN) No. of v points/lev UIE2F404.845
& p_levels, !(IN) No. of press levels. UIE2F404.846
& work4(pos+1), !(IN) Heights of v field UIE2F404.847
& ! in 1st UM dump. UIE2F404.848
& work2, !(IN) Heights of v field UIE2F404.849
& ! in 2nd UM dump. UIE2F404.850
& Linear, !(IN) Linear interpolation UIE2F404.851
& work5(pos+1)) !(OUT)v (2nd dump) UIE2F404.852
& ! interpolated onto height UIE2F404.853
& ! field of u in 1st UM dump. UIE2F404.854
UIE2F404.855
End do ! k UIE2F404.856
UIE2F404.857
Call Locate(stashcode_ND_v, ! Intent(IN) PARAMETER name for UIE2F404.858
& ! STASH item/sect. code for v. UIE2F404.859
& pp_itemc, ! Intent(IN) Array of item codes. UIE2F404.860
& n_types, ! Intent(IN) No. of field types. UIE2F404.861
& pos) ! Intent(OUT) Position of v UIE2F404.862
& ! field in pp_itemc. UIE2F404.863
UIE2F404.864
! Reorganisation of v field for LS storage. UIE2F404.865
Call PF_Reverse(work5, !(IN/OUT) V UIE2F404.866
& row_length, !(IN) No. of columns. UIE2F404.867
& p_levels, !(IN) No. of p levels. UIE2F404.868
& p_rows-1, !(IN) No. v of rows. UIE2F404.869
& len_realhd, UIE2F404.870
& realhd, UIE2F404.871
& pp_pos(pos), UIE2F404.872
& len1_lookup, UIE2F404.873
& len2_lookup, UIE2F404.874
*CALL ARGPPX UIE2F404.875
& lookup, UIE2F404.876
& lookup) UIE2F404.877
UIE2F404.878
UIE2F404.879
Call Writflds(nftout, !(IN) Unit number of LS dump. UIE2F404.880
& p_levels, !(IN) Write v on all press levels. UIE2F404.881
& pp_pos(pos), !(IN) Field no. in LS dump. UIE2F404.882
& lookup, !(IN) Lookup table of LS dump. UIE2F404.883
& len1_lookup, !(IN) 1st dim of Lookup. UIE2F404.884
& work5, !(IN) Write v from work3 UIE2F404.885
& p_field, !(IN) No. of v points per level. UIE2F404.886
& fixhd, !(IN) LS Fixed header record. UIE2F404.887
*CALL ARGPPX UIE2F404.888
& icode,cmessage) !(IN/OUT) Error flags. UIE2F404.889
UIE2F404.890
If (icode.ne.0) Call abort_io('INIT_LS',cmessage, UIE2F404.891
& icode,nftout) UIE2F404.892
UIE2F404.893
! Need to reuse work space - store v in work1 for calc. UIE2F404.894
! of polar rows of u. UIE2F404.895
Do k =1,p_levels UIE2F404.896
pos = p_field*(k-1) UIE2F404.897
Do i =1,p_field UIE2F404.898
UIE2F404.899
work1(i+pos) = work5(i+pos) UIE2F404.900
UIE2F404.901
End do UIE2F404.902
End do UIE2F404.903
UIE2F404.904
! Cu_hgt calculates the height at each u point for the second UIE2F404.905
! UM dump by linear interpolation of the heights of the pressure UIE2F404.906
! levels. Use work2 to hold the height of each u point. UIE2F404.907
UIE2F404.908
Do k=1,p_levels UIE2F404.909
UIE2F404.910
pos = len1_flddepc+p_field UIE2F404.911
pos1 = p_field*(k-1) UIE2F404.912
UIE2F404.913
Call Cu_hgt(flddepc(pos+1), !(IN) Pressure level heights of UIE2F404.914
& work2(pos1+1), !(OUT)Heights of u field. UIE2F404.915
& p_field, !(IN) No. of p points. UIE2F404.916
& p_levels, !(IN) No. of press levels. UIE2F404.917
& k, UIE2F404.918
& row_length, !(IN) No. of columns. UIE2F404.919
& (fixhd(4).eq.103)) !(IN) Equatorial lat-lon LAM gri UIE2F404.920
UIE2F404.921
! Calculaton of the height at each u point for the first UIE2F404.922
! UM dump. Read into work4. UIE2F404.923
UIE2F404.924
Call Cu_hgt(flddepc_um1(pos+1),!(IN) Pressure level heights of UIE2F404.925
& work4(pos1+1), !(OUT)Heights of u field. UIE2F404.926
& p_field, !(IN) No. of p points. UIE2F404.927
& p_levels, !(IN) No. of press levels. UIE2F404.928
& k, UIE2F404.929
& row_length, !(IN) No. of columns. UIE2F404.930
& (fixhd(4).eq.103)) !(IN) Equatorial lat-lon LAM gri UIE2F404.931
UIE2F404.932
UIE2F404.933
End do UIE2F404.934
UIE2F404.935
! Interpolation of u (work3) from the second UM dump to the UIE2F404.936
& ! first UM dump points. UIE2F404.937
Do k = 1,p_levels ! Loop over levels UIE2F404.938
pos=(k -1)*p_field UIE2F404.939
UIE2F404.940
Call vert_interp(work3, !(IN) u (2nd dump) UIE2F404.941
& p_field, !(IN) No. of points per lev UIE2F404.942
& p_levels, !(IN) No. of press levels. UIE2F404.943
& work4(pos+1), !(IN) Heights of u field UIE2F404.944
& ! in 1st UM dump. UIE2F404.945
& work2, !(IN) Heights of u field UIE2F404.946
& ! in 2nd UM dump. UIE2F404.947
& Linear, !(IN) Linear interpolation UIE2F404.948
& work5(1+pos)) !(OUT)u (2nd dump) interpolated UIE2F404.949
& ! onto height field of u in UIE2F404.950
& ! 1st UM dump. UIE2F404.951
UIE2F404.952
End do ! k UIE2F404.953
UIE2F404.954
Call Locate(stashcode_ND_u, ! Intent(IN) PARAMETER name for UIE2F404.955
& ! STASH item/sect. code for u. UIE2F404.956
& pp_itemc, ! Intent(IN) Array of item codes. UIE2F404.957
& n_types, ! Intent(IN) No. of field types. UIE2F404.958
& pos) ! Intent(OUT) Position of u UIE2F404.959
& ! field in pp_itemc. UIE2F404.960
UIE2F404.961
! Reorganisation of u field for LS storage. UIE2F404.962
Call PF_Reverse(work5, !(IN/OUT) U UIE2F404.963
& row_length, !(IN) No. of columns. UIE2F404.964
& p_levels, !(IN) No. of p levels. UIE2F404.965
& p_rows, !(IN) No. of rows. UIE2F404.966
& len_realhd, UIE2F404.967
& realhd, UIE2F404.968
& pp_pos(pos), UIE2F404.969
& len1_lookup, UIE2F404.970
& len2_lookup, UIE2F404.971
*CALL ARGPPX UIE2F404.972
& lookup, UIE2F404.973
& lookup) UIE2F404.974
UIE2F404.975
If (fixhd(4) .eq. 0) then UIE2F404.976
UIE2F404.977
Call Polar_Row_Adj(work5, UIE2F404.978
& work1, UIE2F404.979
& row_length, UIE2F404.980
& p_levels, UIE2F404.981
& p_rows, UIE2F404.982
& pp_pos(pos), UIE2F404.983
& len1_lookup,len2_lookup, UIE2F404.984
*CALL ARGPPX UIE2F404.985
& lookup,lookup) UIE2F404.986
UIE2F404.987
End if UIE2F404.988
UIE2F404.989
UIE2F404.990
Call Writflds(nftout, !(IN) Unit number of LS dump. UIE2F404.991
& p_levels, !(IN) Write u on all press levels. UIE2F404.992
& pp_pos(pos), !(IN) Field no. in LS dump. UIE2F404.993
& lookup, !(IN) Lookup table of LS dump. UIE2F404.994
& len1_lookup, !(IN) 1st dim of Lookup. UIE2F404.995
& work5, !(IN) Write u from work5 UIE2F404.996
& p_field, !(IN) No. of p points per level. UIE2F404.997
& fixhd, !(IN) LS Fixed header record. UIE2F404.998
*CALL ARGPPX UIE2F404.999
& icode,cmessage) !(IN/OUT) Error flags. UIE2F404.1000
UIE2F404.1001
If (icode.ne.0) Call abort_io('INIT_LS',cmessage, UIE2F404.1002
& icode,nftout) UIE2F404.1003
UIE2F404.1004
UIE2F404.1005
Else UIE2F404.1006
UIE2F404.1007
UIE2F404.1008
Call Locate(stashcode_ND_v, ! Intent(IN) PARAMETER name for UIE2F404.1009
& ! STASH item/sect. code for v. UIE2F404.1010
& pp_itemc, ! Intent(IN) Array of item codes. UIE2F404.1011
& n_types, ! Intent(IN) No. of field types. UIE2F404.1012
& pos) ! Intent(OUT) Position of v UIE2F404.1013
& ! field in pp_itemc. UIE2F404.1014
UIE2F404.1015
! Reorganisation of v field for LS storage. UIE2F404.1016
Call PF_Reverse(work1, !(IN/OUT) V UIE2F404.1017
& row_length, !(IN) No. of columns. UIE2F404.1018
& p_levels, !(IN) No. of p levels. UIE2F404.1019
& p_rows-1, !(IN) No. of v rows. UIE2F404.1020
& len_realhd, UIE2F404.1021
& realhd, UIE2F404.1022
& pp_pos(pos), UIE2F404.1023
& len1_lookup, UIE2F404.1024
& len2_lookup, UIE2F404.1025
*CALL ARGPPX UIE2F404.1026
& lookup, UIE2F404.1027
& lookup) UIE2F404.1028
UIE2F404.1029
UIE2F404.1030
Call Writflds(nftout, !(IN) Unit number of LS dump. UIE2F404.1031
& p_levels, !(IN) Write v on all press levels. UIE2F404.1032
& pp_pos(pos), !(IN) Field no. in LS dump. UIE2F404.1033
& lookup, !(IN) Lookup table of LS dump. UIE2F404.1034
& len1_lookup, !(IN) 1st dim of Lookup. UIE2F404.1035
& work1, !(IN) Write v from work1 UIE2F404.1036
& p_field, !(IN) No. of v points per level. UIE2F404.1037
& fixhd, !(IN) LS Fixed header record. UIE2F404.1038
*CALL ARGPPX UIE2F404.1039
& icode,cmessage) !(IN/OUT) Error flags. UIE2F404.1040
UIE2F404.1041
If (icode.ne.0) Call abort_io('INIT_LS',cmessage, UIE2F404.1042
& icode,nftout) UIE2F404.1043
UIE2F404.1044
Call Locate(stashcode_ND_u, ! Intent(IN) PARAMETER name for UIE2F404.1045
& ! STASH item/sect. code for u. UIE2F404.1046
& pp_itemc, ! Intent(IN) Array of item codes. UIE2F404.1047
& n_types, ! Intent(IN) No. of field types. UIE2F404.1048
& pos) ! Intent(OUT) Position of u UIE2F404.1049
& ! field in pp_itemc. UIE2F404.1050
UIE2F404.1051
! Reorganisation of u field for LS storage. UIE2F404.1052
Call PF_Reverse(work3, !(IN/OUT) U UIE2F404.1053
& row_length, !(IN) No. of columns. UIE2F404.1054
& p_levels, !(IN) No. of p levels. UIE2F404.1055
& p_rows, !(IN) No. of rows. UIE2F404.1056
& len_realhd, UIE2F404.1057
& realhd, UIE2F404.1058
& pp_pos(pos), UIE2F404.1059
& len1_lookup, UIE2F404.1060
& len2_lookup, UIE2F404.1061
*CALL ARGPPX UIE2F404.1062
& lookup, UIE2F404.1063
& lookup) UIE2F404.1064
UIE2F404.1065
If (fixhd(4) .eq. 0) then UIE2F404.1066
UIE2F404.1067
Call Polar_Row_Adj(work3, UIE2F404.1068
& work1, UIE2F404.1069
& row_length, UIE2F404.1070
& p_levels, UIE2F404.1071
& p_rows, UIE2F404.1072
& pp_pos(pos), UIE2F404.1073
& len1_lookup,len2_lookup, UIE2F404.1074
*CALL ARGPPX UIE2F404.1075
& lookup,lookup) UIE2F404.1076
UIE2F404.1077
End if UIE2F404.1078
UIE2F404.1079
Call Writflds(nftout, !(IN) Unit number of output LS dump UIE2F404.1080
& p_levels, !(IN) Write u on all press levels. UIE2F404.1081
& pp_pos(pos), !(IN) Field no. in LS dump. UIE2F404.1082
& lookup, !(IN) Lookup table of output LS dum UIE2F404.1083
& len1_lookup, !(IN) 1st dim of Lookup. UIE2F404.1084
& work3, !(IN) Write u from work3 UIE2F404.1085
& p_field, !(IN) No. of p points per level. UIE2F404.1086
& fixhd, !(IN) Fixed header record of LS dum UIE2F404.1087
*CALL ARGPPX UIE2F404.1088
& icode,cmessage) !(IN/OUT) Error flags. UIE2F404.1089
UIE2F404.1090
If (icode.ne.0) Call abort_io('INIT_LS',cmessage, UIE2F404.1091
& icode,nftout) UIE2F404.1092
INITLS1A.2374
End if ! umtwo INITLS1A.2375
INITLS1A.2376
!6.3 Write Pstar to LS dump INITLS1A.2377
INITLS1A.2378
Call Locate(stashcode_OD_pstar, ! Intent(IN) PARAMETER name for INITLS1A.2379
& ! STASH item/sect. code for pstar INITLS1A.2380
& pp_itemc, ! Intent(IN) Array of item codes. INITLS1A.2381
& n_types, ! Intent(IN) No. of field types. INITLS1A.2382
& pos) ! Intent(OUT) Position of pstar INITLS1A.2383
& ! field in pp_itemc. INITLS1A.2384
INITLS1A.2385
! Reorganisation of pstar field for LS storage. INITLS1A.2386
Call PF_Reverse(pstar, !(IN/OUT) P* field. INITLS1A.2387
& row_length, !(IN) No. of columns. INITLS1A.2388
& 1, !(IN) Single level field. INITLS1A.2389
& p_rows, !(IN) No. of p rows. INITLS1A.2390
& len_realhd, INITLS1A.2391
& realhd, INITLS1A.2392
& pp_pos(pos), INITLS1A.2393
& len1_lookup, INITLS1A.2394
& len2_lookup, INITLS1A.2395
*CALL ARGPPX INITLS1A.2396
& lookup, INITLS1A.2397
& lookup) INITLS1A.2398
INITLS1A.2399
Call Writflds(nftout, !(IN) Unit number of output LS dump. INITLS1A.2400
& 1, !(IN) Write pstar on single level. INITLS1A.2401
& pp_pos(pos),!(IN) Field no. in LS dump. INITLS1A.2402
& lookup, !(IN) Lookup table of output LS dump. INITLS1A.2403
& len1_lookup,!(IN) 1st dim of Lookup. INITLS1A.2404
& pstar, !(IN) Write pstar from array pstar. INITLS1A.2405
& p_field, !(IN) No. of p points per level. INITLS1A.2406
& fixhd, !(IN) Fixed header record of LS dump. INITLS1A.2407
*CALL ARGPPX INITLS1A.2408
& icode,cmessage)!(IN/OUT) Error flags. INITLS1A.2409
INITLS1A.2410
If (icode.ne.0) Call abort_io('INIT_LS',cmessage,icode,nftout) INITLS1A.2411
INITLS1A.2412
INITLS1A.2413
! 7.0 Overwrite header information of LS dump. INITLS1A.2414
INITLS1A.2415
!7.1 Change fixed header and Real constants. INITLS1A.2416
INITLS1A.2417
fixhd(3) = 5 ! indicates radial vertical co-ordinate INITLS1A.2418
fixhd(9) = 3 ! indicates radial c grid INITLS1A.2419
INITLS1A.2420
! Although a radial vertical co-ordinate is defined, it is the INITLS1A.2421
! height coordinate which is stored in the fields of constants. INITLS1A.2422
! realhd(7) is set to the mean earth radius to ensure that the INITLS1A.2423
! vertical coordinate (radius from the earth centre) is easily fou INITLS1A.2424
realhd(7) = EarthRadius INITLS1A.2425
INITLS1A.2426
If (umtwo) then !Code for conversion of 2nd UM dump->LS dump only INITLS1A.2427
INITLS1A.2428
!7.2 Overwrite level boundaries of 2nd UM dump with 1st dump hei INITLS1A.2429
Do k = 1,(p_levels +1)*2 INITLS1A.2430
pos = (k -1)*p_field INITLS1A.2431
INITLS1A.2432
Do i = 1,p_field INITLS1A.2433
INITLS1A.2434
flddepc(i+pos) = flddepc_um1(i+pos) INITLS1A.2435
INITLS1A.2436
End do ! i INITLS1A.2437
End do ! k INITLS1A.2438
INITLS1A.2439
End if ! umtwo INITLS1A.2440
INITLS1A.2441
INITLS1A.2442
! Reorganisation of the height field for LS storage. INITLS1A.2443
Call PF_Reverse(flddepc, !(IN/OUT)Orography,pressure and INITLS1A.2444
& ! theta level heights INITLS1A.2445
& row_length, !(IN) No. of columns. INITLS1A.2446
& (p_levels+1)*2, !(IN) Total number of levels. INITLS1A.2447
& p_rows, !(IN) No. of rows. INITLS1A.2448
& len_realhd, INITLS1A.2449
& realhd, INITLS1A.2450
& 0, INITLS1A.2451
& len1_lookup, INITLS1A.2452
& len2_lookup, INITLS1A.2453
*CALL ARGPPX INITLS1A.2454
& lookup, INITLS1A.2455
& lookup) INITLS1A.2456
INITLS1A.2457
! 7.3 Write out changed header information in space of old header INITLS1A.2458
INITLS1A.2459
*IF DEF,TIMER INITLS1A.2460
Call Timer('WRITHEAD',3) INITLS1A.2461
*ENDIF INITLS1A.2462
INITLS1A.2463
Call setpos(nftout,0,icode) ! Position at start of file INITLS1A.2464
INITLS1A.2465
Call Writhead(nftout, INITLS1A.2466
& fixhd,len_fixhd, INITLS1A.2467
& inthd,len_inthd, INITLS1A.2468
& realhd,len_realhd, INITLS1A.2469
& levdepc,len1_levdepc,len2_levdepc, INITLS1A.2470
& rowdepc,len1_rowdepc,len2_rowdepc, INITLS1A.2471
& coldepc,len1_coldepc,len2_coldepc, INITLS1A.2472
& flddepc,len1_flddepc,len2_flddepc, INITLS1A.2473
& extcnst,len_extcnst, INITLS1A.2474
& dumphist,len_dumphist, INITLS1A.2475
& cfi1,len_cfi1, INITLS1A.2476
& cfi2,len_cfi2, INITLS1A.2477
& cfi3,len_cfi3, INITLS1A.2478
& lookup,len1_lookup,len2_lookup, INITLS1A.2479
& len_data, INITLS1A.2480
*CALL ARGPPX INITLS1A.2481
& start_block, INITLS1A.2482
& icode,cmessage) INITLS1A.2483
INITLS1A.2484
*IF DEF,TIMER INITLS1A.2485
Call Timer('WRITHEAD',4) INITLS1A.2486
*ENDIF INITLS1A.2487
INITLS1A.2488
Return INITLS1A.2489
End INITLS1A.2490
*ENDIF INITLS1A.2491