PDP-10 Archive: 43,50466/financ.for from decuslib10-09

Trailing-Edge - PDP-10 Archives - decuslib10-09 - 43,50466/financ.for
There are 2 other files named financ.for in the archive. Click here to see a list.
C	WESTERN MICHIGAN UNIVERSITY
C	FINANC.FOR (FILENAME ON LIBRARY DECTAPE)
C	FINANC, 4.2.1 (CALLING NAME, SUBLST #)
C	INTEGRATED FINANCIAL PACKAGE
C	WRITTEN AT WMU BY R. R. BARR, PUT ON SYSTEM FALL 75
C	OPTIONS NETFRATE, NETFVALU AND SUBR. RATAPR WERE PUT IN 
C	 PROG. BY B. GRANET (10/75)
C	OPTIONS ADDON AND EFECTV WERE PUT IN PROG BY B GRANET 6/77
C	PROF BAWLIK PROVIDED BASIC FORMULA LEADING TO SUBR.
C	 ADDON AND EFECTV
C	FORWMU PROGS USED: PRINTS
C	INTERNAL SUBR USED - KEYWRD, LPTOUT, TTYOUT, INFORM, RULE78,
C	 NETPVA, RATAPR, DEPREC, ANNUIT, EFECTV, ADDON
C	 FUNCTIONS USED BY MAIN PROG. - SDP
C	LIBRARY DECTAPE PROGS USED:  USAGE.MAC
C	APLB10 PROGS USED:  SETSTR, CALC, IFREE, SDUMP
C	ABOVE COMMENTS AND RIGHT ADJUSTED COMMENTS PUT IN BY WG
C
	DOUBLE PRECISION ALLOC
C---------------KEYWD (19), NKEYS/19/-WHEN OPTIONS ARE ADDED, A
C--------------- SUITABLE # LARGER THAN 19 SHOULD BE USED
C---------------WORDS RETURNED BY CALC THRU COMMON
C---------------
	DOUBLE PRECISION ANAME,ANAME1,KEYWD(19)
	COMMON/CALDAT/IN(80),WORDS(4),RESULT(2),NR
	COMMON/INFOR/NKEYS,KEYWD
	COMMON/ALLOCS/INIT,NEXT,LAST,ALLOC(500)
	DATA NWDS/500/
	DATA NKEYS/19/
C---------------KEYWD PASSED TO SUBR KEYWRD THRU COMMON /INFOR/
	DATA KEYWD/
     #	'EXIT  ','HELP  ','INFORMAT','FINISH    ',
     #	'PRINT ','TYPE ',1.D0,'FREE ',0.D0,'DUMP    ',
     1	'RULE78','NETPVALU','NETPRATE','DEPREC','ANNUIT'
	2,'NETFVALU','NETFRATE','EFECTV','ADDON'/
	DATA IDLG,IRSP/-1,-4/
	CALL SETSTR(NWDS)
	CALL TTYOUT(IPT)
	WRITE(IDLG,796)
796	FORMAT(/,' WMU FINANCIAL CALCULATION PACKAGE',/)
C 	CALL USAGEB('FINANC')
799	WRITE(IDLG,800)
800	FORMAT(/,' TYPE "HELP" FOR HELP')
801	WRITE(IDLG,798)
798	FORMAT(/,' *',$)
C---------------TWO TYPES OF ARITHMETIC FORMS ARE ALLOWED:
C--------------- 1) AN ARITHMETIC EXPRESSION, 2) USER DEF.
C--------------- VAR. FOLLOWED BY = AND AN ARITHMETIC EXPRESSION.  THIS 
C--------------- IS CALLED AN ASSIGNMENT STATEMENT.
C---------------IF MODE = 0 OR 1 AND USER ENTERS AN ASSIGNMENT STAT.,
C--------------- CALC STORES THE VALUE OF ARITHM. EXP.
C---------------IF MODE = 0 AND USER ENTERS AN ARITHM. EXP. ONLY, 
C--------------- CALC PRINTS THE VALUE OF ARITHM. EXP.
C---------------IF MODE = 1 AND USER ENTERS AND ARITHM. EXP. ONLY,
C--------------- CALC RETURNS VALUE OF ARITHM. EXP.
	CALL CALC(ANS,0,IERR)
C---------------SEE FOLDER FOR NOTES ABOUT COMPUTED GO THAT IMMEDIATELY
C--------------- FOLLOWS CALL CALC
C---------------CALC RETURNS WORDS IT DOES NOT RECOGNIZE TO FINANC
C--------------- FOR ANALYSIS
	GO TO (801,801,801,802,101),IERR+1
C---------------WORDS RETURNED BY CALC THRU COMMON, IOP RETURNS USER
C--------------- OPTION
802	CALL KEYWRD(WORDS,IOP)
	IF(IOP)803,799,1000
803	WRITE(IDLG,804)WORDS(1),WORDS(2)
804	FORMAT(/,1X,2A5,' IS NOT DEFINED',/)
	GO TO 799
C---------------IOP GREATER 10 GIVES FINANCIAL OPTIONS
1000	IF(IOP.GT.10)GO TO 1100
	GO TO (101,102,103,104,105,106,107,108,109,110),IOP
C**EXIT
101	CALL TTYOUT(IPT)
	CALL EXIT
C**HELP
102	CONTINUE
	WRITE(30,1020)
