*IF DEF,A12_1D DIVDMP1D.2
C ******************************COPYRIGHT****************************** DIVDMP1D.3
C (c) CROWN COPYRIGHT 1996, METEOROLOGICAL OFFICE, All Rights Reserved. DIVDMP1D.4
C DIVDMP1D.5
C Use, duplication or disclosure of this code is subject to the DIVDMP1D.6
C restrictions as set forth in the contract. DIVDMP1D.7
C DIVDMP1D.8
C Meteorological Office DIVDMP1D.9
C London Road DIVDMP1D.10
C BRACKNELL DIVDMP1D.11
C Berkshire UK DIVDMP1D.12
C RG12 2SZ DIVDMP1D.13
C DIVDMP1D.14
C If no contract has been raised with this copy of the code, the use, DIVDMP1D.15
C duplication or disclosure of it is strictly prohibited. Permission DIVDMP1D.16
C to do so must first be obtained in writing from the Head of Numerical DIVDMP1D.17
C Modelling at the above address. DIVDMP1D.18
C ******************************COPYRIGHT****************************** DIVDMP1D.19
C DIVDMP1D.20
CLL SUBROUTINE DIV_DAMP ------------------------------------------- DIVDMP1D.21
CLL DIVDMP1D.22
CLL PURPOSE: CALCULATES AND ADDS DIVERGENCE DAMPING INCREMENTS TO DIVDMP1D.23
CLL U AND V AS DESCRIBED IN SECTION 3.4 OF DOCUMENTATION DIVDMP1D.24
CLL PAPER NO 10. DIVDMP1D.25
CLL NOT SUITABLE FOR SINGLE COLUMN USE. DIVDMP1D.26
CLL DIVDMP1D.27
CLL WRITTEN BY M.H MAWSON. DIVDMP1D.28
CLL DIVDMP1D.29
CLL MODEL MODIFICATION HISTORY: DIVDMP1D.30
CLL VERSION DATE DIVDMP1D.31
!LL 4.2 28/10/96 New deck for HADCM2-specific section A12_1D, DIVDMP1D.32
!LL as DIVDMP1A but with inconsistent 'old' type DIVDMP1D.33
!LL of polar weights. T.Johns DIVDMP1D.34
!LL 4.3 10/04/97 Updated in line with MPP optimisations. T Johns ATJ0F403.204
CLL DIVDMP1D.35
CLL PROGRAMMING STANDARD: UNIFIED MODEL DOCUMENTATION PAPER NO. 4, DIVDMP1D.36
CLL STANDARD B. VERSION 2, DATED 18/01/90 DIVDMP1D.37
CLL DIVDMP1D.38
CLL SYSTEM COMPONENTS COVERED: P15 DIVDMP1D.39
CLL DIVDMP1D.40
CLL SYSTEM TASK: P1 DIVDMP1D.41
CLL DIVDMP1D.42
CLL DOCUMENTATION: THE EQUATIONS USED ARE (30) AND (49) DIVDMP1D.43
CLL IN UNIFIED MODEL DOCUMENTATION DIVDMP1D.44
CLL PAPER NO. 10 M.J.P. CULLEN, T.DAVIES AND DIVDMP1D.45
CLLEND------------------------------------------------------------- DIVDMP1D.46
C DIVDMP1D.47
C*L ARGUMENTS:--------------------------------------------------- DIVDMP1D.48
SUBROUTINE DIV_DAMP 2,14DIVDMP1D.49
1 (U,V,RS,SEC_U_LATITUDE,PSTAR_OLD,COS_U_LATITUDE, DIVDMP1D.50
2 KD,LONGITUDE_STEP_INVERSE,LATITUDE_STEP_INVERSE, DIVDMP1D.51
3 P_FIELD,U_FIELD,ROW_LENGTH,P_LEVELS, DIVDMP1D.52
*CALL ARGFLDPT 
DIVDMP1D.53
4 BKH,ADVECTION_TIMESTEP,DELTA_AK, DIVDMP1D.54
5 DELTA_BK,COS_U_LONGITUDE,SIN_U_LONGITUDE, DIVDMP1D.55
6 SEC_P_LATITUDE) DIVDMP1D.56
DIVDMP1D.57
IMPLICIT NONE DIVDMP1D.58
DIVDMP1D.59
INTEGER DIVDMP1D.60
* P_FIELD !IN DIMENSION OF FIELDS ON PRESSSURE GRID. DIVDMP1D.61
*, U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID DIVDMP1D.62
*, P_LEVELS !IN NUMBER OF PRESSURE LEVELS. DIVDMP1D.63
*, ROW_LENGTH !IN NUMBER OF POINTS PER ROW DIVDMP1D.64
! All TYPFLDPT arguments are intent IN DIVDMP1D.65
*CALL TYPFLDPT DIVDMP1D.66
DIVDMP1D.67
REAL DIVDMP1D.68
* U(U_FIELD,P_LEVELS) !IN U VELOCITY FIELD DIVDMP1D.69
*,V(U_FIELD,P_LEVELS) !IN V VELOCITY FIELD DIVDMP1D.70
* ,COS_U_LATITUDE(U_FIELD) ! cos(lat) at u points (2nd array) DIVDMP1D.71
*,PSTAR_OLD(U_FIELD) !IN PSTAR AT PREVIOUS TIME-LEVEL AT DIVDMP1D.72
* ! U POINTS DIVDMP1D.73
*,RS(P_FIELD,P_LEVELS) !IN RS FIELD ON U GRID DIVDMP1D.74
DIVDMP1D.75
REAL DIVDMP1D.76
* DELTA_AK(P_LEVELS) !IN LAYER THICKNESS DIVDMP1D.77
*,DELTA_BK(P_LEVELS) !IN LAYER THICKNESS DIVDMP1D.78
*,BKH(P_LEVELS+1) !IN SECOND TERM IN HYBRID CO-ORDS AT DIVDMP1D.79
* ! HALF LEVELS. DIVDMP1D.80
*,SEC_U_LATITUDE(U_FIELD) !IN 1/COS(LAT) AT U POINTS (2-D ARRAY) DIVDMP1D.81
*,SEC_P_LATITUDE(P_FIELD) !IN 1/COS(LAT) AT P POINTS (2-D ARRAY) DIVDMP1D.82
*,COS_U_LONGITUDE(ROW_LENGTH) !IN COS(LONGITUDE) AT U POINTS DIVDMP1D.83
*,SIN_U_LONGITUDE(ROW_LENGTH) !IN SIN(LONGITUDE) AT U POINTS DIVDMP1D.84
*,LONGITUDE_STEP_INVERSE !IN 1/(DELTA LAMDA) DIVDMP1D.85
*,LATITUDE_STEP_INVERSE !IN 1/(DELTA PHI) DIVDMP1D.86
*,KD(P_LEVELS) !IN DIVERGENCE COEFFICIENTS. DIVDMP1D.87
*,ADVECTION_TIMESTEP !IN DIVDMP1D.88
C*--------------------------------------------------------------------- DIVDMP1D.89
DIVDMP1D.90
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- DIVDMP1D.91
C DEFINE LOCAL ARRAYS: 7 ARE REQUIRED DIVDMP1D.92
REAL DIVDMP1D.93
* D(P_FIELD) ! HOLDS DIVERGENCE AT A LEVEL DIVDMP1D.94
*, D_BY_DLAT(P_FIELD) ! HOLDS D/D(LAT) OF DIVERGENCE DIVDMP1D.95
*, D_BY_DLAT2(P_FIELD) ! HOLDS AVERAGED D_BY_DLAT DIVDMP1D.96
*, D_BY_DLONG(P_FIELD) ! HOLDS D/D(LONG) OF DIVERGENCE DIVDMP1D.97
*, DU_DLONGITUDE(U_FIELD) DIVDMP1D.98
*, DV_DLATITUDE(U_FIELD) DIVDMP1D.99
*, DV_DLATITUDE2(U_FIELD) DIVDMP1D.100
* ,U_MW(U_FIELD) ! Mass weighted u field DIVDMP1D.101
* ,V_MW(U_FIELD) ! Mass weighted v field DIVDMP1D.102
* ,RS_U_GRID(U_FIELD) ! RS field on u grid DIVDMP1D.103
DIVDMP1D.104
C*--------------------------------------------------------------------- DIVDMP1D.105
C DEFINE LOCAL VARIABLES DIVDMP1D.106
DIVDMP1D.107
*IF DEF,MPP DIVDMP1D.108
*IF DEF,GLOBAL DIVDMP1D.109
INTEGER info DIVDMP1D.110
*ELSE DIVDMP1D.111
INTEGER row_start_offset,row_end_offset DIVDMP1D.112
*ENDIF DIVDMP1D.113
*ENDIF DIVDMP1D.114
C REAL SCALARS DIVDMP1D.115
REAL DIVDMP1D.116
* SCALAR DIVDMP1D.117
*IF DEF,GLOBAL DIVDMP1D.118
*,SUM_N,SUM_S DIVDMP1D.119
*ENDIF DIVDMP1D.120
DIVDMP1D.121
C COUNT VARIABLES FOR DO LOOPS ETC. DIVDMP1D.122
INTEGER DIVDMP1D.123
* I,J,K DIVDMP1D.124
DIVDMP1D.125
C*L EXTERNAL SUBROUTINE CALLS:--------------------------------------- DIVDMP1D.126
EXTERNAL P_TO_UV DIVDMP1D.127
*IF DEF,GLOBAL DIVDMP1D.128
& ,POLAR_UV DIVDMP1D.129
GSS2F402.310
*ELSE DIVDMP1D.134
C NO EXTERNAL SUBROUTINE CALLS DIVDMP1D.135
*ENDIF DIVDMP1D.136
C*--------------------------------------------------------------------- DIVDMP1D.137
DIVDMP1D.138
CL MAXIMUM VECTOR LENGTH ASSUMED IS P_POINTS_UPDATE DIVDMP1D.139
CL--------------------------------------------------------------------- DIVDMP1D.140
CL INTERNAL STRUCTURE INCLUDING SUBROUTINE CALLS: DIVDMP1D.141
CL--------------------------------------------------------------------- DIVDMP1D.142
CL DIVDMP1D.143
CL--------------------------------------------------------------------- DIVDMP1D.144
CL SECTION 1. INITIALISATION DIVDMP1D.145
CL--------------------------------------------------------------------- DIVDMP1D.146
C INCLUDE LOCAL CONSTANTS FROM GENERAL CONSTANTS BLOCK DIVDMP1D.147
DIVDMP1D.148
DIVDMP1D.149
CL LOOP OVER P_LEVELS DIVDMP1D.150
DIVDMP1D.151
DO 100 K=1,P_LEVELS DIVDMP1D.152
IF(KD(K).GT.0.) THEN DIVDMP1D.153
CL CALCULATE MASS WEIGHTED VELOCITY COMPONENTS DIVDMP1D.154
CALL P_TO_UV(RS(1,K),RS_U_GRID,P_FIELD,U_FIELD,ROW_LENGTH, DIVDMP1D.155
& tot_P_ROWS) DIVDMP1D.156
*IF DEF,MPP ATJ0F403.205
call swapbounds(RS_U_GRID,row_length,tot_u_rows,1,1,1) ATJ0F403.206
*ENDIF ATJ0F403.207
! Loop over field, missing North and South halos DIVDMP1D.157
DO I=FIRST_VALID_PT,LAST_U_VALID_PT ATJ0F403.208
SCALAR=RS_U_GRID(I)*(DELTA_AK(K)+DELTA_BK(K)*PSTAR_OLD(I)) DIVDMP1D.159
U_MW(I)=U(I,K)*SCALAR DIVDMP1D.160
V_MW(I)=V(I,K)*SCALAR*COS_U_LATITUDE(I) DIVDMP1D.161
ENDDO DIVDMP1D.162
DIVDMP1D.163
CL DIVDMP1D.164
CL--------------------------------------------------------------------- DIVDMP1D.165
CL SECTION 2. CALCULATE DIVERGENCE USING EQUATION (30) DIVDMP1D.166
CL--------------------------------------------------------------------- DIVDMP1D.167
DIVDMP1D.168
C CALCULATE DU/D(LAMDA) DIVDMP1D.169
! Loop over field, starting at second row and ending on row above DIVDMP1D.170
! last row. Missing out North and South halos DIVDMP1D.171
DO 210 I=START_POINT_NO_HALO-ROW_LENGTH+1, DIVDMP1D.172
& LAST_U_VALID_PT ATJ0F403.209
DU_DLONGITUDE(I) = LONGITUDE_STEP_INVERSE* DIVDMP1D.174
& (U_MW(I)-U_MW(I-1)) DIVDMP1D.175
210 CONTINUE DIVDMP1D.176
DIVDMP1D.177
C CALCULATE DV/D(PHI) DIVDMP1D.178
! Loop over field, missing top and bottom rows and North and South halos DIVDMP1D.179
DO 220 I=START_POINT_NO_HALO,LAST_U_VALID_PT ATJ0F403.210
DV_DLATITUDE(I) = LATITUDE_STEP_INVERSE* DIVDMP1D.181
& (V_MW(I-ROW_LENGTH)-V_MW(I)) DIVDMP1D.182
220 CONTINUE DIVDMP1D.183
DIVDMP1D.184
*IF DEF,GLOBAL DIVDMP1D.185
C CALCULATE AVERAGE OF DV_DLATITUDE DIVDMP1D.186
! Loop over field, missing first point, poles and North and South halos DIVDMP1D.187
DO 230 I=START_POINT_NO_HALO+1,LAST_U_VALID_PT ATJ0F403.211
DV_DLATITUDE2(I) = DV_DLATITUDE(I) + DV_DLATITUDE(I-1) DIVDMP1D.189
230 CONTINUE DIVDMP1D.190
DIVDMP1D.191
C NOW DO FIRST POINT ON EACH SLICE FOR DU_DLONGITUDE AND DV_DLATITUDE2 DIVDMP1D.192
*IF -DEF,MPP DIVDMP1D.193
I=START_POINT_NO_HALO-ROW_LENGTH DIVDMP1D.194
DU_DLONGITUDE(I)=LONGITUDE_STEP_INVERSE* DIVDMP1D.195
& (U_MW(I)-U_MW(I+ROW_LENGTH-1)) DIVDMP1D.196
! Loop over the first point of each row between top and bottom rows DIVDMP1D.197
DO 240 I=START_POINT_NO_HALO,END_P_POINT_NO_HALO,ROW_LENGTH DIVDMP1D.198
DU_DLONGITUDE(I)=LONGITUDE_STEP_INVERSE* DIVDMP1D.199
& (U_MW(I)-U_MW(I+ROW_LENGTH-1)) DIVDMP1D.200
DV_DLATITUDE2(I)=DV_DLATITUDE(I)+DV_DLATITUDE(I-1+ROW_LENGTH) DIVDMP1D.201
240 CONTINUE DIVDMP1D.202
*ELSE DIVDMP1D.203
DU_DLONGITUDE(START_POINT_NO_HALO-ROW_LENGTH)=0.0 DIVDMP1D.204
DV_DLATITUDE2(START_POINT_NO_HALO)=0.0 DIVDMP1D.205
! No need to do recalculations of end points, but just need to set first DIVDMP1D.206
! point of the arrays. DIVDMP1D.207
*ENDIF DIVDMP1D.208
DIVDMP1D.209
C CALCULATE DIVERGENCES DIVDMP1D.210
DIVDMP1D.211
! Loop over field, missing top and bottom rows and North and South halos DIVDMP1D.212
DO 250 J=START_POINT_NO_HALO+1,END_P_POINT_NO_HALO ATJ0F403.212
D(J)= SEC_P_LATITUDE(J)*.5*(DU_DLONGITUDE(J) DIVDMP1D.214
* + DU_DLONGITUDE(J-ROW_LENGTH) DIVDMP1D.215
* + DV_DLATITUDE2(J)) DIVDMP1D.216
250 CONTINUE DIVDMP1D.217
*IF DEF,MPP ATJ0F403.213
call swapbounds(d,row_length,tot_p_rows,1,1,1) ATJ0F403.214
*ENDIF ATJ0F403.215
*ELSE DIVDMP1D.218
! Set first point of top row to zero DIVDMP1D.219
DU_DLONGITUDE(START_POINT_NO_HALO-ROW_LENGTH) = 0.0 DIVDMP1D.220
DIVDMP1D.221
C CALCULATE DIVERGENCES DIVDMP1D.222
DIVDMP1D.223
DO 230 J=START_POINT_NO_HALO+1,END_P_POINT_NO_HALO DIVDMP1D.224
D(J)= SEC_P_LATITUDE(J)*.5*(DU_DLONGITUDE(J) DIVDMP1D.225
* + DU_DLONGITUDE(J-ROW_LENGTH) DIVDMP1D.226
* + DV_DLATITUDE(J) + DV_DLATITUDE(J-1)) DIVDMP1D.227
230 CONTINUE DIVDMP1D.228
*IF DEF,MPP ATJ0F403.216
call swapbounds(d,row_length,tot_p_rows,1,1,1) ATJ0F403.217
*ENDIF ATJ0F403.218
DIVDMP1D.229
C ZERO DIVERGENCES ON BOUNDARIES. DIVDMP1D.230
*IF DEF,MPP DIVDMP1D.231
IF (at_top_of_LPG) THEN DIVDMP1D.232
*ENDIF DIVDMP1D.233
! Loop over Northern row DIVDMP1D.234
DO J=TOP_ROW_START,TOP_ROW_START+ROW_LENGTH-1 DIVDMP1D.235
D(J)=0.0 DIVDMP1D.236
ENDDO DIVDMP1D.237
*IF DEF,MPP DIVDMP1D.238
ENDIF DIVDMP1D.239
DIVDMP1D.240
IF (at_base_of_LPG) THEN DIVDMP1D.241
*ENDIF DIVDMP1D.242
! Loop over Southern row DIVDMP1D.243
DO J=P_BOT_ROW_START,P_BOT_ROW_START+ROW_LENGTH-1 DIVDMP1D.244
D(J)=0.0 DIVDMP1D.245
ENDDO DIVDMP1D.246
*IF DEF,MPP DIVDMP1D.247
ENDIF DIVDMP1D.248
DIVDMP1D.249
IF (at_left_of_LPG) THEN DIVDMP1D.250
*ENDIF DIVDMP1D.251
! Loop over first point in each row DIVDMP1D.252
DO J=START_POINT_NO_HALO+FIRST_ROW_PT-1, DIVDMP1D.253
& END_P_POINT_NO_HALO,ROW_LENGTH DIVDMP1D.254
D(J)=0.0 DIVDMP1D.255
ENDDO DIVDMP1D.256
*IF DEF,MPP DIVDMP1D.257
ENDIF DIVDMP1D.258
DIVDMP1D.259
IF (at_right_of_LPG) THEN DIVDMP1D.260
*ENDIF DIVDMP1D.261
! Loop over last point in each row DIVDMP1D.262
DO J=START_POINT_NO_HALO+LAST_ROW_PT-1, DIVDMP1D.263
& END_P_POINT_NO_HALO,ROW_LENGTH DIVDMP1D.264
D(J)=0.0 DIVDMP1D.265
ENDDO DIVDMP1D.266
*IF DEF,MPP DIVDMP1D.267
ENDIF DIVDMP1D.268
*ENDIF DIVDMP1D.269
*ENDIF DIVDMP1D.270
DIVDMP1D.271
*IF DEF,GLOBAL DIVDMP1D.272
C CALCULATE DIVERGENCE AT POLES. DIVDMP1D.273
! Note that factor 8. is incorrect, but consistent with HADCM2 DIVDMP1D.274
SCALAR = 8.*LATITUDE_STEP_INVERSE * LATITUDE_STEP_INVERSE / DIVDMP1D.275
& GLOBAL_ROW_LENGTH DIVDMP1D.276
DIVDMP1D.277
SUM_N = 0.0 DIVDMP1D.278
SUM_S = 0.0 DIVDMP1D.279
DIVDMP1D.280
! North Pole DIVDMP1D.281
*IF -DEF,MPP DIVDMP1D.282
! Loop over North Pole row DIVDMP1D.283
DO I=TOP_ROW_START,TOP_ROW_START+ROW_LENGTH-1 DIVDMP1D.284
SUM_N=SUM_N-V_MW(I) DIVDMP1D.285
ENDDO DIVDMP1D.286
*ELSE DIVDMP1D.287
IF (at_top_of_LPG) THEN DIVDMP1D.288
CALL GCG_RVECSUMR(U_FIELD,ROW_LENGTH-2*EW_Halo, DIVDMP1D.289
& TOP_ROW_START+FIRST_ROW_PT-1,1, DIVDMP1D.290
& V_MW,GC_ROW_GROUP,info,SUM_N) DIVDMP1D.291
SUM_N=-SUM_N DIVDMP1D.292
*ENDIF DIVDMP1D.293
DIVDMP1D.294
! Set all points on North Pole row to this value DIVDMP1D.295
DO I=TOP_ROW_START,TOP_ROW_START+ROW_LENGTH-1 DIVDMP1D.296
D(I)=SUM_N DIVDMP1D.297
ENDDO DIVDMP1D.298
*IF DEF,MPP DIVDMP1D.299
ENDIF DIVDMP1D.300
*ENDIF DIVDMP1D.301
DIVDMP1D.302
! South Pole DIVDMP1D.303
*IF -DEF,MPP DIVDMP1D.304
! Loop over South Pole row DIVDMP1D.305
DO I=U_BOT_ROW_START,U_BOT_ROW_START+ROW_LENGTH-1 DIVDMP1D.306
SUM_S=SUM_S+V_MW(I) DIVDMP1D.307
ENDDO DIVDMP1D.308
*ELSE DIVDMP1D.309
IF (at_base_of_LPG) THEN DIVDMP1D.310
CALL GCG_RVECSUMR(U_FIELD,ROW_LENGTH-2*EW_Halo, DIVDMP1D.311
& U_BOT_ROW_START+FIRST_ROW_PT-1,1, DIVDMP1D.312
& V_MW,GC_ROW_GROUP,info,SUM_S) DIVDMP1D.313
*ENDIF DIVDMP1D.314
DIVDMP1D.315
! Set all points on South Pole row to this value DIVDMP1D.316
DO I=P_BOT_ROW_START,P_BOT_ROW_START+ROW_LENGTH-1 DIVDMP1D.317
D(I)=SUM_S DIVDMP1D.318
ENDDO DIVDMP1D.319
*IF DEF,MPP DIVDMP1D.320
ENDIF DIVDMP1D.321
*ENDIF DIVDMP1D.322
*ENDIF DIVDMP1D.323
DIVDMP1D.324
CL DIVDMP1D.325
CL--------------------------------------------------------------------- DIVDMP1D.326
CL SECTION 3. CALCULATE D(D)/D(LONGITUDE) DIVDMP1D.327
CL--------------------------------------------------------------------- DIVDMP1D.328
DIVDMP1D.329
! Loop over field, missing top and bottom rows and halos DIVDMP1D.330
DO 300 I=START_POINT_NO_HALO,END_P_POINT_INC_HALO-1 ATJ0F403.219
D_BY_DLONG(I) = (D(I+1) - D(I))*LONGITUDE_STEP_INVERSE DIVDMP1D.332
300 CONTINUE DIVDMP1D.333
DIVDMP1D.334
CL DIVDMP1D.335
CL--------------------------------------------------------------------- DIVDMP1D.336
CL SECTION 4. CALCULATE D(D)/D(LATITUDE) DIVDMP1D.337
CL UPDATE V FIELD WITH DIVERGENCE. DIVDMP1D.338
CL UPDATE U FIELD WITH DIVERGENCE DIVDMP1D.339
CL IF GLOBAL CALL POLAR_UV TO UPDATE U AND V AT POLE. DIVDMP1D.340
CL--------------------------------------------------------------------- DIVDMP1D.341
DIVDMP1D.342
C---------------------------------------------------------------------- DIVDMP1D.343
CL SECTION 4.1 CALCULATE D(D)/D(LATITUDE) DIVDMP1D.344
C---------------------------------------------------------------------- DIVDMP1D.345
DIVDMP1D.346
! Loop over field, including Northern row but missing Southern row and DIVDMP1D.347
! top and bottom halos DIVDMP1D.348
DO 410 I=START_POINT_NO_HALO-ROW_LENGTH, DIVDMP1D.349
& END_P_POINT_NO_HALO DIVDMP1D.350
D_BY_DLAT(I) = (D(I)-D(I+ROW_LENGTH))*LATITUDE_STEP_INVERSE DIVDMP1D.351
410 CONTINUE DIVDMP1D.352
DIVDMP1D.353
C---------------------------------------------------------------------- DIVDMP1D.354
CL SECTION 4.2 UPDATE V FIELD WITH DIVERGENCE DIVDMP1D.355
CL UPDATE U FIELD WITH DIVERGENCE DIVDMP1D.356
C---------------------------------------------------------------------- DIVDMP1D.357
DIVDMP1D.358
*IF DEF,GLOBAL DIVDMP1D.359
C GLOBAL MODEL, CALCULATE SECOND V TERM IN EQUATION. DIVDMP1D.360
! Loop over field, including Northern row, but missing Southern row, and DIVDMP1D.361
! last point of last row, and top and bottom halos DIVDMP1D.362
DO 420 I=START_POINT_NO_HALO-ROW_LENGTH, DIVDMP1D.363
& END_P_POINT_NO_HALO-1 DIVDMP1D.364
D_BY_DLAT2(I) = KD(K)*.5*(D_BY_DLAT(I)+D_BY_DLAT(I+1)) DIVDMP1D.365
* *ADVECTION_TIMESTEP DIVDMP1D.366
420 CONTINUE DIVDMP1D.367
DIVDMP1D.368
C NOW DO END POINTS. DIVDMP1D.369
*IF -DEF,MPP DIVDMP1D.370
! Loop over last point of each row DIVDMP1D.371
DO 424 I=START_POINT_NO_HALO+LAST_ROW_PT-1, DIVDMP1D.372
& END_P_POINT_NO_HALO,ROW_LENGTH DIVDMP1D.373
D_BY_DLAT2(I)= KD(K)*.5*(D_BY_DLAT(I)+ DIVDMP1D.374
* D_BY_DLAT(I+1-ROW_LENGTH))*ADVECTION_TIMESTEP DIVDMP1D.375
C DO END POINTS FOR SECTION 3.1 DIVDMP1D.376
D_BY_DLONG(I)=(D(I+1-ROW_LENGTH)-D(I))*LONGITUDE_STEP_INVERSE DIVDMP1D.377
424 CONTINUE DIVDMP1D.378
DIVDMP1D.379
C DO FIRST END POINT OF SECTION 4.1. DIVDMP1D.380
D_BY_DLAT2(TOP_ROW_START+LAST_ROW_PT-1)= KD(K)*.5* DIVDMP1D.381
& (D_BY_DLAT(TOP_ROW_START)+ DIVDMP1D.382
& D_BY_DLAT(TOP_ROW_START+LAST_ROW_PT-1))*ADVECTION_TIMESTEP DIVDMP1D.383
*ELSE DIVDMP1D.384
D_BY_DLAT2(END_P_POINT_NO_HALO)= DIVDMP1D.385
& D_BY_DLAT2(END_P_POINT_NO_HALO-1) DIVDMP1D.386
! MPP Code : No need to do recalculations of end points because cyclic DIVDMP1D.387
! boundary conditions means that halos do this for us automatically DIVDMP1D.388
DIVDMP1D.389
*ENDIF DIVDMP1D.390
DIVDMP1D.391
C UPDATE U AND V FIELDS WITH DIVERGENCE DIVDMP1D.392
DIVDMP1D.393
C UPDATE ALL POINTS. DIVDMP1D.394
! Loop over U field, missing Northern and Southern rows and top and DIVDMP1D.395
! bottom halos. DIVDMP1D.396
DO 426 I=START_POINT_NO_HALO,END_U_POINT_NO_HALO-1 ATJ0F403.220
SCALAR=1./(RS_U_GRID(I)*RS_U_GRID(I)*RS_U_GRID(I) DIVDMP1D.398
* *(DELTA_AK(K)+DELTA_BK(K)*PSTAR_OLD(I))) DIVDMP1D.399
U(I,K) = U(I,K) + KD(K)*.5*(D_BY_DLONG(I)+ DIVDMP1D.400
* D_BY_DLONG(I+ROW_LENGTH)) DIVDMP1D.401
* *SEC_U_LATITUDE(I)*ADVECTION_TIMESTEP*SCALAR DIVDMP1D.402
V(I,K) = V(I,K) + D_BY_DLAT2(I)*SCALAR DIVDMP1D.403
426 CONTINUE DIVDMP1D.404
*ELSE DIVDMP1D.405
CL LIMITED AREA MODEL. FIRST,PENULTIMATE AND LAST V VALUES ON A ROW DIVDMP1D.406
CL NOT UPDATED. DIVDMP1D.407
*IF DEF,MPP DIVDMP1D.408
! For the MPP code this requires a little more code. Only processors DIVDMP1D.409
! at the left and right of the LPG need to miss points out. DIVDMP1D.410
! We can also be sneaky and use the code structure to avoid duplicate DIVDMP1D.411
! calculations by avoiding the halo areas. DIVDMP1D.412
IF (at_left_of_LPG) THEN DIVDMP1D.413
row_start_offset=EW_Halo+1 ! Miss halo and first point DIVDMP1D.414
ELSE DIVDMP1D.415
row_start_offset=EW_Halo ! Miss halo only DIVDMP1D.416
ENDIF DIVDMP1D.417
DIVDMP1D.418
IF (at_right_of_LPG) THEN DIVDMP1D.419
row_end_offset=ROW_LENGTH-EW_Halo-2-1 ! Miss last two DIVDMP1D.420
! ! points and halo DIVDMP1D.421
ELSE DIVDMP1D.422
row_end_offset=ROW_LENGTH-EW_Halo-1 ! Miss out halo only DIVDMP1D.423
ENDIF DIVDMP1D.424
*ENDIF DIVDMP1D.425
DO 420 J=START_POINT_NO_HALO,END_U_POINT_NO_HALO,ROW_LENGTH DIVDMP1D.426
*IF -DEF,MPP DIVDMP1D.427
DO 422 I=J+1,J+ROW_LENGTH-3 DIVDMP1D.428
*ELSE DIVDMP1D.429
DO 422 I=J+row_start_offset,J+row_end_offset DIVDMP1D.430
*ENDIF DIVDMP1D.431
SCALAR=1./(RS_U_GRID(I)*RS_U_GRID(I)*RS_U_GRID(I) DIVDMP1D.432
* *(DELTA_AK(K)+DELTA_BK(K)*PSTAR_OLD(I))) DIVDMP1D.433
U(I,K) = U(I,K) + KD(K)*.5*(D_BY_DLONG(I)+ DIVDMP1D.434
* D_BY_DLONG(I+ROW_LENGTH)) DIVDMP1D.435
* *SEC_U_LATITUDE(I)*ADVECTION_TIMESTEP*SCALAR DIVDMP1D.436
V(I,K)=V(I,K)+KD(K)*.5*(D_BY_DLAT(I)+ DIVDMP1D.437
* D_BY_DLAT(I+1))*ADVECTION_TIMESTEP*SCALAR DIVDMP1D.438
422 CONTINUE DIVDMP1D.439
420 CONTINUE DIVDMP1D.440
*ENDIF ATJ0F403.221
*IF DEF,MPP ATJ0F403.222
call swapbounds(u,row_length,tot_u_rows,1,1,p_levels) ATJ0F403.223
call swapbounds(v,row_length,tot_u_rows,1,1,p_levels) ATJ0F403.224
*ENDIF DIVDMP1D.441
DIVDMP1D.442
C---------------------------------------------------------------------- DIVDMP1D.443
CL SECTION 4.3 GLOBAL MODEL POLAR UPDATE OF U AND V. DIVDMP1D.444
C---------------------------------------------------------------------- DIVDMP1D.445
DIVDMP1D.446
*IF DEF,GLOBAL DIVDMP1D.447
DIVDMP1D.448
CL CALL POLAR_UV TO UPDATE U AND V. DIVDMP1D.449
DIVDMP1D.450
CALL POLAR_UV(U(1,K),V(1,K),ROW_LENGTH,U_FIELD,1, DIVDMP1D.451
*CALL ARGFLDPT DIVDMP1D.452
& COS_U_LONGITUDE,SIN_U_LONGITUDE) DIVDMP1D.453
DIVDMP1D.454
*ENDIF DIVDMP1D.455
DIVDMP1D.456
END IF DIVDMP1D.457
CL END LOOP OVER LEVELS DIVDMP1D.458
DIVDMP1D.459
100 CONTINUE DIVDMP1D.460
DIVDMP1D.461
CL END OF ROUTINE DIV_DAMP DIVDMP1D.462
DIVDMP1D.463
RETURN DIVDMP1D.464
END DIVDMP1D.465
*ENDIF DIVDMP1D.466