home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / ORBSRC14.ZIP / DATESUBS.BAS next >
Encoding:
BASIC Source File  |  1987-08-17  |  3.4 KB  |  118 lines
  1.     '* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  2.     '
  3.     '                  T U R B O   D A T E S U B S
  4.     '870816-4                                            Ron Dunbar, W0PN
  5.     '* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  6.     '- - - - Dates subroutine - - - - - - - - - - - - -
  7.  
  8.     ' INPUT: YEAR = Year (e.g. 83 for 1983)
  9.     '         MON = Month
  10.     '         DAY = Day of month
  11.     '
  12.     'OUTPUT: ADNR = elapsed days since 1978.0
  13.     '      ADNR11 = elapsed days from 1978.0 to 1/1/YEAR
  14.     '         DOW = day of week (0 - 6 with Sunday = 0)
  15.     '        DOW$ = string containing day of the week (i.e. " Monday")
  16.     '         DOY = day of the current year
  17.     '         DT$ = string containing MM/DD/YY with 1 leading space
  18.     '       GMST# = Greenwich Mean Sideral Time in days at 00:00 UT
  19.     '      JULIAN = Julian date (YYDOY)
  20.     '        STR# = Sideral Time Rate
  21.     '- - - - - - - - - - - - - - - - -
  22.  
  23. $static
  24.  
  25. dimarry:
  26.  
  27.     DIM dowtbl$(7)
  28.  
  29.     dowtbl$(0) ="Sunday"     :dowtbl$(1) ="Monday"
  30.     dowtbl$(2) ="Tuesday"    :dowtbl$(3) ="Wednesday"
  31.     dowtbl$(4) ="Thursday"   :dowtbl$(5) ="Friday"
  32.     dowtbl$(6) ="Saturday"
  33.  
  34. dimflag = 1            'indicate initialization complete
  35.  
  36. return
  37.  
  38.     '- - - Actual date subroutine - - -
  39.     '
  40. datecalc:
  41.     if dimflag <> 1 then gosub dimarry        'dim array 1st time thru only
  42.  
  43.     day = fix(day)
  44.     mon = fix(mon)
  45.     year= fix(year)
  46.  
  47.     DX#  = fix((YEAR-1)*365.25)
  48.     ADNR = fix(DAY)
  49.     YEAR = fix(YEAR)
  50.     MON  = fix(MON)
  51.  
  52.     IF MON > 2 THEN
  53.               ADNR = fix((MON+1)*30.6)+fix(YEAR*365.25)+ADNR-28553
  54.                ELSE
  55.           ADNR = fix((MON + 13) * 30.6) + DX#+ADNR - 28553
  56.     end if    
  57.  
  58.     dow    = fix(adnr MOD 7)
  59.     IF dow < 0 THEN dow = 0
  60.  
  61.     dow$   = dowtbl$(dow)
  62.     DT$    = STR$(MON) + "/"
  63.     wk9$   = STR$(DAY)+"/"   :DT$ = DT$+RIGHT$(wk9$,LEN(wk9$)-1)
  64.     wk9$   = STR$(YEAR)      :DT$ = DT$+RIGHT$(wk9$,LEN(wk9$)-1)
  65.     DOY    = fix(ADNR - DX# + 28125)
  66.     ADNR11 = ADNR - DOY + 1
  67.     JULIAN = (YEAR * 1000) + ADNR - ADNR11 + 1
  68.     AGMST  = ADNR11 - 1           'Jan 0.0, YEAR
  69.  
  70.  
  71.     GMST#   = AGMST * 0.0027379093# + AGMST *_
  72.               AGMST * 8.05975e-16 +.278586056#
  73.     GMST#   = GMST# - fix(GMST#)
  74.     STR#    = 1.00273790931# + 1.61195D-15 * ADNR
  75.     RETURN
  76.  
  77.     '- - - Inverse date subroutine - - -
  78.     '
  79.     ' INPUT:     ADNR = Elapsed days since 1978.0
  80.     'OUTPUT:     YEAR, MONth, DAY
  81.     '
  82.     'First, calc year = YEAR, month = MON
  83. adnr:
  84.     adnr1# = fix(adnr)
  85.     adnr = fix(adnr1#)
  86.     YEAR = fix((ADNR + 731) / 365.25) + 76
  87. julad:
  88.     MON  = ((ADNR + 28553 - fix(YEAR * 365.25)) / 30.61) - 1
  89.     IF MON > 2.1 OR (MON > 2.06 AND YEAR/4 = fix(YEAR/4))  THEN
  90.     MON = fix(MON)
  91.     ELSE
  92.     MON = 1
  93.     end if
  94.     '- - - now get day of month
  95.     TEMP = ADNR
  96.     DAY  = 1
  97.     GOSUB datecalc
  98.  
  99.     DAY  = TEMP - ADNR + 1
  100.     '- - - now recalculate everything and exit
  101.     GOSUB datecalc
  102.     RETURN
  103.  
  104.     '- - - This is the JULIAN entry point  - - -
  105.  
  106. julian:
  107.     julian1# = fix(julian)
  108.     julian = fix(julian1#)
  109.     YEAR = fix(JULIAN / 1000)
  110.     DOY  = fix(JULIAN - (YEAR * 1000))
  111.     ADNR = 429 + ((YEAR-1) * 365) + fix((YEAR-1)/4) - 28553 + fix(DOY) - 1
  112.     GOSUB julad                'go get the rest of the stuff
  113.  
  114.     RETURN
  115.  
  116.     '- - - - - - - - - - - - - - - - - - - - - -
  117.     '
  118.