SUBROUTINE GETPPX(NFTPPXREF,NFTSTMSTU,StmsrNam,RowNumber, 56,8GSS2F401.110
*CALL ARGPPX 
GETPPX1.8
& ErrorStatus,CMESSAGE) GSS1F400.23
IMPLICIT NONE GETPPX1.10
! GETPPX1.11
! Description: GETPPX1.12
! Reads records from PPXREF file into arrays PPXI (for integer data) GETPPX1.13
! and PPXC (for character data, i.e. name of diagnostic/prognostic). GETPPX1.14
! The entire PPXREF file is read in (non-null records only). GETPPX1.15
! GETPPX1.16
! Method: GETPPX1.17
! Uses routines SETPOS and BUFFIN - these employ Cray-specific code GETPPX1.18
! GETPPX1.19
! Current code owner: S.J.Swarbrick GETPPX1.20
! GETPPX1.21
! History: GETPPX1.22
! Version Date Comment GETPPX1.23
! ======= ==== ======= GETPPX1.24
! 3.5 Mar 95 Original code. S.J.Swarbrick GETPPX1.25
! 4.0 Oct. 95 S.J.Swarbrick GSS1F400.24
! 4.0 15/12/95 Changed interface to READSTM so that GSS1F400.25
! Internal_Model_Number is specified directly GSS1F400.26
! rather than using CODES(1). P.Burton GSS1F400.27
! 4.0 Dec. 95 Check for ppxRecs LE (NDIAGP or NUM_DIAG_MAX) ANF4F400.1
! (N Farnon) ANF4F400.2
! 4.1 Apr. 96 Correct OOB error when reading user STASH & GSS1F401.3
! changes associated with new STASHmaster format GSS1F401.4
! S.J.Swarbrick GSS1F401.5
! 4.1 18/06/96 Changes to cope with changes in STASH addressing GDG0F401.632
! Author D.M. Goddard. GDG0F401.633
! 4.2 Jan. 97 Correct record-counting bug in PPX arrays GSS1F403.26
! S.J.Swarbrick GSS1F403.27
! 4.4 04/11/97 Changed -RECON def line to allow for other small UIE3F404.14
! execs which had used the RECON def. K Rogers UIE3F404.15
! 4.5 30/10/97 Read stash data on PE 0 for the T3E GBCVF405.323
! and distribute it. GBCVF405.324
! Author: Bob Carruthers, Cray Research GBCVF405.325
! GETPPX1.26
! Code description: GETPPX1.27
! FORTRAN 77 + common Fortran 90 extensions. GETPPX1.28
! Written to UM programming standards version 7. GETPPX1.29
! GETPPX1.30
! System component covered: GETPPX1.31
! System task: Sub-Models Project GETPPX1.32
! GETPPX1.33
! Global Variables: GETPPX1.34
GETPPX1.35
*CALL CSUBMODL GETPPX1.36
*CALL CPPXREF GETPPX1.37
*CALL PPXLOOK GETPPX1.39
*CALL C_MDI GETPPX1.40
*CALL CSTASH GRB0F401.22
GETPPX1.42
! Subroutine arguments GETPPX1.43
GETPPX1.44
! Scalar arguments with intent(in): GETPPX1.45
INTEGER NFTPPXREF ! Unit no. for PPXREF file GETPPX1.46
INTEGER NFTSTMSTU ! Unit no. for user ppxref files GSS1F400.28
CHARACTER*13 StmsrNam ! Names of stash master files GSS2F401.111
GETPPX1.48
! Array arguments with intent(out): GETPPX1.49
CHARACTER*80 CMESSAGE ! Error return message GETPPX1.50
GETPPX1.51
! Error status: GETPPX1.52
INTEGER ErrorStatus ! Error return code GSS1F400.29
GETPPX1.54
! Local scalars: GETPPX1.55
INTEGER I,J,IE,ID,II ! Loop counters GSS1F400.30
INTEGER hashcount GSS2F401.112
INTEGER IFIL,IREC ! Do. GSS1F400.31
INTEGER LEN_IO ! No. words read on each CALL BUFFIN GETPPX1.59
REAL STATUS ! Error return code from BUFFIN GETPPX1.60
INTEGER IOSTATUS GSS1F400.32
CHARACTER*80 UpsmFile ! Full pathname for user psm files GSS1F400.33
CHARACTER*80 STASH_MSTR ! Do. STASH master files GSS2F401.113
CHARACTER*1 CHAR1 GSS2F401.114
INTEGER Im_index ! GSS1F400.34
INTEGER Im_ident ! GSS1F400.35
INTEGER Section ! GSS1F400.36
INTEGER Item ! GSS1F400.37
INTEGER LModel ,DM GSS1F400.38
INTEGER LSection,DS GSS1F400.39
INTEGER LItem ,DI GSS1F400.40
INTEGER USTrow GSS1F400.41
INTEGER RowNumber ! Row no. counter for PPXI, PPXC arrays GETPPX1.65
INTEGER FirstBlank ! Used to append Upsm file name to dir GSS1F400.42
INTEGER RI ! Row index GSS1F400.44
INTEGER NU_recs ! No. of records in a user psm file GSS1F400.45
LOGICAL OVERWRITE ! Set T if a system stash master record GSS1F403.28
! is being overwritten by a user rec. GSS1F403.29
! Local arrays: GETPPX1.67
! WARNING: must have PPXREF_CHARLEN=4*PPX_CHARWORD GETPPX1.68
! to avoid overwriting GETPPX1.69
CHARACTER DNAM (PPXREF_CHARLEN) ! For character part of ppx rec GETPPX1.70
INTEGER CODES(PPXREF_CODELEN) ! For integer part of ppx record GETPPX1.71
INTEGER IMASK(20) ! For ver mask in user psm GSS1F400.46
*IF DEF,MPP,AND,DEF,T3E GBCVF405.326
GBCVF405.327
common/shmem_getppx_c1/ dnam GBCVF405.328
cdir$ cache_align /shmem_getppx_c1/ GBCVF405.329
common/shmem_getppx_c2/ char1 GBCVF405.330
cdir$ cache_align /shmem_getppx_c2/ GBCVF405.331
common/shmem_getppx/ codes, iostatus, nu_recs GBCVF405.332
cdir$ cache_align /shmem_getppx/ GBCVF405.333
c GBCVF405.334
integer shmem_n_pes, msg, info, nproc, shmem_my_pe, mype GBCVF405.335
c GBCVF405.336
*ENDIF GBCVF405.337
GETPPX1.72
! Function and subroutine calls: GETPPX1.73
EXTERNAL READSTM GSS2F401.116
! GETPPX1.75
!- End of header ------------------------------------------------------- GETPPX1.76
! GETPPX1.77
ErrorStatus = 0 GSS1F400.48
NU_recs = 0 GSS1F400.49
IOStatus =0 GSS2F401.115
!---------------------------------------------------------------------- GSS2F401.117
! Check that the no. of requested diagnostics does not exceed max GSS2F401.118
! defined in comdecks VERSION and PPXLOOK. GSS2F401.119
! GSS2F401.120
IF ( (ppxRecs .GT. NDIAGP) .OR. (ppxRecs .GT. NUM_DIAG_MAX) ) ANF4F400.7
&THEN ANF4F400.8
WRITE(6,*) 'ERROR: no. of diags. requested exceeds max' GSS2F401.121
WRITE(6,*) 'ppxRecs=',ppxRecs,' NDIAGP=',NDIAGP, ANF4F400.10
& ' NUM_DIAG_MAX=',NUM_DIAG_MAX ANF4F400.11
Errorstatus=104 ANF4F400.12
CMESSAGE= 'GETPPX: ppxRecs GT (NDIAGP or NUM_DIAG_MAX)' GSS2F401.122
GO TO 9999 ANF4F400.14
END IF ANF4F400.15
!---------------------------------------------------------------------- GSS2F401.123
GSS2F401.124
*IF DEF,MPP,AND,DEF,T3E GBCVF405.338
mype=shmem_my_pe() GBCVF405.339
nproc=shmem_n_pes() GBCVF405.340
*ENDIF GBCVF405.341
IF (NFTPPXREF.EQ.22) THEN GSS2F401.125
!---------------------------------------------------------------------- GSS2F401.126
!Read in records from STASHmaster for current internal model GSS2F401.127
!---------------------------------------------------------------------- GSS2F401.128
!Open STASHmaster file for current internal model GSS2F401.129
! Get directory name for STASHmaster & append rest of filename GSS2F401.130
*IF DEF,MPP,AND,DEF,T3E GBCVF405.342
stash_mstr='empty ' GBCVF405.343
if(mype.eq.0) CALL GET_FILE(NFTPPXREF,STASH_MSTR,80, GBCVF405.344
2 ErrorStatus) GBCVF405.345
*ELSE GBCVF405.346
CALL GET_FILE(NFTPPXREF,STASH_MSTR,80,ErrorStatus) GSS2F401.131
*ENDIF GBCVF405.347
FirstBlank = 0 GSS2F401.132
DO I = 1,80 GSS2F401.133
IF (STASH_MSTR(I:I).EQ.' '.AND.FirstBlank.EQ.0) GSS2F401.134
& FirstBlank=I GSS2F401.135
END DO GSS2F401.136
STASH_MSTR(FirstBlank:FirstBlank)='/' GSS2F401.137
STASH_MSTR(FirstBlank+1:FirstBlank+13)=StmsrNam GSS2F401.138
*IF DEF,MPP,AND,DEF,T3E GBCVF405.348
if(mype.eq.0) OPEN(UNIT=NFTPPXREF,FILE=STASH_MSTR, GBCVF405.349
2 IOSTAT=IOStatus) GBCVF405.350
GBCVF405.351
msg=7030 GBCVF405.352
info=0 GBCVF405.353
call gc_ibcast(msg, 1, 0, nproc, info, IOStatus) GBCVF405.354
GBCVF405.355
*ELSE GBCVF405.356
OPEN(UNIT=NFTPPXREF,FILE=STASH_MSTR,IOSTAT=IOStatus) GSS2F401.139
*ENDIF GBCVF405.357
IF(IOStatus.NE.0) THEN GSS2F401.140
WRITE(6,*) 'ERROR in routine GETPPX' GSS2F401.141
WRITE(6,*) GSS2F401.142
& 'CANNOT OPEN STASHmaster FILE, IOSTATUS=',IOStatus GSS2F401.143
WRITE(6,*) 'UNIT=',NFTPPXREF,' FILE=',STASH_MSTR GSS2F401.144
ErrorStatus=100 GSS2F401.145
CMESSAGE=' GETPPX: ERROR OPENING STASHmaster' GSS2F401.146
GOTO 9999 GSS2F401.147
END IF GSS2F401.148
GETPPX1.94
GETPPX1.98
*IF DEF,MPP,AND,DEF,T3E GBCVF405.358
100 continue GBCVF405.359
if(mype.eq.0) READ(NFTPPXREF,'(A1)') CHAR1 GBCVF405.360
c GBCVF405.361
msg=7033 GBCVF405.362
info=0 GBCVF405.363
call gc_cbcast(msg, 1, 0, nproc, info, char1) GBCVF405.364
c GBCVF405.365
*ELSE GBCVF405.366
100 READ(NFTPPXREF,'(A1)') CHAR1 GSS2F401.149
*ENDIF GBCVF405.367
IF (CHAR1.EQ.'1') THEN GSS2F401.150
!Read block of records GSS2F401.151
*IF DEF,MPP,AND,DEF,T3E GBCVF405.368
if(mype.eq.0) then GBCVF405.369
BACKSPACE NFTPPXREF GBCVF405.370
CALL READSTM(IMASK,DNAM,CODES,NFTPPXREF, GBCVF405.371
2 ErrorStatus,CMESSAGE) GBCVF405.372
endif GBCVF405.373
GBCVF405.374
msg=7031 GBCVF405.375
info=0 GBCVF405.376
call gc_ibcast(msg, ppxref_codelen, 0, nproc, info, codes) GBCVF405.377
msg=7032 GBCVF405.378
info=0 GBCVF405.379
call gc_cbcast(msg, ppxref_charlen, 0, nproc, info, dnam) GBCVF405.380
*ELSE GBCVF405.381
BACKSPACE NFTPPXREF GSS2F401.152
CALL READSTM(IMASK,DNAM,CODES,NFTPPXREF,ErrorStatus,CMESSAGE) GSS2F401.153
*ENDIF GBCVF405.382
Im_ident = CODES(ppx_model_number) GSS2F401.154
Section = CODES(ppx_section_number) GSS2F401.155
Item = CODES(ppx_item_number) GSS2F401.156
IF (Im_ident.EQ.-1) THEN GSS2F401.157
!End of file reached GSS2F401.158
*IF DEF,MPP,AND,DEF,T3E GBCVF405.383
if(mype.eq.0) CLOSE(UNIT=NFTPPXREF) GBCVF405.384
*ELSE GBCVF405.385
CLOSE(UNIT=NFTPPXREF) GSS2F401.159
*ENDIF GBCVF405.386
GO TO 9999 GSS1F400.65
END IF GSS1F400.66
Im_index= INTERNAL_MODEL_INDEX(Im_ident) GSS2F401.160
! Increment row number GSS2F401.161
RowNumber = RowNumber + 1 GSS2F401.162
! Assign value to PPXPTR element corresponding to this record GETPPX1.117
*IF DEF,RECON GSS1F400.67
PPXPTR(Im_ident,Section,Item) = RowNumber GSS2F401.163
*ELSE GSS1F400.69
PPXPTR(Im_index,Section,Item) = RowNumber GSS2F401.164
*ENDIF GSS1F400.71
! Transfer data from ppx record to look-up arrays GSS2F401.165
DO I=1,PPXREF_CHARLEN GSS2F401.166
PPXC(RowNumber,I)=DNAM(I) GSS2F401.167
END DO GSS2F401.168
DO I=1,PPXREF_CODELEN GSS2F401.169
PPXI(RowNumber,I)=CODES(I) GSS2F401.170
END DO GSS2F401.171
! Set row index - indicates values of model,sec,item for this row GSS2F401.172
RowIndex (RowNumber)= Im_ident*100000 GSS2F401.173
& + Section *1000 GSS2F401.174
& + Item GSS2F401.175
! Set flag to indicate record originated from ppxref file GSS2F401.176
OriginFlag(RowNumber)='P' GSS2F401.177
IF (RowNumber .GT. ppxRecs) THEN GSS2F401.178
WRITE(6,*) 'Error in GETPPX:' GSS2F401.179
WRITE(6,*) GSS1F400.78
& ' PPXI row number exceeds total no. of ppx records ', GSS2F401.180
& RowNumber GSS2F401.181
GO TO 9999 GSS2F401.182
END IF GETPPX1.125
GO TO 100 ! Back to READ GSS2F401.183
ELSE GSS2F401.184
! Skip to next line GSS2F401.185
GO TO 100 GSS2F401.186
END IF GSS2F401.187
ELSE ! NFTPPXREF.NE.1 GSS2F401.188
! ---------------------------------------------------------- GSS1F400.109
! Insert user-defined diagnostics into ppxref look-up arrays GSS1F400.110
! ---------------------------------------------------------- GSS1F400.111
GSS1F400.112
*IF DEF,PUMF,OR,DEF,CUMF,OR,DEF,CONVIEEE,OR,DEF,MERGE,OR,DEF,CONVPP GSS2F401.189
IF (NRECS_USTASH(1).GT.0) THEN GSS2F401.190
*ELSEIF DEF,FLDOP GSS2F401.191
IF (NRECS_USTASH(1).GT.0) THEN GSS2F401.192
*ELSE GSS2F401.193
IF (NRECS_USTASH.GT.0) THEN GSS2F401.194
*ENDIF GSS2F401.195
! There are user diagnostic records GSS2F401.196
ErrorStatus=0 GSS1F400.114
IOStatus =0 GSS1F400.115
*IF DEF,PUMF,OR,DEF,CUMF,OR,DEF,CONVIEEE,OR,DEF,MERGE,OR,DEF,CONVPP GDG0F401.634
*ELSEIF DEF,FLDOP GDG0F401.635
*ELSE GDG0F401.636
! Get directory name for Upsm files GSS1F400.116
*IF DEF,MPP,AND,DEF,T3E GBCVF405.387
upsmfile='empty ' GBCVF405.388
if(mype.eq.0) CALL GET_FILE(NFTSTMSTU,UpsmFile,80, GBCVF405.389
2 ErrorStatus) GBCVF405.390
*ELSE GBCVF405.391
CALL GET_FILE(NFTSTMSTU,UpsmFile,80,ErrorStatus) GSS1F400.117
*ENDIF GBCVF405.392
FirstBlank = 0 GSS1F400.118
DO I = 1,80 GSS1F400.119
IF (UpsmFile(I:I).EQ.' '.AND.FirstBlank.EQ.0) FirstBlank=I GSS1F400.120
END DO GSS1F400.121
*ENDIF GDG0F401.637
GSS1F400.122
! Loop over user pre-stash master files GSS1F400.123
DO IFIL = 1,N_USTASH GSS1F400.124
*IF DEF,PUMF,OR,DEF,CUMF,OR,DEF,CONVIEEE,OR,DEF,MERGE,OR,DEF,CONVPP GDG0F401.638
UpsmFile=USTSFILS(IFIL) GDG0F401.639
*ELSEIF DEF,FLDOP GDG0F401.640
UpsmFile=USTSFILS(IFIL) GDG0F401.641
*ELSE GDG0F401.642
UpsmFile(FirstBlank :FirstBlank )='.' GSS1F400.125
UpsmFile(FirstBlank+1:FirstBlank+8)=USTSFILS(IFIL) GSS1F400.126
GSS2F401.197
*ENDIF GDG0F401.643
! Open user stash master file GSS1F400.127
*IF DEF,MPP,AND,DEF,T3E GBCVF405.393
if(mype.eq.0) OPEN(UNIT=NFTSTMSTU,FILE=UpsmFile, GBCVF405.394
2 IOSTAT=IOStatus) GBCVF405.395
GBCVF405.396
msg=7040 GBCVF405.397
info=0 GBCVF405.398
call gc_ibcast(msg, 1, 0, nproc, info, IOStatus) GBCVF405.399
GBCVF405.400
*ELSE GBCVF405.401
OPEN(NFTSTMSTU,FILE=UpsmFile,IOSTAT=IOStatus) GSS1F400.128
*ENDIF GBCVF405.402
IF(IOStatus.NE.0) THEN GSS1F400.129
WRITE(6,*) 'CANNOT OPEN USER PPXREF FILE.IOSTATUS=', GSS1F400.130
& IOStatus GSS1F400.131
WRITE(6,*) 'UNIT=',NFTSTMSTU,' FILE=',UpsmFile GSS1F400.132
ErrorStatus=100 GSS1F400.133
CMESSAGE=' GETPPX: ERROR OPENING USER PPXREF' GSS2F401.198
GOTO 9999 GSS1F400.135
END IF GSS1F400.136
GSS2F401.199
*IF DEF,PUMF,OR,DEF,CUMF,OR,DEF,CONVIEEE,OR,DEF,MERGE,OR,DEF,CONVPP GDG0F401.644
NU_recs = NRECS_USTASH(IFIL) GDG0F401.645
*ELSEIF DEF,FLDOP GDG0F401.646
NU_recs = NRECS_USTASH(IFIL) GDG0F401.647
*ELSE GDG0F401.648
! Read number of records in this file GDG0F401.649
*IF DEF,MPP,AND,DEF,T3E GBCVF405.403
if(mype.eq.0) READ(NFTSTMSTU,'(I3)') NU_recs GBCVF405.404
GBCVF405.405
msg=7050 GBCVF405.406
info=0 GBCVF405.407
call gc_ibcast(msg, 1, 0, nproc, info, nu_recs) GBCVF405.408
GBCVF405.409
*ELSE GBCVF405.410
READ(NFTSTMSTU,'(I3)') NU_recs GDG0F401.650
*ENDIF GBCVF405.411
*ENDIF GDG0F401.651
GDG0F401.652
! Read in records from user pre-stash master file GSS1F400.139
DO IREC = 1,NU_recs GSS1F400.140
! Initialise OVERWRITE switch GSS1F403.30
OVERWRITE=.FALSE. GSS1F403.31
hashcount=0 GSS2F401.200
*IF DEF,MPP,AND,DEF,T3E GBCVF405.412
200 continue GBCVF405.413
if(mype.eq.0) READ(NFTSTMSTU,'(A1)') CHAR1 GBCVF405.414
c GBCVF405.415
msg=7043 GBCVF405.416
info=0 GBCVF405.417
call gc_cbcast(msg, 1, 0, nproc, info, char1) GBCVF405.418
c GBCVF405.419
*ELSE GBCVF405.420
200 READ(NFTSTMSTU,'(A1)') CHAR1 GSS2F401.201
*ENDIF GBCVF405.421
IF (CHAR1.NE.'1') THEN GSS2F401.202
hashcount=hashcount+1 GSS2F401.203
IF (hashcount.GT.20) THEN GSS2F401.204
Errorstatus=100 GSS2F401.205
CMESSAGE='INCORRECT FORMAT IN USER STASHmaster FILE' GSS2F401.206
WRITE(6,*) 'INCORRECT FORMAT IN USER STASHmaster FILE' GSS2F401.207
WRITE(6,*) 'GAP BETWEEN RECORDS TOO LARGE?' GSS2F401.208
GO TO 9999 GSS2F401.209
ELSE GSS2F401.210
GO TO 200 GSS2F401.211
END IF GSS2F401.212
ELSE GSS2F401.213
!Read block of records GSS2F401.214
*IF DEF,MPP,AND,DEF,T3E GBCVF405.422
if(mype.eq.0) then GBCVF405.423
BACKSPACE NFTSTMSTU GBCVF405.424
CALL READSTM GBCVF405.425
& (IMASK,DNAM,CODES,NFTSTMSTU,ErrorStatus,CMESSAGE) GBCVF405.426
endif GBCVF405.427
GBCVF405.428
msg=7041 GBCVF405.429
info=0 GBCVF405.430
call gc_ibcast(msg, ppxref_codelen, 0, nproc, info, codes) GBCVF405.431
msg=7042 GBCVF405.432
info=0 GBCVF405.433
call gc_cbcast(msg, ppxref_charlen, 0, nproc, info, dnam) GBCVF405.434
*ELSE GBCVF405.435
BACKSPACE NFTSTMSTU GSS2F401.215
CALL READSTM GSS1F400.141
& (IMASK,DNAM,CODES,NFTSTMSTU,ErrorStatus,CMESSAGE) GSS2F401.216
*ENDIF GBCVF405.436
Im_ident = CODES(ppx_model_number) GSS2F401.217
Section = CODES(ppx_section_number) GSS2F401.218
Item = CODES(ppx_item_number) GSS2F401.219
GSS1F400.170
! Transfer data from ppx record to look-up arrays GSS1F400.171
! No. of records extracted from STASHmaster file(s)= RowNumber. GSS2F401.220
USTrow = 0 GSS1F400.172
DO I=1,RowNumber GSS2F401.221
RI = RowIndex(I) GSS1F400.174
! Determine values of model,section,item for this row GSS1F400.175
IF (RI.GT.0.AND.USTrow.EQ.0) THEN GSS1F400.176
LModel = RI/100000 GSS1F400.177
LSection=(RI-(RI/100000)*100000)/1000 GSS1F400.178
LItem =(RI-(RI/1000 )*1000 ) GSS1F400.179
! Check whether previous item is being overwritten GSS1F400.180
IF (Im_ident.EQ.LModel .AND. GSS1F400.181
& Section .EQ.LSection.AND. GSS1F400.182
& Item .EQ.LItem ) THEN GSS1F400.183
IF (OriginFlag(I).EQ.'P') THEN GSS1F400.184
OVERWRITE=.TRUE. GSS1F403.32
WRITE(6,*) 'MESSAGE FROM ROUTINE GETPPX:' GSS2F401.222
WRITE(6,*) GSS1F400.186
& 'The following PPXREF record has been overwritten by' GSS1F400.187
WRITE(6,*) GSS1F400.188
& 'a record read from a user-STASH master file: ' GSS1F400.189
WRITE(6,*) 'Internal Model ',Im_ident, GSS1F400.190
& ' Section ',Section,' Item ',Item GSS1F400.191
ELSE IF (OriginFlag(I).EQ.'U') THEN GSS1F400.206
WRITE(6,*) 'ERROR, GETPPX: ' GSS1F400.207
WRITE(6,*) 'User diagnostic duplicated' GSS1F400.208
WRITE(6,*) 'Model,Section,Item ', GSS1F400.209
& Im_ident,Section,Item GSS1F400.210
ErrorStatus=100 GSS1F400.211
CMESSAGE='ERROR,GETPPX:user diag duplicated' GSS1F400.212
GO TO 9999 GSS1F400.213
END IF GSS1F400.214
END IF GSS1F400.215
! Determine appropriate row number GSS1F400.216
IF (LModel .EQ.Im_ident.AND. GSS1F400.217
& LSection.EQ.Section .AND. GSS1F400.218
& LItem .EQ.Item .AND.USTrow.EQ.0) THEN GSS1F400.219
USTrow=I ! Row number found GSS1F400.220
! This record will overwrite a pre-existing record GSS1F400.221
! Insert new record GSS1F400.222
DO IE=1,PPXREF_CHARLEN GSS1F400.223
PPXC(USTrow,IE)=DNAM(IE) GSS1F400.224
END DO GSS1F400.225
DO IE=1,PPXREF_CODELEN GSS1F400.226
PPXI(USTRow,IE)=CODES(IE) GSS1F400.227
END DO GSS1F400.228
! Set flag to indicate record originated from user psm file GSS1F400.232
OriginFlag(USTrow)='U' GSS1F400.233
ELSE IF((LModel .GT.Im_ident.AND.USTrow.EQ.0) .OR. GSS1F400.234
& (LModel .EQ.Im_ident.AND. GSS1F400.235
& LSection.GT.Section .AND.USTrow.EQ.0) .OR. GSS1F400.236
& (LModel .EQ.Im_ident.AND. GSS1F400.237
& LSection.EQ.Section .AND. GSS1F400.238
& LItem .GT.Item .AND.USTrow.EQ.0)) THEN GSS1F400.239
USTrow=I ! Row number found GSS1F400.240
! This record will be inserted between two pre-existing records GSS1F400.241
! Create spare row - move all subsequent records up by one row GSS1F400.242
DO ID = RowNumber+1,USTrow+1,-1 GSS2F401.223
DO IE=1,PPXREF_CHARLEN GSS1F400.244
PPXC(ID,IE)=PPXC(ID-1,IE) GSS1F400.245
END DO GSS1F400.246
DO IE=1,PPXREF_CODELEN GSS1F400.247
PPXI(ID,IE)=PPXI(ID-1,IE) GSS1F400.248
END DO GSS1F400.249
RI =RowIndex (ID-1) GSS1F400.250
RowIndex (ID)=RowIndex (ID-1) GSS1F400.251
OriginFlag(ID)=OriginFlag(ID-1) GSS1F400.252
! Determine values of model,section,item for this row GSS1F400.253
DM= RI/100000 GSS1F400.254
DS=(RI-(RI/100000)*100000)/1000 GSS1F400.255
DI=(RI-(RI/1000 )*1000 ) GSS1F400.256
! Increment PPXPTR for record moved up GSS1F400.257
*IF DEF,RECON GSS1F400.258
PPXPTR(DM,DS,DI)=PPXPTR(DM,DS,DI)+1 GSS1F400.259
*ELSE GSS1F400.260
Im_index=INTERNAL_MODEL_INDEX(DM) GSS1F400.261
PPXPTR(Im_index,DS,DI)=PPXPTR(Im_index,DS,DI)+1 GSS1F400.262
*ENDIF GSS1F400.263
END DO GSS1F400.264
! Insert new record GSS1F400.265
DO IE=1,PPXREF_CHARLEN GSS1F400.266
PPXC(USTrow,IE)=DNAM(IE) GSS1F400.267
END DO GSS1F400.268
DO IE=1,PPXREF_CODELEN GSS1F400.269
PPXI(USTRow,IE)=CODES(IE) GSS1F400.270
END DO GSS1F400.271
! Set row index - indicates model,sec,item for this row GSS1F400.275
RowIndex (USTrow)= Im_ident*100000 GSS1F400.276
& + Section *1000 GSS1F400.277
& + Item GSS1F400.278
! Set flag to indicate record originated from user psm file GSS1F400.279
OriginFlag(USTrow)='U' GSS1F400.280
! Set PPXPTR for the new record GSS1F400.281
*IF DEF,RECON GSS1F400.282
PPXPTR(Im_ident,Section,Item)=USTrow GSS1F400.283
*ELSE GSS1F400.284
Im_index=INTERNAL_MODEL_INDEX(Im_ident) GSS1F400.285
PPXPTR(Im_index,Section,Item)=USTrow GSS1F400.286
*ENDIF GSS1F400.287
GSS1F400.288
END IF GSS1F400.289
ELSE IF (RI.EQ.0 .AND. USTrow.EQ.0) THEN GSS1F400.290
! This record will be added after all pre-existing records GSS1F400.291
USTrow = I GSS1F400.292
! Add new record GSS1F400.293
DO IE=1,PPXREF_CHARLEN GSS1F400.294
PPXC(USTrow,IE)=DNAM(IE) GSS1F400.295
END DO GSS1F400.296
DO IE=1,PPXREF_CODELEN GSS1F400.297
PPXI(USTrow,IE)=CODES(IE) GSS1F400.298
END DO GSS1F400.299
! Set row index - indicates model,sec,item for this row GSS1F400.303
RowIndex (USTrow)= Im_ident*100000 GSS1F400.304
& + Section *1000 GSS1F400.305
& + Item GSS1F400.306
! Set flag to indicate record originated from user psm file GSS1F400.307
OriginFlag(USTrow)='U' GSS1F400.308
! Set PPXPTR for the new record GSS1F400.309
*IF DEF,RECON GSS1F400.310
PPXPTR(Im_ident,Section,Item)=USTrow GSS1F400.311
*ELSE GSS1F400.312
Im_index=INTERNAL_MODEL_INDEX(Im_ident) GSS1F400.313
PPXPTR(Im_index,Section,Item)=USTrow GSS1F400.314
*ENDIF GSS1F400.315
END IF GSS1F400.316
END DO GSS1F400.317
! Increment RowNumber as UserSTASH record has been added. GSS2F401.224
! don't increment it if a standard record has been overwritten. GSS1F403.33
IF (.NOT.OVERWRITE) THEN GSS1F403.34
RowNumber = RowNumber + 1 GSS2F401.225
END IF GSS1F403.35
END IF ! hashcount GSS2F401.226
END DO ! Loop over IREC recs in upsm file GSS1F400.318
END DO ! Loop over user psm files GSS1F400.319
END IF ! NRECS_USTASH.GT.0 GSS1F400.320
*IF -DEF,RECON,AND,-DEF,UTILIO,AND,-DEF,FLDOP UIE3F404.16
! Copy user pre-stash master records to storage arrays - GSS1F400.322
! for passing into to U_MODEL GSS1F400.323
! Note: OriginFlag will be compressed to requested items only GSS1F400.324
! at the end of routine STASH_PROC (before used in GETPPX_PART) GSS1F400.325
IF (NRECS_USTASH.GT.0) THEN GSS1F400.326
RowNumber = 1 GSS1F400.327
DO I = 1,ppxRecs GSS1F400.328
IF (OriginFlag(I).EQ.'U') THEN GSS1F400.329
DO IE=1,PPXREF_CHARLEN GSS1F400.330
PPXC_U(RowNumber,IE)=PPXC(I,IE) GSS1F400.331
END DO GSS1F400.332
DO IE=1,PPXREF_CODELEN GSS1F400.333
PPXI_U(RowNumber,IE)=PPXI(I,IE) GSS1F400.334
END DO GSS1F400.335
RowNumber=RowNumber+1 GSS1F400.336
END IF GSS1F400.337
END DO GSS1F400.338
END IF GSS1F400.339
*ENDIF GSS1F400.340
GSS2F401.227
END IF !NFT.eq.22 (Standard STASHmstr or user STASHmstr) GSS2F401.228
GSS2F401.229
9999 CONTINUE GETPPX1.206
RETURN GETPPX1.207
END GETPPX1.208
*ENDIF GETPPX1.209