PROGRAM POLYFRAC IMPLICIT NONE C*************************************************************************** C*** C*** This program generates a chaotic polygon lattice in a 1024x1024 C*** image array, and then outputs it to a file. The user can specify C**** the number of verticies in the polygon, the number of iterations C*** for the fractal generation, and the method for developing the fractal. C*** C*** Compile using : $FORTRAN/EXT C*** C*** Author : Jeff Cameron C*** C*** Modification history : C*** C*** Programmer Date Description C*** ---------------------------------------------------------------------- C*** Jeff Cameron 25-JAN-1996 Initially written C*** ---------------------------------------------------------------------- C*** C*************************************************************************** CHARACTER*80 FILENAME INTEGER*4 LFN INTEGER*2 IMAGE (0:1023,0:1023) INTEGER*2 IVAL INTEGER*1 LINE (0:1023) INTEGER*4 LIMIT INTEGER*4 TYI /5/, TYO /6/, IMG /11/ INTEGER*4 X(0:99), Y(0:99), NVERT INTEGER*4 CX,CY, NX,NY INTEGER*4 POINT,I,J,IST INTEGER*4 RANDOM_VALUE, OPTION INTEGER*4 SEED /123456789/ INTEGER*4 INTERATION, MAX, MAXCOUNT REAL*4 DX,DY,R,DELTA,ANGLE,DIVISOR REAL*4 GOLDENSECTION /0.6/ REAL*4 LAST /1.6/ REAL*4 ROOT2,RATIO REAL*4 BETA, SIDE C INTEGER*4 LENGTH EXTERNAL LENGTH C C*** INITIALIZE THE ARRAY TO full scale white WRITE (TYO,1) 1 FORMAT (' > Initializing.') DO J = 0,1023 DO I = 0,1023 IMAGE (I,J) = 255 END DO END DO C C*** Calculate the golden section DO WHILE (LAST .NE. GOLDENSECTION) LAST = GOLDENSECTION GOLDENSECTION = 1.0 / (1.0+ GOLDENSECTION) END DO C WRITE (TYO,*) ' Golden section = ', GOLDENSECTION C C*** Calculate 1 over root 2 ROOT2 = 1.0 / SQRT (2.0) C C*** Generate Verticies WRITE (TYO,2) ' Enter number of verticies :' 2 FORMAT (A,$) READ (TYI,*) NVERT DELTA = 2.0 * ACOS (-1.0) / FLOAT (NVERT) DO I = 0,NVERT-1 ANGLE = DELTA * FLOAT (I) X(I) = 500.0 * COS (ANGLE) + 512.5 Y(I) = 500.0 * SIN (ANGLE) + 512.5 END DO DIVISOR = NVERT - 1 C C*** Adjacent verticie ratio BETA = ACOS (-1.0) - FLOAT (NVERT-2) / FLOAT (NVERT) SIDE = 1.0 / SQRT (2. + 2. * COS (BETA)) NX = (X(0) - X(1)) ** 2 NY = (X(0) - X(1)) ** 2 CX = (X(0) - X(2)) ** 2 CY = (X(0) - X(2)) ** 2 DX = SQRT (FLOAT(NX + NY)) DY = SQRT (FLOAT(CX + CY)) RATIO = DX / DY WRITE (TYO,*) ' Side = ', SIDE WRITE (TYO,*) ' Ratio= ', RATIO C C*** Pixel limit WRITE (TYO,2) ' Number of itterations : ' READ (TYI,4) LIMIT 4 FORMAT (I) C WRITE (TYO,2) ' Enter output File name : ' READ (TYI,5) FILENAME 5 FORMAT (A) LFN = LENGTH (FILENAME) C 7 WRITE (TYO,5) ' Method operation : ' WRITE (TYO,5) ' 1 = One Half' WRITE (TYO,5) ' 2 = Square Root' WRITE (TYO,5) ' 3 = Golden Section' WRITE (TYO,5) ' 4 = One over root 2' WRITE (TYO,5) ' 5 = Adjacent Sides Ratio' WRITE (TYO,5) ' 5 = Generalized n sided polygon.' WRITE (TYO,2) ' Selection (1,2,3,4,5 or 6) : ' READ (TYI,4) OPTION IF ((OPTION .LT. 1) .OR. (OPTION .GT. 6)) GO TO 7 C C*** INITIALIZE THE BEGINNING COORDINATE CX = JINT (RAN(SEED) * 1023) CY = JINT (RAN(SEED) * 1023) MAX = 0 INTERATION = 0 MAXCOUNT = 0 WRITE (TYO,9) 9 FORMAT (' > Beginning image generation.') C C*** LOOP UNTIL number of itterations = limit 10 INTERATION = INTERATION + 1 IF (INTERATION .GE. LIMIT) GO TO 100 R = RAN (SEED) * 123456.0 RANDOM_VALUE = JINT (R) POINT = MOD (RANDOM_VALUE,NVERT) C DX = X(POINT) - CX DY = Y(POINT) - CY C C*** COMPUTE HALF DISTANCE TO THE FIXED POINT IF (OPTION .EQ. 1) THEN NY = CY + JINT (DY/2.0) ! Half the distance NX = CX + JINT (DX/2.0) C ELSE IF (OPTION .EQ. 2) THEN NY = CY + JINT (SIGN(SQRT(ABS(DY)),DY)) ! Square Root NX = CX + JINT (SIGN(SQRT(ABS(DX)),DX)) C ELSE IF (OPTION .EQ. 3) THEN C*** The golden section NY = CY + JINT (DY*GOLDENSECTION) ! Golden Section NX = CX + JINT (DX*GOLDENSECTION) C ELSE IF (OPTION .EQ. 4) THEN C*** 1 over the Square root of 2 NY = CY + JINT (DY*ROOT2) NX = CX + JINT (DX*ROOT2) ELSE IF (OPTION .EQ. 5) THEN C*** Adjacent sides ratio NY = CY + JINT (DY*RATIO) NX = CX + JINT (DX*RATIO) ELSE IF (OPTION .EQ. 6) THEN NY = CY + JINT (DY/SIDE) NX = CX + JINT (DX/SIDE) ENDIF C IMAGE (NX,NY) = 0 C CX = NX CY = NY GO TO 10 C 100 WRITE (TYO,*) ' > Completed. Writing to disk file.' C OPEN (UNIT=IMG, 1 FILE=FILENAME(1:LFN), 2 TYPE='NEW', 3 ACCESS='DIRECT', 4 RECORDTYPE='FIXED', 5 RECL=256, 6 FORM='UNFORMATTED', 7 IOSTAT=IST) IF (IST .NE. 0) THEN CALL RT_ERROR (TYO,IST) STOP 'OPEN ERROR' ELSE ENDIF C DO J = 0,1023 DO I = 0,1023 IVAL = IIAND(IMAGE(I,J),'00FF'X) IF (IVAL .GT. 127) THEN LINE (I) = IVAL - 256 ELSE LINE (I) = IVAL ENDIF END DO C WRITE (IMG,REC=(J+1),IOSTAT=IST) (LINE(I),I=0,1023) IF (IST .NE. 0) THEN CALL RT_ERROR (TYO,IST) STOP 'WRITE ERROR' ELSE ENDIF END DO C CLOSE (UNIT=IMG,IOSTAT=IST) CALL EXIT END INTEGER*4 FUNCTION LENGTH (STRING) ! SUBROUTINE LENGTH CHARACTER *(*) STRING C************************************************************************ C*** C*** THIS FUNCTION DIFFERS FROM THE STANDARD LEN FUNCTION ONLY C*** IN THAT IT RETURNS THE POSITION OF THE LAST NON-BLANK CHARACTER C*** IN THE STRING, RATHER THAN THE CAPACITY OF THE STRING. C*** C************************************************************************ C*MCT C C*** FIRST DETERMINE THE ACTUAL SIZE OF THE STRING VARIABLE I = LEN (STRING) C 10 IF (STRING (I:I) .NE. ' ' .AND. 1 ICHAR (STRING(I:I)) .GT. 32) THEN LENGTH = I RETURN ELSE I = I - 1 ENDIF IF (I .LE. 0) THEN LENGTH = 0 RETURN ELSE ENDIF GO TO 10 END SUBROUTINE RT_ERROR (OUT,ERROR) INTEGER*4 OUT ! LOGICAL UNIT TO REPORT TO INTEGER*4 ERROR ! FORTRAN RUNTIME ERROR NUMBER C************************************************************************ C*** C*** THIS ROUTINE WILL REPORT THE RUN-TIME ERROR TO THE LOGICAL UNIT C*** SPECIFIED. C*** TWO ERROR TYPES ARE SUPPORTED, 1-68 = SYSTEM: 100-126 = NRTC C*** C************************************************************************ C*MCT C CHARACTER*40 MESS CHARACTER*40 MESSAGE (68), DSK_TAPE (27) C DATA MESSAGE /'Not a FORTRAN specific error ', ! 1 1 ' * Undefined * ', ! 2 1 ' * Undefined * ', ! 3 1 ' * Undefined * ', ! 4 1 ' * Undefined * ', ! 5 1 ' * Undefined * ', ! 6 1 ' * Undefined * ', ! 7 1 ' * Undefined * ', ! 8 1 ' * Undefined * ', ! 9 1 ' * Undefined * ', ! 10 1 ' * Undefined * ', ! 11 1 ' * Undefined * ', ! 12 1 ' * Undefined * ', ! 13 1 ' * Undefined * ', ! 14 1 ' * Undefined * ', ! 15 1 ' * Undefined * ', ! 16 1 'Syntax error in NAMELIST input ', ! 17 1 'Too many values for NAMELIST variable ', ! 18 1 'Inv. ref. to variable in NAMELIST input ', ! 19 1 'REWIND error ', ! 20 1 'Duplicate file specifications ', ! 21 1 'Input record too long ', ! 22 1 'BACKSPACE error ', ! 23 1 'End-Of-File during read ', ! 24 1 'Record number outside of range ', ! 25 1 'OPEN or DEFINE FILE required ', ! 26 1 'Too many records in I/O statement ', ! 27 1 'CLOSE error ', ! 28 1 'File not found ', ! 29 1 'Open failure ', ! 30 1 'Mixed file access modes ', ! 31 1 'Invalid Logical Unit Number ', ! 32 1 'ENDFILE error ', ! 33 1 'Unit already open ', ! 34 1 'Segmented record format error ', ! 35 1 'Attempt to access non-existent record ', ! 36 1 'Inconsistent record number ', ! 37 1 'Error during write operation ', ! 38 1 'Error during read operation ', ! 39 1 'Recursive I/O operation ', ! 40 1 'Insufficient virtual memory ', ! 41 1 'No such device ', ! 42 1 'File name specification error ', ! 43 1 'Inconsistent record type ', ! 44 1 'Keyword value error in OPEN statement ', ! 45 1 'Inconsistent OPEN/CLOSE parameters ', ! 46 1 'Write to READONLY file ', ! 47 1 'Invalid argument to Runtime lib routine ', ! 48 1 'Invalid key specification ', ! 49 1 'Inconsistent key change or duplication ', ! 50 1 'Inconsistent file organization ', ! 51 1 'Specified record locked ', ! 52 1 'No current record ', ! 53 1 'REWRITE error ', ! 54 1 'DELETE error ', ! 55 1 'UNLOCK error ', ! 56 1 'FIND error ', ! 57 1 ' * Undefined * ', ! 58 1 'List directed I/O syntax error ', ! 59 1 'Infinite format loop ', ! 60 1 'Format/variable-type mismatch ', ! 61 1 'Syntax error in format ', ! 62 1 'Output conversion error ', ! 63 1 'Input conversion error ', ! 64 1 ' * Undefined * ', ! 65 1 'Output statement overflows record ', ! 66 1 'Input statement requires too much data ', ! 67 1 'Variable format expression value error '/ ! 68 C DATA DSK_TAPE /'DSK_OPEN: LUN less than 1 ', ! 100 1 'DSK_OPEN: LUN greater than 40 ', ! 101 1 'DSK_OPEN: LUN previously opened by DSK ', ! 102 1 'DSK_OPEN: Record Size too Small ', ! 103 1 'DSK_OPEN: Record Size Exceedes 8192 ', ! 104 1 'DSK_OPEN: File previosly OPENED by Sys. ', ! 105 1 'DSK_OPEN: Accessing Formatted File ', ! 106 1 'DSK_LINK: LUN Less than 1 ', ! 107 1 'DSK_LINK: LUN Greater than 40 ', ! 108 1 'DSK_LINK: LUN Previously Opened by DSK ', ! 109 1 'DSK_LINK: Record Size too small ', ! 110 1 'DSK_LINK: Record Size Exceedes 8192 ', ! 111 1 'DSK_LINK: Access is UNKNOWN File no OPEN', ! 112 1 'DSK_LINK: File not Opened UNFORMATTED ', ! 113 1 'DSK_LINK: File not Created SEQUENTIAL ', ! 114 1 'DSK_LINK: File Access not Opened DIRECT ', ! 115 1 'DSK_LINK: FILENAME =not LUN Filename ', ! 116 1 'DSK_LINK: REC_SIZE =not File Record Size', ! 117 1 'DSK_CLOSE: LUN not Opened by DSK_SUBS ', ! 118 1 'DSK_I/O: Inconsistant Record Length ', ! 119 1 'DSK_OPEN: *** not defined *** ', ! 120 1 'ADSK_: File NOT Accessed - Record Size 0', ! 121 1 'ADSK_: No Available DSK_ Luns ', ! 122 1 'ADSK_: Mis-Match of File-Array-Crop Size', ! 123 1 'ADSK_: File NOT Opened Successfully ', ! 124 1 'ADSK_: I/O ERROR - Transfer Terminated ', ! 125 1 'ADSK_: DSK_CLOSE Error Return '/ ! 126 C LOGICAL MESS_ONLY C C ********************************************************************** C C ** PROCESS THE CALL C C ********************************************************************** C MESS_ONLY = .FALSE. GO TO 10 C ENTRY RT_MESSAGE (MESS,ERROR) MESS_ONLY = .TRUE. GO TO 10 C 10 IF (ERROR .EQ. 0) THEN IF (MESS_ONLY) MESS = ' ' RETURN ELSE IF ( ERROR .GE. 100 .AND. ERROR .LT. 127 ) THEN ERRP = ERROR - 99 IF (MESS_ONLY) THEN MESS = DSK_TAPE(ERRP) ELSE IF ( OUT .EQ. 0 ) THEN TYPE 13,ERROR,DSK_TAPE(ERRP) ELSE WRITE (OUT,13) ERROR,DSK_TAPE(ERRP) ENDIF 13 FORMAT (' %%% DISK_SUBS or TAPE_SUBS Run-Time Error Number ', 1 I5,'. %%%',/, 2 1X,'(',A40,')' ) ENDIF ELSE IF (ERROR .LT. 0 .OR. ERROR .GT. 68) THEN IF (MESS_ONLY) THEN ENCODE (40,11,MESS) ERROR ELSE IF ( OUT .EQ. 0 ) THEN TYPE 11,ERROR ELSE WRITE (OUT,11) ERROR ENDIF 11 FORMAT (' %FORTRAN Run-Time error : ',I5,'.') ENDIF ELSE IF (MESS_ONLY) THEN MESS = MESSAGE (ERROR) ELSE IF ( OUT .EQ. 0 ) THEN TYPE 12,ERROR, MESSAGE(ERROR) ELSE WRITE (OUT,12) ERROR, MESSAGE (ERROR) ENDIF ENDIF 12 FORMAT (' %%% FORTRAN Run-Time error number : ',I5,'. %%%',/, 1 1X,'(',A40,')') ENDIF C RETURN END