INTEGER ONE,TWO,M,Y,D,NZER,BORN,DIF REAL OHYS,DPHYS,MENTAL,DMENT,EMO,DEMO INTEGER MTHS(12) DATA MTHS /'Jan','Feb','Mar','Apr','May','Jun','Jul', 1 'Aug','Sep','Oct','Nov','Dec'/ CHARACTER*10 DA CALL DATE(DA) READ(DA,FMT='I2,1X,A3,1X,I2') D,M1,Y M = -1 DO M2 = 1,12 IF( MTHS(M2) .EQ. M1 ) M = M2 END DO IF( M .EQ. -1) STOP 'BAD MONTH' ! TYPE 1000 !1000 FORMAT(' Start date (Month,Day,Year) ? ',$) ! ACCEPT 1001,M,D,Y 1001 FORMAT(3I) ! IF(Y.LT.1900) Y=Y+1900 CALL CON(1,Y,M,D,ONE) ! TYPE 1090 !1090 FORMAT(' End date (Month,Day,Year) ? ',$) ! ACCEPT 1001,M,D,Y ! IF(Y.LT.1900) Y=Y+1900 CALL CON(1,Y,M,D,TWO) ! TYPE 1010 !1010 FORMAT('+Your birthday ? ',$) OPEN(1,FILE='BIRTH.DAY',ERR=999) READ(1,1001,ERR=999)M,D,Y CLOSE(1) IF(Y.LT.1900) Y=Y+1900 CALL CON(1,Y,M,D,BORN) DO IDAY = ONE, TWO DIF = IDAY-BIRTH CALL CON(2,Y,M,D,IDAY) TYPE 1100,M,D,Y 1100 FORMAT(1X,I2,'/',I2,'/',I2, 1 T15,' Value',T25,' dV/dT') NZER = 0 CALL CALC(NZER,DIF,23,PHYS ,DPHYS) CALL CALC(NZER,DIF,33,MENTAL,DMENT) CALL CALC(NZER,DIF,28,EMO ,DEMO) AVG=(PHYS+EMO+MENTAL)/3. IF( NZER .EQ. 1 ) TYPE *,'ZERO DAY!' IF( NZER .EQ. 2 ) TYPE *,'DOUBLE ZERO DAY!!' IF( NZER .EQ. 3 ) TYPE *,'TRIPLE ZERO DAY!!!' TYPE 1020,PHYS, DPHYS TYPE 1030,EMO, DEMO TYPE 1040,MENTAL,DMENT TYPE 1050,AVG 1020 FORMAT(' Physical:',T15,F7.2,'%',T25,F7.2) 1030 FORMAT(' Emotional:',T15,F7.2,'%',T25,F7.2) 1040 FORMAT(' Mental:',T15,F7.2,'%',T25,F7.2) 1050 FORMAT(' Average:',T15,F7.2,'%',/) END DO CALL QUIETX CALL EXIT 999 STOP 'FILE BIRTH.DAY SHOULD CONTAIN M,D,Y' END ******** SUBROUTINE CALC(NZER,DIF,PD,PERCNT,DERIV) INTEGER NZER,DIF,PD REAL PERCNT,THETA,PI,DDRIV,DERIV,THETA1 DATA PI /3.141592653584626323/ THETA1 = MOD(DIF,PD) / FLOAT(PD) THETA = 2.*PI*THETA1 ! TYPE *,DIF,PD,THETA1,THETA PERCNT = SIN( THETA ) * 100. DERIV = COS( THETA ) * PD IF( ABS(PERCNT) .LT. .05 ) NZER = NZER + 1 END