*IF DEF,A10_1A,OR,DEF,A10_1B,OR,DEF,A10_1C AAD2F404.248
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.14861
C GTS2F400.14862
C Use, duplication or disclosure of this code is subject to the GTS2F400.14863
C restrictions as set forth in the contract. GTS2F400.14864
C GTS2F400.14865
C Meteorological Office GTS2F400.14866
C London Road GTS2F400.14867
C BRACKNELL GTS2F400.14868
C Berkshire UK GTS2F400.14869
C RG12 2SZ GTS2F400.14870
C GTS2F400.14871
C If no contract has been raised with this copy of the code, the use, GTS2F400.14872
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.14873
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.14874
C Modelling at the above address. GTS2F400.14875
C ******************************COPYRIGHT****************************** GTS2F400.14876
C GTS2F400.14877
! Subroutine ATMOS_ANG_MOM---------------------------------------- ANGMOM1A.3
! Description: ANGMOM1A.4
! Routine to calculate the 3 components of atmospheric angular ANGMOM1A.5
! momentum for the wind term and the mass term separately. ANGMOM1A.6
! ANGMOM1A.7
! Method: The 3 components of angular momentum are defined below ANGMOM1A.8
! as integrals over pressure of ANGMOM1A.9
! ANGMOM1A.10
! W1= {u*sin(lat)cos(lon)-v*sin(lon)} r**3 cos(lat) dp/g ANGMOM1A.11
! W2= {u*sin(lat)sin(lon)+v*cos(lon)} r**3 cos(lat) dp/g ANGMOM1A.12
! W3= -u*cos(lat) r**3 cos(lat) dp/g ANGMOM1A.13
! ANGMOM1A.14
! M1= {r*omega*cos(lat)sin(lat)cos(lon)} r**3 cos(lat) dp/g ANGMOM1A.15
! M2= {r*omega*cos(lat)sin(lat)sin(lon)} r**3 cos(lat) dp/g ANGMOM1A.16
! M3= -{r*omega*cos(lat)}cos(lat) r**3 cos(lat) dp/g ANGMOM1A.17
! ANGMOM1A.18
! ANGMOM1A.19
! Current Code Owner: R A Stratton ANGMOM1A.20
! ANGMOM1A.21
! History: ANGMOM1A.22
! Version Date Comment ANGMOM1A.23
! ------- ---- ------- ANGMOM1A.24
! 4.0 11/11/94 Original code. R A Stratton ANGMOM1A.25
! 4.4 02/07/97 Added ARGFLDPT args and MPP code P.Burton GPB1F404.155
! ANGMOM1A.26
! Code Description: ANGMOM1A.27
! Language: FORTRAN 77 + common extensions. ANGMOM1A.28
! This code is written to UMDP3 v6 programming standards. ANGMOM1A.29
! ANGMOM1A.30
! System component covered: ? ANGMOM1A.31
! System Task: ? ANGMOM1A.32
! -------------------------------------------------------------------- ANGMOM1A.33
SUBROUTINE ATMOS_ANG_MOM( 1,2GPB1F404.156
& P_FIELD,U_FIELD,P_ROWS,ROW_LENGTH,P_LEVS, GPB1F404.157
*CALL ARGFLDPT 
GPB1F404.158
& EW_SPACE,NS_SPACE,FIRST_LAT,FIRST_LONG, GPB1F404.159
& PSTAR,U,V,RS,COS_U_LATITUDE,DELTA_AK,DELTA_BK, ANGMOM1A.36
& L_AMM1,L_AMM2,L_AMM3,L_AMW1,L_AMW2,L_AMW3, ANGMOM1A.37
& AMM1,AMM2,AMM3,AMW1,AMW2,AMW3) ANGMOM1A.38
IMPLICIT NONE ANGMOM1A.39
! Declarations: ANGMOM1A.40
! ANGMOM1A.41
! Global variables ANGMOM1A.42
ANGMOM1A.43
*CALL C_A ANGMOM1A.44
*CALL C_G ANGMOM1A.45
*CALL C_OMEGA ANGMOM1A.46
*CALL C_PI ANGMOM1A.47
ANGMOM1A.48
! Subroutine arguments ANGMOM1A.49
INTEGER ANGMOM1A.50
& P_FIELD ! IN : length of p grid ANGMOM1A.51
& ,U_FIELD ! IN : length of u grid ANGMOM1A.52
& ,P_ROWS ! IN : number of rows p grid ANGMOM1A.53
& ,ROW_LENGTH ! IN : length of row ANGMOM1A.54
& ,P_LEVS ! IN : number of model levels ANGMOM1A.55
ANGMOM1A.56
*CALL TYPFLDPT GPB1F404.160
REAL ANGMOM1A.57
& EW_SPACE ! IN : East west grid spacing in degrees ANGMOM1A.58
& ,NS_SPACE ! IN : North South grid spacing in degrees ANGMOM1A.59
& ,FIRST_LAT ! IN : first latitude ANGMOM1A.60
& ,FIRST_LONG ! IN : first longitude ANGMOM1A.61
REAL ANGMOM1A.62
& PSTAR(P_FIELD) ! IN : pstar ANGMOM1A.63
& ,U(U_field,P_LEVS) ! IN : u ANGMOM1A.64
& ,V(U_field,P_LEVS) ! IN : V ANGMOM1A.65
& ,RS(P_field,P_LEVS) ! IN : effect radius of atmosphere ANGMOM1A.66
& ,COS_U_LATITUDE(U_FIELD) ! IN : cos (lat) u-grid ANGMOM1A.67
& ,DELTA_AK(P_LEVS) ! IN : layer akh(k+1)-akh(k) ANGMOM1A.68
& ,DELTA_BK(P_LEVS) ! IN : layer bkh(k+1)-bkh(k) ANGMOM1A.69
ANGMOM1A.70
LOGICAL ANGMOM1A.71
& L_AMM1 ! IN : true if field required ANGMOM1A.72
& ,L_AMM2 ! IN : true if field required ANGMOM1A.73
& ,L_AMM3 ! IN : true if field required ANGMOM1A.74
& ,L_AMW1 ! IN : true if field required ANGMOM1A.75
& ,L_AMW2 ! IN : true if field required ANGMOM1A.76
& ,L_AMW3 ! IN : true if field required ANGMOM1A.77
ANGMOM1A.78
REAL ANGMOM1A.79
& AMM1(U_FIELD) ! OUT: 1st com of angular momemtum mass term ANGMOM1A.80
& ,AMM2(U_FIELD) ! OUT: 2nd com of angular momemtum mass term ANGMOM1A.81
& ,AMM3(U_FIELD) ! OUT: 3rd com of angular momemtum mass term ANGMOM1A.82
& ,AMW1(U_FIELD) ! OUT: 1st com of angular momemtum wind term ANGMOM1A.83
& ,AMW2(U_FIELD) ! OUT: 2nd com of angular momemtum wind term ANGMOM1A.84
& ,AMW3(U_FIELD) ! OUT: 3rd com of angular momemtum wind term ANGMOM1A.85
ANGMOM1A.86
! ------------------------------------------------------------------- ANGMOM1A.87
! Local variables: ANGMOM1A.88
ANGMOM1A.89
REAL ANGMOM1A.90
& R3DP ! r**3 dp/g ANGMOM1A.91
& ,DP ! dp ANGMOM1A.92
& ,ROCOS ! r omega cos(lat) ANGMOM1A.93
& ,FACTOR ! scaling factor /g ANGMOM1A.94
& ,COS_LONG ANGMOM1A.95
& ,SIN_LONG ANGMOM1A.96
& ,SIN_LAT ANGMOM1A.97
REAL ANGMOM1A.98
& RS_U(U_FIELD) ! effective radius on u grid ANGMOM1A.99
& ,PSTAR_U(U_FIELD) ! pstar on u grid ANGMOM1A.100
& ,COSSQ(U_FIELD) ! cos**2 ANGMOM1A.101
& ,LONGITUDE(U_FIELD) ! longitude ANGMOM1A.102
& ,LATITUDE(U_FIELD) ! latitude ANGMOM1A.103
& ,SLCP(U_FIELD) ! sin(lon)cos(lat) ANGMOM1A.104
& ,CLCP(U_FIELD) ! cos(lon)cos(lat) ANGMOM1A.105
& ,SPSLCP(U_FIELD) ! sin(lat)sin(lon)cos(lat) ANGMOM1A.106
& ,SPCLCP(U_FIELD) ! sin(lat)cos(lon)cos(lat) ANGMOM1A.107
ANGMOM1A.108
INTEGER ANGMOM1A.109
& I,J,K,II ! loop counters ANGMOM1A.110
ANGMOM1A.111
! Function & Subroutine calls: ANGMOM1A.112
External p_to_uv ANGMOM1A.113
ANGMOM1A.114
*IF DEF,MPP GPB1F404.161
*CALL PARVARS GPB1F404.162
*ENDIF GPB1F404.163
! ------------------------------------------------------------------ ANGMOM1A.115
! constants ANGMOM1A.116
FACTOR=1.e-24/g ANGMOM1A.117
ANGMOM1A.118
! Calculate longitude & latitude ANGMOM1A.119
DO I=1,P_ROWS-1 ANGMOM1A.120
DO J=1,ROW_LENGTH ANGMOM1A.121
II=J+(I-1)*ROW_LENGTH ANGMOM1A.122
*IF -DEF,MPP GPB1F404.164
LONGITUDE(II)=(FIRST_LONG+EW_SPACE*(J-0.5))*PI_OVER_180 ANGMOM1A.123
LATITUDE(II)=(FIRST_LAT-NS_SPACE*(I-0.5))*PI_OVER_180 ANGMOM1A.124
*ELSE GPB1F404.165
LONGITUDE(II)=(FIRST_LONG+EW_SPACE* GPB1F404.166
& ((J+datastart(1)-Offx-1)-0.5))*PI_OVER_180 GPB1F404.167
LATITUDE(II)=(FIRST_LAT-NS_SPACE* GPB1F404.168
& ((I+datastart(2)-Offy-1)-0.5))*PI_OVER_180 GPB1F404.169
*ENDIF GPB1F404.170
ENDDO ANGMOM1A.125
ENDDO ANGMOM1A.126
ANGMOM1A.127
! calculate pstar on u grid ANGMOM1A.128
ANGMOM1A.129
CALL P_TO_UV(PSTAR,PSTAR_U,P_FIELD,U_FIELD,ROW_LENGTH,P_ROWS) ANGMOM1A.130
ANGMOM1A.131
DO I=1,U_FIELD ANGMOM1A.132
! Intialise output arrays ANGMOM1A.133
IF (L_AMW1) AMW1(I)=0.0 ANGMOM1A.134
IF (L_AMW2) AMW2(I)=0.0 ANGMOM1A.135
IF (L_AMW3) AMW3(I)=0.0 ANGMOM1A.136
IF (L_AMM1) AMM1(I)=0.0 ANGMOM1A.137
IF (L_AMM2) AMM2(I)=0.0 ANGMOM1A.138
IF (L_AMM3) AMM3(I)=0.0 ANGMOM1A.139
ENDDO ANGMOM1A.140
DO I=FIRST_FLD_PT,LAST_U_FLD_PT GPB1F404.171
COSSQ(I)=COS_U_LATITUDE(I)*COS_U_LATITUDE(I) ANGMOM1A.142
ENDDO ANGMOM1A.143
! calculate cos , sin etc ANGMOM1A.144
IF (L_AMM1.OR.L_AMM2.OR.L_AMW1.OR.L_AMW2) THEN ANGMOM1A.145
DO I=FIRST_FLD_PT,LAST_U_FLD_PT GPB1F404.172
COS_LONG=COS(LONGITUDE(I)) ANGMOM1A.147
SIN_LONG=SIN(LONGITUDE(I)) ANGMOM1A.148
SIN_LAT=SIN(LATITUDE(I)) ANGMOM1A.149
spclcp(i)=SIN_LAT*COS_LONG*COS_U_LATITUDE(I) ANGMOM1A.150
spslcp(i)=SIN_LAT*SIN_LONG*COS_U_LATITUDE(I) ANGMOM1A.151
clcp(i)=COS_LONG*COS_U_LATITUDE(I) ANGMOM1A.152
slcp(i)=SIN_LONG*COS_U_LATITUDE(I) ANGMOM1A.153
ENDDO ANGMOM1A.154
ENDIF ANGMOM1A.155
ANGMOM1A.156
! integrate momemtum over p ANGMOM1A.157
ANGMOM1A.158
DO K=1,P_LEVS ! loop over model levels ANGMOM1A.159
CALL P_TO_UV(RS(1,K),RS_U,P_FIELD,U_FIELD,ROW_LENGTH,P_ROWS) ANGMOM1A.160
ANGMOM1A.161
DO I=FIRST_FLD_PT,LAST_U_FLD_PT GPB1F404.173
ANGMOM1A.163
DP=DELTA_AK(K) + DELTA_BK(K)*PSTAR_U(I) ANGMOM1A.164
R3DP=(RS_U(I)**3)*DP*FACTOR ANGMOM1A.165
ROCOS=OMEGA*RS_U(I)*COS_U_LATITUDE(I) ANGMOM1A.166
ANGMOM1A.167
IF (L_AMW1) AMW1(I)=AMW1(I) ANGMOM1A.168
& +(U(I,K)*SPCLCP(I)-V(I,K)*SLCP(I))*R3DP ANGMOM1A.169
ANGMOM1A.170
IF (L_AMW2) AMW2(I)=AMW2(I) ANGMOM1A.171
& +(U(I,K)*SPSLCP(I)+V(I,K)*CLCP(I))*R3DP ANGMOM1A.172
ANGMOM1A.173
IF (L_AMW3) AMW3(I)=AMW3(I) - U(I,K)*COSSQ(I)*R3DP ANGMOM1A.174
ANGMOM1A.175
IF (L_AMM1) AMM1(I)=AMM1(I) + ROCOS*SPCLCP(I)*R3DP ANGMOM1A.176
IF (L_AMM2) AMM2(I)=AMM2(I) + ROCOS*SPSLCP(I)*R3DP ANGMOM1A.177
IF (L_AMM3) AMM3(I)=AMM3(I) - ROCOS*COSSQ(I)*R3DP ANGMOM1A.178
ENDDO ! end loop over gridpoints ANGMOM1A.179
ENDDO ! end loop over model levels ANGMOM1A.180
ANGMOM1A.181
RETURN ANGMOM1A.182
END ANGMOM1A.183
*ENDIF ANGMOM1A.184