SUBROUTINE STOCGT ( 6,5SF011193.48
*CALL ARGPPX 
GKR0F305.814
& ROWS, ROW_LEN, LEVELS, im_ident, submodel, GKR0F305.815
*DATA,STNO,SECTION,LEVEL1,LEVEL2,base_level, SF011193.50
& RMDI,VALUES,IX,IY,IZ,NT_DIM, GKR0F400.355
& SI,JOC_TRACER,JOC_U,JOC_V,O_CFI1, GKR0F305.816
& O_CFI2,O_CFI3,JOC_NO_SEAPTS,JOC_NO_SEGS,ICODE,CMESSAGE) @DYALLOC.3436
STOCGT1.30
IMPLICIT NONE STOCGT1.31
STOCGT1.32
CL Common Blocks STOCGT1.33
STOCGT1.34
*CALL TYPSIZE @DYALLOC.3437
*CALL CSUBMODL GKR0F305.824
*CALL CPPXREF @DYALLOC.3438
*CALL PPXLOOK ! Contains *CALL VERSION GSS1F401.58
STOCGT1.37
INTEGER STOCGT1.38
& ROWS, ! (IN) No of rows GKR0F305.818
& ROW_LEN, ! (IN) No of points per row GKR0F305.819
& LEVELS, ! (IN) No of levels GKR0F305.820
& im_ident, ! (IN) Internal model id GKR0F305.821
& submodel, ! (IN) Submodel id GKR0F305.822
& STNO , !(IN) stash identifier for extracted variable STOCGT1.39
& SECTION, ! (IN) STOCGT1.40
& LEVEL1,LEVEL2 ! (IN) levels between which data is extracted STOCGT1.41
& ,base_level ! (IN) first ocean level diagnosed STOCGT1.42
& ,NT_DIM ! (IN) number of tracers GKR0F400.356
& ,SI(NITEMS,0:NSECTS,N_INTERNAL_MODEL) !STASH IN ADDRESS GGH2F401.4
& ,JOC_TRACER(NT_DIM,2) ! (IN) ocean tracer pointers GKR0F400.357
& ,JOC_U(2),JOC_V(2) ! (IN) ocean pointers @DYALLOC.3442
& ,JOC_NO_SEAPTS,JOC_NO_SEGS @DYALLOC.3443
& ,O_CFI1(O_LEN_CFI1+1) ! (IN) ocean compressed field index @DYALLOC.3444
& ,O_CFI2(O_LEN_CFI2+1),O_CFI3(O_LEN_CFI3+1) @DYALLOC.3445
c STOCGT1.43
INTEGER STOCGT1.44
& IX, ! (OUT) STOCGT1.45
& IY, ! (OUT) STOCGT1.46
& IZ, ! (OUT) STOCGT1.47
& ICODE ! (OUT) STOCGT1.48
STOCGT1.49
REAL STOCGT1.50
& DATA(*), ! (IN) input1-d array of data, possibly compr STOCGT1.51
& RMDI, ! (IN) missing data indicator STOCGT1.52
& VALUES(*) ! (OUT) output array of data for diagnostic STOCGT1.53
STOCGT1.54
CHARACTER*256 STOCGT1.55
& CMESSAGE ! (OUT) Error message if return code >0 STOCGT1.56
STOCGT1.57
CL External subroutines called STOCGT1.58
STOCGT1.59
EXTERNAL STOCGT1.60
& UNPACK STOCGT1.61
c STOCGT1.62
c*-------------------------------------------------------------------- STOCGT1.63
c STOCGT1.64
c Local variables STOCGT1.65
c STOCGT1.66
INTEGER STOCGT1.67
& ROW1, ! 1st row to be extracted from compressed data STOCGT1.68
& ROW2, ! Last " " " " " " " STOCGT1.69
& PT, ! Local pointer to correct position in array D1 STOCGT1.70
& INDEX, ! Local pointer to position in output array valu STOCGT1.71
& JJ,KK,KK1,! Temporary inner loop counters STOCGT1.72
& I,J,K, ! Do loop indices STOCGT1.73
& im_index, ! Internal model index number GGH2F401.3
& GR, ! Local value of PP cross reference grid code STOCGT1.74
& IXDATA ! No of x-points in input data array STOCGT1.75
* ,EXPPXI ! Function to extract ppxref info GKR0F305.823
c STOCGT1.76
CL-------------------------------------------------------------------- STOCGT1.77
C Get internal model index GGH2F401.5
im_index = internal_model_index(im_ident) GGH2F401.6
CL Check input values for validity STOCGT1.78
c STOCGT1.79
c Check levels STOCGT1.80
c STOCGT1.81
IF (LEVEL1.GT.LEVEL2) THEN STOCGT1.82
ICODE=3 STOCGT1.83
CMESSAGE='STOCGT : Incorrect levels: level1 > level2' STOCGT1.84
GOTO 999 STOCGT1.85
ENDIF STOCGT1.86
c STOCGT1.87
IF (LEVEL1.LT.1) THEN STOCGT1.88
ICODE=3 STOCGT1.89
CMESSAGE='STOCGT : Incorrect levels: level1 < 1' STOCGT1.90
GOTO 999 STOCGT1.91
ENDIF STOCGT1.92
c STOCGT1.93
IF (LEVEL1.GT.LEVELS) THEN GKR0F305.827
ICODE=3 STOCGT1.95
CMESSAGE='STOCGT : Incorrect levels: level1 > LEVELS' GKR0F305.828
GOTO 999 STOCGT1.97
ENDIF STOCGT1.98
c STOCGT1.99
IF (LEVEL2.LT.1) THEN STOCGT1.100
ICODE=3 STOCGT1.101
CMESSAGE='STOCGT : Incorrect levels: level2 < 1' STOCGT1.102
GOTO 999 STOCGT1.103
ENDIF STOCGT1.104
c STOCGT1.105
IF (LEVEL2.GT.LEVELS) THEN GKR0F305.829
ICODE=3 STOCGT1.107
CMESSAGE='STOCGT : Incorrect levels: level2 > LEVELS' GKR0F305.830
GOTO 999 STOCGT1.109
ENDIF STOCGT1.110
c STOCGT1.111
c Check STASH identifier STOCGT1.112
c STOCGT1.113
IF ( im_ident .NE.OCEAN_IM) THEN GKR0F305.831
ICODE=1 STOCGT1.115
CMESSAGE='STOCGT : Invalid SUB-MODEL' RH221193.5
GOTO 999 STOCGT1.117
ENDIF STOCGT1.118
CL---------------------------------------------------------------------- STOCGT1.138
CL Calculate IX,IY,IZ - the output field dimensions, and STOCGT1.139
CL IXDATA - the input field x-dimension STOCGT1.140
c STOCGT1.141
c Look up local PP cross reference STOCGT1.142
c STOCGT1.143
GR = EXPPXI(im_ident, section, stno, ppx_grid_type, GKR0F305.832
*CALL ARGPPX GKR0F305.833
& icode, cmessage) GKR0F305.834
c STOCGT1.151
c Extract all physical points - number depends on EW bdry condition STOCGT1.152
c and the input grid type STOCGT1.153
c STOCGT1.154
IF (CYCLIC_OCEAN) THEN ! CYCLIC_OCEAN is set by user interface STOCGT1.155
IF ((GR.EQ.ppx_ocn_tfield).OR.(GR.EQ.ppx_ocn_ufield) STOCGT1.156
& .OR.(GR.EQ.ppx_ocn_tmerid).OR.(GR.EQ.ppx_ocn_umerid)) THEN STOCGT1.157
IXDATA=IMTM2 STOCGT1.158
IX=IMTM2 STOCGT1.159
ELSEIF ((GR.EQ.ppx_ocn_tzonal).OR.(GR.EQ.ppx_ocn_uzonal) STOCGT1.160
& .OR.(GR.EQ.ppx_ocn_scalar)) THEN STOCGT1.161
IXDATA=1 STOCGT1.162
IX=1 STOCGT1.163
ELSE STOCGT1.164
IXDATA=IMTM2 +2 ORH5F400.37
IX=IMTM2 STOCGT1.166
ENDIF STOCGT1.167
ELSE STOCGT1.168
IF ((GR.EQ.ppx_ocn_tzonal).OR.(GR.EQ.ppx_ocn_uzonal) STOCGT1.169
& .OR.(GR.EQ.ppx_ocn_scalar)) THEN STOCGT1.170
IXDATA=1 STOCGT1.171
IX=1 STOCGT1.172
ELSE STOCGT1.173
IXDATA=ROW_LEN GKR0F305.836
IX=ROW_LEN GKR0F305.837
ENDIF STOCGT1.176
ENDIF STOCGT1.177
c STOCGT1.178
c Remove row ROWS at U,V points in output field GKR0F305.838
c STOCGT1.180
IF ((GR.EQ.ppx_ocn_uall) STOCGT1.181
& .OR.(GR.EQ.ppx_ocn_ucomp) STOCGT1.182
& .OR.(GR.EQ.ppx_ocn_ufield) STOCGT1.183
& .OR.(GR.EQ.ppx_ocn_uzonal)) THEN STOCGT1.184
*IF DEF,MPP ORH5F403.1
IY = ROWS ORH5F403.2
*ELSE ORH5F403.3
IY = ROWS - 1 ORH5F403.4
*ENDIF ORH5F403.5
ELSEIF ((GR.EQ.ppx_ocn_tmerid).OR.(GR.EQ.ppx_ocn_umerid) STOCGT1.186
& .OR.(GR.EQ.ppx_ocn_scalar)) THEN STOCGT1.187
IY=1 STOCGT1.188
ELSE STOCGT1.189
IY=ROWS GKR0F305.840
ENDIF STOCGT1.191
c STOCGT1.192
IZ=LEVEL2-LEVEL1+1 STOCGT1.193
c STOCGT1.194
CL---------------------------------------------------------------------- STOCGT1.195
CL Set pointer to stash address OSI0F402.148
OSI0F402.149
IF (STNO.GE.101.AND.STNO.LE.122) THEN OSI0F402.150
OSI0F402.151
C For all dual time level variables, except climate mean sections, OSI0F402.152
C select 'update' level (joc_variable(2)). OSI0F402.153
OSI0F402.154
IF (SECTION.GE.41.AND.SECTION.LE.44) THEN OSI0F402.155
PT = SI(STNO,SECTION,im_index) OSI0F402.156
ELSE OSI0F402.157
IF (STNO.GE.101.AND.STNO.LE.120) THEN ! tracers OSI0F402.158
PT = JOC_TRACER(STNO-100,2) OSI0F402.159
ELSE IF (STNO.EQ.121) THEN ! zonal velocity OSI0F402.160
PT = JOC_U(2) OSI0F402.161
ELSE IF (STNO.EQ.122) THEN ! meridional velocity OSI0F402.162
PT = JOC_V(2) OSI0F402.163
ENDIF OSI0F402.164
ENDIF OSI0F402.165
OSI0F402.166
ELSE OSI0F402.167
OSI0F402.168
PT = SI(STNO,SECTION,im_index) OSI0F402.169
OSI0F402.170
ENDIF OSI0F402.171
OSI0F402.172
CL---------------------------------------------------------------------- OSI0F402.173
CL Extract data STOCGT1.196
c STOCGT1.197
c STOCGT1.198
IF (GR.EQ.ppx_ocn_tcomp) THEN STOCGT1.199
c Extract tracers. STOCGT1.200
c Need to access 3d primary data, using UNPACK to expand from STOCGT1.201
c compressed form STOCGT1.202
c Extract all rows STOCGT1.203
ROW1=1 STOCGT1.204
ROW2=IY STOCGT1.205
*IF DEF,MPP ORH4F403.2
CALL OD12SLAB(1,IMT,ROW1,ROW2,1,KM,IMT,1,KM,IMT,JMT,KM, ORH4F403.3
& DATA(PT),VALUES) ORH4F403.4
*ELSE ORH4F403.5
OSI0F402.174
CALL UNPACK(ROW1,ROW2,LEVEL1,LEVEL2,ROWS,LEVELS, GKR0F305.841
& IX,IY,IZ,O_CFI1,O_CFI2,joc_no_segs,O_CFI3, STOCGT1.212
& joc_no_seapts,DATA(PT),VALUES,RMDI,.FALSE.) STOCGT1.213
*ENDIF ORH4F403.6
ELSE IF (GR.EQ.ppx_ocn_ucomp) THEN STOCGT1.214
c Extract velocities STOCGT1.215
c Extract all rows STOCGT1.216
ROW1=1 STOCGT1.217
ROW2=IY STOCGT1.218
c STOCGT1.219
*IF DEF,MPP ORH4F403.7
CALL OD12SLAB(1,IMT,ROW1,ROW2,1,KM,IMT,1,KM,IMT,JMT,KM, ORH4F403.8
& DATA(PT),VALUES) ORH4F403.9
*ELSE ORH4F403.10
CALL UNPACK(ROW1,ROW2,LEVEL1,LEVEL2,ROWS,LEVELS, GKR0F305.842
& IX,IY,IZ,O_CFI1,O_CFI2,joc_no_segs,O_CFI3, STOCGT1.239
& joc_no_seapts,DATA(PT),VALUES,RMDI,.FALSE.) STOCGT1.240
c STOCGT1.241
*ENDIF ORH4F403.11
ELSE IF((GR.EQ.ppx_ocn_tall).OR.(GR.EQ.ppx_ocn_uall).OR. STOCGT1.242
& (GR.EQ.ppx_ocn_tfield).OR.(GR.EQ.ppx_ocn_ufield) .OR. STOCGT1.243
& (GR.EQ.ppx_ocn_tzonal).OR.(GR.EQ.ppx_ocn_uzonal) .OR. STOCGT1.244
& (GR.EQ.ppx_ocn_tmerid).OR.(GR.EQ.ppx_ocn_umerid) .OR. STOCGT1.245
& (GR.EQ.ppx_ocn_scalar)) THEN STOCGT1.246
c Extract uncompressed data, excluding cyclic points if present STOCGT1.247
c in input field STOCGT1.248
DO K=1,IZ STOCGT1.249
KK=(K-1)*IX*IY STOCGT1.250
KK1=(K-1)*IXDATA*IY+(LEVEL1-base_level)*IXDATA*IY STOCGT1.251
DO J=1,IY STOCGT1.252
JJ=(J-1)*IXDATA STOCGT1.253
INDEX=KK+(J-1)*IX STOCGT1.254
DO I=1,IX STOCGT1.255
INDEX=INDEX+1 STOCGT1.256
VALUES(INDEX)=DATA(PT+(I-1)+JJ+KK1) OSI0F402.175
ENDDO STOCGT1.259
ENDDO STOCGT1.260
ENDDO STOCGT1.261
ELSE STOCGT1.262
ICODE=1 STOCGT1.263
CMESSAGE='STOCGT : Unrecognised grid type' STOCGT1.264
GOTO 999 STOCGT1.265
ENDIF STOCGT1.266
c STOCGT1.267
ICODE=0 STOCGT1.268
CMESSAGE='Normal Exit' STOCGT1.269
c STOCGT1.270
999 CONTINUE STOCGT1.271
RETURN STOCGT1.272
END STOCGT1.273
*ENDIF STOCGT1.274