rendered paste body! Biorythm July 23rd, 2009 10am
!
! ascgrid(y)(x)
!
! gfortran bio.f95 -o bio
!
program biorythm
implicit none
double precision, parameter :: PI=3.141592653589793238462643d0
double precision, parameter :: TP=2.0d0 * PI
double precision, parameter :: PT=PI / 2.0d0
double precision, parameter :: PE=Pi / 180.0d0
double precision, parameter :: GP=180.0d0 / PI
character(8) :: date
character(10) :: time
character(5) :: zone
integer, dimension(8) :: values
double precision :: mm, dd, yy;
double precision :: bm, bd, by;
double precision :: JD, j1, j2, age;
double precision :: pc, ec, ic;
double precision :: pd, q;
integer i;
integer n,c
character arg*80,astr*45,buffer*256
! Rely on PC to suppy current local date/time
call date_and_time(VALUES=values)
mm = DBLE(values(2))
dd = DBLE(values(3))
yy = DBLE(values(1))
n = iargc()
if (n == 3) then
call getarg(1, arg);
read(arg,*) bm ! Mondth get cmdline value (real8)
call getarg(2, arg);
read(arg,*) bd ! Day get cmdline value (real8)
call getarg(3, arg);
read(arg,*) by ! Full Year get cmdline value (real8)
! Calculate Days Alive
j1 = MDYtoJD(mm, dd, yy);
j2 = MDYtoJD(bm, bd, by);
age = abs(j1 - j2);
write(*,*) '**** Biorythm ****'
write(*,*) ''
write(*,*) 'Your Birth Sign is ',BirthSign(bm,bd)
write(*,"(A15,F7.1,A6)") 'You been alive ', age, ' days.'
write(*,"(A15,F7.1,A7)") 'You been alive ', age/365.25, ' years.'
! -------------------------------------------------------------------------
write(*,*) ''
write(*,*) 'Physical Cycle runs 23 days'
write(*,*) 'Emotional Cycle runs 28 days'
write(*,*) 'Intellectual Cycle runs 33 days'
write(*,*) ''
! -------------------------------------------------------------------------
pd = age ! Age in Days
do 150 i=1,30,1
! Calculate Actual Biorythm
pc = (360.0 * pd / 23.0); ! Physical Cycle (Red)
ec = (360.0 * pd / 28.0); ! Emotional Cycle (Green)
ic = (360.0 * pd / 33.0); ! Intellectual Cycle (Blue)
pc = fmod360(pc)
ec = fmod360(ec)
ic = fmod360(ic)
! write(*,*) INT(mm),Int(dd),Int(yy),'PC',pc,'EC',ec,'IC',ic
! write(*,"(I2,A1,I2,A1,I4,A4,F8.3,A4,F8.3,A4,F8.3)") &
! INT(mm),' ',Int(dd),' ',Int(yy),' PC ',pc,' EC ',ec,' IC ',ic
write(*,"(I2,A1,I2,A1,I4,A3,F7.3,A3,F7.3,A3,F7.3)") &
INT(mm),' ',Int(dd),' ',Int(yy),' P ',pc,' E ',ec,' I ',ic
pd = pd + i ! Period Day
JD = j1 + i ! Current Julian Day Increment
q = JDtoMDY(JD,mm,dd,yy) ! Julian Day to m,d,y
150 continue
! -------------------------------------------------------------------------
else
write(*,*) 'Error: improper number of aruments!'
write(*,*) 'Biorythm <Month> <Day> <Full Year>'
end if
contains
! Determine Birth-Sign
character*11 function BirthSign(m,d)
double precision, intent(in) :: m,d
character sign*11
if ( ((m==3.0) .and. (d>=21.0)) .or. ((m==4.0) .and. (d<=19.0)) ) sign = "Aries"
if ( ((m==4.0) .and. (d>=20.0)) .or. ((m==5.0) .and. (d<=20.0)) ) sign = "Taurus"
if ( ((m==5.0) .and. (d>=21.0)) .or. ((m==6.0) .and. (d<=20.0)) ) sign = "Gemini"
if ( ((m==6.0) .and. (d>=21.0)) .or. ((m==7.0) .and. (d<=22.0)) ) sign = "Cancer"
if ( ((m==7.0) .and. (d>=23.0)) .or. ((m==8.0) .and. (d<=22.0)) ) sign = "Leo"
if ( ((m==8.0) .and. (d>=23.0)) .or. ((m==9.0) .and. (d<=22.0)) ) sign = "Virgo"
if ( ((m==9.0) .and. (d>=23.0)) .or. ((m==10.0) .and. (d<=22.0)) ) sign = "Libra"
if ( ((m==10.0) .and. (d>=23.0)) .or. ((m==11.0) .and. (d<=21.0)) ) sign = "Scorpio"
if ( ((m==11.0) .and. (d>=22.0)) .or. ((m==12.0) .and. (d<=21.0)) ) sign = "Sagittarius"
if ( ((m==12.0) .and. (d>=22.0)) .or. ((m==1.0) .and. (d<=21.0)) ) sign = "Capricorn"
if ( ((m==1.0) .and. (d>=20.0)) .or. ((m==2.0) .and. (d<=18.0)) ) sign = "Aquarius"
if ( ((m==2.0) .and. (d>=19.0)) .or. ((m==3.0) .and. (d<=20.0)) ) sign = "Pices"
BirthSign = sign
end function BirthSign
double precision function fmod360(x)
double precision, intent(in) :: x
if (x .lt. 0.0d0) then
fmod360 = mod(x, 360.0d0) + 360.0d0
else
fmod360 = mod(x, 360.0d0)
end if
end function fmod360
double precision function fix(x)
double precision, intent(in) :: x
if (x .lt. 0.0d0) then
fix = ceiling(x)
else
fix = floor(x)
end if
end function fix
double precision function fnd(x)
double precision, intent(in) :: x
fnd = x - fix(x)
end function fnd
double precision function MDYtoJD(M,D,Y)
double precision, intent(in) :: M,D,Y
double precision :: q,mm,dd,yy
mm = M ! initialize to
yy = Y ! original values
if (M < 3.0d0) then
yy = yy - 1.0d0
mm = mm + 12.0d0
end if
q = fix(yy/100.0d0)
q = ( 2.0d0 - q + fix(q/4.0d0)) + fix(365.25d0 * yy) &
+ fix(30.6001d0 * (mm + 1.0d0)) + D + 1720994.5d0
MDYtoJD = q
end function MDYtoJD
double precision function JDtoMDY(JD,M,D,Y)
double precision, intent(in) :: JD
double precision, intent(out) :: M,D,Y
double precision :: c,g,e,f
c = fix(JD + 0.5d0) + 1537.0d0
g = fix( (c-122.1d0) / 365.25d0 )
e = fix(365.25d0 * g)
f = fix((c-e) / 30.6001d0)
D = c - e - fix(30.6001d0 * f) + ( (JD + 0.5d0) - fix(JD+0.5d0))
M = f - 1.0d0 - 12.0d0 * fix(f / 14.0d0)
Y = g - 4715.0d0 - fix( (7.0d0 + M )/10.0d0 );
JDtoMDY = Y
end function JDtoMDY
end program biorythm