SUBROUTINE HDPPXRF(NFT,StmsrNam,ppxRecs,ICODE,CMESSAGE) 53,3GSS2F401.1
IMPLICIT NONE HDPPXRF1.26
INTEGER NFT,NFTU !IN: UNIT NUMBER FOR FILE GSS2F401.2
CHARACTER*(80) CMESSAGE !OUT: ERROR RETURN MESSAGE GSS1F305.202
INTEGER ICODE !OUT: ERROR RETURN CODE HDPPXRF1.32
GSS1F305.203
*CALL CSUBMODL 
GSS1F305.204
*CALL CPPXREF HDPPXRF1.33
*CALL PPXLOOK GSS1F305.206
*CALL CSTASH GRB0F401.21
*CALL LENFIL GSS1F400.460
HDPPXRF1.34
INTEGER LEN_IO HDPPXRF1.35
INTEGER IU ! Local - unit no. for stash control file GSS1F400.461
INTEGER I GSS1F400.462
INTEGER Int_Model_No GSS2F401.3
INTEGER FirstBlank GSS2F401.4
CHARACTER*13 StmsrNam GSS2F401.5
CHARACTER*80 STASH_MSTR GSS2F401.6
CHARACTER*1 CHAR1 GSS2F401.7
INTEGER IOStatus GSS2F401.8
GSS1F400.463
character*8 c_um_version !UM version as string GJC0F405.17
character*8 c_stm_version !STASHmaster version string GJC0F405.18
integer um_version, !Version of UM GJC0F405.19
& um_revision !Revision of UM GDW1F404.15
integer stm_version, !Version of STASHmaster file GJC0F405.20
& stm_revision !Revision of STASHmaster file GJC0F405.21
integer ocode !Copy of the input value of ICODE GDW1F404.18
logical found_version !Indicates presence of STM version GDW1F404.19
REAL STATUS HDPPXRF1.36
INTEGER RECORD(PPX_RECORDLEN) HDPPXRF1.37
*IF DEF,MPP,AND,DEF,T3E GBCVF405.4
integer shmem_n_pes, msg, info, nproc, shmem_my_pe, mype GBCVF405.5
common/shmem_hdppxrf/ IOStatus, found_version, stm_version GBCVF405.6
cdir$ cache_align /shmem_hdppxrf/ GBCVF405.7
*ENDIF GBCVF405.8
IOStatus=0 GSS2F401.9
c Check if an error has already been encountered, and get out GDW1F404.20
c if it has. GDW1F404.21
ocode = 0 GDW1F404.22
IF (icode .gt. 0) then GDW1F404.23
goto 9999 GDW1F404.24
ELSE IF (icode .lt. 0)then GDW1F404.25
ocode = icode GDW1F404.26
icode = 0 GDW1F404.27
END IF GDW1F404.28
GDW1F404.29
GSS1F305.214
*IF DEF,MPP,AND,DEF,T3E GBCVF405.9
mype=shmem_my_pe() GBCVF405.10
nproc=shmem_n_pes() GBCVF405.11
*ENDIF GBCVF405.12
IF (NFT.EQ.22) THEN GSS2F401.10
*IF DEF,MPP,AND,DEF,T3E GBCVF405.13
if(mype.eq.0) then GBCVF405.14
stash_mstr='empty ' GBCVF405.15
*ENDIF GBCVF405.16
!Open STASHmaster file for current internal model GSS2F401.11
! Get directory name for STASHmaster & append rest of filename GSS2F401.12
CALL GET_FILE(NFT,STASH_MSTR,80,ICODE) GSS2F401.13
FirstBlank = 0 GSS2F401.14
DO I = 1,80 GSS2F401.15
IF (STASH_MSTR(I:I).EQ.' '.AND.FirstBlank.EQ.0) GSS2F401.16
& FirstBlank=I GSS2F401.17
END DO GSS2F401.18
STASH_MSTR(FirstBlank:FirstBlank)='/' GSS2F401.19
STASH_MSTR(FirstBlank+1:FirstBlank+13)=StmsrNam GSS2F401.20
OPEN(UNIT=NFT,FILE=STASH_MSTR,IOSTAT=IOStatus) GSS2F401.21
write(6,*) '!!!! STASH_MSTR ',STASH_MSTR GSS2F401.22
*IF DEF,MPP,AND,DEF,T3E GBCVF405.17
endif GBCVF405.18
c GBCVF405.19
msg=7001 GBCVF405.20
info=0 GBCVF405.21
call gc_ibcast(msg, 1, 0, nproc, info, IOStatus) GBCVF405.22
*ENDIF GBCVF405.23
GSS1F305.216
IF (IOStatus.NE.0) THEN GSS2F401.23
CMESSAGE= GSS2F401.24
& 'Error opening STASHmaster file, routine HDPPXRF' GSS2F401.25
WRITE(6,*) GSS2F401.26
& 'HDPPXRF: Fortran Error Response = ',IOStatus, GBCKF405.9
& ' Opening STASHmaster file ',StmsrNam GBCKF405.10
ICODE=100 GSS2F401.29
GO TO 9999 GSS2F401.30
ENDIF GSS2F401.31
GDW1F404.30
c Get the UM version from the environment variable $VN. GDW1F404.31
CALL FORT_GET_ENV('VN', 2, c_um_version, 8, icode) GDW1F404.32
IF (icode .ne. 0) then GDW1F404.33
c $VN was not set GDW1F404.34
write (6,*) GDW1F404.35
& 'HDPPXRF : WARNING : Environment variable VN not ', GRR0F405.2
& 'set or not obtainable; skipping version checking.' GRR0F405.3
cmessage = 'Environment variable VN not set, no version '// GRR0F405.4
& 'checking performed' GRR0F405.5
icode = -1 GDW1F404.41
goto 100 GDW1F404.42
ELSE GDW1F404.43
READ (c_um_version, '(i1,1x,i1)') um_version, um_revision GDW1F404.44
um_version = um_version*100 + um_revision GDW1F404.45
END IF GDW1F404.46
GDW1F404.47
c Now check through the header section of the STASHmaster GDW1F404.48
c file looking for H3 GDW1F404.49
found_version = .false. GDW1F404.50
*IF DEF,MPP,and,DEF,T3E GBCVF405.24
if (mype.eq.0) then GBCVF405.25
*ENDIF GBCVF405.26
READ (nft, '(A1)') char1 GDW1F404.51
DO WHILE (char1 .eq. 'H' .or. char1 .eq. '#') GDW1F404.52
IF (char1 .eq. 'H') THEN GDW1F404.53
BACKSPACE nft GDW1F404.54
READ (nft, '(1X, A1)') char1 GDW1F404.55
IF (char1 .eq. '3') THEN GDW1F404.56
c This line starts with H3 and should GDW1F404.57
c indicate the STASHmaster version. The line should look like GDW1F404.58
c H3| UM_VERSION=4.3 GDW1F404.59
found_version = .true. GDW1F404.60
BACKSPACE nft GDW1F404.61
READ (nft, '(15x,a8)') c_stm_version GDW1F404.62
READ (c_stm_version, '(i1,1x,i1)') GDW1F404.63
& stm_version, stm_revision GDW1F404.64
stm_version = stm_version*100 + stm_revision GDW1F404.65
c Now perform the check against the UM version GDW1F404.66
IF (stm_version .ne. um_version) then GDW1F404.67
*IF DEF,MPP,and,DEF,T3E GBCVF405.27
c--in MPP mode, defer setting the variables until all PE's can GBCVF405.28
icode=1 GBCVF405.29
go to 9997 GBCVF405.30
*ELSE GBCVF405.31
write (cmessage,*) GDW1F404.68
& 'HDPPXRF : UM version and STASHmaster version differ' GDW1F404.69
write (6,*) 'Version of STASHmaster file (' GDW1F404.70
& ,stm_version, GDW1F404.71
& ') does not match UM version (' GDW1F404.72
& ,um_version,') in file ',StmsrNam GDW1F404.73
icode = 1 GDW1F404.74
goto 9999 GDW1F404.75
*ENDIF GBCVF405.32
END IF ! version check GJC0F405.22
END IF ! char1 == '3' GJC0F405.23
END IF ! char1 == 'H' GDW1F404.78
READ (nft, '(a1)') char1 GDW1F404.79
END DO GDW1F404.80
GBCVF405.33
*IF DEF,MPP,and,DEF,T3E GBCVF405.34
endif ! if(mype .eq. 0) GBCVF405.35
c GBCVF405.36
c--in MPP Mode, get the Value of 'icode', 'stm_version', GBCVF405.37
c and 'found_version' GBCVF405.38
9997 continue GBCVF405.39
msg=7007 GBCVF405.40
iostatus=icode GBCVF405.41
call gc_ibcast (msg,3,0,nproc,info,iostatus) GBCVF405.42
icode=iostatus GBCVF405.43
c--check if we generated a failure GBCVF405.44
if(icode.ne.0) then GBCVF405.45
write (cmessage,*) GBCVF405.46
& 'HDPPXRF: UM version and STASHmaster version differ' GBCVF405.47
write (6,*) 'Version of STASHmaster file (' GBCVF405.48
& ,stm_version,') does not match UM version (' GBCVF405.49
& ,um_version,') in file ',StmsrNam GBCVF405.50
go to 9999 GBCVF405.51
endif GBCVF405.52
*ENDIF GBCVF405.53
GDW1F404.81
IF (.not. found_version) THEN GDW1F404.82
write (6,*) GDW1F404.83
& 'HDPPXRF : No STASHmaster version available; Unable to' GDW1F404.84
write (6,*) GDW1F404.85
& 'check against UM version for file ',StmsrNam GDW1F404.86
cmessage = 'HDPPXRF : No STASHmaster version available' GDW1F404.87
icode = -1 GDW1F404.88
END IF GDW1F404.89
*IF DEF,MPP,AND,DEF,T3E GBCVF405.54
if(mype.eq.0) then GBCVF405.55
*ENDIF GBCVF405.56
c For safety, rewind to the start of the STASH file. GDW1F404.90
rewind (nft) GDW1F404.91
*IF DEF,MPP,AND,DEF,T3E GBCVF405.57
endif ! if(mype .eq. 0) GBCVF405.58
*ENDIF GBCVF405.59
GSS2F401.32
100 continue GBCVF405.60
*IF DEF,MPP,AND,DEF,T3E GBCVF405.61
if(mype.eq.0) then GBCVF405.62
*ENDIF GBCVF405.63
!Count records - ppxRecs is counter GSS2F401.33
READ(NFT,'(A1)') CHAR1 GBCVF405.64
IF (CHAR1.EQ.'1') THEN GSS2F401.35
BACKSPACE NFT GSS2F401.36
READ(NFT,'(2X,I5)') Int_Model_No GSS2F401.37
IF (Int_Model_No.EQ.-1) THEN GSS2F401.38
!End of file reached GSS2F401.39
!ppxRecs initialised to 1 before HDPPXRF - so subtract 1 now GSS2F401.40
IF (StmsrNam(13:).EQ.'A') THEN GSS2F401.41
IF (INTERNAL_MODEL_INDEX(A_IM).EQ.1) THEN GSS2F401.42
ppxRecs=ppxRecs-1 GSS2F401.43
END IF GSS2F401.44
END IF GSS2F401.45
IF (StmsrNam(13:).EQ.'O') THEN GSS2F401.46
IF (INTERNAL_MODEL_INDEX(O_IM).EQ.1) THEN GSS2F401.47
ppxRecs=ppxRecs-1 GSS2F401.48
END IF GSS2F401.49
END IF GSS2F401.50
IF (StmsrNam(13:).EQ.'S') THEN GSS2F401.51
IF (INTERNAL_MODEL_INDEX(S_IM).EQ.1) THEN GSS2F401.52
ppxRecs=ppxRecs-1 GSS2F401.53
END IF GSS2F401.54
END IF GSS2F401.55
IF (StmsrNam(13:).EQ.'W') THEN GSS2F401.56
IF (INTERNAL_MODEL_INDEX(W_IM).EQ.1) THEN GSS2F401.57
ppxRecs=ppxRecs-1 GSS2F401.58
END IF GSS2F401.59
END IF GSS2F401.60
CLOSE(UNIT=NFT) GSS2F401.61
*IF DEF,MPP,AND,DEF,T3E GBCVF405.65
GO TO 9998 GBCVF405.66
*ELSE GBCVF405.67
GO TO 9999 GSS2F401.62
*ENDIF GBCVF405.68
END IF GSS2F401.63
ppxRecs = ppxRecs + 1 GSS2F401.64
GO TO 100 GSS2F401.65
ELSE GSS2F401.66
GO TO 100 GSS2F401.67
END IF GSS2F401.68
*IF DEF,MPP,AND,DEF,T3E GBCVF405.69
endif GBCVF405.70
GBCVF405.71
9998 continue GBCVF405.72
iostatus=ppxrecs GBCVF405.73
msg=7002 GBCVF405.74
call gc_ibcast(msg, 1, 0, nproc, info, iostatus) GBCVF405.75
ppxrecs=iostatus GBCVF405.76
goto 9999 GBCVF405.77
GBCVF405.78
*ENDIF GBCVF405.79
ELSE GSS2F401.69
GSS1F400.464
! Open stash control file and read USTSNUM namelist: number of user GSS1F400.465
! stash files and total no. of user stash records GSS1F400.466
*IF DEF,RECON GSS1F400.467
! Read USTNUM namelist from unit 5 GSS1F400.468
IU = 5 GSS2F401.70
*ELSE GSS1F400.470
! Read USTNUM namelist from unit 4 GSS1F400.471
IU = 4 ! Unit number GSS2F401.71
*IF DEF,MPP,AND,DEF,T3E GBCVF405.80
if(mype.eq.0) then GBCVF405.81
file='empty ' GBCVF405.82
*ENDIF GBCVF405.83
CALL GET_FILE(IU,FILE,80,icode) ! Get name for stash file GSS2F401.72
OPEN(IU,FILE=FILE,IOSTAT=icode) ! Open stash file GSS2F401.73
*IF DEF,MPP,AND,DEF,T3E GBCVF405.84
endif GBCVF405.85
c GBCVF405.86
msg=7003 GBCVF405.87
info=0 GBCVF405.88
iostatus=icode GBCVF405.89
call gc_ibcast(msg, 1, 0, nproc, info, iostatus) GBCVF405.90
icode=iostatus GBCVF405.91
c GBCVF405.92
*ENDIF GBCVF405.93
IF(icode.GT.0)THEN ! Error check GSS2F401.74
WRITE(6,*)'HDPPXRF : Failed in OPEN of Stash Control File' GIE0F403.257
GOTO 9999 GSS2F401.76
ELSEIF(icode.LT.0)THEN GSS2F401.77
WRITE(6,*)'HDPPXRF : GIE0F403.258
& Warning message on OPEN of Stash Control File' GSS1F400.480
WRITE(6,*)'IOSTAT= ',icode GIE0F403.259
ENDIF GSS2F401.80
*ENDIF GSS1F400.483
!Initialisation GSS2F401.81
*IF DEF,PUMF,OR,DEF,CUMF,OR,DEF,CONVIEEE,OR,DEF,MERGE,OR,DEF,CONVPP GSS2F401.82
DO I = 1,20 GSS2F401.83
NRECS_USTASH(I)=0 GSS2F401.84
END DO GSS2F401.85
*ELSEIF DEF,FLDOP GSS2F401.86
DO I = 1,20 GSS2F401.87
NRECS_USTASH(I)=0 GSS2F401.88
END DO GSS2F401.89
*ELSE GSS2F401.90
N_USTASH = 0 GSS2F401.91
NRECS_USTASH = 0 PXPPXRF.1
*ENDIF GSS2F401.92
DO I = 1,20 GSS2F401.94
USTSFILS(I)=' ' GSS2F401.95
END DO GSS2F401.96
! Read namelist GSS1F400.490
*IF DEF,MPP,AND,DEF,T3E GBCVF405.94
if(mype.eq.0) then GBCVF405.95
*ENDIF GBCVF405.96
READ(IU,USTSNUM) GSS2F401.97
*IF DEF,MPP,AND,DEF,T3E GBCVF405.97
endif GBCVF405.98
c GBCVF405.99
msg=7004 GBCVF405.100
call gc_ibcast(msg, 1, 0, nproc, info, N_USTASH) GBCVF405.101
msg=7005 GBCVF405.102
call gc_ibcast(msg, 1, 0, nproc, info, NRECS_USTASH) GBCVF405.103
msg=7006 GBCVF405.104
call gc_cbcast(msg, 160, 0, nproc, info, USTSFILS) GBCVF405.105
*IF DEF,DIAG190 GBCVF405.106
if(my_pe().le.1) write(190+my_pe(), USTSNUM) GBCVF405.107
*ENDIF GBCVF405.108
*ENDIF GBCVF405.109
! Add no. of user stash records to ppxRecs GSS1F400.492
*IF DEF,PUMF,OR,DEF,CUMF,OR,DEF,CONVIEEE,OR,DEF,MERGE,OR,DEF,CONVPP GSS2F401.98
DO I=1,N_USTASH GSS2F401.99
ppxRecs = ppxRecs + NRECS_USTASH(I) GSS2F401.100
END DO GSS2F401.101
*ELSEIF DEF,FLDOP GSS2F401.102
DO I=1,N_USTASH GSS2F401.103
ppxRecs = ppxRecs + NRECS_USTASH(I) GSS2F401.104
END DO GSS2F401.105
*ELSE GSS2F401.106
ppxRecs = ppxRecs + NRECS_USTASH GSS2F401.107
*ENDIF GSS2F401.108
END IF GSS2F401.109
GSS1F305.218
9999 CONTINUE GSS1F305.219
c If we have found an error, leave it in icode. If no error GDW1F404.92
c occurred then check if the original input value of icode was] GDW1F404.93
c non-zero (a previous untrapped error/warning), and copy this GDW1F404.94
c back into ICODE before eaving the routine. GDW1F404.95
IF (icode .eq. 0 .and. ocode .ne. 0) then GDW1F404.96
icode = ocode GDW1F404.97
END IF GDW1F404.98
RETURN GSS1F305.220
END HDPPXRF1.96
HDPPXRF1.97
*ENDIF HDPPXRF1.98