FTN4,C,Q
      PROGRAM GTCXX(3,99),92425-16049 REV.2001 791112 
*     NAME: GTCXX 
*   SOURCE: 92425-18049 
*    RELOC: 92425-1X049 
*     PRGM: DICK LAMPMAN
************************************************************************* 
*    (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS             * 
*    RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,             *
*   REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT        * 
*   THE PRIOR WRITTED CONSENT OF HEWLETT-PACKARD COMPANY.               * 
************************************************************************* 
      DIMENSION IDCB (200)
      DIMENSION IBUF (80), NSLC(4), ITR(14), ITRE(4)
      DATA NSLC/ 3 ,2H/S ,2HLC ,2H  / 
      DATA ICRN2/-2/ , ICNR3/-3/
      DATA ITR  /  13,2H:T ,2HR, ,2H/S ,2HLC ,2H:: ,2H,+
     C,2H00 ,2H00 ,2H00 ,2H,+ ,2H00 ,2H00 ,2H00/
      DATA ITRE /      3,2H:E ,2HX, ,2HRP/
C 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
C     PICK UP SCHEDULING PARAMETERS.
      CALL RMPAR (IBUF) 
C 
C 
C     CHANGE MESSAGE LU IF SUPPLIED AS SCHEDULING PARAMETER.
      LU = LOGLU (LUSYS)
      IF (IBUF.NE.0) LU = IBUF
C     CHANGE CLUSTER IF SUPPLIED AS SCHEDULING PARAMETER. 
C     USE TERMINAL SYSTEM LU AS DEFAULT CLUSTER VALUE.
      ICLS = LUTRU (1)
      IF (IBUF(2).NE.0) ICLS = IBUF(2)
C 
C     CHANGE CRN FOR /SLC IF IT WAS PASSED. 
      ICRN = ICRN2
      IF (IBUF(3).NE.0) ICRN = IBUF(3)
C 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
C     CHECK FOR VALID DRTXX.    . 
C     FIRST GET THE NO. OF TERMINALS. 
      CALL JDRTG (1,J)
      CALL ABREG (IA,IB)
      IF (IB.NE.0.OR.J.EQ.0) GOTO 8011
C     SEARCH TERMINAL TABLE FOR SESSION CONSOLE 
      INDRT = 2 
50    CALL JDRTG (INDRT,ITSYS)
      CALL ABREG (IA,IB)
      IF (IB.NE.0) GOTO 8011
C     CHECK TERMINAL SYSTEM LU HAS BEEN FOUND.
      ITSYS = IAND (ITSYS,377B) 
      IF (ITSYS.EQ.LUSYS) GOTO 100
C     CHECK IF THERE IS ANOTHER TERMINAL IN DRTXX 
      INDRT = INDRT + 2 
      J = J - 2 
      IF (J.EQ.0) GOTO 8050 
C     GO CHECK NEXT TERMINAL
      GOTO 50 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
100   CONTINUE
C     PUT CLUSTER NUMBER IN DRTXX TABLE.
      CALL JDRTP (INDRT,ICLS*400B+ITSYS)
      CALL ABREG (IA,IB)
      IF (IB.NE.0) GOTO 8012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
200   CONTINUE
C 
C     CHECK FOR /SLC
C     OPEN FILE FOR NON EXCLUSIVE USE.
205   CALL OPEN (IDCB,IERR,NSLC(2),1,0,ICRN)
C     IF THE FILE CANNOT BE FOUND TRY (CRN=-3) IF 
C      (CRN=-2) FAILED. 
      IF (IERR.NE.-6.OR.ICRN.NE.ICNR2) GOTO 210 
      ICRN = ICRN3
      GOTO 205
C 
210   CONTINUE
C      EXIT IF UNSUCCESSFUL OPEN. 
       IF (IERR.LT.0) GOTO 8040 
C      CLOSE FILE . 
C 
       CALL CLOSE (IDCB)
C      EXIT IF FILE NOT TYPE 4. 
       IF (IERR.NE.4) GOTO 8041 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
400    CONTINUE 
C      IF CRN IS NOT (CRN=-2 OR =-3) CHECK CAPABILITY TO
C       EXECUTE FMGR "SL" COMMAND.
       IF (ICRN.EQ.ICRN2.OR.ICNR.EQ.ICRN3) GOTO 499 
       IF (ICAPS(IDUMY).LT.50) GOTO 8030
499    CONTINUE 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
C      BUILD UP THE :TR,/SLC::CRN,CLUSTER  COMMAND. 
C 
C      CONVERT THE CRN TO ASCII.
C       SAVE THE SIGN.
       ITR ( 7) = 2H:+
       IF (ICRN.LT.0) ITR ( 7) = 2H:- 
       ICRN = IABS (ICRN) 
       CALL CNUMD (ICRN,ITR( 8) ) 
C      CONVERT THE CLUSTER TO ASCII 
        ITR (11) =2H,+
       IF  (ICLS .LT. 0) ITR (11) = 2H,-
       ICLS = IABS (ICLS) 
       CALL CNUMD (ICLS,ITR(12) ) 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
C      PASS THE TR COMMAND BACK TO THE FATHER.
C       !!!!!!!AN ASSUMPTION IS MADE HERE THAT THE FATHER IS FMGR!!!! 
       CALL EXEC (14,2,ITR(2),ITR(1) )
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
C      MAKE GRACEFUL EXIT 
       GOTO 9999
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
8000   CONTINUE 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
8010   CONTINUE 
C      NOT IN SESSION ERROR.
       WRITE (LU,8015)
8015   FORMAT (/" GTCXX ERROR. NOT IN SESSION") 
       GOTO 8990
8011   CONTINUE 
C      DRTXX NOT VALID. 
       WRITE (LU,8016)
8016   FORMAT (/" GTCXX ERROR. INVALID DRTXX TABLE")
       GOTO 8990
8012   CONTINUE 
C      CANNOT PUT CLUSTER NUMBER IN DRTXX.
       WRITE (LU,8017)
8017   FORMAT (/" GTCXX ERROR. DRTXX TABLE CANNOT BE UP DATED") 
       GOTO 8990
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
8030   CONTINUE 
C      INSUFFICIENT CAPABILITY. 
       WRITE (LU,8035)  ICRN
8035   FORMAT (/" GTCXX ERROR. INSUFFICIENT CAPABILITY TO EXECUTE"
     C /"             FMGR SL COMMAND IN /SLC ON CRN" I7".")
       GOTO 8990
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
8040   CONTINUE 
       WRITE (LU,8045) IERR 
8045   FORMAT (/" GTCXX ERROR. FMGR ERROR" I7".") 
       GOTO 8990
8041   CONTINUE 
C      ILLEGAL FILE TYPE. 
       WRITE (LU,8046) ICRN 
8046   FORMAT (/" GTCXX ERROR. /SLC::"I6" TYPE WAS NOT 4")
       GOTO 8990
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
8050   CONTINUE 
       WRITE (LU,8055) LUSYS
8055   FORMAT (/" GTCXX ERROR. NO ENTRY IN DRTXX FOR TERMINAL" ,
     C " WITH SYSTEM LU "I3".") 
       GOTO 8990
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
8990   CONTINUE 
C      MAKE ERROR EXIT. 
C      SET RETURN PARAMETER TO NEGATIVE VALUE 
       IF (IBUF.GE.0) IBUF = -1 
       IBUF(2) = IERR 
       CALL PRTN (IBUF) 
       CALL EXEC (6)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
9999   CONTINUE 
C      MAKE "NO ERROR" RETURN.
       IBUF = 0 
       CALL PRTN (IBUF) 
       CALL EXEC (6)
       END
       END$ 
                                                                                                                                                                                                                                                    