1020	FORMAT(' OPTIONS AVAILABLE:',/)
	J=0
	DO 1022 K=1,NKEYS
	IF(KEYWD(K).EQ.0.D0)GO TO 1022
	WRITE(30,1021)KEYWD(K)
1021	FORMAT('+ ',A8,$)
	J=J+1
	IF(J.LT.7)GO TO 1022
	WRITE(IDLG,1023)
	J=0
1022	CONTINUE
	IF(J.NE.0)WRITE(30,1023)
1023	FORMAT('+',/)
	WRITE(IDLG,1024)
1024	FORMAT(/,' FOR MORE INFORMATION ABOUT AN OPTION, TYPE',
     1	' "INFORMAT"',/)
	GO TO 801
C**INFORMAT
103	CONTINUE
	WRITE(IDLG,1030)
1030	FORMAT(/,' TYPE NAME OF OPTION FOR WHICH YOU DESIRE',
     1	' INFORMATION.',/,' TYPE "ALL" FOR ALL.',/)
	READ(IRSP,1031,END=801)ANAME
1031	FORMAT(A10)
	CALL INFORM(ANAME)
	GO TO 801
C**FINISH(SAME AS EXIT)
104	GO TO 101
C**
105	CONTINUE
	CALL LPTOUT(IPT)
	GO TO 801
C**
106	CONTINUE
	CALL TTYOUT(IPT)
	GO TO 801
C**
107	CONTINUE
	GO TO 801
C**FREE
108	WRITE(IDLG,1081)
1081	FORMAT(/,' ENTER NAME TO BE FREED.',/)
	READ(IRSP,1031,END=801)ANAME
	IER=IFREE(ANAME)
	GO TO 801
C**BACKUP(NOOP AT THIS LEVEL)
109	CONTINUE
	GO TO 801
C**DUMP(DISPLAY VALUES OF ALL NAMED OBJECTS)
110	CALL SDUMP(IER)
	GO TO 801
1100	IOP=IOP-10
	IF(IOP.GT.10)GO TO 1200
C---------------FINANCIAL OPTIONS
	GO TO (111,112,113,114,115,116,117,118,119),IOP
C**RULE78
111	CALL RULE78
	GO TO 801
C**NETPVALU
112	CALL NETPVA(1)
	GO TO 801
C**NETPRATE
113	CALL NETPVA(2)
	GO TO 801
C**DEPREC
114	CALL DEPREC
	GO TO 801
C**ANNUIT
115	CALL ANNUIT
	GO TO 801
C**NETFVALU
116	CALL NETPVA(3)
	GO TO 801
C**NETFRATE
117	CALL NETPVA(4)
	GO TO 801
1200	CONTINUE
	GO TO 801
118	CALL EFECTV
	GO TO 801
119	CALL ADDON
	GO TO 801
	END
C---------------IDENTIFY USER OPTION
	SUBROUTINE KEYWRD(ANAME,IOP)
	DOUBLE PRECISION ANAME,KEYWD
	COMMON/INFOR/NKEYS,KEYWD(1)
	IDLG=-1
C---------------SEE ST.1030, +1, +2 OF MAIN PROG.
	IF(ANAME.EQ.'ALL          ')GO TO 106
	DO 100 IOP=1,NKEYS
100	IF(KEYWD(IOP).EQ.ANAME)GO TO 104
	IOP=0
	WRITE(IDLG,102)ANAME
102	FORMAT(/,1X,A10,' IS NOT DEFINED',/)
104	RETURN
106	IOP=-1
	GO TO 104
	END
	SUBROUTINE LPTOUT(IPT)
	IF(IPT.EQ.1)RETURN
	OPEN(UNIT=30,DEVICE='DSK',ACCESS='SEQOUT'
	1,FILE='OUTPUT.DAT')
	IPT=1
	RETURN
	END
	SUBROUTINE TTYOUT(IPT)
	IF(IPT.NE.1)GO TO 3000
	IPT=0
	CLOSE(UNIT=30)
	CALL PRINTS('OUTPUT.DAT',2,1,1)
3000	OPEN(UNIT=30,DEVICE='TTY')
	RETURN
	END
C---------------PRINT HELP EXPLANATION
	SUBROUTINE INFORM(ANAME)
	DOUBLE PRECISION ANAME,KEYWD
	COMMON/INFOR/NKEYS,KEYWD(1)
	IDLG=-1
	CALL KEYWRD(ANAME,IOP)
	IF(IOP.EQ.0)RETURN
	IF(IOP.LT.0.OR.IOP.EQ.1)WRITE(IDLG,1011)
1011	FORMAT(' EXIT  -  TERMINATES THE PROGRAM AND',
     1	' RETURNS TO MONITOR.',/,' SAME AS "FINISH".',/)
	IF(IOP.LT.0.OR.IOP.EQ.2)WRITE(IDLG,1021)
1021	FORMAT(' HELP  -  LISTS THE OPTIONS AVAILABLE',/,
     1	' AND EXPLAINS HOW TO GET MORE INFORMATION',/,
     2	' ABOUT A SPECIFIC ROUTINE.',/)
	IF(IOP.LT.0.OR.IOP.EQ.3)WRITE(IDLG,1031)
