*IF DEF,C92_1A BOXSUM1.2
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.15320
C GTS2F400.15321
C Use, duplication or disclosure of this code is subject to the GTS2F400.15322
C restrictions as set forth in the contract. GTS2F400.15323
C GTS2F400.15324
C Meteorological Office GTS2F400.15325
C London Road GTS2F400.15326
C BRACKNELL GTS2F400.15327
C Berkshire UK GTS2F400.15328
C RG12 2SZ GTS2F400.15329
C GTS2F400.15330
C If no contract has been raised with this copy of the code, the use, GTS2F400.15331
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.15332
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.15333
C Modelling at the above address. GTS2F400.15334
C ******************************COPYRIGHT****************************** GTS2F400.15335
C GTS2F400.15336
CLL SUBROUTINE BOX_SUM BOXSUM1.3
CLL BOXSUM1.4
CLL NOT SUITABLE FOR SINGLE COLUMN USE BOXSUM1.5
CLL BOXSUM1.6
CLL BOXSUM1.7
CLL SUITABLE FOR ROTATED GRIDS BOXSUM1.8
CLL BOXSUM1.9
CLL ORIGINAL VERSION FOR CRAY Y-MP/IBM BOXSUM1.10
CLL WRITTEN 12/07/91 BY C. WILSON BOXSUM1.11
CLL BOXSUM1.12
CLL CODE REVIEWED BY R.SMITH ??/??/?? BOXSUM1.13
CLL BOXSUM1.14
CLL VERSION NO. 2 DATED 16/09/91 BOXSUM1.15
CLL COSMOS DSN MS15.CWUM.JOBS(BOXSUM2) BOXSUM1.16
CLL PROGRAMMING STANDARD: UNIFIED MODEL DOCUMENTATION PAPER NO. 4, BOXSUM1.17
CLL VERSION 1, DATED 12/09/89 BOXSUM1.18
! History: UDG2F401.131
! Version Date Comment UDG2F401.132
! ------- ---- ------- UDG2F401.133
! 4.0 12/04/95 Imported into Unified model. D.M. Goddard UDG2F401.134
! 4.1 12/06/96 Corrections for zonal means. D.M. Goddard UDG2F401.135
! 4.4 30/09/97 Corrections for portable model. D.M. Goddard UDG0F404.136
CLL BOXSUM1.19
CLL SYSTEM TASK: S1 (part,extension for area mean interpolation) BOXSUM1.20
CLL BOXSUM1.21
CLL PURPOSE: BOXSUM1.22
CLL Routine sums contributions from gridboxes for source data on a BOXSUM1.23
CLL regular lat-long grid to form means for gridboxes of a regular BOXSUM1.24
CLL lat-long grid specified as target. BOXSUM1.25
CLL Both grids are defined with the same pole and orientation; BOXSUM1.26
CLL the original data must be interpolated onto a rotated BOXSUM1.27
CLL grid ,if the target grid is a rotated grid, BEFORE calling this BOXSUM1.28
CLL routine. BOXSUM1.29
CLL The algorithms are general and will cope with either a finer BOXSUM1.30
CLL or coarser resolution source grid. BOXSUM1.31
CLL BOXSUM1.32
CLL DOCUMENTATION: UNIFIED MODEL DOCUMENTATION S1 BOXSUM1.33
CLL BY A.DICKINSON/C WILSON VERSION ??DATED ??/??/91 BOXSUM1.34
CLL BOXSUM1.35
CLL BOXSUM1.36
CLLEND------------------------------------------------------------- BOXSUM1.37
C BOXSUM1.38
C*L ARGUMENTS:--------------------------------------------------- BOXSUM1.39
SUBROUTINE BOX_SUM 1BOXSUM1.40
1 (SOURCE_ROW_LENGTH,SOURCE_ROWS,ROW_LENGTH,ROWS, BOXSUM1.41
2 LONG_L,COLAT_T,I_L,J_T,GLOBAL,BOXSUM,SOURCE) BOXSUM1.42
BOXSUM1.43
IMPLICIT NONE BOXSUM1.44
BOXSUM1.45
INTEGER BOXSUM1.46
* SOURCE_ROW_LENGTH !IN Number of points per row (source data) BOXSUM1.47
* ! on rotated grid if necessary BOXSUM1.48
*, SOURCE_ROWS !IN Number of rows of source data BOXSUM1.49
* ! on rotated grid if necessary BOXSUM1.50
*, ROW_LENGTH !IN Number of points per row target area BOXSUM1.51
*, ROWS !IN Number of rows of target area BOXSUM1.52
C BOXSUM1.53
INTEGER BOXSUM1.54
1 I_L(ROW_LENGTH+1)!IN Index of first source gridbox to overlap BOXSUM1.55
* ! with left hand side of target gridbox BOXSUM1.56
2,J_T(ROWS+1) !IN Index of first source gridbox to overlap BOXSUM1.57
* ! top of target gridbox BOXSUM1.58
C BOXSUM1.59
CL N.B.I_L(I) is the first source gridbox to overlap LH side of target BOXSUM1.60
CL box I of a row BOXSUM1.61
CL I_L(I+1) is the last source gridbox to overlap RH side of target BOXSUM1.62
CL box I of a row BOXSUM1.63
CL J_T(J) is the first source gridbox to overlap top of target BOXSUM1.64
CL box on row J BOXSUM1.65
CL J_T(J+1) is the last source gridbox to overlap bottom of target BOXSUM1.66
CL box on row J BOXSUM1.67
CL BOXSUM1.68
CL REAL value of:- BOXSUM1.69
CL I_L(I) is also used to measure the 'longitude' of the RHS of the BOXSUM1.70
CL source gridbox BOXSUM1.71
CL J_T(J) is also used to measure the 'colatitude' of the bottom BOXSUM1.72
CL of the source gridbox BOXSUM1.73
C BOXSUM1.74
BOXSUM1.75
REAL BOXSUM1.76
1 SOURCE(SOURCE_ROW_LENGTH,SOURCE_ROWS)!IN source data BOXSUM1.77
REAL BOXSUM(ROW_LENGTH,ROWS) !OUT Sum of data on target grid BOXSUM1.78
2, LONG_L(ROW_LENGTH +1) !IN Left longitude of gridbox (in BOXSUM1.79
+ ! units of souce gridbox EW length) BOXSUM1.80
3, COLAT_T(ROWS +1) !IN Colatitude of top of gridbox (in BOXSUM1.81
+ ! units of source gridbox NS length) BOXSUM1.82
BOXSUM1.83
LOGICAL GLOBAL !IN true if global area required BOXSUM1.84
C*--------------------------------------------------------------------- BOXSUM1.85
BOXSUM1.86
C*L WORKSPACE USAGE:------------------------------------------------- BOXSUM1.87
C Define local workspace arrays: BOXSUM1.88
C 1 real of length row_length BOXSUM1.89
REAL BOXSUM1.90
1 EW_SUM(ROW_LENGTH) ! summed WE source data BOXSUM1.91
2, EW_WEIGHT(ROW_LENGTH) ! summed WE weights for source data BOXSUM1.92
3, BOX_WEIGHT(ROW_LENGTH) ! summed weights for target boxes BOXSUM1.93
C BOXSUM1.94
C*--------------------------------------------------------------------- BOXSUM1.95
C BOXSUM1.96
C*L EXTERNAL SUBROUTINES CALLED--------------------------------------- BOXSUM1.97
C None BOXSUM1.98
C*------------------------------------------------------------------ BOXSUM1.99
BOXSUM1.100
*CALL C_MDI 
BOXSUM1.101
BOXSUM1.102
C DEFINE LOCAL VARIABLES BOXSUM1.103
BOXSUM1.104
INTEGER I,J,I1,I2,IT,J1,J2,JT,K ! loop counters UDG0F404.137
BOXSUM1.106
REAL RH_BOX BOXSUM1.107
BOXSUM1.108
CL ********************************************************************* BOXSUM1.109
CL 1.0 Sum source boxes (whole and partial) contributions to target box BOXSUM1.110
CL ********************************************************************* BOXSUM1.111
BOXSUM1.112
DO 150 J=1,ROWS BOXSUM1.113
J1 = J_T(J) BOXSUM1.114
J2 = J_T(J+1) BOXSUM1.115
BOXSUM1.116
DO I=1,ROW_LENGTH BOXSUM1.117
BOX_WEIGHT(I)=0.0 BOXSUM1.118
ENDDO BOXSUM1.119
BOXSUM1.120
DO 140 JT=J1,J2 BOXSUM1.121
BOXSUM1.122
CL ********************************************************************* BOXSUM1.123
CL 1.1 Sum EW (whole and partial) contributions to target grid boxes BOXSUM1.124
CL ********************************************************************* BOXSUM1.125
BOXSUM1.126
DO I=1,ROW_LENGTH BOXSUM1.127
EW_SUM(I)=0.0 BOXSUM1.128
EW_WEIGHT(I)=0.0 BOXSUM1.129
ENDDO BOXSUM1.130
BOXSUM1.131
DO 120 I=1,ROW_LENGTH BOXSUM1.132
I1 = I_L(I) BOXSUM1.133
I2 = I_L(I+1) BOXSUM1.134
IF(I1.GT.I2.AND.GLOBAL) THEN BOXSUM1.135
C If grid box spans zero longitude need to split summation BOXSUM1.136
BOXSUM1.137
DO 101 IT=I1,SOURCE_ROW_LENGTH BOXSUM1.138
IF(IT.EQ.I1) THEN BOXSUM1.139
C Left side partial contribution BOXSUM1.140
RH_BOX = LONG_L(I+1) BOXSUM1.141
IF(RH_BOX.LT.LONG_L(I)) RH_BOX=RH_BOX BOXSUM1.142
& +SOURCE_ROW_LENGTH BOXSUM1.143
CXX IF(NINT(SOURCE(I1,JT)).NE.IMDI) THEN BOXSUM1.144
IF(NINT(SOURCE(I1,JT)).NE.NINT(RMDI)) THEN BOXSUM1.145
CXX IF(SOURCE(I1,JT).GE.0.0) THEN BOXSUM1.146
EW_WEIGHT(I) = BOXSUM1.147
& EW_WEIGHT(I) + (MIN(REAL(I1),RH_BOX) - LONG_L(I)) BOXSUM1.148
EW_SUM(I) = (MIN(REAL(I1),RH_BOX) - LONG_L(I)) BOXSUM1.149
& *SOURCE(I1,JT) + EW_SUM(I) BOXSUM1.150
ELSEIF(NINT(SOURCE(I1,JT)).EQ.NINT(RMDI)) THEN BOXSUM1.151
C missing data BOXSUM1.152
ELSE BOXSUM1.153
write (6,*) '-ve source 1 ? I1 JT data',I1,JT, BOXSUM1.154
+ source(i1,jt) BOXSUM1.155
ENDIF BOXSUM1.156
BOXSUM1.157
ELSE BOXSUM1.158
BOXSUM1.159
C Whole contributions BOXSUM1.160
CXX IF(NINT(SOURCE(IT,JT)).NE.IMDI) THEN BOXSUM1.161
IF(NINT(SOURCE(IT,JT)).NE.NINT(RMDI)) THEN BOXSUM1.162
CXX IF(SOURCE(IT,JT).GE.0.0) THEN BOXSUM1.163
EW_WEIGHT(I) = EW_WEIGHT(I)+ 1.0 BOXSUM1.164
EW_SUM(I) = EW_SUM(I) + SOURCE(IT,JT) BOXSUM1.165
ELSEIF(NINT(SOURCE(IT,JT)).EQ.NINT(RMDI)) THEN BOXSUM1.166
C missing data BOXSUM1.167
ELSE BOXSUM1.168
write (6,*) '-ve source 2 ? IT JT data',IT,JT, BOXSUM1.169
+ source(it,jt) BOXSUM1.170
ENDIF BOXSUM1.171
BOXSUM1.172
ENDIF BOXSUM1.173
BOXSUM1.174
101 CONTINUE BOXSUM1.175
BOXSUM1.176
DO 102 IT=1,I2 BOXSUM1.177
IF(IT.EQ.I2) THEN BOXSUM1.178
C Right side partial contribution BOXSUM1.179
CXX IF(NINT(SOURCE(I2,JT)).NE.IMDI) THEN BOXSUM1.180
IF(NINT(SOURCE(I2,JT)).NE.NINT(RMDI)) THEN BOXSUM1.181
CXX IF(SOURCE(I2,JT).GE.0.0) THEN BOXSUM1.182
EW_WEIGHT(I) = EW_WEIGHT(I)+(LONG_L(I+1)-(I2-1)) BOXSUM1.183
EW_SUM(I)=EW_SUM(I) + BOXSUM1.184
& (LONG_L(I+1)-(I2-1))*SOURCE(I2,JT) BOXSUM1.185
ELSEIF(NINT(SOURCE(I2,JT)).EQ.NINT(RMDI)) THEN BOXSUM1.186
C missing data BOXSUM1.187
ELSE BOXSUM1.188
write (6,*) '-ve source 3 ? I2 JT data',I2,JT, BOXSUM1.189
+ source(i2,jt) BOXSUM1.190
ENDIF BOXSUM1.191
ELSE BOXSUM1.192
BOXSUM1.193
C Whole contributions BOXSUM1.194
CXX IF(NINT(SOURCE(IT,JT)).NE.IMDI) THEN BOXSUM1.195
IF(NINT(SOURCE(IT,JT)).NE.NINT(RMDI)) THEN BOXSUM1.196
CXX IF(SOURCE(IT,JT).GE.0.0) THEN BOXSUM1.197
EW_WEIGHT(I) = EW_WEIGHT(I)+ 1.0 BOXSUM1.198
EW_SUM(I) = EW_SUM(I) + SOURCE(IT,JT) BOXSUM1.199
ELSEIF(NINT(SOURCE(IT,JT)).EQ.NINT(RMDI)) THEN BOXSUM1.200
C missing data BOXSUM1.201
ELSE BOXSUM1.202
write (6,*) '-ve source 4 ? IT JT data',IT,JT, BOXSUM1.203
+ source(it,jt) BOXSUM1.204
ENDIF BOXSUM1.205
BOXSUM1.206
ENDIF BOXSUM1.207
BOXSUM1.208
102 CONTINUE BOXSUM1.209
BOXSUM1.210
ELSE IF(I1.LT.I2)THEN ! no zero meridian crossing UDG2F401.136
DO 110 IT=I1,I2 BOXSUM1.212
IF(IT.EQ.I1) THEN BOXSUM1.213
C Left side partial contribution BOXSUM1.214
CXX IF(NINT(SOURCE(I1,JT)).NE.IMDI) THEN BOXSUM1.215
IF(NINT(SOURCE(I1,JT)).NE.NINT(RMDI)) THEN BOXSUM1.216
CXX IF(SOURCE(I1,JT).GE.0.0) THEN BOXSUM1.217
EW_WEIGHT(I) = EW_WEIGHT(I) + BOXSUM1.218
& (MIN(REAL(I1),LONG_L(I+1)) - LONG_L(I)) BOXSUM1.219
EW_SUM(I) = (MIN(REAL(I1),LONG_L(I+1)) - LONG_L(I)) BOXSUM1.220
& *SOURCE(I1,JT) + EW_SUM(I) BOXSUM1.221
ELSEIF(NINT(SOURCE(I1,JT)).EQ.NINT(RMDI)) THEN BOXSUM1.222
C missing data BOXSUM1.223
ELSE BOXSUM1.224
write (6,*) '-ve source 5 ? I1 JT data',I1,JT, BOXSUM1.225
+ source(i1,jt) BOXSUM1.226
ENDIF BOXSUM1.227
BOXSUM1.228
ELSE IF(IT.EQ.I2) THEN BOXSUM1.229
C Right side partial contribution BOXSUM1.230
CXX IF(NINT(SOURCE(I2,JT)).NE.IMDI) THEN BOXSUM1.231
IF(NINT(SOURCE(I2,JT)).NE.NINT(RMDI)) THEN BOXSUM1.232
CXX IF(SOURCE(I2,JT).GE.0.0) THEN BOXSUM1.233
EW_WEIGHT(I) = EW_WEIGHT(I)+ (LONG_L(I+1)-(I2-1)) BOXSUM1.234
EW_SUM(I)=EW_SUM(I)+(LONG_L(I+1)-(I2-1))*SOURCE(I2,JT) BOXSUM1.235
ELSEIF(NINT(SOURCE(I2,JT)).EQ.NINT(RMDI)) THEN BOXSUM1.236
C missing data BOXSUM1.237
ELSE BOXSUM1.238
write (6,*) '-ve source 6 ? I2 JT data',I2,JT, BOXSUM1.239
+ source(i2,jt) BOXSUM1.240
ENDIF BOXSUM1.241
BOXSUM1.242
ELSE BOXSUM1.243
BOXSUM1.244
C Whole contributions BOXSUM1.245
BOXSUM1.246
CXX IF(NINT(SOURCE(IT,JT)).NE.IMDI) THEN BOXSUM1.247
IF(NINT(SOURCE(IT,JT)).NE.NINT(RMDI)) THEN BOXSUM1.248
CXX IF(SOURCE(IT,JT).GE.0.0) THEN BOXSUM1.249
EW_WEIGHT(I) = EW_WEIGHT(I)+ 1.0 BOXSUM1.250
EW_SUM(I) = EW_SUM(I) + SOURCE(IT,JT) BOXSUM1.251
ELSEIF(NINT(SOURCE(IT,JT)).EQ.NINT(RMDI)) THEN BOXSUM1.252
C missing data BOXSUM1.253
ELSE BOXSUM1.254
write (6,*) '-ve source 7 ? IT JT data',IT,JT, BOXSUM1.255
+ source(it,jt) BOXSUM1.256
ENDIF BOXSUM1.257
BOXSUM1.258
ENDIF BOXSUM1.259
110 CONTINUE BOXSUM1.260
BOXSUM1.261
ELSE UDG2F401.137
!Zonal mean no need to average in EW direction UDG2F401.138
DO K=1,ROW_LENGTH UDG0F404.138
EW_WEIGHT(K)=1.0 UDG0F404.139
EW_SUM(K)=SOURCE(1,JT) UDG0F404.140
END DO UDG0F404.141
UDG0F404.142
UDG2F401.141
UDG2F401.142
ENDIF BOXSUM1.262
BOXSUM1.263
120 CONTINUE BOXSUM1.264
BOXSUM1.265
CL ********************************************************************* BOXSUM1.266
CL 1.3 Add summed EW box contributions into rows J target grid boxes BOXSUM1.267
CL ********************************************************************* BOXSUM1.268
BOXSUM1.269
IF(JT.EQ.J1) THEN BOXSUM1.270
C Top row BOXSUM1.271
DO 130 I=1,ROW_LENGTH BOXSUM1.272
BOXSUM(I,J) = (MIN(REAL(J1),COLAT_T(J+1)) - COLAT_T(J)) BOXSUM1.273
& *EW_SUM(I) BOXSUM1.274
BOX_WEIGHT(I) = (MIN(REAL(J1),COLAT_T(J+1)) - COLAT_T(J)) BOXSUM1.275
& *EW_WEIGHT(I) + BOX_WEIGHT(I) BOXSUM1.276
130 CONTINUE BOXSUM1.277
BOXSUM1.278
ELSE IF(JT.EQ.J2) THEN BOXSUM1.279
C Bottom of row J BOXSUM1.280
DO 131 I=1,ROW_LENGTH BOXSUM1.281
BOXSUM(I,J) = BOXSUM(I,J) + BOXSUM1.282
1 (1-(J2 - COLAT_T(J+1)))*EW_SUM(I) BOXSUM1.283
BOX_WEIGHT(I) = BOX_WEIGHT(I) + BOXSUM1.284
& (1-(J2 - COLAT_T(J+1)))*EW_WEIGHT(I) BOXSUM1.285
131 CONTINUE BOXSUM1.286
BOXSUM1.287
ELSE BOXSUM1.288
C Whole contributions to row J BOXSUM1.289
DO 132 I=1,ROW_LENGTH BOXSUM1.290
BOXSUM(I,J) = BOXSUM(I,J) + EW_SUM(I) BOXSUM1.291
BOX_WEIGHT(I) = BOX_WEIGHT(I) + EW_WEIGHT(I) BOXSUM1.292
132 CONTINUE BOXSUM1.293
BOXSUM1.294
ENDIF BOXSUM1.295
BOXSUM1.296
140 CONTINUE BOXSUM1.297
BOXSUM1.298
DO 142 I=1,ROW_LENGTH BOXSUM1.299
IF(BOX_WEIGHT(I).NE.0.0) THEN BOXSUM1.300
BOXSUM(I,J) = BOXSUM(I,J) / BOX_WEIGHT(I) BOXSUM1.301
ELSE BOXSUM1.302
BOXSUM(I,J) = RMDI BOXSUM1.303
ENDIF BOXSUM1.304
142 CONTINUE BOXSUM1.305
BOXSUM1.306
150 CONTINUE BOXSUM1.307
BOXSUM1.308
RETURN BOXSUM1.309
END BOXSUM1.310
*ENDIF BOXSUM1.311