Directory of image this file is from
This file as a plain text file

C	HAUPTPROGRAMM
C	NAME: RB2704
C	BERECHNET KLEINPHIRB UND GROSSPHIRB

	COMMON ASUM,BSUM
	DIMENSION ASUM(500),BSUM(500)

	READ(1,100) IN
100	FORMAT('ANZAHL DER SCHRITTE: 'I7)

	READ(1,200) RQ,RC1,RC2,RC3
200	FORMAT('  Q='F5.1/'  C1='F5.1/'  C2='F5.1/'  C3='F5.1)

	RTIN=1.0/(FLOAT(IN))

	RALPH=RTIN*RQ
	RBETA=RTIN*(1.2+RQ)
	RGAMM=RTIN*(1.2+RC3-RC1+RQ)


C	**** BERECHNUNG VON KLEIN PHIRA+RK ****
C	
	IF (RQ) 1000,1405,1000

1000	CALL SQUAR(0.3,1.5,0.,RM,RB,RH)
	PHIRA=1.0/RQ

	CALL OOPEN('DCWR',0)
	DO 1200 J=1,IN
	SUM=0.

	DO 1100 I=1,IN
	RT1=0.3+RBETA*FLOAT(J-1)-RALPH*FLOAT(I-1)
	IF (RT1-0.3) 1100,1100,1020
1020	IF (RT1-1.5) 1040,1040,1100
C	GO 1100, CAUSE PHIRK=0.0
1040	PHIRK=RT1*RM+RB
	SUM=SUM+PHIRA*PHIRK
1100	CONTINUE
	BSUM(J)=RALPH*SUM
1200	CONTINUE
	CALL OCLOSE

C	BERECHNUNG VON KLEINPHIRB

	CALL SQUAR(RC1,RC2,RC3,RM,RB,RH)

	DO 1400 K=1,IN
	SUM=0.

	DO 1300 J=1,IN
	RT1=RC1+RGAMM*FLOAT(K-1)-RBETA*FLOAT(J-1)
	IF (RT1-RC1) 1300,1300,1202
1202	IF (RT1-RC3) 1205,1205,1300
1205	IF (RT1-RC2) 1210,1220,1220
1210	PHIRU=RM*RT1+RB
	GOTO 1230
1220	PHIRU=RH
1230	SUM=SUM+BSUM(J)*PHIRU
1300	CONTINUE

	ASUM(K)=RBETA*SUM
1400	CONTINUE
	GOTO 1700

C	*** SONDERFALL MIT Q=0 ***

1405	CALL SQUAR(0.3,1.5,0.,RSTEI,RORD,RH)
	CALL SQUAR(RC1,RC2,RC3,RM,RB,RH)

	DO 1600 K=1,IN
	SUM=0.

	DO 1500 J=1,IN
	RT1=RC1+RGAMM*FLOAT(K-1)-RBETA*FLOAT(J-1)
	RT2=0.3+RBETA*FLOAT(J-1)
	IF (RT2-0.3) 1500,1500,1403
1403	IF (RT2-1.5) 1404,1404,1500
1404	IF (RT1-RC1) 1500,1500,1407
1407	IF (RT1-RC3) 1409,1409,1500
1409	IF (RT1-RC2) 1410,1420,1420
1410	PHIRU=RM*RT1+RB
	GOTO 1430
1420	PHIRU=RH
1430	PHIRK=RSTEI*RT2+RORD
	SUM=SUM+PHIRK*PHIRU
1500	CONTINUE

	ASUM(K)=RBETA*SUM
1600	CONTINUE

1700	CALL OOPEN('DCWR',0)

	WRITE(4,1800)
	WRITE(4,1810)
	WRITE(4,1820)
	WRITE(4,1800)
	WRITE(4,1830)
	WRITE(4,1800)

1800	FORMAT(2/)
1810	FORMAT('BERECHNUNG VON KLEIN UND GROSS PHIRB')
1820	FORMAT('------------------------------------')
1830	FORMAT('INDEX',4X,'ARGUMENT',8X,'LPHIRB',12X,'HPHIRB')

C	BERECHNUNG VON GROSS PHIRB

	DO 1950 K=1,IN
	SUM=0.

	DO 1900 J=1,K
	SUM=SUM+ASUM(J)
1900	CONTINUE

	SUM=SUM*RGAMM
	RT1=RC1+0.3+RGAMM*FLOAT(K-1)
	WRITE(4,1910) K,RT1,ASUM(K),SUM
1910	FORMAT(I5,'  ',E15.6,'  ',F15.10,'  ',F15.10)
1950	CONTINUE

	CALL OCLOSE
	CALL EXIT
	END