! Example showing how to use OpenGL's feedback mode to capture
! transformed vertices and output them as Encapsulated PostScript.
! Handles limited hidden surface removal by sorting and does
! smooth shading (albeit limited due to PostScript).
! Modified for use with PHAML graphics, William F. Mitchell, 5/15/97
! Translated to Fortran by William F. Mitchell, 6/16/00
! Extended to an example for f90gl by William F. Mitchell, 1/3/03
! This is a translation of a C program written by Mark J. Kilgard. The
! original C program had the following notice:
! /* Copyright (c) Mark J. Kilgard, 1997. */
!
! /* This program is freely distributable without licensing fees
! and is provided without guarantee or warrantee expressed or
! implied. This program is -not- in the public domain. */
! (end of Mark's notice)
! The Fortran version is a contribution of NIST, not subject to copyright.
! The OpenGL image must be drawn in display list number 1, since this
! routine uses "call glCallList(1_GLint)" to render the image.
! The interface for the public routine is:
! subroutine outputEPS(bsize, doSort, filename)
! integer, intent(in) :: bsize
! logical, intent(in) :: doSort
! character(len=*), intent(in), optional :: filename
! bsize is the amount of space (in words) to allocate for the feedback buffer.
! doSort indicates whether or not to sort the rendered objects, back to front.
! filename is the name of the file to which to write the postscript. If it
! is not present, the feedback buffer is printed (for debugging)
module rendereps
use opengl_gl
implicit none
private
public :: outputEPS
real(GLfloat) :: pointSize(1)
character(len=74) :: gouraudtriangleEPS(25) = (/ &
"/bd{bind def}bind def /triangle { aload pop setrgbcolor aload pop 5 3 ",&
"roll 4 2 roll 3 2 roll exch moveto lineto lineto closepath fill } bd ",&
"/computediff1 { 2 copy sub abs threshold ge {pop pop pop true} { exch 2 ",&
"index sub abs threshold ge { pop pop true} { sub abs threshold ge } ifelse",&
"} ifelse } bd /computediff3 { 3 copy 0 get 3 1 roll 0 get 3 1 roll 0 get ",&
"computediff1 {true} { 3 copy 1 get 3 1 roll 1 get 3 1 roll 1 get ",&
"computediff1 {true} { 3 copy 2 get 3 1 roll 2 get 3 1 roll 2 get ",&
"computediff1 } ifelse } ifelse } bd /middlecolor { aload pop 4 -1 roll ",&
"aload pop 4 -1 roll add 2 div 5 1 roll 3 -1 roll add 2 div 3 1 roll add 2 ",&
"div 3 1 roll exch 3 array astore } bd /gouraudtriangle { computediff3 { 4 ",&
"-1 roll aload 7 1 roll 6 -1 roll pop 3 -1 roll pop add 2 div 3 1 roll add ",&
"2 div exch 3 -1 roll aload 7 1 roll exch pop 4 -1 roll pop add 2 div 3 1 ",&
"roll add 2 div exch 3 -1 roll aload 7 1 roll pop 3 -1 roll pop add 2 div 3",&
"1 roll add 2 div exch 7 3 roll 10 -3 roll dup 3 index middlecolor 4 1 roll",&
"2 copy middlecolor 4 1 roll 3 copy pop middlecolor 4 1 roll 13 -1 roll ",&
"aload pop 17 index 6 index 15 index 19 index 6 index 17 index 6 array ",&
"astore 10 index 10 index 14 index gouraudtriangle 17 index 5 index 17 ",&
"index 19 index 5 index 19 index 6 array astore 10 index 9 index 13 index ",&
"gouraudtriangle 13 index 16 index 5 index 15 index 18 index 5 index 6 ",&
"array astore 12 index 12 index 9 index gouraudtriangle 17 index 16 index ",&
"15 index 19 index 18 index 17 index 6 array astore 10 index 12 index 14 ",&
"index gouraudtriangle 18 {pop} repeat } { aload pop 5 3 roll aload pop 7 3",&
"roll aload pop 9 3 roll 4 index 6 index 4 index add add 3 div 10 1 roll 7 ",&
"index 5 index 3 index add add 3 div 10 1 roll 6 index 4 index 2 index add ",&
"add 3 div 10 1 roll 9 {pop} repeat 3 array astore triangle } ifelse } bd " &
/)
! OpenGL's GL_3D_COLOR feedback vertex format. Use as offsets from base entry.
integer, parameter :: X=0, Y=1, Z=2, CRED=3, CGREEN=4, CBLUE=5, ALPHA=6
type DepthIndex
integer(GLint) :: ptr
real(GLfloat) :: depth
end type DepthIndex
interface operator(.le.)
module procedure di_le
end interface
interface operator(.lt.)
module procedure di_lt
end interface
interface operator(.gt.)
module procedure di_gt
end interface
interface operator(.ge.)
module procedure di_ge
end interface
contains
! ------------------
subroutine print3DcolorVertex(count, buffer)
! ------------------
integer(GLint), intent(inout) :: count
real(GLfloat), intent(in) :: buffer(:)
! Write contents of one vertex to stdout.
write(unit=*,fmt="(' ',7(f4.2,' '))") buffer(count:count+6)
count = count + 7
end subroutine print3DcolorVertex
! -----------
subroutine printBuffer(bsize, buffer)
! -----------
integer, intent(in) :: bsize
real(GLfloat),intent(in) :: buffer(:)
integer(GLint) :: count
integer(GLint) :: token
integer :: nvertices, i
count = 1
do while (count < bsize)
token = buffer(count)
count = count + 1
select case (token)
case (GL_PASS_THROUGH_TOKEN)
write(unit=*,fmt=*) "GL_PASS_THROUGH_TOKEN"
write(unit=*,fmt="(' ',f4.2)") buffer(count)
count = count + 1
case (GL_POINT_TOKEN)
write(unit=*,fmt=*) "GL_POINT_TOKEN"
call print3DcolorVertex(count, buffer)
case (GL_LINE_TOKEN)
write(unit=*,fmt=*) "GL_LINE_TOKEN"
call print3DcolorVertex(count, buffer)
call print3DcolorVertex(count, buffer)
case (GL_LINE_RESET_TOKEN)
write(unit=*,fmt=*) "GL_LINE_RESET_TOKEN"
call print3DcolorVertex(count, buffer)
call print3DcolorVertex(count, buffer)
case (GL_POLYGON_TOKEN)
write(unit=*,fmt=*) "GL_POLYGON_TOKEN"
nvertices = buffer(count)
count = count + 1
do i=1,nvertices
call print3DcolorVertex(count, buffer)
end do
case default
write(unit=*,fmt=*) "Incomplete implementation. Unexpected token ",token
end select
end do
end subroutine printBuffer
! ----------------
subroutine spewPrimitiveEPS(file, loc, buffer)
! ----------------
integer, intent(in) :: file
integer, intent(inout) :: loc
real(GLfloat), intent(in) :: buffer(:)
integer(GLint) :: token
integer :: nvertices, i
real(GLfloat) :: red, green, blue
logical :: smooth
real(GLfloat) :: dx, dy, dr, dg, db, absR, absG, absB, colormax
integer :: steps
real(GLfloat) :: xstep, ystep, rstep, gstep, bstep
real(GLfloat) :: xnext, ynext, rnext, gnext, bnext, distance
! Lower for better smooth lines.
real(GLfloat), parameter :: EPS_SMOOTH_LINE_FACTOR = 0.06
token = buffer(loc)
loc = loc + 1
select case (token)
case (GL_LINE_RESET_TOKEN, GL_LINE_TOKEN)
dr = buffer(loc+7+CRED) - buffer(loc+CRED)
dg = buffer(loc+7+CGREEN) - buffer(loc+CGREEN)
db = buffer(loc+7+CBLUE) - buffer(loc+CBLUE)
if (dr /= 0 .or. dg /= 0 .or. db /= 0) then
! Smooth shaded line.
dx = buffer(loc+7+X) - buffer(loc+X)
dy = buffer(loc+7+Y) - buffer(loc+Y)
distance = sqrt(dx * dx + dy * dy)
absR = abs(dr)
absG = abs(dg)
absB = abs(db)
colormax = max(absR, absG, absB)
steps = max(1.0_GLfloat, colormax * distance * EPS_SMOOTH_LINE_FACTOR)
xstep = dx / steps
ystep = dy / steps
rstep = dr / steps
gstep = dg / steps
bstep = db / steps
xnext = buffer(loc+X)
ynext = buffer(loc+Y)
rnext = buffer(loc+CRED)
gnext = buffer(loc+CGREEN)
bnext = buffer(loc+CBLUE)
! Back up half a step; we want the end points to be
! exactly the their endpoint colors.
xnext = xnext - xstep / 2.0_GLfloat
ynext = ynext - ystep / 2.0_GLfloat
rnext = rnext - rstep / 2.0_GLfloat
gnext = gnext - gstep / 2.0_GLfloat
bnext = bnext - bstep / 2.0_GLfloat
else
! Single color line.
steps = 0
endif
write(unit=file,fmt=*) buffer(loc+CRED),buffer(loc+CGREEN),buffer(loc+CBLUE),&
" setrgbcolor"
write(unit=file,fmt=*) buffer(loc+X),buffer(loc+Y)," moveto"
do i=1,steps
xnext = xnext + xstep
ynext = ynext + ystep
rnext = rnext + rstep
gnext = gnext + gstep
bnext = bnext + bstep
write(unit=file,fmt=*) xnext, ynext, " lineto stroke"
write(unit=file,fmt=*) rnext, gnext, bnext, " setrgbcolor"
write(unit=file,fmt=*) xnext, ynext, " moveto"
end do
write(unit=file,fmt=*) buffer(loc+7+X), buffer(loc+7+Y), " lineto stroke"
loc = loc + 14 ! Each vertex element in the feedback buffer is 7 GLfloats.
case (GL_POLYGON_TOKEN)
nvertices = buffer(loc)
loc = loc + 1
if (nvertices > 0) then
red = buffer(loc+CRED)
green = buffer(loc+CGREEN)
blue = buffer(loc+CBLUE)
smooth = .false.
do i=1,nvertices-1
if (red /= buffer(loc+7*i+CRED) .or. green /= buffer(loc+7*i+CGREEN) &
.or. blue /= buffer(loc+7*i+CBLUE)) then
smooth = .true.
exit
endif
end do
if (smooth) then
! Smooth shaded polygon; varying colors at vetices.
! Break polygon into "nvertices-2" triangle fans.
do i=1,nvertices-2
write(unit=file,fmt=*) "[",buffer(loc+X),buffer(loc+7*i+X), &
buffer(loc+7*(i+1)+X),buffer(loc+Y),buffer(loc+7*i+Y), &
buffer(loc+7*(i+1)+Y),"] [",buffer(loc+CRED),buffer(loc+CGREEN), &
buffer(loc+CBLUE),"] [",buffer(loc+7*i+CRED),buffer(loc+7*i+CGREEN), &
buffer(loc+7*i+CBLUE),"] [",buffer(loc+7*(i+1)+CRED), &
buffer(loc+7*(i+1)+CGREEN),buffer(loc+7*(i+1)+CBLUE), &
"] gouraudtriangle"
end do
else
! Flat shaded polygon; all vertex colors the same.
write(unit=file,fmt=*) "newpath"
write(unit=file,fmt=*) red, green, blue, " setrgbcolor"
! Draw a filled triangle.
write(unit=file,fmt=*) buffer(loc+X),buffer(loc+Y)," moveto"
do i=1,nvertices-1
write(unit=file,fmt=*) buffer(loc+7*i+X),buffer(loc+7*i+Y)," lineto"
end do
write(unit=file,fmt=*) "closepath fill"
write(unit=file,fmt=*) ""
endif
endif
loc = loc + nvertices * 7 ! Each vertex element in the
! feedback buffer is 7 GLfloats.
case (GL_POINT_TOKEN)
write(unit=file,fmt=*) buffer(loc+CRED),buffer(loc+CGREEN),buffer(loc+CBLUE), &
" setrgbcolor"
write(unit=file,fmt=*) buffer(loc+X),buffer(loc+Y),pointSize(1)/2.0,0, &
360," arc fill"
write(unit=file,fmt=*) ""
loc = loc + 7 ! Each vertex element in the feedback buffer is 7 GLfloats.
case default
write(unit=*,fmt=*) "Incomplete implementation. Unexpected token ",token
end select
end subroutine spewPrimitiveEPS
! --------------------
subroutine spewUnsortedFeedback(file, bsize, buffer)
! --------------------
integer, intent(in) :: file, bsize
real(GLfloat), intent(in) :: buffer(:)
integer :: loc
loc = 1
do while (loc < bsize)
call spewPrimitiveEPS(file, loc, buffer)
end do
end subroutine spewUnsortedFeedback
! ------------------
subroutine spewSortedFeedback(file, bsize, buffer)
! ------------------
integer, intent(in) :: file, bsize
real(GLfloat), intent(in) :: buffer(:)
integer(GLint) :: token
integer :: loc
real(GLfloat) :: depthSum
integer :: nprimitives, item
type(DepthIndex), allocatable :: prims(:)
integer :: nvertices, i
real :: ydum(1)
! Count how many primitives there are.
nprimitives = 0
loc = 1
do while (loc < bsize)
token = buffer(loc)
loc = loc + 1
select case (token)
case (GL_LINE_TOKEN, GL_LINE_RESET_TOKEN)
loc = loc + 14
nprimitives = nprimitives + 1
case (GL_POLYGON_TOKEN)
nvertices = buffer(loc)
loc = loc + 1
loc = loc + 7*nvertices
nprimitives = nprimitives + 1
case (GL_POINT_TOKEN)
loc = loc + 7
nprimitives = nprimitives + 1
case default
write(unit=*,fmt=*) "Incomplete implementation. Unexpected token ",token
end select
end do
! Allocate an array of pointers that will point back at
! primitives in the feedback buffer. There will be one
! entry per primitive. This array is also where we keep the
! primitive's average depth. There is one entry per
! primitive in the feedback buffer.
allocate(prims(nprimitives))
item = 1
loc = 1
do while (loc < bsize)
prims(item)%ptr = loc ! Save this primitive's location.
token = buffer(loc)
loc = loc + 1
select case (token)
case (GL_LINE_TOKEN, GL_LINE_RESET_TOKEN)
depthSum = buffer(loc+Z) + buffer(loc+7+Z)
prims(item)%depth = depthSum / 2.0
! WFM to force triangle edges on top of filled triangle
! prims(item)%depth = prims(item)%depth - .0001
loc = loc + 14
case (GL_POLYGON_TOKEN)
nvertices = buffer(loc)
loc = loc + 1
depthSum = buffer(loc+Z)
do i=1,nvertices-1
depthSum = depthSum + buffer(loc+7*i+Z)
end do
prims(item)%depth = depthSum / nvertices
loc = loc + 7*nvertices
case (GL_POINT_TOKEN)
prims(item)%depth = buffer(loc+Z)
loc = loc + 7
case default
write(unit=*,fmt=*) "Incomplete implementation. Unexpected token ",token
end select
item = item + 1
end do
! Sort the primitives back to front.
call ssort(prims, ydum, nprimitives, -1)
! XXX Understand that sorting by a primitives average depth
! doesn't allow us to disambiguate some cases like self
! intersecting polygons. Handling these cases would require
! breaking up the primitives. That's too involved for this
! example. Sorting by depth is good enough for lots of
! applications.
! Emit the Encapsulated PostScript for the primitives in
! back to front order.
do item=1,nprimitives
call spewPrimitiveEPS(file, prims(item)%ptr, buffer)
end do
deallocate(prims)
end subroutine spewSortedFeedback
! ----------------
subroutine spewWireFrameEPS(file, doSort, bsize, buffer, creator)
! ----------------
integer, intent(in) :: file, bsize
logical, intent(in) :: doSort
real(GLfloat), intent(in) :: buffer(:)
character(len=*), intent(in) :: creator
real(GLfloat) :: clearColor(4), viewport(4)
real(GLfloat) :: lineWidth(1)
integer :: i
! Lower for better (slower) smooth shading.
real(GLfloat), parameter :: EPS_GOURAUD_THRESHOLD=0.1
! Read back a bunch of OpenGL state to help make the EPS
! consistent with the OpenGL clear color, line width, point
! bsize, and viewport.
call glGetFloatv(GL_VIEWPORT, viewport)
call glGetFloatv(GL_COLOR_CLEAR_VALUE, clearColor)
call glGetFloatv(GL_LINE_WIDTH, lineWidth)
call glGetFloatv(GL_POINT_SIZE, pointSize)
! Emit EPS header. */
write(unit=file,fmt="(a)") "%!PS-Adobe-2.0 EPSF-2.0"
write(unit=file,fmt="(a)") "%%Creator: eps.f90 (using OpenGL feedback)"
write(unit=file,fmt="(a,4i10)") "%%BoundingBox: ", int(viewport)
write(unit=file,fmt="(a)") "%%EndComments"
write(unit=file,fmt=*) ""
write(unit=file,fmt=*) "gsave"
write(unit=file,fmt=*) ""
! Output Frederic Delhoume's "gouraudtriangle" PostScript fragment.
write(unit=file,fmt=*) "% the gouraudtriangle PostScript fragement below is free"
write(unit=file,fmt=*) "% written by Frederic Delhoume ([email protected])"
write(unit=file,fmt=*) "/threshold ",EPS_GOURAUD_THRESHOLD," def"
do i=1,size(gouraudtriangleEPS)
write(unit=file,fmt=*) gouraudtriangleEPS(i)
end do
write(unit=file,fmt=*) ""
write(unit=file,fmt=*) lineWidth(1)," setlinewidth"
! Clear the background like OpenGL had it.
write(unit=file,fmt=*) clearColor(1:3)," setrgbcolor"
write(unit=file,fmt=*) viewport," rectfill"
write(unit=file,fmt=*) ""
if (doSort) then
call spewSortedFeedback(file, bsize, buffer)
else
call spewUnsortedFeedback(file, bsize, buffer)
endif
! Emit EPS trailer.
write(unit=file,fmt=*) "grestore"
write(unit=file,fmt=*) ""
! WFM I don't know why Mark put this comment instead of showpage, unless some
! apps that take eps input don't like it (ghostview is fine with it)
! write(unit=file,fmt=*) "%Add `showpage' to the end of this file to be able to print to a printer."
write(unit=file,fmt=*) "% 'showpage' is needed to print to a printer, but there"
write(unit=file,fmt=*) "% may be some apps for which it must be removed"
write(unit=file,fmt=*) "showpage"
close(file)
end subroutine spewWireFrameEPS
subroutine outputEPS(bsize, doSort, filename)
integer, intent(in) :: bsize
logical, intent(in) :: doSort
character(len=*), intent(in), optional :: filename
real(GLfloat), allocatable :: feedbackBuffer(:)
integer(GLint) :: returned, idum
integer :: file, iostat
logical :: opened
allocate(feedbackBuffer(bsize))
call glFeedbackBuffer(bsize, GL_3D_COLOR, feedbackBuffer)
idum = glRenderMode(GL_FEEDBACK)
call glCallList(1_GLint)
returned = glRenderMode(GL_RENDER)
if (present(filename)) then
file = 11
do
inquire(unit=file,opened=opened)
if (.not. opened) exit
file = file + 1
end do
open(unit=file,file=filename,iostat=iostat)
if (iostat==0) then
call spewWireFrameEPS(file, doSort, returned, feedbackBuffer, "rendereps")
else
write(unit=*,fmt=*) "Could not open ", filename
endif
else
! Helps debugging to be able to see the decode feedback buffer as text.
call printBuffer(returned, feedbackBuffer)
endif
deallocate(feedbackBuffer)
end subroutine outputEPS
! The following routine was taken from CMLIB at http://gams.nist.gov
! and modified to be acceptable in free format, not require subroutine
! xerror, and to sort type(DepthIndex).
! Later made 3 trivial changes to remove f95 obsolescent features
SUBROUTINE SSORT(X,Y,N,KFLAG)
!***BEGIN PROLOGUE SSORT
!***DATE WRITTEN 761101 (YYMMDD)
!***REVISION DATE 820801 (YYMMDD)
!***CATEGORY NO. N6A2B1
!***KEYWORDS QUICKSORT,SINGLETON QUICKSORT,SORT,SORTING
!***AUTHOR JONES, R. E., (SNLA)
! WISNIEWSKI, J. A., (SNLA)
!***PURPOSE SSORT sorts array X and optionally makes the same
! interchanges in array Y. The array X may be sorted in
! increasing order or decreasing order. A slightly modified
! QUICKSORT algorithm is used.
!***DESCRIPTION
!
! Written by Rondall E. Jones
! Modified by John A. Wisniewski to use the Singleton quicksort
! algorithm. Date 18 November 1976.
!
! Abstract
! SSORT sorts array X and optionally makes the same
! interchanges in array Y. The array X may be sorted in
! increasing order or decreasing order. A slightly modified
! quicksort algorithm is used.
!
! Reference
! Singleton, R. C., Algorithm 347, An Efficient Algorithm for
! Sorting with Minimal Storage, CACM,12(3),1969,185-7.
!
! Description of Parameters
! X - array of values to be sorted (usually abscissas)
! Y - array to be (optionally) carried along
! N - number of values in array X to be sorted
! KFLAG - control parameter
! =2 means sort X in increasing order and carry Y along.
! =1 means sort X in increasing order (ignoring Y)
! =-1 means sort X in decreasing order (ignoring Y)
! =-2 means sort X in decreasing order and carry Y along.
!***REFERENCES SINGLETON,R.C., ALGORITHM 347, AN EFFICIENT ALGORITHM
! FOR SORTING WITH MINIMAL STORAGE, CACM,12(3),1969,
! 185-7.
!***ROUTINES CALLED XERROR
!***END PROLOGUE SSORT
integer n
real Y(*)
integer IL(21),IU(21)
type(DepthIndex) :: X(N), T, TT
integer :: m, j, k, ij, l, nn, kk, kflag, i
real :: r, ty, tty
!***FIRST EXECUTABLE STATEMENT SSORT
NN = N
IF (NN.GE.1) GO TO 10
! CALL XERROR ( 'SSORT- THE NUMBER OF VALUES TO BE SORTED WAS NOT PO
! 1SITIVE.',58,1,1)
write(unit=*,fmt=*) 'SSORT- THE NUMBER OF VALUES TO BE SORTED WAS NOT POSITIVE.'
RETURN
10 KK = IABS(KFLAG)
IF ((KK.EQ.1).OR.(KK.EQ.2)) GO TO 15
! CALL XERROR ( 'SSORT- THE SORT CONTROL PARAMETER, K, WAS NOT 2, 1,
! 1 -1, OR -2.',62,2,1)
write(unit=*,fmt=*) 'SSORT- THE SORT CONTROL PARAMETER, K, WAS NOT 2, 1, -1, OR -2.'
RETURN
!
! ALTER ARRAY X TO GET DECREASING ORDER IF NEEDED
!
15 IF (KFLAG.GE.1) GO TO 30
DO 20 I=1,NN
X(I)%depth = -X(I)%depth
20 CONTINUE
! WFM replace obsolete computed goto
! 30 GO TO (100,200),KK
30 IF (KK .EQ. 1) GOTO 100
IF (KK .EQ. 2) GOTO 200
!
! SORT X ONLY
!
100 CONTINUE
M=1
I=1
J=NN
R=.375
110 IF (I .EQ. J) GO TO 155
115 IF (R .GT. .5898437) GO TO 120
R=R+3.90625E-2
GO TO 125
120 R=R-.21875
125 K=I
! SELECT A CENTRAL ELEMENT OF THE
! ARRAY AND SAVE IT IN LOCATION T
IJ = I + IFIX (FLOAT (J-I) * R)
T=X(IJ)
! IF FIRST ELEMENT OF ARRAY IS GREATER
! THAN T, INTERCHANGE WITH T
IF (X(I) .LE. T) GO TO 130
X(IJ)=X(I)
X(I)=T
T=X(IJ)
130 L=J
! IF LAST ELEMENT OF ARRAY IS LESS THAN
! T, INTERCHANGE WITH T
IF (X(J) .GE. T) GO TO 140
X(IJ)=X(J)
X(J)=T
T=X(IJ)
! IF FIRST ELEMENT OF ARRAY IS GREATER
! THAN T, INTERCHANGE WITH T
IF (X(I) .LE. T) GO TO 140
X(IJ)=X(I)
X(I)=T
T=X(IJ)
GO TO 140
135 TT=X(L)
X(L)=X(K)
X(K)=TT
! FIND AN ELEMENT IN THE SECOND HALF OF
! THE ARRAY WHICH IS SMALLER THAN T
140 L=L-1
IF (X(L) .GT. T) GO TO 140
! FIND AN ELEMENT IN THE FIRST HALF OF
! THE ARRAY WHICH IS GREATER THAN T
145 K=K+1
IF (X(K) .LT. T) GO TO 145
! INTERCHANGE THESE ELEMENTS
IF (K .LE. L) GO TO 135
! SAVE UPPER AND LOWER SUBSCRIPTS OF
! THE ARRAY YET TO BE SORTED
IF (L-I .LE. J-K) GO TO 150
IL(M)=I
IU(M)=L
I=K
M=M+1
GO TO 160
150 IL(M)=K
IU(M)=J
J=L
M=M+1
GO TO 160
! BEGIN AGAIN ON ANOTHER PORTION OF
! THE UNSORTED ARRAY
155 M=M-1
IF (M .EQ. 0) GO TO 300
I=IL(M)
J=IU(M)
160 IF (J-I .GE. 1) GO TO 125
IF (I .EQ. 1) GO TO 110
I=I-1
165 I=I+1
IF (I .EQ. J) GO TO 155
T=X(I+1)
IF (X(I) .LE. T) GO TO 165
K=I
170 X(K+1)=X(K)
K=K-1
IF (T .LT. X(K)) GO TO 170
X(K+1)=T
GO TO 165
!
! SORT X AND CARRY Y ALONG
!
200 CONTINUE
M=1
I=1
J=NN
R=.375
210 IF (I .EQ. J) GO TO 255
215 IF (R .GT. .5898437) GO TO 220
R=R+3.90625E-2
GO TO 225
220 R=R-.21875
225 K=I
! SELECT A CENTRAL ELEMENT OF THE
! ARRAY AND SAVE IT IN LOCATION T
IJ = I + IFIX (FLOAT (J-I) *R)
T=X(IJ)
TY= Y(IJ)
! IF FIRST ELEMENT OF ARRAY IS GREATER
! THAN T, INTERCHANGE WITH T
IF (X(I) .LE. T) GO TO 230
X(IJ)=X(I)
X(I)=T
T=X(IJ)
Y(IJ)= Y(I)
Y(I)=TY
TY= Y(IJ)
230 L=J
! IF LAST ELEMENT OF ARRAY IS LESS THAN
! T, INTERCHANGE WITH T
IF (X(J) .GE. T) GO TO 240
X(IJ)=X(J)
X(J)=T
T=X(IJ)
Y(IJ)= Y(J)
Y(J)=TY
TY= Y(IJ)
! IF FIRST ELEMENT OF ARRAY IS GREATER
! THAN T, INTERCHANGE WITH T
IF (X(I) .LE. T) GO TO 240
X(IJ)=X(I)
X(I)=T
T=X(IJ)
Y(IJ)= Y(I)
Y(I)=TY
TY= Y(IJ)
GO TO 240
235 TT=X(L)
X(L)=X(K)
X(K)=TT
TTY= Y(L)
Y(L)= Y(K)
Y(K)=TTY
! FIND AN ELEMENT IN THE SECOND HALF OF
! THE ARRAY WHICH IS SMALLER THAN T
240 L=L-1
IF (X(L) .GT. T) GO TO 240
! FIND AN ELEMENT IN THE FIRST HALF OF
! THE ARRAY WHICH IS GREATER THAN T
245 K=K+1
IF (X(K) .LT. T) GO TO 245
! INTERCHANGE THESE ELEMENTS
IF (K .LE. L) GO TO 235
! SAVE UPPER AND LOWER SUBSCRIPTS OF
! THE ARRAY YET TO BE SORTED
IF (L-I .LE. J-K) GO TO 250
IL(M)=I
IU(M)=L
I=K
M=M+1
GO TO 260
250 IL(M)=K
IU(M)=J
J=L
M=M+1
GO TO 260
! BEGIN AGAIN ON ANOTHER PORTION OF
! THE UNSORTED ARRAY
255 M=M-1
IF (M .EQ. 0) GO TO 300
I=IL(M)
J=IU(M)
260 IF (J-I .GE. 1) GO TO 225
IF (I .EQ. 1) GO TO 210
I=I-1
265 I=I+1
IF (I .EQ. J) GO TO 255
T=X(I+1)
TY= Y(I+1)
IF (X(I) .LE. T) GO TO 265
K=I
270 X(K+1)=X(K)
Y(K+1)= Y(K)
K=K-1
IF (T .LT. X(K)) GO TO 270
X(K+1)=T
Y(K+1)=TY
GO TO 265
!
! CLEAN UP
!
300 IF (KFLAG.GE.1) RETURN
DO 310 I=1,NN
X(I)%depth = -X(I)%depth
310 CONTINUE
RETURN
END subroutine ssort
! comparison operators for SSORT
logical function di_le(a,b)
type(DepthIndex), intent(in) :: a,b
di_le = a%depth <= b%depth
end function di_le
logical function di_lt(a,b)
type(DepthIndex), intent(in) :: a,b
di_lt = a%depth < b%depth
end function di_lt
logical function di_gt(a,b)
type(DepthIndex), intent(in) :: a,b
di_gt = a%depth > b%depth
end function di_gt
logical function di_ge(a,b)
type(DepthIndex), intent(in) :: a,b
di_ge = a%depth >= b%depth
end function di_ge
end module rendereps
!-----------------------------------------------------------
!
! Use the fscene.f90 program to illustrate use of rendereps. Contrast the
! remainder of this file to the file fscene.f90.
! GLUT Fortran program to render simple red scene.
! This is a fortran 90 program in fixed source form.
! In a risky move, this program assumes that the default kind of
! integer is the same as glint and glsizei and also that the
! default real is the same kind as glfloat
subroutine display
use opengl_gl
use opengl_glu
use opengl_glut
call gldeletelists(1_gluint, 1_glsizei)
! put the display in list 1 for rendereps
call glnewlist(1_gluint, gl_compile_and_execute)
call glclear(GL_COLOR_BUFFER_BIT + GL_DEPTH_BUFFER_BIT)
call glpushmatrix
call glscalef(1.3, 1.3, 1.3)
call glrotatef(20.0, 1.0, 0.0, 0.0)
call glpushmatrix
call gltranslatef(-0.75, 0.5, 0.0)
call glrotatef(90.0, 1.0, 0.0, 0.0)
call glutsolidtorus(0.275_gldouble, 0.85_gldouble, 10, 15)
call glpopmatrix
call glpushmatrix
call gltranslatef(-0.75, -0.5, 0.0)
call glrotatef(270.0, 1.0, 0.0, 0.0)
call glutsolidtetrahedron
call glpopmatrix
call glpushmatrix
call gltranslatef(0.75, 0.0, -1.0)
call glutsolidicosahedron
call glpopmatrix
call glpopmatrix
call glendlist
call glflush
end
subroutine reshape(w,h)
use opengl_gl
use opengl_glu
use opengl_glut
integer, intent(inout) :: w,h
real(gldouble) wr,hr
double precision d
call glviewport(0, 0, w, h)
call glmatrixmode(GL_PROJECTION)
call glloadidentity
wr = w
hr = h
d = 1.0d0
if ( w .le. h ) then
call glortho(-2.5_gldouble, 2.5_gldouble, &
-2.5_gldouble * hr/wr, 2.5_gldouble * hr/wr, &
-10.0_gldouble, 10.0_gldouble)
else
call glortho(-2.5_gldouble * hr/wr, &
2.5_gldouble * hr/wr, &
-2.5_gldouble, 2.5_gldouble, -10.0_gldouble, &
10.0_gldouble)
end if
call glmatrixmode(GL_MODELVIEW)
end
subroutine submenu(value)
use opengl_gl
use opengl_glu
use opengl_glut
integer, intent(inout) :: value
if ( value .eq. 1 ) then
call glenable(GL_DEPTH_TEST)
call glenable(GL_LIGHTING)
call gldisable(GL_BLEND)
call glpolygonmode(GL_FRONT_AND_BACK, GL_FILL)
else
call gldisable(GL_DEPTH_TEST)
call gldisable(GL_LIGHTING)
call glcolor3f(1.0, 1.0, 1.0)
call glpolygonmode(GL_FRONT_AND_BACK, GL_LINE)
call glenable(GL_LINE_SMOOTH)
call glenable(GL_BLEND)
call glblendfunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA)
end if
call glutpostredisplay
end
subroutine mainmenu(value)
use rendereps
use opengl_glut
integer, intent(inout) :: value
if (value == 10) then
call glutsetcursor(glut_cursor_wait)
call outputeps(100000,.true.,"epsout.eps")
call glutsetcursor(glut_cursor_inherit)
endif
if (value == 666) stop
end
subroutine myinit
use opengl_gl
use opengl_glu
use opengl_glut
real lambient(4), ldiffuse(4), lspecular(4), lposition(4)
data lambient /0.0, 0.0, 0.0, 1.0/
data ldiffuse /1.0, 0.0, 0.0, 1.0/
data lspecular /1.0, 1.0, 1.0, 1.0/
data lposition /1.0, 1.0, 1.0, 0.0/
call gllightfv(GL_LIGHT0, GL_AMBIENT, lambient)
call gllightfv(GL_LIGHT0, GL_DIFFUSE, ldiffuse)
call gllightfv(GL_LIGHT0, GL_SPECULAR, lspecular)
call gllightfv(GL_LIGHT0, GL_POSITION, lposition)
call glenable(GL_LIGHT0)
call gldepthfunc(GL_LESS)
call glenable(GL_DEPTH_TEST)
call glenable(GL_LIGHTING)
end
program main
use opengl_gl
use opengl_glu
use opengl_glut
interface
subroutine display()
end subroutine display
subroutine reshape(w,h)
integer, intent(inout):: w,h
end subroutine reshape
subroutine submenu(value)
integer, intent(inout):: value
end subroutine submenu
subroutine mainmenu(value)
integer, intent(inout):: value
end subroutine mainmenu
end interface
call glutinitwindowposition(500,500)
call glutinitwindowsize(500,500)
call glutinit
i = glutcreatewindow('Fortran GLUT program')
call myinit
call glutdisplayfunc(display)
call glutreshapefunc(reshape)
i = glutcreatemenu(submenu)
call glutaddmenuentry('Filled', 1)
call glutaddmenuentry('Outline', 2)
j = glutcreatemenu(mainmenu)
call glutaddsubmenu('Polygon mode', i)
call glutaddmenuentry('Save postscript',10)
call glutaddmenuentry('Quit', 666)
call glutattachmenu(GLUT_RIGHT_BUTTON)
call glutmainloop
end
¤ Dauer der Verarbeitung: 0.47 Sekunden
(vorverarbeitet)
¤
|
Haftungshinweis
Die Informationen auf dieser Webseite wurden
nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit,
noch Qualität der bereit gestellten Informationen zugesichert.
Bemerkung:
Die farbliche Syntaxdarstellung ist noch experimentell.
|
