Task: Biorhythms








VB: Function Biorhythm(Birthdate As Date, Targetdate As Date) As String


TextArray = Array(Array("up and rising", "peak"), Array("up but falling", "transition"), Array("down and falling", "valley"), Array("down but rising", "transition"))

DaysBetween = Targetdate - Birthdate

positionP = DaysBetween Mod 23
positionE = DaysBetween Mod 28
positionM = DaysBetween Mod 33


Biorhythm = CStr(positionP) & "/" & CStr(positionE) & "/" & CStr(positionM)

quadrantP = Int(4 * positionP / 23)
quadrantE = Int(4 * positionE / 28)
quadrantM = Int(4 * positionM / 33)

percentageP = Round(100 * Sin(2 * WorksheetFunction.Pi * (positionP / 23)), 1)
percentageE = Round(100 * Sin(2 * WorksheetFunction.Pi * (positionE / 28)), 1)
percentageM = Round(100 * Sin(2 * WorksheetFunction.Pi * (positionM / 33)), 1)

transitionP = Targetdate + WorksheetFunction.Floor((quadrantP + 1) / 4 * 23, 1) - positionP
transitionE = Targetdate + WorksheetFunction.Floor((quadrantE + 1) / 4 * 28, 1) - positionE
transitionM = Targetdate + WorksheetFunction.Floor((quadrantM + 1) / 4 * 33, 1) - positionM

Select Case True
    Case percentageP > 95
        textP = "Physical day " & positionP & " : " & "peak"
    Case percentageP < -95
        textP = "Physical day " & positionP & " : " & "valley"
    Case percentageP < 5 And percentageP > -5
        textP = "Physical day " & positionP & " : " & "critical transition"
    Case Else
        textP = "Physical day " & positionP & " : " & percentageP & "% (" & TextArray(quadrantP)(0) & ", next " & TextArray(quadrantP)(1) & " " & transitionP & ")"
End Select

Select Case True
    Case percentageE > 95
        textE = "Emotional day " & positionE & " : " & "peak"
    Case percentageE < -95
        textE = "Emotional day " & positionE & " : " & "valley"
    Case percentageE < 5 And percentageE > -5
        textE = "Emotional day " & positionE & " : " & "critical transition"
    Case Else
        textE = "Emotional day " & positionE & " : " & percentageE & "% (" & TextArray(quadrantE)(0) & ", next " & TextArray(quadrantE)(1) & " " & transitionE & ")"
End Select

Select Case True
    Case percentageM > 95
        textM = "Mental day " & positionM & " : " & "peak"
    Case percentageM < -95
        textM = "Mental day " & positionM & " : " & "valley"
    Case percentageM < 5 And percentageM > -5
        textM = "Mental day " & positionM & " : " & "critical transition"
    Case Else
        textM = "Mental day " & positionM & " : " & percentageM & "% (" & TextArray(quadrantM)(0) & ", next " & TextArray(quadrantM)(1) & " " & transitionM & ")"
End Select

Header1Text = "Born " & Birthdate & ", Target " & Targetdate
Header2Text = "Day " & DaysBetween


Debug.Print Header1Text
Debug.Print Header2Text
Debug.Print textP
Debug.Print textE
Debug.Print textM
Debug.Print ""

End Function



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