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$