Trailing-Edge
-
PDP-10 Archives
-
decuslib20-05
-
decus/20-0137/financ/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