Download code

Jump to: navigation, search

Back to Julian_days_(QBASIC)

Download for Windows: single file, zip

Download for UNIX: single file, zip, tar.gz, tar.bz2

julian.bas

  1 REM The authors of this work have released all rights to it and placed it
  2 REM in the public domain under the Creative Commons CC0 1.0 waiver
  3 REM (http://creativecommons.org/publicdomain/zero/1.0/).
  4 REM 
  5 REM THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  6 REM EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  7 REM MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  8 REM IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  9 REM CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
 10 REM TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
 11 REM SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 12 REM 
 13 REM Retrieved from: http://en.literateprograms.org/Julian_days_(QBASIC)?oldid=15472
 14 
 15 DECLARE FUNCTION JulianDay# (aISOdate AS STRING)
 16 DECLARE FUNCTION ISOday$ (aJulianDay AS DOUBLE)
 17 DECLARE FUNCTION AnISOdate% (aISOdate AS STRING)
 18 DECLARE FUNCTION US2ISOdate$ (aUSdate AS STRING)
 19 DECLARE FUNCTION ISO2USdate$ (aISOdate AS STRING)
 20 
 21 CLS
 22 LET TestDate$ = "02-28-1900": GOSUB PrintResult
 23 LET TestDate$ = "02-29-1900": GOSUB PrintResult
 24 LET TestDate$ = "03-01-1900": GOSUB PrintResult
 25 LET TestDate$ = "01-01-2000": GOSUB PrintResult
 26 LET TestDate$ = "02-28-2000": GOSUB PrintResult
 27 LET TestDate$ = "02-29-2000": GOSUB PrintResult
 28 LET TestDate$ = "03-01-2000": GOSUB PrintResult
 29 LET TestDate$ = "02-28-2004": GOSUB PrintResult
 30 LET TestDate$ = "02-29-2004": GOSUB PrintResult
 31 LET TestDate$ = "03-01-2004": GOSUB PrintResult
 32 LET TestDate$ = "12-31-2004": GOSUB PrintResult
 33 LET TestDate$ = "01-01-2005": GOSUB PrintResult
 34 LET TestDate$ = "12-31-2005": GOSUB PrintResult
 35 LET TestDate$ = "01-01-2006": GOSUB PrintResult
 36 LET TestDate$ = "01-31-2006": GOSUB PrintResult
 37 LET TestDate$ = "02-01-2006": GOSUB PrintResult
 38 LET TestDate$ = "02-28-2006": GOSUB PrintResult
 39 LET TestDate$ = "03-01-2006": GOSUB PrintResult
 40 LET TestDate$ = "03-31-2006": GOSUB PrintResult
 41 LET TestDate$ = "04-01-2006": GOSUB PrintResult
 42 LET TestDate$ = "04-30-2006": GOSUB PrintResult
 43 PRINT
 44 LET TestDate$ = DATE$: GOSUB PrintResult
 45 
 46 SYSTEM
 47 
 48 PrintResult:
 49    PRINT TestDate$,
 50    PRINT ISOdate$(TestDate$),
 51    PRINT JulianDay(ISOdate$(TestDate$)),
 52    PRINT ISOday(JulianDay(ISOdate$(TestDate$)))
 53    RETURN
 54 FUNCTION AnISOdate% (aISOdate AS STRING)
 55 
 56    DIM dTruth AS INTEGER
 57    DIM dYear AS STRING
 58    DIM dMonth AS STRING
 59    DIM dDay AS STRING
 60 
 61    LET dYear = MID$(aISOdate, 1, 4)
 62    LET dMonth = MID$(aISOdate, 5, 2)
 63    LET dDay = MID$(aISOdate, 7, 2)
 64 
 65    LET dTruth = (LEN(aISOdate) = 8)
 66    LET dTruth = dTruth AND (LTRIM$(STR$(ABS(VAL(dYear)))) = dYear)
 67    LET dTruth = dTruth AND (VAL(dMonth) >= 1 AND VAL(dMonth) <= 12)
 68    LET dTruth = dTruth AND (VAL(dDay) >= 1 AND VAL(dDay) <= 31)
 69 
 70    LET AnISOdate% = dTruth
 71 
 72 END FUNCTION
 73 FUNCTION US2ISOdate$ (aUSdate AS STRING)
 74 
 75    LET US2ISOdate$ = MID$(aUSdate, 7) + MID$(aUSdate, 1, 2) + MID$(aUSdate, 4, 2)
 76 
 77 END FUNCTION
 78 FUNCTION ISO2USdate$ (aISOdate AS STRING)
 79 
 80    LET ISO2USdate$ = MID$(aISOdate, 5, 2) + "-" + MID$(aISOdate, 7, 2) + "-" + MID$(aISOdate, 1, 4)
 81 
 82 END FUNCTION
 83 FUNCTION ISOday$ (aJulianDay AS DOUBLE)
 84 
 85    DIM dBaseDay AS LONG
 86    DIM G AS DOUBLE
 87    DIM dCentury AS LONG
 88    DIM B AS LONG
 89    DIM C AS LONG
 90    DIM dYear AS LONG
 91    DIM dMonth AS INTEGER
 92    DIM dDay AS INTEGER
 93 
 94    LET dBaseDay = INT(aJulianDay - 1721118.5#)
 95    LET G = dBaseDay - .25#
 96    LET dCentury = INT(G / 36524.25)
 97    LET B = dCentury - INT(dCentury / 4)
 98    LET dYear = INT((B + G) / 365.25)
 99    LET C = B + dBaseDay - INT(365.25 * dYear)
100    LET dMonth = (5 * C + 456) \ 153
101    LET dDay = C - (153 * dMonth - 457) \ 5
102    IF dMonth > 12 THEN
103       dYear = dYear + 1
104       dMonth = dMonth - 12
105    END IF
106 
107    LET ISOday$ = RIGHT$(STR$(10000 + dYear), 4) + RIGHT$(STR$(100 + dMonth), 2) + RIGHT$(STR$(100 + dDay), 2)
108 
109 END FUNCTION
110 FUNCTION JulianDay# (aISOdate AS STRING)
111 
112    DIM dDay AS LONG
113    DIM dMonth AS LONG
114    DIM dYear AS LONG
115 
116    LET dYear = VAL(MID$(aISOdate, 1, 4))
117    LET dMonth = VAL(MID$(aISOdate, 5, 2))
118    LET dDay = VAL(MID$(aISOdate, 7, 2))
119 
120    IF dMonth < 3 THEN
121       LET dMonth = dMonth + 12
122       LET dYear = dYear - 1
123    END IF
124 
125    LET JulianDay# = 1721118.5# + dDay + (153 * dMonth - 457) \ 5 + INT(365.25# * dYear) - INT(.01# * dYear) + INT(.0025# * dYear)
126 
127 END FUNCTION
128 


hijacker
hijacker
hijacker
hijacker