[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
C       IF (COUNT.GE.8) NOUT=46
C       IF (COUNT.GE.23) NOUT=43
C       IF (COUNT.EQ.MAXI) NOUT=64
       IF (COUNT.GE.8) NOUT=46
       IF (COUNT.GE.23) NOUT=43
       IF (COUNT.EQ.MAXI) NOUT=64

  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   = 68
       MAXI    = 60
       MAXVAL  = 2.0
       LOWX    =-1.48
       HIGHX   = 0.5
       LOWY    =-1.2
       HIGHY   = 1.2
       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
4102e16c	97	C IF (COUNT.GE.8) NOUT=46
	98	C IF (COUNT.GE.23) NOUT=43
	99	C IF (COUNT.EQ.MAXI) NOUT=64
b098c879	100	IF (COUNT.GE.8) NOUT=46
	101	IF (COUNT.GE.23) NOUT=43
	102	IF (COUNT.EQ.MAXI) NOUT=64
4102e16c	103
b098c879	104	411 CALL PCHAR(NOUT)
	105	GO TO 500
	106	C
	107	CCCCCC NEUEN PUNKT MACHEN
	108	500 X = X + XSTEP
	109	CCCCCC ZEILE NOCH NICHT VOLL?
	110	IF (X.LE.HIGHX) GO TO 300
	111	CCCCCC X AN ANFANG SETZTEN, CR+LF DRUCKEN
	112	X = LOWX
	113	CALL PCHAR(CR)
	114	CALL PCHAR(LF)
	115	CCCCCC Y WEITERRUECKEN - NEGATIV WEIL WIR VON OBEN KOMMEN
	116	Y=Y-YSTEP
	117	IF (Y.GE.LOWY) GO TO 300
	118	C
	119	CCCCCC HIER IST DAS BILD FERTIG.
	120	RETURN
	121	END
	122	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	123	CCCCCC STARTWERTE AUSFUELLEN
	124	SUBROUTINE STVAL
	125	C
	126	INTEGER MAXI,WIDTH,CR,LF
	127	COMMON /PARAM2/MAXI,WIDTH,CR,LF
	128	REAL LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
	129	COMMON /PARAM1/LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
	130	INTEGER INIT
	131	COMMON /PARAM3/INIT
	132	C
	133	CR = 13
	134	LF = 10
4102e16c	135	WIDTH = 68
b098c879	136	MAXI = 60
b098c879	137	MAXVAL = 2.0
4102e16c	138	LOWX =-1.48
	139	HIGHX = 0.5
	140	LOWY =-1.2
	141	HIGHY = 1.2
b098c879	142	INIT = 1
	143	C
	144	CCCCCC SCHRITTWEITEN AUSRECHNEN
	145	XSTEP = (HIGHX-LOWX)/FLOAT(WIDTH)
	146	YSTEP = 2.0 * XSTEP
	147	C
	148	WRITE (1,1500)
	149	1500 FORMAT (20HDEFAULT VALUES USED.)
	150	RETURN
	151	END
	152	C
	153	C
	154	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	155	CCCCCC EINSTELLUNGEN EINLESEN
	156	SUBROUTINE GETCFG
	157	C
	158	INTEGER MAXI,WIDTH,CR,LF
	159	COMMON /PARAM2/MAXI,WIDTH,CR,LF
	160	REAL LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
	161	COMMON /PARAM1/LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
	162	C
	163	REAL XIN1,XIN2,YIN1,YIN2
	164	C
	165	WRITE(1,11)
	166	READ (1,16) XIN1
	167	WRITE(1,12)
	168	READ (1,16) XIN2
	169	WRITE(1,13)
	170	READ (1,16) YIN1
	171	WRITE(1,14)
	172	READ (1,16) YIN2
	173	WRITE(1,15)
	174	READ (1,17) MAXI
	175	C
	176	11 FORMAT(14H X FROM : )
	177	12 FORMAT(14H TO : )
	178	13 FORMAT(14H Y FROM : )
	179	14 FORMAT(14H TO : )
	180	15 FORMAT(14H MAXIT (I3): )
	181	16 FORMAT(F12.0)
	182	17 FORMAT(I3)
	183	C
	184	CCCCCC EVENTUELL STARTWERTE TAUSCHEN:
	185	CCCCCC WENN XIN2 GROESSER IST OK, ANSONSTEN TAUSCHEN
	186	150 I F(XIN2.GT.XIN1) GO TO 200
	187	TEMP = XIN1
	188	XIN1 = XIN2
	189	XIN2 = TEMP
	190	C
	191	CCCCCC WENN YIN2 GROESSER IST OK, ANSONSTEN TAUSCHEN
	192	200 IF(YIN2.GT.YIN1) GO TO 201
	193	TEMP = YIN1
	194	YIN1 = YIN2
	195	YIN2 = TEMP
	196	C
	197	CCCCCC WERTE UEBERNEHMEN
	198	201 LOWX = XIN1
	199	HIGHX = XIN2
	200	LOWY = YIN1
	201	HIGHY = YIN2
	202	C
	203	CCCCCC SCHRITTWEITEN AUSRECHNEN
	204	XSTEP = (HIGHX-LOWX)/FLOAT(WIDTH)
	205	YSTEP = 2.0 * XSTEP
206	C
207	RETURN
208	END
209	C
210	C
211	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
212	CCCCCC EINSTELLUNGEN AUSGEBEN
213	SUBROUTINE OUTCFG
214	C
215	INTEGER MAXI,WIDTH,CR,LF
216	COMMON /PARAM2/MAXI,WIDTH,CR,LF
217	REAL LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
218	COMMON /PARAM1/LOWX,LOWY,HIGHX,HIGHY,MAXVAL,XSTEP,YSTEP
219	C
220	WRITE (1,20)
221	20 FORMAT (9HSETTINGS:)
222	WRITE (1,30) LOWX, HIGHX
223	30 FORMAT (12HX-WERTE VON ,1F8.5,5H BIS ,1F8.5)
224	WRITE (1,40) LOWY, HIGHY
225	40 FORMAT (12HY-WERTE VON ,F8.5,5H BIS ,F8.5)
226	WRITE (1,50) MAXI, MAXVAL, XSTEP, YSTEP, WIDTH
227	50 FORMAT ( 4HMAX:,I3,
228	+ 8H MAXVAL:,F8.5,
229	+ 7H XSTEP:,F8.5,
230	+ 7H YSTEP:,F8.5,
231	+ 7H WIDTH:,I2)
232	RETURN
233	END
234	C
235	C
236	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
237	CCCCCC RUECKSETZEN
238	SUBROUTINE RST
239	C
240	INTEGER MAXI,WIDTH,CR,LF
241	COMMON /PARAM2/MAXI,WIDTH,CR,LF
242	C
243	WRITE(1,245)
244	245 FORMAT(25HPARAMETER RESET REQUESTED)
245	INIT=0
246	RETURN
247	END
248	C
249	C
250	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
251	C PRELOAD VALUE OF INIT
252	BLOCK DATA
253	INTEGER INIT
254	COMMON /PARAM3/INIT
255	DATA INIT/0/
256	END
257	CCCCCCCCCCCCCCCCCCCCCCCC
258	$0