[h316.git] / programs / mandelbrot / src / apfel3.f

C    APFELMAENNCHEN-PROGRAMM, 02.APRIL.2006 PHILIPP HACHTMANN
C    INTERMEDIATE VERSION
C
C    THIS VERSION SHOULD RUN A BIT FASTER BECAUSE THE SQUARE
C    ROOT IS OMMITTED.
C
C    SWITCH SETTINGS:
C    SENSE-SWITCH 1: IF SET, ASK FOR PARAMETERS
C    SENSE-SWITCH 2: IF SET, DON'T PRINT PARAMETERS ON START
C    SENSE-SWITCH 3: IF SET, RESTORE PARAMETERS TO DEFAULT VALUES
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                        COMMON BLOCK DECLARATIONS
C
       INTEGER        MAXI,WIDTH,CR,LF,POSI,NEGA
       COMMON /PARAM2/MAXI,WIDTH,CR,LF,POSI,NEGA
C
       REAL           LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
       COMMON /PARAM1/LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
C
       INTEGER INIT
       COMMON /PARAM3/INIT
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                        START MESSAGE
  100  WRITE (1,10)
   10  FORMAT (46HMANDELBROT-DEMO 3RC1 02.04.2006, PH. HACHTMANN,
     + 20H - PRELIMIMARY ISSUE)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                        CONFIGURATION
CCCCCC RESET DO DEFAULT VALUES?
  110  CALL SSWTCH(3,I)
       IF (I.EQ.1) CALL RST
C    
CCCCCC ON THE FIRST START OR IF DESIRED
       IF(INIT.EQ.0) CALL STVAL
C
CCCCCC DO WE HAVE TO ASK FOR PARAMETERS?
       CALL SSWTCH(1,I)
       IF (I.EQ.1) CALL GETCFG
C
CCCCCC OUTPUT SETTINGS?      
       CALL SSWTCH(2,I)
       IF(I.EQ.2) CALL OUTCFG
C
       WRITE  (1,55)
   55  FORMAT (1H0)
C
       CALL CALC2
C
       WRITE(1, 60)
   60  FORMAT (5HREADY)
C
CCCCCC BREAK WITH 7 in A REG, THEN START OVER
       PAUSE 7
       GO TO 100
       END
C      END OF MAIN PROGRAM
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCC THE MANDELBROT SET CALCULATION
       SUBROUTINE CALC2
C            
       INTEGER        MAXI,WIDTH,CR,LF
       COMMON /PARAM2/MAXI,WIDTH,CR,LF
       REAL           LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
       COMMON /PARAM1/LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
       REAL CMPAVL
       REAL ZR,ZI,ZRN
       REAL X,Y
       INTEGER COUNT
C
CCCCCC ENTER THE CALCULATION
  299  CMPVAL=MAXVAL*MAXVAL
       X=LOWX
       Y=HIGHY
C     
CCCCCC EINSTIEG IN DEN AKTUELLEN PUNKT
  300  COUNT=0
       ZR=0.0
       ZI=0.0
C
CCCCCC HIER DER ITERIERTE TEIL
C
  400 ZRN=ZR*ZR-ZI*ZI+X
      ZI=2.0*ZR*ZI+Y
      ZR=ZRN
C
       IF ((ZR*ZR+ZI*ZI).GE.CMPVAL) GO TO 410
       COUNT=COUNT+1
       IF (COUNT.GE.MAXI)     GO TO 410
       GO TO 400
C
CCCCCC PUNKT FERTIG
  410  NOUT=32
       IF (COUNT.GE.8) NOUT=46
       IF (COUNT.GE.23) NOUT=43
       IF (COUNT.EQ.MAXI) NOUT=64
C       NOUT=46
  411  CALL PCHAR(NOUT)
       GO TO 500
C
CCCCCC NEUEN PUNKT MACHEN
  500  X = X + XSTEP
CCCCCC ZEILE NOCH NICHT VOLL?
       IF (X.LE.HIGHX) GO TO 300
CCCCCC X AN ANFANG SETZTEN, CR+LF DRUCKEN
       X = LOWX
       CALL PCHAR(CR)
       CALL PCHAR(LF)
CCCCCC Y WEITERRUECKEN - NEGATIV WEIL WIR VON OBEN KOMMEN
       Y=Y-YSTEP
       IF (Y.GE.LOWY) GO TO 300
C
CCCCCC HIER IST DAS BILD FERTIG.       
       RETURN
       END 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCC STARTWERTE AUSFUELLEN
       SUBROUTINE STVAL
C
       INTEGER        MAXI,WIDTH,CR,LF
       COMMON /PARAM2/MAXI,WIDTH,CR,LF
       REAL           LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
       COMMON /PARAM1/LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
       INTEGER INIT
       COMMON /PARAM3/INIT
