*IF DEF,C84_1A STEXTC1A.2
C ******************************COPYRIGHT****************************** GTS2F400.9577
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.9578
C GTS2F400.9579
C Use, duplication or disclosure of this code is subject to the GTS2F400.9580
C restrictions as set forth in the contract. GTS2F400.9581
C GTS2F400.9582
C Meteorological Office GTS2F400.9583
C London Road GTS2F400.9584
C BRACKNELL GTS2F400.9585
C Berkshire UK GTS2F400.9586
C RG12 2SZ GTS2F400.9587
C GTS2F400.9588
C If no contract has been raised with this copy of the code, the use, GTS2F400.9589
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.9590
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.9591
C Modelling at the above address. GTS2F400.9592
C ******************************COPYRIGHT****************************** GTS2F400.9593
C GTS2F400.9594
CLL Routine: STEXTC --------------------------------------------------- STEXTC1A.3
CLL STEXTC1A.4
CLL Purpose: Extracts a weighted subfield within a region specified STEXTC1A.5
CLL by a lower left hand and upper right hand corner. STEXTC1A.6
CLL Single level at a time. (STASH service routine). STEXTC1A.7
CLL STEXTC1A.8
CLL Tested under compiler: cft77 STEXTC1A.9
CLL Tested under OS version: UNICOS 5.1 STEXTC1A.10
CLL STEXTC1A.11
CLL Author: T.Johns/S.Tett STEXTC1A.12
CLL STEXTC1A.13
CLL Model Modification history from model version 3.0: STEXTC1A.14
CLL version date STEXTC1A.15
CLL 3.3 16/09/93 Allow level-by-level mass-weighting if mass-weights TJ170993.71
CLL are so defined, otherwise use P*. TJ170993.72
!LL 4.3 06/01/97 Moved weighting and masking calculations up to GPB0F403.143
!LL SPATIAL. P.Burton GPB0F403.144
CLL STEXTC1A.16
CLL Programming standard: UM Doc Paper 3, version 2 (7/9/90) STEXTC1A.17
CLL STEXTC1A.18
CLL Logical components covered: D711 STEXTC1A.19
CLL STEXTC1A.20
CLL Project task: D7 STEXTC1A.21
CLL STEXTC1A.22
CLL External documentation: STEXTC1A.23
CLL Unified Model Doc Paper C4 - Storage handling and diagnostic STEXTC1A.24
CLL system (STASH) STEXTC1A.25
CLL STEXTC1A.26
C*L Interface and arguments: ------------------------------------------ STEXTC1A.27
C STEXTC1A.28
SUBROUTINE STEXTC(fieldin,vx,vy,st_grid,lwrap,lmasswt, 1TJ170993.73
& xstart,ystart,xend,yend, STEXTC1A.30
& fieldout, STEXTC1A.31
& pstar_weight,delta_ak,delta_bk, GPB0F403.145
& area_weight,mask, GPB0F403.146
& row_length,p_rows, GPB0F403.147
& level_code,mask_code,weight_code,rmdi, STEXTC1A.35
& icode,cmessage) STEXTC1A.36
C STEXTC1A.37
IMPLICIT NONE STEXTC1A.38
C STEXTC1A.39
INTEGER STEXTC1A.40
& vx,vy, ! IN input field size STEXTC1A.41
& st_grid, ! IN STASH grdtype code STEXTC1A.42
& xstart,ystart, ! IN lower LH corner STEXTC1A.43
& xend,yend, ! IN upper RH corner STEXTC1A.44
& row_length,p_rows, ! IN primary dimensions GPB0F403.148
& level_code, ! IN input level code STEXTC1A.46
& mask_code, ! IN masking code STEXTC1A.47
& weight_code, ! IN weighting code STEXTC1A.48
& icode ! OUT error return code STEXTC1A.49
CHARACTER*(*) STEXTC1A.50
& cmessage ! OUT error return msg STEXTC1A.51
LOGICAL STEXTC1A.52
& lwrap, ! IN TRUE if wraparound STEXTC1A.53
& lmasswt, ! IN TRUE if masswts OK TJ170993.74
& mask(row_length,p_rows) ! IN mask array GPB0F403.149
REAL STEXTC1A.55
& fieldin(vx,vy), ! IN input field STEXTC1A.56
& fieldout(xstart:xend,ystart:yend), ! OUT output field STEXTC1A.57
& pstar_weight(row_length,p_rows), ! IN pstar mass weight GPB0F403.150
! (already interpolated to the correct grid and GPB0F403.151
! set to 1.0 where no mass weighting is required) GPB0F403.152
& delta_ak, ! IN hybrid coordinates STEXTC1A.60
& delta_bk, ! IN hybrid coordinates STEXTC1A.61
& area_weight(row_length,p_rows), ! IN area weighting GPB0F403.153
! (already interpolated to the correct grid and GPB0F403.154
! set to 1.0 where no area weighting is required) GPB0F403.155
& rmdi ! IN missing data indic STEXTC1A.64
C*---------------------------------------------------------------------- STEXTC1A.65
C STEXTC1A.66
C External subroutines called STEXTC1A.67
C STEXTC1A.68
C STEXTC1A.70
*CALL STPARAM 
STEXTC1A.71
*CALL STERR STEXTC1A.72
*IF DEF,MPP GPB0F403.156
*CALL PARVARS GPB0F403.157
*ENDIF GPB0F403.158
C STEXTC1A.73
C Local variables STEXTC1A.74
C STEXTC1A.75
INTEGER i,j,ii ! ARRAY INDICES FOR VARIABLE STEXTC1A.76
STEXTC1A.77
STEXTC1A.80
CL---------------------------------------------------------------------- STEXTC1A.81
GPB0F403.159
! Calculate the output field, by multiplying the input field by GPB0F403.160
! pstar_weight and area_weight. These arrays contain appropriate GPB0F403.161
! weighting factors, interpolated to the correct grid, for GPB0F403.162
! mass weighting and area weighting respectively. If either type GPB0F403.163
! of weighting is not required, the relevant array is set to 1.0 GPB0F403.164
GPB0F403.165
DO i=xstart,xend GPB0F403.166
*IF -DEF,MPP GPB0F403.167
IF (lwrap) THEN GPB0F403.168
ii=1+MOD(i-1,vx) GPB0F403.169
ELSE GPB0F403.170
ii=i GPB0F403.171
ENDIF GPB0F403.172
*ELSE GPB0F403.173
IF ( lwrap .AND. (i .GT. (lasize(1)-Offx))) THEN GPB0F403.174
ii=i-lasize(1)+2*Offx ! miss halos on wrap around GPB0F403.175
ELSE GPB0F403.176
ii=i GPB0F403.177
ENDIF GPB0F403.178
*ENDIF GPB0F403.179
DO j=ystart,yend GPB0F403.180
IF (mask(ii,j)) THEN GPB0F403.181
IF (.NOT. lmasswt) THEN GPB0F403.182
fieldout(i,j) = GPB0F403.183
& fieldin(ii,j)*pstar_weight(ii,j)*area_weight(ii,j) GPB0F403.184
ELSE GPB0F403.185
fieldout(i,j) = -fieldin(ii,j)* GPB0F403.186
& (delta_ak+delta_bk*pstar_weight(ii,j))* GPB0F403.187
& area_weight(ii,j) GPB0F403.188
ENDIF GPB0F403.189
ELSE STEXTC1A.90
fieldout(i,j)=rmdi GPB0F403.190
ENDIF STEXTC1A.92
ENDDO GPB0F403.191
ENDDO GPB0F403.192
999 CONTINUE STEXTC1A.285
RETURN STEXTC1A.286
END STEXTC1A.287
*ENDIF STEXTC1A.288