| products/sources/formale sprachen/Fortran/f90gl-1.2.15/examples/ |
|
Quellcode-Bibliothek
© Kompilation durch diese Firma
[Weder Korrektheit noch Funktionsfähigkeit der Software werden zugesichert.]
Datei: eps.f90 Sprache: Unknown
|
! 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 pr 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 - 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.12 Sekunden (vorverarbeitet) ] |