C
       CR      = 13 
       LF      = 10
       WIDTH   = 70
       MAXI    = 60
       MAXVAL  = 2.0
       LOWX    =-1.45
       HIGHX   = 0.45
       LOWY    =-1.00
       HIGHY   = 1.00
       INIT    =  1
C  
CCCCCC SCHRITTWEITEN AUSRECHNEN
       XSTEP = (HIGHX-LOWX)/FLOAT(WIDTH)
       YSTEP = 2.0 * XSTEP
C
       WRITE (1,1500)
 1500  FORMAT (20HDEFAULT VALUES USED.)
       RETURN
       END
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCC EINSTELLUNGEN EINLESEN
       SUBROUTINE GETCFG
C
       INTEGER        MAXI,WIDTH,CR,LF
       COMMON /PARAM2/MAXI,WIDTH,CR,LF
       REAL           LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
       COMMON /PARAM1/LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
C
       REAL XIN1,XIN2,YIN1,YIN2
C
       WRITE(1,11)
       READ (1,16) XIN1
       WRITE(1,12)
       READ (1,16) XIN2
       WRITE(1,13)
       READ (1,16) YIN1
       WRITE(1,14)
       READ (1,16) YIN2
       WRITE(1,15)
       READ (1,17) MAXI
C
   11  FORMAT(14H X FROM     : )
   12  FORMAT(14H     TO     : )       
   13  FORMAT(14H Y FROM     : )
   14  FORMAT(14H     TO     : )
   15  FORMAT(14H  MAXIT (I3): )
   16  FORMAT(F12.0)
   17  FORMAT(I3)
C
CCCCCC EVENTUELL STARTWERTE TAUSCHEN:
CCCCCC WENN XIN2 GROESSER IST OK, ANSONSTEN TAUSCHEN
  150  I F(XIN2.GT.XIN1) GO TO 200
       TEMP = XIN1
       XIN1 = XIN2
       XIN2 = TEMP
C       
CCCCCC WENN YIN2 GROESSER IST OK, ANSONSTEN TAUSCHEN
  200  IF(YIN2.GT.YIN1) GO TO 201
       TEMP = YIN1
       YIN1 = YIN2
       YIN2 = TEMP
C
CCCCCC WERTE UEBERNEHMEN
  201  LOWX  = XIN1
       HIGHX = XIN2
       LOWY  = YIN1
       HIGHY = YIN2
C
CCCCCC SCHRITTWEITEN AUSRECHNEN
       XSTEP = (HIGHX-LOWX)/FLOAT(WIDTH)
       YSTEP = 2.0 * XSTEP
C
       RETURN
       END       
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCC EINSTELLUNGEN AUSGEBEN
       SUBROUTINE OUTCFG
C
       INTEGER        MAXI,WIDTH,CR,LF
       COMMON /PARAM2/MAXI,WIDTH,CR,LF
       REAL           LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
       COMMON /PARAM1/LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
C
       WRITE  (1,20)
  20   FORMAT (9HSETTINGS:)
       WRITE  (1,30) LOWX, HIGHX
  30   FORMAT (12HX-WERTE VON ,1F8.5,5H BIS ,1F8.5)
       WRITE  (1,40) LOWY, HIGHY
   40  FORMAT (12HY-WERTE VON ,F8.5,5H BIS ,F8.5)     
       WRITE  (1,50) MAXI, MAXVAL, XSTEP, YSTEP, WIDTH
   50  FORMAT (   4HMAX:,I3,
     +        8H MAXVAL:,F8.5,
     +         7H XSTEP:,F8.5,
     +         7H YSTEP:,F8.5,
     +         7H WIDTH:,I2)
       RETURN
       END
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCC RUECKSETZEN
       SUBROUTINE RST
C
       INTEGER        MAXI,WIDTH,CR,LF
       COMMON /PARAM2/MAXI,WIDTH,CR,LF
C
       WRITE(1,245)
  245  FORMAT(25HPARAMETER RESET REQUESTED)
       INIT=0
       RETURN
       END
C
C       
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                        PRELOAD VALUE OF INIT
       BLOCK DATA
       INTEGER INIT
       COMMON /PARAM3/INIT
       DATA INIT/0/ 
       END
