JHR
12
CONST@SRC
HEAD@@SRC
LINE@@SRC
MAIN@@SRC
OUT@@@SRC
PA@@@@SRC
RDIT@@SRC
READS@SRC
ROUND@SRC
SCHED@SRC
SORTITSRC
TTS@@@SRC
[\].
CONST@SRC
UML 01 0.
UML 02 146000.
UML 17 622600.
UML 05 262400.
UML 06 23800.
UML 08 598600.
UML 09 441800.
UML 10 2390900.
VAL 01 3600.
VAL 02 3600.
VAL 17 -36500.
VAL 09 2500.
VAL 10 3800.
REG 02 2000.
REG 09 2000.
TWR 01 3000.
TWR 02 3600.
TWR 17 5200.
TWR 09 28600.
TWR 10 37900.
NEW 01 92957.
NEW 02 54533.
NEW 06 745960.
NEW 08 2050000.
NEW 09 97935.
NEW 10 500621.
NEW 13 2407631.
[\].
HEAD@@SRC
SUBROUTINE HEAD(ILINE,ICO)
DIMENSION DATE(2)
DIMENSION ALPHA(5)
DATA ALPHA/'UML ','VAL ','REG ','TWR ','NEW '/
CALL WATDAY(DATE)
1000 FORMAT(1H1,'RUN DATE: ',2A5,29X'PROFORMA BALANCESHEET FOR ',A4,//)
1009 FORMAT(//,40X,60('*'),//,50X,'PROFORMA PROFIT & LOSS FOR ',
1A4,//)
IF(ILINE.EQ.1)WRITE(6,1000)DATE,ALPHA(ICO)
IF(ILINE.EQ.1)WRITE(6,1001)
IF(ILINE.EQ.2)WRITE(6,1009)ALPHA(ICO)
1001 FORMAT(3X,'ASSETS',76X,'LIABILITIES',/
1,3X, '------',76X,'-----------',//)
RETURN
END
[\].
LINE@@SRC
C LINE
C THIS ROUTINE PRINTS A STANDARD DETAIL LINE
C
C WRITTEN BY F.J. ALLEN.
C
SUBROUTINE LINE(A)
DOUBLE INTEGER JAMT
DIMENSION A(16),IPRNT(90)
COMMON/BUFFER/BUF1(16),BUF2(16),BUF3(16)
IS=1
DO 1 I=1,5
IF=IS+17
JAMT=RDIT(A(I))*10
CALL EDIT(JAMT,1,0,IPRNT,IS,IF,IER)
1 IS=IF+1
WRITE(6,100)(BUF1(I),I=1,2),(BUF1(I),I=7,11),(IPRNT(I),I=1,90)
100 FORMAT(' ',2A5,2X,4A5,A3,90A1)
RETURN
END
[\].
MAIN@@SRC
C
C
C PROGRAM: BAL
C 28JUL75 JHR FOR DEXTER LINDBERG
C
C USES:ROUND,OUT,HEAD,READS
C
C
DOUBLE PRECISION VAL(18,5),APP,BOK,AOUT,BINC,SUM
DIMENSION FILE (2)
COMMON VAL
DATA FILE /'TOTAL',' SRC'/
DO 1 I=1,18
DO 1 J=1,5
VAL(I,J)=0.
1 CONTINUE
C
C GET CONSTANTS
C
CALL READS
C
C GET TOTALS
C
CALL SEEK (1,FILE)
3 READ (1,1000,END=4)ICO,ITYP,APP,BOK,AOUT,BINC
APP=(APP*1000.)
BOK=(BOK*1000.)
AOUT=(AOUT*1000.)
BINC=(BINC*1000.)
1000 FORMAT (1X,2I1,4F10.0)
VAL(16,ICO)=VAL(16,ICO)+BINC
IF (ITYP.EQ.0) VAL (3,ICO)=APP
IF (ITYP.EQ.1) VAL (4,ICO)=APP
IF (ITYP.EQ.0) VAL (11,ICO)=AOUT
IF (ITYP.EQ.1) VAL (12,ICO)=AOUT
GO TO 3
4 CONTINUE
C
C DO THE 5 STMTS
C
DO 20 IT=1,5
SUM=0.
DO 21 IJ=1,6
21 SUM=SUM+VAL(IJ,IT)
VAL(7,IT)=SUM+ VAL(17,IT)
SUM=0.
DO 22 IJ=8,13
22 SUM=SUM+VAL(IJ,IT)
VAL(14,IT)=SUM
VAL (15,IT)= VAL(7,IT)-VAL(14,IT)
C
C SPECIAL FOR NEW
C
IF (IT.NE.5) GO TO 30
SUM=0.
SUM=SUM+(VAL(15,1)*.500)
SUM=SUM+(VAL(15,2)*.375)
SUM=SUM+(VAL(15,3)*.500)
SUM=SUM+(VAL(15,4)*.250)
VAL(5,5)=SUM
VAL(7,5)=VAL(7,5)+VAL(5,5)
C REVISE SHAREHOLDERS EQUITY
VAL (15,5)= VAL (7,5)-VAL(14,5)
30 CONTINUE
CALL OUT (IT)
20 CONTINUE
ENDFILE 1
STOP 1
END
[\].
OUT@@@SRC
SUBROUTINE OUT (ICO)
DOUBLE PRECISION VAL,REAL
DOUBLE INTEGER IDBL
DIMENSION JVALS(18,12),JV(12)
COMMON VAL(18,5)
DO 1 I=1,18
REAL= VAL (I,ICO)
IDBL=ROUND(REAL)
IDEC=-1
IDOL=0
CALL EDIT(IDBL,IDEC,IDOL,JV,1,12,IERR)
DO 2 J=1,12
2 JVALS(I,J)= JV(J)
1 CONTINUE
CALL HEAD (1,ICO)
WRITE (6,1002) (JVALS( 1,J),J=1,12),(JVALS( 8,K),K=1,12)
WRITE (6,1003) (JVALS( 2,J),J=1,12),(JVALS( 9,K),K=1,12)
WRITE (6,1013) (JVALS(17,J),J=1,12),(JVALS(10,K),K=1,12)
WRITE (6,1004) (JVALS( 3,J),J=1,12),(JVALS(11,K),K=1,12)
WRITE (6,1005) (JVALS( 4,J),J=1,12),(JVALS(12,K),K=1,12)
WRITE (6,1006) (JVALS( 5,J),J=1,12),(JVALS(13,K),K=1,12)
WRITE(6,1007) (JVALS(6,J),J=1,12)
WRITE (6,1012)
WRITE (6,1008) (JVALS( 14,J),J=1,12)
WRITE (6,1011) (JVALS(15,K),K=1,12)
WRITE(6,1014)(JVALS(7,K),K=1,12),(JVALS(7,J),J=1,12)
CALL HEAD (2,ICO)
WRITE (6,1010) (JVALS(16,J),J=1,12)
1002 FORMAT(3X,'CASH ',16X,12A1,35X,
1'BANK LOANS ',9X,12A1,//)
1003 FORMAT(3X,'ACCOUNTS RECEIVABLE',16X,12A1,35X,
1'ACCOUNTS PAYABLE ',9X,12A1,//)
1013 FORMAT(3X,'ADVANCES TO SHAREHOLDERS',11X,12A1,35X,
1'OTHER PAYABLES ',9X,12A1,//)
1004 FORMAT(3X,'LAND ',16X,12A1,35X,
1'LONG TERM DEBT - LAND ',9X,12A1,//)
1005 FORMAT(3X,'INCOME PROPERTIES ',16X,12A1,35X,
1'LONG TERM DEBT - IPP ',9X,12A1,//)
1006 FORMAT(3X,'INVESTMENT IN AFFL ',16X,12A1,35X,
1'MINORITY INTEREST ',9X,12A1,//)
1007 FORMAT(3X,'OTHER ASSETS ',16X,12A1,35X,//)
1008 FORMAT(3X,' ',16X,12X,35X,
1' TOTAL LIABILITIES',9X,12A1,//)
1011 FORMAT(3X,' ',16X,12X ,35X,
1'SHAREHOLDERS EQUITY ',9X,12A1,//)
1012 FORMAT(38X,12('-'),69X,12('-'),//)
1010 FORMAT(40X,'BUDGETED INCOME',10X,12A1,//,42X,'AFTER DEPRECIATION'
1,/,43X,'& MORTAGAGE INTEREST')
1014 FORMAT(//,38X,12A1,68X,12A1,/38X,12('='),68X,12('='),/)
RETURN
END
[\].
PA@@@@SRC
C PA
C THIS ROUTINE HANDLES PAGE CONTROL
C
C WRITTEN BY F.J. ALLEN
C
SUBROUTINE PA (KEY)
DIMENSION ICO(5),ACO(5),TITL(2,2),B(2)
COMMON/BUFFER/BUF1(16),BUF2(16),BUF3(16)
COMMON/TOT/TOTAL(4),DATE(2),KOUNT,KC,KL
DATA ICO/30,12,80,44,10/,ACO/'UML','VAL','REG','TWR','NEW'/
DATA TITL/' LAND',' ','PROPE','RTY '/,IP/1/,B/'A','B'/
100 FORMAT('1RUN DATE: ',2A5,35X,A3/' ',54X,
1'SCHEDULE ',A1/' ',56X,2A5//' ',49X,'OWN',6X,'APPRAISED',
112X,'BOOK',17X,'O/S',13X,'BUDGET'/' PROJECT ID PROJECT NAME ',
125X,'%',7X,'VALUE',16X,'VALUE',16X,'DEBT',12X,'INCOME'//)
IL=KEY-KEY/10*10+1
IC=KEY/10
DO 2 I=1,6
IF(ICO(I).EQ.IC)GO TO 3
2 CONTINUE
3 IF(I.NE.KC)KOUNT=0
IF(IFT.EQ.0)GO TO 4
IF(I.NE.KC.OR.KL.NE.IL)CALL TTS
4 IFT=1
KC=I
KOUNT=KOUNT-1
KL=IL
IF(KOUNT.GT.0)RETURN
KOUNT=35
WRITE(6,100)DATE(1),DATE(2),ACO(I),B(IL),TITL(1,IL),TITL(2,IL)
IP=IP+1
RETURN
END
[\].
RDIT@@SRC
FUNCTION RDIT (X)
IF(X.EQ.0)RDIT=0.
IF (X.EQ.0.)RETURN
RDIT=X+(.005*X/ABS(X))
RETURN
END
[\].
READS@SRC
SUBROUTINE READS
DOUBLE PRECISION VAL,X
DIMENSION FILE(2),ACO(5)
COMMON VAL (18,5)
DATA FILE /'CONST',' SRC'/
DATA ACO/'UML','VAL','REG','TWR','NEW'/
CALL SEEK (1,FILE)
1 READ (1,1000,END=9) BCO,J,X
1000 FORMAT (A3,1X,I2,F10.0)
DO 2 I=1,5
IF(ACO(I).EQ.BCO)ISUB=I
2 CONTINUE
VAL (J,ISUB)=X
GO TO 1
9 CONTINUE
ENDFILE 1
RETURN
END
[\].
ROUND@SRC
FUNCTION ROUND (X)
DOUBLE PRECISION X
IF (X.EQ.0.)ROUND=0.
IF (X.EQ.0.)RETURN
ROUND=X+(.5*X/ABS(X))
RETURN
END
[\].
SCHED@SRC
C SCHED
C
C THIS ROUTINE PRINTS A SCHEDULE OF BACKUP INFORMATION
C FOR THE BALANCE SHEETS
C
C
C WRITTEN BY F.J. ALLEN
C
DIMENSION F(2),A(16),F3(2),C(5)
COMMON/BUFFER/ BUF1(16),BUF2(16),BUF3(16)
COMMON/SRT/IREC(1000),JKEY(1000),II1(1000),II2(1000),L
COMMON/TOT/TOTAL(4),DATE(2),KOUNT,IC,IL
DATA F/'DSALE',' SRC'/,F3/'TOTAL',' SRC'/
DATA BLNK/' '/
CALL ENTER(2,F3)
CALL WATDAY(DATE)
L=0
K=0
CALL SEEK(1,F)
1 READ(1,100,END=2)(A(I),I=1,16)
K=K+1
CALL UNPAK(A(16),C)
IF(C(5).EQ.1H3)GO TO 3
IF(C(5).NE.1H1)GO TO 1
IN=0
IF(A(4).EQ.3HINC)IN=1
IF(A(15).EQ.BLNK.OR.A(15).EQ.3HCNU)GO TO 1
IN=0
GO TO 1
3 IF(IN.EQ.0)GO TO 1
DECODE(72,A,101)I1,I2,IC
101 FORMAT(1X,I4,I4,61X,I2)
L=L+1
IP=1
IF(A(11).EQ.4HLAND)IP=0
JKEY(L)=IC*10+IP
II1(L)=I1
II2(L)=I2
IREC(L)=K-2
GO TO 1
2 CALL CLOSE(1)
CALL SORTIT
CALL ROPEN(1,F)
DO 4 I=1,L
M=IREC(I)
CALL RREAD(1,M,BUF1)
M=M+1
CALL RREAD(1,M,BUF2)
M=M+1
CALL RREAD(1,M,BUF3)
DECODE(30,BUF1,102)BUD
102 FORMAT(20X,F10.0)
DECODE(60,BUF2,103)PCT,APP,BOOK
103 FORMAT(10X,2F10.0,20X,F10.0)
100 FORMAT(16A5)
DECODE(40,BUF3,104)DEBT
104 FORMAT(30X,F10.0)
BUD=BUD*PCT/100.0
APP=APP*PCT/100.0
JK=JKEY(I)
CALL PA(JK)
TOTAL(1)=TOTAL(1)+APP
TOTAL(2)=TOTAL(2)+BOOK
TOTAL(3)=TOTAL(3)+DEBT
TOTAL(4)=TOTAL(4)+BUD
A(1)=PCT
A(2)=APP
A(3)=BOOK
A(4)=DEBT
A(5)=BUD
CALL LINE(A)
4 CONTINUE
KOUNT=0
CALL TTS
CALL RCLOSE(1)
CALL CLOSE(2)
STOP
END
[\].
SORTITSRC
C SORTIT
C THIS ROUTINE SORTS THE KEYS FOR THE SCHEDULES
C
C WRITTEN BY F.J. ALLEN
C
SUBROUTINE SORTIT
COMMON/SRT/IREC(1000),JKEY(1000),I1(1000),I2(1000),L
L2=L-1
DO 1 I=1,L2
M=I+1
DO 1 K=M,L
IF(JKEY(I)-JKEY(K))1,2,4
2 IF(I1(I)-I1(K))1,3,4
3 IF(I2(I)-I2(K))1,1,4
4 ITEMP=JKEY(I)
JKEY(I)=JKEY(K)
JKEY(K)=ITEMP
ITEMP=I1(I)
I1(I)=I1(K)
I1(K)=ITEMP
ITEMP=I2(I)
I2(I)=I2(K)
I2(K)=ITEMP
ITEMP=IREC(I)
IREC(I)=IREC(K)
IREC(K)=ITEMP
1 CONTINUE
RETURN
END
[\].
TTS@@@SRC
C TTS
C THIS ROUTINE PRINTS TOTALS ON FILE AND REPORT
C
C WRITTEN BY F.J. ALLEN
C
SUBROUTINE TTS
DOUBLE INTEGER JAMT
DIMENSION IPRNT(72)
COMMON/TOT/TOTAL(4),DATE(2),IND,IC,IL
DISC=20.0
102 FORMAT(1X,2I1,4F10.1)
IK=IL-1
IS=1
DO 1 I=1,4
IF=IS+17
JAMT=RDIT(TOTAL(I))*10
CALL EDIT(JAMT,1,0,IPRNT,IS,IF,IER)
1 IS=IF+1
WRITE(6,100)(IPRNT(I),I=1,72)
100 FORMAT(' ',53X,4(2X,16('-'))/' ',53X,72A1)
IF(IND.EQ.0)GO TO 4
JAMT=RDIT(TOTAL(1)*DISC/10.)
CALL EDIT(JAMT,1,0,IPRNT,1,18,IER)
WRITE(6,112)DISC,(IPRNT(I),I=1,72)
TOTAL(1)=TOTAL(1)*(100.-DISC)/100.
JAMT=RDIT(TOTAL(1)*10.)
CALL EDIT(JAMT,1,0,IPRNT,1,18,IER)
WRITE(6,100)(IPRNT(I),I=1,72)
112 FORMAT(' ',12X,'DISCOUNT',3X,F4.0,' %',24X,72A1)
WRITE(6,101)
101 FORMAT(/'0',54X,'SCHEDULE B'/' ',56X,'PROPERTY'//)
4 WRITE(2,102)IC,IK,(TOTAL(I),I=1,4)
DO 2 I=1,4
2 TOTAL(I)=0.
RETURN
END
[\].