github.com/PDP-10.stacken
1
0
Fork 0
mirror of https://github.com/PDP-10/stacken.git synced 2026-03-01 09:21:15 +00:00
Code Issues Projects Releases Wiki Activity
Files
master
PDP-10.stacken/files/games_interchange/play.for
Lars Brinkhoff 6e18f5ebef Extract files from tape images. 
Some tapes could not be extracted.
2021-01-29 10:47:33 +01:00

1801 lines
41 KiB
Fortran
Raw Permalink Blame History

COMMON CHKING,SAVING,LOAN,BALNC(9),OVERDU(9),PAYMNT(9),
1 ITEM(9),MONTH,CAR(3),INSUR(3),MIWORK(2),TOTMI(3),HOUSE(2),
2 NOMNTH(3),CALEND
C
DIMENSION IRAN(5),PERCNT(5),ANSWER(5),FSTNAM(9),
1 DESCRP(15,3),GROUP(5,2),RECORD(15),AVGCST(15),SPREAD(15)
2 ,MINMAL(3),RESPNS(10)
C
INTEGER STUNUM,FOLIO,CAR,HOUSE,SIZE,
1 SAVING,CHKING,EXPENS,EVENT,OVERDU,BALNC,PAYMNT,FIRST,FILSIZ
C
REAL MILES,LICENS,MIWORK,INSUR,NEWBLN
C
DOUBLE PRECISION VEHICL,ITEM,FILE,THING,CALEND
C
C ***SET RANDOM NUMBER GENERATOR
C
CALL TIME(ISET)
CALL SETRAN(ISET)
C
C ***GET STUDENT'S NAME
C
CALL CHECK(STUNUM,FSTNAM)
C
C ***READ IN STUDENT'S INFORMATION
C
CALL READ(STUNUM,FOLIO)
NNNNNN=STUNUM
C
C ***GET PAYCHECK AND PAY FOR FIXED EXPENSES
C
CALL FIXED(FOLIO)
C
C
C ***PAY CREDIT PURCHASES***
TYPE 10
10 FORMAT(' YOU WILL NOW BE ASKED TO PAY ON ANY CREDIT PURCHASES
1 YOU MAY HAVE MADE.',/)
C
FLAG=0.0
DO 100 I=1,9
IF (BALNC(I).EQ.0) GOTO 100
FLAG=FLAG+1
C
C *ADD 18% APR TO THE BILL
C
PREBLN=FLOAT(BALNC(I))/100.
P=FLOAT(PAYMNT(I))/100.
XINT=FLOAT(IFIX(PREBLN*1.5+.5))/100.
NEWBLN=PREBLN+XINT
BALNC(I)=IFIX(NEWBLN*100.+.5)
TYPE 20,I,ITEM(I),PREBLN,P,XINT,NEWBLN
20 FORMAT(' BILL #',I2,':',1X,A10,/
1 ' PREVIOUS BALNC =$',F7.2,2X,'MIN MONTHLY PAYMNT =$',F7.2,/
2 ' INTEREST CHARGED =$',F7.2,/
3 ' NEW BALNC =$',F7.2,/)
C
C *ASK FOR PAYMENT
C
25 TYPE 30,I
30 FORMAT(' AMOUNT YOU WILL PAY ON BILL # ',I1,'=$',$)
C
ACCEPT 32,RESPNS
32 FORMAT(12A1)
IF(.NOT.CORECT(RESPNS,2,AMOUNT)) GOTO 25
IF (BANK(AMOUNT)) GOTO 25
C
C *SEE IF PAID TOO MUCH,TOO LITTLE,OR PAID IT OFF.
C
IAMT=IFIX(AMOUNT*100.+.5)
IF(IAMT.LT.BALNC(I)) GOTO 40
IF (IAMT.EQ.BALNC(I)) GOTO 37
TYPE 35
35 FORMAT(' THAT''S TOO MUCH. PLEASE TRY AGAIN.'/)
GOTO 25
C
37 TYPE 38
38 FORMAT(/' THANK YOU. YOUR BILL IS NOW FULLY PAID'//)
BALNC(I)=0
PAYMNT(I)=0
OVERDU(I)=0
ITEM(I)='BLANK'
GOTO 48
C
C *IF PAID LESS THAN MINIMUM-SEE IF NEED TO REPOSSES--ELSE CONT.
C
40 BALNC(I)=BALNC(I)-IAMT
IF(IAMT.GE.PAYMNT(I)) GOTO 48
OVERDU(I)=OVERDU(I)+1
IF(OVERDU(I).LE.3) GOTO 48
C
C *SINCE OVERDU BY 3 MO.--DUN CHECKING FOR 1/2 BALNC
C *AND REPOSES THE ITEM IF POSSIBLE
C
DUN=FLOAT(IFIX(FLOAT(BALNC(I))/2.+.5))/100.
TYPE 42,ITEM(I),DUN
42 FORMAT(/' THE BILL ON ',A10,' HAS BEEN UNDERPAID TOO
1 LONG. YOUR'/' PAYCHECK HAS BEEN DUNED FOR $',F8.2,' AND IF
2 THE BILL WAS'/' FOR AN ITEM, IT HAS BEEN REPOSSESSED.'//)
BALNC(I)=0
PAYMNT(I)=0
OVERDU(I)=0
C
CALL UPDATE(DUN)
GOTO 100
C
48 CALL UPDATE(AMOUNT)
C
100 CONTINUE
C
C *IF NO BILLS SAY GREAT
C
IF (FLAG.NE.0.0) GOTO 130
TYPE 110
110 FORMAT(' YOU DO NOT HAVE ANY CREDIT PURCHASES AT THIS
1 TIME -- GREAT!!!',/)
C
C
C ***PAYMENT TO BANK FOR LOANS***
C
130 IF(LOAN.EQ.0) GOTO 200
PREBLN=FLOAT(LOAN)/100.
XINT=FLOAT(IFIX(PREBLN+.5))/100.
NEWBLN=PREBLN+XINT
LOAN=IFIX(NEWBLN*100.+.5)
C
TYPE 145,PREBLN,XINT,NEWBLN
145 FORMAT(/' YOU CAN NOW PAY ON YOUR BANK LOAN',/
1 ' PREVIOUS BALNC=$',F7.2,/
2 ' INTEREST AT 12%=$',F7.2,/
3 ' NEW BALNC=$',F7.2,/)
C
C *CALCULATE MINIMUM PAYMENT(THIS IS CRUDE)
C
IBILL=IFIX(FLOAT(LOAN)/30.+.5)
BILL=FLOAT(IBILL)/100.
C
150 TYPE 155,BILL
155 FORMAT(' YOU NEED TO PAY AT LEAST $',F7.2,' ON THIS LOAN.'/
1 ' PLEASE ENTER THE AMOUNT YOU WILL PAY: $',$)
C
ACCEPT 32,RESPNS
IF(.NOT.CORECT(RESPNS,2,AMOUNT)) GOTO 150
IAMT=IFIX(AMOUNT*100.+.5)
IF(BANK(AMOUNT)) GOTO 150
IF((IAMT.GE.IBILL).AND.(LOAN-IAMT.GE.0)) GOTO 180
TYPE 175
175 FORMAT(/' SORRY, YOU PAID EITHER TOO MUCH OR TOO
1 LITTLE. TRY AGAIN.'/)
GOTO 150
C
180 CALL UPDATE(AMOUNT)
LOAN=LOAN-IAMT
C
C ***FOOD AND BEVERAGE***
C
200 TYPE 300
300 FORMAT(' AT THIS TIME PLEASE TYPE THE')
310 TYPE 312
312 FORMAT(' AMOUNT YOU WILL SPEND FOR FOOD THIS MONTH? $',$)
C
ACCEPT 32,RESPNS
IF(.NOT.CORECT(RESPNS,2,AMOUNT)) GOTO 310
IF (BANK(AMOUNT)) GOTO 310
C
C *SEE IF BUDGETED ENOUGH-IF SO UPDATE CHKING-ELSE TRY AGAIN
C
CALL PORTFO(FOLIO,TAXREF,INCOME,FEDTAX,STATAX,RETIRE,
1 HEALTH,LIFE,UNION,FOOD)
C
315 IF (AMOUNT.GE.FOOD) GOTO 335
TYPE 320,AMOUNT,FOOD
320 FORMAT(/,' I AM SORRY. $',F6.2,' JUST IS NOT ENOUGH TO FEED
1 YOUR WHOLE FAMILY.',/,' YOU NEED TO SPEND AT LEAST $',F6.2,
2 ' TO FEED THEM ADEQUATELY.',//,' PLEASE RETYPE ',$)
C
GOTO 310
C
335 CALL UPDATE(AMOUNT)
C
C
C ***RANDOM HOUSEHOLD EXPENSES***
C
C *TYPE MESSAGE EXPLAINING THIS SECTION
C
GOTO 375
C
TYPE 350
350 FORMAT(//' HOLD ON!'//' YOU ARE ABOUT TO GET SOME EXPENSES
1 FOR YOUR HOUSE THAT '/' HAPPEN UNEXPECTADLY. IF YOU LIVE IN
2 AN APPARTMENT WHERE THESE'/' EXPENSES ARE COVERED, THEN
3 JUST TYPE IN A "0" WHEN ASKED TO'/' PAY FOR THE BILL. IF
4 THE ITEM IS COVERED BY A WARRANTY OF SOME'/' KIND, THEN JUST
5 TYPE IN THE DIFFERENCE IN THE AMOUNT THE WARRANTY'/' COVERS
6 AND WHAT YOU HAVE TO PAY.'//' IF YOU ARE LUCKY, THEN NOTHING
7 WILL HAPPEN TO YOU THIS MONTH.'//)
C
375 TYPE 376
376 FORMAT(' HOUSEHOLD EXPENSES')
C
C *SET UP VARIABLES TO BE SENT TO RANDOM NUMBER GENERATOR
C
C *NUMBER = NUMBER OF TIMES SOMETHING CAN HAPPEN IN A MONTH
C *IRAN(NUMBER)= THE RANDOM NUMBERS (CAN BE ZERO)
C *PERCNT(NUMBER)= % PROBABILITY SOMETHING WILL HAPPEN
C *FILSIZ=CURRENT FILE SIZE OF THE RANDOM HAPPENINGS
C
FILE='SHACK.FIL'
380 FILSIZ=SIZE(FILE)
CLOSE (UNIT=5)
IF(FILSIZ.EQ.0) GOTO 453
NUMBER=2
PERCNT(1)=90.
PERCNT(2)=10.
C
CALL RANDOM(NUMBER,PERCNT,IRAN,FILSIZ)
C
DO 450 I=1,NUMBER
C
C *SEE IF ANYTHING HAPPENS - IF SO PAY FOR IT ELSE CONT.
IF(IRAN(I).EQ.0) GOTO 450
C
FILSIZ=SIZE(FILE)
C
C *THE ABOVE STATEMENT IS NECESSARY TO REINITIALIZE THE
C *'SHACK.FIL'
C
IFILE=IRAN(I)
CALL TYPEIT(IFILE,THING,BILL1,RANGE,DOWNPY)
C
CALL PAYIT(AMOUNT,THING,BILL1,RANGE,DOWNPY)
C
450 CONTINUE
C
J=0
DO 452 I=1,NUMBER
C
452 J=J+IRAN(I)
C
IF (J.NE.0) GOTO 455
453 TYPE 454
454 FORMAT(//' YOU WERE LUCKY THIS MONTH--NOTHING HAPPENED')
C
C
C ***RECREATION***
C
C
C *MESSAGE FOR THE SECTION
C
455 TYPE 456
456 FORMAT(//' YOU WILL NOW BE ASKED TO ENTER THE AMOUNTS FROM
1 THE'/' WORKSHEET ON RECREATION.'/)
C
C *FIGURE TRANSPORTATION COSTS
C
470 TYPE 475
475 FORMAT(/' ENTER THE CURRENT PRICE OF GAS IN CENTS (EXAMPLE "53.9
1")? ',$)
C
ACCEPT 32,RESPNS
IF(.NOT.CORECT(RESPNS,2,GAS)) GOTO 470
IF(BANK(GAS)) GOTO 470
C
C ***CURRENT COST OF GAS--MAY HAVE TO BE CHANGED PERIODICALLY
C
IF(GAS.GE.48.9.AND.GAS.LE.70.9) GOTO 480
TYPE 478
478 FORMAT(' I THINK YOU GOOFED. PLEASE TRY AGAIN.'/)
GOTO 470
C **SET UP THE MINIMUM MILES FOR EACH CAR
C
480 I=0
DATA (MINMAL(I),I=1,3)/500,150,150/
C
C **GO THROUGH ALL THREE CAR POSSIBILITIES**
C
DO 530 I=1,3
IF(CAR(I).EQ.0) GOTO 530
N=CAR(I)
CALL AUTO(N,VEHICL,PAY,LICENS,CSTMI,AVGMPG,
1 WEIGHT,DESCRP,RECORD,AVGCST,SPREAD)
C
487 TYPE 488,VEHICL
488 FORMAT(/' NUMBER OF MILES ',A10,' WAS DRIVEN, OTHER THAN
1 WORK? ',$)
C
ACCEPT 32,RESPNS
IF(.NOT.CORECT(RESPNS,2,MILES)) GOTO 487
IF(BANK(MILES)) GOTO 487
C
C *SEE IF ENOUGH MILES
C
IF(MILES.GE.MINMAL(I)) GOTO 490
C *ELSE TYPE ERROR MESSAGE
C
TYPE 507
507 FORMAT(/' ARE YOU KIDDING? YOU CHEEPSKATE! CERTAINLY YOU
1 WENT OUT OF THE'/' HOUSE MORE THAN ONCE. LET''S TRY AGAIN.'/)
GOTO 487
C
490 COST=FLOAT(IFIX(MILES*CSTMI*100.+.5))/100.
CSTGAS=FLOAT(IFIX(GAS/100*MILES/AVGMPG*100+.5))/100
C
C ***PAY TRANSPORTATION COSTS FOR THIS VEHICLE
C
BILL=COST+CSTGAS
DOWNPY=0.
C
TYPE 514,MILES,VEHICL,COST,CSTGAS,BILL
514 FORMAT(' COST OF DRIVING ',F6.1,' MILES IN YOUR ',A10, ' FOR
1 RECREATION:'/
2 ' COST OF NORMAL MAINTENANCE =$',F7.2,/
3 ' COST OF GAS =$',F7.2,/
4 ' TOTAL =$',F7.2,/)
C
THING='GAS&MAINT.'
C
IF(CREDIT(AMOUNT,THING,BILL,DOWNPY)) GOTO 530
C
C *CASH FOR TRANSPORTATION
C
516 TYPE 517,BILL
517 FORMAT(/' PLEASE PAY $',F6.2,' AT THIS TIME : $',$)
C
ACCEPT 32,RESPNS
IF(.NOT.CORECT(RESPNS,2,AMOUNT)) GOTO 516
IF(BANK(AMOUNT)) GOTO 516
IF (ABS(AMOUNT-BILL).LT..001) GOTO 519
TYPE 518
518 FORMAT(' YOU DIDN''T ENTER EXACTLY THE AMOUNT. TRY AGAIN.'/)
GOTO 516
C
519 CALL UPDATE(AMOUNT)
C
530 CONTINUE
C
C ***CASH ON COSTS OTHER THAN TRANSPORTATION***
C
540 TYPE 545
545 FORMAT(' PLEASE ENTER THE TOTAL AMOUNT OF MONEY FOR ITEMS
1 OTHER'/' THAN TRANSPORTATION: $ ',$)
C
ACCEPT 32, RESPNS
IF(.NOT.CORECT(RESPNS,2,AMOUNT)) GOTO 540
IF(BANK(AMOUNT)) GOTO 540
C
CALL UPDATE(AMOUNT)
C
C ***CLOTHING***
C
550 TYPE 552
552 FORMAT(//' NOW ENTER THE AMOUNT FROM THE WORKSHEET YOU WILL
1 SPEND ON CLOTHES'/' THIS MONTH: $ ',$)
C
555 ACCEPT 32,RESPNS
IF(.NOT.CORECT(RESPNS,2,BILL)) GOTO 560
IF (BILL.EQ.0.) GOTO 560
IF(BANK(BILL)) GOTO 550
C
C *PAY WITH CREDIT OR CASH
C
DOWNPY=0.00
C
IF(CREDIT(AMOUNT,THING,BILL,DOWNPY)) GOTO 560
C
C *CASH
C
556 TYPE 517,BILL
C
ACCEPT 32,RESPNS
IF(.NOT.CORECT(RESPNS,2,AMOUNT))GOTO 556
IF(BANK(AMOUNT)) GOTO 556
IF(ABS(AMOUNT-BILL).LT..001) GOTO 558
TYPE 518
GOTO 556
C
558 CALL UPDATE(AMOUNT)
C
C
C ***RANDOM MEDICAL - DENTAL EXPENSES***
C
C *SEE RANDOM HOUSEHOLD EXPENSES FOR VARIABLES TO BE DEFINED
C
560 FILE='DOCTOR.FIL'
FILSIZ=SIZE(FILE)
CLOSE (UNIT=5)
IF(FILSIZ.EQ.0) GOTO 595
NUMBER=3
PERCNT(1)=50.
PERCNT(2)=50.
PERCNT(3)=10.
C
C *MESSAGE EXPLAINING SECTION
C
TYPE 565
565 FORMAT(//' YOU WILL NOW GET SOME RANDOM MEDICAL--DENTAL
1 EXPENSES. AGAIN, IF'/' YOU ARE LUCKY, NOTHING WILL HAPPEN TO
2 YOU OR YOUR FAMILY.'/)
C
CALL RANDOM(NUMBER,PERCNT,IRAN,FILSIZ)
C
DO 580 I=1,NUMBER
C
C *SEE IF ANYTHING HAPPENS - IF SO PAY FOR IT - ELSE CONT.
IF (IRAN(I).EQ.0) GOTO 580
C
FILSIZ=SIZE(FILE)
IFILE=IRAN(I)
CALL TYPEIT(IFILE,THING,BILL1,RANGE,DOWNPY)
C
CALL PAYIT(AMOUNT,THING,BILL1,RANGE,DOWNPY)
C
580 CONTINUE
C
J=0
DO 590 I=1,NUMBER
590 J=J+IRAN(I)
C
IF (J.NE.0) GOTO 600
595 TYPE 454
C
C ***EDUCATION AND READING***
C
600 TYPE 605
605 FORMAT(//' PLEASE ENTER THE AMOUNT YOU WILL SPEND ON EDUCATION
1 AND READING'/' THIS MONTH? $',$)
C
ACCEPT 32,RESPNS
IF(.NOT.CORECT(RESPNS,2,AMOUNT)) GOTO 600
IF (BANK(AMOUNT)) GOTO 600
CALL UPDATE(AMOUNT)
C
C
C ***SEASONAL COSTS***
C
TYPE 625
625 FORMAT(//' AT THIS TIME YOU WILL HAVE TO PAY FOR ALL THE THINGS
1 THAT HAPPEN'/' ON A SEASONAL BASIS.'//)
C
FILE='SEASON.FIL'
FILSIZ=SIZE(FILE)
IF(FILSIZ.NE.0) GOTO 635
CLOSE(UNIT=5)
TYPE 630
630 FORMAT(' NOTHING NEED BE PAID THIS MONTH')
GOTO 6000
C
C *PRINT EVERYTHING IN THE FILE--AUTO THINGS HAPPEN IN THE
C *NEXT SECTION
C
635 DO 640 I=1,FILSIZ
C
C *THIS IS AN ENTRY POINT IN THE TYPEIT SUBROUTINE
C
CALL RDFILE(THING,BILL1,RANGE,DOWNPY)
C
CALL PAYIT(AMOUNT,THING,BILL1,RANGE,DOWNPY)
C
640 CONTINUE
C
C *INCOME TAX REFUND?*
C
6000 IF(MONTH.NE.9) GOTO 644
CALL PORTFO(FOLIO,TAXREF,INCOME,FEDTAX,STATAX,RETIRE,
1 HEALTH,LIFE,UNION,FOOD)
C
C *ADJUST TAXREF IF OWN A HOUSE
C
NHOUSE=HOUSE(1)
CALL SHLTER(NHOUSE,TYPE,GAS,ELEC,WATER,GARBAG,RENT,PITI)
C
IF(TYPE.GE.4.) GOTO 641
C
C *ADJUSTED BY 22% OF PITI
C
TAXREF=TAXREF+FLOAT(IFIX(PITI*5.+.5)*12)/100
C
641 TYPE 642,TAXREF
642 FORMAT(/' SINCE IT''S MARCH, YOU HAVE JUST RECEIVED YOUR
1 INCOME TAX REFUND'/' WHICH IS $',F7.2,' THIS YEAR.'/)
C
AMOUNT=-TAXREF
CALL UPDATE(AMOUNT)
C
C ***CAR MAINTAINANCE AND SEASONAL COSTS
C
C **SEE IF MINOR REPAIR OCCURS**
C
644 FILE='CAR.FIL'
FILSIZ=SIZE(FILE)
CLOSE (UNIT=5)
IF(FILSIZ.EQ.0) GOTO 1660
NUMBER=0
PERCNT(1)=60.
PERCNT(2)=60.
PERCNT(3)=60.
C
DO 1610 I=1,3
IF(CAR(I).EQ.0) GOTO 1610
NUMBER=NUMBER+1
1610 CONTINUE
C
CALL RANDOM(NUMBER,PERCNT,IRAN,FILSIZ)
C
DO 1650 J=1,NUMBER
IF(IRAN(J).EQ.0) GOTO 1650
NCAR=CAR(J)
CALL AUTO(NCAR,VEHICL,PAY,LICENS,CSTMI,AVGMPG,WEIGHT,
1 DESCRP,RECORD,AVGCST,SPREAD)
TYPE 1615,VEHICL
1615 FORMAT(' TROUBLE WITH ',A10)
C
FILSIZ=SIZE(FILE)
IFILE=IRAN(J)
CALL TYPEIT(IFILE,THING,BILL1,RANGE,DOWNPY)
CALL PAYIT(AMOUNT,THING,BILL1,RANGE,DOWNPY)
C
1650 CONTINUE
C
1660 CALL UPKEEP
C
C ***BIG PURCHASES***
C
TYPE 645
645 FORMAT(//' NOW YOU WILL HAVE THE CHANCE TO MAKE THOSE BIG
1 PURCHASES ($20 OR MORE)'/' THAT YOU WANT TO MAKE.
2 BE SURE TO PUT IN THE NAME OF THE ITEM'/' AS YOU HAVE WRITTEN
3 IT ON YOUR WORKSHEET (10 LETTERS OR LESS).'//)
C
TYPE 647
647 FORMAT(' DO YOU WANT TO MAKE A PURCHASE (YES OR NO)? ',$)
GOTO 706
C
650 TYPE 655
655 FORMAT(' WHAT IS THE ITEM (10 LETTERS OR LESS)? ',$)
C
ACCEPT 32,RESPNS
IF(.NOT.CORECT(RESPNS,1,AMOUNT)) GOTO 650
IF(BANK(AMOUNT)) GOTO 650
DO 663 J=1,10
663 THING=THING+RESPNS(J)
C
664 TYPE 665
665 FORMAT(/' GIVE THE COST OF THE ITEM? $ ',$)
C
ACCEPT 32,RESPNS
IF(.NOT.CORECT(RESPNS,2,BILL)) GOTO 664
IF(BANK(BILL)) GOTO 664
IF (BILL.GE.20.00) GOTO 670
TYPE 667
667 FORMAT(/' I AM SORRY. THIS SECTION IS LIMITED TO ITEMS
1 OF $20 OR MORE.'/)
GOTO 650
C
670 CONTINUE
C
C *CALCULATE DOWNPY: 0.00-99.99=0.00,100.00-199.99=10.00,ETC.
C
DOWNPY=FLOAT(IFIX(BILL*.01))*10
C
C *SEE IF CASH OR CREDIT
C
IF(CREDIT(AMOUNT,THING,BILL,DOWNPY)) GOTO 685
C
C *CASH
C
680 TYPE 517, BILL
C
ACCEPT 32,RESPNS
IF(.NOT.CORECT(RESPNS,2,AMOUNT)) GOTO 680
IF(BANK(AMOUNT)) GOTO 680
IF(ABS(AMOUNT-BILL).LT..001) GOTO 685
TYPE 518
GOTO 680
C
685 CALL UPDATE(AMOUNT)
C
700 TYPE 705
705 FORMAT(/' DO YOU WANT TO MAKE ANOTHER PURCHASE (YES OR NO)
1? ',$)
C
706 ACCEPT 32,RESPNS
IF(.NOT.CORECT(RESPNS,1,AMOUNT)) GOTO 700
IF(BANK(AMOUNT)) GOTO 700
C
IF (RESPNS(1).NE.'Y') GOTO 750
GOTO 650
C
C
C ***RANDOM BIGGIES***
C
750 TYPE 755
755 FORMAT(/' HERE COME THOSE UNEXPECTED THINGS.',/)
C
756 FILE='BIGGIE.FIL'
NUMBER=3
PERCNT(1)=100.0
PERCNT(2)=75.0
PERCNT(3)=50.0
C
FILSIZ=SIZE(FILE)
CLOSE (UNIT=5)
IF(FILSIZ.NE.0) GOTO 770
TYPE 765
765 FORMAT(' NOTHING HAPPENED THIS TIME'/)
GOTO 890
770 CALL RANDOM(NUMBER,PERCNT,IRAN,FILSIZ)
C
DO 800 I=1,NUMBER
IF(IRAN(I).EQ.0) GOTO 800
FILSIZ=SIZE(FILE)
IFILE=IRAN(I)
CALL TYPEIT(IFILE,THING,BILL1,RANGE,DOWNPY)
C
CALL PAYIT(AMOUNT,THING,BILL1,RANGE,DOWNPY)
C
800 CONTINUE
C
C ***UPDATE STUDEN.DAT WITH THIS MONTHS CHANGES
C
890 MONTH=MONTH+1
CALL PRINT(NNNNNN,FOLIO)
C
C
C ***TYPE A SUMMARY
C
TYPE 900
900 FORMAT(///' THIS IS THE END OF THE MONTH. THE FOLLOWING IS
1 A SUMMARY OF'/' YOUR FINANCIAL STATUS'/)
C
CALL MONEYS
C
C
END
SUBROUTINE MONEYS
C
COMMON CHKING,SAVING,LOAN,BALNC(9)
C
DIMENSION RESPNS(10)
C
INTEGER CHKING,SAVING,BALNC
C
C *FIGURE NO. AND TOTAL COST OF BILLS ON CREDIT
C
ITOTAL=0
J=0
C
DO 10 I=1,9
IF(BALNC(I).EQ.0) GOTO 10
ITOTAL=ITOTAL + BALNC(I)
J=J+1
10 CONTINUE
C
C *PRINT SUMMARY
C
C=FLOAT(CHKING)/100
S=FLOAT(SAVING)/100
XL=FLOAT(LOAN)/100
TOTAL=FLOAT(ITOTAL)/100
C
TYPE 15,C,S,XL,J,TOTAL
15 FORMAT(/' FINANCIAL SUMMARY:'/' CHECKING ACCOUNT = $',F9.2,
1 5X,' SAVINGS ACCOUNT = $',F9.2,/' AMOUNT BORROWED FROM BANK AT
2 12% = $',F9.2,/,1X,I2,' BILLS ON CREDIT AT 18% TOTAL = $',
3 F9.2,//)
C
RETURN
END
SUBROUTINE PAYIT(AMOUNT,THING,BILL1,RANGE,DOWNPY)
C
COMMON CHKING,SAVING,LOAN,BALNC(9),OVERDU(9),PAYMNT(9),
1 ITEM(9)
C
INTEGER CHKING,SAVING,BALNC,OVERDU,PAYMNT
C
DIMENSION ANSWER(5),RESPNS(10)
C
DOUBLE PRECISION ITEM,THING
C
C *SEE IF INSURANCE TYPE OF BILL
C
IF(BILL1.GE.RANGE) GOTO 750
10 TYPE 15
15 FORMAT(/' TYPE IN THE AMOUNT YOU NEED TO PAY? $',$)
C
ACCEPT 32, RESPNS
32 FORMAT(10A1)
IF(.NOT.CORECT(RESPNS,2,AMOUNT)) GOTO 10
IF(AMOUNT.NE.0.0) GOTO 20
17 TYPE 18
18 FORMAT(/' ARE YOU SURE YOU DON''T HAVE TO PAY FOR
1 THIS.'/' ANSWER "YES" OR "NO"? ',$)
C
ACCEPT 32,RESPNS
IF(.NOT.CORECT(RESPNS,1,AMOUNT)) GOTO 17
IF (BANK(AMOUNT)) GOTO 17
C
IF (RESPNS(1).EQ.'Y') RETURN
GOTO 10
C
C *SEE IF IN THE INTERVAL SPECIFIED
C
20 IF(BANK(AMOUNT)) GOTO 10
BILL=AMOUNT
IF((AMOUNT.GE.BILL1).AND.(AMOUNT.LE.RANGE)) GOTO 785
TYPE 390
390 FORMAT(/' YOU GOOFED--PLEASE TRY AGAIN')
GOTO 10
C
C *SEE IF NEED TO GENERATE A RANDOM #
C
750 BILL=BILL1
IF(RANGE.EQ.0.0) GOTO 760
BILL=ONERND(BILL1,RANGE)
TYPE 755,BILL
755 FORMAT(' YOUR BILL IS $',F7.2)
C
C *SEE IF BUY ON CREDIT
C
760 IF(DOWNPY.LT.0.00) GOTO 780
IF( CREDIT(AMOUNT,THING,BILL,DOWNPY)) GOTO 790
C
C *CASH
C
780 TYPE 375
375 FORMAT(/' ENTER EXACTLY THE AMOUNT YOU ARE TO PAY. $',$)
C
ACCEPT 32,RESPNS
IF(.NOT.CORECT(RESPNS,2,AMOUNT)) GOTO 780
785 IF(BANK(AMOUNT)) GOTO 780
IF(AMOUNT.EQ.BILL) GOTO 790
TYPE 390
GOTO 780
C
790 CALL UPDATE(AMOUNT)
C
RETURN
END
SUBROUTINE PORTFO(FOLIO,TAXREF,INCOME,FEDTAX,STATAX,RETIRE,
1 HEALTH,LIFE,UNION,FOOD)
C
DOUBLE PRECISION V
C
INTEGER FOLIO
C
REAL INCOME,LIFE
C
OPEN(UNIT=5,DEVICE='DSK',ACCESS='SEQIN',FILE='PORTFO.FIL',
1 DIRECTORY='1700,170700')
C
DO 20 I=1,FOLIO
READ(5,10) V,N,V,TAXREF,V,INCOME,V,FEDTAX,V,STATAX,V,
1 RETIRE,V,HEALTH,V,LIFE,
2 V,UNION,V,FOOD
10 FORMAT(A7,I2,9(/,A7,F7.2))
C
20 CONTINUE
C
CLOSE (UNIT=5)
RETURN
END
SUBROUTINE PRINT(STUNUM,FOLIO)
C
COMMON CHKING,SAVING,LOAN,BALNC(9),OVERDU(9),PAYMNT(9),
1 ITEM(9),MONTH,CAR(3),INSUR(3),MIWORK(2),TOTMI(3),HOUSE(2),
2 NOMNTH(3)
C
INTEGER STUNUM,FOLIO,CHKING,SAVING,LOAN,BALNC,OVERDU,
1 PAYMNT,MONTH,CAR,HOUSE
C
REAL INSUR,MIWORK
C
DOUBLE PRECISION ITEM
C
OPEN(UNIT=5,DEVICE='DSK',ACCESS='RANDOM',FILE='STUDEN.DAT',
1 RECORD=310,DIRECTORY='1700,170700')
C
WRITE (5#STUNUM,10) STUNUM,FOLIO,MONTH,CHKING,SAVING,LOAN,
1 (ITEM(J),PAYMNT(J),BALNC(J),OVERDU(J),J=1,9),
2 (CAR(J),TOTMI(J),INSUR(J),NOMNTH(J),J=1,3),
3 (MIWORK(J),J=1,2),(HOUSE(J),J=1,2)
C
10 FORMAT(I3,2I2,3I7,
1 9(A10,I5,I6,I2),
2 3(I2,F7.0,F6.2,I2),
3 2F4.1,2I2)
C
CLOSE(UNIT=5)
RETURN
END
SUBROUTINE READ(STUNUM,FOLIO)
C
COMMON CHKING,SAVING,LOAN,BALNC(9),OVERDU(9),PAYMNT(9),
1 ITEM(9),MONTH,CAR(3),INSUR(3),MIWORK(2),TOTMI(3),HOUSE(2),
2 NOMNTH(3)
C
INTEGER STUNUM,FOLIO,CHKING,SAVING,LOAN,BALNC,OVERDU,
1 PAYMNT,MONTH,CAR,HOUSE
C
REAL INSUR,MIWORK
C
DOUBLE PRECISION ITEM
C
OPEN(UNIT=5,DEVICE='DSK',ACCESS='RANDOM',FILE='STUDEN.DAT',
1 RECORD=310,DIRECTORY='1700,170700')
C
READ (5#STUNUM,10) STUNUM,FOLIO,MONTH,CHKING,SAVING,LOAN,
1 (ITEM(J),PAYMNT(J),BALNC(J),OVERDU(J),J=1,9),
2 (CAR(J),TOTMI(J),INSUR(J),NOMNTH(J),J=1,3),
3 (MIWORK(J),J=1,2),(HOUSE(J),J=1,2)
C
10 FORMAT(I3,2I2,3I7,
1 9(A10,I5,I6,I2),
2 3(I2,F7.0,F6.2,I2),
3 2F4.1,2I2)
C
CLOSE(UNIT=5)
RETURN
END
SUBROUTINE SHLTER(NUMBER,TYPE,GAS,ELEC,WATER,GARBAG,RENT,PITI)
C
DOUBLE PRECISION V
C
OPEN(UNIT=5,DEVICE='DSK',ACCESS='SEQIN',FILE='SHLTER.FIL',
1 DIRECTORY='1700,170700')
C
DO 20 I=1,NUMBER
READ(5,10) V,J,V,TYPE,V,GAS,V,ELEC,V,WATER,V,GARBAG,V,
1 RENT,V,PITI
10 FORMAT(A7,I2,7(/,A7,F7.2))
C
20 CONTINUE
C
CLOSE (UNIT=5)
RETURN
END
SUBROUTINE TYPEIT(IFILE,THING,BILL1,RANGE,DOWNPY)
C
C ***SUBROUTINE TO LIST THE EVENT AND THE COST
C
DIMENSION LINE(14)
C
DOUBLE PRECISION THING
C
C *GO TO THE RIGHT EVENT
C
IF (IFILE.EQ.1) GOTO 63
N=IFILE-1
DO 60 I=1,N
READ(5,15) MNTH,NEVENT,LENGTH,THING,BILL1,RANGE,DOWNPY
15 FORMAT(3(I2,X),A10,3F7.2)
C
DO 50 J=1,LENGTH
READ(5,20) (LINE(K),K=1,14)
20 FORMAT(14A5)
50 CONTINUE
C
C
60 CONTINUE
C
C *PRINT OUT THE EVENT AND ITS COST
C
ENTRY RDFILE(THING,BILL1,RANGE,DOWNPY)
C
63 READ(5,15) MNTH,NEVENT,LENGTH,THING,BILL1,RANGE,DOWNPY
C
TYPE 65
65 FORMAT(/)
C
DO 80 I=1,LENGTH
READ(5,20) (LINE(K),K=1,14)
C
DO 72 M=1,14
IF (LINE(M).EQ.' ') GOTO 74
72 CONTINUE
C
74 TYPE 75, (LINE(K),K=1,M)
75 FORMAT(1X,14A5)
C
80 CONTINUE
C
TYPE 65
CLOSE(UNIT=5)
RETURN
END
SUBROUTINE UPDATE(AMOUNT)
C
COMMON CHKING
C
INTEGER CHKING
REAL NEWBAL
C
IF(AMOUNT.EQ.0.) GOTO 20
C
CHKING=CHKING-IFIX(AMOUNT*100+.5)
C
C *IF AMOUNT IS NEG.--ADD 1 TO CHKING TO COMPENSATE FOR
C *ERROR CAUSED BY +.5 IN THE IFIX STATEMENT
C
IF(AMOUNT.GE.0.0) GOTO 5
CHKING=CHKING+1
C
C *SEE IF ENOUGH CHECKING--ELSE PRINT MESSAGE AND RETURN
C
5 IF (CHKING.GE.0) GOTO 20
OLDBAL=FLOAT(CHKING)/100
CHKING=CHKING-400
NEWBAL=FLOAT(CHKING)/100
TYPE 10,AMOUNT,OLDBAL,NEWBAL
10 FORMAT(/' INSUFFICIENT FUNDS IN CHECKING ACCOUNT.'//
1 ' AMOUNT OF CHECK =$',F9.2,5X,' BALNC. =$',F9.2,/,
2 ' SERVICE CHARGE =$ 4.00',5X,'NEW BALNC. =$',F9.2,//,
3 ' PLEASE MAKE A DEPOSIT TO COVER THIS LACK OF FUNDS AS SOON AS
4 POSSIBLE.'/' (EITHER BY TAKING OUT A LOAN OR WITHDRAWING FROM
5 SAVINGS)'//)
C
20 RETURN
END
SUBROUTINE FIXED(FOLIO)
C
COMMON CHKING,SAVING,LOAN,BALNC(9),OVERDU(9),PAYMNT(9),
1 ITEM(9),MONTH,CAR(3),INSUR(3),MIWORK(2),TOTMI(3),HOUSE(2),
2 NOMNTH(3),CALEND
C
DIMENSION THING(4),DESCRP(15,3),GROUP(5,2),RECORD(15),
1 AVGCST(15),SPREAD(15),RESPNS(10)
C
INTEGER STUNUM,FOLIO,CAR,HOUSE,SAVING,CHKING,EXPENS,EVENT,
1 OVERDU,BALNC,PAYMNT,SIZE
C
REAL MILE,LICENS,INCOME,LIFE,MIWORK,INSUR
C
DOUBLE PRECISION VEHICL,ITEM,CALEND,FILE
C
C ***CHECK MONTHLY COUNTER
C
IF(MONTH.NE.0) GOTO 10
TYPE 5
5 FORMAT(/' YOU NEED TO RUN THE START PROGRAM AND MAKE YOUR
1 YEARLY CHOICES.'//)
STOP
C
10 IF(MONTH.LE.12) GOTO 20
TYPE 15
15 FORMAT(' YOU ARE FINISHED WITH ONE YEAR. IF YOU WANT TO
1 PLAY ANOTHER'/' YEAR, THEN ASK YOUR TEACHER TO RE-ENROLL YOU
2 IN THE COMPUTER;'/' AND THEN RUN THE START PROGRAM TO MAKE YOUR
3 YEARLY CHOICES.'/)
STOP
C
C ***GET PAYCHECK INCLUDING STANDARD DEDUCTIONS AND MIN. FOOD COSTS.
C
20 CALL PORTFO(FOLIO,TAXREF,INCOME,FEDTAX,STATAX,RETIRE,HEALTH,
1 LIFE,UNION,FOOD)
TAKHOM=INCOME-FEDTAX-STATAX-RETIRE-HEALTH-LIFE-UNION
C
C *PRINT PAYCHECK
C
C *THE FOLLOWING IS HERE TO GET THE MONTH STORED IN CALEND
C
FILE='SEASON.FIL'
I=SIZE(FILE)
C
TYPE 22, CALEND
22 FORMAT (/' HERE''S YOUR PAYCHECK FOR ',A10,':'/)
C
TYPE 25,INCOME,FEDTAX,STATAX,RETIRE,HEALTH,LIFE,UNION,TAKHOM
25 FORMAT(' INCOME FED. TAX STATE TAX'/,1X,3(3X,F7.2),/
1 ' RETIREMENT HEALTH INS. LIFE INS. UNION DUES'/,1X,4(3X,F7.2)
2 ,/' TOTAL TAKE HOME PAY =$',F8.2)
C
AMOUNT=-TAKHOM
CALL UPDATE(AMOUNT)
C
C ***ADD 6% COMPOUNDED MONTHLY (.5%) TO SAVINGS
C
S=FLOAT(SAVING)/100
XINT=FLOAT(IFIX(S*.5+.5))/100
SAVING=SAVING+IFIX(XINT*100+.5)
TSAV=FLOAT(SAVING)/100
C
TYPE 27,S,XINT,TSAV
27 FORMAT(' SAVINGS ACCOUNT STATEMENT:'/
1 ' AMT. AT 1ST OF MONTH =$',F7.2,/
2 ' INTERST AT 6% COMPOUNDED MONTHLY =$',F7.2,/
3 ' TOTAL =$',F7.2,/)
C
C ***ASK FOR AMOUNT TO GO TO SAVINGS
C
30 TYPE 35
35 FORMAT(/' HOW MUCH DO YOU WANT TO PUT IN SAVINGS? $',$)
C
ACCEPT 32,RESPNS
32 FORMAT(10A1)
IF(.NOT.CORECT(RESPNS,2,AMOUNT)) GOTO 30
IF(BANK(AMOUNT)) GOTO 30
C
SAVING=SAVING+IFIX(AMOUNT*100+.5)
CALL UPDATE(AMOUNT)
C
C ***PAY FOR SHELTERS AND UTILITIES
C
DO 50 I=1,2
IF(HOUSE(I).EQ.0) GOTO 50
NHOUSE=HOUSE(I)
CALL SHLTER(NHOUSE,TYPE,GAS,ELEC,WATER,GARBAG,RENT,PITI)
C
C **SEASONAL ADJUSTMENTS**
C
IF(MONTH.GT.2.AND.MONTH.NE.11.AND.MONTH.NE.12)GOTO 1310
WATER=3.*WATER
GOTO 1350
1310 IF(MONTH.NE.3) GOTO 1320
GAS=1.26*GAS
WATER=2.*WATER
GOTO 1350
1320 IF(MONTH.GE.5) GOTO 1330
GAS=2.1*GAS
WATER=1.2*WATER
GOTO 1350
1330 IF(MONTHE .GT.8) GOTO 1340
GAS=3.58*GAS
GOTO 1350
1340 IF(MONTH.GT.10) GOTO 1350
GAS=2.21*GAS
WATER=1.4*WATER
C
1350 CGAS=ONERND(GAS,.25)
CELEC=ONERND(ELEC,1.00)
CWATER=ONERND(WATER,.50)
C
C *SEWER CALCULATED AT .5 COST OF WATER
C
SEWER=FLOAT(IFIX(CWATER*50+.5))/100
C
C
TOTAL=CGAS+CELEC+CWATER+SEWER+RENT+PITI+GARBAG
C
C *SEE IF RENTING OR BUYING AND MAKE PROPER ADJUSTMENTS
C
IF(RENT.GT.0.0) GOTO 38
THING(1)='PITI'
COST=PITI
GOTO 40
C
38 THING(1)='RENT'
COST=RENT
C
40 TYPE 45,I,THING(1),COST,CGAS,CELEC,CWATER,SEWER,GARBAG,TOTAL
45 FORMAT(/' SUMMARY OF SHELTER COSTS THIS MONTH ON DWELLING
1 NUMBER ',I1,':'/
2 1X,A4,' ON SHELTER =$',F6.2,/
3 ' GAS =$',F6.2,/
4 ' ELECTRICITY =$',F6.2,/
5 ' WATER =$',F6.2,/
6 ' SEWER =$',F6.2,/
7 ' TRASH HAUL =$',F6.2,/
8 ' TOTAL =$',F6.2,//)
C
CALL UPDATE(TOTAL)
C
50 CONTINUE
C
C ***PAY FOR CARS AND COST TO DRIVE TO WORK
C
DO 70 I=1,3
IF(CAR(I).EQ.0) GOTO 70
CALL AUTO(CAR(I),VEHICL,PAY,LICENS,CSTMI,AVGMPG,
1 WEIGHT,DESCRP,RECORD,AVGCST,SPREAD)
C
C *SEE IF CAR PAID OFF
C
IF(MONTH.LE.NOMNTH(I)) GOTO 65
PAY=0.00
C
C *SEE IF CAR DRIVEN TO WORK(#1 ALWAYS,#2 IF WIFE WORKS,#3 NEVER)
C
C *CALCULATE COST OF DRIVING CAR TO WORK (COST=0 IF MIWORK=0)
C
65 COST=FLOAT(IFIX(CSTMI*MIWORK(I)*100.+.5))/100.*20.
TOTAL=PAY+COST
C
C *TYPE A SUMMARY
C
TYPE 67,VEHICL,PAY,COST,TOTAL
67 FORMAT(/' COSTS FOR ',A10,':'/
1 ' MONTHLY PAYMENT =$',F7.2,/
2 ' COST TO DRIVE TO WORK =$',F7.2,/
3 ' TOTAL =$',F7.2,//)
C
CALL UPDATE(TOTAL)
C
70 CONTINUE
C
C ***PAY TELEPHONE BILL
C
BILL=ONERND(14.00,6.00)
TYPE 75, BILL
75 FORMAT(/' TELEPHONE BILL FOR THIS MONTH =$',F5.2,/)
C
CALL UPDATE(BILL)
C
C ***GIVE A SUMMARY OF FINANCIAL STATUS
C
CALL MONEYS
C
RETURN
END
SUBROUTINE UPKEEP
C
COMMON CHKING,SAVING,LOAN,BALNC(9),OVERDU(9),PAYMNT(9),
1 ITEM(9),MONTH,CAR(3),INSUR(3),MIWORK(2)
C
DIMENSION IRAN(5),PERCNT(5),DESCRP(15,3),GROUP(6,2),
1 RECORD(16),AVGCST(15),SPREAD(15),RESPNS(10)
C
INTEGER CHKING,SAVING,BALNC,OVERDU,PAYMNT,CAR,HOUSE,
1 WEIGHT,RECORD
C
REAL INSUR,MIWORK,LICENS
C
DOUBLE PRECISION FILE,ITEM,THING, VEHICL
C
C ***TEST ALL THREE CAR POSSIBILITIES***
C
DO 500 I=1,3
IF(CAR(I).EQ.0) GOTO 500
C
C ***READ IN ALL THE VARIABLES FROM VEHICL.FIL FOR THIS CAR
C
NCAR=CAR(I)
CALL AUTO(NCAR,VEHICL,PAY,LICENS,CSTMI,AVGMPG,WEIGHT,
1 DESCRP,RECORD,AVGCST,SPREAD)
C
C ***SEE IF NEED TO PAY TAXES AND LICENSE OR INSURANCE
C
GOTO (30,10,30,30,30,30,20,10,30,30,30,30),MONTH
C
C *INSURANCE*
C
10 BILL=INSUR(I)
C
TYPE 15, VEHICL,BILL
15 FORMAT (/' YOU NEED TO PAY CAR INSURANCE ON YOUR ',A10,'.
1 IT COSTS $',F7.2)
C
GOTO 170
C
C *LICENSE AND TAXES*
C
20 BILL=LICENS
TYPE 25,VEHICL,BILL
25 FORMAT(/' SINCE IT IS JANUARY, YOU MUST PAY FOR THE
1 LICENSE AND'/' TAXES ON YOUR ',A10,', WHICH COSTS $',F7.2)
C
C *PAY THE BILL*
C
170 TYPE 375
375 FORMAT(/' PLEASE ENTER EXACTLY THE AMOUNT OF THE BILL: $ ',$)
C
ACCEPT 32,RESPNS
32 FORMAT(10A1)
IF(.NOT.CORECT(RESPNS,2,AMOUNT)) GOTO 170
IF(BANK(AMOUNT)) GOTO 170
IF(AMOUNT.EQ.BILL) GOTO 180
TYPE 390
390 FORMAT(/' WOOPS--YOU MADE A MISTAKE!')
GOTO 170
C
180 CALL UPDATE(AMOUNT)
C
C ***SEE IF A MAJOR REPAIR OCCURS***
C
30 TYPE 305,VEHICL
305 FORMAT(/' YOU MAY GET A REPAIR JOB ON YOUR ',A10,'.')
C
C *CHANCES VARY ACCORDING TO WEIGHTED TOTAL IN CONSUMERS REP.
C
N=IFIX(100.*RAN(1)+1.)
IF(N.LE.10*WEIGHT) GOTO 335
TYPE 325
325 FORMAT(/' YOU LUCKED OUT THIS MONTH ON THIS CAR.')
GOTO 500
C
335 RECORD(16)=6
GROUP(RECORD(1),1)=1.
C
C *GROUP(5,2) CONTAINS THE 5 GROUPS AND THE START AND TOTAL
C *NUMBERS IN THAT GROUP
C
T=1.
DO 320 J=2,16
IF(RECORD(J-1).NE.RECORD(J)) GOTO 340
T=T+1.
GOTO 320
C
340 GROUP(RECORD(J),1)=FLOAT(J)
GROUP(RECORD(J-1),2)=T
T=1.
C
320 CONTINUE
C
C *GENERATE RANDOM #'S UNTIL GET A NUMBER WHICH FALLS IN ONE
C OF THE GROUPS
C
355 DO 360 K=1,5
L=6-K
IF(GROUP(L,1).EQ.0.) GOTO 360
C
C *SEE IF GET A NUMBER IN THE GROUP (WEIGHT THE POSSIBILITY
C *5=75;4=60;3=45;2=30;1=15)
C
NUM=IFIX(GROUP(L,2)/(FLOAT(L)*.15)*RAN(1)+GROUP(L,1))
C
ILEFT=IFIX(GROUP(L,1)+.5)
IRIGHT=IFIX(GROUP(L,1)+GROUP(L,2)-1.+.5)
IF((NUM.GE.ILEFT).AND.(NUM.LE.IRIGHT)) GOTO 370
C
360 CONTINUE
C
C *KEEP TRYING UNTIL GET A NUMBER IN ONE OF THE GROUPS
C
GOTO 355
C
C *GENERATE THE BILL USING AVGCST & SPREAD*
C
370 BILL=ONERND(AVGCST(NUM),SPREAD(NUM))
C
TYPE 405,VEHICL
405 FORMAT (/' YOUR ',A10,' NEEDS REPAIR IN THE FOLLOWING
1 CATEGORY'/' AND AT THE FOLLOWING COST:')
C
TYPE 415,(DESCRP(NUM,K),K=1,3),BILL
415 FORMAT(1X,3A5,2X,'$',F7.2)
C
C *PAY THE BILL
C
420 TYPE 375
ACCEPT 32,RESPNS
IF(.NOT.CORECT(RESPNS,2,AMOUNT)) GOTO 420
IF(BANK(AMOUNT)) GOTO 420
IF(AMOUNT.EQ.BILL) GOTO 430
TYPE 390
GOTO 420
C
430 CALL UPDATE(AMOUNT)
C
500 CONTINUE
C
RETURN
END
SUBROUTINE AUTO(N,VEHICL,PAY,LICENS,CSTMI,AVGMPG,
1 WEIGHT,DESCRP,RECORD,AVGCST,SPREAD)
C
DIMENSION DESCRP(15,3),RECORD(15),AVGCST(15),
1 SPREAD(15)
C
INTEGER WEIGHT,RECORD
C
REAL LICENS
C
DOUBLE PRECISION VEHICL,V
C
OPEN(UNIT=5,DEVICE='DSK',ACCESS='SEQIN',FILE='VEHICL.FIL',
1 DIRECTORY='1700,170700')
C
DO 100 I=1,N
READ (5,10) J,VEHICL,V,PAY,V,LICENS,V,CSTMI,V,AVGMPG,V,WEIGHT,
1(((DESCRP(K,J),J=1,3),RECORD(K),AVGCST(K),SPREAD(K)),K=1,15)
C
10 FORMAT(I3,X,A10,4(/,A7,F7.3),/,A7,I1,15(/,3A5,X,I1,F7.2,F7.2))
C
100 CONTINUE
C
CLOSE (UNIT=5)
RETURN
END
SUBROUTINE CHECK(STUNUM,FSTNAM)
C
COMMON CHKING,SAVING,LOAN,BALNC(9),OVERDU(9),PAYMNT(9),
1 ITEM(9),MONTH,CAR(3),INSUR(3),MIWORK(2),TOTMI(3),HOUSE(2),
2 NOMNTH(3)
C
DIMENSION ANSWER(5),FSTNAM(9),NAME(20)
INTEGER STUNUM
REAL NAME
C
7 FORMAT (/, ' ALWAYS HIT THE [RETURN] KEY AFTER TYPING
1 SOMETHING TO THE COMPUTER!!!',/)
C
C ASK THE STUDENT FOR HIS NUMBER
10 FORMAT (20A1,I3)
15 OPEN (UNIT=4,DEVICE='DSK',ACCESS='SEQIN',FILE='CROSS.REF',
1 DIRECTORY='1700,170700')
TYPE 20
20 FORMAT (' PLEASE TYPE YOUR NUMBER: ',$)
ACCEPT *,STUNUM
C
C CHECK TO SEE IF # IN CROSS.REF
DO 30 I=1,50
READ (4,10) (NAME(J),J=1,20),ISTU
C IF # IN CROSS.REF - CHECK IF IT CORRESPONDS TO RIGHT STU.
IF (ISTU.EQ.STUNUM) GOTO 35
30 CONTINUE
C IF NOT IN CROSS.REF - TRY AGAIN
32 TYPE 34
34 FORMAT (/,' PLEASE TRY AGAIN.',/)
CLOSE (UNIT=4)
GOTO 15
C
C RIGHT STUDENT NAME?
35 TYPE 40, (NAME(J),J=1,20)
40 FORMAT (' ARE YOU ',20A1,'?',$)
ACCEPT 45,(ANSWER(J),J=1,5)
45 FORMAT (5A1)
C IF YES CONTINUE AND GET FSTNAM NAME - IF NO TRY AGAIN
IF (ANSWER(1).EQ.'Y') GOTO 50
GOTO 32
50 DO 60 J=1,9
IF (NAME(J).EQ.' ') GOTO 70
FSTNAM(J)=NAME(J)
60 CONTINUE
70 CLOSE (UNIT=4)
RETURN
END
FUNCTION ONERND(COST,RANGE)
C
C ***GENERATES A RANDOM NUMBER IN THE INTERVAL COST +OR- RANGE
C
IF (COST.NE.0.) GOTO 10
ONERND=0.
RETURN
C
10 ONERND=FLOAT(IFIX((RANGE*2.0*RAN(1)+COST-RANGE)*100.+.5))/100.
C
RETURN
END
LOGICAL FUNCTION BANK(AMOUNT)
C
COMMON CHKING,SAVING,LOAN
C
DIMENSION RESPNS(10)
C
INTEGER CHKING,LOAN,SAVING
C
C *SEE IF WANT A FINANCIAL SUMMARY
C
7 IF(AMOUNT.NE.-2.) GOTO 10
CALL MONEYS
BANK=.TRUE.
RETURN
C
C *SEE IF NEED TO USE THE BANK--ELSE RETURN
C
10 IF (AMOUNT.LT.0.0) GOTO 12
C
C *CHECK IF DECIMAL PLACEMENT OF AMOUNT
C
IF(ABS(FLOAT(IFIX(AMOUNT*100.+.5))-AMOUNT*100.).LT..1)GOTO11
C
C **THE ABOVE IS SO COMPLICATED BECAUSE OF COMPENSATING
C **FOR ROUNDOFF ERROR
C
TYPE 5
5 FORMAT(/' YOU GOT THE DECIMAL IN THE WRONG PLACE.
1 PLEASE TRY AGAIN.'/)
BANK=.TRUE.
RETURN
C
11 BANK=.FALSE.
RETURN
C
C ***BANK***
C
12 TYPE 13
13 FORMAT(/' DO YOU WANT TO TAKE OUT A LOAN OR TO WITHDRAW FROM
1 SAVINGS'/' (RESPNS BY TYPING "LOAN" OR "SAVINGS")? ',$)
C
14 ACCEPT 15,RESPNS
15 FORMAT(10A1)
IF(RESPNS(1).EQ.'L') GOTO 20
IF(RESPNS(1).EQ.'S') GOTO 50
TYPE 16
16 FORMAT(/' I DIDN''T UNDERSTAND THAT. PLEASE TYPE EITHER
1 "LOAN" OR "SAVINGS"? ',$)
GOTO 14
C
20 TYPE 25
25 FORMAT(/' HOW MUCH OF A LOAN DO YOU WANT? $ ',$)
C
ACCEPT 15,RESPNS
IF(.NOT.CORECT(RESPNS,2,AMOUNT)) GOTO 20
IF(AMOUNT.NE.-2.) GOTO 100
CALL MONEYS
GOTO 20
C
100 IF(AMOUNT.GE.0.) GOTO 27
TYPE 26
26 FORMAT(' ERROR--YOU ARE ALREADY AT THE BANK')
GOTO 20
C
27 IF(FLOAT(IFIX(AMOUNT*100)).EQ. AMOUNT*100) GOTO 30
TYPE 5
GOTO 20
C
30 IF (LOAN+IFIX(AMOUNT*100).LE.1000000) GOTO 40
DOLLAR=10000.00-FLOAT(LOAN)/100
TYPE 35,DOLLAR
35 FORMAT(/' THE MAXIMUM YOU CAN BORROW IS $',F8.2,/)
GOTO 20
C
40 LOAN=LOAN+IFIX(AMOUNT*100+.5)
CHKING=CHKING+IFIX(AMOUNT*100+.5)
TLOAN=FLOAT(LOAN)/100
TCHK=FLOAT(CHKING)/100
C
TYPE 45,AMOUNT,TLOAN,TCHK
45 FORMAT(/' YOUR LOAN FOR $',F8.2,' WAS APPROVED. YOU NOW OWE
1 $',F8.2,/,' AND HAVE $',F9.2,' IN YOUR CHECKING ACCOUNT.'/)
BANK=.TRUE.
RETURN
C
C *WITHDRAW FROM SAVINGS
C
50 TSAVE=FLOAT(SAVING)/100
60 TYPE 65,TSAVE
65 FORMAT(/' YOU HAVE $',F9.2,' IN SAVINGS.'/' HOW MUCH DO YOU
1 WANT TO WITHDRAW? $ ',$)
C
ACCEPT 15,RESPNS
IF(.NOT.CORECT(RESPNS,2,AMOUNT)) GOTO 60
IF(AMOUNT.NE.-2.) GOTO 66
CALL MONEYS
GOTO 60
C
66 IF(AMOUNT.GE.0.) GOTO 67
TYPE 26
GOTO 60
C
67 IF(FLOAT(IFIX(AMOUNT*100)).EQ.AMOUNT*100) GOTO 70
TYPE 5
GOTO 60
C
70 IF(TSAVE-AMOUNT.GE.0.0) GOTO 80
TYPE 75
75 FORMAT(' YOU DON''T HAVE THAT MUCH MONEY IN SAVINGS!')
GOTO 60
C
80 SAVING=SAVING-IFIX(AMOUNT*100+.5)
CHKING=CHKING+IFIX(AMOUNT*100+.5)
TSAV=FLOAT(SAVING)/100
TCHK=FLOAT(CHKING)/100
TYPE 85,TSAV,TCHK
85 FORMAT(//' YOU NOW HAVE ',F9.2,' IN SAVINGS'/' AND $',F9.2,'
1 IN YOUR CHECKING ACCOUNT.'/)
BANK=.TRUE.
RETURN
C
END
LOGICAL FUNCTION CREDIT(AMOUNT,THING,BILL,DOWNPY)
C
COMMON CHKING,SAVING,LOAN,BALNC(9),OVERDU(9),PAYMNT(9),
1 ITEM(9)
C
INTEGER CHKING,SAVING,BALNC,OVERDU,PAYMNT
C
DIMENSION RESPNS(10)
C
DOUBLE PRECISION ITEM,THING,WORD
C
C *CREDIT OR CASH?
C
5 TYPE 10
10 FORMAT(/' WILL THIS BE (1) CREDIT OR (2) CASH (TYPE "1" OR
1 "2")? ',$)
C
ACCEPT 32,RESPNS
32 FORMAT(10A1)
IF(.NOT.CORECT(RESPNS,2,CHOICE)) GOTO 5
IF(BANK(CHOICE)) GOTO 5
C
IF (CHOICE.EQ.1.) GOTO 40
C
C **CASH
C
CREDIT=.FALSE.
RETURN
C
C **CREDIT
C
C *SEE IF CREDIT STILL GOOD(I.E. NOT MORE THAN 9 THINGS ON CREDIT)
C *WORK BACKWARDS THROUGH ALL CREDIT SLOTS TO FIND LOWEST
C OPEN SLOT AND ASSIGN THIS SLOT TO I
C
40 K=0
C
DO 50 J=1,9
I=10-J
C
C *CHECK IF SHOULD ADD TO GAS CREDIT CARD
C (I IS AUTOMATICALLY SET TO RIGHT SLOT)
C
IF(THING.EQ.'GAS&MAINT.'.AND.THING.EQ.ITEM(I)) GOTO 70
C
C *ELSE CHECK FOR OPEN SLOT
C
IF(BALNC(I).NE.0) GOTO 50
C
C *SET K TO OPEN SLOT
C
K=I
C
50 CONTINUE
C
C *SET I TO LOWEST OPEN SLOT--WILL BE 0 IF NO OPEN SLOTS
C
I=K
IF(I.NE.0)GOTO 70
C
C *ELSE TYPE ERROR MESSAGE
C
TYPE 60
60 FORMAT(' SORRY YOUR CREDIT IS NO GOOD AT THIS TIME. YOU
1 WILL HAVE TO'/' PAY FOR THIS ITEM SOME OTHER WAY.'//)
C
CREDIT=.FALSE.
RETURN
C
C **SET UP THE CREDIT PURCHASE**
C
C *MAKE THE DOWN PAYMENT
C
70 TYPE 75, DOWNPY
75 FORMAT(' WE HAVE CHECKED YOUR CREDIT, AND IT IS GOOD. AT
1 THIS TIME'/' PUT AT LEAST $',F6.2,' DOWN ON THE PURCHASE.'//)
C
76 TYPE 78
78 FORMAT(' AMOUNT YOU WILL PUT DOWN? $',$)
C
80 ACCEPT 32,RESPNS
IF(.NOT.CORECT(RESPNS,2,AMOUNT)) GOTO 76
IF (BANK(AMOUNT)) GOTO 76
C
C *SEE IF IT IS ENOUGH
C
83 IF (AMOUNT.GE.DOWNPY) GOTO 100
TYPE 85
85 FORMAT(/' I AM SORRY, BUT THAT IS NOT ENOUGH FOR A
1 DOWNPAYMENT. PLEASE'/' TYPE IN AGAIN THE AMOUNT YOU WILL
2 PUT DOWN? $',$)
C
GOTO 80
C
C *UPDATE ALL THE NECESSARY STORAGE AREAS
C
100 ITEM(I)=THING
C ***HERE # TO UPDATE GAS&MAINT.
BALNC(I)=IFIX((BILL-AMOUNT)*100+.5)+BALNC(I)
IF(BALNC(I).GT.0) GOTO 104
TYPE 103
103 FORMAT(/' YOU PAID TOO MUCH. PLEASE TRY AGAIN')
GOTO 76
C
C *CALCULATE MINUMUM MONTHLY PAYMNT: 0.00-99.00=10.00;
C *100.00-199.00=20.00; ETC.
C
104 PAYMNT(I)=IFIX(FLOAT(BALNC(I))*.0001+1.)*1000
IF(PAYMNT(I).LE.BALNC(I)) GOTO 105
PAYMNT(I)=IFIX(FLOAT(BALNC(I))*1.015+.5)
C
C *SUMMARIZE THE PURCHASE
C
105 PAY=FLOAT(PAYMNT(I))/100
AMTLFT=FLOAT(BALNC(I))/100
TYPE 110,AMOUNT,AMTLFT,PAY
110 FORMAT(//' HERE IS A SUMMARY OF YOUR PURCHASE:'//' DOWNPAYMENT
1 = $',F6.2,2X,'BALNC. TO BE PAID OFF AT 18%= $',F6.2,/,
2 ' MINIMUM MONTHLY PAYMENT =$',F6.2,/)
C
CREDIT=.TRUE.
RETURN
C
END
C ***OPEN THE CORRECT FILE, GET TO THE RIGHT MONTH, AND DETERMINE
C *THE SIZE OF THAT MONTHS FILE
C
INTEGER FUNCTION SIZE(FILE)
C
COMMON I1,I2,I3,I4(9),I5(9),I6(9),ITEM(9),MONTH,I7(3),
1 R1(3),R2(2),R3(3),I8(2),I9(3),CALEND
C
DIMENSION LINE(14)
DOUBLE PRECISION FILE,CALEND,ITEM,THING
C
OPEN (UNIT =5,DEVICE ='DSK',ACCESS='SEQIN',FILE=FILE,
1 DIRECTORY='1700,170700')
C
C *GET THE RIGHT MONTH
C
5 READ(5,10) MO,NUMHAP,CALEND
10 FORMAT(I2,X,I2,A10)
C
IF(MO.EQ.MONTH) GOTO 50
IF(NUMHAP.EQ.0) GOTO 5
DO 40 I=1,NUMHAP
READ(5,15) MNTH,NEVENT,LENGTH,THING,BILL1,BILL2,DOWNPY
15 FORMAT(3(I2,X),A10,3F7.2)
C
DO 30 J=1,LENGTH
20 READ(5,25) (LINE(K),K=1,14)
25 FORMAT(14A5)
30 CONTINUE
C
40 CONTINUE
C
GOTO 5
C
50 SIZE=NUMHAP
RETURN
C
END
LOGICAL FUNCTION CORECT(RESPNS,SECTON,AMOUNT)
C
DIMENSION RESPNS(10),INTPRT(10),DECIML(10),DIGITS(10)
C
REAL INTPRT
C
INTEGER SECTON,DFLAG
C
C **IF SECTION IS = TO 1 GOTO ALPHA PART OF ROUTINE
C
IF (SECTON.EQ.1) GOTO 450
C
C ***ELSE CONVERT THE ELEMENTS IS RESPNS TO A DECIMAL NUMBER
C
DATA (DIGITS(I),I=1,10)/'0','1','2','3','4','5','6','7','8','9'/
C
J=0
K=0
C *DECIMAL FLAG FOLLOWS
DFLAG=0
C
DO 100 I=1,10
IF(DFLAG.EQ.1) GOTO 60
C
C **GET THE NUMBERS TO THE LEFT OF THE DECIMAL--INTPRT(?)
C
IF (RESPNS(I).EQ.' ') GOTO 100
IF (RESPNS(I).EQ.'/') GOTO 500
IF (RESPNS(I).EQ.'.') GOTO 57
C
DO 50 L=1,10
C
C *N CORESPONDS TO THE DIGIT IN RESPNS(I)
C
N=L-1
IF (RESPNS(I).NE.DIGITS(L)) GOTO 50
J=J+1
INTPRT(J)=N
GOTO 100
50 CONTINUE
C
52 TYPE 55
55 FORMAT (1X,'ERROR--PLEASE TYPE A NUMBER')
GOTO 1000
C
C **DECIMAL SECTION**
C
57 DFLAG=1
GOTO 100
C
60 DO 70 L=1,10
N=L-1
IF (RESPNS(I).EQ.' ') GOTO 100
IF (RESPNS(I).NE.DIGITS(L)) GOTO 70
K=K+1
DECIML(K)=N
GOTO 100
70 CONTINUE
C
GOTO 52
C
100 CONTINUE
C
C
C **FIGURE OUT DECIMAL # AND STORE IN AMOUNT
C
C
AMOUNT=0.
PLACEL=1.
PLACER=.1
C
C *INTEGER PART--INTPRT(?)
C
IF(J.EQ.0) GOTO 240
DO 200 I=1,J
N=J+1-I
AMOUNT=AMOUNT+INTPRT(N)*PLACEL
PLACEL=PLACEL*10.
200 CONTINUE
C
C **DECIMAL PART
C
240 DO 250 I=1,K
AMOUNT=AMOUNT+DECIML(I)*PLACER
PLACER=PLACER/10.
250 CONTINUE
C
C *MAKE SURE AMOUNT IS ROUNDED OFF
C
AMOUNT=FLOAT(IFIX(AMOUNT*100.+.5))/100.
C
GOTO 1010
C
C
C ***SECTION 1--BANK OR SUMMARY SECTION***
C
450 IF (RESPNS(1).EQ.'/') GOTO 500
CORECT=.TRUE.
RETURN
C
500 IF (RESPNS(2).NE.'B') GOTO 510
AMOUNT=-1.
GOTO 1010
510 IF (RESPNS(2).NE.'S') GOTO 530
AMOUNT=-2.
GOTO 1010
C
C **ERROR SECTION**
C
530 TYPE 535
535 FORMAT (1X,'COMMAND ERROR--TYPE EITHER "/BANK" OR "/SUMMARY"')
C
C
C **PUT BLANKS IN RESPNS AND RETURN APPROPRIATE TRUTH VALUE
C
1000 CORECT=.FALSE.
GOTO 1020
C
1010 CORECT=.TRUE.
C
1020 DO 1030 J=1,10
INTPRT(J)=0.
DECIML(J)=0.
1030 RESPNS(J)=' '
C
RETURN
END
SUBROUTINE RANDOM(NUMBER,PERCNT,IRAN,FILSIZ)
C
DIMENSION PERCNT(5),IRAN(5)
C
INTEGER FILSIZ
C
C ***SUBROUTINE TO GENERATE AS MANY RANDOM NUMBERS AS 'NUMBER'
C WITH A GIVEN 'PERCNT' CHANCE THAT IT WILL FALL WITHIN THE
C 'FILSIZ' OF THE FILE TO BE READ. IRAN(?)=0 IF IT DOESN'T
C FALL WITHIN THE SPECIFIED RANGE
C
DO 10 I=1,NUMBER
10 IRAN(I)=0
C
IF(FILSIZ.EQ.0) RETURN
C
LOOP=NUMBER
C
C *IF FILSIZE TOO SMALL--CHANGE THE LOOP BOUNDS
C
IF (FILSIZ.GE.NUMBER) GOTO 12
LOOP=FILSIZ
C
12 DO 30 I=1,LOOP
C
C *SEE IF SHOULD GENERATE A NUMBER GIVEN PERCNT(I)
C
TEST=FLOAT(IFIX(100.*RAN(1)+1.0))
IF(TEST.GT.PERCNT(I)) GOTO 30
C
C *GENRATE A NUMBER
C
15 K=IFIX(FLOAT(FILSIZ)*RAN(1)+1.0)
C
IF(NUMBER.EQ.1) GOTO 25
C
C *IF RANDOM NUMBER ALREADY GENERATED TRY AGAIN
C
DO 20 J=1,NUMBER-1
IF (K.EQ.IRAN(J)) GOTO 15
20 CONTINUE
C
25 IRAN(I)=K
C
30 CONTINUE
C
40 RETURN
END
Reference in New Issue View Git Blame Copy Permalink