*IF DEF,CONTROL AND DEF,ATMOS DIVCAL1A.2
C ******************************COPYRIGHT****************************** GTS2F400.2197
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.2198
C GTS2F400.2199
C Use, duplication or disclosure of this code is subject to the GTS2F400.2200
C restrictions as set forth in the contract. GTS2F400.2201
C GTS2F400.2202
C Meteorological Office GTS2F400.2203
C London Road GTS2F400.2204
C BRACKNELL GTS2F400.2205
C Berkshire UK GTS2F400.2206
C RG12 2SZ GTS2F400.2207
C GTS2F400.2208
C If no contract has been raised with this copy of the code, the use, GTS2F400.2209
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.2210
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.2211
C Modelling at the above address. GTS2F400.2212
C ******************************COPYRIGHT****************************** GTS2F400.2213
C GTS2F400.2214
CLL Subroutine DIV_CALC------------------------------------------ DIVCAL1A.3
CLL DIVCAL1A.4
CLL Purpose: Calculates the horizontal divergence of the DIVCAL1A.5
CLL input wind field on a given level, assuming a DIVCAL1A.6
CLL radius of constant value A, the radius of the DIVCAL1A.7
CLL earth. The input fields are assumed not to be DIVCAL1A.8
CLL mass weighted. No value of divergence is DIVCAL1A.9
CLL calculated at the boundaries. DIVCAL1A.10
CLL DIVCAL1A.11
CLL DIVCAL1A.12
CLL Model Modification history: DIVCAL1A.13
CLL version Date DIVCAL1A.14
CLL 3.3 9/12/93 Original code written by Amos S. Lawless DIVCAL1A.15
!LL 4.3 28/01/97 Add code for MPP version. RTHBarnes. ARB2F403.6
CLL DIVCAL1A.16
CLL Programming standard: UMDP No.3 DIVCAL1A.17
CLL DIVCAL1A.18
CLL System components covered: P1 DIVCAL1A.19
CLL DIVCAL1A.20
CLL System task: P0 DIVCAL1A.21
CLL DIVCAL1A.22
CLLEND----------------------------------------------------------- DIVCAL1A.23
C*L Arguments:-------------------------------------------------- DIVCAL1A.24
SUBROUTINE DIV_CALC(U,V,U_FIELD,P_FIELD,ROW_LENGTH, 2ARB2F403.7
*CALL ARGFLDPT 
ARB2F403.8
& SEC_P_LATITUDE,COS_U_LATITUDE, ARB2F403.9
& LATITUDE_STEP_INVERSE,LONGITUDE_STEP_INVERSE,DIVERG) ARB2F403.10
C*--------------------------------------------------------------- DIVCAL1A.28
IMPLICIT NONE ARB2F403.11
*CALL TYPFLDPT ARB2F403.12
C*L ARB2F403.13
INTEGER DIVCAL1A.30
& U_FIELD !IN SIZE OF FIELD ON U GRID DIVCAL1A.31
& ,P_FIELD !IN SIZE OF FIELD ON P GRID DIVCAL1A.32
& ,ROW_LENGTH !IN NUMBER OF POINTS PER ROW DIVCAL1A.34
REAL DIVCAL1A.36
& U(U_FIELD) !IN U COMPONENT OF VELOCITY ARB2F403.14
& ,V(U_FIELD) !IN V COMPONENT OF VELOCITY ARB2F403.15
& ,SEC_P_LATITUDE(P_FIELD) !IN 1/COS(LAT) AT P POINTS DIVCAL1A.39
& ,COS_U_LATITUDE(U_FIELD) !IN COS(LAT) AT U POINTS DIVCAL1A.40
& ,LATITUDE_STEP_INVERSE !IN 1/LATITUDE INCREMENT DIVCAL1A.41
& ,LONGITUDE_STEP_INVERSE !IN 1/LONGITUDE INCREMENT DIVCAL1A.42
& ,DIVERG(P_FIELD) !OUT DIVERGENCE DIVCAL1A.43
C*--------------------------------------------------------------- DIVCAL1A.44
C*L LOCAL VARIABLES DIVCAL1A.45
INTEGER DIVCAL1A.46
& I ! LOOP VARIABLE DIVCAL1A.47
*IF DEF,MPP ARB2F403.16
& ,J ! loop variable ARB2F403.17
*ENDIF ARB2F403.18
REAL DIVCAL1A.48
& VCOS(U_FIELD) ! HOLDS V*COS(PHI) DIVCAL1A.49
& ,DU_DLONGITUDE(P_FIELD) ! WORK ARRAY DIVCAL1A.50
& ,DV_DLATITUDE(P_FIELD) ! " " DIVCAL1A.51
& ,DV_DLATITUDE2(U_FIELD) ! " " DIVCAL1A.52
*IF DEF,MPP ARB2F403.19
& ,RECIP_A ! 1/A ARB2F403.20
*ENDIF ARB2F403.21
*CALL C_A DIVCAL1A.53
C---------------------------------------------------------------- DIVCAL1A.54
C DIVCAL1A.55
C FIRST MULTIPLY V BY COS(PHI) DIVCAL1A.56
DO I = FIRST_VALID_PT,LAST_U_VALID_PT ARB2F403.22
! DO I=1,U_FIELD ARB2F403.23
VCOS(I)=V(I)*COS_U_LATITUDE(I) ARB2F403.24
END DO DIVCAL1A.59
C NOW CALCULATE DERIVATIVES DIVCAL1A.60
DO I = FIRST_VALID_PT+1,LAST_U_VALID_PT ARB2F403.25
! DO I=2,U_FIELD ARB2F403.26
DU_DLONGITUDE(I)=LONGITUDE_STEP_INVERSE*(U(I)-U(I-1)) ARB2F403.27
END DO DIVCAL1A.63
DO I = START_POINT_NO_HALO,LAST_U_VALID_PT ARB2F403.28
! DO I=ROW_LENGTH+1,U_FIELD ARB2F403.29
DV_DLATITUDE(I)=LATITUDE_STEP_INVERSE* DIVCAL1A.65
* (VCOS(I-ROW_LENGTH)-VCOS(I)) DIVCAL1A.66
END DO DIVCAL1A.67
C DIVCAL1A.68
*IF DEF,MPP ARB2F403.30
RECIP_A = 1.0/A ARB2F403.31
! Compute divergence for all available points ARB2F403.32
DO I = FIRST_VALID_PT+ROW_LENGTH+1,LAST_U_VALID_PT ARB2F403.33
DIVERG(I) = 0.5*RECIP_A*SEC_P_LATITUDE(I)* ARB2F403.34
& (DU_DLONGITUDE(I)+DU_DLONGITUDE(I-ROW_LENGTH) ARB2F403.35
& + DV_DLATITUDE(I)+DV_DLATITUDE(I-1)) ARB2F403.36
END DO ARB2F403.37
! Zero W & E haloes ARB2F403.38
DO I = FIRST_VALID_PT+ROW_LENGTH,LAST_U_VALID_PT,ROW_LENGTH ARB2F403.39
DO J = 0,EW_Halo-1 ARB2F403.40
DIVERG(I+J) = 0.0 ARB2F403.41
DIVERG(I+ROW_LENGTH-1-J) = 0.0 ARB2F403.42
END DO ARB2F403.43
END DO ARB2F403.44
*IF -DEF,GLOBAL ARB2F403.45
! Zero W boundary points of Westmost processors, ARB2F403.46
! as these are incorrect for Limited Area Models. ARB2F403.47
IF (at_left_of_LPG) THEN ARB2F403.48
DO I=FIRST_VALID_PT+ROW_LENGTH+EW_Halo,LAST_U_VALID_PT,ROW_LENGTH ARB2F403.49
DIVERG(I) = 0.0 ARB2F403.50
END DO ARB2F403.51
END IF ARB2F403.52
*ENDIF ARB2F403.53
*ELSE ARB2F403.54
*IF DEF,GLOBAL DIVCAL1A.69
C CALCULATE AVERAGE OF DV_DLATITUDE DIVCAL1A.70
DO I=ROW_LENGTH+2,U_FIELD DIVCAL1A.71
DV_DLATITUDE2(I)=DV_DLATITUDE(I)+DV_DLATITUDE(I-1) DIVCAL1A.72
END DO DIVCAL1A.73
C DIVCAL1A.74
C NOW DO FIRST POINT ON EACH SLICE DIVCAL1A.75
DU_DLONGITUDE(1)=LONGITUDE_STEP_INVERSE*(U(1) ARB2F403.55
* -U(ROW_LENGTH)) ARB2F403.56
DO I=ROW_LENGTH+1,P_FIELD-ROW_LENGTH,ROW_LENGTH DIVCAL1A.78
DU_DLONGITUDE(I)= LONGITUDE_STEP_INVERSE*(U(I) ARB2F403.57
* -U(I+ROW_LENGTH-1)) ARB2F403.58
DV_DLATITUDE2(I)=DV_DLATITUDE(I)+DV_DLATITUDE(I-1+ROW_LENGTH) DIVCAL1A.81
END DO DIVCAL1A.82
C DIVCAL1A.83
C CALCULATE DIVERGENCES DIVCAL1A.84
DO I=ROW_LENGTH+1,U_FIELD DIVCAL1A.85
DIVERG(I) = (1/A)*SEC_P_LATITUDE(I)*.5*(DU_DLONGITUDE(I) DIVCAL1A.86
* + DU_DLONGITUDE(I-ROW_LENGTH) DIVCAL1A.87
* + DV_DLATITUDE2(I)) DIVCAL1A.88
END DO DIVCAL1A.89
*ELSE DIVCAL1A.90
DU_DLONGITUDE(1)=0 DIVCAL1A.91
DO I=ROW_LENGTH+2,U_FIELD-1 DIVCAL1A.92
DIVERG(I) = (1/A)*SEC_P_LATITUDE(I)*.5*(DU_DLONGITUDE(I) DIVCAL1A.93
* + DU_DLONGITUDE(I-ROW_LENGTH) DIVCAL1A.94
* + DV_DLATITUDE(I) + DV_DLATITUDE(I-1)) DIVCAL1A.95
DIVERG(ROW_LENGTH+1)=0 DIVCAL1A.96
DIVERG(U_FIELD)=0 DIVCAL1A.97
END DO DIVCAL1A.98
!!! This looks wrong to me - surely the 2 lines without the loop index I ARB2F403.59
!!! should be outside the loop over I, and the whole of the W boundary ARB2F403.60
!!! then reset to zero as these are wrap-around calculations. ARB2F403.61
C DIVCAL1A.99
*ENDIF DIVCAL1A.100
*ENDIF ARB2F403.62
C DIVCAL1A.101
RETURN DIVCAL1A.102
END DIVCAL1A.103
*ENDIF DIVCAL1A.104