*IF DEF,C84_1A STCOMG1A.2
C ******************************COPYRIGHT****************************** GTS2F400.9559
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.9560
C GTS2F400.9561
C Use, duplication or disclosure of this code is subject to the GTS2F400.9562
C restrictions as set forth in the contract. GTS2F400.9563
C GTS2F400.9564
C Meteorological Office GTS2F400.9565
C London Road GTS2F400.9566
C BRACKNELL GTS2F400.9567
C Berkshire UK GTS2F400.9568
C RG12 2SZ GTS2F400.9569
C GTS2F400.9570
C If no contract has been raised with this copy of the code, the use, GTS2F400.9571
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.9572
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.9573
C Modelling at the above address. GTS2F400.9574
C ******************************COPYRIGHT****************************** GTS2F400.9575
C GTS2F400.9576
CLL SUBROUTINE STASH_COMP_GRID---------------------- STCOMG1A.3
CLL STCOMG1A.4
CLL Compute grid descriptors STCOMG1A.5
CLL out_bdx,out_bdy,out_bzx and out_bzy from inputs STCOMG1A.6
CLL 1) samples STCOMG1A.7
CLL 2) grid type code STCOMG1A.8
CLL 3) ocean (true if an ocean grid) STCOMG1A.9
CLL 4) real and integer headers STCOMG1A.10
CLL 5) w_mostcol and n_mostrow STCOMG1A.11
CLL 6) processing code STCOMG1A.12
CLL STCOMG1A.13
CLL Tested under compiler CFT77 STCOMG1A.14
CLL Tested under OS version 6.1 STCOMG1A.15
CLL STCOMG1A.16
CLL Author Simon Tett (Based on code in pp_head by Tim Johns) STCOMG1A.17
CLL STCOMG1A.18
CLL Model Modification history from model version 3.0: STCOMG1A.19
CLL version date STCOMG1A.20
CLL STCOMG1A.21
CLL Logical components covered: D40 STCOMG1A.22
CLL STCOMG1A.23
CLL Project TASK: C4 STCOMG1A.24
CLL STCOMG1A.25
CLL Programming standard: U M DOC Paper NO. 4, STCOMG1A.26
CLL STCOMG1A.27
CLL External documentation C4 STCOMG1A.28
CLL STCOMG1A.29
CLLEND------------------------------------------------------------- STCOMG1A.30
STCOMG1A.31
C STCOMG1A.32
C*L INTERFACE and ARGUMENTS:------------------------------------------ STCOMG1A.33
SUBROUTINE STASH_COMP_GRID( 1STCOMG1A.34
1 out_bzx,out_bzy,out_bdx,out_bdy, STCOMG1A.35
2 samples,st_grid,ocean, STCOMG1A.36
3 w_mostcol,n_mostrow, STCOMG1A.37
4 realhd,len_realhd,inthd,len_inthd,gr, STCOMG1A.38
5 ICODE,CMESSAGE) STCOMG1A.39
C STCOMG1A.40
IMPLICIT NONE STCOMG1A.41
STCOMG1A.42
STCOMG1A.43
C STCOMG1A.44
LOGICAL OCEAN !IN TRUE if processing an ocean diagnostic STCOMG1A.45
C STCOMG1A.46
INTEGER samples ! IN no of samples in period (times STCOMG1A.47
C STCOMG1A.48
INTEGER STCOMG1A.49
* ICODE !OUT Return code from the routine STCOMG1A.50
*, LEN_REALHD !IN Length of the Real Constants STCOMG1A.51
*, LEN_INTHD !IN Length of integer constants STCOMG1A.52
*, INTHD(LEN_INTHD) !IN Integer constants STCOMG1A.53
C STCOMG1A.54
INTEGER STCOMG1A.55
* st_grid !IN STASH horizontal grid type STCOMG1A.56
*, N_MOSTROW !IN The most nrthrly row. STCOMG1A.57
*, W_MOSTCOL !IN The most westerly column STCOMG1A.58
*, gr !IN The type of processing done STCOMG1A.59
C STCOMG1A.60
REAL STCOMG1A.61
* REALHD(LEN_REALHD) !IN Real header STCOMG1A.62
REAL STCOMG1A.63
* out_bzx,out_bdx,out_bzy,out_bdy ! OUT grid descriptors STCOMG1A.64
CHARACTER*(*) STCOMG1A.65
* cmessage ! OUT error messages STCOMG1A.66
C* STCOMG1A.67
C STCOMG1A.68
CL Local Variables STCOMG1A.69
C STCOMG1A.70
INTEGER mean_code STCOMG1A.71
C STCOMG1A.72
C*--------------------------------------------------------------------- STCOMG1A.73
*CALL CLOOKADD 
STCOMG1A.74
*CALL STPARAM STCOMG1A.75
*CALL CPPXREF STCOMG1A.76
C*L WORKSPACE USAGE:------------------------------------------------- STCOMG1A.77
C DEFINE LOCAL WORKSPACE ARRAYS: None STCOMG1A.78
C STCOMG1A.79
C*--------------------------------------------------------------------- STCOMG1A.80
C STCOMG1A.81
CLL Construct PP header STCOMG1A.82
IF (samples.GT.0) THEN ! Indicates a timeseries/trajectory STCOMG1A.83
OUT_BZX=0.0 STCOMG1A.84
OUT_BDX=0.0 STCOMG1A.85
OUT_BZY=0.0 STCOMG1A.86
OUT_BDY=0.0 STCOMG1A.87
ELSE STCOMG1A.88
IF (OCEAN) THEN ! set OUT_BZY,OUT_BZX,OUT_BDY,OUT_BDX fo STCOMG1A.89
IF (st_grid.EQ.st_uv_grid) THEN STCOMG1A.90
OUT_BZY=REALHD(3)-REALHD(2)/2.0 STCOMG1A.91
OUT_BZX=REALHD(4)-REALHD(1)/2.0 STCOMG1A.92
ELSEIF (st_grid.EQ.st_tp_grid) THEN STCOMG1A.93
OUT_BZY=REALHD(3)-REALHD(2) STCOMG1A.94
OUT_BZX=REALHD(4)-REALHD(1) STCOMG1A.95
ELSEIF (st_grid.EQ.st_cu_grid) THEN STCOMG1A.96
OUT_BZY=REALHD(3)-REALHD(2) STCOMG1A.97
OUT_BZX=REALHD(4)-REALHD(1)/2.0 STCOMG1A.98
ELSEIF (st_grid.EQ.st_cv_grid) THEN STCOMG1A.99
OUT_BZY=REALHD(3)-REALHD(2)/2.0 STCOMG1A.100
OUT_BZX=REALHD(4)-REALHD(1) STCOMG1A.101
ENDIF STCOMG1A.102
IF (REALHD(32).GT.REALHD(29)) THEN ! greater than RMDI STCOMG1A.103
OUT_BDY=0.0 STCOMG1A.104
OUT_BDX=REALHD(32) STCOMG1A.105
ELSE STCOMG1A.106
OUT_BDY=REALHD(2) STCOMG1A.107
OUT_BDX=REALHD(1) STCOMG1A.108
ENDIF STCOMG1A.109
ELSE ! set OUT_BZY,OUT_BZX,OUT_BDY,OUT_BDX for STCOMG1A.110
IF(st_grid.EQ.st_uv_grid.OR.st_grid.EQ.st_cv_grid) THEN STCOMG1A.111
OUT_BZY=REALHD(3)+REALHD(2)/2.0 ! UV pts STCOMG1A.112
ELSE STCOMG1A.113
OUT_BZY=REALHD(3)+REALHD(2) ! Zeroth Lat OUT_BZY STCOMG1A.114
ENDIF STCOMG1A.115
C STCOMG1A.116
IF(st_grid.EQ.st_uv_grid.OR.st_grid.EQ.st_cu_grid) THEN STCOMG1A.117
OUT_BZX=REALHD(4)-REALHD(1)/2.0 !UV points STCOMG1A.118
ELSE STCOMG1A.119
OUT_BZX=REALHD(4)-REALHD(1) ! Zeroth Long OUT_BZX STCOMG1A.120
ENDIF STCOMG1A.121
OUT_BDX=REALHD(1) ! Long intvl OUT_BDX STCOMG1A.122
OUT_BDY=-REALHD(2) ! Lat intvl OUT_BDY STCOMG1A.123
ENDIF STCOMG1A.124
C STCOMG1A.125
C Add on offset for fields not starting from the origin STCOMG1A.126
C STCOMG1A.127
OUT_BZY=OUT_BZY STCOMG1A.128
& +(N_MOSTROW-1)*OUT_BDY STCOMG1A.129
OUT_BZX=OUT_BZX STCOMG1A.130
& +(W_MOSTCOL-1)*OUT_BDX STCOMG1A.131
IF(OUT_BZX.GE.360.0) STCOMG1A.132
* OUT_BZX=OUT_BZX-360.0 STCOMG1A.133
C STCOMG1A.134
C If horizontal averaging has been applied to the output field, STCOMG1A.135
C set OUT_BDX and/or OUT_BDY to the full domain extent STCOMG1A.136
C STCOMG1A.137
mean_code=(GR/block_size)*block_size STCOMG1A.138
IF (mean_code.EQ.zonal_mean_base .OR. STCOMG1A.139
& mean_code.EQ.field_mean_base .OR. STCOMG1A.140
& mean_code.EQ.global_mean_base) THEN STCOMG1A.141
OUT_BDX=REAL(INTHD(6))*REALHD(1) STCOMG1A.142
ENDIF STCOMG1A.143
IF (mean_code.EQ.merid_mean_base .OR. STCOMG1A.144
& mean_code.EQ.field_mean_base .OR. STCOMG1A.145
& mean_code.EQ.global_mean_base) THEN STCOMG1A.146
OUT_BDY=REAL(INTHD(7))*REALHD(2) STCOMG1A.147
ENDIF STCOMG1A.148
ENDIF STCOMG1A.149
C STCOMG1A.150
999 CONTINUE STCOMG1A.151
RETURN STCOMG1A.152
END STCOMG1A.153
*ENDIF STCOMG1A.154