home *** CD-ROM | disk | FTP | other *** search
/ nisttime.carsoncity.k12.mi.us / nisttime.carsoncity.k12.mi.us.tar / nisttime.carsoncity.k12.mi.us / pub / acts / nistime.rsx < prev    next >
Text File  |  1996-11-07  |  24KB  |  822 lines
  1.       PROGRAM NISTIM
  2. C
  3. C     THIS PROGRAM COMPARES THE LOCAL TIME WITH
  4. C     THE TIME RECEIVED BY CALLING THE NIST ACTS
  5. C     SERVICE.
  6. C
  7. C     RSX11M VERSION 2    9 NOVEMBER 1988
  8. C
  9. C      CONVERSION TO LOCAL TIME ZONE ADDED FOR VERSION
  10. C      2 USING FORTRAN VERSION OF IBM-PC CODE ORIGINALLY
  11. C      WRITTEN IN C
  12. C
  13.       PARAMETER IOATT="1400,ISFSMC="2440
  14.       INTEGER*2 IPRL(6),ISB(2)
  15.       BYTE IBB(14),TELNO(40),PARAM(10)
  16.       BYTE IANS
  17. C
  18. C     FOLLOWING CONSTANTS CONTROL WHAT HAPPENS
  19. C     EACH OPERATION IS ENABLED IF CONSTANT IS 1, DISABLED IF 0
  20. C     NOTE THAT ANY COMBINATION OF OPERATIONS MAY BE SPECIFIED
  21. C
  22. C
  23. C     ILIST     LIST LINES RECEIVED FROM NIST
  24. C     ICHK      COMPARE NIST TIME WITH SYSTEM TIME AND TYPE DIFFERENCE
  25. C     IARC      COMPARE NIST TIME WITH SYSTEM TIME AND WRITE DIFFERENCE
  26. C               TO FILE NISTIME.DIF  IN APPEND MODE
  27. C     ISET      SET SYSTEM TIME TO NIST TIME
  28. C     IDEBUG    TURN ON DIAGNOSTIC MESSAGES FOR DEBUGGING
  29. C     IRATE     COMPARE CURRENT DIFFERENCE WITH PREVIOUS VALUE TO GET RATE
  30. C
  31.       COMMON/OPS/ILIST,ICHK,IARC,ISET,IDEBUG,IRATE
  32.       COMMON/LOCAL/IUTDIF,IDST
  33. C
  34. C    FORCE IBB ARRAY TO BE WORD-ALIGNED
  35. C    USED FOR SETTING PORT CHARACTERISTICS
  36. C
  37.       EQUIVALENCE(IBB(1),IDUMMY)
  38. C
  39.       DATA IBB/ '7'O,1,'50'O,1,'71'O,0,'72'O,0,'64'O,1,3,11,4,11/
  40. C
  41. C     START OUT WITH ALL OPERATIONS DISABLED
  42. C
  43.       ILIST=0
  44.       ICHK=0
  45.       IARC=0
  46.       ISET=0
  47.       IDEBUG=0
  48.       IRATE=0
  49. C
  50. C    OPEN CONFIGURATION FILE AND READ PARAMETERS
  51. C
  52. C    FIRST LINE OF CONFIGURATION FILE HAS FULL TELEPHONE NUMBER
  53. C    INCLUDING LEADING T/P FOR TONE OR PULSE DIALING AND ANY
  54. C    REQUIRED LONG DISTANCE AND ACCOUNTING INFORMATION
  55. C
  56.       OPEN(UNIT=2,NAME='NISTIME.CFG',TYPE='OLD',
  57.      + ACCESS='SEQUENTIAL',FORM='FORMATTED',
  58.      + CARRIAGECONTROL='LIST',READONLY,DISPOSE='SAVE')
  59.       READ(2,1) IL,(TELNO(I),I=1,IL)
  60.       TELNO(IL+1)=0
  61.     1 FORMAT(Q,40A1)
  62. C
  63. C     SECOND LINE OF CONFIGURATION FILE HAS PORT NUMBER IN FIRST
  64. C     TWO PLACES FOLLOWED BY AS MANY OPERATION CODE LETTERS AS
  65. C     NEEDED
  66. C
  67.       READ(2,2) IPORT,IL,(PARAM(I),I=1,IL)
  68.     2 FORMAT(O2,Q,10A1)
  69. C
  70. C     NOW SET OPERATION USING SPECIFIED PARAMETERS
  71. C
  72. C     TURN OFF MS BIT OF EACH CHARACTER AND CONVERT
  73. C     TO UPPER CASE FOR COMPARISON
  74. C
  75.       IF(IL .GE. 1) THEN
  76.       DO 3 I=1,IL
  77.       IF(PARAM(I) .LT. 0) PARAM(I) = PARAM(I) + '200'O
  78.       IF(PARAM(I) .GT. '140'O) PARAM(I)=PARAM(I) - '40'O
  79.       IF(PARAM(I) .EQ. 'L') ILIST=1
  80.       IF(PARAM(I) .EQ. 'A') IARC=1
  81.       IF(PARAM(I) .EQ. 'C') ICHK=1
  82.       IF(PARAM(I) .EQ. 'S') ISET=1
  83.       IF(PARAM(I) .EQ. 'D') IDEBUG=1
  84.       IF(PARAM(I) .EQ. 'R') IRATE=1
  85.     3 CONTINUE
  86.       ENDIF
  87. C
  88. C     THIRD LINE OF CONFIGURATION FILE HAS TIME ZONE AS 
  89. C     LETTER P/p Pacific
  90. C            M/m Mountain
  91. C            C/c Central
  92. C            E/e Eastern
  93. C            Z/z Greenwich 
  94. C     or as (signed) number: +/- j, giving difference between
  95. C     local time and Greenwich.  Locations West of Greenwich are
  96. C     negative, East are Positive.
  97. C
  98. C     optional trailing D/d, specifies conversion to Daylight 
  99. C     savings time if present.
  100. C
  101.       READ(2,4) IL,(PARAM(I),I=1,IL)
  102.     4 FORMAT(Q,10A1)
  103.       DO 5 I=1,IL
  104.       IF(PARAM(I) .LT. 0) PARAM(I) = PARAM(I) + 128
  105.       IF(PARAM(I) .GT. '140'O) PARAM(I)=PARAM(I) - '40'O
  106.     5 CONTINUE
  107.       DO 9 I=IL+1,10
  108.       PARAM(I) = 0
  109.     9 CONTINUE
  110. C
  111. C    IF FIRST CHARACTER IS A ZONE LETTER THEN DECODE IT
  112. C    AND CHECK IF SECOND CHARACTER IS DAYLIGHT SAVINGS FLAG
  113. C   
  114. C    IF FIRST CHARACTER IS A SIGN OR DIGIT, THEN PARSE NUMBER
  115. C
  116.       IF(PARAM(1) .EQ. 'P') THEN
  117.         IUTDIF=-8
  118.       ELSEIF(PARAM(1) .EQ. 'M') THEN
  119.         IUTDIF=-7
  120.       ELSEIF(PARAM(1) .EQ. 'C') THEN
  121.         IUTDIF=-6
  122.       ELSEIF(PARAM(1) .EQ. 'E') THEN
  123.         IUTDIF=-5
  124.       ELSEIF(PARAM(1) .EQ. 'Z') THEN
  125.         IUTDIF=0
  126.       ELSEIF(PARAM(1) .EQ. '-') THEN
  127.         ISIGN=-1
  128.         IUTDIF=0
  129.         GO TO 6
  130.       ELSEIF(PARAM(1) .EQ. '+') THEN
  131.         ISIGN=+1
  132.         IUTDIF=0
  133.         GO TO 6
  134.       ELSEIF((PARAM(1).GE. '0').AND. (PARAM(1).LE. '9'))THEN
  135.         ISIGN=+1
  136.         IUTDIF=(PARAM(1) - '0')
  137.         GO TO 6
  138.       ELSE
  139.         TYPE 7
  140.     7 FORMAT(' Error on third line of configuration file.')
  141.       STOP
  142.       ENDIF
  143.       IS=2
  144.       GO TO 11
  145. C
  146. C    COME HERE IF FIRST CHARACTER WAS SIGN OR DIGIT -- PARSE
  147. C    FOLLOWING CHARACTERS AS UTC OFFSET AS NUMBER
  148. C
  149.     6 IS=2
  150.       IF( (PARAM(2) .GE. '0') .AND. (PARAM(2) .LE. '9'))THEN
  151.         IUTDIF= 10*IUTDIF + (PARAM(2) - '0')
  152.         IS=3
  153.       ENDIF
  154.       IF( (PARAM(3) .GE. '0') .AND. (PARAM(3) .LE. '9'))THEN
  155.         IUTDIF= 10*IUTDIF + (PARAM(3) - '0')
  156.         IS=4
  157.       ENDIF
  158.       IUTDIF=IUTDIF*ISIGN
  159.    11 IF(PARAM(IS) .EQ. 'D') THEN
  160.          IDST=1
  161.       ELSE
  162.          IDST=0
  163.       ENDIF
  164. C
  165.       CLOSE(UNIT=2,DISPOSE='SAVE')
  166. C
  167.       IF(IDEBUG .NE. 0) THEN
  168.       TYPE 18,ILIST,ICHK,IARC,ISET,IDEBUG,IRATE,
  169.      +  IPORT,TELNO,IUTDIF,IDST
  170.    18 FORMAT(' Operations Requested'/
  171.      + ' List ='I2' Check='I2' Archive='I2' Set='I2' Debug='I2/
  172.      + ' Rate ='I2/
  173.      + ' Port ='O2' Telephone Number='40A1/
  174.      + ' UTC offset='I5' Daylight Savings Flag='I2)
  175.       ENDIF
  176.       CALL ASNLUN(1,'TT',IPORT,IDS)
  177.       IF(IDS .NE. 1) CALL STPERR(100,IDS)
  178. C
  179. C     ATTEMPT ATTACH OF DIALER.  IF ATTACH FAILS TO COMPLETE IN 5
  180. C     SECONDS, SOMETHING IS WRONG -- SOMEBODY ELSE HAS THE DIALER
  181. C     IN THAT CASE EXIT WITH ERROR
  182. C
  183. C      ON THE OTHER HAND, IF ATTACH IS OKAY, THEN CANCEL MARK TIME
  184. C     REQUEST SINCE THAT EVENT FLAG WILL BE USED AGAIN LATER.
  185. C
  186.       CALL QIO(IOATT,1,1,,ISB,IPRL,IDS)
  187.       IF(IDS .NE. 1) CALL STPERR(1,IDS)
  188.       CALL MARK(3,5,2,IDS)
  189.       IF(IDS .NE. 1) CALL STPERR(21,IDS)
  190.       CALL WFLOR(1,3)
  191.       CALL READEF(3,IDS)
  192.       IF(IDS .EQ. 2) CALL STPERR(22,IDS)
  193.       CALL CANMT(3,IDS)
  194.       IF(IDS .NE. 1) CALL STPERR(23,IDS)
  195.       CALL GETADR(IPRL(1),IBB(1))
  196.       IPRL(2)=14
  197.       CALL WTQIO(ISFSMC,1,1,,ISB,IPRL,IDS)
  198. C
  199. C    IF SF.SMC IS OKAY THEN PROCEED. 
  200. C    IF SF.SMC IS NOT OKAY AND ERROR IS IN SPEED SET
  201. C     THEN PRINT MESSAGE AND WAIT FOR RESPONSE
  202. C
  203.       IF(ISB(1) .EQ. 1) GO TO 133
  204.       IF(ISB(2) .EQ. 10) THEN
  205.         TYPE 134
  206.   134   FORMAT('$Error -- can''t set speed of requested port.',
  207.      +         '  Proceed ? [y/n] =')
  208.       READ(5,124) IANS
  209.       IF(IANS .LT. 0) IANS= IANS + '200'O
  210.       IF(IANS .GT. '140'O) IANS=IANS - '40'O
  211.       IF(IANS .EQ. 'N') CALL STPERR(0,0)
  212.       ELSE
  213.         CALL STPERR(2,ISB)
  214.       ENDIF
  215. C
  216. C     IF RATE ESTIMATE TO BE MADE, GET LAST VALUE FROM FILE NOW
  217. C
  218.   133 IF(IRATE .NE. 0) CALL GETLST
  219. C
  220. C    IF FIRST DIGIT IS M THEN MANUAL DIALING IS REQUESTED
  221. C    PRINT MESSAGE AND WAIT
  222. C    OTHERWISE CALL DIALING SUBROUTINE
  223. C
  224.       IF(TELNO(1) .LT. 0) TELNO(1)= TELNO(1) + '200'O
  225.       IF( (TELNO(1) .EQ. 'M')  .OR.
  226.      +    (TELNO(1) .EQ. 'm') ) THEN
  227.       TYPE 123
  228.   123 FORMAT(' Dial telephone now. Enter'/
  229.      + '       y<cr> when connection is complete'/
  230.      + '       n<cr> if busy or no answer.')
  231.       TYPE 125
  232.   125 FORMAT('$Ans=')
  233.       READ(5,124) IANS
  234.   124 FORMAT(A1)
  235.       IF(IANS .LT. 0) IANS= IANS + '200'O
  236.       IF(IANS .GT. '140'O) IANS= IANS -'40'O
  237.       IF(IANS .EQ. 'N') CALL STPERR(0,0)
  238.       ELSE
  239.       CALL DIALIT(TELNO)
  240.       ENDIF
  241.       CALL RCVDAT
  242.       CALL HANGUP
  243.       CALL STPERR(0,0)
  244.       END
  245.       SUBROUTINE STPERR(J,JDS)
  246.       INTEGER*2 JDS(2)
  247. C
  248. C     FOLLOWING CODE DETACH PORT
  249. C
  250.       PARAMETER IODET='2000'O
  251. C
  252.       IF(J .NE. 0) TYPE 1,J,JDS
  253.     1 FORMAT(' ERROR 'I3' STATUS='O6,'SECOND STATUS='O6)
  254.       CLOSE(UNIT=2,DISPOSE='SAVE')
  255. C
  256.       CALL QIO(IODET,1,1)
  257.       CALL EXIT
  258.       END
  259.       SUBROUTINE RCVDAT
  260. C
  261. C     RECEIVES DATA FROM THE NIST ACTS SERVICE AND STORES T HE
  262. C     LINES IN A BUFFER.  UP TO 40 LINES ARE RECEIVED
  263. C
  264.       BYTE ILEN(20),LINES(80,20),IJJ
  265.       INTEGER*2 ISB(2),IPRL(6)
  266.       INTEGER*2 JSB(2),JPRL(6)
  267. C
  268.       COMMON/OPS/ ILIST,ICHK,IARC,ISET,IDEBUG,IRATE
  269. C
  270. C     IORNTA IS READ PASS ALL , NO ECHO WITH TIMEOUT
  271. C     IOWLB  IS WRITE LOGICAL BLOCK
  272. C
  273. C
  274.       PARAMETER IORNTA='1230'O,IOWLB='400'O
  275. C
  276. C     PARAMETER BLOCK USED FOR READING
  277. C
  278.       CALL GETADR(IPRL(1),IJJ)
  279.       IPRL(2)=1
  280.       IPRL(3)=1
  281. C
  282. C     PARAMETER BLOCK USED FOR ECHOING ON TIME MARKER
  283. C
  284.       CALL GETADR(JPRL(1),IJJ)
  285.       JPRL(2)=1
  286.       JPRL(3)=0
  287. C
  288.       DO 1 ILIN=1,20
  289. C
  290.       IJJK=0
  291.  9876 CALL WTQIO(IORNTA,1,1,,ISB,IPRL,IDS)
  292.       IF(IDS .NE. 1)CALL STPERR(102,IDS)
  293. C
  294. C     TERMINATE READ LOOP ON A TIMEOUT
  295. C
  296.       IF(ISB(1) .EQ. 2)  GO TO 2
  297. C
  298. C     IGNORE ALL OTHER ERRORS
  299. C
  300.       IF(IAND(ISB(1),"377) .NE. 1) GO TO 9876
  301.       IJJ=IJJ .AND. '177'O
  302.       IF(IJJ .EQ. '15'O) THEN
  303.       ILEN(ILIN)=IJJK
  304. D     WRITE(4,5252) (LINES(MM,ILIN),MM=1,IJJK)
  305. D5252 FORMAT(1X,80A1)
  306.       GO TO 1
  307.       ENDIF
  308.       IF(IJJ .LT. '40'O) GO TO 9876
  309.       IJJK=IJJK+1
  310.       LINES(IJJK,ILIN)=IJJ
  311.       IF( (IJJ .EQ. '*') .OR. (IJJ .EQ. '#') ) THEN
  312.       CALL QIO(IOWLB,1,2,,JSB,JPRL)
  313.       ENDIF
  314.       IF( IJJ .EQ. '#') CALL PARSET(LINES(1,ILIN),MMSTAT)
  315.       IF(MMSTAT .EQ. 0) GO TO 9876
  316.       ILEN(ILIN)=IJJK
  317.       GO TO 33
  318.     1 CONTINUE
  319.       ILIN=21
  320.     2 ILIN=ILIN-1
  321.    33 IF(ILIST .NE. 0) THEN
  322.       DO 5544 I=1,ILIN
  323.       MM=ILEN(I)
  324.       TYPE 5545, (LINES(NN,I),NN=1,MM)
  325.  5545 FORMAT(1X,80A1)
  326.  5544 CONTINUE
  327.       ENDIF
  328.       RETURN
  329.       END
  330.       SUBROUTINE PARSET(BUF,MMSTAT)
  331. C
  332. C     RECEIVES A LINE FROM NIST AND PARSES IT TO EXTRACT TIME
  333. C     IF SECOND IS TOO NEAR END OF MINUTE, WAIT FOR NEW MINUTE
  334. C     CHECKS THAT TIME OF TWO CONSECUTIVE LINES DIFFER BY
  335. C     EXACTLY ONE SECOND
  336. C
  337.       COMMON/OPS/ILIST,ICHK,IARC,ISET,IDEBUG,IRATE
  338. C
  339. C     COMMON BLOCK LVAL HOLDS PREVIOUS VALUES READ FROM ARCHIVE FILE
  340. C     FOR RATE ESTIMATE IF REQUESTED
  341. C
  342.       COMMON/LVAL/IPYR,IPMO,IPDY,IPHR,IPMIN,IPSEC,PDIFF,CUNIT
  343.       BYTE CUNIT
  344. C
  345.       REAL*8 SDIFF
  346.       DATA IYR / 0 /
  347.       BYTE BUF(80)
  348.       INTEGER*2 ISYS(8),JSYS(8)
  349.       INTEGER*2 MON(12)
  350.       DATA MON /0,31,59,90,120,151,181,212,243,273,304,334/
  351. C
  352. C     MMSTAT SETS RETURN STATUS.  IF MMSTAT=0 CONTINUE, =1 FINISHED
  353. C
  354.       MMSTAT=0
  355.       DO 1 I=1,80
  356.       IF(BUF(I) .EQ. '-') GO TO 2
  357.     1 CONTINUE
  358.       RETURN
  359.     2 IF(IYR .EQ. 0) THEN
  360.       IYR=10*(BUF(I-2) - '0')  + (BUF(I-1) - '0')
  361.       IMO=10*(BUF(I+1) - '0')  + (BUF(I+2) - '0')
  362.       IDY=10*(BUF(I+4) - '0')  + (BUF(I+5) - '0')
  363.       IHR=10*(BUF(I+7) - '0')  + (BUF(I+8) - '0')
  364.       IMN=10*(BUF(I+10)- '0')  + (BUF(I+11)- '0')
  365.       ISC=10*(BUF(I+13)- '0')  + (BUF(I+14)- '0')
  366.       IDS=10*(BUF(I+16)- '0')  + (BUF(I+17)- '0')
  367.       IF(IDEBUG .NE. 0) TYPE 3, IYR,IMO,IDY,IHR,IMN,ISC,IDS
  368.     3 FORMAT(7I4)
  369. C
  370. C     IF NEAR END OF MINUTE, SET IYR =0 SO THIS PORTION
  371. C     WILL BE REPEATED IN NEW MINUTE
  372. C
  373.       IF(ISC .GT. 57) IYR=0
  374.       RETURN
  375.       ENDIF
  376. C
  377. C    IF WE GET HERE THIS MUST BE SECOND TIME THROUGH
  378. C    GET THIS TIME AND COMPARE WITH PREVIOUS LINE
  379. C
  380.       JYR=10*(BUF(I-2) - '0')  + (BUF(I-1) - '0')
  381.       JMO=10*(BUF(I+1) - '0')  + (BUF(I+2) - '0')
  382.       JDY=10*(BUF(I+4) - '0')  + (BUF(I+5) - '0')
  383.       JHR=10*(BUF(I+7) - '0')  + (BUF(I+8) - '0')
  384.       JMN=10*(BUF(I+10)- '0')  + (BUF(I+11)- '0')
  385.       JSC=10*(BUF(I+13)- '0')  + (BUF(I+14)- '0')
  386.       JDS=10*(BUF(I+16)- '0')  + (BUF(I+17)- '0')
  387.       IF(IDEBUG .NE. 0) TYPE 3, JYR,JMO,JDY,JHR,JMN,JSC,JDS
  388. C
  389. C    IF TWO LINES NOT CONSECUTIVE SET IYR=0 SO ENTIRE PROCESS
  390. C    WILL BE REPEATED WITH NEXT TWO LINES
  391. C
  392.       IF(  (IYR .NE. JYR)  .OR.
  393.      +     (IMO .NE. JMO)  .OR.
  394.      +     (IDY .NE. JDY)  .OR.
  395.      +     (IHR .NE. JHR)  .OR.
  396.      +     (IMN .NE. JMN)  .OR.
  397.      +     (IDS .NE. JDS)  .OR.
  398.      +     (ISC .NE. (JSC -1))  ) THEN
  399.       IYR = 0
  400.       RETURN
  401.       ENDIF
  402. C
  403. C     IF CHECK OR ARC IS ENABLED, THEN 
  404. C     GET SYSTEM TIME FOR COMPARISONS
  405. C      
  406. C      WE NEED NUMBER OF TICKS PER SECOND FOR SET, BUT REST OF
  407. C      TIME WILL NOT BE USED
  408. C
  409.       CALL GETTIM(ISYS)
  410. C
  411. C     CONVERT RECEIVED TIME TO LOCAL TIME USING DAYLIGHT SAVINGS
  412. C     TIME FLAG IF REQUESTED.  THIS MUST BE DONE BEFORE SYSTEM CAN
  413. C     BE SET OR TIME COMPARED
  414. C
  415. C     NOTE THAT CONVERSION TO LOCAL TIME CANNOT CHANGE MINUTE OR
  416. C     SECOND AND THAT THEY ARE CORRECT NOW
  417. C
  418.       CALL CVTLCL(JYR,JMO,JDY,JHR,JDS)
  419. C
  420. C     IF SET ENABLED THEN SET THE TIME NOW
  421. C
  422.       IF(ISET .NE. 0) THEN
  423.       JSYS(1)=JYR
  424.       JSYS(2)=JMO
  425.       JSYS(3)=JDY
  426.       JSYS(4)=JHR
  427.       JSYS(5)=JMN
  428.       JSYS(6)=JSC
  429.       JSYS(7)=0
  430.       JSYS(8)=ISYS(8)
  431.       CALL SETTIM(JSYS)
  432.       ENDIF
  433. C
  434. C     NOW DEAL WITH COMPARING NIST AND SYSTEM TIMES
  435. C
  436. C     IF ICHK, IARC, IRATE ARE ZERO, THEN WE ARE FINISHED.
  437. C
  438.       IF( (ICHK .EQ. 0) .AND. 
  439.      +    (IARC .EQ. 0) .AND.
  440.      +    (IRATE .EQ. 0) )GO TO 77
  441. C
  442. C    GET ELAPSED TIME SINCE LAST COMPARISON IF RATE ESTIMATE REQUESTED
  443. C
  444.       IF(IRATE .NE. 0) THEN
  445.       ELAPSE=365.*(JYR - IPYR) + MON(JMO) - MON(IPMO)
  446.       IF( ( (JYR .AND. 3) .EQ. 0) .AND. 
  447.      +    (  JMO          .GT. 2) ) ELAPSE=ELAPSE + 1.
  448.       IF( ( (IPYR.AND. 3) .EQ. 0) .AND.
  449.      +    (  IPMO         .GT. 2) ) ELAPSE=ELAPSE - 1.
  450.       ELAPSE=ELAPSE + (JDY - IPDY) +
  451.      +                (JHR - IPHR)/24.D+0 + 
  452.      +                (JMN - IPMIN)/1440.D+0 +
  453.      +                (JSC - IPSEC)/86400.D+0
  454.       IF(CUNIT .EQ. 'D') THEN
  455.         SDIFF=86400.D+0*PDIFF
  456.       ELSEIF(CUNIT .EQ. 'H') THEN
  457.         SDIFF=3600.D+0*PDIFF
  458.       ELSEIF(CUNIT .EQ. 'M') THEN
  459.         SDIFF=60.D+0*PDIFF
  460.       ELSEIF(CUNIT .EQ. 'S') THEN
  461.         SDIFF=PDIFF
  462.       ELSEIF(CUNIT .EQ. 'T') THEN
  463.         SDIFF=PDIFF/ISYS(8)
  464.       ENDIF
  465.       IF(IDEBUG .NE. 0) TYPE 5555,ELAPSE,SDIFF
  466.  5555 FORMAT(1X,F9.4' Days since last comparison which was 'F8.3' sec.')
  467.       ENDIF
  468.       IFRACT=(100.*FLOAT(ISYS(7)))/FLOAT(ISYS(8))
  469.       IDIFF=ISYS(1) - JYR
  470.       IF( ABS(IDIFF) .GT. 1) THEN
  471.       QDIFF=IDIFF
  472.       MDIFF='yr'
  473.       IF(IRATE .NE. 0)SDIFF=(31536000.D+0*QDIFF - SDIFF)/ELAPSE
  474.       GO TO 47
  475.       ENDIF
  476.       III=ISYS(2)
  477.       IDIFF=365*IDIFF + MON(III) - MON(JMO) + ISYS(3) - JDY
  478.       IF( ((JYR .AND. 3) .EQ. 0)  .AND. (JMO .GT. 2))IDIFF=IDIFF-1
  479.       IF( ((ISYS(1).AND.3).EQ.0) .AND. (ISYS(2) .GT.2))IDIFF=IDIFF+1
  480.       IF( ABS(IDIFF) .GT. 1) THEN
  481.       QDIFF=IDIFF
  482.       MDIFF='dy'
  483.       IF(IRATE .NE. 0) SDIFF=(86400.D+0*QDIFF - SDIFF)/ELAPSE
  484.       GO TO 47
  485.       ENDIF
  486.       IDIFF=24*IDIFF + ISYS(4) - JHR
  487.       IF( ABS(IDIFF) .GT. 30) THEN
  488.       QDIFF=IDIFF
  489.       MDIFF='hr'
  490.       IF(IRATE .NE. 0) SDIFF=(3600.D+0*QDIFF - SDIFF)/ELAPSE
  491.       GO TO 47
  492.       ENDIF
  493.       IDIFF=60*IDIFF + ISYS(5) - JMN
  494.       IF( ABS(IDIFF) .GT. 100) THEN
  495.       QDIFF=IDIFF
  496.       MDIFF='m '
  497.       IF(IRATE .NE. 0) SDIFF=(60.D+0*QDIFF - SDIFF)/ELAPSE
  498.       GO TO 47
  499.       ENDIF
  500.       IDIFF=60*IDIFF + ISYS(6) - JSC
  501.       QDIFF=FLOAT(IDIFF) + FLOAT(IFRACT)/100.
  502.       MDIFF='s '
  503.       IF(IRATE .NE. 0) SDIFF=(QDIFF - SDIFF)/ELAPSE
  504.       IF( ABS(QDIFF) .GT. 1.) GO TO 47
  505.       QDIFF=FLOAT(ISYS(8))*QDIFF
  506.       MDIFF='tk'
  507.    47 IF(ICHK .NE. 0) THEN
  508.       TYPE 44,(ISYS(I),I=1,6),IFRACT
  509.    44 FORMAT(' System Time='I2'-'I2.2'-'I2.2,1X,I2.2':'I2.2':'I2.2'.'
  510.      +  I2.2)
  511.       TYPE 45,JYR,JMO,JDY,JHR,JMN,JSC
  512.    45 FORMAT(' NIST Time  ='I2'-'I2.2'-'I2.2,1X,I2.2':'I2.2':'I2.2,
  513.      + '.00')
  514.       IF(QDIFF .GE. 1.) THEN
  515.       TYPE 48,QDIFF,MDIFF
  516.       ELSEIF(QDIFF .LE. -1.) THEN
  517.       TYPE 49,-QDIFF,MDIFF
  518.       ELSE
  519.       TYPE 50
  520.       ENDIF
  521.    48 FORMAT(' System time fast by 'F6.2,A2)
  522.    49 FORMAT(' System time slow by 'F6.2,A2)
  523.    50 FORMAT(' System time correct to within 1 tick')
  524.       ENDIF
  525.       IF(IRATE .NE. 0) THEN
  526.       TYPE 5554,SDIFF
  527.  5554 FORMAT(' Approximate rate offset='F8.3' s/day.')
  528.       ENDIF
  529.       IF(IARC .NE. 0) THEN
  530.       OPEN(UNIT=2,NAME='NISTIME.DIF',TYPE='UNKNOWN',
  531.      + FORM='FORMATTED',ACCESS='APPEND',CARRIAGECONTROL='LIST',
  532.      + DISPOSE='SAVE')
  533.       WRITE(2,51) JYR,JMO,JDY,JHR,JMN,JSC,QDIFF,MDIFF
  534.    51 FORMAT(1X,SS,I2'-'I2.2'-'I2.2,1X,I2.2':'I2.2':'I2.2,1X,
  535.      + SP,F7.2,A2)
  536.       CLOSE(UNIT=2,DISPOSE='SAVE')
  537.       ENDIF
  538.    77 MMSTAT=1
  539.       RETURN
  540.       END
  541.       SUBROUTINE CVTLCL(JYR,JMO,JDY,JHR,JDS)
  542. C
  543. C     CONVERT RECEIVED TIME TO LOCAL TIME BASED ON CONSTANTS IN
  544. C     COMMON BLOCK /LOCAL/
  545. C
  546.       COMMON/LOCAL/IUTDIF,IDST
  547. C
  548. C    FOLLOWING ARRAY HOLDS LAST DAY OF EVERY MONTH
  549. C
  550.       INTEGER*2 LDAY(12)
  551.       DATA LDAY /31,28,31,30,31,30,31,31,30,31,30,31/
  552. C
  553. C     FEB HAS 29 DAYS IN A LEAP YEAR
  554. C
  555.       IF( (JYR .AND. 3) .EQ. 0) LDAY(2)=29
  556. C
  557. C     FIRST CONVERT HOURS TO LOCAL TIME
  558. C
  559.       JHR=JHR + IUTDIF
  560. C
  561. C     ADD DAYLIGHT SAVINGS TIME IF REQUESTED AND IF NEEDED
  562. C
  563. C     IF IDST NON ZERO THEN DST WAS REQUESTED
  564. C     IF JDS IS 2 - 50 INCLUSIVE WE ARE SOLIDLY IN DST
  565. C
  566. C     FLAG KDS SHOWS THAT CONVERSION TO DST HAS BEEN DONE
  567. C
  568.       IF( (IDST .NE. 0)  .AND.
  569.      +    (JDS  .LE.50)  .AND.
  570.      +    (JDS  .GT. 1)  ) THEN
  571.          JHR= JHR + 1
  572.          KDS=1
  573.       ELSE
  574.          KDS=0
  575.       ENDIF
  576. c
  577. c     if conversion to dst was requested and this is the
  578. c     Fall transition day and the transition time has not
  579. c     yet arrived, then we are still on dst.  note that
  580. c     the test uses jhr < 1 even though the transition is
  581. c     at 0200 since jhr has been converted to standard time
  582. c     above so that the transition time will arrive when jhr=1
  583. c
  584.       if( (idst .ne. 0) .and.
  585.      +    (jds  .eq. 1) .and.
  586.      +    (jhr  .lt. 1) ) then
  587.         jhr=jhr + 1
  588.         kds=1
  589.       endif
  590. C
  591. C
  592. C    NOW SEE IF CHANGING THE HOUR AFFECTED THE DAY
  593. C
  594. C    IF HOUR IS NEGATIVE, GO BACK TO PREVIOUS DAY
  595. C    AND THEN PROPAGATE BACKWARDS THROUGH MONTH AND YEAR IF NEEDED
  596. C
  597. C     SINCE THE DAYLIGHT SAVINGS TIME FLAG IS LINKED TO LOCAL TIME
  598. C     A CHANGE IN DAY/DATE MEANS A CHANGE IN FLAG.  THIS IS ONLY
  599. C     IMPORTANT IF WE ARE IN FACT ON A TRANSITION DAY.
  600. C
  601.       IF(JHR .LT. 0) THEN
  602.          JHR=JHR + 24
  603.          JDY=JDY - 1
  604.          JDS=JDS + 1
  605.          IF(JDY .LT. 1) THEN
  606.             JMO=JMO - 1
  607.             IF(JMO .LT. 1) THEN
  608.                JMO=12
  609.                JYR=JYR -1
  610.             ENDIF
  611.             JDY=LDAY(JMO)
  612.          ENDIF
  613.       ENDIF
  614.       IF(JHR .GT. 23) THEN
  615.          JHR=JHR - 24
  616.          JDY=JDY + 1
  617.          JDS=JDS - 1
  618.          IF(JDY .GT. LDAY(JMO)) THEN
  619.             JDY=1
  620.             JMO=JMO + 1
  621.             IF(JMO .GT. 12) THEN
  622.                JMO=1
  623.                JYR=JYR + 1
  624.             ENDIF
  625.          ENDIF
  626.       ENDIF
  627. C
  628. C    IF DST CONVERSION REQUESTED AND IF IT WAS NOT DONE BEFORE
  629. C    THEN NOW CHECK FOR CONVERSION ON TRANSITION DAYS  --
  630. C    AFTER 2 AM ON THE DAY DST STARTS AND BEFORE 2 AM ON THE DAY
  631. C    IT ENDS
  632. C
  633. c    since jhr is set above to standard time by default, the
  634. c    Fall conversion will actuall arrive at jhr=1
  635. C
  636.       IF( (IDST .NE. 0) .AND. (KDS .EQ. 0) ) THEN
  637.          IF( (JDS .EQ. 51) .AND. (JHR .GE. 2) ) JHR=JHR + 1
  638.          IF( (JDS .EQ.  1) .AND. (JHR .LT. 1) ) JHR=JHR + 1
  639.       ENDIF
  640.       RETURN
  641.       END
  642.       SUBROUTINE DIALIT(TELNO)
  643. C
  644. C     THIS SUBROUTINE DIALS A NUMBER USING HAYES COMMANDS
  645. C     THE DIALER IS CONNECTED VIA LUN 1
  646. C     
  647. C     THIS SUBROUTINE ASSUMES THAT THE CALLING TASK HAS
  648. C     PROPERLY SET THE SPEED AND PARITY OF THE LINE CONNECTED TO
  649. C     THE DIALER.
  650. C
  651.       PARAMETER IORNT="1220
  652.       PARAMETER IOWAL="410,ISFSMC="2440
  653.       PARAMETER IOWLB='400'O
  654. C
  655.       INTEGER*2 IPRL(6),ISB(2)
  656.       INTEGER*2 KPRL(6),KSB(2)
  657.       BYTE BUFI(80),BUFO(80)
  658.       BYTE IZ(4),TELNO(40)
  659. C
  660. C     THE FOLLOWING EQUIVALENCES ASSURE THAT THE BYTE ARRAYS
  661. C     USED FOR SET CHARACTERISTICS ARE WORD ALIGNED
  662. C
  663.       BYTE KBB(2)
  664.       EQUIVALENCE(KBB(1),KDUMMY)
  665. C
  666. C     IOPT IS THE OPTION COMMAND STRING FOR THE MODEM
  667. C
  668.       BYTE IOPT(12)
  669. C
  670. C     IZ IS MODEM INTIALIZE STRING
  671. C
  672.       DATA IZ / 'A','T','Z','15'O/
  673. C
  674. C     FOLLOWING CODE CLEARS TYPEAHEAD BUFFER WHEN USED IN SF.SMC
  675. C
  676.       DATA KBB / "71,0 /
  677.       DATA IOPT/ 'A','T',' ','E','1',' ','Q','0',' ','V','0','15'O/
  678. C
  679. C     SET UP K ARRAYS TO CLEAR BUFFER
  680. C
  681.       CALL GETADR(KPRL(1),KBB(1))
  682.       KPRL(2)=2
  683. C
  684. C     SEND RESET STRING TO MODEM
  685. C
  686.       CALL GETADR(IPRL(1),IZ)
  687.       IPRL(2)=4
  688.       IPRL(3)=0
  689.       CALL WTQIO(IOWLB,1,1,,ISB,IPRL,IDS)
  690.       IF(IDS .NE. 1) CALL STPERR(703,IDS)
  691.       IF(ISB(1) .NE. 1) CALL STPERR(704,ISB)
  692. C
  693. C    WAIT FOR MODEM TO FINISH RESET
  694. C
  695.       CALL WAIT(2,2)
  696. C
  697. C     NOW SET MODEM CHARACTERISTICS
  698. C
  699.       CALL GETADR(IPRL(1),IOPT(1))
  700.       IPRL(2)=11
  701.       IPRL(3)='53'O
  702.       CALL WTQIO(IOWLB,1,1,,ISB,IPRL,IDS)
  703.       IF(IDS .NE. 1) CALL STPERR(705,IDS)
  704.       IF( (ISB(1) .AND. '377'O) .NE. 1) CALL STPERR(706,ISB)
  705.       CALL WAIT(2,2)
  706. C
  707. C     CLEAR INPUT BUFFER
  708. C
  709.       CALL WTQIO(ISFSMC,1,1,,KSB,KPRL,KDS)
  710.       IF(KDS .NE. 1) CALL STPERR(707,KDS)
  711.       IF( (KSB(1) .AND. '377'O) .NE. 1) CALL STPERR(708,KSB)
  712. C
  713.       BUFO(1)='A'
  714.       BUFO(2)='T'
  715.       BUFO(3)='D'
  716.       IJ=3
  717.       DO 2 I=1,40
  718.       IF( TELNO(I) .EQ. 0) GO TO 22
  719.       IJ=IJ+1
  720.       BUFO(IJ)=TELNO(I)
  721.     2 CONTINUE
  722.    22 CALL GETADR(IPRL(1),BUFO(1))
  723.       IPRL(2)=IJ
  724.       IPRL(3)="53
  725.       CALL WTQIO(IOWLB,1,1,,ISB,IPRL,IDS)
  726.       IF(ISB(1) .NE. 1) CALL STPERR(3,ISB(1))
  727.       CALL GETADR(IPRL(1),BUFI(1))
  728.       IPRL(2)=70
  729.       IPRL(3)=10
  730.       ILIN=0
  731.   800 CALL WTQIO(IORNT,1,1,,ISB,IPRL,IDS)
  732. C
  733. C      IF THE RESPONSE READ BY THIS QIO IS 3,4,6,7 OR 8, THEN THE CALL DID
  734. C      NOT GO THROUGH -- WE HAVE A FATAL ERROR.  IF THE RESPONSE
  735. C      IS 1,5, OR 10, WE HAVE A LIFT OFF.  OTHER RESPONSES ARE
  736. C      INTERMEDIATE ONES OR ARE RESIDUES OF THE DIALING COMMANDS.
  737. C      IN THAT CASE GO BACK AND READ THE NEXT LINE
  738. C
  739.       ILIN=ILIN+1
  740. D     TYPE 801,ILIN,ISB,BUFI(1),BUFI(1)
  741. D 801 FORMAT(' ILIN,ISB,BUFI,BUFI='1X,I3,2O6,1X,A1,1X,O4)
  742. C
  743. C      IF ENDS ON A TIMEOUT THEN CALL ERROR
  744. C
  745.       IF( (ISB(1) .AND. '377'O) .EQ. 2) CALL STPERR(801,ISB)
  746. C  
  747. C     POSSIBLE INTERMEDIATE RESPONSES ARE 0 OR 2 OR A NON-DIGIT.
  748. C     IN THESE CASES GO BACK AND READ THE NEXT RESPONSE
  749. C
  750.       IF( (BUFI(1) .LT. '0') .OR. (BUFI(1) .GT. '9') .OR.
  751.      +    (BUFI(1) .EQ. '0') .OR. (BUFI(1) .EQ. '2') ) GO TO 800
  752. C
  753. C     ANY OTHER RESPONSE EXCEPT ON LINE IS BAD NEWS
  754. C
  755.       IF(ISB(2) .GT. 0)
  756.      +TYPE 888,(BUFI(K),K=1,ISB(2))
  757.   888 FORMAT(' MODEM ANSWER='40A1)
  758.       ISTAT=0
  759.       IF( (BUFI(1) .EQ. '1') .OR. (BUFI(1) .EQ. '5') )RETURN 
  760.       TYPE 887
  761.   887 FORMAT(' Exit -- No answer from NIST')
  762.       CALL STPERR(0,0)
  763.       END
  764.       SUBROUTINE HANGUP
  765. C
  766. C     HANGS UP THE DIALER.
  767. C
  768. C     THIS FOLLOWING CODE IS IO.WBT, I.E. A BREAKTHROUGH WRITE.
  769. C
  770.       PARAMETER IOWBT='500'O
  771. C
  772.       INTEGER *2 IPRL(6),ISB(2)
  773.       BYTE IQUIT(3),IHANG(3)
  774. C
  775.       DATA IQUIT / '+','+','+' /
  776.       DATA IHANG / 'A','T','H' /
  777. C
  778.       CALL WAIT(3,2)
  779.       CALL GETADR(IPRL(1),IQUIT)
  780.       IPRL(2)=3
  781.       IPRL(3)=0
  782.       CALL WTQIO(IOWBT,1,1,,ISB,IPRL,IDS)
  783.       CALL WAIT(3,2)
  784.       CALL GETADR(IPRL(1),IHANG)
  785.       IPRL(2)=3
  786.       IPRL(3)='53'O
  787.       CALL WTQIO(IOWBT,1,1,,ISB,IPRL,IDS)
  788.       RETURN
  789.       END
  790.       SUBROUTINE GETLST
  791. C
  792. C     THIS SUBROUTINE READS THE ARCHIVE FILE AND GETS THE
  793. C     LAST VALUE STORED THERE FOR SUBSEQUENT ESTIMATE OF 
  794. C     THE RATE OFFSET OF THE COMPUTER CLOCK
  795. C
  796.       COMMON/OPS/ILIST,ICHK,IARC,ISET,IDEBUG,IRATE
  797.       COMMON/LVAL/IPYR,IPMO,IPDY,IPHR,IPMIN,IPSEC,PDIFF,CUNIT
  798.       BYTE CUNIT
  799.       OPEN(UNIT=2,NAME='NISTIME.DIF',TYPE='OLD',ACCESS='SEQUENTIAL',
  800.      + FORM='FORMATTED',CARRIAGECONTROL='LIST',DISPOSE='SAVE',
  801.      + READONLY)
  802.       INUM=0
  803.     1 READ(2,2,END=3,ERR=5)IPYR,IPMO,IPDY,IPHR,IPMIN,IPSEC,
  804.      + PDIFF,CUNIT
  805.     2 FORMAT( 6(1X,I2),F8.2,A1)
  806.       INUM=INUM + 1
  807.       GO TO 1
  808.     5 TYPE 6,INUM
  809.     6 FORMAT(' GETLST -- Error reading archive file at line'I5)
  810.       CALL STPERR(50,INUM)
  811.     3 IF(IDEBUG .NE. 0) TYPE 7,INUM,IPYR,IPMO,IPDY,IPHR,IPMIN,IPSEC,
  812.      +   PDIFF,CUNIT
  813.     7 FORMAT(' Last values read from file at line' I2'=',
  814.      + 6(1X,I2),F7.2,A1)
  815. C
  816. C    CONVERT UNITS TO UPPER CASE IF NECESSARY
  817. C
  818.       IF(CUNIT .GT. '140'O) CUNIT= CUNIT - '40'O
  819.       CLOSE(UNIT=2)
  820.       RETURN
  821.       END
  822.