sw/src/f4/MANDEL.FT

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