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        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=ZR*ZR-ZI*ZI+X
  87       ZI=2.0*ZR*ZI+Y
  88       ZR=ZRN
  89 C
  90        IF ((ZR*ZR+ZI*ZI).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 C       IF (COUNT.GE.8) NOUT=46
  98 C       IF (COUNT.GE.23) NOUT=43
  99 C       IF (COUNT.EQ.MAXI) NOUT=64
 100        IF (COUNT.GE.8) NOUT=46
 101        IF (COUNT.GE.23) NOUT=43
 102        IF (COUNT.EQ.MAXI) NOUT=64
 103
 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
 135        WIDTH   = 68
 136        MAXI    = 60
 137        MAXVAL  = 2.0
 138        LOWX    =-1.48
 139        HIGHX   = 0.5
 140        LOWY    =-1.2
 141        HIGHY   = 1.2
 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