SUBROUTINE UV_ADJ 2,14UVADJ1C.55
1 (U,V,THETA,Q,OROG_HEIGHT,PSTAR,F1, UVADJ1C.56
2 F2,F3,SEC_U_LATITUDE,TAN_U_LATITUDE,AK,BK,DELTA_AK, UVADJ1C.57
3 DELTA_BK,LATITUDE_STEP_INVERSE,ADJUSTMENT_TIMESTEP, UVADJ1C.58
4 LONGITUDE_STEP_INVERSE,RS, UVADJ1C.59
*CALL ARGFLDPT 
UVADJ1C.60
5 U_FIELD,P_FIELD,ROW_LENGTH,P_LEVELS, UVADJ1C.61
6 Q_LEVELS,CALL_NUMBER,AKH,BKH,P_EXNER, UVADJ1C.62
8 ADJUSTMENT_STEPS,L_PHI_OUT,PHI_OUT,LLINTS, UVADJ1C.63
9 LWHITBROM) UVADJ1C.64
UVADJ1C.65
IMPLICIT NONE UVADJ1C.66
UVADJ1C.67
LOGICAL UVADJ1C.68
* L_PHI_OUT !IN. TRUE IF PHI OUTPUT REQUIRED AS UVADJ1C.69
* ! DIAGNOSTIC. UVADJ1C.70
*,LLINTS !Switch for linear TS calc in CALC_TS UVADJ1C.71
*,LWHITBROM !Switch for White & Bromley terms UVADJ1C.72
UVADJ1C.73
INTEGER UVADJ1C.74
* P_FIELD !IN DIMENSION OF FIELDS ON PRESSSURE GRID UVADJ1C.75
*, U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID UVADJ1C.76
*, P_LEVELS !IN NUMBER OF PRESSURE LEVELS. UVADJ1C.77
*, Q_LEVELS !IN NUMBER OF MOIST LEVELS. UVADJ1C.78
*, ROW_LENGTH !IN NUMBER OF POINTS PER ROW UVADJ1C.79
*, CALL_NUMBER !IN ADJUSTMENT STEP NUMBER UVADJ1C.80
*, ADJUSTMENT_STEPS !IN NUMBER OF ADJUSTMENT STEPS UVADJ1C.81
! All TYPFLDPT arguments are intent IN UVADJ1C.82
*CALL TYPFLDPT UVADJ1C.83
UVADJ1C.84
REAL UVADJ1C.85
* THETA(P_FIELD,P_LEVELS)!INOUT THETA FIELD UVADJ1C.86
*,Q(P_FIELD,Q_LEVELS) !INOUT Q FIELD UVADJ1C.87
*,PSTAR(P_FIELD) !INOUT PSTAR FIELD UVADJ1C.88
*,RS(P_FIELD,P_LEVELS) !INOUT PRIMARY MODEL ARRAY FOR RS FIELD UVADJ1C.89
*,U(U_FIELD,P_LEVELS) !INOUT U FIELD UVADJ1C.90
*,V(U_FIELD,P_LEVELS) !INOUT V FIELD UVADJ1C.91
UVADJ1C.92
REAL UVADJ1C.93
* P_EXNER(P_FIELD,P_LEVELS+1) !IN HOLDS EXNER PRESSURE AT HALF UVADJ1C.94
* ! LEVELS UVADJ1C.95
*,OROG_HEIGHT(P_FIELD) !IN OROGRAPHIC HEIGHT FIELD UVADJ1C.96
UVADJ1C.97
REAL UVADJ1C.98
* DELTA_AK(P_LEVELS) !IN LAYER THICKNESS UVADJ1C.99
*,DELTA_BK(P_LEVELS) !IN LAYER THICKNESS UVADJ1C.100
*,AK(P_LEVELS) !IN VALUE OF A AT P POINTS UVADJ1C.101
*,BK(P_LEVELS) !IN VALUE OF B AT P POINTS UVADJ1C.102
*,AKH(P_LEVELS+1) !IN VALUE OF A AT HALF LEVELS. UVADJ1C.103
*,BKH(P_LEVELS+1) !IN VALUE OF B AT HALF LEVELS. UVADJ1C.104
*,SEC_U_LATITUDE(U_FIELD) !IN 1/COS(LAT) AT U POINTS (2-D ARRAY) UVADJ1C.105
*,TAN_U_LATITUDE(U_FIELD) !IN TAN(LAT) AT U POINTS (2-D ARRAY) UVADJ1C.106
UVADJ1C.107
REAL UVADJ1C.108
* F1(U_FIELD) !IN A CORIOLIS TERM SEE DOCUMENTATION UVADJ1C.109
*,F2(U_FIELD) !IN A CORIOLIS TERM SEE DOCUMENTATION UVADJ1C.110
*,F3(U_FIELD) !IN A CORIOLIS TERM SEE DOCUMENTATION UVADJ1C.111
*,LONGITUDE_STEP_INVERSE !IN 1/LONGITUDE INCREMENT UVADJ1C.112
*,LATITUDE_STEP_INVERSE !IN 1/LATITUDE INCREMENT UVADJ1C.113
*,ADJUSTMENT_TIMESTEP !IN UVADJ1C.114
UVADJ1C.115
REAL UVADJ1C.116
* PHI_OUT(P_FIELD,P_LEVELS) !OUT. PHI DIAGNOSTIC UVADJ1C.117
REAL RECIP UVADJ1C.118
UVADJ1C.119
C*--------------------------------------------------------------------- UVADJ1C.120
UVADJ1C.121
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- UVADJ1C.122
C DEFINE LOCAL ARRAYS: UVADJ1C.123
UVADJ1C.124
REAL UVADJ1C.125
* DPHI_BY_DLATITUDE(P_FIELD) !HOLDS HORIZONTAL PRESSURE GRADIENT UVADJ1C.126
* !IN X-DIRECTION AT U POINTS UVADJ1C.127
*,DPHI_BY_DLONGITUDE(P_FIELD)!HOLDS HORIZONTAL PRESSURE GRADIENT UVADJ1C.128
* !IN Y-DIRECTION AT U POINTS UVADJ1C.129
*,P(P_FIELD) !HOLDS PRESSURE AT A MODEL LEVEL UVADJ1C.130
*,RECIP_RS_UV(U_FIELD,P_LEVELS) !HOLDS 1/RS AT U POINTS UVADJ1C.131
*,PHI_FULL_LEVEL(P_FIELD) !HOLDS GEOPOTENTIAL AT A FULL LEVEL UVADJ1C.132
*,PHI_HALF_LEVEL(P_FIELD) !HOLDS GEOPOT AT A HALF LEVEL UVADJ1C.133
*,DELTA_P_P_EXNER_BY_DELTAP(P_FIELD) ! UVADJ1C.134
UVADJ1C.135
REAL UVADJ1C.136
* THETAS(P_FIELD,P_LEVELS) !HOLDS THETAV + MU*THETAS UVADJ1C.137
*,TS(P_FIELD) !HOLDS STANDARD TEMPERATURE UVADJ1C.138
*,WORK_U(U_FIELD) !GENERAL WORKSPACE FOR VARIABLES UVADJ1C.139
* !AT U POINTS UVADJ1C.140
*,WORK_P(P_FIELD) !GENERAL WORKSPACE FOR VARIABLES UVADJ1C.141
* !AT P POINTS UVADJ1C.142
*IF -DEF,GLOBAL UVADJ1C.143
*,U_TEMP_R(U_FIELD),V_TEMP_R(U_FIELD) UVADJ1C.144
*,U_TEMP_L(U_FIELD),V_TEMP_L(U_FIELD) UVADJ1C.145
*ENDIF UVADJ1C.146
INTEGER IP,IJP,J UVADJ1C.147
UVADJ1C.148
C*--------------------------------------------------------------------- UVADJ1C.149
C DEFINE LOCAL VARIABLES UVADJ1C.150
INTEGER POINTS ! Number of points with valid part of field UVADJ1C.151
UVADJ1C.152
*IF DEF,MPP UVADJ1C.153
*IF DEF,GLOBAL UVADJ1C.154
INTEGER info UVADJ1C.155
*ELSE UVADJ1C.156
INTEGER row_start_offset,row_end_offset UVADJ1C.157
! offsets required to mark out the updatable area for LAM MPP code UVADJ1C.158
*ENDIF UVADJ1C.159
*ENDIF UVADJ1C.160
REAL UVADJ1C.161
* HALF_ADJUSTMENT_TIMESTEP UVADJ1C.162
*, RECIP_G UVADJ1C.163
*IF DEF,GLOBAL UVADJ1C.164
INTEGER np,sp ! points in field refering to poles UVADJ1C.165
REAL UVADJ1C.166
& MU_NORTH_POLE(P_LEVELS) ! MU at North Pole UVADJ1C.167
&, MU_SOUTH_POLE(P_LEVELS) ! MU at South Pole UVADJ1C.168
*ENDIF UVADJ1C.169
UVADJ1C.170
C COUNT VARIABLES FOR DO LOOPS ETC. UVADJ1C.171
INTEGER UVADJ1C.172
* I,IJ,IK,K,II,IX1 UVADJ1C.173
C WORK-SPACE SCALARS UVADJ1C.174
REAL UVADJ1C.175
* TEMP1,TEMP2 UVADJ1C.176
* ,PKP1,PK ! Pressures at half levels k+1 and k UVADJ1C.177
* ,c1,c2,WORK_V UVADJ1C.178
C LOGICAL VARIABLE UVADJ1C.179
LOGICAL UVADJ1C.180
* CONSTANT_PRESSURE ! TRUE IF ON A CONSTANT PRESSURE SURFACE UVADJ1C.181
UVADJ1C.182
C*L EXTERNAL SUBROUTINE CALLS:--------------------------------------- UVADJ1C.183
UVADJ1C.184
EXTERNAL P_TO_UV,POLAR_UV,UV_TO_P UVADJ1C.185
* ,CALC_TS,CALC_RS UVADJ1C.186
C*--------------------------------------------------------------------- UVADJ1C.187
CL CALL COMDECK TO OBTAIN CONSTANTS USED. UVADJ1C.188
UVADJ1C.189
*CALL C_UVADJ UVADJ1C.190
UVADJ1C.191
CL MAXIMUM VECTOR LENGTH ASSUMED IS P_FIELD UVADJ1C.192
CL--------------------------------------------------------------------- UVADJ1C.193
CL INTERNAL STRUCTURE INCLUDING SUBROUTINE CALLS: UVADJ1C.194
CL--------------------------------------------------------------------- UVADJ1C.195
CL UVADJ1C.196
*CALL P_EXNERC UVADJ1C.197
UVADJ1C.198
CL--------------------------------------------------------------------- UVADJ1C.199
CL SECTION 1. INITIALISATION UVADJ1C.200
CL--------------------------------------------------------------------- UVADJ1C.201
C INCLUDE LOCAL CONSTANTS FROM GENERAL CONSTANTS BLOCK UVADJ1C.202
UVADJ1C.203
POINTS=LAST_P_VALID_PT-FIRST_VALID_PT+1 UVADJ1C.204
! Number of points to be processed by CALC_RS/TS. For non-MPP runs UVADJ1C.205
! this is simply P_FIELD, for MPP, it is all the points, minus any UVADJ1C.206
! unused halo areas (ie. the halo above North pole row, and beneath UVADJ1C.207
! South pole row) UVADJ1C.208
UVADJ1C.209
HALF_ADJUSTMENT_TIMESTEP = ADJUSTMENT_TIMESTEP*.5 UVADJ1C.210
RECIP_G = 1./G UVADJ1C.211
UVADJ1C.212
! Initialise work arrays UVADJ1C.213
! cdir$ cache_bypass WORK_U GSM4F405.4
DO I=1,U_FIELD UVADJ1C.215
WORK_U(I)=0.0 UVADJ1C.216
ENDDO UVADJ1C.217
! cdir$ cache_bypass WORK_P GSM4F405.5
DO I=1,P_FIELD UVADJ1C.219
WORK_P(I)=0.0 UVADJ1C.220
ENDDO UVADJ1C.221
UVADJ1C.222
CL LOOP OVER ALL PRESSURE LEVELS. UVADJ1C.223
UVADJ1C.224
DO K=1,P_LEVELS UVADJ1C.225
UVADJ1C.226
CL--------------------------------------------------------------------- UVADJ1C.227
CL IF (.NOT.LWHITBROM) THEN UVADJ1C.228
CL SECTION 2. STORE RADIUS OF EARTH IN HORIZONTAL FIELD. UVADJ1C.229
CL ELSE UVADJ1C.230
CL SECTION 2. CALCULATE RS AT LEVEL K. UVADJ1C.231
CL END IF UVADJ1C.232
CL--------------------------------------------------------------------- UVADJ1C.233
UVADJ1C.234
C---------------------------------------------------------------------- UVADJ1C.235
CL IF (.NOT.LWHITBROM) THEN UVADJ1C.236
CL SECTION 2.1. STORE RADIUS OF EARTH IN HORIZONTAL FIELD. UVADJ1C.237
CL ELSE UVADJ1C.238
CL SECTION 2.1. CALL CALC_RS TO GET RS ON FIRST CALL ONLY. UVADJ1C.239
CL ALSO RETURNS TS SAVING CALL TO CALC_TS IN 3.4 UVADJ1C.240
CL END IF UVADJ1C.241
C---------------------------------------------------------------------- UVADJ1C.242
UVADJ1C.243
IF (.NOT.LWHITBROM) THEN UVADJ1C.244
! loop over all points, including valid halos UVADJ1C.245
DO 210 I=1,P_FIELD UVADJ1C.246
RS(I,K) = A UVADJ1C.247
RECIP_RS_UV(I,K) = 1.0 UVADJ1C.248
210 CONTINUE UVADJ1C.249
ELSE UVADJ1C.250
IF(CALL_NUMBER.EQ.1) THEN UVADJ1C.251
UVADJ1C.252
! Initialise RS so that P_TO_UV works in MPP mode UVADJ1C.253
DO I=1,FIRST_VALID_PT-1 UVADJ1C.254
RS(I,K)=1.0 UVADJ1C.255
ENDDO UVADJ1C.256
DO I=FIRST_VALID_PT+POINTS-1,P_FIELD UVADJ1C.257
RS(I,K)=1.0 UVADJ1C.258
ENDDO UVADJ1C.259
UVADJ1C.260
IF(K.NE.1) THEN UVADJ1C.261
CALL CALC_RS(PSTAR(FIRST_VALID_PT),AK,BK,TS(FIRST_VALID_PT), UVADJ1C.262
& RS(FIRST_VALID_PT,K-1), UVADJ1C.263
& RS(FIRST_VALID_PT,K), UVADJ1C.264
& POINTS,K,P_LEVELS,LLINTS) UVADJ1C.265
ELSE UVADJ1C.266
C IF LEVEL 1 CALC_RS NEEDS A DUMMY ARRAY IN PLACE OF RS( ,K-1) UVADJ1C.267
CALL CALC_RS(PSTAR(FIRST_VALID_PT),AK,BK,TS(FIRST_VALID_PT), UVADJ1C.268
& RS(FIRST_VALID_PT,K+1), UVADJ1C.269
& RS(FIRST_VALID_PT,K), UVADJ1C.270
& POINTS,K,P_LEVELS,LLINTS) UVADJ1C.271
END IF UVADJ1C.272
END IF UVADJ1C.273
ENDIF ! LWHITBROM UVADJ1C.274
UVADJ1C.275
C---------------------------------------------------------------------- UVADJ1C.276
CL IF (.NOT.LWHITBROM) THEN UVADJ1C.277
CL SECTION 2.2. STORE 1./RADIUS OF EARTH IN HORIZONTAL FIELD. UVADJ1C.278
CL ELSE UVADJ1C.279
CL SECTION 2.2. CALL P_TO_UV TO GET RS AT U POINTS. UVADJ1C.280
CL END IF UVADJ1C.281
C---------------------------------------------------------------------- UVADJ1C.282
UVADJ1C.283
IF (.NOT.LWHITBROM) THEN UVADJ1C.284
! loop over all points, including valid halos UVADJ1C.285
DO 220 I=FIRST_VALID_PT,LAST_U_VALID_PT UVADJ1C.286
RECIP_RS_UV(I,K) = 1./A UVADJ1C.287
220 CONTINUE UVADJ1C.288
ELSE UVADJ1C.289
C STORE RS AT U POINTS IN RECIP_RS_UV UVADJ1C.290
UVADJ1C.291
CALL P_TO_UV(RS(1,K),RECIP_RS_UV(1,K),P_FIELD, UVADJ1C.292
& U_FIELD,ROW_LENGTH,tot_P_ROWS) UVADJ1C.293
UVADJ1C.294
ENDIF UVADJ1C.295
ENDDO UVADJ1C.296
*IF DEF,MPP UVADJ1C.297
IF (LWHITBROM) THEN UVADJ1C.298
CALL SWAPBOUNDS(RECIP_RS_UV,ROW_LENGTH,tot_P_ROWS, UVADJ1C.299
& EW_Halo,NS_Halo,P_LEVELS) UVADJ1C.300
ENDIF UVADJ1C.301
*ENDIF UVADJ1C.302
CL--------------------------------------------------------------------- UVADJ1C.303
CL SECTION 3. CALCULATE PHI AT LEVEL K-1/2, EXNER AT LEVEL K, UVADJ1C.304
CL IF (.NOT.LWHITBROM) THEN UVADJ1C.305
CL AND THETAV. UVADJ1C.306
CL ELSE UVADJ1C.307
CL AND THETAV + MU * THETAS AT LEVEL K. UVADJ1C.308
CL END IF UVADJ1C.309
CL--------------------------------------------------------------------- UVADJ1C.310
*IF DEF,GLOBAL UVADJ1C.311
! Set up array of MU values at poles for use in section 3.5 UVADJ1C.312
! put into north_pole_mu(level) and south_pole_mu(level) UVADJ1C.313
IF (LWHITBROM) THEN UVADJ1C.314
! North Pole first UVADJ1C.315
*IF DEF,MPP UVADJ1C.316
IF (MY_PROC_ID .EQ. NP_PROC_ID) THEN UVADJ1C.317
*ENDIF UVADJ1C.318
np=TOP_ROW_START+FIRST_ROW_PT-1 UVADJ1C.319
DO K=1,P_LEVELS UVADJ1C.320
MU_NORTH_POLE(K)=(U(np,K)*U(np,K)+V(np,K)*V(np,K))/ UVADJ1C.321
& RS(np,K)*RECIP_G UVADJ1C.322
ENDDO UVADJ1C.323
*IF DEF,MPP UVADJ1C.324
ENDIF UVADJ1C.325
IF (at_top_of_LPG) THEN UVADJ1C.326
! Send this array to everyone on top processor row UVADJ1C.327
CALL GCG_RBCAST(123,P_LEVELS,NP_PROC_ID, UVADJ1C.328
& GC_ROW_GROUP,info,MU_NORTH_POLE) UVADJ1C.329
ENDIF UVADJ1C.330
*ENDIF UVADJ1C.331
UVADJ1C.332
! And now the South Pole UVADJ1C.333
*IF DEF,MPP UVADJ1C.334
IF (MY_PROC_ID .EQ. SP_PROC_ID) THEN UVADJ1C.335
*ENDIF UVADJ1C.336
sp=U_BOT_ROW_START+LAST_ROW_PT-1 UVADJ1C.337
DO K=1,P_LEVELS UVADJ1C.338
MU_SOUTH_POLE(K)=(U(sp,K)*U(sp,K)+V(sp,K)*V(sp,K))/ UVADJ1C.339
& RS(sp+ROW_LENGTH,K)*RECIP_G UVADJ1C.340
ENDDO UVADJ1C.341
*IF DEF,MPP UVADJ1C.342
ENDIF UVADJ1C.343
IF (at_base_of_LPG) THEN UVADJ1C.344
! Send this array to everyone on bottom processor row UVADJ1C.345
CALL GCG_RBCAST(321,P_LEVELS,SP_PROC_ID, UVADJ1C.346
& GC_ROW_GROUP,info,MU_SOUTH_POLE) UVADJ1C.347
ENDIF UVADJ1C.348
*ENDIF UVADJ1C.349
ENDIF ! IF (LWHITBROM) UVADJ1C.350
*ENDIF UVADJ1C.351
UVADJ1C.352
DO K=1,P_LEVELS UVADJ1C.353
UVADJ1C.354
IF (LWHITBROM) THEN UVADJ1C.355
C---------------------------------------------------------------------- UVADJ1C.356
CL SECTION 3.3. CALCULATES PRESSURE AT LEVEL K NEEDED FOR CALL UVADJ1C.357
CL TO CALC_TS. PERFORMED ONLY IF CALL_NUMBER > 1. UVADJ1C.358
C---------------------------------------------------------------------- UVADJ1C.359
UVADJ1C.360
IF(BK(K).EQ.0.) THEN UVADJ1C.361
C SET CONSTANT_PRESSURE BEFORE CALL TO TS AND P AT START ADDRESS AS UVADJ1C.362
C THIS IS ALL TS NEEDS IN THIS CASE. UVADJ1C.363
CONSTANT_PRESSURE = .TRUE. UVADJ1C.364
P(FIRST_VALID_PT) = AK(K) UVADJ1C.365
ELSE UVADJ1C.366
C SET CONSTANT_PRESSURE BEFORE CALL TO TS AND P. UVADJ1C.367
! loop over all points, including valid halos UVADJ1C.368
DO 330 I=FIRST_VALID_PT,LAST_P_VALID_PT UVADJ1C.369
P(I) = AK(K) + BK(K)*PSTAR(I) UVADJ1C.370
330 CONTINUE UVADJ1C.371
CONSTANT_PRESSURE = .FALSE. UVADJ1C.372
END IF UVADJ1C.373
UVADJ1C.374
C---------------------------------------------------------------------- UVADJ1C.375
CL SECTION 3.4. CALL CALC_TS TO GET STANDARD TEMPERATURE. UVADJ1C.376
CL ONLY CALLED IF CALL_NUMBER GREATER THAN 1 UVADJ1C.377
CL AS TS CALCULATED IN SECTION 2.1 ON CALL_NUMBER 1. UVADJ1C.378
CL THEN CALCULATE THETAS BY DIVIDING BY EXNER. UVADJ1C.379
C---------------------------------------------------------------------- UVADJ1C.380
C EXNER AT LEVEL K IS IN WORK_P UVADJ1C.381
UVADJ1C.382
CALL CALC_TS(P(FIRST_VALID_PT),TS(FIRST_VALID_PT),POINTS, UVADJ1C.383
& CONSTANT_PRESSURE,LLINTS) UVADJ1C.384
UVADJ1C.385
C Convert TS to THETAS UVADJ1C.386
! loop over all valid points - including top and bottom halos UVADJ1C.387
DO 340 I=FIRST_VALID_PT,LAST_P_VALID_PT UVADJ1C.388
PKP1 = AKH(K+1) + BKH(K+1)*PSTAR(I) UVADJ1C.389
PK = AKH(K) + BKH(K) *PSTAR(I) UVADJ1C.390
WORK_P(I) = R_P_EXNER_C UVADJ1C.391
+ (P_EXNER(I,K+1),P_EXNER(I,K),PKP1,PK,KAPPA) UVADJ1C.392
THETAS(I,K) = TS(I)*WORK_P(I) UVADJ1C.393
340 CONTINUE UVADJ1C.394
UVADJ1C.395
C---------------------------------------------------------------------- UVADJ1C.396
CL SECTION 3.5. CALCULATE MU UVADJ1C.397
CL CALCULATE 1/RS AT U POINTS. UVADJ1C.398
C---------------------------------------------------------------------- UVADJ1C.399
UVADJ1C.400
C MU IS CALCULATED AT U POINTS AND HELD IN WORK_U UVADJ1C.401
! loop over all points, including valid halos UVADJ1C.402
DO 350 I=FIRST_VALID_PT,LAST_U_VALID_PT UVADJ1C.403
RECIP_RS_UV(I,K)=1.0/RECIP_RS_UV(I,K) UVADJ1C.404
WORK_U(I) = (F2(I)*U(I,K) - F1(I)*V(I,K) + UVADJ1C.405
* (U(I,K)*U(I,K)+V(I,K)*V(I,K))*RECIP_RS_UV(I,K))* UVADJ1C.406
* RECIP_G UVADJ1C.407
350 CONTINUE UVADJ1C.408
C CALL UV_TO_P TO INTERPOLATE MU ONTO P-GRID HELD IN WORK_P UVADJ1C.409
UVADJ1C.410
CALL UV_TO_P(WORK_U(START_POINT_NO_HALO-ROW_LENGTH), UVADJ1C.411
& WORK_P(START_POINT_NO_HALO), UVADJ1C.412
& U_FIELD-(START_POINT_NO_HALO-ROW_LENGTH)+1, UVADJ1C.413
& P_FIELD-START_POINT_NO_HALO+1, UVADJ1C.414
& ROW_LENGTH,upd_P_ROWS+1) UVADJ1C.415
UVADJ1C.416
*IF DEF,GLOBAL UVADJ1C.417
! Set WORK at poles to MU UVADJ1C.418
*ELSE UVADJ1C.419
! Set WORK at North and South edges to one row in UVADJ1C.420
*ENDIF UVADJ1C.421
*IF DEF,MPP UVADJ1C.422
IF (at_top_of_LPG) THEN UVADJ1C.423
*ENDIF UVADJ1C.424
DO I=TOP_ROW_START,TOP_ROW_START+ROW_LENGTH-1 UVADJ1C.425
*IF DEF,GLOBAL UVADJ1C.426
WORK_P(I) = MU_NORTH_POLE(K) UVADJ1C.427
*ELSE UVADJ1C.428
WORK_P(I) = WORK_P(I+ROW_LENGTH) UVADJ1C.429
*ENDIF UVADJ1C.430
ENDDO UVADJ1C.431
*IF DEF,MPP UVADJ1C.432
ENDIF UVADJ1C.433
IF (at_base_of_LPG) THEN UVADJ1C.434
*ENDIF UVADJ1C.435
DO I=P_BOT_ROW_START,P_BOT_ROW_START+ROW_LENGTH-1 UVADJ1C.436
*IF DEF,GLOBAL UVADJ1C.437
WORK_P(I) = MU_SOUTH_POLE(K) UVADJ1C.438
*ELSE UVADJ1C.439
WORK_P(I) = WORK_P(I-ROW_LENGTH) UVADJ1C.440
*ENDIF UVADJ1C.441
ENDDO UVADJ1C.442
*IF DEF,MPP UVADJ1C.443
ENDIF UVADJ1C.444
*ENDIF UVADJ1C.445
UVADJ1C.446
C---------------------------------------------------------------------- UVADJ1C.447
CL SECTION 3.6. CALCULATE THETAV + MU * THETAS UVADJ1C.448
C---------------------------------------------------------------------- UVADJ1C.449
UVADJ1C.450
IF(K.LE.Q_LEVELS) THEN UVADJ1C.451
! loop over all points - including top and bottom halos UVADJ1C.452
DO 360 I=FIRST_VALID_PT,LAST_P_VALID_PT UVADJ1C.453
THETAS(I,K) = THETA(I,K)*(1.+ C_VIRTUAL UVADJ1C.454
* *Q(I,K))+ WORK_P(I)*THETAS(I,K) UVADJ1C.455
360 CONTINUE UVADJ1C.456
ELSE UVADJ1C.457
! loop over all points - including top and bottom halos UVADJ1C.458
DO 362 I=FIRST_VALID_PT,LAST_P_VALID_PT UVADJ1C.459
THETAS(I,K) = THETA(I,K) + WORK_P(I)*THETAS(I,K) UVADJ1C.460
362 CONTINUE UVADJ1C.461
END IF UVADJ1C.462
UVADJ1C.463
ELSE ! LWHITBROM UVADJ1C.464
UVADJ1C.465
C---------------------------------------------------------------------- UVADJ1C.466
CL SECTION 3.3. CALCULATE THETAV UVADJ1C.467
C---------------------------------------------------------------------- UVADJ1C.468
UVADJ1C.469
IF(K.LE.Q_LEVELS) THEN UVADJ1C.470
! loop over all points, including valid halos UVADJ1C.471
DO 460 I=FIRST_VALID_PT,LAST_P_VALID_PT UVADJ1C.472
THETAS(I,K) = THETA(I,K)*(1.+ C_VIRTUAL UVADJ1C.473
* *Q(I,K)) UVADJ1C.474
460 CONTINUE UVADJ1C.475
ELSE UVADJ1C.476
! loop over all points, including valid halos UVADJ1C.477
DO 462 I=FIRST_VALID_PT,LAST_P_VALID_PT UVADJ1C.478
THETAS(I,K) = THETA(I,K) UVADJ1C.479
462 CONTINUE UVADJ1C.480
END IF UVADJ1C.481
UVADJ1C.482
END IF ! LWHITBROM UVADJ1C.483
UVADJ1C.484
UVADJ1C.485
ENDDO UVADJ1C.486
UVADJ1C.487
*IF DEF,MPP UVADJ1C.488
IF (LWHITBROM) THEN UVADJ1C.489
CALL SWAPBOUNDS(THETAS,ROW_LENGTH,tot_P_ROWS, UVADJ1C.490
& EW_Halo,NS_Halo,P_LEVELS) UVADJ1C.491
ENDIF UVADJ1C.492
*ENDIF UVADJ1C.493
UVADJ1C.494
c1=.5*LONGITUDE_STEP_INVERSE*ADJUSTMENT_TIMESTEP UVADJ1C.495
c2=.5*LATITUDE_STEP_INVERSE*ADJUSTMENT_TIMESTEP UVADJ1C.496
UVADJ1C.497
DO 110 K=1,P_LEVELS UVADJ1C.498
UVADJ1C.499
CL--------------------------------------------------------------------- UVADJ1C.500
CL SECTION 4. CALCULATE PHI AT LEVEL K, EQUATION (26). UVADJ1C.501
CL--------------------------------------------------------------------- UVADJ1C.502
C---------------------------------------------------------------------- UVADJ1C.503
CL SECTION 4.1. CALCULATE PHI AT LEVEL K UVADJ1C.504
C---------------------------------------------------------------------- UVADJ1C.505
TEMP2 = 1./(KAPPA+1.) UVADJ1C.506
UVADJ1C.507
if(k.ne.1)then UVADJ1C.508
UVADJ1C.509
cdir$ nosplit UVADJ1C.510
DO I=FIRST_VALID_PT,LAST_P_VALID_PT UVADJ1C.511
PHI_HALF_LEVEL(I) = PHI_HALF_LEVEL(I) UVADJ1C.512
& -CP*THETAS(I,K-1)* UVADJ1C.513
& (P_EXNER(I,K) - P_EXNER(I,K-1) ) UVADJ1C.514
ENDDO UVADJ1C.515
cdir$ nosplit UVADJ1C.516
DO I=FIRST_VALID_PT,LAST_P_VALID_PT UVADJ1C.517
TEMP1= 1.0/(DELTA_AK(K)+DELTA_BK(K)*PSTAR(I)) UVADJ1C.518
DELTA_P_P_EXNER_BY_DELTAP(I) = (P_EXNER(I,K+1)* UVADJ1C.519
* (AKH(K+1)+BKH(K+1)*PSTAR(I)) - UVADJ1C.520
* P_EXNER(I,K)*(AKH(K)+BKH(K)*PSTAR(I))) UVADJ1C.521
* *TEMP1*TEMP2 UVADJ1C.522
ENDDO UVADJ1C.523
UVADJ1C.524
cdir$ nosplit UVADJ1C.525
DO I=FIRST_VALID_PT,LAST_P_VALID_PT UVADJ1C.526
PHI_FULL_LEVEL(I) = PHI_HALF_LEVEL(I) + CP*THETAS(I,K)* UVADJ1C.527
* (P_EXNER(I,K) - DELTA_P_P_EXNER_BY_DELTAP(I)) UVADJ1C.528
ENDDO UVADJ1C.529
UVADJ1C.530
else if(k.eq.1)then UVADJ1C.531
UVADJ1C.532
cdir$ nosplit UVADJ1C.533
! loop over all points, including valid halos UVADJ1C.534
DO I=FIRST_VALID_PT,LAST_P_VALID_PT UVADJ1C.535
UVADJ1C.536
PHI_HALF_LEVEL(I) = OROG_HEIGHT(I) * G UVADJ1C.537
ENDDO UVADJ1C.538
cdir$ nosplit UVADJ1C.539
DO I=FIRST_VALID_PT,LAST_P_VALID_PT UVADJ1C.540
TEMP1= 1.0/(DELTA_AK(K)+DELTA_BK(K)*PSTAR(I)) UVADJ1C.541
DELTA_P_P_EXNER_BY_DELTAP(I) = (P_EXNER(I,K+1)* UVADJ1C.542
* (AKH(K+1)+BKH(K+1)*PSTAR(I)) - UVADJ1C.543
* P_EXNER(I,K)*(AKH(K)+BKH(K)*PSTAR(I))) UVADJ1C.544
* *TEMP1*TEMP2 UVADJ1C.545
ENDDO UVADJ1C.546
cdir$ nosplit UVADJ1C.547
DO I=FIRST_VALID_PT,LAST_P_VALID_PT UVADJ1C.548
PHI_FULL_LEVEL(I) = PHI_HALF_LEVEL(I) + CP*THETAS(I,K)* UVADJ1C.549
* (P_EXNER(I,K) - DELTA_P_P_EXNER_BY_DELTAP(I)) UVADJ1C.550
ENDDO UVADJ1C.551
UVADJ1C.552
endif UVADJ1C.553
UVADJ1C.554
CL COPY PHI_FULL_LEVEL INTO OUTPUT ARRAY IF DIAGNOSTIC REQUIRED. UVADJ1C.555
UVADJ1C.556
IF(L_PHI_OUT) THEN UVADJ1C.557
! loop over all points, including valid halos UVADJ1C.558
DO I=FIRST_VALID_PT,LAST_P_VALID_PT UVADJ1C.559
PHI_OUT(I,K) = PHI_FULL_LEVEL(I) UVADJ1C.560
END DO UVADJ1C.561
*IF DEF,MPP UVADJ1C.562
! Initialise whole array so there are no NaNs for STASH to fall UVADJ1C.563
! over on UVADJ1C.564
DO I=1,FIRST_VALID_PT-1 UVADJ1C.565
PHI_OUT(I,K)=PHI_OUT(FIRST_VALID_PT,K) UVADJ1C.566
ENDDO UVADJ1C.567
DO I=LAST_P_VALID_PT+1,P_FIELD UVADJ1C.568
PHI_OUT(I,K)=PHI_OUT(LAST_P_VALID_PT,K) UVADJ1C.569
ENDDO UVADJ1C.570
*ENDIF UVADJ1C.571
END IF UVADJ1C.572
CL--------------------------------------------------------------------- UVADJ1C.573
CL SECTION 5. CALCULATE HORIZONTAL PRESSURE GRADIENTS. UVADJ1C.574
CL THEN CALCULATE CORIOLIS TERM AND IMPLICITLY UPDATE UVADJ1C.575
CL U AND V. EQUATIONS (23) TO (25). UVADJ1C.576
CL--------------------------------------------------------------------- UVADJ1C.577
UVADJ1C.578
*IF -DEF,GLOBAL UVADJ1C.579
UVADJ1C.580
CL Save East and West edges so that they are held constant in LAM mode UVADJ1C.581
UVADJ1C.582
*IF DEF,MPP UVADJ1C.583
IF (at_left_of_LPG) THEN UVADJ1C.584
*ENDIF UVADJ1C.585
DO I=START_POINT_NO_HALO + FIRST_ROW_PT-1, UVADJ1C.586
& END_U_POINT_NO_HALO,ROW_LENGTH UVADJ1C.587
U_TEMP_L(I)=U(I,K) UVADJ1C.588
V_TEMP_L(I)=V(I,K) UVADJ1C.589
ENDDO UVADJ1C.590
*IF DEF,MPP UVADJ1C.591
ENDIF UVADJ1C.592
IF (at_right_of_LPG) THEN UVADJ1C.593
*ENDIF UVADJ1C.594
DO I=START_POINT_NO_HALO + LAST_ROW_PT-1, UVADJ1C.595
& END_U_POINT_NO_HALO,ROW_LENGTH UVADJ1C.596
U_TEMP_R(I)=U(I,K) UVADJ1C.597
V_TEMP_R(I)=V(I,K) UVADJ1C.598
U_TEMP_R(I-1)=U(I-1,K) UVADJ1C.599
V_TEMP_R(I-1)=V(I-1,K) UVADJ1C.600
ENDDO UVADJ1C.601
*IF DEF,MPP UVADJ1C.602
ENDIF UVADJ1C.603
*ENDIF UVADJ1C.604
*ENDIF UVADJ1C.605
UVADJ1C.606
UVADJ1C.607
C---------------------------------------------------------------------- UVADJ1C.608
CL SECTION 5.1. CALCULATE HORIZONTAL PRESSURE GRADIENT, UVADJ1C.609
CL D(PHI)/D(LONGITUDE). UVADJ1C.610
C---------------------------------------------------------------------- UVADJ1C.611
C---------------------------------------------------------------------- UVADJ1C.612
CL SECTION 5.2. CALCULATE HORIZONTAL PRESSURE GRADIENT, UVADJ1C.613
CL D(PHI)/D(LATITUDE). UVADJ1C.614
C---------------------------------------------------------------------- UVADJ1C.615
C UVADJ1C.616
C UVADJ1C.617
UVADJ1C.618
C The following loop is unrolled to level 2 by hand since the compiler UVADJ1C.619
C is not able to do this at present. UVADJ1C.620
C UVADJ1C.621
cdir$ nosplit UVADJ1C.622
IX1=IAND(MAX(END_U_POINT_NO_HALO-START_POINT_NO_HALO,0),1) UVADJ1C.623
IF (IX1 .EQ. 1)THEN UVADJ1C.624
I=START_POINT_NO_HALO UVADJ1C.625
IJ = I + ROW_LENGTH UVADJ1C.626
DPHI_BY_DLONGITUDE(i) = c1*SEC_U_LATITUDE(I)*( UVADJ1C.627
* ((PHI_FULL_LEVEL(I+1)- PHI_FULL_LEVEL(I))+ UVADJ1C.628
* (PHI_FULL_LEVEL(IJ+1)-PHI_FULL_LEVEL(IJ)))+ UVADJ1C.629
* .5*CP*(((THETAS(I+1,K)+THETAS(I,K)) UVADJ1C.630
* *(DELTA_P_P_EXNER_BY_DELTAP(I+1) - UVADJ1C.631
* DELTA_P_P_EXNER_BY_DELTAP(I)))+ UVADJ1C.632
* ((THETAS(IJ+1,K)+THETAS(IJ,K)) UVADJ1C.633
* *(DELTA_P_P_EXNER_BY_DELTAP(IJ+1) - UVADJ1C.634
* DELTA_P_P_EXNER_BY_DELTAP(IJ))))) UVADJ1C.635
DPHI_BY_DLATITUDE(i) = c2*( UVADJ1C.636
* ((PHI_FULL_LEVEL(I)-PHI_FULL_LEVEL(IJ))+ UVADJ1C.637
* (PHI_FULL_LEVEL(I+1)-PHI_FULL_LEVEL(IJ+1)))+ UVADJ1C.638
* .5*CP*(((THETAS(I,K)+THETAS(IJ,K)) UVADJ1C.639
* *(DELTA_P_P_EXNER_BY_DELTAP(I) - UVADJ1C.640
* DELTA_P_P_EXNER_BY_DELTAP(IJ)))+ UVADJ1C.641
* ((THETAS(I+1,K)+THETAS(IJ+1,K)) UVADJ1C.642
* *(DELTA_P_P_EXNER_BY_DELTAP(I+1) - UVADJ1C.643
* DELTA_P_P_EXNER_BY_DELTAP(IJ+1))))) UVADJ1C.644
ENDIF UVADJ1C.645
DO II=IX1 + START_POINT_NO_HALO,END_U_POINT_NO_HALO-1,2 UVADJ1C.646
I = II UVADJ1C.647
IJ = I + ROW_LENGTH UVADJ1C.648
DPHI_BY_DLONGITUDE(i) = c1*SEC_U_LATITUDE(I)*( UVADJ1C.649
* ((PHI_FULL_LEVEL(I+1)- PHI_FULL_LEVEL(I))+ UVADJ1C.650
* (PHI_FULL_LEVEL(IJ+1)-PHI_FULL_LEVEL(IJ)))+ UVADJ1C.651
* .5*CP*(((THETAS(I+1,K)+THETAS(I,K)) UVADJ1C.652
* *(DELTA_P_P_EXNER_BY_DELTAP(I+1) - UVADJ1C.653
* DELTA_P_P_EXNER_BY_DELTAP(I)))+ UVADJ1C.654
* ((THETAS(IJ+1,K)+THETAS(IJ,K)) UVADJ1C.655
* *(DELTA_P_P_EXNER_BY_DELTAP(IJ+1) - UVADJ1C.656
* DELTA_P_P_EXNER_BY_DELTAP(IJ))))) UVADJ1C.657
DPHI_BY_DLATITUDE(i) = c2*( UVADJ1C.658
* ((PHI_FULL_LEVEL(I)-PHI_FULL_LEVEL(IJ))+ UVADJ1C.659
* (PHI_FULL_LEVEL(I+1)-PHI_FULL_LEVEL(IJ+1)))+ UVADJ1C.660
* .5*CP*(((THETAS(I,K)+THETAS(IJ,K)) UVADJ1C.661
* *(DELTA_P_P_EXNER_BY_DELTAP(I) - UVADJ1C.662
* DELTA_P_P_EXNER_BY_DELTAP(IJ)))+ UVADJ1C.663
* ((THETAS(I+1,K)+THETAS(IJ+1,K)) UVADJ1C.664
* *(DELTA_P_P_EXNER_BY_DELTAP(I+1) - UVADJ1C.665
* DELTA_P_P_EXNER_BY_DELTAP(IJ+1))))) UVADJ1C.666
I = II + 1 UVADJ1C.667
IJ = I + ROW_LENGTH UVADJ1C.668
DPHI_BY_DLONGITUDE(i) = c1*SEC_U_LATITUDE(I)*( UVADJ1C.669
* ((PHI_FULL_LEVEL(I+1)- PHI_FULL_LEVEL(I))+ UVADJ1C.670
* (PHI_FULL_LEVEL(IJ+1)-PHI_FULL_LEVEL(IJ)))+ UVADJ1C.671
* .5*CP*(((THETAS(I+1,K)+THETAS(I,K)) UVADJ1C.672
* *(DELTA_P_P_EXNER_BY_DELTAP(I+1) - UVADJ1C.673
* DELTA_P_P_EXNER_BY_DELTAP(I)))+ UVADJ1C.674
* ((THETAS(IJ+1,K)+THETAS(IJ,K)) UVADJ1C.675
* *(DELTA_P_P_EXNER_BY_DELTAP(IJ+1) - UVADJ1C.676
* DELTA_P_P_EXNER_BY_DELTAP(IJ))))) UVADJ1C.677
DPHI_BY_DLATITUDE(i) = c2*( UVADJ1C.678
* ((PHI_FULL_LEVEL(I)-PHI_FULL_LEVEL(IJ))+ UVADJ1C.679
* (PHI_FULL_LEVEL(I+1)-PHI_FULL_LEVEL(IJ+1)))+ UVADJ1C.680
* .5*CP*(((THETAS(I,K)+THETAS(IJ,K)) UVADJ1C.681
* *(DELTA_P_P_EXNER_BY_DELTAP(I) - UVADJ1C.682
* DELTA_P_P_EXNER_BY_DELTAP(IJ)))+ UVADJ1C.683
* ((THETAS(I+1,K)+THETAS(IJ+1,K)) UVADJ1C.684
* *(DELTA_P_P_EXNER_BY_DELTAP(I+1) - UVADJ1C.685
* DELTA_P_P_EXNER_BY_DELTAP(IJ+1))))) UVADJ1C.686
ENDDO UVADJ1C.687
UVADJ1C.688
*IF DEF,GLOBAL UVADJ1C.689
*IF -DEF,MPP UVADJ1C.690
C Correct DPHI_BY_DLONGITUDE & DPHI_BY_DLATITUDE UVADJ1C.691
C for global wrap around UVADJ1C.692
cdir$ nosplit UVADJ1C.693
cdir$ nounroll UVADJ1C.694
UVADJ1C.695
DO I=START_POINT_NO_HALO + LAST_ROW_PT-1, UVADJ1C.696
& END_U_POINT_NO_HALO,ROW_LENGTH UVADJ1C.697
UVADJ1C.698
IP = I + 1 - ROW_LENGTH UVADJ1C.699
IJ = I + ROW_LENGTH UVADJ1C.700
IJP = IJ + 1 - ROW_LENGTH UVADJ1C.701
UVADJ1C.702
DPHI_BY_DLONGITUDE(i) = c1*( UVADJ1C.703
* (PHI_FULL_LEVEL(IP )-PHI_FULL_LEVEL(I))+ UVADJ1C.704
* (PHI_FULL_LEVEL(IJP )-PHI_FULL_LEVEL(IJ))+ UVADJ1C.705
* .5*CP*(THETAS(IP ,K)+THETAS(I,K)) UVADJ1C.706
* *(DELTA_P_P_EXNER_BY_DELTAP(IP ) - UVADJ1C.707
* DELTA_P_P_EXNER_BY_DELTAP(I))+ UVADJ1C.708
* .5*CP*(THETAS(IJP ,K)+THETAS(IJ,K)) UVADJ1C.709
* *(DELTA_P_P_EXNER_BY_DELTAP(IJP ) - UVADJ1C.710
* DELTA_P_P_EXNER_BY_DELTAP(IJ)))* UVADJ1C.711
* SEC_U_LATITUDE(I) UVADJ1C.712
DPHI_BY_DLATITUDE(i) = c2*( UVADJ1C.713
* (PHI_FULL_LEVEL(I)-PHI_FULL_LEVEL(IJ))+ UVADJ1C.714
* (PHI_FULL_LEVEL(IP )-PHI_FULL_LEVEL(IJP ))+ UVADJ1C.715
* .5*CP*(THETAS(I,K)+THETAS(IJ,K)) UVADJ1C.716
* *(DELTA_P_P_EXNER_BY_DELTAP(I) - UVADJ1C.717
* DELTA_P_P_EXNER_BY_DELTAP(IJ))+ UVADJ1C.718
* .5*CP*(THETAS(IP ,K)+THETAS(IJP ,K)) UVADJ1C.719
* *(DELTA_P_P_EXNER_BY_DELTAP(IP ) - UVADJ1C.720
* DELTA_P_P_EXNER_BY_DELTAP(IJP ))) UVADJ1C.721
ENDDO UVADJ1C.722
UVADJ1C.723
*ENDIF UVADJ1C.724
*ENDIF UVADJ1C.725
UVADJ1C.726
UVADJ1C.727
C---------------------------------------------------------------------- UVADJ1C.728
CL SECTION 5.3. UPDATE U AND V USING IMPLICIT UVADJ1C.729
CL TREATMENT OF CORIOLIS TERMS. UVADJ1C.730
C---------------------------------------------------------------------- UVADJ1C.731
C This loop calculates the reciprocal on the previous pass UVADJ1C.732
C in order to mask the cost of the divide. UVADJ1C.733
UVADJ1C.734
cdir$ nosplit UVADJ1C.735
! cdir$ cache_bypass f3 GSM4F405.6
DO I=START_POINT_NO_HALO,END_U_POINT_NO_HALO-1 UVADJ1C.737
TEMP1 = HALF_ADJUSTMENT_TIMESTEP* UVADJ1C.738
* (F3(I)+U(I,K)*TAN_U_LATITUDE(I)*RECIP_RS_UV(I,K)) UVADJ1C.739
TEMP2 = TEMP1 * TEMP1 UVADJ1C.740
RECIP=1.0/(1.+TEMP2) UVADJ1C.741
UVADJ1C.742
WORK_V= (V(I,K)*(1.-TEMP2) UVADJ1C.743
* - TEMP1*(2.*U(I,K)-DPHI_BY_DLONGITUDE(I) UVADJ1C.744
* *RECIP_RS_UV(I,K)) UVADJ1C.745
* - DPHI_BY_DLATITUDE(i)*RECIP_RS_UV(I,K))*RECIP UVADJ1C.746
U(I,K) = U(I,K) + TEMP1*(V(I,K)+WORK_V) - UVADJ1C.747
* DPHI_BY_DLONGITUDE(i)*RECIP_RS_UV(I,K) UVADJ1C.748
V(I,K) = WORK_V UVADJ1C.749
UVADJ1C.750
ENDDO UVADJ1C.751
UVADJ1C.752
UVADJ1C.753
*IF -DEF,GLOBAL UVADJ1C.754
C Reset East West values of U and V with input values UVADJ1C.755
*IF DEF,MPP UVADJ1C.756
IF (at_left_of_LPG) THEN UVADJ1C.757
*ENDIF UVADJ1C.758
DO I=START_POINT_NO_HALO + FIRST_ROW_PT-1, UVADJ1C.759
& END_U_POINT_NO_HALO,ROW_LENGTH UVADJ1C.760
U(I,K)=U_TEMP_L(I) UVADJ1C.761
V(I,K)=V_TEMP_L(I) UVADJ1C.762
ENDDO UVADJ1C.763
*IF DEF,MPP UVADJ1C.764
ENDIF UVADJ1C.765
IF (at_right_of_LPG) THEN UVADJ1C.766
*ENDIF UVADJ1C.767
DO I=START_POINT_NO_HALO + LAST_ROW_PT-1, UVADJ1C.768
& END_U_POINT_NO_HALO,ROW_LENGTH UVADJ1C.769
U(I,K)=U_TEMP_R(I) UVADJ1C.770
V(I,K)=V_TEMP_R(I) UVADJ1C.771
U(I-1,K)=U_TEMP_R(I-1) UVADJ1C.772
V(I-1,K)=V_TEMP_R(I-1) UVADJ1C.773
ENDDO UVADJ1C.774
*IF DEF,MPP UVADJ1C.775
ENDIF UVADJ1C.776
*ENDIF UVADJ1C.777
*ENDIF UVADJ1C.778
UVADJ1C.779
CL END LOOP OVER P_LEVELS UVADJ1C.780
110 CONTINUE UVADJ1C.781
UVADJ1C.782
CL END OF ROUTINE UV_ADJ UVADJ1C.783
UVADJ1C.784
RETURN UVADJ1C.785
END UVADJ1C.786
*ENDIF UVADJ1C.787