C C C C THESE ROUTINES WERE WRITTEN TO EMULATE SOME OF THE RSX11-D C FORTRAN SPECIAL SUBROUTINES ON THE VAX. NOT ALL FEATURES ARE C PRESENT AND OR TESTED. C C SUBROUTINE WAIT(TIMM,UNITS,M) C SUBROUTINE TO ISSUE A MARK TIME AND THEN A WAIT C INTEGER*2 TIM,TIMM,UNITS,DDD,HH(2),MM(2),SS(2),CC(2) INTEGER*4 TIMADR(2),STAT,SYS$BINTIM,SYS$SCHDWK CHARACTER*16 TIMBUF DDD=0 TIM=TIMM DO 5 I=1,2 HH(I)=0 MM(I)=0 SS(I)=0 5 CC(I)=0 KK=UNITS IF(KK.LE.1) KK=KK+1 GO TO (10,20,30,40),KK 10 DO 11 I=1,2 CC(3-I)=MOD(TIM,10) 11 TIM=TIM/10 IF(TIM.EQ.0) GO TO 50 20 SS(2)=MOD(TIM,10) TIM=TIM/10 SS(1)=MOD(TIM,6) TIM=TIM/6 IF(TIM.EQ.0) GO TO 50 30 MM(2)=MOD(TIM,10) TIM=TIM/10 MM(1)=MOD(TIM,6) TIM=TIM/6 IF(TIM.EQ.0) GO TO 50 40 HH(2)=MOD(TIM,24) TIM=TIM/24 HH(1)=HH(2)/10 HH(2)=MOD(HH(2),10) DDD=TIM 50 ENCODE(16,51,TIMBUF) DDD,HH,MM,SS,CC 51 FORMAT(I4,1X,2I1,2(':',2I1),'.',2I1) C TYPE *,TIMBUF STAT=SYS$BINTIM(TIMBUF,TIMADR) IF(STAT) GO TO 60 CALL PRINTMSG(STAT) M=STAT RETURN 60 STAT=SYS$SCHDWK(,,TIMADR,) IF(STAT) GO TO 100 CALL PRINTMSG(STAT) M=STAT RETURN 100 CALL SYS$HIBER RETURN END SUBROUTINE PRINTMSG(STATUS) C C THIS SUBROUTINE TAKES A SYSTEM SERVICE STATUS CODE, C FORMATS IT AND OUTPUTS IT TO THE USER C IMPLICIT INTEGER(A-Z) CHARACTER*256 MSGBUF C C FORMAT THE MESSAGE C STAT=SYS$GETMSG(%VAL(STATUS),LENGTH,MSGBUF,%VAL('F'X),) C C IF GETMSG GETS AN ERROR, RETURN C IF(.NOT.STAT) GO TO 20 C C INFORM THE USER OF THE ERROR C TYPE 10,MSGBUF(1:LENGTH) 10 FORMAT(1X,A) C C DONE C 20 RETURN END C ************************** DISCKP ************************ SUBROUTINE DISCKP RETURN END C **************************** ENACKP ********************* SUBROUTINE ENACKP RETURN END C***************************** SSWITCH ********************* FUNCTION SSWTCH(I,J) INTEGER*2 SSWTCH SSWTCH=0 J=0 RETURN END C **************************** ABORT ************************** SUBROUTINE ABORT CALL LIB$STOP(16) END C**************************** GETTSK **************************** SUBROUTINE GETTSK(A,I) REAL A,B(2),C(2) INTEGER*2 I DATA B/' ',' '/ A=RAD50(B) I=1 RETURN C C ENTRY FOR SETTING UP GETTSK RETURN NAME C ENTRY SETTSK(C) DO 10 K=1,2 10 B(K)=C(K) RETURN END