CCCCCCCCCCCCCCCCCCCCCCCC
$0
Commit	Line	Data
b098c879	1	C APFELMAENNCHEN-PROGRAMM, 02.APRIL.2006 PHILIPP HACHTMANN
	2	C INTERMEDIATE VERSION
	3	C
	4	C THIS VERSION SHOULD RUN A BIT FASTER BECAUSE THE SQUARE
	5	C ROOT IS OMMITTED.
	6	C
	7	C SWITCH SETTINGS:
	8	C SENSE-SWITCH 1: IF SET, ASK FOR PARAMETERS
	9	C SENSE-SWITCH 2: IF SET, DON'T PRINT PARAMETERS ON START
	10	C SENSE-SWITCH 3: IF SET, RESTORE PARAMETERS TO DEFAULT VALUES
	11	C
	12	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	13	C COMMON BLOCK DECLARATIONS
	14	C
	15	INTEGER MAXI,WIDTH,CR,LF,POSI,NEGA
	16	COMMON /PARAM2/MAXI,WIDTH,CR,LF,POSI,NEGA
	17	C
	18	REAL LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
	19	COMMON /PARAM1/LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
	20	C
	21	INTEGER INIT
	22	COMMON /PARAM3/INIT
	23	C
	24	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	25	C START MESSAGE
	26	100 WRITE (1,10)
	27	10 FORMAT (46HMANDELBROT-DEMO 3RC1 02.04.2006, PH. HACHTMANN,
	28	+ 20H - PRELIMIMARY ISSUE)
	29	C
	30	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	31	C CONFIGURATION
	32	CCCCCC RESET DO DEFAULT VALUES?
	33	110 CALL SSWTCH(3,I)
	34	IF (I.EQ.1) CALL RST
	35	C
	36	CCCCCC ON THE FIRST START OR IF DESIRED
	37	IF(INIT.EQ.0) CALL STVAL
	38	C
	39	CCCCCC DO WE HAVE TO ASK FOR PARAMETERS?
	40	CALL SSWTCH(1,I)
	41	IF (I.EQ.1) CALL GETCFG
	42	C
	43	CCCCCC OUTPUT SETTINGS?
	44	CALL SSWTCH(2,I)
	45	IF(I.EQ.2) CALL OUTCFG
	46	C
	47	WRITE (1,55)
	48	55 FORMAT (1H0)
	49	C
	50	CALL CALC2
	51	C
	52	WRITE(1, 60)
	53	60 FORMAT (5HREADY)
	54	C
	55	CCCCCC BREAK WITH 7 in A REG, THEN START OVER
	56	PAUSE 7
	57	GO TO 100
	58	END
	59	C END OF MAIN PROGRAM
	60	C
	61	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	62	CCCCCC THE MANDELBROT SET CALCULATION
	63	SUBROUTINE CALC2
	64	C
