SUBROUTINE UV_DIF 2,15UVDIF1C.60
1 (U,V,RS_SQUARED_DELTAP, UVDIF1C.61
2 SEC_U_LATITUDE,START_U_UPDATE,END_U_UPDATE, UVDIF1C.62
3 ROW_LENGTH, UVDIF1C.63
*CALL ARGFLDPT 
UVDIF1C.64
& P_LEVELS,KEXP_K1,ADVECTION_TIMESTEP, UVDIF1C.65
& P_FIELD,U_FIELD, UVDIF1C.66
4 DIFFUSION_EW,DIFFUSION_NS) UVDIF1C.67
UVDIF1C.68
IMPLICIT NONE UVDIF1C.69
UVDIF1C.70
INTEGER UVDIF1C.71
* U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID UVDIF1C.72
*, P_FIELD !IN DIMENSION OF FIELDS ON PRESSURE GRID UVDIF1C.73
*, ROW_LENGTH !IN NUMBER OF POINTS PER ROW UVDIF1C.74
*, START_U_UPDATE !IN FIRST POINT TO BE UPDATED. UVDIF1C.75
*, END_U_UPDATE !IN LAST POINT TO BE UPDATED. UVDIF1C.76
*, P_LEVELS !IN NUMBER OF LEVELS UVDIF1C.77
*, KEXP_K1(P_LEVELS) !IN ORDER OF DIFFUSION UVDIF1C.78
UVDIF1C.79
! All TYPFLDPT arguments are intent IN UVDIF1C.80
*CALL TYPFLDPT UVDIF1C.81
UVDIF1C.82
REAL UVDIF1C.83
* U(U_FIELD,P_LEVELS) !INOUT. U FIELD. UVDIF1C.84
*,V(U_FIELD,P_LEVELS) !INOUT. V FIELD. UVDIF1C.85
*,ADVECTION_TIMESTEP !IN UVDIF1C.86
UVDIF1C.87
REAL UVDIF1C.88
* RS_SQUARED_DELTAP(P_FIELD,P_LEVELS) !IN 1/RS*RS*DELTA P UVDIF1C.89
*,DIFFUSION_EW(P_FIELD,P_LEVELS) !IN EW DIFFUSION COEFFICIENT UVDIF1C.90
*,DIFFUSION_NS(P_FIELD,P_LEVELS) !IN NS DIFFUSION COEFFICIENT UVDIF1C.91
*,SEC_U_LATITUDE(U_FIELD) !IN 1/COS(LAT) AT U POINTS UVDIF1C.92
UVDIF1C.93
UVDIF1C.94
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- UVDIF1C.95
C DEFINE LOCAL ARRAYS: 4 ARE REQUIRED UVDIF1C.96
UVDIF1C.97
*IF DEF,MPP,AND,DEF,T3E UVDIF1C.98
*IF DEF,MPP UVDIF1C.99
*CALL AMAXSIZE UVDIF1C.100
*ENDIF UVDIF1C.101
*ENDIF UVDIF1C.102
REAL UVDIF1C.103
* FIELD1(P_FIELD) ! GENERAL WORKSPACE UVDIF1C.104
*,FIELD2(P_FIELD) ! GENERAL WORKSPACE UVDIF1C.105
*,FIELD3(P_FIELD) ! GENERAL WORKSPACE UVDIF1C.106
*,FIELD4(P_FIELD) ! GENERAL WORKSPACE UVDIF1C.107
*,FIELDU(P_FIELD) ! GENERAL WORKSPACE UVDIF1C.108
*,FIELDV(P_FIELD) ! GENERAL WORKSPACE UVDIF1C.109
*,RS_SQUARED_DELTAP_U_GRID(P_FIELD) ! RS**2*DELTAP on UV GRID UVDIF1C.110
*IF DEF,MPP UVDIF1C.111
*IF DEF,MPP,AND,DEF,T3E UVDIF1C.112
&,u_copy(row_length_max) ! copy of polar row UVDIF1C.113
&,v_copy(row_length_max) ! copy of polar row UVDIF1C.114
&,u_out_copy(row_length_max) UVDIF1C.115
&,v_out_copy(row_length_max) UVDIF1C.116
c UVDIF1C.117
integer ipad1(32), ipad2(32), ipad3(32), ipad4(32) UVDIF1C.118
c UVDIF1C.119
common/uv_dif_shmem/ ipad1, u_copy, ipad2, v_copy, ipad3 UVDIF1C.120
c UVDIF1C.121
*CALL PARVARS UVDIF1C.122
integer g_start(maxproc), g_new_start, l_new_length, UVDIF1C.123
2 l_iadd, current_length, l_rem_iadd, my_row_pe UVDIF1C.124
*ELSE UVDIF1C.125
&,U_COPY(ROW_LENGTH) ! copy of polar row UVDIF1C.126
&,V_COPY(ROW_LENGTH) ! copy of polar row UVDIF1C.127
*ENDIF UVDIF1C.128
*ENDIF UVDIF1C.129
C*--------------------------------------------------------------------- UVDIF1C.130
C DEFINE LOCAL VARIABLES UVDIF1C.131
UVDIF1C.132
C LOCAL REALS. UVDIF1C.133
REAL UVDIF1C.134
* SCALAR,SCALAR1 UVDIF1C.135
C COUNT VARIABLES FOR DO LOOPS ETC. UVDIF1C.136
INTEGER UVDIF1C.137
* I,IJ,J,JI,HALF_RL,K,JJ UVDIF1C.138
*IF DEF,GLOBAL,AND,DEF,MPP UVDIF1C.139
INTEGER info UVDIF1C.140
*ENDIF UVDIF1C.141
UVDIF1C.142
C*L EXTERNAL SUBROUTINE CALLS: NONE--------------------------------- UVDIF1C.143
C*--------------------------------------------------------------------- UVDIF1C.144
CL MAXIMUM VECTOR LENGTH ASSUMED IS END_U_UPDATE-START_U_UPDATE+1+ UVDIF1C.145
CL ROW_LENGTH UVDIF1C.146
CL--------------------------------------------------------------------- UVDIF1C.147
CL INTERNAL STRUCTURE. UVDIF1C.148
CL--------------------------------------------------------------------- UVDIF1C.149
CL UVDIF1C.150
DO K=1,P_LEVELS UVDIF1C.151
UVDIF1C.152
C INTERPOLATE RS_SQUARED_DELTAP TO U GRID. UVDIF1C.153
UVDIF1C.154
CALL P_TO_UV( RS_SQUARED_DELTAP(1,K), UVDIF1C.155
* RS_SQUARED_DELTAP_U_GRID, UVDIF1C.156
* P_FIELD,U_FIELD,ROW_LENGTH,tot_P_ROWS) UVDIF1C.157
DO I=FIRST_VALID_PT,LAST_U_VALID_PT UVDIF1C.158
FIELDU(I) = U(I,K) UVDIF1C.159
FIELDV(I) = V(I,K) UVDIF1C.160
END DO UVDIF1C.161
UVDIF1C.162
UVDIF1C.163
C LOOP THROUGH CODE KEXP_K1 TIMES. THE ORDER OF THE DIFFUSION SCHEME IS UVDIF1C.164
C DEL TO THE POWER 2*KEXP_K1. UVDIF1C.165
UVDIF1C.166
DO JJ=1,KEXP_K1(K) UVDIF1C.167
UVDIF1C.168
UVDIF1C.169
UVDIF1C.170
CL--------------------------------------------------------------------- UVDIF1C.171
CL SECTION 1. CALCULATE FIRST TERM IN EQUATION (47) UVDIF1C.172
CL--------------------------------------------------------------------- UVDIF1C.173
UVDIF1C.174
C---------------------------------------------------------------------- UVDIF1C.175
CL SECTION 1.1 CALCULATE DELTALAMBDA TERMS UVDIF1C.176
C---------------------------------------------------------------------- UVDIF1C.177
UVDIF1C.178
UVDIF1C.179
DO I=START_U_UPDATE+1,END_U_UPDATE UVDIF1C.180
FIELD1(I) =FIELDU(I)-FIELDU(I-1) UVDIF1C.181
FIELD2(I) =FIELDV(I)-FIELDV(I-1) UVDIF1C.182
END DO UVDIF1C.183
UVDIF1C.184
*IF -DEF,MPP UVDIF1C.185
C CORRECT END POINTS UVDIF1C.186
UVDIF1C.187
DO I=START_U_UPDATE,END_U_UPDATE,ROW_LENGTH UVDIF1C.188
IJ=I+ROW_LENGTH-1 UVDIF1C.189
FIELD1(I) =FIELDU(I)-FIELDU(IJ) UVDIF1C.190
FIELD2(I) =FIELDV(I)-FIELDV(IJ) UVDIF1C.191
END DO UVDIF1C.192
*ELSE UVDIF1C.193
FIELD1(START_U_UPDATE)=FIELD1(START_U_UPDATE+1) UVDIF1C.194
FIELD2(START_U_UPDATE)=FIELD2(START_U_UPDATE+1) UVDIF1C.195
*ENDIF UVDIF1C.196
UVDIF1C.197
C---------------------------------------------------------------------- UVDIF1C.198
CL SECTION 1.3 COMPLETE DELTALAMBDA TERM UVDIF1C.199
C---------------------------------------------------------------------- UVDIF1C.200
UVDIF1C.201
DO I= START_U_UPDATE+1,END_U_UPDATE UVDIF1C.202
FIELD3(I-1)=(DIFFUSION_EW(I,K)*FIELD1(I)- UVDIF1C.203
& DIFFUSION_EW(I-1,K)*FIELD1(I-1))* UVDIF1C.204
& SEC_U_LATITUDE(I-1) UVDIF1C.205
FIELD4(I-1)=(DIFFUSION_EW(I,K)*FIELD2(I)- UVDIF1C.206
& DIFFUSION_EW(I-1,K)*FIELD2(I-1))* UVDIF1C.207
& SEC_U_LATITUDE(I-1) UVDIF1C.208
END DO UVDIF1C.209
UVDIF1C.210
C CORRECT END POINT UVDIF1C.211
*IF -DEF,MPP UVDIF1C.212
UVDIF1C.213
DO I= START_U_UPDATE,END_U_UPDATE,ROW_LENGTH UVDIF1C.214
IJ=I+ROW_LENGTH-1 UVDIF1C.215
FIELD3(IJ)=(DIFFUSION_EW(I,K)*FIELD1(I)- UVDIF1C.216
& DIFFUSION_EW(IJ,K)*FIELD1(IJ))* UVDIF1C.217
& SEC_U_LATITUDE(IJ) UVDIF1C.218
FIELD4(IJ)=(DIFFUSION_EW(I,K)*FIELD2(I)- UVDIF1C.219
& DIFFUSION_EW(IJ,K)*FIELD2(IJ))* UVDIF1C.220
& SEC_U_LATITUDE(IJ) UVDIF1C.221
END DO UVDIF1C.222
*ELSE UVDIF1C.223
FIELD3(END_U_UPDATE)=FIELD3(END_U_UPDATE-1) UVDIF1C.224
FIELD4(END_U_UPDATE)=FIELD4(END_U_UPDATE-1) UVDIF1C.225
*ENDIF UVDIF1C.226
UVDIF1C.227
CL UVDIF1C.228
CL--------------------------------------------------------------------- UVDIF1C.229
CL SECTION 2. CALCULATE PHI DIRECTION TERM AND ADD UVDIF1C.230
CL ONTO FIRST TO GET TOTAL INCREMENT. UVDIF1C.231
CL--------------------------------------------------------------------- UVDIF1C.232
UVDIF1C.233
! Loop over field, missing top row UVDIF1C.234
DO I=START_POINT_NO_HALO,LAST_U_VALID_PT UVDIF1C.235
FIELD1(I)=FIELDU(I-ROW_LENGTH)-FIELDU(I) UVDIF1C.236
FIELD2(I)=FIELDV(I-ROW_LENGTH)-FIELDV(I) UVDIF1C.237
END DO UVDIF1C.238
UVDIF1C.239
*IF DEF,GLOBAL UVDIF1C.240
C CALCULATE POLAR TERMS USING ACROSS-POLE DIFFERENCE, REMEMBERING SIGN UVDIF1C.241
C CHANGE ACROSS THE POLE UVDIF1C.242
C NB: EFFECTIVE COS_P_LATITUDE IS 1/4 THAT AT ADJACENT ROW UVDIF1C.243
UVDIF1C.244
HALF_RL = global_ROW_LENGTH/2 UVDIF1C.245
UVDIF1C.246
*IF -DEF,MPP UVDIF1C.247
UVDIF1C.248
DO I=1,HALF_RL UVDIF1C.249
C NORTH POLE (FIRST HALF OF ROW) UVDIF1C.250
J = I+HALF_RL UVDIF1C.251
FIELD1(I)=-(FIELDU(I)+FIELDU(J)) UVDIF1C.252
FIELD2(I)=-(FIELDV(I)+FIELDV(J)) UVDIF1C.253
FIELD1(J)=-(FIELDU(I)+FIELDU(J)) UVDIF1C.254
FIELD2(J)=-(FIELDV(I)+FIELDV(J)) UVDIF1C.255
UVDIF1C.256
C SOUTH POLE (SECOND HALF OF ROW) UVDIF1C.257
IJ = U_FIELD+J UVDIF1C.258
JI = U_FIELD+I UVDIF1C.259
FIELD1(IJ)= FIELDU(IJ-ROW_LENGTH)+ FIELDU(JI-ROW_LENGTH) UVDIF1C.260
FIELD2(IJ)= FIELDV(IJ-ROW_LENGTH)+ FIELDV(JI-ROW_LENGTH) UVDIF1C.261
FIELD1(JI)= FIELDU(IJ-ROW_LENGTH)+ FIELDU(JI-ROW_LENGTH) UVDIF1C.262
FIELD2(JI)= FIELDV(IJ-ROW_LENGTH)+ FIELDV(JI-ROW_LENGTH) UVDIF1C.263
END DO UVDIF1C.264
*ELSE UVDIF1C.265
*IF DEF,MPP,AND,DEF,T3E UVDIF1C.266
c UVDIF1C.267
c--for MPP Code, check that we have enough processors UVDIF1C.268
if(nproc_x.eq.1 .or. nproc_y.eq.1) then UVDIF1C.269
c UVDIF1C.270
*ENDIF UVDIF1C.271
IF (at_top_of_LPG) THEN UVDIF1C.272
! North Pole UVDIF1C.273
! Copy NP row into U/V_COPY arrays UVDIF1C.274
DO I=1,ROW_LENGTH UVDIF1C.275
J=TOP_ROW_START+I-1 ! point along North Pole row UVDIF1C.276
U_COPY(I)=FIELDU(J) UVDIF1C.277
V_COPY(I)=FIELDV(J) UVDIF1C.278
ENDDO UVDIF1C.279
UVDIF1C.280
! and rotate these rows by half a global row length, so that item I now UVDIF1C.281
! contains the value which was on the opposite side of the pole. UVDIF1C.282
UVDIF1C.283
CALL GCG_RVECSHIFT(ROW_LENGTH,ROW_LENGTH-2*EW_Halo, UVDIF1C.284
& FIRST_ROW_PT,1,HALF_RL,.TRUE.,U_COPY, UVDIF1C.285
& GC_ROW_GROUP,info) UVDIF1C.286
CALL GCG_RVECSHIFT(ROW_LENGTH,ROW_LENGTH-2*EW_Halo, UVDIF1C.287
& FIRST_ROW_PT,1,HALF_RL,.TRUE.,V_COPY, UVDIF1C.288
& GC_ROW_GROUP,info) UVDIF1C.289
UVDIF1C.290
DO I=1,ROW_LENGTH UVDIF1C.291
J=TOP_ROW_START+I-1 ! point along North Pole row UVDIF1C.292
FIELD1(J)=-(FIELDU(J)+U_COPY(I)) UVDIF1C.293
FIELD2(J)=-(FIELDV(J)+V_COPY(I)) UVDIF1C.294
ENDDO UVDIF1C.295
ENDIF ! (IF at_top_of_LPG) UVDIF1C.296
UVDIF1C.297
IF (at_base_of_LPG) THEN UVDIF1C.298
! South Pole UVDIF1C.299
! Copy SP row in U/V_COPY arrays UVDIF1C.300
DO I=1,ROW_LENGTH UVDIF1C.301
J=U_BOT_ROW_START+I-1 ! point along South Pole row UVDIF1C.302
U_COPY(I)=FIELDU(J) UVDIF1C.303
V_COPY(I)=FIELDV(J) UVDIF1C.304
ENDDO UVDIF1C.305
UVDIF1C.306
! and rotate these rows by half a global row length, so that item I now UVDIF1C.307
! contains the value which was on the opposite side of the pole. UVDIF1C.308
UVDIF1C.309
CALL GCG_RVECSHIFT(ROW_LENGTH,ROW_LENGTH-2*EW_Halo, UVDIF1C.310
& FIRST_ROW_PT,1,HALF_RL,.TRUE.,U_COPY, UVDIF1C.311
& GC_ROW_GROUP,info) UVDIF1C.312
CALL GCG_RVECSHIFT(ROW_LENGTH,ROW_LENGTH-2*EW_Halo, UVDIF1C.313
& FIRST_ROW_PT,1,HALF_RL,.TRUE.,V_COPY, UVDIF1C.314
& GC_ROW_GROUP,info) UVDIF1C.315
UVDIF1C.316
DO I=1,ROW_LENGTH UVDIF1C.317
J=P_BOT_ROW_START+I-1 UVDIF1C.318
FIELD1(J)=U_COPY(I)+FIELDU(J-ROW_LENGTH) UVDIF1C.319
FIELD2(J)=V_COPY(I)+FIELDV(J-ROW_LENGTH) UVDIF1C.320
ENDDO UVDIF1C.321
ENDIF ! (IF at_base_of_LPG) UVDIF1C.322
*IF DEF,MPP,AND,DEF,T3E UVDIF1C.323
c UVDIF1C.324
else ! MPP/T3E and only 1 processor along either direction UVDIF1C.325
c UVDIF1C.326
call barrier() UVDIF1C.327
c UVDIF1C.328
IF (at_top_of_LPG) THEN UVDIF1C.329
! North Pole UVDIF1C.330
! Copy NP row into U/V_COPY arrays UVDIF1C.331
DO I=1,ROW_LENGTH UVDIF1C.332
J=TOP_ROW_START+I-1 ! point along North Pole row UVDIF1C.333
U_COPY(I)=FIELDU(J) UVDIF1C.334
V_COPY(I)=FIELDV(J) UVDIF1C.335
ENDDO UVDIF1C.336
ENDIF ! (IF at_top_of_LPG) UVDIF1C.337
UVDIF1C.338
IF (at_base_of_LPG) THEN UVDIF1C.339
! South Pole UVDIF1C.340
! Copy SP row in U/V_COPY arrays UVDIF1C.341
DO I=1,ROW_LENGTH UVDIF1C.342
J=U_BOT_ROW_START+I-1 ! point along South Pole row UVDIF1C.343
U_COPY(I)=FIELDU(J) UVDIF1C.344
V_COPY(I)=FIELDV(J) UVDIF1C.345
ENDDO UVDIF1C.346
ENDIF ! (IF at_base_of_LPG) UVDIF1C.347
c UVDIF1C.348
call barrier() UVDIF1C.349
c UVDIF1C.350
c--process North and South Rows together UVDIF1C.351
IF (at_top_of_LPG .or. at_base_of_LPG) THEN UVDIF1C.352
c--work out the PE at the start of my Row UVDIF1C.353
my_row_pe=(mype/nproc_x)*nproc_x UVDIF1C.354
g_start(1)=1 UVDIF1C.355
c--find the global start addresses for PE's in my row UVDIF1C.356
do i=2, nproc_x+1 UVDIF1C.357
g_start(i)=g_start(i-1)+g_blsizep(1,i-2) UVDIF1C.358
end do UVDIF1C.359
c write(0,*) my_pe(), (g_start(i), i=1, nproc_x+1) UVDIF1C.360
c UVDIF1C.361
c--set the global start address for the start of my exchange UVDIF1C.362
g_new_start=g_start(mype-my_row_pe+1)+half_rl UVDIF1C.363
c--set the length of the data to exchange UVDIF1C.364
l_new_length=row_length-2*ew_halo UVDIF1C.365
c--set the start address UVDIF1C.366
l_iadd=1+ew_halo UVDIF1C.367
c--loop until we have moved all the segments for this PE UVDIF1C.368
1000 continue UVDIF1C.369
c--check we not off the end UVDIF1C.370
if(g_new_start.gt.glsize(1)) g_new_start= UVDIF1C.371
2 g_new_start-glsize(1) UVDIF1C.372
c--loop over the PE's in a row UVDIF1C.373
do i=1, nproc_x UVDIF1C.374
c--check if this glocal address is on the the current remote PE UVDIF1C.375
if(g_new_start.ge.g_start(i) .and. UVDIF1C.376
2 g_new_start.lt.g_start(i+1)) then UVDIF1C.377
c--compute the new local address on the remote PE UVDIF1C.378
l_rem_iadd=g_new_start-g_start(i) UVDIF1C.379
c--compute the number of words to move on this get UVDIF1C.380
current_length=min(l_new_length, UVDIF1C.381
2 g_start(i+1)-g_new_start) UVDIF1C.382
c write(0,*) my_pe(), ' fetch ', current_length, UVDIF1C.383
c 2 ' from PE ',i-1, ' at ',l_rem_iadd+halo_4th, UVDIF1C.384
c 3 ' to ', l_iadd UVDIF1C.385
c--get the data UVDIF1C.386
call shmem_get(u_out_copy(l_iadd), UVDIF1C.387
2 u_copy(l_rem_iadd+1+ew_halo), current_length, UVDIF1C.388
3 my_row_pe+i-1) UVDIF1C.389
call shmem_get(v_out_copy(l_iadd), UVDIF1C.390
2 v_copy(l_rem_iadd+1+ew_halo), current_length, UVDIF1C.391
3 my_row_pe+i-1) UVDIF1C.392
UVDIF1C.393
c--update the global address and local addresses and lengths UVDIF1C.394
g_new_start=g_new_start+current_length UVDIF1C.395
l_iadd=l_iadd+current_length UVDIF1C.396
l_new_length=l_new_length-current_length UVDIF1C.397
c--check if we have finished UVDIF1C.398
if(l_new_length.gt.0) goto 1000 UVDIF1C.399
goto 1100 UVDIF1C.400
endif UVDIF1C.401
end do UVDIF1C.402
write(0,*) 'PE ', my_pe(), ' is Lost in UV_DIF ', UVDIF1C.403
2 l_new_length, current_length, l_rem_iadd+halo_4th, l_iadd, UVDIF1C.404
3 g_new_start, (g_start(i), i=1, nproc_x+1) UVDIF1C.405
call abort('Lost in UV_DIF') UVDIF1C.406
UVDIF1C.407
1100 continue UVDIF1C.408
u_out_copy(1)=u_copy(1) UVDIF1C.409
u_out_copy(row_length)=u_copy(row_length) UVDIF1C.410
v_out_copy(1)=v_copy(1) UVDIF1C.411
v_out_copy(row_length)=v_copy(row_length) UVDIF1C.412
c write(0,*) my_pe(), (v_copy(i), i=1, row_length) UVDIF1C.413
UVDIF1C.414
ENDIF ! (at_top_of_LPG .or. at_base_of_LPG) UVDIF1C.415
c UVDIF1C.416
IF (at_top_of_LPG) THEN UVDIF1C.417
! North Pole UVDIF1C.418
DO I=1,ROW_LENGTH UVDIF1C.419
J=TOP_ROW_START+I-1 ! point along North Pole row UVDIF1C.420
FIELD1(J)=-(FIELDU(J)+u_out_copy(I)) UVDIF1C.421
FIELD2(J)=-(FIELDV(J)+v_out_copy(I)) UVDIF1C.422
ENDDO UVDIF1C.423
ENDIF ! (IF at_top_of_LPG) UVDIF1C.424
c UVDIF1C.425
IF (at_base_of_LPG) THEN UVDIF1C.426
! South Pole UVDIF1C.427
DO I=1,ROW_LENGTH UVDIF1C.428
J=P_BOT_ROW_START+I-1 UVDIF1C.429
FIELD1(J)=u_out_copy(I)+FIELDU(J-ROW_LENGTH) UVDIF1C.430
FIELD2(J)=v_out_copy(I)+FIELDV(J-ROW_LENGTH) UVDIF1C.431
ENDDO UVDIF1C.432
ENDIF ! (IF at_base_of_LPG) UVDIF1C.433
c UVDIF1C.434
endif ! Code for more then one processor in each direction UVDIF1C.435
c UVDIF1C.436
*ENDIF UVDIF1C.437
UVDIF1C.438
*ENDIF UVDIF1C.439
*ENDIF UVDIF1C.440
UVDIF1C.441
C---------------------------------------------------------------------- UVDIF1C.442
CL SECTION 2.3 CALCULATE SECOND TERM IN EQUATION (47) AND ADD UVDIF1C.443
CL ONTO FIRST TERM TO GET TOTAL CORRECTION. UVDIF1C.444
C---------------------------------------------------------------------- UVDIF1C.445
DO I= START_U_UPDATE,END_U_UPDATE UVDIF1C.446
SCALAR1=SEC_U_LATITUDE(I)/RS_SQUARED_DELTAP_U_GRID(I) UVDIF1C.447
FIELDU(I)=(FIELD3(I)+DIFFUSION_NS(I,K)*FIELD1(I) UVDIF1C.448
& -DIFFUSION_NS(I+ROW_LENGTH,K)*FIELD1(I+ROW_LENGTH))* UVDIF1C.449
& SCALAR1 UVDIF1C.450
FIELDV(I)=(FIELD4(I)+DIFFUSION_NS(I,K)*FIELD2(I) UVDIF1C.451
& -DIFFUSION_NS(I+ROW_LENGTH,K)*FIELD2(I+ROW_LENGTH))* UVDIF1C.452
& SCALAR1 UVDIF1C.453
END DO UVDIF1C.454
UVDIF1C.455
CL LIMITED AREA ZERO AT LATERAL BOUNDARIES UVDIF1C.456
UVDIF1C.457
*IF -DEF,GLOBAL UVDIF1C.458
UVDIF1C.459
! Set all boundaries of the increment to zero. UVDIF1C.460
*IF DEF,MPP UVDIF1C.461
IF (at_top_of_LPG) THEN UVDIF1C.462
*ENDIF UVDIF1C.463
! Northern boundary UVDIF1C.464
DO I=TOP_ROW_START,TOP_ROW_START+ROW_LENGTH-1 UVDIF1C.465
FIELDU(I)=0.0 UVDIF1C.466
FIELDV(I)=0.0 UVDIF1C.467
ENDDO UVDIF1C.468
*IF DEF,MPP UVDIF1C.469
ENDIF UVDIF1C.470
UVDIF1C.471
IF (at_base_of_LPG) THEN UVDIF1C.472
*ENDIF UVDIF1C.473
! Southern boundary UVDIF1C.474
DO I=U_BOT_ROW_START,U_BOT_ROW_START+ROW_LENGTH-1 UVDIF1C.475
FIELDU(I)=0.0 UVDIF1C.476
FIELDV(I)=0.0 UVDIF1C.477
ENDDO UVDIF1C.478
*IF DEF,MPP UVDIF1C.479
ENDIF UVDIF1C.480
UVDIF1C.481
IF (at_left_of_LPG) THEN UVDIF1C.482
*ENDIF UVDIF1C.483
! Western boundary UVDIF1C.484
DO I=START_U_UPDATE+FIRST_ROW_PT-1,END_U_UPDATE,ROW_LENGTH UVDIF1C.485
FIELDU(I)=0.0 UVDIF1C.486
FIELDV(I)=0.0 UVDIF1C.487
ENDDO UVDIF1C.488
*IF DEF,MPP UVDIF1C.489
ENDIF UVDIF1C.490
UVDIF1C.491
IF (at_right_of_LPG) THEN UVDIF1C.492
*ENDIF UVDIF1C.493
! Eastern boundary - set last two points of each row to zero UVDIF1C.494
DO I=START_U_UPDATE+LAST_ROW_PT-2,END_U_UPDATE,ROW_LENGTH UVDIF1C.495
FIELDU(I)=0.0 UVDIF1C.496
FIELDU(I+1)=0.0 UVDIF1C.497
FIELDV(I)=0.0 UVDIF1C.498
FIELDV(I+1)=0.0 UVDIF1C.499
ENDDO UVDIF1C.500
*IF DEF,MPP UVDIF1C.501
ENDIF UVDIF1C.502
*ENDIF UVDIF1C.503
UVDIF1C.504
*ENDIF UVDIF1C.505
UVDIF1C.506
*IF DEF,MPP UVDIF1C.507
if(jj.ne.KEXP_K1(K))then UVDIF1C.508
CALL SWAPBOUNDS(FIELDU,ROW_LENGTH,tot_P_ROWS, UVDIF1C.509
& EW_Halo,NS_Halo,1) UVDIF1C.510
CALL SWAPBOUNDS(FIELDV,ROW_LENGTH,tot_P_ROWS, UVDIF1C.511
& EW_Halo,NS_Halo,1) UVDIF1C.512
endif UVDIF1C.513
*ENDIF UVDIF1C.514
UVDIF1C.515
C FIELD1 AND FIELD2 NOW CONTAIN DIFFUSED QUANTITIES WHICH CAN UVDIF1C.516
C BE USED IN FURTHER DIFFUSION SWEEPS UVDIF1C.517
UVDIF1C.518
CL END OF DIFFUSION SWEEPS UVDIF1C.519
END DO UVDIF1C.520
CL ADD FINAL INCREMENT ONTO WIND FIELDS. UVDIF1C.521
SCALAR = (-1)**KEXP_K1(K) UVDIF1C.522
! Loop over field, missing top and bottom rows and halos UVDIF1C.523
DO I=START_POINT_NO_HALO,END_U_POINT_NO_HALO UVDIF1C.524
U(I,K) = U(I,K) - FIELDU(I) * ADVECTION_TIMESTEP UVDIF1C.525
& *SCALAR UVDIF1C.526
V(I,K) = V(I,K) - FIELDV(I) * ADVECTION_TIMESTEP UVDIF1C.527
& *SCALAR UVDIF1C.528
END DO UVDIF1C.529
CL END LOOP OVER P_LEVELS UVDIF1C.530
UVDIF1C.531
END DO UVDIF1C.532
UVDIF1C.533
*IF DEF,MPP UVDIF1C.534
CALL SWAPBOUNDS UVDIF1C.535
1 (U,ROW_LENGTH,tot_P_ROWS, UVDIF1C.536
& EW_Halo,NS_Halo,P_LEVELS) UVDIF1C.537
CALL SWAPBOUNDS UVDIF1C.538
1 (V,ROW_LENGTH,tot_P_ROWS, UVDIF1C.539
& EW_Halo,NS_Halo,P_LEVELS) UVDIF1C.540
*ENDIF UVDIF1C.541
CL END OF ROUTINE UV_DIF UVDIF1C.542
UVDIF1C.543
RETURN UVDIF1C.544
END UVDIF1C.545
*ENDIF UVDIF1C.546