173 lines
4.9 KiB
Fortran
173 lines
4.9 KiB
Fortran
C ------------------------------------------------------------------
|
|
PROGRAM BIORHYTHM
|
|
C ------------------------------------------------------------------
|
|
DOUBLE PRECISION GETJD
|
|
CHARACTER*3 DOW
|
|
|
|
DOUBLE PRECISION JD0, JD1, JD2, PI2, DIF
|
|
|
|
INTEGER BYEAR, BMON, BDAY, TYEAR, TMON, TDAY
|
|
INTEGER I, J, PHY, EMO, MEN, NDAY, DNUM, YR, DOY
|
|
CHARACTER*3 DNAME
|
|
CHARACTER*1 GRID, ROW(65)
|
|
C ------------------------------------------------------------------
|
|
|
|
PI2 = ACOS(-1.0D0)*2.0D0
|
|
|
|
WRITE(*,*) 'ENTER YOUR BIRTHDAY YYYY MM DD'
|
|
READ(*,*) BYEAR, BMON, BDAY
|
|
|
|
WRITE(*,*) 'ENTER START DATE YYYY MM DD'
|
|
READ(*,*) TYEAR, TMON, TDAY
|
|
|
|
WRITE(*,*) 'ENTER NUMBER OF DAYS TO PLOT'
|
|
READ(*,*) NDAY
|
|
|
|
JD0 = GETJD( TYEAR, 1, 1 )
|
|
JD1 = GETJD( BYEAR, BMON, BDAY )
|
|
JD2 = GETJD( TYEAR, TMON, TDAY )
|
|
|
|
WRITE(*,1010)
|
|
WRITE(*,1000) DOW(JD1), INT( JD2-JD1 )
|
|
WRITE(*,1010)
|
|
WRITE(*,1020)
|
|
DO I=1,NDAY
|
|
DIF = JD2 - JD1
|
|
PHY = INT(3.3D1+3.2D1*SIN( PI2 * DIF / 2.3D1 ))
|
|
EMO = INT(3.3D1+3.2D1*SIN( PI2 * DIF / 2.8D1 ))
|
|
MEN = INT(3.3D1+3.2D1*SIN( PI2 * DIF / 3.3D1 ))
|
|
|
|
IF ( PHY.LT.1 ) PHY = 1
|
|
IF ( EMO.LT.1 ) EMO = 1
|
|
IF ( MEN.LT.1 ) MEN = 1
|
|
IF ( PHY.GT.65 ) PHY = 65
|
|
IF ( EMO.GT.65 ) EMO = 65
|
|
IF ( MEN.GT.65 ) MEN = 65
|
|
|
|
DNAME = DOW(JD2)
|
|
DOY = INT(JD2-JD0)+1
|
|
IF ( DNAME.EQ.'SUN' ) THEN
|
|
GRID = '.'
|
|
ELSE
|
|
GRID = ' '
|
|
END IF
|
|
DO J=1,65
|
|
ROW(J) = GRID
|
|
END DO
|
|
ROW(1) = '|'
|
|
ROW(17) = ':'
|
|
ROW(33) = '|'
|
|
ROW(49) = ':'
|
|
ROW(65) = '|'
|
|
ROW(PHY) = 'P'
|
|
ROW(EMO) = 'E'
|
|
ROW(MEN) = 'M'
|
|
IF ( PHY.EQ.EMO ) ROW(PHY) = '*'
|
|
IF ( PHY.EQ.MEN ) ROW(PHY) = '*'
|
|
IF ( EMO.EQ.MEN ) ROW(EMO) = '*'
|
|
WRITE(*,1030) ROW,DNAME,DOY
|
|
JD2 = JD2 + 1.0D0
|
|
END DO
|
|
WRITE(*,1010)
|
|
|
|
C ------------------------------------------------------------------
|
|
|
|
1000 FORMAT( 'YOU WERE BORN ON A (', A3, ') YOU WERE ',I0,
|
|
$ ' DAYS OLD AT THE START.' )
|
|
1010 FORMAT( 75('=') )
|
|
1020 FORMAT( '-1',31X,'0',30X,'+1 DOY' )
|
|
1030 FORMAT( 1X,65A1, 1X, A3, 1X, I3 )
|
|
|
|
STOP
|
|
END
|
|
|
|
C ------------------------------------------------------------------
|
|
FUNCTION DOW( JD )
|
|
C ------------------------------------------------------------------
|
|
C RETURN THE ABBREVIATION FOR THE DAY OF THE WEEK
|
|
C JD JULIAN DATE - GREATER THAN 1721423.5 (JAN 1, 0001 SATURDAY)
|
|
C ------------------------------------------------------------------
|
|
DOUBLE PRECISION JD
|
|
INTEGER IDX
|
|
CHARACTER*3 DOW, NAMES(7)
|
|
DATA NAMES/'SAT','SUN','MON','TUE','WED','THR','FRI'/
|
|
|
|
IDX = INT(MODULO(JD-1.721423500D6,7.0D0)+1)
|
|
|
|
DOW = NAMES(IDX)
|
|
RETURN
|
|
END
|
|
|
|
C ------------------------------------------------------------------
|
|
FUNCTION ISGREG( Y, M, D )
|
|
C ------------------------------------------------------------------
|
|
C IS THIS DATE ON IN THE GREGORIAN CALENDAR
|
|
C DATES BEFORE OCT 5 1582 ARE JULIAN
|
|
C DATES AFTER OCT 14 1582 ARE GREGORIAN
|
|
C DATES OCT 5-14 1582 INCLUSIVE DO NOT EXIST
|
|
C ------------------------------------------------------------------
|
|
C YEAR 1-ANYTHING
|
|
C MONTH 1-12
|
|
C DAY 1-31
|
|
C ------------------------------------------------------------------
|
|
LOGICAL ISGREG
|
|
INTEGER Y, M, D
|
|
C ------------------------------------------------------------------
|
|
ISGREG=.TRUE.
|
|
IF ( Y.LT.1582 ) GOTO 888
|
|
IF ( Y.GT.1582 ) GOTO 999
|
|
IF ( M.LT.10 ) GOTO 888
|
|
IF ( M.GT.10 ) GOTO 999
|
|
IF ( D.LT.5 ) GOTO 888
|
|
IF ( D.GT.14 ) GOTO 999
|
|
|
|
WRITE(*,*) Y,M,D,' DOES NOT EXIST'
|
|
GOTO 999
|
|
|
|
888 CONTINUE
|
|
ISGREG=.FALSE.
|
|
999 CONTINUE
|
|
RETURN
|
|
END
|
|
|
|
C ------------------------------------------------------------------
|
|
FUNCTION GETJD( YEAR, MONTH, DAY )
|
|
C ------------------------------------------------------------------
|
|
C RETURN THE JULIAN DATE
|
|
C YEAR 1-ANYTHING
|
|
C MONTH 1-12
|
|
C DAY 1-31
|
|
C ------------------------------------------------------------------
|
|
DOUBLE PRECISION GETJD
|
|
INTEGER YEAR, MONTH, DAY
|
|
INTEGER Y, M, D, A, B, P1, P2
|
|
C ------------------------------------------------------------------
|
|
DOUBLE PRECISION TEMP
|
|
LOGICAL ISGREG, IG
|
|
|
|
IG = ISGREG( YEAR, MONTH, DAY )
|
|
Y = YEAR
|
|
M = MONTH
|
|
D = DAY
|
|
|
|
IF (M.LT.3) THEN
|
|
Y = Y - 1
|
|
M = M + 12
|
|
ENDIF
|
|
|
|
IF (IG) THEN
|
|
A = FLOOR( DBLE(Y) * 1.0D-2 )
|
|
B = 2 - A + FLOOR( DBLE(A) * 2.5D-1 )
|
|
ELSE
|
|
A = 0
|
|
B = 0
|
|
ENDIF
|
|
|
|
P1 = FLOOR( 3.65250D2 * DBLE(Y + 4716) )
|
|
P2 = FLOOR( 3.06001D1 * DBLE(M + 1) )
|
|
|
|
GETJD = DBLE(P1 + P2 + D + B) - 1.5245D3
|
|
|
|
RETURN
|
|
END
|