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        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