*IF DEF,C72_1A,AND,DEF,ATMOS,AND,DEF,OCEAN GLW1F404.19
C ******************************COPYRIGHT****************************** GTS2F400.2251
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.2252
C GTS2F400.2253
C Use, duplication or disclosure of this code is subject to the GTS2F400.2254
C restrictions as set forth in the contract. GTS2F400.2255
C GTS2F400.2256
C Meteorological Office GTS2F400.2257
C London Road GTS2F400.2258
C BRACKNELL GTS2F400.2259
C Berkshire UK GTS2F400.2260
C RG12 2SZ GTS2F400.2261
C GTS2F400.2262
C If no contract has been raised with this copy of the code, the use, GTS2F400.2263
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.2264
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.2265
C Modelling at the above address. GTS2F400.2266
C ******************************COPYRIGHT****************************** GTS2F400.2267
C GTS2F400.2268
SUBROUTINE DO_AREAVER(GAPS_LAMBDA_SRCE,GAPS_PHI_SRCE,LROW_SRCE 24DOARAV1.3
&,INVERT_SRCE,DATA_SRCE,GAPS_LAMBDA_TARG,GAPS_PHI_TARG,COUNT_TARG OJG1F403.1
&,BASE_TARG,LROW_TARG,WANT,MASK_TARG,INDEX_SRCE,WEIGHT,ADJUST OJG1F403.2
&,DATA_TARG,ICODE,CMESSAGE) OJG1F403.3
CLL Subroutine DO_AREAVER ------------------------------------------- DOARAV1.7
CLL DOARAV1.8
CLL Purpose: OJG1F403.4
CLL OJG1F403.5
CLL Perform area-averaging to transform data from the source grid to DOARAV1.10
CLL the target grid, or adjust the values on the source grid to have OJG1F403.6
CLL the area-averages supplied on the target grid. The latter mode OJG1F403.7
CLL is intended for adjusting values obtained by interpolating from OJG1F403.8
CLL "target" to "source" in order to conserve the area-averages. OJG1F403.9
CLL This mode should be used ONLY if each source box belongs in OJG1F403.10
CLL exactly one target box. ADJUST=0 selects normal area-averaging, OJG1F403.11
CLL ADJUST=1 selects adjustment by addition (use this mode for fields OJG1F403.12
CLL which may have either sign), ADJUST=2 selects adjustment by OJG1F403.13
CLL multiplication (for fields which are positive-definite or OJG1F403.14
CLL negative-definite). OJG1F403.15
CLL OJG1F403.16
CLL The shape of the source and target grids are specified by their DOARAV1.12
CLL dimensions GAPS_aa_bb, which give the number of gaps in the DOARAV1.13
CLL aa=LAMBDA,PHI coordinate in the bb=SRCE,TARG grid. (The product DOARAV1.14
CLL of GAPS_LAMBDA_bb and GAPS_PHI_bb is the number of boxes in the DOARAV1.15
CLL bb grid.) DOARAV1.16
CLL DOARAV1.17
CLL The input and output data are supplied as 2D arrays DATA_SRCE and DOARAV1.18
CLL DATA_TARG, whose first dimensions should also be supplied. Speci- DOARAV1.19
CLL fying these sizes separately from the actual dimensions of the DOARAV1.20
CLL grids allows for columns and rows in the arrays to be ignored. DOARAV1.21
CLL A target land/sea mask should be supplied in MASK_TARG, with the DOARAV1.22
CLL value indicating wanted points specified in WANT. Points which DOARAV1.23
CLL are unwanted or which lie outside the source grid are not altered DOARAV1.24
CLL in DATA_TARG. DATA_SRCE can optionally be supplied with its rows OJG1F403.17
CLL in reverse order (i.e. with the first row corresponding to OJG1F403.18
CLL minimum LAMBDA). OJG1F403.19
CLL DOARAV1.26
CLL The arrays COUNT_TARG, BASE_TARG, INDEX_SRCE and WEIGHT should be DOARAV1.27
CLL supplied as returned by PRE_AREAVER q.v. DOARAV1.28
CLL DOARAV1.29
CLL Programming Standard, paper 4 version 4 (14.12.90) DOARAV1.33
CLL DOARAV1.34
CLL Modification history: OJG1F403.20
CLL OJG1F403.21
CLL Logical components covered : DOARAV1.35
CLL DOARAV1.36
CLL Project task : DOARAV1.37
CLL DOARAV1.38
CLL External documentation: Unified Model documentation paper No: DOARAV1.39
CLL Version: DOARAV1.40
CLL DOARAV1.41
CLLEND ----------------------------------------------------------------- DOARAV1.42
C DOARAV1.43
IMPLICIT NONE DOARAV1.44
C*L DOARAV1.45
INTEGER DOARAV1.46
& GAPS_LAMBDA_SRCE !IN number lambda gaps in source grid DOARAV1.47
&,GAPS_PHI_SRCE !IN number phi gaps in source grid DOARAV1.48
&,LROW_SRCE !IN first dimension of source arrays DOARAV1.49
&,GAPS_LAMBDA_TARG !IN number lambda gaps in target grid DOARAV1.50
&,GAPS_PHI_TARG !IN number phi gaps in target grid DOARAV1.51
&,LROW_TARG !IN first dimension of target arrays DOARAV1.52
&,COUNT_TARG(GAPS_LAMBDA_TARG,GAPS_PHI_TARG) DOARAV1.53
C !IN no. of source boxes in target box DOARAV1.54
&,BASE_TARG(GAPS_LAMBDA_TARG,GAPS_PHI_TARG) DOARAV1.55
C !IN first index in list for target box OJG1F403.22
&,INDEX_SRCE(*) !IN list of source box indices DOARAV1.57
&,ADJUST !IN selects normal or adjust mode OJG1F403.23
&,ICODE !OUT return code DOARAV1.58
LOGICAL DOARAV1.59
& INVERT_SRCE !IN DATA_SRCE rows in reverse order OJG1F403.24
&,WANT !IN indicator of wanted points in mask OJG1F403.25
&,MASK_TARG(LROW_TARG,*) !IN land/sea mask for target grid DOARAV1.61
C NB alternative intents below apply for normal/adjust mode OJG1F403.26
REAL DOARAV1.62
& DATA_SRCE(LROW_SRCE,*) !IN/INOUT data on source grid OJG1F403.27
&,WEIGHT(*) !IN list of weights for source boxes DOARAV1.64
&,DATA_TARG(LROW_TARG,*) !INOUT/IN data on target grid OJG1F403.28
CHARACTER DOARAV1.66
& CMESSAGE*(*) !OUT error message DOARAV1.67
C* DOARAV1.68
INTEGER DOARAV1.69
& IP ! pointer into lists DOARAV1.70
&,I ! loop index DOARAV1.72
&,IX1(GAPS_LAMBDA_SRCE*GAPS_PHI_SRCE) OJG1F403.29
C ! working SRCE LAMBDA indices OJG1F403.30
&,IY1(GAPS_LAMBDA_SRCE*GAPS_PHI_SRCE) OJG1F403.31
C ! working SRCE PHI indices OJG1F403.32
&,IX2,IY2 ! working TARG LAMBDA/PHI indices OJG1F403.33
REAL OJG1F403.34
& TEMP_TARG ! workspace for area-average OJG1F403.35
&,DELTA ! additive adjustment OJG1F403.36
&,RATIO ! multiplicative adjustment OJG1F403.37
C DOARAV1.73
CL Loop over all target boxes and calculate values as required. DOARAV1.74
C DOARAV1.75
C The weights and source box indices are recorded in continuous DOARAV1.76
C lists. COUNT_TARG indicates how many consecutive entries in these DOARAV1.77
C lists apply to each target box. DOARAV1.78
C DOARAV1.79
DO IY2=1,GAPS_PHI_TARG DOARAV1.80
DO IX2=1,GAPS_LAMBDA_TARG DOARAV1.81
IF ((MASK_TARG(IX2,IY2).EQV.WANT) DOARAV1.82
& .AND.COUNT_TARG(IX2,IY2).NE.0) THEN DOARAV1.83
TEMP_TARG=0. OJG1F403.38
DO I=1,COUNT_TARG(IX2,IY2) DOARAV1.85
IP=BASE_TARG(IX2,IY2)+I DOARAV1.86
IX1(I)=MOD(INDEX_SRCE(IP)-1,GAPS_LAMBDA_SRCE)+1 OJG1F403.39
IY1(I)=(INDEX_SRCE(IP)-1)/GAPS_LAMBDA_SRCE+1 OJG1F403.40
IF (INVERT_SRCE) IY1(I)=GAPS_PHI_SRCE-IY1(I)+1 OJG1F403.41
TEMP_TARG=TEMP_TARG+WEIGHT(IP)*DATA_SRCE(IX1(I),IY1(I)) OJG1F403.42
ENDDO DOARAV1.91
IF (ADJUST.EQ.0) THEN OJG1F403.43
DATA_TARG(IX2,IY2)=TEMP_TARG OJG1F403.44
ELSEIF (ADJUST.EQ.1) THEN OJG1F403.45
DELTA=DATA_TARG(IX2,IY2)-TEMP_TARG OJG1F403.46
DO I=1,COUNT_TARG(IX2,IY2) OJG1F403.47
DATA_SRCE(IX1(I),IY1(I))=DATA_SRCE(IX1(I),IY1(I))+DELTA OJG1F403.48
ENDDO OJG1F403.49
ELSEIF (ADJUST.EQ.2.AND.TEMP_TARG.NE.0.) THEN OJG1F403.50
RATIO=DATA_TARG(IX2,IY2)/TEMP_TARG OJG1F403.51
DO I=1,COUNT_TARG(IX2,IY2) OJG1F403.52
DATA_SRCE(IX1(I),IY1(I))=DATA_SRCE(IX1(I),IY1(I))*RATIO OJG1F403.53
ENDDO OJG1F403.54
ENDIF OJG1F403.55
ENDIF DOARAV1.92
ENDDO DOARAV1.93
ENDDO DOARAV1.94
C DOARAV1.95
ICODE=0 DOARAV1.96
CMESSAGE=' ' DOARAV1.97
RETURN DOARAV1.98
END DOARAV1.99
*ENDIF DOARAV1.100