C *************************************************************** C C FEE CALCULATION FOR CONCESSION PERMITS C C FUNCTION: CALCULATES THE FEES DUE USING THE C THE GRADUATED RATE FEE SYSTEM. THIS C PROGRAM CALCULATES AND FORMATS THE C PERMITTEE FEE FORM. C C WRITTEN BY: JIM BARBIERI C MAY 82 C MODIFIED BY: ALAN BRISCOE C MAY 82 C *************************************************************** DIMENSION IX(150), IT(270),IN(10) DOUBLE PRECISION A(20),B(20),C(10),D(11),E(10),BI(10),CC(10) DOUBLE PRECISION F(15),G(10),H(17),AI(10),AM(14),Z(10),DD(10) DOUBLE PRECISION FEE C CALL IDATE (IM,ID,IY) C OPEN FILES OPEN (UNIT=1,NAME='GRFS.DAT',TYPE='OLD') OPEN (UNIT=2,NAME='GRFSAR.DAT',TYPE='OLD') C K=1 M=27 C READ IN SOURCE OF SALES NAMES DO 360,J=1,9 READ (2,350)(IT(I),I=K,M) 350 FORMAT(27A1) K=K+27 M=M+27 360 CONTINUE CC TYPE 10 CC 10 FORMAT('SOURCE DATA READ (LINE=16)' ) C READ IN RATES DATA READ (2,370)(D(I),I=1,9) 370 FORMAT(9(F5.2,X)) READ (2,370)(F(I),I=1,9) READ (2,370)(H(I),I=1,9) C C C CLOSE ARRAY DATA FILE --- C CLOSE (UNIT=2) C C C ...... READ IN NUMBER OF TIME GRFS.FTN IS TO BE LOOPED C C READ (1,10) NLOOP C 10 FORMAT (I2) C C ...... START LOOP C C ILOOP = 0 C ILOOP = ILOOP + 1 C IF (ILOOP .GT. NLOOP ) GO TO 9999 C C ...... START CALULATION C CC TYPE 11 CC 11 FORMAT(' ARRAYS D,F,H HAVE BEEN READ (LINE=21)' ) C 100 CONTINUE C READ IN 21 DATA ITEMS C K=1 M=30 400 CONTINUE DO 200,J=1,5 READ (1,330,END=9999)(IX(I),I=K,M) 330 FORMAT(30A1) K=K+30 M=M+30 200 CONTINUE C OPEN (UNIT=3,NAME='GRFS.RPT',TYPE='NEW') C READ IN 'FEE CALCULATION SALES' C READ (1,210) FEE 210 FORMAT(F11.2) B(11)=FEE C READ (1,300)(A(I),I=1,10),S,A(19),FR,AM(9) *,AM(11),A(20) 300 FORMAT (F11.2/F11.2/F11.2/F11.2/F11.2 */F11.2/F11.2/F11.2/F11.2/F11.2/F6.3/F8.2/F6.3/F11.2/F11.2/F11.2) J=0 C CC TYPE 12 CC 12 FORMAT(' A,S,A(19),FR,AM(9),AM(11), & A(20) READ (LINE=36)') C C TOTAL AMOUNTS OF SALES DO 480,J=1, 9 B(J)=A(J) B(10)=B(10)+B(J) 480 CONTINUE CCC TYPE 13 CC 13 FORMAT(' B(J) & B(10) CALCULATED (LINE=41)') J=0 DO 615,J=1,9 C CALCULATE SALES C(J)=(B(J)/B(10)*100.) CC TYPE 14 CC 14 FORMAT( ' C(J) ARRAY CALCULATED (LINE=47)') C ADD TO TOTAL PER-CENT C(10)=C(10)+C(J) C CALCULATE B.E. POINT AND ADD TO B.E. TOTAL E(J)=C(J)*D(J) E(10)=E(10) + E(J) C CONVERT RATES TO % C D(J)=D(J)*100. C CALCULATE BASE RATE AND ADD TO BASE RATE TOTAL G(J)=C(J)*F(J)*100. G(10)=G(10) + G(J) CC TYPE 15 CC 15 FORMAT(' ARRAYS C(J),E(J), & H(J) CALCULATED (LINE=52)') C CALCULATE BAL. SALES RATE AND ADD TO TOTAL AI(J)=C(J)*H(J)*100. AI(10)=AI(10) + AI(J) 615 CONTINUE C CALCULATE B.E. POINT AND RATE BASE X=(E(10)*.01)+.5 IN(10)=X D(11)=D(11)+IN(10) F(12)=(G(10)*.0001) XNUM=F(12) CALL ROUND(XNUM) F(12)=XNUM C CALCULATE: 1/2 & 3/2 RATE BASE AND BAL SALES RATE F(13)=(F(12)*.50 ) XNUM=F(13) CALL ROUND(XNUM) F(13)=XNUM F(14)=(F(12)*1.50 ) XNUM=F(14) CALL ROUND(XNUM) F(14)=XNUM F(15)=(AI(10)*.0001 ) XNUM=F(15) CALL ROUND(XNUM) F(15)=XNUM B(20)=A(20) A(13)=B(20)*D(11)*.01 CC TYPE 16 CC 16 FORMAT(' B.E. , 1/2 & 3/2 B.E. POINTS CALCULATED (LINE=76)') C CORRECT ROUNDING ROUTINE CCC IF (C(10).EQ.100.)GOTO 540 C C ADJUST SUBROUTINE ----- C CALL ADJUST(C,IERR) IF(IERR .GT. 5) GO TO 2938 C C CC TYPE 119 CC 119 FORMAT(' ADJUST COMPLETED') 540 CONTINUE CC TYPE 117 CC 117 FORMAT(' ROUND ROUTINE COMPLETED (LINE=114)') DIFF=B(10) - A(13) IF (DIFF .GE. 0.) GOTO 730 A(13)=B(10) CC TYPE 116 CC 116 FORMAT(' A(13) CALCULATED (LINE=110)') C SALES AT 1/2 BASE -------- 730 CONTINUE A(14)=B(10) - A(13) DIFF=A(13)-A(14) IF(DIFF .GE. 0.) GO TO 770 A(14)=A(13) CC TYPE 17 CC 17 FORMAT(' SALES AT 1/2 BASE CALCULATED (LINE=110)') C SALES AT B.S. RATE ----- 770 CONTINUE A(15)=B(10) - A(13) - A(14) C TOTAL SALES ----- A(16)=A(13) + A(14) + A(15) CC TYPE 18 CC 18 FORMAT(' TOTAL SALES & B.S. RATE CALCULATED (LINE=113)') C CALCULATE: FEE AT 1/2 AND 3/2 BASE AND AT BAL SALES AM(1)=F(13)*A(13)*.01 AM(2)=F(14)*A(14)*.01 AM(3)=F(15)*A(15)*.01 C TYPE 19 CC 19 FORMAT(' FEE AT 1/2 & 3/2 HAS BEEN CALCULATES (LINE=116)' ) C TOTAL FEE ---- AM(4)=AM(1) + AM(2) + AM(3) H(16)=(AM(4)/A(16)*100. ) CC TYPE 20 CC 20 FORMAT( ' TOTAL FEE HAS BEEN CALCULATED (LINE=118)' ) C CALCULATE: SURCHARGE, COMMISSION, & FRANCHISE FEES ---- AM(5)=(AM(4)*S*.01) AM(6)=(A(10)*H(16) ) AM(7)=(A(19)*FR) CC TYPE 21 CC 21 FORMAT(' SURCHARGE ETC. HAS BEEN CALCULATED (LINE=121)' ) C CALCULATE FEE EARNED & TOTAL FEE DUE -- AM(8)=AM(4)+AM(5)+AM(6)+AM(7) AM(10)=AM(8) DIFF=AM(10)-AM(9) IF(DIFF .GE. 0.) GO TO 920 AM(10)=AM(9) 920 CONTINUE AM(12)=AM(10)-AM(11) IF (AM(12) .LT. 0)GOTO 950 GO TO 970 950 CONTINUE AM(13)=AM(11)-AM(10) CC TYPE 22 CC 22 FORMAT(' FEES EARNED & TOTAL FEES DUE (LINE=134)' ) C TENTATIVE & MINIMUM FEE ---- 970 CONTINUE H(17)=(AM(8)/(A(16)+A(10)+A(19))*100.) AM(14)=(B(20)*D(11)*F(13)*.000008)*5. CC TYPE 23 CC 23 FORMAT(' *** ENTERING PRINT SECTION *** (LINE=138) ') C *************************************************************** C C PERMIT FORMAT SECTION C C *************************************************************** C C WRITE (3,1165) 1165 FORMAT (1H ,///) WRITE(3, 2950) WRITE (3,1180)(IX(I),I=1,30) 1180 FORMAT (' USDA-FOREST SERVICE : A. PERMITTEE:',2X,30A1 *,': B. LUR IDENTITY CODE:') WRITE (3,1200)(IX(I),I=31,60) 1200 FORMAT (' FEE CALCULATION FOR :',16X,30A1 *,':') WRITE (3,1220)(IX(I),I=61,90),(IX(I),I=121,150) 1220 FORMAT (' CONCESSION PERMITS :',16X,30A1 *,': ',30A1) WRITE (3,1240) 1240 FORMAT (' ------------------------------------------------', *'--------------------------------------------------') WRITE (3,1260) 1260 FORMAT (' C. PERIOD:',31X,': D. FEE CALCULATION SALES:', *3X,': E. GROSS FIXED ASSETS:') WRITE (3,1280) 1280 FORMAT (43X,':',29X,':') WRITE (3,1290)(IX(I),I=91,120),B(11),A(20) 1290 FORMAT (9X,30A1,4X,':',4X,'$',F11.2,13X,':',4X,'$',F11.2) WRITE (3,2950) WRITE (3,1340) 1340 FORMAT (29X,':',4X,'SALES FOR',6X,':BREAK-EVEN POINT:', *17X,':BALANCE OF SALES') WRITE (3,1360) 1360 FORMAT (29X,':FEE CALCULATION',4X,':',16X,':',4X, *'RATE BASE',4X,':',6X,'RATE') WRITE (3,1380) 1380 FORMAT (8X,'SOURCE OF SALES :-------------------:--', *'--------------:-----------------:-----------------') WRITE (3,1400) 1400 FORMAT (29X,':',2X,'AMOUNTS',2X,':',7X,':',6X,':',9X, *':',6X,':',11X,':',6X,':') WRITE (3,1420) 1420 FORMAT (29X,':',6X,'I',4X,': II : III :',4X,'IV : V', *3X,':',5X,'VI',4X,':',2X,'VII',X,':',2X,'VIII') WRITE (3,1440) 1440 FORMAT (' ---------------------------:-----------:-------:-', *'-----:---------:------:-----------:------:---------') J=0 L=0 K=1 M=27 DO 1720,J=1,9 IF (B(J).LE.0.) GO TO 1710 WRITE (3,1500)(IT(I),I=K,M),B(J),C(J),D(J),E(J),F(J),G(J),H(J), *AI(J) 1500 FORMAT (2H ,27A1,':',F11.2,':',F6.2,' :',2X,F3.0,' :',2X, * F5.0,2X,':',F5.2,' :',2X,F7.0,' :',F5.2,' :',F8.0) 1710 CONTINUE K=K+27 M=M+27 1720 CONTINUE J=0 WRITE (3,2950) WRITE (3,1800)B(10),C(10),E(10),G(10),AI(10) 1800 FORMAT (23X,'TOTAL :',F11.2,':',F6.2,' :******:',1X,F6.0,2X, *':******:',2X,F7.0,2X,':******:',F8.0) WRITE (3,2950) WRITE (3,1890) 1890 FORMAT (26X,'ITEMS',25X,': RATE :', *6X,'SALES : FEE',6X,':') WRITE (3,1910) 1910 FORMAT (' ------------------------------------------------', *'------:---------:----------------:----------------:') WRITE (3,1930)D(11) 1930 FORMAT (' 1. COMPOSITE BREAK-EVEN POINT',24X,': ',F4.0, *3X,':****************:****************') WRITE (3,1960)F(12) 1960 FORMAT (' 2. COMPOSITE BASE RATE',31X,':',3X,F5.2,1X, *':****************:****************') WRITE (3,1990) 1990 FORMAT (' 3. COMPUTATION OF BASIC FEE',26X,':*********: *****************:****************') WRITE (3,2010)F(13),A(13),AM(1) 2010 FORMAT (' A. ON SALES BELOW BREAK-EVEN',22X,':' *,3X,F5.2,' : $',F11.2,3X,': $',F11.2) WRITE (3,2070)F(14),A(14),AM(2) 2070 FORMAT (' B. ON SALES FROM BREAK-EVEN TO TWICE BREAK-EVEN *:',3X,F5.2,1X,': $',F11.2,3X,': ',F11.2) WRITE (3,2130)F(15),A(15),AM(3) 2130 FORMAT (' C. ON SALES GREATER THAN TWICE BREAK-EVEN',9X, *':',3X,F5.2,1X,': $',F11.2,3X,': ',F11.2/ *56X,':---------:----------------:----------------') WRITE (3,2200)A(16),AM(4) 2200 FORMAT (' 4. TOTALS (SALES AND BASIC FEE)',22X,':*********:' *,1X,'$',F11.2,3X,':',X,'$',F11.2) WRITE (3,2250) 2250 FORMAT (56X,':---------:----------------:----------------') WRITE (3,2260)H(16) 2260 FORMAT (' 5. WEIGHTED AVERAGE FEE RATE',25X,':'1X,F6.2,1X,' : *****************:****************') WRITE (3,2300) 2300 FORMAT (56X,':--------------------------:----------------') IF (S-0.)2320,2320,2325 2320 CONTINUE AM(4)=0. 2325 WRITE (3,2330)AM(4),S,AM(5) 2330 FORMAT (' 6. SURCHARGE (IF ANY) ','$',F11.2,' X ' *,F4.2,' %',24X,'= : $',F11.2) 2395 CONTINUE AM(4)=AM(1) + AM(2) + AM(3) WRITE (3,2400)A(10),H(16),AM(6) 2400 FORMAT (' 7. COMMISSIONS AND OTHER INCOME $',F11.2,' X ', *F6.2,' %',21X,'= : $',F11.2) WRITE (3,2470)A(19),FR,AM(7) 2470 FORMAT (' 8. FRANCHISE PAYMENTS $',F11.2,' X ', *F6.2,' %',21X,'= : $',F11.2) WRITE (3,2540)AM(8) 2540 FORMAT (' 9. FEE EARNED --------------------------------- *-------------------------------> : $',F11.2) WRITE (3,2570) 2570 FORMAT (83X,':----------------') WRITE (3,2580)AM(9) 2580 FORMAT (' 10. MINIMUM FEE PAID --------------------------- *-------------------------------> : $',F11.2) WRITE (3,2570) WRITE (3,2620)AM(10) 2620 FORMAT (' 11. TOTAL FEE DUE ------------------------------ *-------------------------------> : $',F11.2) WRITE (3,2650)AM(11) 2650 FORMAT (' 12. PAYMENTS TO DATE (INCLUDING CREDITS) ------- *-------------------------------> : $',F11.2) IF (AM(12).LT.0)GOTO 2725 WRITE (3,2690)AM(12) 2690 FORMAT (' 13. BALANCE DUE -------------------------------- *-------------------------------> : $',F11.2) GOTO 2760 2725 WRITE (3,2730)AM(12) 2730 FORMAT (' 13. CREDIT DUE --------------------------------- *-------------------------------> : $',F11.2) 2760 WRITE (3,2950) WRITE (3,2770) 2770 FORMAT (' PREPARED BY : DATE:', *6X,': CHECKED BY',25X, ': DATE:') WRITE (3,2800)IM,ID,IY 2800 FORMAT (37X,': ',I2,'-',I2,'-',I2,2X,':',36X,':') WRITE (3,2950) WRITE (3,2850)AM(14) 2850 FORMAT (' MINIMUM ANNUAL FEE: $',F11.2) WRITE (3,2870) H(17) 2870 FORMAT (' TENTATIVE FEE RATE: ',F6.2, *' PER-CENT') 2950 FORMAT (100H ================================================ *==================================================) 3020 FORMAT (32X,':',10X,':',5X,':',6X,':',9X,':',6X,':',9X,':',6X,':') CLOSE (UNIT=3,DISPOSE='SAVE') K=0 M=30 2938 CONTINUE IF ( IERR .GT. 5 ) TYPE 9000 , IERR 9000 FORMAT ( 'ADJUST FAILED - IERR = ', I2 ) C C CLOSE PRINT FILES C GO TO 100 C 9999 CLOSE ( UNIT=1, DISPOSE='SAVE') STOP C END SUBROUTINE ROUND(X) C C X=X*100. IX=X Y=IX C Z=X-Y IF(Z .GE. .5) Y=Y+1. Y=Y*.01 X=Y RETURN END SUBROUTINE ADJUST ( C, IERR ) C C ..... SUBROUTINE ADJUST RE-ADJUSTS THE VALUES OF THE C ..... PERCENTAGE CALCULATION SO THAT THE TOTAL VALUE C ..... ALWAYS EQUALS 100%. C DOUBLE PRECISION C(10), R(9), H(10), T(9), VALM(9) DOUBLE PRECISION DIFF, UNIT C UNIT = 1.0000 C C C C ..... TRUNCATE TO TEN-THOUSANDS COLUMN. C DO 100 I=1,9 T(I) = C(I) * 1000. R(I) = DMOD ( T(I), UNIT ) T(I) = T(I) - R(I) 100 CONTINUE C C ..... FIND THOUSANDS COLUMN AND TRUNCATE TO HUNDREDTHS COLUMN C DO 110 I = 1, 9 H(I) = T(I) * 0.1 R(I) = DMOD ( H(I), UNIT ) H(I) = H(I) - R(I) T(I) = T(I) - ( H(I) * 10. ) 110 CONTINUE C C ..... T(I): VALUE OF THE THOUSANDS COLUMN C ..... H(I): PER-CENT ACCURATE TO HUNDRETHS C C ..... SUM H(I) C IERR = 0 150 IERR = IERR + 1 IF ( IERR .GT. 5 ) RETURN H(10) = 0. DO 200 I=1,9 200 H(10) = H(10) + H(I) C C ..... DIAGNOSTIC CHECK ---- C C TYPE 10 C 10 FORMAT (7X,'T',7X,'H',7X,'R' ) C C DO 210 I=1,9 C TYPE 11, T(I), H(I), R(I) C 11 FORMAT ( 3 (2X,F12.7) ) C 210 CONTINUE C C ACCEPT 12, IANS C 12 FORMAT (A1) C IF( H(10) .EQ. 10000. ) GO TO 500 C C ..... SUM NOTE EQUAL TO 100 --- ADJUST. C C ..... THE ADJUSTMENT IS MADE BY DETERMINING C ..... THE THOUSANDS VALUE CLOSEST TO 5, THEN C ..... CORRECTING THAT RECORD BY THE APPROPRIATE C ..... CORRECTION. C C DIFF = H(10) - 10000. C C KMIN = 0 XMID = 9. DO 300 I=1,9 VALM(I) = T(I) - 5. IF(VALM(I) .LT. 0. ) VALM(I) = -VALM(I) IF( VALM(I) .GE. XMID ) GO TO 300 KMIN = I XMID = VALM(I) 300 CONTINUE C C ..... SET H-VALUES C IF ( DIFF .LT. 0. ) GO TO 400 H(KMIN) = H(KMIN) - DIFF GO TO 150 C 400 DIFF = -DIFF H(KMIN) = H(KMIN) + DIFF GO TO 150 C C ..... SET C-VALUES C 500 DO 600 I=1,10 600 C(I) = H(I) * .01 C RETURN END