*IF DEF,A12_1B,OR,DEF,A12_1C,OR,DEF,A12_1E AAD2F404.249
C ******************************COPYRIGHT****************************** GTS2F400.2215
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.2216
C GTS2F400.2217
C Use, duplication or disclosure of this code is subject to the GTS2F400.2218
C restrictions as set forth in the contract. GTS2F400.2219
C GTS2F400.2220
C Meteorological Office GTS2F400.2221
C London Road GTS2F400.2222
C BRACKNELL GTS2F400.2223
C Berkshire UK GTS2F400.2224
C RG12 2SZ GTS2F400.2225
C GTS2F400.2226
C If no contract has been raised with this copy of the code, the use, GTS2F400.2227
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.2228
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.2229
C Modelling at the above address. GTS2F400.2230
C ******************************COPYRIGHT****************************** GTS2F400.2231
C GTS2F400.2232
CLL SUBROUTINE DIV_DAMP ------------------------------------------- DIVDMP1A.3
CLL DIVDMP1A.4
CLL PURPOSE: CALCULATES AND ADDS DIVERGENCE DAMPING INCREMENTS TO DIVDMP1A.5
CLL U AND V AS DESCRIBED IN SECTION 3.4 OF DOCUMENTATION DIVDMP1A.6
CLL PAPER NO 10. DIVDMP1A.7
CLL NOT SUITABLE FOR SINGLE COLUMN USE. DIVDMP1A.8
CLL DIVDMP1A.9
CLL WRITTEN BY M.H MAWSON. DIVDMP1A.10
CLL DIVDMP1A.11
CLL MODEL MODIFICATION HISTORY FROM MODEL VERSION 3.0: DIVDMP1A.12
CLL VERSION DATE DIVDMP1A.13
CLL 4.0 10/07/95 SEC_P_LATITUDE at pole changed for consistency ACH1F400.36
CLL with other parts of UM code. C.D.Hall ACH1F400.37
! 3.5 28/03/95 MPP code: Change updateable area and APB0F305.659
! remove wrap around code. P.Burton APB0F305.660
! 4.1 23/04/96 Added TYPFLDPT arguments to dynamics routines APB0F401.880
! which allows many of the differences between APB0F401.881
! MPP and "normal" code to be at top level APB0F401.882
! P.Burton APB0F401.883
CLL GDS1F402.1831
CLL 4.2 4/12/96 : FIX to code to make it work for MPP GDS1F402.1832
CLL Alan Dickinson and Deborah Salmond GDS1F402.1833
CLL 4.4 18/11/97 Correction to loop bound: divergence for first point ASB1F404.244
CLL following polar row (non-MPP only) used but not ASB1F404.245
CLL assigned. Rick Rawlins ASB1F404.246
CLL DIVDMP1A.14
CLL PROGRAMMING STANDARD: UNIFIED MODEL DOCUMENTATION PAPER NO. 4, DIVDMP1A.15
CLL STANDARD B. VERSION 2, DATED 18/01/90 DIVDMP1A.16
CLL DIVDMP1A.17
CLL SYSTEM COMPONENTS COVERED: P15 DIVDMP1A.18
CLL DIVDMP1A.19
CLL SYSTEM TASK: P1 DIVDMP1A.20
CLL DIVDMP1A.21
CLL DOCUMENTATION: THE EQUATIONS USED ARE (30) AND (49) DIVDMP1A.22
CLL IN UNIFIED MODEL DOCUMENTATION DIVDMP1A.23
CLL PAPER NO. 10 M.J.P. CULLEN, T.DAVIES AND DIVDMP1A.24
CLLEND------------------------------------------------------------- DIVDMP1A.25
C DIVDMP1A.26
C*L ARGUMENTS:--------------------------------------------------- DIVDMP1A.27
SUBROUTINE DIV_DAMP 2,14DIVDMP1A.28
1 (U,V,RS,SEC_U_LATITUDE,PSTAR_OLD,COS_U_LATITUDE, DIVDMP1A.29
2 KD,LONGITUDE_STEP_INVERSE,LATITUDE_STEP_INVERSE, DIVDMP1A.30
3 P_FIELD,U_FIELD,ROW_LENGTH,P_LEVELS, APB0F401.884
*CALL ARGFLDPT 
APB0F401.885
4 BKH,ADVECTION_TIMESTEP,DELTA_AK, APB0F401.886
5 DELTA_BK,COS_U_LONGITUDE,SIN_U_LONGITUDE, DIVDMP1A.33
6 SEC_P_LATITUDE) DIVDMP1A.34
DIVDMP1A.35
IMPLICIT NONE DIVDMP1A.36
DIVDMP1A.37
INTEGER DIVDMP1A.38
* P_FIELD !IN DIMENSION OF FIELDS ON PRESSSURE GRID. DIVDMP1A.39
*, U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID DIVDMP1A.40
*, P_LEVELS !IN NUMBER OF PRESSURE LEVELS. DIVDMP1A.42
*, ROW_LENGTH !IN NUMBER OF POINTS PER ROW DIVDMP1A.44
! All TYPFLDPT arguments are intent IN APB0F401.887
*CALL TYPFLDPT APB0F401.888
DIVDMP1A.45
REAL DIVDMP1A.46
* U(U_FIELD,P_LEVELS) !IN U VELOCITY FIELD DIVDMP1A.47
*,V(U_FIELD,P_LEVELS) !IN V VELOCITY FIELD DIVDMP1A.48
* ,COS_U_LATITUDE(U_FIELD) ! cos(lat) at u points (2nd array) DIVDMP1A.49
*,PSTAR_OLD(U_FIELD) !IN PSTAR AT PREVIOUS TIME-LEVEL AT DIVDMP1A.50
* ! U POINTS DIVDMP1A.51
*,RS(P_FIELD,P_LEVELS) !IN RS FIELD ON U GRID DIVDMP1A.52
DIVDMP1A.53
REAL DIVDMP1A.54
* DELTA_AK(P_LEVELS) !IN LAYER THICKNESS DIVDMP1A.55
*,DELTA_BK(P_LEVELS) !IN LAYER THICKNESS DIVDMP1A.56
*,BKH(P_LEVELS+1) !IN SECOND TERM IN HYBRID CO-ORDS AT DIVDMP1A.57
* ! HALF LEVELS. DIVDMP1A.58
*,SEC_U_LATITUDE(U_FIELD) !IN 1/COS(LAT) AT U POINTS (2-D ARRAY) DIVDMP1A.59
*,SEC_P_LATITUDE(P_FIELD) !IN 1/COS(LAT) AT P POINTS (2-D ARRAY) DIVDMP1A.60
*,COS_U_LONGITUDE(ROW_LENGTH) !IN COS(LONGITUDE) AT U POINTS DIVDMP1A.61
*,SIN_U_LONGITUDE(ROW_LENGTH) !IN SIN(LONGITUDE) AT U POINTS DIVDMP1A.62
*,LONGITUDE_STEP_INVERSE !IN 1/(DELTA LAMDA) DIVDMP1A.63
*,LATITUDE_STEP_INVERSE !IN 1/(DELTA PHI) DIVDMP1A.64
*,KD(P_LEVELS) !IN DIVERGENCE COEFFICIENTS. DIVDMP1A.65
*,ADVECTION_TIMESTEP !IN DIVDMP1A.66
C*--------------------------------------------------------------------- DIVDMP1A.67
DIVDMP1A.68
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- DIVDMP1A.69
C DEFINE LOCAL ARRAYS: 7 ARE REQUIRED DIVDMP1A.70
REAL DIVDMP1A.71
* D(P_FIELD) ! HOLDS DIVERGENCE AT A LEVEL DIVDMP1A.72
*, D_BY_DLAT(P_FIELD) ! HOLDS D/D(LAT) OF DIVERGENCE DIVDMP1A.73
*, D_BY_DLAT2(P_FIELD) ! HOLDS AVERAGED D_BY_DLAT DIVDMP1A.74
*, D_BY_DLONG(P_FIELD) ! HOLDS D/D(LONG) OF DIVERGENCE DIVDMP1A.75
*, DU_DLONGITUDE(U_FIELD) DIVDMP1A.76
*, DV_DLATITUDE(U_FIELD) DIVDMP1A.77
*, DV_DLATITUDE2(U_FIELD) DIVDMP1A.78
* ,U_MW(U_FIELD) ! Mass weighted u field DIVDMP1A.79
* ,V_MW(U_FIELD) ! Mass weighted v field DIVDMP1A.80
* ,RS_U_GRID(U_FIELD) ! RS field on u grid DIVDMP1A.81
DIVDMP1A.82
C*--------------------------------------------------------------------- DIVDMP1A.83
C DEFINE LOCAL VARIABLES DIVDMP1A.84
DIVDMP1A.94
*IF DEF,MPP APB0F401.889
*IF DEF,GLOBAL APB0F401.890
INTEGER info APB0F401.891
*ELSE APB0F401.892
INTEGER row_start_offset,row_end_offset APB0F401.893
*ENDIF APB0F401.894
*ENDIF APB0F401.895
C REAL SCALARS DIVDMP1A.95
REAL DIVDMP1A.96
* SCALAR DIVDMP1A.97
*IF DEF,GLOBAL DIVDMP1A.98
*,SUM_N,SUM_S DIVDMP1A.100
*ENDIF DIVDMP1A.102
DIVDMP1A.103
C COUNT VARIABLES FOR DO LOOPS ETC. DIVDMP1A.104
INTEGER DIVDMP1A.105
* I,J,K DIVDMP1A.106
DIVDMP1A.107
C*L EXTERNAL SUBROUTINE CALLS:--------------------------------------- DIVDMP1A.108
EXTERNAL P_TO_UV DIVDMP1A.109
*IF DEF,GLOBAL DIVDMP1A.110
& ,POLAR_UV DIVDMP1A.111
*IF DEF,CRAY DIVDMP1A.112
*, SSUM DIVDMP1A.113
REAL SSUM DIVDMP1A.114
*ENDIF DIVDMP1A.115
*ELSE DIVDMP1A.116
C NO EXTERNAL SUBROUTINE CALLS DIVDMP1A.117
*ENDIF DIVDMP1A.118
C*--------------------------------------------------------------------- DIVDMP1A.119
DIVDMP1A.120
CL MAXIMUM VECTOR LENGTH ASSUMED IS P_POINTS_UPDATE DIVDMP1A.121
CL--------------------------------------------------------------------- DIVDMP1A.122
CL INTERNAL STRUCTURE INCLUDING SUBROUTINE CALLS: DIVDMP1A.123
CL--------------------------------------------------------------------- DIVDMP1A.124
CL DIVDMP1A.125
CL--------------------------------------------------------------------- DIVDMP1A.126
CL SECTION 1. INITIALISATION DIVDMP1A.127
CL--------------------------------------------------------------------- DIVDMP1A.128
C INCLUDE LOCAL CONSTANTS FROM GENERAL CONSTANTS BLOCK DIVDMP1A.129
DIVDMP1A.130
DIVDMP1A.137
CL LOOP OVER P_LEVELS DIVDMP1A.138
DIVDMP1A.139
DO 100 K=1,P_LEVELS DIVDMP1A.140
IF(KD(K).GT.0.) THEN DIVDMP1A.141
CL CALCULATE MASS WEIGHTED VELOCITY COMPONENTS DIVDMP1A.142
CALL P_TO_UV(RS(1,K),RS_U_GRID,P_FIELD,U_FIELD,ROW_LENGTH, APB0F401.896
& tot_P_ROWS) APB0F401.897
*IF DEF,MPP GDS1F402.1835
call swapbounds(RS_U_GRID,row_length,tot_u_rows,1,1,1) GDS1F402.1836
*ENDIF GDS1F402.1837
! Loop over field, missing North and South halos APB0F401.898
DO I=FIRST_VALID_PT,LAST_U_VALID_PT GDS1F402.1838
SCALAR=RS_U_GRID(I)*(DELTA_AK(K)+DELTA_BK(K)*PSTAR_OLD(I)) DIVDMP1A.145
U_MW(I)=U(I,K)*SCALAR DIVDMP1A.146
V_MW(I)=V(I,K)*SCALAR*COS_U_LATITUDE(I) DIVDMP1A.147
ENDDO DIVDMP1A.148
DIVDMP1A.149
CL DIVDMP1A.150
CL--------------------------------------------------------------------- DIVDMP1A.151
CL SECTION 2. CALCULATE DIVERGENCE USING EQUATION (30) DIVDMP1A.152
CL--------------------------------------------------------------------- DIVDMP1A.153
DIVDMP1A.154
C CALCULATE DU/D(LAMDA) DIVDMP1A.155
! Loop over field, starting at second row and ending on row above APB0F401.900
! last row. Missing out North and South halos APB0F401.901
DO 210 I=START_POINT_NO_HALO-ROW_LENGTH+1, APB0F401.902
& LAST_U_VALID_PT GDS1F402.1839
DU_DLONGITUDE(I) = LONGITUDE_STEP_INVERSE* DIVDMP1A.157
& (U_MW(I)-U_MW(I-1)) DIVDMP1A.158
210 CONTINUE DIVDMP1A.159
DIVDMP1A.160
C CALCULATE DV/D(PHI) DIVDMP1A.161
! Loop over field, missing top and bottom rows and North and South halos APB0F401.904
DO 220 I=START_POINT_NO_HALO,LAST_U_VALID_PT GDS1F402.1840
DV_DLATITUDE(I) = LATITUDE_STEP_INVERSE* DIVDMP1A.163
& (V_MW(I-ROW_LENGTH)-V_MW(I)) DIVDMP1A.164
220 CONTINUE DIVDMP1A.165
DIVDMP1A.166
*IF DEF,GLOBAL DIVDMP1A.167
C CALCULATE AVERAGE OF DV_DLATITUDE DIVDMP1A.168
! Loop over field, missing first point, poles and North and South halos APB0F401.906
DO 230 I=START_POINT_NO_HALO+1,LAST_U_VALID_PT GDS1F402.1841
DV_DLATITUDE2(I) = DV_DLATITUDE(I) + DV_DLATITUDE(I-1) DIVDMP1A.170
230 CONTINUE DIVDMP1A.171
DIVDMP1A.172
C NOW DO FIRST POINT ON EACH SLICE FOR DU_DLONGITUDE AND DV_DLATITUDE2 DIVDMP1A.173
*IF -DEF,MPP APB0F305.680
I=START_POINT_NO_HALO-ROW_LENGTH APB0F401.908
DU_DLONGITUDE(I)=LONGITUDE_STEP_INVERSE* DIVDMP1A.175
& (U_MW(I)-U_MW(I+ROW_LENGTH-1)) DIVDMP1A.176
! Loop over the first point of each row between top and bottom rows APB0F401.909
DO 240 I=START_POINT_NO_HALO,END_P_POINT_NO_HALO,ROW_LENGTH APB0F401.910
DU_DLONGITUDE(I)=LONGITUDE_STEP_INVERSE* DIVDMP1A.178
& (U_MW(I)-U_MW(I+ROW_LENGTH-1)) DIVDMP1A.179
DV_DLATITUDE2(I)=DV_DLATITUDE(I)+DV_DLATITUDE(I-1+ROW_LENGTH) DIVDMP1A.180
240 CONTINUE DIVDMP1A.181
*ELSE APB0F305.681
DU_DLONGITUDE(START_POINT_NO_HALO-ROW_LENGTH)=0.0 APB0F401.911
DV_DLATITUDE2(START_POINT_NO_HALO)=0.0 APB0F401.912
! No need to do recalculations of end points, but just need to set first APB0F401.913
! point of the arrays. APB0F401.914
*ENDIF APB0F305.686
DIVDMP1A.182
C CALCULATE DIVERGENCES DIVDMP1A.183
DIVDMP1A.184
! Loop over field, missing top and bottom rows and North and South halos APB0F401.915
DO 250 J=START_POINT_NO_HALO,END_P_POINT_NO_HALO ASB1F404.247
D(J)= SEC_P_LATITUDE(J)*.5*(DU_DLONGITUDE(J) DIVDMP1A.186
* + DU_DLONGITUDE(J-ROW_LENGTH) DIVDMP1A.187
* + DV_DLATITUDE2(J)) DIVDMP1A.188
250 CONTINUE DIVDMP1A.189
*IF DEF,MPP GDS1F402.1843
call swapbounds(d,row_length,tot_p_rows,1,1,1) GDS1F402.1844
*ENDIF GDS1F402.1845
*ELSE DIVDMP1A.190
! Set first point of top row to zero APB0F401.917
DU_DLONGITUDE(START_POINT_NO_HALO-ROW_LENGTH) = 0.0 APB0F401.918
DIVDMP1A.192
C CALCULATE DIVERGENCES DIVDMP1A.193
DIVDMP1A.194
DO 230 J=START_POINT_NO_HALO+1,END_P_POINT_NO_HALO APB0F401.919
D(J)= SEC_P_LATITUDE(J)*.5*(DU_DLONGITUDE(J) DIVDMP1A.196
* + DU_DLONGITUDE(J-ROW_LENGTH) DIVDMP1A.197
* + DV_DLATITUDE(J) + DV_DLATITUDE(J-1)) DIVDMP1A.198
230 CONTINUE DIVDMP1A.199
*IF DEF,MPP GDS1F402.1846
call swapbounds(d,row_length,tot_p_rows,1,1,1) GDS1F402.1847
*ENDIF GDS1F402.1848
DIVDMP1A.200
C ZERO DIVERGENCES ON BOUNDARIES. DIVDMP1A.201
*IF DEF,MPP APB0F401.920
IF (at_top_of_LPG) THEN APB0F401.921
*ENDIF APB0F401.922
! Loop over Northern row APB0F401.923
DO J=TOP_ROW_START,TOP_ROW_START+ROW_LENGTH-1 APB0F401.924
D(J)=0.0 APB0F401.925
ENDDO APB0F401.926
*IF DEF,MPP APB0F401.927
ENDIF APB0F401.928
APB0F401.929
IF (at_base_of_LPG) THEN APB0F401.930
*ENDIF APB0F401.931
! Loop over Southern row APB0F401.932
DO J=P_BOT_ROW_START,P_BOT_ROW_START+ROW_LENGTH-1 APB0F401.933
D(J)=0.0 APB0F401.934
ENDDO APB0F401.935
*IF DEF,MPP APB0F401.936
ENDIF APB0F401.937
APB0F401.938
IF (at_left_of_LPG) THEN APB0F401.939
*ENDIF APB0F401.940
! Loop over first point in each row APB0F401.941
DO J=START_POINT_NO_HALO+FIRST_ROW_PT-1, APB0F401.942
& END_P_POINT_NO_HALO,ROW_LENGTH APB0F401.943
D(J)=0.0 APB0F401.944
ENDDO APB0F401.945
*IF DEF,MPP APB0F401.946
ENDIF APB0F401.947
APB0F401.948
IF (at_right_of_LPG) THEN APB0F401.949
*ENDIF APB0F401.950
! Loop over last point in each row APB0F401.951
DO J=START_POINT_NO_HALO+LAST_ROW_PT-1, APB0F401.952
& END_P_POINT_NO_HALO,ROW_LENGTH APB0F401.953
D(J)=0.0 APB0F401.954
ENDDO APB0F401.955
*IF DEF,MPP APB0F401.956
ENDIF APB0F401.957
*ENDIF APB0F401.958
*ENDIF DIVDMP1A.210
DIVDMP1A.211
*IF DEF,GLOBAL DIVDMP1A.212
C CALCULATE DIVERGENCE AT POLES. DIVDMP1A.213
SCALAR = LATITUDE_STEP_INVERSE*SEC_P_LATITUDE(TOP_ROW_START)/ APB0F401.959
& GLOBAL_ROW_LENGTH APB0F401.960
APB0F401.961
SUM_N = 0.0 APB0F401.962
SUM_S = 0.0 APB0F401.963
APB0F401.964
! North Pole APB0F401.965
*IF -DEF,MPP APB0F401.966
! Loop over North Pole row APB0F401.967
DO I=TOP_ROW_START,TOP_ROW_START+ROW_LENGTH-1 APB0F401.968
SUM_N=SUM_N-V_MW(I) APB0F401.969
ENDDO APB0F401.970
*ELSE APB0F401.971
IF (at_top_of_LPG) THEN APB0F401.972
CALL GCG_RVECSUMR(U_FIELD,ROW_LENGTH-2*EW_Halo, APB0F401.973
& TOP_ROW_START+FIRST_ROW_PT-1,1, APB0F401.974
& V_MW,GC_ROW_GROUP,info,SUM_N) APB0F401.975
SUM_N=-SUM_N APB0F401.976
*ENDIF APB0F401.977
APB0F401.978
! Set all points on North Pole row to this value APB0F401.979
DO I=TOP_ROW_START,TOP_ROW_START+ROW_LENGTH-1 APB0F401.980
D(I)=SUM_N APB0F401.981
ENDDO APB0F401.982
*IF DEF,MPP APB0F401.983
ENDIF APB0F401.984
*ENDIF APB0F401.985
APB0F401.986
! South Pole APB0F401.987
*IF -DEF,MPP APB0F401.988
! Loop over South Pole row APB0F401.989
DO I=U_BOT_ROW_START,U_BOT_ROW_START+ROW_LENGTH-1 APB0F401.990
SUM_S=SUM_S+V_MW(I) APB0F401.991
ENDDO APB0F401.992
*ELSE APB0F401.993
IF (at_base_of_LPG) THEN APB0F401.994
CALL GCG_RVECSUMR(U_FIELD,ROW_LENGTH-2*EW_Halo, APB0F401.995
& U_BOT_ROW_START+FIRST_ROW_PT-1,1, APB0F401.996
& V_MW,GC_ROW_GROUP,info,SUM_S) APB0F401.997
*ENDIF APB0F401.998
APB0F401.999
! Set all points on South Pole row to this value APB0F401.1000
DO I=P_BOT_ROW_START,P_BOT_ROW_START+ROW_LENGTH-1 APB0F401.1001
D(I)=SUM_S APB0F401.1002
ENDDO APB0F401.1003
*IF DEF,MPP APB0F401.1004
ENDIF APB0F401.1005
*ENDIF APB0F401.1006
*ENDIF DIVDMP1A.236
DIVDMP1A.237
CL DIVDMP1A.238
CL--------------------------------------------------------------------- DIVDMP1A.239
CL SECTION 3. CALCULATE D(D)/D(LONGITUDE) DIVDMP1A.240
CL--------------------------------------------------------------------- DIVDMP1A.241
DIVDMP1A.242
! Loop over field, missing top and bottom rows and halos APB0F401.1007
DO 300 I=START_POINT_NO_HALO,END_P_POINT_INC_HALO-1 GDS1F402.1849
D_BY_DLONG(I) = (D(I+1) - D(I))*LONGITUDE_STEP_INVERSE DIVDMP1A.244
300 CONTINUE DIVDMP1A.245
DIVDMP1A.246
CL DIVDMP1A.247
CL--------------------------------------------------------------------- DIVDMP1A.248
CL SECTION 4. CALCULATE D(D)/D(LATITUDE) DIVDMP1A.249
CL UPDATE V FIELD WITH DIVERGENCE. DIVDMP1A.250
CL UPDATE U FIELD WITH DIVERGENCE DIVDMP1A.251
CL IF GLOBAL CALL POLAR_UV TO UPDATE U AND V AT POLE. DIVDMP1A.252
CL--------------------------------------------------------------------- DIVDMP1A.253
DIVDMP1A.254
C---------------------------------------------------------------------- DIVDMP1A.255
CL SECTION 4.1 CALCULATE D(D)/D(LATITUDE) DIVDMP1A.256
C---------------------------------------------------------------------- DIVDMP1A.257
DIVDMP1A.258
! Loop over field, including Northern row but missing Southern row and APB0F401.1009
! top and bottom halos APB0F401.1010
DO 410 I=START_POINT_NO_HALO-ROW_LENGTH, APB0F401.1011
& END_P_POINT_NO_HALO APB0F401.1012
D_BY_DLAT(I) = (D(I)-D(I+ROW_LENGTH))*LATITUDE_STEP_INVERSE DIVDMP1A.260
410 CONTINUE DIVDMP1A.261
DIVDMP1A.262
C---------------------------------------------------------------------- DIVDMP1A.263
CL SECTION 4.2 UPDATE V FIELD WITH DIVERGENCE DIVDMP1A.264
CL UPDATE U FIELD WITH DIVERGENCE DIVDMP1A.265
C---------------------------------------------------------------------- DIVDMP1A.266
DIVDMP1A.267
*IF DEF,GLOBAL DIVDMP1A.268
C GLOBAL MODEL, CALCULATE SECOND V TERM IN EQUATION. DIVDMP1A.269
! Loop over field, including Northern row, but missing Southern row, and APB0F401.1013
! last point of last row, and top and bottom halos APB0F401.1014
DO 420 I=START_POINT_NO_HALO-ROW_LENGTH, APB0F401.1015
& END_P_POINT_NO_HALO-1 APB0F401.1016
D_BY_DLAT2(I) = KD(K)*.5*(D_BY_DLAT(I)+D_BY_DLAT(I+1)) DIVDMP1A.271
* *ADVECTION_TIMESTEP DIVDMP1A.272
420 CONTINUE DIVDMP1A.273
DIVDMP1A.274
C NOW DO END POINTS. DIVDMP1A.275
*IF -DEF,MPP APB0F305.743
! Loop over last point of each row APB0F401.1017
DO 424 I=START_POINT_NO_HALO+LAST_ROW_PT-1, APB0F401.1018
& END_P_POINT_NO_HALO,ROW_LENGTH APB0F401.1019
D_BY_DLAT2(I)= KD(K)*.5*(D_BY_DLAT(I)+ DIVDMP1A.277
* D_BY_DLAT(I+1-ROW_LENGTH))*ADVECTION_TIMESTEP DIVDMP1A.278
C DO END POINTS FOR SECTION 3.1 DIVDMP1A.279
D_BY_DLONG(I)=(D(I+1-ROW_LENGTH)-D(I))*LONGITUDE_STEP_INVERSE DIVDMP1A.280
424 CONTINUE DIVDMP1A.281
DIVDMP1A.282
C DO FIRST END POINT OF SECTION 4.1. DIVDMP1A.283
D_BY_DLAT2(TOP_ROW_START+LAST_ROW_PT-1)= KD(K)*.5* APB0F401.1020
& (D_BY_DLAT(TOP_ROW_START)+ APB0F401.1021
& D_BY_DLAT(TOP_ROW_START+LAST_ROW_PT-1))*ADVECTION_TIMESTEP APB0F401.1022
*ELSE APB0F305.744
D_BY_DLAT2(END_P_POINT_NO_HALO)= APB0F401.1023
& D_BY_DLAT2(END_P_POINT_NO_HALO-1) APB0F401.1024
! MPP Code : No need to do recalculations of end points because cyclic APB0F305.746
! boundary conditions means that halos do this for us automatically APB0F305.747
APB0F305.748
*ENDIF APB0F305.749
DIVDMP1A.286
C UPDATE U AND V FIELDS WITH DIVERGENCE DIVDMP1A.287
DIVDMP1A.288
C UPDATE ALL POINTS. DIVDMP1A.289
! Loop over U field, missing Northern and Southern rows and top and APB0F401.1025
! bottom halos. APB0F401.1026
DO 426 I=START_POINT_NO_HALO,END_U_POINT_NO_HALO-1 GDS1F402.1850
SCALAR=1./(RS_U_GRID(I)*RS_U_GRID(I)*RS_U_GRID(I) DIVDMP1A.291
* *(DELTA_AK(K)+DELTA_BK(K)*PSTAR_OLD(I))) DIVDMP1A.292
U(I,K) = U(I,K) + KD(K)*.5*(D_BY_DLONG(I)+ DIVDMP1A.293
* D_BY_DLONG(I+ROW_LENGTH)) DIVDMP1A.294
* *SEC_U_LATITUDE(I)*ADVECTION_TIMESTEP*SCALAR DIVDMP1A.295
V(I,K) = V(I,K) + D_BY_DLAT2(I)*SCALAR DIVDMP1A.296
426 CONTINUE DIVDMP1A.297
*ELSE DIVDMP1A.298
CL LIMITED AREA MODEL. FIRST,PENULTIMATE AND LAST V VALUES ON A ROW DIVDMP1A.299
CL NOT UPDATED. DIVDMP1A.300
*IF DEF,MPP APB0F401.1028
! For the MPP code this requires a little more code. Only processors APB0F401.1029
! at the left and right of the LPG need to miss points out. APB0F401.1030
! We can also be sneaky and use the code structure to avoid duplicate APB0F401.1031
! calculations by avoiding the halo areas. APB0F401.1032
IF (at_left_of_LPG) THEN APB0F401.1033
row_start_offset=EW_Halo+1 ! Miss halo and first point APB0F401.1034
ELSE APB0F401.1035
row_start_offset=EW_Halo ! Miss halo only APB0F401.1036
ENDIF APB0F401.1037
APB0F401.1038
IF (at_right_of_LPG) THEN APB0F401.1039
row_end_offset=ROW_LENGTH-EW_Halo-2-1 ! Miss last two APB0F401.1040
! ! points and halo APB0F401.1041
ELSE APB0F401.1042
row_end_offset=ROW_LENGTH-EW_Halo-1 ! Miss out halo only APB0F401.1043
ENDIF APB0F401.1044
*ENDIF APB0F401.1045
DO 420 J=START_POINT_NO_HALO,END_U_POINT_NO_HALO,ROW_LENGTH APB0F401.1046
*IF -DEF,MPP APB0F305.750
DO 422 I=J+1,J+ROW_LENGTH-3 DIVDMP1A.302
*ELSE APB0F305.751
DO 422 I=J+row_start_offset,J+row_end_offset APB0F401.1047
*ENDIF APB0F305.763
SCALAR=1./(RS_U_GRID(I)*RS_U_GRID(I)*RS_U_GRID(I) DIVDMP1A.303
* *(DELTA_AK(K)+DELTA_BK(K)*PSTAR_OLD(I))) DIVDMP1A.304
U(I,K) = U(I,K) + KD(K)*.5*(D_BY_DLONG(I)+ DIVDMP1A.305
* D_BY_DLONG(I+ROW_LENGTH)) DIVDMP1A.306
* *SEC_U_LATITUDE(I)*ADVECTION_TIMESTEP*SCALAR DIVDMP1A.307
V(I,K)=V(I,K)+KD(K)*.5*(D_BY_DLAT(I)+ DIVDMP1A.308
* D_BY_DLAT(I+1))*ADVECTION_TIMESTEP*SCALAR DIVDMP1A.309
422 CONTINUE DIVDMP1A.310
420 CONTINUE DIVDMP1A.311
*ENDIF DIVDMP1A.312
*IF DEF,MPP GDS1F402.1851
call swapbounds(u,row_length,tot_u_rows,1,1,p_levels) GDS1F402.1852
call swapbounds(v,row_length,tot_u_rows,1,1,p_levels) GDS1F402.1853
*ENDIF GDS1F402.1854
DIVDMP1A.313
C---------------------------------------------------------------------- DIVDMP1A.314
CL SECTION 4.3 GLOBAL MODEL POLAR UPDATE OF U AND V. DIVDMP1A.315
C---------------------------------------------------------------------- DIVDMP1A.316
DIVDMP1A.317
*IF DEF,GLOBAL DIVDMP1A.318
DIVDMP1A.319
CL CALL POLAR_UV TO UPDATE U AND V. DIVDMP1A.320
DIVDMP1A.321
CALL POLAR_UV(U(1,K),V(1,K),ROW_LENGTH,U_FIELD,1, APB2F401.201
*CALL ARGFLDPT APB2F401.202
& COS_U_LONGITUDE,SIN_U_LONGITUDE) APB2F401.203
DIVDMP1A.324
*ENDIF DIVDMP1A.325
DIVDMP1A.326
END IF DIVDMP1A.327
CL END LOOP OVER LEVELS DIVDMP1A.328
DIVDMP1A.329
100 CONTINUE DIVDMP1A.330
DIVDMP1A.331
CL END OF ROUTINE DIV_DAMP DIVDMP1A.332
DIVDMP1A.333
RETURN DIVDMP1A.334
END DIVDMP1A.335
*ENDIF DIVDMP1A.336