programs/mandelbrot/src/apfel3.f

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