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 [\].