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