*IF DEF,C90_1A,OR,DEF,C90_2A,OR,DEF,C90_2B AAD2F404.290
C ******************************COPYRIGHT****************************** GTS2F400.10945
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.10946
C GTS2F400.10947
C Use, duplication or disclosure of this code is subject to the GTS2F400.10948
C restrictions as set forth in the contract. GTS2F400.10949
C GTS2F400.10950
C Meteorological Office GTS2F400.10951
C London Road GTS2F400.10952
C BRACKNELL GTS2F400.10953
C Berkshire UK GTS2F400.10954
C RG12 2SZ GTS2F400.10955
C GTS2F400.10956
C If no contract has been raised with this copy of the code, the use, GTS2F400.10957
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.10958
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.10959
C Modelling at the above address. GTS2F400.10960
C ******************************COPYRIGHT****************************** GTS2F400.10961
C GTS2F400.10962
CLL SUBROUTINE UV_TO_P_FULL---------------------------------------- UVTOPF1A.3
CLL UVTOPF1A.4
CLL Purpose: Interpolates a horizontal field from wind to pressure UVTOPF1A.5
CLL points on an Arakawa B grid. Under UPDATE identifier GLOBAL the data UVTOPF1A.6
CLL is assumed periodic along rows. Otherwise, the first value CW250393.18
CLL on each row is set equal to the second value on each row and the CW250393.19
CLL top row values set to the second row, and the bottom row set to the CW250393.20
CLL penultimate row.The input array is a full U/V field and the CW250393.21
CLL output array is a full P field. UVTOPF1A.10
CLL The routine UV_TO_P outputs data on a P-field starting at the UVTOPF1A.11
CLL first element in the second row - i.e. the north pole or top UVTOPF1A.12
CLL row is ignored. UVTOPF1A.13
CLL UVTOPF1A.14
CLL Not suitable for single column use. UVTOPF1A.15
CLL UVTOPF1A.16
CLL J.Heming <- programmer of some or all of previous code or changes UVTOPF1A.17
CLL R.Rawlins <- programmer of some or all of previous code or changes UVTOPF1A.18
CLL M.Carter <- programmer of some or all of previous code or changes UVTOPF1A.19
CLL UVTOPF1A.20
CLL Model Modification history from model version 3.0: UVTOPF1A.21
CLL version Date UVTOPF1A.22
CLL 3.2 25/03/93 Remove one-sided differencing for edge points. CW250393.22
CLL Author: C.A.Wilson Reviewer: A.Dickinson CW250393.23
!LL 4.3 07/05/97 Added MPP code P.Burton GPB1F403.1824
CLL UVTOPF1A.23
CLL Programming standard: Unified Model Documentation Paper No 3 UVTOPF1A.24
CLL UVTOPF1A.25
CLL System component: S101 UVTOPF1A.26
CLL UVTOPF1A.27
CLL System task: S1 UVTOPF1A.28
CLL UVTOPF1A.29
CLL Documentation: The equation used is (2.1) UVTOPF1A.30
CLL in unified model documentation paper No. S1 UVTOPF1A.31
CLL UVTOPF1A.32
CLLEND------------------------------------------------------------- UVTOPF1A.33
UVTOPF1A.34
C UVTOPF1A.35
C*L Arguments:--------------------------------------------------- UVTOPF1A.36
SUBROUTINE UV_TO_P_FULL 2UVTOPF1A.37
1 (U_DATA,P_DATA,U_FIELD,P_FIELD,ROW_LENGTH,P_ROWS) UVTOPF1A.38
UVTOPF1A.39
IMPLICIT NONE UVTOPF1A.40
UVTOPF1A.41
INTEGER UVTOPF1A.42
* P_ROWS !IN Number of rows in p field UVTOPF1A.43
*, ROW_LENGTH !IN Number of points per row UVTOPF1A.44
*, P_FIELD !IN Number of points in output field UVTOPF1A.45
*, U_FIELD !IN Number of points in input field UVTOPF1A.46
UVTOPF1A.47
REAL UVTOPF1A.48
* P_DATA(P_FIELD) ! OUT Data on p points UVTOPF1A.49
*,U_DATA(U_FIELD) ! IN Data on uv points UVTOPF1A.50
C*--------------------------------------------------------------------- UVTOPF1A.51
UVTOPF1A.52
C*L Local arrays:---------------------------------------------------- UVTOPF1A.53
REAL UVTOPF1A.54
* U_DATASUM ! Sum of uv point data on first and last rows UVTOPF1A.55
*,RECIP_ROW_LENGTH ! Reciprocal of rowlength UVTOPF1A.56
C*--------------------------------------------------------------------- UVTOPF1A.57
UVTOPF1A.58
C*L External subroutine calls:---------------------------------------- UVTOPF1A.59
C None UVTOPF1A.60
C*--------------------------------------------------------------------- UVTOPF1A.61
UVTOPF1A.62
*IF DEF,MPP GPB1F403.1825
!---------------------------------------------------------------------- GPB1F403.1826
! Comdecks required by MPP code GPB1F403.1827
GPB1F403.1828
*CALL PARVARS 
GPB1F403.1829
*CALL GCCOM GPB1F403.1830
GPB1F403.1831
!---------------------------------------------------------------------- GPB1F403.1832
*ENDIF GPB1F403.1833
! GPB1F403.1834
!---------------------------------------------------------------------- GPB1F403.1835
! Loop bound variables GPB1F403.1836
INTEGER GPB1F403.1837
& FIRST_POINT,LAST_POINT GPB1F403.1838
&, TOP_ROW_START , TOP_ROW_END GPB1F403.1839
&, BOT_ROW_START , BOT_ROW_END GPB1F403.1840
GPB1F403.1841
*IF DEF,MPP GPB1F403.1842
! GCOM variables GPB1F403.1843
INTEGER GPB1F403.1844
& info GPB1F403.1845
*ENDIF GPB1F403.1846
GPB1F403.1847
C---------------------------------------------------------------------- UVTOPF1A.63
C Define local variables UVTOPF1A.64
C---------------------------------------------------------------------- UVTOPF1A.65
INTEGER UVTOPF1A.66
* I ! Horizontal loop indices CW250393.24
UVTOPF1A.68
C--------------------------------------------------------------------- UVTOPF1A.69
CL 1. Initialise local constants UVTOPF1A.70
C--------------------------------------------------------------------- UVTOPF1A.71
UVTOPF1A.72
U_DATASUM = 0.0 UVTOPF1A.73
*IF -DEF,MPP GPB1F403.1848
RECIP_ROW_LENGTH = 1.0/ROW_LENGTH UVTOPF1A.74
*ELSE GPB1F403.1849
RECIP_ROW_LENGTH = 1.0/glsize(1) GPB1F403.1850
*ENDIF GPB1F403.1851
GPB1F403.1852
UVTOPF1A.75
C--------------------------------------------------------------------- UVTOPF1A.76
CL 2. Calculate horizontal average at p points excluding first UVTOPF1A.77
CL and last rows UVTOPF1A.78
C--------------------------------------------------------------------- UVTOPF1A.79
UVTOPF1A.80
*IF -DEF,MPP GPB1F403.1853
FIRST_POINT=ROW_LENGTH+2 GPB1F403.1854
LAST_POINT=P_FIELD-ROW_LENGTH GPB1F403.1855
*ELSE GPB1F403.1856
IF (attop) THEN GPB1F403.1857
FIRST_POINT=(Offy+1)*ROW_LENGTH+Offx+1 GPB1F403.1858
ELSE GPB1F403.1859
FIRST_POINT=Offy*ROW_LENGTH+Offx+1 GPB1F403.1860
ENDIF GPB1F403.1861
GPB1F403.1862
IF (atbase) THEN GPB1F403.1863
LAST_POINT=P_FIELD-(Offy+1)*ROW_LENGTH-Offx GPB1F403.1864
ELSE GPB1F403.1865
LAST_POINT=P_FIELD-Offy*ROW_LENGTH-Offx GPB1F403.1866
ENDIF GPB1F403.1867
*ENDIF GPB1F403.1868
GPB1F403.1869
DO I=FIRST_POINT,LAST_POINT GPB1F403.1870
P_DATA(I)=0.25*(U_DATA(I)+U_DATA(I-1)+ UVTOPF1A.82
* U_DATA(I-ROW_LENGTH)+U_DATA(I-1-ROW_LENGTH)) UVTOPF1A.83
ENDDO UVTOPF1A.84
UVTOPF1A.85
*IF DEF,GLOBAL UVTOPF1A.86
C--------------------------------------------------------------------- UVTOPF1A.87
CL 3. Calculate horizontal average at north and south pole UVTOPF1A.88
C--------------------------------------------------------------------- UVTOPF1A.89
UVTOPF1A.90
*IF -DEF,MPP GPB1F403.1871
DO I=1,ROW_LENGTH UVTOPF1A.91
U_DATASUM=U_DATASUM+U_DATA(I) UVTOPF1A.92
ENDDO UVTOPF1A.93
DO I=1,ROW_LENGTH UVTOPF1A.94
P_DATA(I)=RECIP_ROW_LENGTH*U_DATASUM UVTOPF1A.95
ENDDO UVTOPF1A.96
UVTOPF1A.97
U_DATASUM = 0.0 UVTOPF1A.98
UVTOPF1A.99
DO I=P_FIELD-(2*ROW_LENGTH)+1,P_FIELD-ROW_LENGTH UVTOPF1A.100
U_DATASUM=U_DATASUM+U_DATA(I) UVTOPF1A.101
ENDDO UVTOPF1A.102
DO I=P_FIELD-ROW_LENGTH+1,P_FIELD UVTOPF1A.103
P_DATA(I)=RECIP_ROW_LENGTH*U_DATASUM UVTOPF1A.104
ENDDO UVTOPF1A.105
*ELSE GPB1F403.1872
GPB1F403.1873
IF (attop) THEN GPB1F403.1874
GPB1F403.1875
CALL GCG_RVECSUMR(ROW_LENGTH,ROW_LENGTH-2*Offx, GPB1F403.1876
& Offy*ROW_LENGTH+Offx+1,1,U_DATA, GPB1F403.1877
& gc_proc_row_group,info,U_DATASUM) GPB1F403.1878
GPB1F403.1879
DO I=Offy*ROW_LENGTH+1,(Offy+1)*ROW_LENGTH GPB1F403.1880
P_DATA(I)=RECIP_ROW_LENGTH*U_DATASUM GPB1F403.1881
ENDDO GPB1F403.1882
GPB1F403.1883
ENDIF GPB1F403.1884
GPB1F403.1885
U_DATASUM=0.0 GPB1F403.1886
GPB1F403.1887
IF (atbase) THEN GPB1F403.1888
GPB1F403.1889
CALL GCG_RVECSUMR(ROW_LENGTH,ROW_LENGTH-2*Offx, GPB1F403.1890
& P_FIELD-(Offy+2)*ROW_LENGTH+Offx+1,1, GPB1F403.1891
& U_DATA,gc_proc_row_group,info,U_DATASUM) GPB1F403.1892
GPB1F403.1893
DO I=P_FIELD-(Offy+1)*ROW_LENGTH+1, GPB1F403.1894
& P_FIELD-Offy*ROW_LENGTH GPB1F403.1895
P_DATA(I)=RECIP_ROW_LENGTH*U_DATASUM GPB1F403.1896
ENDDO GPB1F403.1897
GPB1F403.1898
ENDIF GPB1F403.1899
GPB1F403.1900
*ENDIF GPB1F403.1901
UVTOPF1A.106
C--------------------------------------------------------------------- UVTOPF1A.107
CL 4.Recalculate horizontal average at end points not including poles UVTOPF1A.108
CL i.e. allow for global wrap round UVTOPF1A.109
C--------------------------------------------------------------------- UVTOPF1A.110
UVTOPF1A.111
*IF -DEF,MPP GPB1F403.1902
DO I=ROW_LENGTH+1,P_FIELD-ROW_LENGTH,ROW_LENGTH UVTOPF1A.112
P_DATA(I)=0.25*(U_DATA(I)+U_DATA(I-1+ROW_LENGTH)+ UVTOPF1A.113
* U_DATA(I-ROW_LENGTH)+U_DATA(I-1)) UVTOPF1A.114
ENDDO UVTOPF1A.115
*ELSE GPB1F403.1903
! Halos take care of this automatically GPB1F403.1904
*ENDIF GPB1F403.1905
UVTOPF1A.116
*ELSE UVTOPF1A.117
C--------------------------------------------------------------------- UVTOPF1A.118
CL 5.Recalculate first and last rows for limited area model by UVTOPF1A.119
CL setting equal to internal rows CW250393.25
C--------------------------------------------------------------------- UVTOPF1A.121
*IF -DEF,MPP GPB1F403.1906
DO I = 2 , ROW_LENGTH CW250393.26
P_DATA(I)=P_DATA(I+ROW_LENGTH) CW250393.27
ENDDO UVTOPF1A.124
UVTOPF1A.125
DO I = P_FIELD-ROW_LENGTH+2 , P_FIELD CW250393.28
P_DATA(I)=P_DATA(I-ROW_LENGTH) CW250393.29
ENDDO UVTOPF1A.128
*ELSE GPB1F403.1907
IF (attop) THEN GPB1F403.1908
DO I=Offy*ROW_LENGTH+1,(Offy+1)*ROW_LENGTH GPB1F403.1909
P_DATA(I)=P_DATA(I+ROW_LENGTH) GPB1F403.1910
ENDDO GPB1F403.1911
ENDIF GPB1F403.1912
GPB1F403.1913
IF (atbase) THEN GPB1F403.1914
DO I=P_FIELD-(Offy+1)*ROW_LENGTH+1,P_FIELD-Offy*ROW_LENGTH GPB1F403.1915
P_DATA(I)=P_DATA(I-ROW_LENGTH) GPB1F403.1916
ENDDO GPB1F403.1917
ENDIF GPB1F403.1918
*ENDIF GPB1F403.1919
C--------------------------------------------------------------------- UVTOPF1A.129
CL 6.Recalculate first points in each row for the limited CW250393.30
CL area model by setting equal to second points CW250393.31
C--------------------------------------------------------------------- UVTOPF1A.132
UVTOPF1A.133
*IF -DEF,MPP GPB1F403.1920
DO I=1,P_FIELD,ROW_LENGTH CW250393.32
P_DATA(I)=P_DATA(I+1) CW250393.33
ENDDO UVTOPF1A.138
*ELSE GPB1F403.1921
IF (atleft) THEN GPB1F403.1922
DO I=Offx+1,P_FIELD,ROW_LENGTH GPB1F403.1923
P_DATA(I)=P_DATA(I+1) GPB1F403.1924
ENDDO GPB1F403.1925
ENDIF GPB1F403.1926
*ENDIF GPB1F403.1927
UVTOPF1A.139
*ENDIF UVTOPF1A.140
C--------------------------------------------------------------------- UVTOPF1A.141
UVTOPF1A.142
RETURN UVTOPF1A.143
END UVTOPF1A.144
UVTOPF1A.145
*ENDIF UVTOPF1A.146