1031	FORMAT(' INFORMAT  -  GIVES DETAILS ON THE VARIOUS ROUTINES.',/)
	IF(IOP.LT.0.OR.IOP.EQ.4)WRITE(IDLG,1041)
1041	FORMAT(' FINISH  -  TERMINATES THE PROGRAM AND RETURNS',
     1	' TO MONITOR.',/,' SAME AS "EXIT".',/)
	IF(IOP.LT.0.OR.IOP.EQ.8)WRITE(IDLG,1081)
1081	FORMAT(' FREE  -  RELEASE AN ASSIGNED VARIABLE NAME.',/)
	IF(IOP.LT.0.OR.IOP.EQ.9)WRITE(IDLG,1091)
1091	FORMAT(' BACKUP  -  RETURN TO THE PRECEEDING QUESTION.',/,
     1	' NO MOVEMENT OCCURS IF THE PROGRAM IS AT COMMAND LEVEL.',/)
	IF(IOP.LT.0.OR.IOP.EQ.10)WRITE(IDLG,1101)
1101	FORMAT(' DUMP  -  DISPLAY ALL ASSIGNED VARIABLE NAMES AND',/,
     1	' THIER VALUES.',/)
	IF(IOP.LT.0.OR.IOP.EQ.11)WRITE(IDLG,1111)
1111	FORMAT(' RULE78  -  CALCULATES INTEREST RETURN ON LOAN',/,
     1	' PREPAYMENT',/)
	IF(IOP.LT.0.OR.IOP.EQ.12)WRITE(IDLG,1121)
1121	FORMAT(' NETPVALU  -  CALCULATES THE NET PRESENT VALUE',/,
     1	' FROM THE PAYMENTS AND THE RATE',/)
	IF(IOP.LT.0.OR.IOP.EQ.13)WRITE(IDLG,1131)
1131	FORMAT(' NETPRATE  -  CALCULATES THE RATE FROM THE PAYMENTS',/,
     1	' AND THE NETPRESENT VALUE',/)
	IF(IOP.LT.0.OR.IOP.EQ.14)WRITE(IDLG,1141)
1141	FORMAT(' DEPREC  -  CALCULATES REMAINING BALANCE AND NEXT',/,
     1' YEARS DEPRECIATION BY THREE METHODS: STRAIGHT LINE,',/,
     1' DOUBLE DECLINING, AND SUM OF DIGITS.',/)
	IF(IOP.LT.0.OR.IOP.EQ.15)WRITE(IDLG,1151)
1151	FORMAT(' ANNUIT  -  MAKES ANNUITY(OR MORTGAGE) CALCULATIONS',/)
	IF(IOP.LT.0.OR.IOP.EQ.5)WRITE(IDLG,1161)
1161	FORMAT(1X,'PRINT-PUTS ANSWERS ON LINE PRINTER.'/)
	IF(IOP.LT.0.OR.IOP.EQ.6)WRITE(IDLG,1171)
1171	FORMAT(1X,'TYPE- PUTS ANSWERS ON TERMINAL(DEFAULT).'/)
	RETURN
	END
C---------------FOR ALGORITHM USED SEE REF. 5 & REF. 7 OF WRITE UP,
C--------------- PAGES 6-7 AND 43-44 RESP.
	SUBROUTINE RULE78
	COMMON/CALDAT/IN(80),WORDS(4),RESULT(2),NR
	IDLG=-1
90	C=0
	WRITE(IDLG,100)
100	FORMAT(' ENTER TOTAL FINANCE CHARGE OR <CR> IF NOT KNOWN',/)
	CALL CALC(C,1,IERR)
	GO TO (92,90,90,80,99),IERR+1
92	WRITE(IDLG,104)
104	FORMAT(' ENTER PRINCIPAL',/)
	CALL CALC(P,1,IERR)
	GO TO (93,92,92,80,99),IERR+1
93	IF(C.NE.0)GO TO 94
	WRITE(IDLG,106)
106	FORMAT(' ENTER ANNUAL ADD-ON RATE AS A PERCENT(I.E. 5.5)',/)
	CALL CALC(A,1,IERR)
	GO TO (98,93,93,80,99),IERR+1
98	A=A/100.
94	WRITE(IDLG,108)
108	FORMAT(' ENTER TOTAL TERM OF LOAN IN MONTHS',/)
	CALL CALC(AM,1,IERR)
	M=AM
	GO TO (95,94,94,80,99),IERR+1
95	D=M*(M+1)/2
	CE=C
	IF(C.EQ.0)CE=A*P*M/12.
96	AL=0
	WRITE(IDLG,110)
110	FORMAT(' ENTER NO. OF MONTHS REQUIRED TO REPAY, <CR> FOR TABLE'
     1,/)
	CALL CALC(AL,1,IERR)
	L=AL
	GO TO (97,96,96,80,99),IERR+1
97	N=L
	IF(L.NE.0)GO TO 1031
	N=M
	L=1
1031	IF(C.EQ.0)WRITE(30,1111)CE
1111	FORMAT(' TOTAL FINANCE CHARGE IS ',F14.2,/)
	WRITE(30,111)
111	FORMAT(T15,'BEGINNING',/T15,'PRINCIPAL',T45,
	1'UNEARNED',/,2X,'PERIOD',T15,'OUTSTANDING',
	2T30,'INTEREST',T45,'INTEREST',/)
	U=0
	AA=P
	ABE=CE
	EQP=(P+CE)/M
	DO 2 I=1,N
	U=U+M-I+1
	A=CE-CE*U/D
	AB=ABE-A
	IF(I.GE.L.AND.I.LE.N)WRITE(30,112)I,AA,AB,A
	AA=EQP*(M-I)-A