65	INTEGER MAXI,WIDTH,CR,LF
66	COMMON /PARAM2/MAXI,WIDTH,CR,LF
67	REAL LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
68	COMMON /PARAM1/LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
69	REAL CMPAVL
70	REAL ZR,ZI,ZRN
71	REAL X,Y
72	INTEGER COUNT
73	C
74	CCCCCC ENTER THE CALCULATION
75	299 CMPVAL=MAXVAL*MAXVAL
76	X=LOWX
77	Y=HIGHY
78	C
79	CCCCCC EINSTIEG IN DEN AKTUELLEN PUNKT
80	300 COUNT=0
81	ZR=0.0
82	ZI=0.0
83	C
84	CCCCCC HIER DER ITERIERTE TEIL
85	C
86	400 ZRN=ZRZR-ZIZI+X
87	ZI=2.0ZRZI+Y
88	ZR=ZRN
89	C
90	IF ((ZRZR+ZIZI).GE.CMPVAL) GO TO 410
91	COUNT=COUNT+1
92	IF (COUNT.GE.MAXI) GO TO 410
93	GO TO 400
94	C
95	CCCCCC PUNKT FERTIG
96	410 NOUT=32
97	IF (COUNT.GE.8) NOUT=46
98	IF (COUNT.GE.23) NOUT=43
99	IF (COUNT.EQ.MAXI) NOUT=64
100	C NOUT=46
101	411 CALL PCHAR(NOUT)
102	GO TO 500
103	C
104	CCCCCC NEUEN PUNKT MACHEN
105	500 X = X + XSTEP
106	CCCCCC ZEILE NOCH NICHT VOLL?
107	IF (X.LE.HIGHX) GO TO 300
108	CCCCCC X AN ANFANG SETZTEN, CR+LF DRUCKEN
109	X = LOWX
110	CALL PCHAR(CR)
111	CALL PCHAR(LF)
112	CCCCCC Y WEITERRUECKEN - NEGATIV WEIL WIR VON OBEN KOMMEN
113	Y=Y-YSTEP
114	IF (Y.GE.LOWY) GO TO 300
115	C
116	CCCCCC HIER IST DAS BILD FERTIG.
117	RETURN
118	END
119	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
120	CCCCCC STARTWERTE AUSFUELLEN
121	SUBROUTINE STVAL
122	C
123	INTEGER MAXI,WIDTH,CR,LF
124	COMMON /PARAM2/MAXI,WIDTH,CR,LF
125	REAL LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
126	COMMON /PARAM1/LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
127	INTEGER INIT
128	COMMON /PARAM3/INIT
129	C
130	CR = 13
131	LF = 10
132	WIDTH = 70
133	MAXI = 60
134	MAXVAL = 2.0
135	LOWX =-1.45
136	HIGHX = 0.45
137	LOWY =-1.00
138	HIGHY = 1.00
139	INIT = 1
140	C
141	CCCCCC SCHRITTWEITEN AUSRECHNEN
142	XSTEP = (HIGHX-LOWX)/FLOAT(WIDTH)
143	YSTEP = 2.0 * XSTEP
144	C
145	WRITE (1,1500)
146	1500 FORMAT (20HDEFAULT VALUES USED.)
147	RETURN
148	END
149	C
150	C
151	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
152	CCCCCC EINSTELLUNGEN EINLESEN
153	SUBROUTINE GETCFG
154	C
155	INTEGER MAXI,WIDTH,CR,LF
156	COMMON /PARAM2/MAXI,WIDTH,CR,LF
157	REAL LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
158	COMMON /PARAM1/LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
159	C
160	REAL XIN1,XIN2,YIN1,YIN2
161	C
162	WRITE(1,11)
163	READ (1,16) XIN1
164	WRITE(1,12)
165	READ (1,16) XIN2
166	WRITE(1,13)
167	READ (1,16) YIN1
168	WRITE(1,14)
169	READ (1,16) YIN2
170	WRITE(1,15)
171	READ (1,17) MAXI
172	C
173	11 FORMAT(14H X FROM : )
174	12 FORMAT(14H TO : )
175	13 FORMAT(14H Y FROM : )
176	14 FORMAT(14H TO : )
177	15 FORMAT(14H MAXIT (I3): )
178	16 FORMAT(F12.0)
179	17 FORMAT(I3)
180	C
181	CCCCCC EVENTUELL STARTWERTE TAUSCHEN:
182	CCCCCC WENN XIN2 GROESSER IST OK, ANSONSTEN TAUSCHEN
183	150 I F(XIN2.GT.XIN1) GO TO 200
184	TEMP = XIN1
185	XIN1 = XIN2
186	XIN2 = TEMP
187	C
188	CCCCCC WENN YIN2 GROESSER IST OK, ANSONSTEN TAUSCHEN
189	200 IF(YIN2.GT.YIN1) GO TO 201
190	TEMP = YIN1
191	YIN1 = YIN2
192	YIN2 = TEMP
193	C
194	CCCCCC WERTE UEBERNEHMEN
195	201 LOWX = XIN1
196	HIGHX = XIN2
197	LOWY = YIN1
198	HIGHY = YIN2
199	C
200	CCCCCC SCHRITTWEITEN AUSRECHNEN
201	XSTEP = (HIGHX-LOWX)/FLOAT(WIDTH)
202	YSTEP = 2.0 * XSTEP
203	C
204	RETURN
205	END
206	C
207	C
208	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
209	CCCCCC EINSTELLUNGEN AUSGEBEN
210	SUBROUTINE OUTCFG
211	C
212	INTEGER MAXI,WIDTH,CR,LF
213	COMMON /PARAM2/MAXI,WIDTH,CR,LF
214	REAL LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
215	COMMON /PARAM1/LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
216	C
217	WRITE (1,20)
218	20 FORMAT (9HSETTINGS:)
219	WRITE (1,30) LOWX, HIGHX
220	30 FORMAT (12HX-WERTE VON ,1F8.5,5H BIS ,1F8.5)
221	WRITE (1,40) LOWY, HIGHY
222	40 FORMAT (12HY-WERTE VON ,F8.5,5H BIS ,F8.5)
223	WRITE (1,50) MAXI, MAXVAL, XSTEP, YSTEP, WIDTH
224	50 FORMAT ( 4HMAX:,I3,
225	+ 8H MAXVAL:,F8.5,
226	+ 7H XSTEP:,F8.5,
227	+ 7H YSTEP:,F8.5,
228	+ 7H WIDTH:,I2)
229	RETURN
230	END
231	C
232	C
233	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
234	CCCCCC RUECKSETZEN
235	SUBROUTINE RST
236	C
237	INTEGER MAXI,WIDTH,CR,LF
238	COMMON /PARAM2/MAXI,WIDTH,CR,LF
239	C
240	WRITE(1,245)
241	245 FORMAT(25HPARAMETER RESET REQUESTED)
242	INIT=0
243	RETURN
244	END
245	C
246	C
247	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
248	C PRELOAD VALUE OF INIT
249	BLOCK DATA
250	INTEGER INIT
251	COMMON /PARAM3/INIT
252	DATA INIT/0/
253	END
254	CCCCCCCCCCCCCCCCCCCCCCCC
255	$0