C  =====================================================================
C  pgm: SHPCOD .. Get parameter code from message
C
C  use:     CALL SHPCOD(KHAR,KHPOS)
C
C  i/o: KHAR ...... last buffer char obtained - CHAR*1
C  i/o: KHPOS ..... last char loc: 2=eol,1=err-eol,0=eof,neg=err - INT
C
C  rqd: SHGETK,SH2BLA,SHERR,SHSAVP
C
C  cmt: Routine will NOT process if current char is "end-of-line".
C  cmt: "KHAR" must be guaranteed not blank if "KHPOS" is less than 2.
C  =====================================================================
      SUBROUTINE SHPCOD(KHAR,KHPOS)

      EXTERNAL       SHGETK,SH2BLA,SHERR,SHSAVP

      CHARACTER*8    PARCOD
      CHARACTER*1    KHAR
      INTEGER        KHPOS,NOC,NN,III
C
C    ================================= RCS keyword statements ==========
      CHARACTER*68     RCSKW1,RCSKW2
      DATA             RCSKW1,RCSKW2 /                                 '
     .$Source: /fs/hseb/ob5/rfc/ofs/src/shefpars_driv/RCS/shpcod.f,v $
     . $',                                                             '
     .$Id: shpcod.f,v 1.3 1998/04/07 19:14:39 page Exp $
     . $' /
C    ===================================================================
C

        CALL SH2BLA(KHAR,KHPOS,NOC)

C                   If current char position is in a message line

        IF (KHPOS .GT. 2) THEN

          CALL SHSAVP('G',III,PARCOD)

C                   Loop while char is not blank nor is output str full

          NN = 0
   30     IF(KHPOS.LE.2.OR.NN.GE.7.OR.KHAR.EQ.' '.OR.KHAR.EQ.'/')GOTO 40

            IF (KHAR.GE.'A' .AND. KHAR.LE.'Z') THEN
              NN = NN+1
              PARCOD(NN:NN) = KHAR
              CALL SHGETK(KHAR,KHPOS)
            ELSEIF (NN.EQ.3 .OR. NN.EQ.4 .OR. NN.EQ.6) THEN
              IF (KHAR.GE.'1' .AND. KHAR.LE.'9') THEN
                NN = NN+1
                PARCOD(NN:NN) = KHAR
                CALL SHGETK(KHAR,KHPOS)
              ELSE
                CALL SHERR('E',29,KHPOS,KHAR)
              ENDIF
            ELSE
              CALL SHERR('E',29,KHPOS,KHAR)
            ENDIF

            GOTO 30
   40     CONTINUE

          CALL SHSAVP('P',III,PARCOD)

          CALL SH2BLA(KHAR,KHPOS,NOC)

          IF (KHPOS.GT.2 .AND. KHAR.NE.'/') THEN
            IF (NOC .EQ. 0) CALL SHERR('E',54,KHPOS,KHAR)
          ENDIF

          IF (KHPOS.NE.1 .AND. PARCOD(2:2).EQ.'        ') THEN
            CALL SHERR('E',64,KHPOS,KHAR)
          ENDIF

        ENDIF

      RETURN
      END