SUBROUTINE FTN_ZILL_MOST_REPORT_SUB IMPLICIT NONE ! ! Create a report of numbers which are most frequently hit ! Both regular drawing numbers and MEGA numbers will be included ! INCLUDE 'MEGA_TEXT_LIB (FTN_MEGA_RECS)' INCLUDE '(LIB$ROUTINES)' INCLUDE '($FORIOSDEF)' C;;;;; C Constants we need C;;;;; INTEGER*1 K_RPT_CHAN, K_ELM_COUNT PARAMETER( K_RPT_CHAN=11, K_ELM_COUNT=52) INTEGER*1 K_DSTAT_CHAN, K_MSTAT_CHAN PARAMETER( K_DSTAT_CHAN=7, K_MSTAT_CHAN=8) CHARACTER*13 DRAWING_STATS CHARACTER*10 MEGA_STATS CHARACTER*13 RPT_FILE PARAMETER( DRAWING_STATS='DRAWING_STATS') PARAMETER( MEGA_STATS='MEGA_STATS') PARAMETER( RPT_FILE='ZILL_MOST.RPT') REAL ONE_SECOND PARAMETER( ONE_SECOND=1.0) C;;;;; C Local variables C;;;;; RECORD /ZILLIONARE_STATS_RECORD/D_STATS(K_ELM_COUNT) RECORD /ZILLIONARE_STATS_RECORD/M_STATS(K_ELM_COUNT) RECORD /ZILLIONARE_STATS_RECORD/SCRATCH_REC INTEGER*4 L_D_STAT, L_M_STAT INTEGER*1 B_SUB, B_LOC_COUNT, B_DONE, B_END, B_X CHARACTER*8 DATE_STR CHARACTER*255 COMMAND_STR C;;;;;;;;;; C Main Logic C;;;;;;;;;; 100 CALL FTN_FILL_IN_LOGICALS 105 OPEN (UNIT=K_RPT_CHAN, STATUS='NEW', 1 FILE=RPT_FILE, DISP='KEEP',FORM='FORMATTED', 2 CARRIAGECONTROL='LIST', RECL=80) 108 OPEN (UNIT=K_DSTAT_CHAN, 1 FILE=DRAWING_STATS, 2 STATUS='OLD', 3 ORGANIZATION='INDEXED', 4 ACCESS='KEYED', 5 RECORDTYPE='FIXED', 6 FORM='UNFORMATTED', 7 RECL=K_ZILLIONARE_STATS_RECORD_SIZE/4, 8 CARRIAGECONTROL='FORTRAN', 9 KEY=(1:4:INTEGER), 1 DISP='KEEP', 2 IOSTAT=L_D_STAT, 3 SHARED, 4 ERR=996) 109 OPEN (UNIT=K_MSTAT_CHAN, 1 FILE=MEGA_STATS, 2 STATUS='OLD', 3 ORGANIZATION='INDEXED', 4 ACCESS='KEYED', 5 RECORDTYPE='FIXED', 6 FORM='UNFORMATTED', 7 RECL=K_ZILLIONARE_STATS_RECORD_SIZE/4, 8 CARRIAGECONTROL='FORTRAN', 9 KEY=(1:4:INTEGER), 1 DISP='KEEP', 2 IOSTAT=L_M_STAT, 3 SHARED, 4 ERR=998) C;;;;;;;;;; C Load the Mega Stats using old GOTO logic C;;;;;;;;;; 110 B_SUB = 1 READ (K_DSTAT_CHAN, KEYGE=0, KEYID=0, IOSTAT=L_D_STAT) 1 D_STATS(B_SUB) IF (L_D_STAT .NE. 0) THEN PRINT *, 'Error ', L_D_STAT, 'Reading first D record' GO TO 1000 END IF 112 B_SUB = B_SUB + 1 B_LOC_COUNT = 0 114 READ (K_DSTAT_CHAN, IOSTAT=L_D_STAT, END=150) D_STATS( B_SUB) SELECT CASE (L_D_STAT) CASE (0) CONTINUE CASE (FOR$IOS_SPERECLOC) B_LOC_COUNT = B_LOC_COUNT + 1 IF (B_LOC_COUNT .LT. 100) THEN CALL LIB$WAIT( ONE_SECOND) GO TO 114 ELSE PRINT *, 'Error ', L_D_STAT, 'reading d_stat' GO TO 1000 END IF CASE DEFAULT PRINT *, 'Error ', L_D_STAT, 'reading d_stat' GO TO 1000 END SELECT GO TO 112 C;;;;; C Now load the Mega Stat records C;;;;; 150 B_SUB = 1 READ (K_MSTAT_CHAN, KEYGE=0, KEYID=0, IOSTAT=L_M_STAT) 1 M_STATS(B_SUB) IF (L_M_STAT .NE. 0) THEN PRINT *, 'Error ', L_M_STAT, 'Reading first M record' GO TO 1000 END IF 152 B_SUB = B_SUB + 1 B_LOC_COUNT = 0 154 READ (K_MSTAT_CHAN, IOSTAT=L_M_STAT,END=200) M_STATS( B_SUB) SELECT CASE (L_M_STAT) CASE (0) B_LOC_COUNT = 0 CONTINUE CASE (FOR$IOS_SPERECLOC) B_LOC_COUNT = B_LOC_COUNT + 1 IF (B_LOC_COUNT .LT. 100) THEN CALL LIB$WAIT( ONE_SECOND) GO TO 154 ELSE PRINT *, 'Error ', L_M_STAT, 'reading m_stat' GO TO 1000 END IF CASE DEFAULT PRINT *, 'Error ', L_M_STAT, 'reading m_stat' GO TO 1000 END SELECT GO TO 152 C;;;;; C Need to sort the arrays so they are descending by SINCE_LAST C;;;;; 200 B_DONE = 0 B_END = K_ELM_COUNT DO 210, WHILE (B_DONE .EQ. 0) B_X = 1 B_DONE = 1 DO 208, WHILE (B_X .LT. B_END) IF ( M_STATS( B_X).HIT_COUNT .LT. 1 M_STATS(B_X+1).HIT_COUNT) THEN B_DONE = 0 SCRATCH_REC = M_STATS(B_X) M_STATS(B_X) = M_STATS(B_X+1) M_STATS(B_X+1) = SCRATCH_REC END IF B_X = B_X + 1 208 CONTINUE ! ! At the end of each pass through this loop ! the smallest SINCE_LAST value will be at the ! bottom of the array. No since looking at it again. ! B_END = B_END - 1 210 CONTINUE 250 B_DONE = 0 B_END = K_ELM_COUNT DO 260, WHILE (B_DONE .EQ. 0) B_X = 1 B_DONE = 1 DO 258, WHILE (B_X .LT. B_END) IF ( D_STATS( B_X).HIT_COUNT .LT. 1 D_STATS(B_X+1).HIT_COUNT) THEN B_DONE = 0 SCRATCH_REC = D_STATS(B_X) D_STATS(B_X) = D_STATS(B_X+1) D_STATS(B_X+1) = SCRATCH_REC END IF B_X = B_X + 1 258 CONTINUE ! ! At the end of each pass through this loop ! the smallest SINCE_LAST value will be at the ! bottom of the array. No since looking at it again. ! B_END = B_END - 1 260 CONTINUE C;;;;;;;;;; C Generate the report. C;;;;;;;;;; ! ! Page title ! 300 CALL DATE_AND_TIME( DATE_STR) WRITE (UNIT=K_RPT_CHAN, FMT=302) DATE_STR(5:6), 1 DATE_STR(7:8), DATE_STR(1:4), 1 302 FORMAT ('DATE: ',A2,'/',A2,'/',A4, T29, 1 'Most Hit Numbers Report', T71, 'Page: ', I3) WRITE (UNIT=K_RPT_CHAN, FMT='(A)') ' ' WRITE (UNIT=K_RPT_CHAN, FMT='(T29, A)') 'Regular Drawing Numbers' WRITE (UNIT=K_RPT_CHAN, FMT='(A)') ' ' WRITE (UNIT=K_RPT_CHAN, FMT='(A)') ' ' C C Column headings C WRITE (UNIT=K_RPT_CHAN, FMT='(A)') 1 'No Hits Since Pct_hits Ave_btwn' WRITE (UNIT=K_RPT_CHAN, FMT='(A)') 1 '-- ---- ----- -------- --------' DO 312, B_SUB=1,10,1 WRITE (UNIT=K_RPT_CHAN, FMT=306) 1 D_STATS(B_SUB).ELM_NO, 2 D_STATS(B_SUB).HIT_COUNT, 3 D_STATS(B_SUB).SINCE_LAST, 4 D_STATS(B_SUB).PCT_HITS, 5 D_STATS(B_SUB).AVE_BTWN 306 FORMAT (I2,3X,I4,3X,I4,5X,F7.3,4X,F7.3) 312 CONTINUE ! ! Second page for Mega numbers ! WRITE (UNIT=K_RPT_CHAN, FMT='(A)') CHAR( 12) WRITE (UNIT=K_RPT_CHAN, FMT=302) DATE_STR(5:6), 1 DATE_STR(7:8), DATE_STR(1:4), 2 WRITE (UNIT=K_RPT_CHAN, FMT='(A)') ' ' WRITE (UNIT=K_RPT_CHAN, FMT='(T34, A)') 'Mega Numbers' WRITE (UNIT=K_RPT_CHAN, FMT='(A)') ' ' WRITE (UNIT=K_RPT_CHAN, FMT='(A)') ' ' C C Column headings C WRITE (UNIT=K_RPT_CHAN, FMT='(A)') 1 'No Hits Since Pct_hits Ave_btwn' WRITE (UNIT=K_RPT_CHAN, FMT='(A)') 1 '-- ---- ----- -------- --------' DO 349, B_SUB=1,10,1 WRITE (UNIT=K_RPT_CHAN, FMT=306) 1 M_STATS(B_SUB).ELM_NO, 2 M_STATS(B_SUB).HIT_COUNT, 3 M_STATS(B_SUB).SINCE_LAST, 4 M_STATS(B_SUB).PCT_HITS, 5 M_STATS(B_SUB).AVE_BTWN 349 CONTINUE GO TO 1000 C;;;;; C Error handling C;;;;; 996 PRINT *, 'Error ',L_D_STAT, ' writing drawing stats' GO TO 1000 998 PRINT *, 'Error ',L_M_STAT, ' writing mega stats' GO TO 1000 1000 CLOSE( K_DSTAT_CHAN) CLOSE( K_MSTAT_CHAN) CLOSE( K_RPT_CHAN) COMMAND_STR = 'EDIT/READ '//RPT_FILE CALL LIB$SPAWN( COMMAND_STR,,0) RETURN END