	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
