SUBROUTINE STASH_PROC(NFTPPXREF,NFTSTMSTU ,L_RECONF, 2,20ST_PROC1.7
*IF DEF,RECON ST_PROC1.8
*CALL ARGPPX 
ST_PROC1.9
*ENDIF ST_PROC1.10
*IF -DEF,RECON GSS1F400.654
& ppxRecs, GSS1F400.655
*ENDIF GSS1F400.656
& ErrorStatus,CMESSAGE) ST_PROC1.11
IMPLICIT NONE ST_PROC1.12
ST_PROC1.13
! Description: ST_PROC1.14
! ST_PROC1.15
! Method: ST_PROC1.16
! ST_PROC1.17
! Current code owner: S.J.Swarbrick ST_PROC1.18
! ST_PROC1.19
! History: ST_PROC1.20
! Version Date Comment ST_PROC1.21
! ======= ==== ======= ST_PROC1.22
! 3.5 Mar. 95 Original code. S.J.Swarbrick ST_PROC1.23
! 4.1 Apr. 96 Generalise & incorporate GSS1F401.8
! wave model S.J.Swarbrick GSS1F401.9
! 4.2 28/11/96 MPP code: Initialised new global_LPRIM and GPB1F402.619
! global_LDUMP variables. P.Burton GPB1F402.620
! vn4.4 9/4/97 Null string in argument list in call to GETPPX UIE2F404.28
! padded out to 13 characters (defined as UIE2F404.29
! CHARACTER*13 in GETPPX) to allow NAG f90 compiled UIE2F404.30
! code to run. IEdmond UIE2F404.31
! ST_PROC1.24
! Code description: ST_PROC1.25
! FORTRAN 77 + common Fortran 90 extensions. ST_PROC1.26
! Written to UM programming standards version 7. ST_PROC1.27
! ST_PROC1.28
! System component covered: ST_PROC1.29
! System task: Sub-Models Project ST_PROC1.30
! ST_PROC1.31
! Global variables: ST_PROC1.32
ST_PROC1.33
*CALL LENFIL ST_PROC1.34
*CALL CSUBMODL ST_PROC1.35
*CALL CPPXREF GSS1F401.10
*CALL PPXLOOK GSS1F401.11
*CALL TYPSIZE GSS1F401.12
*CALL MODEL ST_PROC1.37
*CALL CSTASH GRB0F401.14
*CALL STEXTEND ST_PROC1.39
*IF DEF,RECON ST_PROC1.44
*CALL NRECON ST_PROC1.45
*ENDIF ST_PROC1.46
*CALL C_MDI GSS2F401.381
ST_PROC1.47
! Subroutine arguments ST_PROC1.48
ST_PROC1.49
! Scalar arguments with intent(in): ST_PROC1.50
INTEGER NFTPPXREF ! Unit no. for PPXREF file ST_PROC1.51
INTEGER NFTSTMSTU ! Unit no. for user STASH master ST_PROC1.52
LOGICAL L_RECONF ! Not used (but may be some day) GSS2F401.382
ST_PROC1.55
! Array arguments with intent(out): ST_PROC1.56
CHARACTER*(80) CMESSAGE ! Error return message ST_PROC1.57
ST_PROC1.58
! Error status: ST_PROC1.59
INTEGER ErrorStatus ! +ve = fatal error GSS1F400.657
ST_PROC1.61
! Local scalars ST_PROC1.62
INTEGER I,J,L,II GSS2F401.383
INTEGER RI ! Row Index GSS1F400.659
INTEGER Model GSS1F400.660
INTEGER Section GSS1F400.661
INTEGER Item GSS1F400.662
INTEGER RowNumber ! Row no. counter for PPXI, PPXC arrays GSS2F401.384
INTEGER NLEVELS ST_PROC1.67
INTEGER NRECS ST_PROC1.68
INTEGER NTIMES ST_PROC1.70
INTEGER NPROFDP6 ST_PROC1.71
PARAMETER(NPROFDP6=NPROFDP*6) ST_PROC1.72
ST_PROC1.73
! Function and subroutine calls: ST_PROC1.77
EXTERNAL GETPPX,ADDRES,SETMODL ST_PROC1.78
*IF -DEF,RECON ST_PROC1.79
&,PRELIM ,ORDER ,SINDX ,DUPLIC,INACTR,TIMSER, GSS1F400.663
& POINTR ,OUTPTL ,INPUTL,WSTLST,RDBASIS ST_PROC1.81
*ENDIF ST_PROC1.82
ST_PROC1.83
!- End of Header --------------------------------------------------- ST_PROC1.84
ST_PROC1.85
!Initialisation GSS1F400.664
NPSLISTS =0 ! Counter for no. of pseudo levels lists GSS1F400.665
NSERIES =0 ! Time series block counter GSS1F400.666
NSERREC_S =0 ! Total no. of time series records GSS1F400.667
NSERBLK_S =0 ! Total no. of time series blocks GSS1F400.668
ErrorStatus =0 GSS1F400.669
GSS1F400.670
DO I=1,NPROFDP GSS1F400.671
NRECS_TS(I)=0 GSS1F400.672
NPOS_TS(I)=0 GSS1F400.673
END DO GSS1F400.674
ST_PROC1.92
! Initialisation of data length arrays GSS1F401.13
DO I=1,N_SUBMODEL_PARTITION_MAX GSS1F401.14
LPRIM(I)=0 ! LENGTH OF PRIMARY DATA GSS1F401.15
LDUMP(I)=0 ! LENGTH OF DUMP EXTENSION (DIAGNOSTIC) GSS1F401.16
*IF DEF,MPP GPB1F402.621
global_LPRIM(I)=0 ! LENGTH OF global PRIMARY DATA GPB1F402.622
global_LDUMP(I)=0 ! LENGTH OF global DUMP EXTENSION GPB1F402.623
*ENDIF GPB1F402.624
LSECD(I)=0 ! LENGTH OF SECONDARY ATMOS GSS1F401.17
LEXTRA(I)=0 ! LENGTH OF SPACE THAT IS ADDRESSED IN MODEL GSS1F401.18
LWORK(I)=0 ! LENGTH OF WORK GSS1F401.19
NHeadSub(I)=0! No. of pp headers for each submodel GSS1F401.20
END DO GSS1F401.21
DO I=1,N_INTERNAL_MODEL_MAX GSS1F401.22
NHEAD (I)=0 ! NUMBER OF PP HEADERS for each internal model GSS1F401.23
LPrimIM(I)=0 ! Primary data length for each internal model GSS1F401.24
LDumpIM(I)=0 ! Diagnostic do. GSS1F401.25
*IF DEF,MPP GPB1F402.625
global_LPrimIM(I)=0 ! GLOBAL Primary data length for each GPB1F402.626
! ! internal model GPB1F402.627
global_LDumpIM(I)=0 ! GLOBAL Diagnostic do. GPB1F402.628
*ENDIF GPB1F402.629
LSecdIM(I)=0 ! Secondary do. GSS1F401.26
END DO GSS1F401.27
LPRIM_O2=0 ! LENGTH OF PRIMARY DATA OCEAN, SECOND TIME LEVEL GSS1F401.28
ST_PROC1.100
DO I=OUTFILE_S,OUTFILE_E GSS1F401.29
PPlen2LkUp(I)=4096 GSS1F401.30
FTOutUnit (I)=' ' GSS1F401.31
END DO GSS1F401.32
GSS1F401.33
ST_PROC1.108
DO I=1,NPROFDP6 GSS1F401.34
LLISTTY(I)=' ' GSS1F401.35
END DO GSS1F401.36
GSS1F401.37
ST_PROC1.123
DO J=1,NLEVP_S ST_PROC1.124
DO I=1,NLEVLSTSP ST_PROC1.125
RLEVLST_S(J,I)=RMDI GSS2F401.385
LEVLST_S(J,I)=IMDI GSS2F401.386
END DO ST_PROC1.128
END DO ST_PROC1.129
ST_PROC1.130
DO L=1,N_INTERNAL_MODEL_MAX ST_PROC1.131
DO J=0,NSECTP ST_PROC1.132
DO I=1,NITEMP ST_PROC1.133
IN_S(1,L,J,I)=0 ST_PROC1.134
IN_S(2,L,J,I)=0 ST_PROC1.135
INDX_S(1,L,J,I)=0 ST_PROC1.136
INDX_S(2,L,J,I)=0 ST_PROC1.137
END DO ST_PROC1.138
END DO ST_PROC1.139
END DO ST_PROC1.140
ST_PROC1.141
DO J=1,NELEMP+1 ST_PROC1.142
DO I=1,NRECDP ST_PROC1.143
LIST_S(J,I)=0 ST_PROC1.144
END DO ST_PROC1.145
END DO ST_PROC1.146
ST_PROC1.147
DO J=1, NTIMEP ST_PROC1.148
DO I=1,2*NPROFTP+2 ST_PROC1.149
ITIM_S(J,I)=-1 ST_PROC1.150
END DO ST_PROC1.151
END DO ST_PROC1.152
ST_PROC1.153
DO J=1,N_INTERNAL_MODEL_MAX ST_PROC1.154
DO I=1,NITEMP ST_PROC1.155
PPIND_S(J,I)=0 ST_PROC1.156
END DO ST_PROC1.157
END DO ST_PROC1.158
ST_PROC1.159
DO I=1,NPROFDP ST_PROC1.160
NRECS_TS(I)=0 ST_PROC1.161
NPOS_TS(I)=0 ST_PROC1.162
END DO ST_PROC1.163
ST_PROC1.164
DO I=1,NPSLISTP ST_PROC1.165
LENPLST(I)=0 ST_PROC1.166
END DO ST_PROC1.167
ST_PROC1.168
DO I=OUTFILE_S,OUTFILE_E ST_PROC1.169
NHEAD_FILE(I)=0 ST_PROC1.170
END DO ST_PROC1.171
ST_PROC1.172
DO I=1,N_INTERNAL_MODEL_MAX ST_PROC1.173
DO J=0,NSECTP ST_PROC1.174
H_VERS(I,J)=0 ST_PROC1.175
END DO ST_PROC1.176
END DO ST_PROC1.177
GSS2F401.387
DO I=1,MAX_AOBS GSS2F401.388
AOBINC(I)=0 GSS2F401.389
AOBGRP(I)=0 GSS2F401.390
END DO GSS2F401.391
GSS2F401.392
*IF -DEF,RECON GSS1F400.676
! Read stash basis file from job library GSS1F400.677
CALL RDBASIS(4,CMESSAGE,ErrorStatus) GSS2F401.393
! Adjust stash time series records (if any) GSS1F400.679
IF (NSERIES.GT.0) THEN GSS1F400.680
CALL TIMSER(CMESSAGE,ErrorStatus) GSS1F400.681
END IF GSS1F400.682
IF (ErrorStatus .NE. 0) GO TO 9999 GSS1F400.683
*ENDIF GSS1F400.684
ST_PROC1.178
! Read STASHmaster files into look-up arrays PPXI, PPXC GSS2F401.394
ErrorStatus = 0 GSS2F401.395
RowNumber = 0 GSS2F401.396
! Initialise arrays GSS2F401.397
*IF DEF,RECON GSS2F401.398
DO I = 1,NDIAGP GSS2F401.399
*ELSE GSS2F401.400
DO I = 1,ppxRecs GSS2F401.401
*ENDIF GSS2F401.402
DO J = 1,PPXREF_CODELEN GSS2F401.403
PPXI(I,J) = 0 GSS2F401.404
END DO GSS2F401.405
DO J = 1,PPXREF_CHARLEN GSS2F401.406
PPXC(I,J) = ' ' GSS2F401.407
END DO GSS2F401.408
END DO GSS2F401.409
DO I = 1,NDIAGP GSS2F401.410
OriginFlag(I) =' ' GSS2F401.411
RowIndex (I) = 0 GSS2F401.412
END DO GSS2F401.413
*IF DEF,RECON GSS2F401.414
DO II = 1,N_INTERNAL_MODEL_MAX GSS2F401.415
*ELSE GSS2F401.416
DO II = 1,N_INTERNAL_MODEL GSS2F401.417
*ENDIF GSS2F401.418
DO I = 0,PPXREF_SECTIONS GSS2F401.419
DO J = 1,PPXREF_ITEMS GSS2F401.420
PPXPTR(II,I,J) = 0 GSS2F401.421
END DO GSS2F401.422
END DO GSS2F401.423
END DO GSS2F401.424
ST_PROC1.181
IF (INTERNAL_MODEL_INDEX(A_IM).GT.0) THEN GSS2F401.425
CALL GETPPX(NFTPPXREF,NFTSTMSTU,'STASHmaster_A',RowNumber, GSS2F401.426
*CALL ARGPPX GSS2F401.427
& ErrorStatus,CMESSAGE) GSS2F401.428
END IF GSS2F401.429
IF (INTERNAL_MODEL_INDEX(O_IM).GT.0) THEN GSS2F401.430
CALL GETPPX(NFTPPXREF,NFTSTMSTU,'STASHmaster_O',RowNumber, GSS2F401.431
*CALL ARGPPX GSS2F401.432
& ErrorStatus,CMESSAGE) GSS2F401.433
END IF GSS2F401.434
IF (INTERNAL_MODEL_INDEX(S_IM).GT.0) THEN GSS2F401.435
CALL GETPPX(NFTPPXREF,NFTSTMSTU,'STASHmaster_S',RowNumber, GSS2F401.436
*CALL ARGPPX GSS2F401.437
& ErrorStatus,CMESSAGE) GSS2F401.438
END IF GSS2F401.439
IF (INTERNAL_MODEL_INDEX(W_IM).GT.0) THEN GSS2F401.440
CALL GETPPX(NFTPPXREF,NFTSTMSTU,'STASHmaster_W',RowNumber, GSS2F401.441
*CALL ARGPPX GSS2F401.442
& ErrorStatus,CMESSAGE) GSS2F401.443
END IF GSS2F401.444
!Read user STASHmaster files (which may be empty) GSS2F401.445
CALL GETPPX(0,NFTSTMSTU,' ',RowNumber, UIE2F404.32
*CALL ARGPPX ST_PROC1.187
& ErrorStatus,CMESSAGE) ST_PROC1.188
ST_PROC1.189
IF (ErrorStatus .NE. 0) GO TO 9999 ST_PROC1.190
ST_PROC1.191
! Define submodel and section/version configuration ST_PROC1.192
CALL SETMODL(ErrorStatus,CMESSAGE) GSS2F401.447
IF (ErrorStatus .NE. 0) GO TO 9999 GSS2F401.448
ST_PROC1.197
NRECS=0 ST_PROC1.198
NTIMES=0 ST_PROC1.199
NLEVELS=0 ST_PROC1.200
DO I=1,NPSLISTP ST_PROC1.202
LENPLST(I)=0 ST_PROC1.203
END DO ST_PROC1.204
ST_PROC1.205
*IF -DEF,RECON ST_PROC1.206
ST_PROC1.208
! Construct preliminary STASH list GSS2F401.449
CALL PRELIM(NRECS, ST_PROC1.212
*CALL ARGPPX ST_PROC1.213
& NTIMES,NLEVELS,ErrorStatus,CMESSAGE) GSS1F400.685
IF (ErrorStatus.GT.0) GO TO 9999 GSS1F400.686
ST_PROC1.215
! REORDER STASH LIST & SET UP INDEX GSS2F401.450
ST_PROC1.222
CALL ORDER(NRECS) ST_PROC1.223
CALL SINDX(NRECS) ST_PROC1.224
ST_PROC1.225
! DELETE DUPLIC ENTRIES, CONCATONATE OVERLAP LEVELS ETC GSS2F401.451
! DELETE DUPLICATE STASH_TIMES, REORDER GSS2F401.452
ST_PROC1.228
CALL DUPLIC(NRECS,NTIMES,NLEVELS) ST_PROC1.229
ST_PROC1.230
! ADD INACTIVE AND IMPLIED RECORDS GSS2F401.453
ST_PROC1.232
CALL INACTR( ST_PROC1.233
*CALL ARGPPX ST_PROC1.234
& NRECS,ErrorStatus,CMESSAGE) GSS2F401.454
IF (ErrorStatus .NE. 0) GO TO 9999 GSS2F401.455
ST_PROC1.236
! REORDER STASH LIST & SET UP INDEX GSS2F401.456
ST_PROC1.238
CALL ORDER(NRECS) ST_PROC1.239
CALL SINDX(NRECS) ST_PROC1.240
ST_PROC1.241
! CHANGE POINTER SYSTEM, ADD ADDRESSES, LENGTHS AND INPUT LEVELS GSS2F401.457
CALL POINTR(NRECS) ST_PROC1.245
ST_PROC1.246
! OUTPUT LENGTH ST_PROC1.247
CALL OUTPTL( ST_PROC1.248
*CALL ARGPPX ST_PROC1.249
& NRECS,ErrorStatus,CMESSAGE) ST_PROC1.250
IF (ErrorStatus .NE. 0) GO TO 9999 GSS2F401.458
ST_PROC1.251
! INPUT LENGTH AND INPUT LEVELS, SET STLIST(NELEMP+1,I) TO MODEL_ST ST_PROC1.252
! ALSO INPUT PSEUDO LEVELS ST_PROC1.253
CALL INPUTL(NRECS, ST_PROC1.254
*CALL ARGPPX ST_PROC1.255
& NLEVELS,ErrorStatus,CMESSAGE) GSS2F401.459
IF (ErrorStatus .NE. 0) GO TO 9999 GSS2F401.460
ST_PROC1.257
*ENDIF ST_PROC1.259
ST_PROC1.260
! ADDRESSING ST_PROC1.261
CALL ADDRES( GSS1F401.38
*CALL ARGPPX ST_PROC1.263
& NRECS,ErrorStatus,CMESSAGE) GSS2F401.461
IF (ErrorStatus .NE. 0) GO TO 9999 GSS2F401.462
ST_PROC1.265
! SET RETURN VALUES FOR OTHER FILES & write out STASH list GSS2F401.463
ST_PROC1.267
*IF -DEF,RECON ST_PROC1.268
NRECS_S=NRECS ST_PROC1.272
NTIMES_S=NTIMES ST_PROC1.273
NLEVL_S=NLEVELS ST_PROC1.274
ITEM_MAX_ALL=NITEMP ST_PROC1.275
! ITEM_MAX_REQ IS DONE IN WSTLIST ST_PROC1.276
NMAXLEV_S=1 ST_PROC1.277
DO I =1,NLEVELS ST_PROC1.278
NMAXLEV_S=MAX(NMAXLEV_S,LEVLST_S(1,I)) ST_PROC1.279
END DO ST_PROC1.280
ST_PROC1.281
NPSLISTS_S=NPSLISTS ST_PROC1.282
NMAXPSL_S=1 ST_PROC1.283
DO I =1,NPSLISTS ST_PROC1.284
NMAXPSL_S=MAX(NMAXPSL_S,LENPLST(I)) ST_PROC1.285
END DO ST_PROC1.286
! LSTUSER=NUSERD.GE.1 ST_PROC1.287
ST_PROC1.288
! Assign values for STSIZES common block. ST_PROC1.289
! Write output file (for checking purposes). ST_PROC1.290
ST_PROC1.291
CALL WSTLST(NRECS,NTIMES,NLEVELS) GSS1F400.687
*ENDIF ST_PROC1.295
ST_PROC1.296
DO I=1,NUM_DIAG_MAX GSS1F400.688
IF (OriginFlag(I).EQ.'P'.OR.OriginFlag(I).EQ.'U') THEN GSS1F400.689
! Determine model,section,item values for this row GSS1F400.690
RI=RowIndex(I) GSS1F400.691
Model = RI/100000 GSS1F400.692
Section=(RI-(RI/100000)*100000)/1000 GSS1F400.693
Item =(RI-(RI/1000 )*1000 ) GSS1F400.694
IF (IN_S(1,Model,Section,Item) .EQ. 0) THEN GSS1F400.695
! No entry in stash address list - overwrite this entry GSS1F400.696
OriginFlag(I)=' ' GSS1F400.697
END IF GSS1F400.698
END IF GSS1F400.699
END DO GSS1F400.700
DO J=1,NUM_DIAG_MAX GSS1F400.701
IF (Originflag(J).NE.' ') THEN GSS1F400.702
RI=RowIndex(J) GSS1F400.703
Model = RI/100000 GSS1F400.704
Section=(RI-(RI/100000)*100000)/1000 GSS1F400.705
Item =(RI-(RI/1000 )*1000 ) GSS1F400.706
END IF GSS1F400.707
END DO GSS1F400.708
! Close up gaps in OriginFlag array GSS1F400.709
DO I=1,NUM_DIAG_MAX GSS1F400.710
IF (OriginFlag(I).EQ.' ') THEN GSS1F400.711
DO J=I+1,NUM_DIAG_MAX GSS1F400.712
IF (OriginFlag(J).NE.' '.AND. GSS1F400.713
& OriginFlag(I).EQ.' ') THEN GSS1F400.714
OriginFlag(I) = OriginFlag(J) GSS1F400.715
Originflag(J) = ' ' GSS1F400.716
END IF GSS1F400.717
END DO GSS1F400.718
END IF GSS1F400.719
END DO GSS1F400.720
GSS1F400.721
9999 RETURN ST_PROC1.297
END ST_PROC1.298
ST_PROC1.299
!- End of Subroutine Code ---------------------------------------------- ST_PROC1.300
*ENDIF ST_PROC1.301