2	ABE=A
112	FORMAT(1X,I5,T13,F10.2,T27,F10.2,T42,F10.2)
80	CONTINUE
99	RETURN
	END
C**NETPVALU,NETPRATE,NETFVALU, AND NETFRATE HAVE
C	MODES 1,2,3, AND 4 RESPECTIVELY.
C---------------SEE WRITE UP (#4.2.1) FOR FORMULAS RELATING TO NETPVALU,
C--------------- NETPRATE ON P. 6 AND TO NETFVALU, NETFRATE ON P. 8.
	SUBROUTINE NETPVA(MODE)
C
C REF:	A GUIDE TO FINANCIAL PLANNING TOOLS AND TECHNIQUES
C	BY D.P. DZIELINSKI
C	FROM IBM SYSTEM JOURNAL NO. 2, 1973
C	PAGES 136-138.
C
	DIMENSION P(100)
	COMMON P,NP,PERF,DUMMY
	DATA IONCE/0/,TOL/.00001/
	IDLG=-1
	IF(IONCE.EQ.0)GO TO 112
100	WRITE(IDLG,113)
113	FORMAT(' DO YOU WISH TO USE THE SAME PAYMENTS AS LAST',
     1	' TIME?(YES OR NO) ',$)
	READ(5,316,END=900)ANS
316	FORMAT(A3)
	IF(ANS.EQ.'YES')GO TO 212
112     WRITE(IDLG,301)
301   FORMAT(' NUMBER OF PAYMENTS: ',$)
	CALL CALC(ANP,1,IERR)
	GO TO (121,112,112,800,900),IERR+1
121	NP=ANP
120      WRITE(IDLG,304)
304   FORMAT(' ENTER PAYMENTS (1 PER LINE)'/)
	NP1=NP+1
	IF(NP.LE.0)NP1=2
	DO 102 I=2,NP1
	CALL CALC(P(I),1,IERR)
	GO TO (102,120,120,800,900),IERR+1
102	CONTINUE
	IF(NP.GE.0)GO TO 21211
	NP=-NP
	DO 21212 I=2,NP+1
21212	P(I)=P(2)
21211	P(NP+2)=0
	CALL CALC(P(NP+2),1,IERR)
	GO TO(2121,102,102,800,900),IERR+1
2121	IF(P(NP+2).EQ.0)GO TO 212
	CALL CALC(PERF,1,IERR)
	GO TO(212,2121,2121,800,900),IERR+1
9001	FORMAT(2F)
212	IF(MODE.EQ.1.OR.MODE.EQ.3)GO TO 2122
	IF(MODE.EQ.4)GO TO 3
213	WRITE(30,302)
302   FORMAT(' NET PRESENT VALUE: ',$)
8	CALL CALC(T,1,IERR)
	GO TO (303,213,213,800,900),IERR+1
303	P(1)=-T
2122	IONCE=1
	IF(MODE.EQ.1.OR.MODE.EQ.3)GO TO 12
C	RATE APPROXIMATION
11	CALL RATAPR(RATE,MODE)
	IF(RATE.EQ.0)GO TO 7
	RATE=100.*RATE
	WRITE(30,2)RATE
2	FORMAT(1X,'RATE IS ',G16.8)
	RETURN
7	WRITE(30,9)
9	FORMAT(1X,'SUM OF PAYMENTS =  PRESENT VALUE.'/)
	RETURN
C	NET PRESENT VALUE CALCULATION
12112	CONTINUE
12	WRITE(IDLG,307)
307	FORMAT(' ENTER RATE AS A PERCENT(I.E. 5.04): ',$)
	CALL CALC(RT,1,IERR)
	GO TO (320,12,12,800,900),IERR+1
320	IF(RT.EQ.0)GO TO 1
	RT=RT/100.
	PV=SDP(RT,MODE)
	IF(MODE.EQ.3)GO TO 5
	WRITE(30,308)PV
308	FORMAT('  PRESENT VALUE = ',G16.8)
	GO TO 1
800	CONTINUE
900	RETURN
1	RETURN
3	WRITE(30,4)
4	FORMAT(1X,'NET FUTURE VALUE: ',$)
	GO TO 8
5	WRITE(30,6)PV
6	FORMAT(1X,'NET FUTURE VALUE = ',G16.8)
	RETURN
      END
C**NETPVALU,NETPRATE,NETFVALU,NETFRATE, AND EFECTV HAVE
C	MODES 1,2,3,4, AND 5 RESPECTIVELY.
C---------------EVALUATE FUNCTIONS FOR MODES 1, 2, 3, 4, AND 5 WHICH
C--------------- CORRESPOND TO NETPVALU, NETPRATE, NETFVALU, NETFRATE,
C--------------- AND EFECTV RESPECTIVELY.
C---------------SUBROUTINE ANNUIT HAS MODE=6 BUT SDP IS NOT USED FOR
C--------------- THAT CASE BECAUSE IN RATAPR SUBR. FLAG = 1
	FUNCTION SDP(ZI,MODE)
	COMMON P(100),NP,PERF,R
	IF(MODE.NE.5)GO TO 4
C**EFECTV PATH
	TEMP1=1.+R*(NP/12.)
	TEMP2=(ZI/12)*NP
	SDP=((TEMP1-TEMP2)/TEMP1)*(1+ZI/12.)**NP-1.
	RETURN
4	SDP=0
	Z=1
	IF(MODE.EQ.3.OR.MODE.EQ.4)GO TO 3
	ZZ=1./(1.+ZI)
	IB=2
	IE=NP+1
	II=1
2	DO 100 I=IB,IE,II
	Z=ZZ*Z
100	SDP=SDP+P(I)*Z
	IF(MODE.EQ.1.OR.MODE.EQ.3)GO TO 1

	IF(P(NP+2).EQ.0)GO TO 101
	SDP=SDP+P(NP+2)*(ZZ**PERF)+P(1)
	RETURN
101	SDP=SDP+P(1)
	RETURN
1	IF(P(NP+2).NE.0)SDP=SDP+P(NP+2)*(ZZ**PERF)
	RETURN
3	ZZ=1.+ZI
	IB=NP+1
	IE=2
	II=-1
	GO TO 2
	END
C---------------RATAPR SOLVES FOR ZEROS OF NONLINEAR FUNCTIONS
C--------------- OF UNKNOWN. MODE=6 MEANS ANNUIT IS USING
C--------------- RATAPR.  MODES 1, 2, 3, 4, AND 5 ARE USED
C--------------- BY NETPVALU, NETPRATE, NETFVALU, NETFRATE
C--------------- (NETPVA(1), NETPVA(2), NETPVA(3), NETPVA(4)) AND
C--------------- EFECTV RESP.


	SUBROUTINE RATAPR(RATE,MODE)
C**RATAPR OBTAINS A ZERO OF A FUNCTION BY METHOD 
C	 OF "ITERATIVE METHODS FOR THE SOLUTION OF EQUATIONS"
C	 BY J.F. TRAUB, PAGE 212,PRENTICE-HALL,1964.
	DIMENSION P(100)
	COMMON/ANR/A,PER,NN,FLAG
	COMMON P,NP,PERF,R
	IF(MODE.NE.5)GO TO 19
	Z1=R
	Z2=R+.0001
	Z3=R+.0002
	GO TO 20
19	Z1=0
C---------------AVOID Z1=0 BECAUSE IN ANRATE THERE IS DIVISION BY Z1
	IF(FLAG.EQ.1)Z1=.00005
	Z2=.0001
	Z3=.0002
20	N=1
C**FLAG=1 MEANS WE ARE CALCULATING ANNUAL RATE FOR ANNUIT.
	IF(FLAG.EQ.1)GO TO 15
 	EFZ3=SDP(Z3,MODE)
	EFZ2=SDP(Z2,MODE)
	EFZ1=SDP(Z1,MODE)
18	IF(EFZ1.EQ.0)GO TO 12
8	IF(ABS(EFZ2).LE.1.0E-8)GO TO 6
5	IF(ABS(Z3-Z2).LE.1.E-8.AND.ABS(EFZ3).LE.1.E-6)GO TO 3
	IF(ABS(Z2-Z1).LE.1.E-8.OR.ABS(Z3-Z1).LE.1.E-8)GO TO 11
	Z3Z2=(EFZ3-EFZ2)/(Z3-Z2)
	Z2Z1=(EFZ2-EFZ1)/(Z2-Z1)
	Z3Z2Z1=(Z3Z2-Z2Z1)/(Z3-Z1)
	WI=Z3Z2+(Z3-Z2)*Z3Z2Z1
	ARGSQT=WI*WI-4.*EFZ3*Z3Z2Z1
	IF(ARGSQT.LT.0)ARGSQT=0
	SQROOT=SQRT(ARGSQT)
	IF(WI.GE.0)GO TO 1
	RI=WI-SQROOT
4	IF(ABS(RI).LE.1.0E-36)GO TO 9
	IF(ABS(RI).GE.1.E37)GO TO 3
	Z=Z3-2.*EFZ3/RI
	IF(Z.LE.0)Z=(Z3+Z2)/2.
	IF(Z.GE.5)GO TO 2
10	Z1=Z2
	Z2=Z3
	Z3=Z
	EFZ1=EFZ2
	EFZ2=EFZ3
	IF(FLAG.EQ.1)GO TO 16
	EFZ3=SDP(Z,MODE)
17	IF(N.GT.75)GO TO 2
	N=N+1
	GO TO 5
1	RI=WI+SQROOT
	GO TO 4
3	RATE=Z3
	RETURN
6	RATE=Z2
	RETURN
9	Z=2.*Z3-Z2
	GO TO 10
11	IF(ABS(EFZ1).GT.5.E-4)GO TO 14
	RATE=Z1
	RETURN
14	IF(ABS(EFZ2).GT.5.E-4)GO TO 2
	RATE=Z2
	RETURN
12	IF(FLAG.EQ.1)GO TO 8
	RATE=Z1
	RETURN
2	RATE =Z3
	PREVRA=100.*Z2
	WRITE(30,7)EFZ3,RATE,PREVRA
7	FORMAT(1X,'A DIFFICULTY IN CALCULATING RATE EXISTS.'/
	1' FUNCTION VALUE IS ',G15.7/
	21X,'PREVIOUS 2 RATES ARE ',/1X,2(G15.7,3X)/)
	RETURN
15	EFZ3=ANRATE(Z3)
	EFZ2=ANRATE(Z2)
	EFZ1=ANRATE(Z1)
	GO TO 18
16	EFZ3=ANRATE(Z)
	GO TO 17
	END
	SUBROUTINE DEPREC
C REF:	MATHEMATICS OF FINANCE
C	BY HUMMEL AND SEEBECK
C	SUM OF DIGITS METHOD - P. 143,144
C	STRAIGHT LINE METHOD - P. 141,142
C REF:	ACCOUNTING REVIEW V. 33 P 93-95(WMU BUS. LIB. #HF 5601.A6)
C	BY JOHN MEYERS
C	DOUBLE DECLINING BALANCE METHOD
C
	IDLG=-1
1001	WRITE(IDLG,1002)
1002	FORMAT(' ENTER DEPRECIABLE COST',/)
	CALL CALC(C,1,IERR)
	GO TO (1005,1001,1001,8000,9000),IERR+1
1005	WRITE(IDLG,1006)
1006	FORMAT(' ENTER ESTIMATED LIFE',/)
	CALL CALC(AN,1,IERR)
	GO TO (1009,1005,1005,8000,9000),IERR+1
1009	WRITE(IDLG,1007)
1007	FORMAT(' ENTER SALVAGE VALUE',/)
	CALL CALC(SLV,1,IERR)
	GO TO (1008,1009,1009,8000,9000),IERR+1
1008	N=AN
	WRITE(30,1010)
1010	FORMAT(//,T12,'STRAIGHT LINE',T33,'DOUBLE DECLINING',
     1T55,'SUM OF DIGITS',/,
     1' YRS    REM BAL  NXT YR DEP   REM BAL  NXT YR DEP   REM BAL ',
     1 'NXT YR DEP')
C	STRAIGHT LINE
	B=C-SLV
	SLB=(C-SLV)/N
	DO 1020 IX=0,N
	IF(IX.EQ.N)SLB=0
	L=N-IX
C	DOUBLE DECLINING
	DDX1=C*(1.-2./N)**IX
	DDXP1=2.*DDX1/N
C	SUM OF YEARS DIGITS
C	STRAIGHT LINE DECLINING BALANCE
	DSX1=(C-SLV)*L*(L+1.)/(N*(N+1.))
	DSDXP1=(C-SLV)*2.*L/(N*(N+1.))
	WRITE(30,1018)IX,B,SLB,DDX1,DDXP1,DSX1,DSDXP1
1018	FORMAT(1X,I3,3(F11.2,F11.2))
1020	B=B-SLB
8000	CONTINUE
9000	RETURN
	RETURN
	END
	SUBROUTINE ANNUIT
C
C REF:	MATHEMATICS OF FINANCE
C	BY HUMMEL AND SEEBECK
C	P. 48-50
C
	COMMON/ANR/A,P,N,FLAG
	IDLG=-1
	ISW=0
100	WRITE(IDLG,102)
102	FORMAT(' ENTER :   TO FIND:',/,'  1		RATE',/,
     1	'  2		LIFE',/,'  3		AMOUNT BORROWED',/,
     1	'  4		PERIODIC PAYMENT',/)
	READ(5,104,END=900)IT
104	FORMAT(3I)
	IF(IT.LT.1.OR.IT.GT.4)GO TO 100
	IF(IT.EQ.1)GO TO 120
110	WRITE(IDLG,111)
111	FORMAT(' ENTER NOMINAL  RATE IN PERCENT',/)
	CALL CALC(R8,1,IERR)
	GO TO (113,110,110,800,900),IERR+1
113	IF(R8.LE.0)WRITE(IDLG,336)
	IF(R8.LE.0)GO TO 110
336	FORMAT(1X,'NEGATIVE AND ZERO VALUES NOT ALLOWED.'/)
	R=R8/100.
112	FORMAT(F)
120	IF(IT.EQ.2)GO TO 130
122	WRITE(IDLG,121)
121	FORMAT(' ENTER NUMBER OF PERIODS TO LIFE OF ANNUITY',/)
	CALL CALC(AN,1,IERR)
	GO TO (133,122,122,800,900),IERR+1
133	IF(AN.LE.0)WRITE(IDLG,336)
	IF(AN.LE.0)GO TO 122
	N=AN
130	IF(IT.EQ.3)GO TO 140
337	WRITE(IDLG,131)
131	FORMAT(' ENTER AMOUNT OF ANNUITY',/)
	CALL CALC(A,1,IERR)
	GO TO (140,337,337,800,900),IERR+1
140	IF(A.LE.0)WRITE(IDLG,336)
	IF(A.LE.0)GO TO 337
	IF(IT.EQ.4)GO TO 150
143	WRITE(IDLG,141)
141	FORMAT(' ENTER AMOUNT OF A PAYMENT',/)
	CALL CALC(P,1,IERR)
	GO TO (152,143,143,800,900),IERR+1
152	IF(P.LE.0)WRITE(IDLG,336)
	IF(P.LE.0)GO TO 143
C---------------ANY NONNUM. CH. GIVES GROUPING OF OUTPUT BY YEAR
150	WRITE(IDLG,151)
151	FORMAT(' ENTER RANGE OF TABLE IN PERIODS(E.G. 1,10)',/)
	READ(5,104,END=900,ERR=314)I1,I2,I3
	IF(I3.EQ.0)I3=1
315	R1=R/12
	GO TO (210,220,230,240),IT
C**TAKE THIS PATH IF USER WANTS ANNUAL RATE.
210	FLAG=1.
C AM 4.2.1,1,WG,8/8/77
	MODE=6
C END AM 4.2.1,1,WG,8/8/77
C---------------ANNUAL RATE FUNCTION IS NONLINEAR IN R SO WE NEED
C--------------- RATAPR. MODE IS ZERO FOR RATAPR SINCE FLAG=2 (SEE 
C--------------- RATAPR.).  R1 IS RETURNED AS ANNUAL RATE.
	CALL RATAPR(R1,MODE)
	FLAG=0
	R=R1*12
	GO TO 300
220	IF(A*R1.GE.P)WRITE(IDLG,338)
338	FORMAT(1X,'AMOUNT OF ANNUITY TIMES RATE SHOULD NOT'/1X,
	1'BE GREATER THAN OR EQUAL TO THE PAYMENT.'/)
C******	WMU AM: 4.2.1, #2, MTO. 13-JAN-78
	N=.5-(ALOG(1.-(A*R1)/P))/ALOG(1.+R1)
C******	END - ANNUIT, @ 38+2  (IMPROPER ROUNDOFF OF #PERIODS)
	GO TO 300
230	A=(P-P/((1.+R1)**N))/R1
	GO TO 300
240	P=(A*R1)/(1.-1./((1.+R1)**N))
C
300	IF(ISW.EQ.1)GO TO 303
	IF(I1.NE.0)GO TO 302
	I1=1
	I2=N
	GO TO 303
302	IF(I2.EQ.0)I2=I1
303	Y9=P*N-A
	R9=R*100.
	WRITE(30,304)R9,N,A,P,Y9
304	FORMAT(/,' NOMINAL RATE=',F9.4,'%',/,' LIFE OF ANNUITY=',I5,
     1	' PERIODS',/,' AMOUNT OF ANNUITY=',G16.8,/,' PAYMENTS=',G16.8,/,
     1	' TOTAL INTEREST=',F15.2,/)
	IF(IT.EQ.2)WRITE(30,306)
306	FORMAT(' NOTE: ANNUITY LIFE HAS BEEN ROUNDED TO ',
     1	'NEAREST PERIOD',/)
	WRITE(30,308)
308	FORMAT(//,' ANNUITY TABLE',//)
	IF(ISW.EQ.1)GO TO 326
	WRITE(30,312)
312	FORMAT(T15,'BEGINNING',/,T15,'PRINCIPAL',T45,'PRINCIPAL',/,
     1	2X,'PERIOD',T15,'OUTSTANDING',T30,'INTEREST',T45,'REPAYMENT',/)
C**IN THE 14 STATEMENTS BELOW THE FOLLOWING PROCEDURE IS
C 	FOLLOWED: FOR 36 OR LESS PERIODIC PAYMENTS TRUNCATE
C	PERIODIC PAYMENT TO FOUR DIGITS TO RIGHT OF DECIMAL
C	POINT. IF BOTH THIRD AND FOURTH DIGITS  TO RIGHT OF
C	DECIMAL POINT ARE ZERO , THEN PERIODIC PAYMENTS
C	WILL INCLUDE THE TWO DIGITS TO RIGHT OF DECIMAL
C	POINT WITHOUT CHANGE; OTHERWISE PERIODIC PAYMENTS

C	WILL INCLUDE TWO DIGITS TO RIGHT OF DECIMAL POINT
C	PLUS ONE PENNY. IF LATTER PROCEDURE IS USED, THE
C	LAST PAYMENT IS DECREASED BY THE APPROPRIATE AMOUNT
C	TO MAKE THE TOTAL PAYMENTS EQUAL TO AMOUNT OF ANNUITY
C	PLUS TOTAL INTEREST. IF THERE ARE MORE THAN 36 PERIODIC 
C	PAYMENTS , THEN WITH THE EXCEPTION THAT THE PROGRAM
C	TRUNCATES TO SIX DIGITS TO THE RIGHT OF THE DECIMAL
C	POINT, THE PROCEDURE IS SAME AS THAT DESCRIBED ABOVE
C	FOR 36 OR LESS PERIODIC PAYMENTS.
326	JTOTAL=(N*P)*100+.5
	JP2=P*100
	IF(N.GT.36)GO TO 309
	JP4=P*10000
	JRES=(JP4/100)*100-JP4
313	IF(JRES.EQ.0)GO TO 310
311	JP=JP2+1
	GO TO 310
309	JP6=P*1000000
	JRES=(JP6/10000)*10000-JP6
	GO TO 313
310	JP=JP2
	JTP=JP*N
	JDIF=JTP-JTOTAL
	IF(ISW.EQ.1)GO TO 316
C******	WMU AM: 4.2.1, #2, MTO. 13-JAN-78
	I2M1=I2-1
	IF(I2.NE.N) I2M1=I2
	DO 330 M1=1,I2M1
	IY0=(A*R1)*100+.5
	MP1=JP-IY0
	P1=MP1/100.
	Y0=IY0/100.
	IF(((M1+I3-I1)/I3)*I3.NE.M1+I3-I1)GO TO 328
	WRITE(30,324)M1,A,Y0,P1
324	FORMAT(1X,I5,T13,F10.2,T27,F10.2,T42,F10.2)
328	A=A-P1
330	CONTINUE
	IF (I2.NE.N) RETURN
C******	END - ANNUIT, @ 330+2
331	IF(JDIF.EQ.0)GO TO 307
	IAP=JP-JDIF
	AP=IAP/100.
	IA=(AP/(1.+R1))*100.+.5
	IY0=IAP-IA
	P1=IA/100.
	A=P1
	GO TO 305
307	IA=A*100.+5
	P1=IA/100.
   	IY0=JP-IA
	A=P1
305	Y0=IY0/100.
	M1=I2
	IF(ISW.EQ.1)GO TO 335
	WRITE(30,324)M1,A,Y0,P1
	RETURN
800	CONTINUE
900	RETURN
314	KS=0
	IYEAR=1
	ISW=1
	NN=N
	GO TO 315
316	WRITE(30,323)
323	FORMAT(T15,'BEGINNING',/,T10,'PMT',T15,'PRINCIPAL',T45,
	1'PRINCIPAL',/,1X,'MONTH',T10,'NO.',T15,'OUTSTANDING',T30,
	2'INTEREST',T45,'REPAYMENT')
333	IF(N.GT.12)GO TO 318
	KK=N-1
	GO TO 334
318	KK=12
334	IY00=0
	MP11=0
	WRITE(30,325)IYEAR
325	FORMAT(//1X,'YEAR  ',I2,//)
	IF(N.EQ.1)GO TO 331
	DO 317 I=1,KK
	KS=KS+1
	IY0=(A*R1)*100+.5
	MP1=JP-IY0
	P1=MP1/100.
	Y0=IY0/100.
	IY00=IY00+IY0
	MP11=MP11+MP1
	WRITE(30,320)I,KS,A,Y0,P1
320	FORMAT(1X,I5,I7,T15,F10.2,T30,F10.2,T45,F10.2)

	A=A-P1
317	CONTINUE
	N=N-12
	Y00=IY00/100.
	P11=MP11/100.
	IF(N.LE.0)GO TO 331
329	WRITE(30,319)Y00,P11,A
319	FORMAT(//1X,'INTEREST PAID FOR YEAR= ',F10.2,/,1X,
	1'PRINCIPAL PAID FOR YEAR= ',F10.2,/1X,'PRINCIPAL',
	2'  REMAINING AT END OF YEAR= ',F10.2,//)
	IF(I.EQ.KK+1)RETURN
	IYEAR=IYEAR+1
	GO TO 333
335	I=KK+1
	IY00=IY00+IY0
	MP11=MP11+IA
	Y00=IY00/100.
	P11=MP11/100.
	KS=KS+1
	WRITE(30,320)I,KS,A,Y0,P1
	A=0.0
	GO TO 329
	END
C**USED IN SUBROUTINE RATAPR WHEN CALCULATING ANNUAL RATE
C	FOR ANNUIT SUBROUTINE.
C---------------USED BY RATAPR SUBR. TO CALC. RATE FOR ANNUIT
	FUNCTION ANRATE(R1)
	COMMON/ANR/A,PER,N,FLAG
	Z=A/PER

C**THIS FORMULA IS DERIVED FROM FORMULA IN THE ANNUIT
C	SECTION OF THE FINANC WRITEUP.
	ANRATE=-Z+(1.-1./((1.+R1)**N))/R1
	RETURN
	END
	SUBROUTINE EFECTV
	COMMON P(100),NP,PERF,R
	IDLG=-1
2	WRITE(IDLG,1)
1	FORMAT(1X,'ENTER ADD-0N  RATE AS A PERCENT(E.G. 5.04).'/)
	CALL CALC(R,1,IERR)
	R=R/100.
	GO TO(7,2,2,4,4),IERR+1
7	WRITE(IDLG,6)
6	FORMAT(1X,'ENTER NO. OF PERIODS.'/)
	CALL CALC(PERNO,1,IERR)
	NP=PERNO
	GO TO(8,7,7,4,4),IERR+1
8	MODE=5
3	CALL RATAPR(RATE,MODE)
	RATE=RATE*100.
	WRITE(30,5)RATE
5	FORMAT(1X,'EQUIVALENT EFFECTIVE RATE IS ',F9.4,'%.'/)
4	RETURN
	END
	SUBROUTINE ADDON
	IDLG=-1
2	WRITE(IDLG,1)
1	FORMAT(1X,'ENTER EFFECTIVE RATE AS A PERCENT(E.G. 5.04).'/)
	CALL CALC(A,1,IERR)
	A=A/100.
	GO TO (6,2,2,4,4),IERR+1
6	WRITE(IDLG,7)
7	FORMAT(1X,'ENTER NO. OF PERIODS.'/)
	CALL CALC(PERNO,1,IERR)
	NP=PERNO
	GO TO(3,6,6,4,4),IERR+1
3	R=(12./NP)*((NP*(A/12.))/(1.-(1.+A/12.)**-NP)-1.)
	R=R*100.
	WRITE(30,5)R
5	FORMAT(1X,'EQUIVALENT ADD-ON RATE IS 'F9.4,'%.'/)
4	RETURN
	END