SUBROUTINE POLAR_UV(U,V,ROW_LENGTH,U_POINTS,LEVELS, 14APB2F401.237
*CALL ARGFLDPT 
APB2F401.238
& COS_LAMBDA,SIN_LAMBDA) APB2F401.239
APB2F401.240
IMPLICIT NONE APB2F401.241
APB2F401.242
INTEGER APB2F401.243
& ROW_LENGTH ! IN Number of points per row APB2F401.244
&, U_POINTS ! IN Horizontal size of fields on U grid APB2F401.245
&, LEVELS ! IN Number of levels to process APB2F401.246
APB2F401.247
! All TYPFLDPT arguments are intent IN APB2F401.248
*CALL TYPFLDPT APB2F401.249
APB2F401.250
REAL APB2F401.251
& U(U_POINTS,LEVELS) ! INOUT U field to process APB2F401.252
&, V(U_POINTS,LEVELS) ! INOUT V field to process APB2F401.253
&, SIN_LAMBDA(ROW_LENGTH) ! IN Sine longitude APB2F401.254
&, COS_LAMBDA(ROW_LENGTH) ! IN Cosine longitude APB2F401.255
APB2F401.256
! Local arrays APB2F401.257
! 4 arrays containing cartesian components of polar fluxes APB2F401.258
APB2F401.259
REAL APB2F401.260
& CART_U_NP(ROW_LENGTH,LEVELS) APB2F401.261
&, CART_U_SP(ROW_LENGTH,LEVELS) APB2F401.262
&, CART_V_NP(ROW_LENGTH,LEVELS) APB2F401.263
&, CART_V_SP(ROW_LENGTH,LEVELS) APB2F401.264
APB2F401.265
! 8 arrays containing the calculated means APB2F401.266
APB2F401.267
REAL APB2F401.268
& MEAN_U_NP(LEVELS) APB2F401.269
&, MEAN_U_SP(LEVELS) APB2F401.270
&, MEAN_V_NP(LEVELS) APB2F401.271
&, MEAN_V_SP(LEVELS) APB2F401.272
&, MEAN_CARTESIAN_U_NP(LEVELS) APB2F401.273
&, MEAN_CARTESIAN_U_SP(LEVELS) APB2F401.274
&, MEAN_CARTESIAN_V_NP(LEVELS) APB2F401.275
&, MEAN_CARTESIAN_V_SP(LEVELS) APB2F401.276
APB2F401.277
! Local variables APB2F401.278
INTEGER APB2F401.279
& K,I,I_NP,I_SP ! loop counters and indexes APB2F401.280
&, NP_ADJACENT_ROW_START ! start of row below NP row APB2F401.281
&, SP_ADJACENT_ROW_START ! start of row above SP row APB2F401.282
*IF DEF,MPP APB2F401.283
&, LOCAL_ROW_PTS ! number of non-halo points in row APB2F401.284
&, info ! return code from GC routines APB2F401.285
*ENDIF APB2F401.286
APB2F401.287
REAL ROW_LENGTH_RECIP,ONE_THIRD APB2F401.288
APB2F401.289
!----------------------------------------------------------------------- APB2F401.290
APB2F401.291
APB2F401.292
NP_ADJACENT_ROW_START=TOP_ROW_START+ROW_LENGTH APB2F401.293
SP_ADJACENT_ROW_START=U_BOT_ROW_START-ROW_LENGTH APB2F401.294
*IF DEF,MPP APB2F401.295
LOCAL_ROW_PTS=LAST_ROW_PT-FIRST_ROW_PT+1 APB2F401.296
*ENDIF APB2F401.297
APB2F401.298
ROW_LENGTH_RECIP=1.0/GLOBAL_ROW_LENGTH APB2F401.299
ONE_THIRD=1.0/3.0 APB2F401.300
APB2F401.301
! 1. Resolve u and v vectorially onto cartesian grid APB2F401.302
APB2F401.303
! North Pole APB2F401.304
*IF DEF,MPP APB2F401.305
IF (at_top_of_LPG) THEN APB2F401.306
*ENDIF APB2F401.307
DO K=1,LEVELS APB2F401.308
DO I=FIRST_ROW_PT,LAST_ROW_PT APB2F401.309
I_NP=I+NP_ADJACENT_ROW_START-1 APB2F401.310
! I_NP index points to points along row beneath North Pole APB2F401.311
CART_U_NP(I,K)= APB2F401.312
& U(I_NP,K)*COS_LAMBDA(I)-V(I_NP,K)*SIN_LAMBDA(I) APB2F401.313
CART_V_NP(I,K)= APB2F401.314
& V(I_NP,K)*COS_LAMBDA(I)+U(I_NP,K)*SIN_LAMBDA(I) APB2F401.315
ENDDO APB2F401.316
ENDDO APB2F401.317
*IF DEF,MPP APB2F401.318
ENDIF APB2F401.319
*ENDIF APB2F401.320
APB2F401.321
! South Pole APB2F401.322
*IF DEF,MPP APB2F401.323
IF (at_base_of_LPG) THEN APB2F401.324
*ENDIF APB2F401.325
DO K=1,LEVELS APB2F401.326
DO I=FIRST_ROW_PT,LAST_ROW_PT APB2F401.327
I_SP=I+SP_ADJACENT_ROW_START-1 APB2F401.328
! I_SP index points to points along row above South Pole APB2F401.329
CART_U_SP(I,K)= APB2F401.330
& U(I_SP,K)*COS_LAMBDA(I)+V(I_SP,K)*SIN_LAMBDA(I) APB2F401.331
CART_V_SP(I,K)= APB2F401.332
& V(I_SP,K)*COS_LAMBDA(I)-U(I_SP,K)*SIN_LAMBDA(I) APB2F401.333
ENDDO APB2F401.334
ENDDO APB2F401.335
*IF DEF,MPP APB2F401.336
ENDIF APB2F401.337
*ENDIF APB2F401.338
APB2F401.339
! 2. Compute mean cartesian values at poles, and mean u and v APB2F401.340
APB2F401.341
DO K=1,LEVELS APB2F401.342
MEAN_CARTESIAN_U_NP(K)=0.0 APB2F401.343
MEAN_CARTESIAN_U_SP(K)=0.0 APB2F401.344
MEAN_CARTESIAN_V_NP(K)=0.0 APB2F401.345
MEAN_CARTESIAN_V_SP(K)=0.0 APB2F401.346
MEAN_U_NP(K)=0.0 APB2F401.347
MEAN_U_SP(K)=0.0 APB2F401.348
MEAN_V_NP(K)=0.0 APB2F401.349
MEAN_V_SP(K)=0.0 APB2F401.350
APB2F401.351
*IF -DEF,MPP APB2F401.352
DO I=FIRST_ROW_PT,LAST_ROW_PT APB2F401.353
APB2F401.354
I_NP=I+NP_ADJACENT_ROW_START-1 APB2F401.355
I_SP=I+SP_ADJACENT_ROW_START-1 APB2F401.356
APB2F401.357
MEAN_CARTESIAN_U_NP(K)= APB2F401.358
& MEAN_CARTESIAN_U_NP(K)+CART_U_NP(I,K) APB2F401.359
MEAN_CARTESIAN_U_SP(K)= APB2F401.360
& MEAN_CARTESIAN_U_SP(K)+CART_U_SP(I,K) APB2F401.361
MEAN_CARTESIAN_V_NP(K)= APB2F401.362
& MEAN_CARTESIAN_V_NP(K)+CART_V_NP(I,K) APB2F401.363
MEAN_CARTESIAN_V_SP(K)= APB2F401.364
& MEAN_CARTESIAN_V_SP(K)+CART_V_SP(I,K) APB2F401.365
APB2F401.366
MEAN_U_NP(K) = MEAN_U_NP(K) + U(I_NP,K) APB2F401.367
MEAN_U_SP(K) = MEAN_U_SP(K) + U(I_SP,K) APB2F401.368
MEAN_V_NP(K) = MEAN_V_NP(K) + V(I_NP,K) APB2F401.369
MEAN_V_SP(K) = MEAN_V_SP(K) + V(I_SP,K) APB2F401.370
APB2F401.371
ENDDO ! I: loop over points on row APB2F401.372
ENDDO ! K: loop over levels APB2F401.373
*ELSE APB2F401.374
ENDDO ! K : loop over levels APB2F401.375
APB2F401.376
IF (at_top_of_LPG) THEN APB2F401.377
*IF DEF,REPROD GPB3F404.11
CALL GCG_RVECSUMR(ROW_LENGTH,LOCAL_ROW_PTS,FIRST_ROW_PT, APB2F401.378
*ELSE GPB3F404.12
CALL GCG_RVECSUMF(ROW_LENGTH,LOCAL_ROW_PTS,FIRST_ROW_PT, GPB3F404.13
*ENDIF GPB3F404.14
& LEVELS,CART_U_NP,GC_ROW_GROUP, APB2F401.379
& info,MEAN_CARTESIAN_U_NP) APB2F401.380
*IF DEF,REPROD GPB3F404.15
CALL GCG_RVECSUMR(ROW_LENGTH,LOCAL_ROW_PTS,FIRST_ROW_PT, APB2F401.381
*ELSE GPB3F404.16
CALL GCG_RVECSUMF(ROW_LENGTH,LOCAL_ROW_PTS,FIRST_ROW_PT, GPB3F404.17
*ENDIF GPB3F404.18
& LEVELS,CART_V_NP,GC_ROW_GROUP, APB2F401.382
& info,MEAN_CARTESIAN_V_NP) APB2F401.383
APB2F401.384
*IF DEF,REPROD GPB3F404.19
CALL GCG_RVECSUMR(U_POINTS,LOCAL_ROW_PTS, APB2F401.385
*ELSE GPB3F404.20
CALL GCG_RVECSUMF(U_POINTS,LOCAL_ROW_PTS, GPB3F404.21
*ENDIF GPB3F404.22
& NP_ADJACENT_ROW_START+FIRST_ROW_PT-1, APB2F401.386
& LEVELS,U,GC_ROW_GROUP,info,MEAN_U_NP) APB2F401.387
*IF DEF,REPROD GPB3F404.23
CALL GCG_RVECSUMR(U_POINTS,LOCAL_ROW_PTS, APB2F401.388
*ELSE GPB3F404.24
CALL GCG_RVECSUMF(U_POINTS,LOCAL_ROW_PTS, GPB3F404.25
*ENDIF GPB3F404.26
& NP_ADJACENT_ROW_START+FIRST_ROW_PT-1, APB2F401.389
& LEVELS,V,GC_ROW_GROUP,info,MEAN_V_NP) APB2F401.390
ENDIF APB2F401.391
APB2F401.392
IF (at_base_of_LPG) THEN APB2F401.393
*IF DEF,REPROD GPB3F404.27
CALL GCG_RVECSUMR(ROW_LENGTH,LOCAL_ROW_PTS,FIRST_ROW_PT, APB2F401.394
*ELSE GPB3F404.28
CALL GCG_RVECSUMF(ROW_LENGTH,LOCAL_ROW_PTS,FIRST_ROW_PT, GPB3F404.29
*ENDIF GPB3F404.30
& LEVELS,CART_U_SP,GC_ROW_GROUP, APB2F401.395
& info,MEAN_CARTESIAN_U_SP) APB2F401.396
*IF DEF,REPROD GPB3F404.31
CALL GCG_RVECSUMR(ROW_LENGTH,LOCAL_ROW_PTS,FIRST_ROW_PT, APB2F401.397
*ELSE GPB3F404.32
CALL GCG_RVECSUMF(ROW_LENGTH,LOCAL_ROW_PTS,FIRST_ROW_PT, GPB3F404.33
*ENDIF GPB3F404.34
& LEVELS,CART_V_SP,GC_ROW_GROUP, APB2F401.398
& info,MEAN_CARTESIAN_V_SP) APB2F401.399
APB2F401.400
*IF DEF,REPROD GPB3F404.35
CALL GCG_RVECSUMR(U_POINTS,LOCAL_ROW_PTS, APB2F401.401
*ELSE GPB3F404.36
CALL GCG_RVECSUMF(U_POINTS,LOCAL_ROW_PTS, GPB3F404.37
*ENDIF GPB3F404.38
& SP_ADJACENT_ROW_START+FIRST_ROW_PT-1, APB2F401.402
& LEVELS,U,GC_ROW_GROUP,info,MEAN_U_SP) APB2F401.403
*IF DEF,REPROD GPB3F404.39
CALL GCG_RVECSUMR(U_POINTS,LOCAL_ROW_PTS, APB2F401.404
*ELSE GPB3F404.40
CALL GCG_RVECSUMF(U_POINTS,LOCAL_ROW_PTS, GPB3F404.41
*ENDIF GPB3F404.42
& SP_ADJACENT_ROW_START+FIRST_ROW_PT-1, APB2F401.405
& LEVELS,V,GC_ROW_GROUP,info,MEAN_V_SP) APB2F401.406
ENDIF APB2F401.407
*ENDIF APB2F401.408
APB2F401.409
DO K=1,LEVELS APB2F401.410
MEAN_CARTESIAN_U_NP(K)= APB2F401.411
& MEAN_CARTESIAN_U_NP(K)*ROW_LENGTH_RECIP APB2F401.412
MEAN_CARTESIAN_U_SP(K)= APB2F401.413
& MEAN_CARTESIAN_U_SP(K)*ROW_LENGTH_RECIP APB2F401.414
MEAN_CARTESIAN_V_NP(K)= APB2F401.415
& MEAN_CARTESIAN_V_NP(K)*ROW_LENGTH_RECIP APB2F401.416
MEAN_CARTESIAN_V_SP(K)= APB2F401.417
& MEAN_CARTESIAN_V_SP(K)*ROW_LENGTH_RECIP APB2F401.418
MEAN_U_NP(K) = MEAN_U_NP(K)*ROW_LENGTH_RECIP APB2F401.419
MEAN_U_SP(K) = MEAN_U_SP(K)*ROW_LENGTH_RECIP APB2F401.420
MEAN_V_NP(K) = MEAN_V_NP(K)*ROW_LENGTH_RECIP APB2F401.421
MEAN_V_SP(K) = MEAN_V_SP(K)*ROW_LENGTH_RECIP APB2F401.422
ENDDO APB2F401.423
APB2F401.424
! 3. Resolve mean values back to lat-lon grid and add in fluxes APB2F401.425
! Scale MEAN_U and MEAN_V by 1/3 to give uniform vorticity and APB2F401.426
! divergence. APB2F401.427
APB2F401.428
! North Pole APB2F401.429
*IF DEF,MPP APB2F401.430
IF (at_top_of_LPG) THEN APB2F401.431
*ENDIF APB2F401.432
DO K=1,LEVELS APB2F401.433
DO I=FIRST_ROW_PT,LAST_ROW_PT APB2F401.434
APB2F401.435
I_NP=TOP_ROW_START+I-1 APB2F401.436
! This points to the real North Pole row. APB2F401.437
APB2F401.438
U(I_NP,K) = MEAN_CARTESIAN_U_NP(K)*COS_LAMBDA(I)+ APB2F401.439
& MEAN_CARTESIAN_V_NP(K)*SIN_LAMBDA(I)+ APB2F401.440
& MEAN_U_NP(K)*ONE_THIRD APB2F401.441
V(I_NP,K) = MEAN_CARTESIAN_V_NP(K)*COS_LAMBDA(I)- APB2F401.442
& MEAN_CARTESIAN_U_NP(K)*SIN_LAMBDA(I)+ APB2F401.443
& MEAN_V_NP(K)*ONE_THIRD APB2F401.444
ENDDO APB2F401.445
ENDDO APB2F401.446
*IF DEF,MPP APB2F401.447
ENDIF APB2F401.448
*ENDIF APB2F401.449
APB2F401.450
! South Pole APB2F401.451
*IF DEF,MPP APB2F401.452
IF (at_base_of_LPG) THEN APB2F401.453
*ENDIF APB2F401.454
DO K=1,LEVELS APB2F401.455
DO I=FIRST_ROW_PT,LAST_ROW_PT APB2F401.456
APB2F401.457
I_SP=U_BOT_ROW_START+I-1 APB2F401.458
! This points to the real South Pole row. APB2F401.459
APB2F401.460
U(I_SP,K) = MEAN_U_SP(K)*ONE_THIRD + APB2F401.461
& MEAN_CARTESIAN_U_SP(K)*COS_LAMBDA(I)- APB2F401.462
& MEAN_CARTESIAN_V_SP(K)*SIN_LAMBDA(I) APB2F401.463
V(I_SP,K) = MEAN_V_SP(K)*ONE_THIRD + APB2F401.464
& MEAN_CARTESIAN_V_SP(K)*COS_LAMBDA(I)+ APB2F401.465
& MEAN_CARTESIAN_U_SP(K)*SIN_LAMBDA(I) APB2F401.466
ENDDO APB2F401.467
ENDDO APB2F401.468
*IF DEF,MPP APB2F401.469
ENDIF APB2F401.470
*ENDIF APB2F401.471
POLAUV1A.121
RETURN POLAUV1A.122
END POLAUV1A.123
*ENDIF POLAUV1A.124