*IF DEF,A13_1A THQDIF1A.2
C ******************************COPYRIGHT****************************** GTS2F400.10297
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.10298
C GTS2F400.10299
C Use, duplication or disclosure of this code is subject to the GTS2F400.10300
C restrictions as set forth in the contract. GTS2F400.10301
C GTS2F400.10302
C Meteorological Office GTS2F400.10303
C London Road GTS2F400.10304
C BRACKNELL GTS2F400.10305
C Berkshire UK GTS2F400.10306
C RG12 2SZ GTS2F400.10307
C GTS2F400.10308
C If no contract has been raised with this copy of the code, the use, GTS2F400.10309
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.10310
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.10311
C Modelling at the above address. GTS2F400.10312
C ******************************COPYRIGHT****************************** GTS2F400.10313
C GTS2F400.10314
CLL SUBROUTINE TH_Q_DIF ----------------------------------------- THQDIF1A.3
CLL THQDIF1A.4
CLL PURPOSE: CALCULATES DIFFUSION INCREMENTS FOR THETAL OR QT ATD1F400.649
CLL IF STEEP SLOPE THEN EFFECTIVE DIFFUSION IS ZERO. ATD1F400.650
CLL ATD1F400.651
CLL NOT SUITABLE FOR SINGLE COLUMN USE. THQDIF1A.9
CLL THQDIF1A.10
CLL VERSION FOR CRAY Y-MP THQDIF1A.11
CLL THQDIF1A.12
CLL MM, TJ <- PROGRAMMER OF SOME OR ALL OF PREVIOUS CODE OR CHANGES THQDIF1A.13
CLL THQDIF1A.14
CLL MODEL MODIFICATION HISTORY FROM MODEL VERSION 3.0: THQDIF1A.15
CLL VERSION DATE THQDIF1A.16
CLL 4.0 03/02/95 RE-WRITTEN TO MAKE MORE EFFICIENT WITH TESTING FOR ATD1F400.652
CLL STEEP SLOPES. AUTHOR: T.DAVIES. REVIEWER: M.MAWSON ATD1F400.653
CLL ATD1F400.654
! 3.5 28/03/95 MPP code additions P.Burton APB0F305.1296
! 4.1 07/05/96 Added MPP code and TYPFLDPT arguments P.Burton APB0F401.1593
! 4.4 17/07/97 SCALAR calculated using SEC_P_LATITUDE at both AIE0F404.17
! poles for non MPP code to enable bit comparison AIE0F404.18
! with MPP code. I Edmond AIE0F404.19
CLL THQDIF1A.17
CLL PROGRAMMING STANDARD: UNIFIED MODEL DOCUMENTATION PAPER NO. 4, THQDIF1A.18
CLL STANDARD B. VERSION 2, DATED 18/01/90 THQDIF1A.19
CLL THQDIF1A.20
CLL SYSTEM COMPONENTS COVERED: P131 THQDIF1A.21
CLL THQDIF1A.22
CLL SYSTEM TASK: P1 THQDIF1A.23
CLL THQDIF1A.24
CLL DOCUMENTATION: THE EQUATION USED IS (47) THQDIF1A.25
CLL IN UNIFIED MODEL DOCUMENTATION PAPER THQDIF1A.26
CLL NO. 10 M.J.P. CULLEN,T.DAVIES AND M.H.MAWSON THQDIF1A.27
CLL VERSION 16, DATED 09/01/91. THQDIF1A.28
CLLEND------------------------------------------------------------- THQDIF1A.29
THQDIF1A.30
C*L ARGUMENTS:--------------------------------------------------- THQDIF1A.31
SUBROUTINE TH_Q_DIF 4,5THQDIF1A.32
1 (FIELD,FIELD_INC, ATD1F400.655
2 SEC_P_LATITUDE,ROW_LENGTH, APB0F401.1594
*CALL ARGFLDPT 
APB0F401.1595
4 P_FIELD,U_FIELD, ATD1F400.658
5 DIFFUSION_EW,DIFFUSION_NS) ATD1F400.659
ATD1F400.660
THQDIF1A.39
IMPLICIT NONE THQDIF1A.40
THQDIF1A.41
INTEGER THQDIF1A.42
* U_FIELD !IN DIMENSION OF FIELDS ON VELOCITY GRID THQDIF1A.43
*, P_FIELD !IN DIMENSION OF FIELDS ON PRESSURE GRID THQDIF1A.44
*, ROW_LENGTH !IN NUMBER OF POINTS PER ROW THQDIF1A.45
APB0F401.1596
! All TYPFLDPT arguments are intent IN APB0F401.1597
*CALL TYPFLDPT APB0F401.1598
THQDIF1A.48
REAL THQDIF1A.49
* FIELD(P_FIELD) !IN. THETAL OR QT FIELD. ATD1F400.661
*, FIELD_INC(P_FIELD) !OUT DIFFUSION INCREMENT ATD1F400.662
THQDIF1A.54
REAL THQDIF1A.55
* DIFFUSION_EW(P_FIELD) !IN HOLDS EAST-WEST EFFECTIVE DIFFUSION ATD1F400.663
*,DIFFUSION_NS(P_FIELD) !IN HOLDS NORTH-SOUTH EFFECTIVE DIFFUSION ATD1F400.664
*,SEC_P_LATITUDE(P_FIELD) !IN 1/COS(LAT) AT P POINTS THQDIF1A.62
THQDIF1A.65
C*--------------------------------------------------------------------- THQDIF1A.66
THQDIF1A.67
C*L DEFINE ARRAYS AND VARIABLES USED IN THIS ROUTINE----------------- THQDIF1A.68
C DEFINE LOCAL ARRAYS: 5 ARE REQUIRED ATD1F400.665
THQDIF1A.70
REAL THQDIF1A.71
* FIELD1(P_FIELD) ! GENERAL WORKSPACE ATD1F400.666
*,FIELD2(P_FIELD) ! GENERAL WORKSPACE ATD1F400.667
*,FIELD3(P_FIELD) ! GENERAL WORKSPACE ATD1F400.668
*,NP_FLUX(ROW_LENGTH) ! HOLDS NORTH POLAR FLUX THQDIF1A.74
*,SP_FLUX(ROW_LENGTH) ! HOLDS SOUTH POLAR FLUX THQDIF1A.75
C*--------------------------------------------------------------------- THQDIF1A.76
C DEFINE LOCAL VARIABLES THQDIF1A.77
THQDIF1A.78
C LOCAL REALS. THQDIF1A.79
REAL THQDIF1A.80
* SCALAR THQDIF1A.81
C COUNT VARIABLES FOR DO LOOPS ETC. THQDIF1A.82
INTEGER THQDIF1A.83
* I,J,IJ APB0F401.1599
THQDIF1A.85
C*L EXTERNAL SUBROUTINE CALLS:--------------------------------------- THQDIF1A.86
EXTERNAL THQDIF1A.87
* POLAR THQDIF1A.88
C*--------------------------------------------------------------------- THQDIF1A.89
CL MAXIMUM VECTOR LENGTH ASSUMED IS END_P_UPDATE-START_P_UPDATE+1 THQDIF1A.90
CL--------------------------------------------------------------------- THQDIF1A.91
CL INTERNAL STRUCTURE. THQDIF1A.92
CL--------------------------------------------------------------------- THQDIF1A.93
CL THQDIF1A.94
CL--------------------------------------------------------------------- THQDIF1A.95
CL SECTION 1. DELTA LAMBDA TERMS ATD1F400.670
CL--------------------------------------------------------------------- ATD1F400.671
C---------------------------------------------------------------------- ATD1F400.672
CL SECTION 1.1 CALCULATE DELTAPHILAMBDA*1/(DELTALAMBDA)SQUARED ATD1F400.673
C---------------------------------------------------------------------- ATD1F400.674
ATD1F400.675
ATD1F400.676
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO-1 APB0F401.1600
FIELD1(I)=FIELD(I+1)-FIELD(I) ATD1F400.678
END DO ATD1F400.679
ATD1F400.680
APB0F401.1601
*IF -DEF,MPP APB0F401.1602
C RECALCULATE END-POINTS ATD1F400.681
ATD1F400.682
DO I=START_POINT_NO_HALO-1,END_P_POINT_NO_HALO,ROW_LENGTH APB0F401.1603
IJ=I-ROW_LENGTH+1 ATD1F400.684
FIELD1(I)=FIELD(IJ)-FIELD(I) ATD1F400.685
END DO ATD1F400.686
*ELSE APB0F401.1604
! Set last point of field APB0F401.1605
FIELD1(END_P_POINT_NO_HALO)=FIELD1(END_P_POINT_NO_HALO-1) APB0F401.1606
*ENDIF APB0F401.1607
ATD1F400.687
C---------------------------------------------------------------------- ATD1F400.688
CL SECTION 1.2 CALCULATE DELTA LAMBDA TERM ATD1F400.689
C---------------------------------------------------------------------- ATD1F400.690
ATD1F400.691
DO I= START_POINT_NO_HALO+1,END_P_POINT_NO_HALO APB0F401.1608
FIELD2(I)=(DIFFUSION_EW(I)*FIELD1(I)- ATD1F400.698
& DIFFUSION_EW(I-1)*FIELD1(I-1))* ATD1F400.699
& SEC_P_LATITUDE(I) ATD1F400.700
END DO ATD1F400.701
ATD1F400.702
APB0F401.1609
*IF -DEF,MPP APB0F401.1610
C RECALCULATE END-POINTS ATD1F400.703
DO I= START_POINT_NO_HALO,END_P_POINT_NO_HALO,ROW_LENGTH APB0F401.1611
IJ=I+ROW_LENGTH-1 ATD1F400.705
FIELD2(I)=(DIFFUSION_EW(I)*FIELD1(I)- ATD1F400.706
& DIFFUSION_EW(IJ)*FIELD1(IJ))* ATD1F400.707
& SEC_P_LATITUDE(I) ATD1F400.708
END DO ATD1F400.709
*ELSE APB0F401.1612
FIELD2(START_POINT_NO_HALO)=FIELD2(START_POINT_NO_HALO+1) APB0F401.1613
*ENDIF APB0F401.1614
ATD1F400.710
C---------------------------------------------------------------------- ATD1F400.711
CL SECTION 2 CALCULATE PHI DIRECTION TERM AND ADD ATD1F400.712
CL ONTO FIRST TERM TO GET TOTAL CORRECTION. ATD1F400.713
C---------------------------------------------------------------------- ATD1F400.714
ATD1F400.715
C CALCULATE DELTA PHI TERMS ATD1F400.716
ATD1F400.717
DO I=START_POINT_NO_HALO-ROW_LENGTH,END_P_POINT_NO_HALO APB0F401.1615
FIELD1(I)=FIELD(I)-FIELD(I+ROW_LENGTH) ATD1F400.719
END DO ATD1F400.720
ATD1F400.721
C---------------------------------------------------------------------- ATD1F400.722
CL SECTION 2.3 CALCULATE DELTAPHI TERM AND ADD ONTO DELTALAMBDA TERM ATD1F400.723
C---------------------------------------------------------------------- ATD1F400.724
ATD1F400.725
DO I=START_POINT_NO_HALO,END_P_POINT_NO_HALO APB0F401.1616
FIELD_INC(I)= (FIELD2(I)+ ATD1F400.731
& DIFFUSION_NS(I-ROW_LENGTH)*FIELD1(I-ROW_LENGTH)- ATD1F400.732
& DIFFUSION_NS(I)*FIELD1(I))*SEC_P_LATITUDE(I) ATD1F400.733
END DO ATD1F400.734
ATD1F400.735
C---------------------------------------------------------------------- ATD1F400.736
CL SECTION 3 CALCULATE DIFFUSION AT POLES ATD1F400.737
C---------------------------------------------------------------------- ATD1F400.738
ATD1F400.739
*IF DEF,GLOBAL ATD1F400.740
ATD1F400.741
C GLOBAL MODEL CALCULATES POLAR DEL-SQUARED USING ACROSS-POLE DIFFERENCE ATD1F400.742
C ASSUMING FLUX=0 AT HALF-GRID-LENGTH ON OTHER SIDE OF POLE ATD1F400.743
ATD1F400.744
APB0F401.1617
SCALAR=SEC_P_LATITUDE(TOP_ROW_START) APB0F401.1618
APB0F401.1619
! Do North Pole APB0F401.1620
*IF DEF,MPP APB0F401.1621
IF (at_top_of_LPG) THEN APB0F401.1622
*ENDIF APB0F401.1623
DO I=1,ROW_LENGTH APB0F401.1624
J=TOP_ROW_START+I-1 APB0F401.1625
FIELD3(J)=-DIFFUSION_NS(J)*FIELD1(J)*SCALAR APB0F401.1626
NP_FLUX(I)=FIELD3(J) APB0F401.1627
FIELD_INC(J)=0.0 APB0F401.1628
ENDDO APB0F401.1629
*IF DEF,MPP APB0F401.1630
ENDIF APB0F401.1631
*ENDIF APB0F401.1632
APB0F401.1633
! And South Pole APB0F401.1634
SCALAR=SEC_P_LATITUDE(P_BOT_ROW_START) AIE0F404.20
*IF DEF,MPP APB0F401.1635
APB0F401.1637
IF (at_base_of_LPG) THEN APB0F401.1638
*ENDIF APB0F401.1639
DO I=1,ROW_LENGTH APB0F401.1640
J=I+P_BOT_ROW_START-1 APB0F401.1641
FIELD3(J)=DIFFUSION_NS(J-ROW_LENGTH)*FIELD1(J-ROW_LENGTH)* APB0F401.1642
& SCALAR APB0F401.1643
SP_FLUX(I)=FIELD3(J) APB0F401.1644
FIELD_INC(J)=0.0 APB0F401.1645
ENDDO APB0F401.1646
*IF DEF,MPP APB0F401.1647
ENDIF APB0F401.1648
*ENDIF APB0F401.1649
ATD1F400.762
CL CALL POLAR TO UPDATE POLAR VALUES ATD1F400.763
ATD1F400.764
CALL POLAR(FIELD_INC,NP_FLUX,SP_FLUX, APB2F401.58
*CALL ARGFLDPT APB2F401.59
& P_FIELD,ROW_LENGTH,ROW_LENGTH, APB2F401.60
& 1,1,ROW_LENGTH,1) APB2F401.61
ATD1F400.766
*ELSE ATD1F400.767
CL LIMITED AREA MODEL ZEROES DEL-SQUARED ON BOUNDARIES. ATD1F400.768
*IF DEF,MPP APB0F401.1650
IF (at_left_of_LPG) THEN APB0F401.1651
*ENDIF APB0F401.1652
DO I=START_POINT_NO_HALO+FIRST_ROW_PT-1, APB0F401.1653
& END_P_POINT_NO_HALO,ROW_LENGTH APB0F401.1654
FIELD_INC(I)=0.0 APB0F401.1655
ENDDO APB0F401.1656
*IF DEF,MPP APB0F401.1657
ENDIF APB0F401.1658
APB0F401.1659
IF (at_right_of_LPG) THEN APB0F401.1660
*ENDIF APB0F401.1661
DO I=START_POINT_NO_HALO+LAST_ROW_PT-1, APB0F401.1662
& END_P_POINT_NO_HALO,ROW_LENGTH APB0F401.1663
FIELD_INC(I)=0.0 APB0F401.1664
ENDDO APB0F401.1665
*IF DEF,MPP APB0F401.1666
ENDIF APB0F401.1667
*ENDIF APB0F401.1668
*ENDIF ATD1F400.773
CL END OF ROUTINE TH_Q_DIF THQDIF1A.227
THQDIF1A.228
RETURN THQDIF1A.229
END THQDIF1A.230
*ENDIF THQDIF1A.231