*IF DEF,C90_1A,OR,DEF,C90_2A,OR,DEF,C90_2B AAD2F404.288
C ******************************COPYRIGHT****************************** GTS2F400.7813
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.7814
C GTS2F400.7815
C Use, duplication or disclosure of this code is subject to the GTS2F400.7816
C restrictions as set forth in the contract. GTS2F400.7817
C GTS2F400.7818
C Meteorological Office GTS2F400.7819
C London Road GTS2F400.7820
C BRACKNELL GTS2F400.7821
C Berkshire UK GTS2F400.7822
C RG12 2SZ GTS2F400.7823
C GTS2F400.7824
C If no contract has been raised with this copy of the code, the use, GTS2F400.7825
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.7826
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.7827
C Modelling at the above address. GTS2F400.7828
C ******************************COPYRIGHT****************************** GTS2F400.7829
C GTS2F400.7830
CLL SUBROUTINE P_TO_UV--------------------------------------------- PTOUV1A.3
CLL PTOUV1A.4
CLL Purpose: Interpolates a horizontal field from pressure to wind PTOUV1A.5
CLL points on an Arakawa B grid. Under UPDATE PTOUV1A.6
CLL identifier GLOBAL the data is assumed periodic along PTOUV1A.7
CLL rows. Otherwise, the last value on each row is set equal CW250393.1
CLL to the penultimate value on each row. The output arra CW250393.2
CLL contains one less row than the input array. PTOUV1A.10
CLL PTOUV1A.11
CLL Not suitable for single column use. PTOUV1A.12
CLL PTOUV1A.13
CLL Written 22/8/89 by A. Dickinson PTOUV1A.14
CLL PTOUV1A.15
CLL Model Modification history from model version 3.0: PTOUV1A.16
CLL version date PTOUV1A.17
CLL 3.2 25/03/93 Removed one-sided differencing for first and CW250393.3
CLL last points on row if not global. CW250393.4
CLL Author: C.A.Wilson Reviewer: A.Dickinson CW250393.5
! 3.5 28/03/95 MPP code: Take account of halos P.Burton APB0F305.73
! 4.1 02/04/96 Addition to MPP code P.Burton APB0F401.126
! 4.2 10/10/96 Extra brackets to ensure bit-reproducability APB1F402.29
! between single/multi-processor runs. D. Robinson APB1F402.30
CLL PTOUV1A.18
CLL Programming standard: Unified Model Documentation Paper No 3 PTOUV1A.19
CLL Version No 1 15/1/90 PTOUV1A.20
CLL PTOUV1A.21
CLL System component: S101 PTOUV1A.22
CLL PTOUV1A.23
CLL System task: S1 PTOUV1A.24
CLL PTOUV1A.25
CLL Documentation: The equation used is (2.1) PTOUV1A.26
CLL in unified model documentation paper No. S1 PTOUV1A.27
CLL PTOUV1A.28
CLLEND------------------------------------------------------------- PTOUV1A.29
PTOUV1A.30
C PTOUV1A.31
C*L Arguments:--------------------------------------------------- PTOUV1A.32
SUBROUTINE P_TO_UV 92PTOUV1A.33
1 (P_DATA,U_DATA,P_FIELD,U_FIELD,ROW_LENGTH,ROWS) PTOUV1A.34
PTOUV1A.35
IMPLICIT NONE PTOUV1A.36
PTOUV1A.37
INTEGER PTOUV1A.38
* ROWS !IN Number of rows to be updated. PTOUV1A.39
*, ROW_LENGTH !IN Number of points per row PTOUV1A.40
*, P_FIELD !IN Number of points in input field PTOUV1A.41
*, U_FIELD !IN Number of points in output field PTOUV1A.42
PTOUV1A.43
REAL PTOUV1A.44
* P_DATA(P_FIELD) !INOUT Data on p points PTOUV1A.45
*,U_DATA(U_FIELD) ! OUT Data on uv points PTOUV1A.46
C*--------------------------------------------------------------------- PTOUV1A.47
PTOUV1A.48
C*L Local arrays:----------------------------------------------------- PTOUV1A.49
C None PTOUV1A.50
C*--------------------------------------------------------------------- PTOUV1A.51
*IF DEF,MPP APB0F305.74
! Parameters and Common blocks APB0F305.75
*CALL PARVARS 
APB0F305.76
*ENDIF APB0F305.77
PTOUV1A.52
C*L External subroutine calls:--------------------------------------- PTOUV1A.53
C None PTOUV1A.54
C*--------------------------------------------------------------------- PTOUV1A.55
PTOUV1A.56
C---------------------------------------------------------------------- PTOUV1A.57
C Define local variables PTOUV1A.58
C---------------------------------------------------------------------- PTOUV1A.59
INTEGER PTOUV1A.60
* U_POINTS ! Number of values at u points PTOUV1A.61
*,I ! Horizontal loop indices CW250393.6
PTOUV1A.63
C--------------------------------------------------------------------- PTOUV1A.64
CL 1. Initialise local constants PTOUV1A.65
C--------------------------------------------------------------------- PTOUV1A.66
PTOUV1A.67
U_POINTS = ROW_LENGTH * (ROWS-1) PTOUV1A.68
PTOUV1A.69
C--------------------------------------------------------------------- PTOUV1A.70
CL 2. Calculate horizontal average at u points PTOUV1A.71
C--------------------------------------------------------------------- PTOUV1A.72
PTOUV1A.73
DO 200 I=1,U_POINTS-1 PTOUV1A.74
U_DATA(I)=0.25*( ( P_DATA(I)+P_DATA(I+1) ) + APB1F402.31
& ( P_DATA(I+ROW_LENGTH)+P_DATA(I+1+ROW_LENGTH) ) ) APB1F402.32
200 CONTINUE PTOUV1A.77
PTOUV1A.78
C End points PTOUV1A.79
PTOUV1A.80
*IF DEF,GLOBAL PTOUV1A.81
*IF -DEF,MPP APB0F305.78
C Cyclic wrap around PTOUV1A.82
DO 201 I=ROW_LENGTH,U_POINTS,ROW_LENGTH PTOUV1A.83
U_DATA(I)=0.25*( ( P_DATA(I)+P_DATA(I+1-ROW_LENGTH) ) + APB1F402.33
& ( P_DATA(I+ROW_LENGTH)+P_DATA(I+1) ) ) APB1F402.34
201 CONTINUE PTOUV1A.86
*ELSE APB0F305.79
! Cyclic wrap around already taken account of via halo APB0F305.80
*ENDIF APB0F305.81
*ELSE PTOUV1A.87
C Set last values on row CW250393.7
*IF -DEF,MPP APB0F305.82
DO 201 I=ROW_LENGTH,U_POINTS,ROW_LENGTH PTOUV1A.89
U_DATA(I)=U_DATA(I-1) CW250393.8
201 CONTINUE PTOUV1A.93
*ELSE APB0F305.83
IF (atright) THEN APB0F305.84
! Set the last values on row APB0F305.85
DO I=ROW_LENGTH,U_POINTS,ROW_LENGTH APB0F305.86
U_DATA(I-Offx)=U_DATA(I-Offx-1) APB0F305.87
ENDDO APB0F305.88
ENDIF APB0F305.89
APB0F305.90
APB0F305.93
*ENDIF APB0F305.94
PTOUV1A.94
PTOUV1A.95
*ENDIF PTOUV1A.96
*IF DEF,MPP APB0F401.127
! Set a sensible number in the bottom right corner APB0F401.128
U_DATA(U_POINTS)=U_DATA(U_POINTS-1) APB0F401.129
APB0F401.130
*ENDIF APB0F401.131
PTOUV1A.97
RETURN PTOUV1A.98
END PTOUV1A.99
*ENDIF PTOUV1A.100