! ******************************************************************** ! * This program is one of a set of demonstration programs which * ! * illustrate the use of the OpenGL graphics library in combination * ! * with the Winteracter Fortran 9x user-interface/graphics toolset. * ! * * ! * This demonstration program is freely distributable. * ! * * ! * Winteracter contact information: * ! * email : help@winteracter.com * ! * web : www.winteracter.com * ! * * ! * This program USE's a Fortran 9x module called OPENGL. * ! * This was derived from f90gl which was written by: * ! * William F. Mitchell * ! * Mathematical and Computational Sciences Division * ! * National Institute of Standards and Technology * ! * Gaithersburg, MD 20899, USA * ! * * ! * OpenGL is a trademark of Silicon Graphics Inc. * ! * * ! ******************************************************************** ! MODULE TEAPOT_MOD ! USE WINTERACTER USE OPENGL ! IMPLICIT NONE ! ! Named parameters for view changing options ! Should match positions on sub-menus ! INTEGER, PARAMETER :: ROTATE = 1 INTEGER, PARAMETER :: PAN = 2 INTEGER, PARAMETER :: ZOOM = 3 INTEGER, PARAMETER :: SCALEX = 4 INTEGER, PARAMETER :: SCALEY = 5 INTEGER, PARAMETER :: SCALEZ = 6 ! INTEGER, PARAMETER :: IDR_MENU1 = 30001 INTEGER, PARAMETER :: ID_VIEW = 40001 INTEGER, PARAMETER :: ID_EXIT = 40002 INTEGER, PARAMETER :: ID_OPTIONS = 40003 INTEGER, PARAMETER :: ID_LEFT = 40100 INTEGER, PARAMETER :: ID_LEFT_ROTATE = 40101 INTEGER, PARAMETER :: ID_LEFT_PAN = 40102 INTEGER, PARAMETER :: ID_LEFT_ZOOM = 40103 INTEGER, PARAMETER :: ID_LEFT_X = 40104 INTEGER, PARAMETER :: ID_LEFT_Y = 40105 INTEGER, PARAMETER :: ID_LEFT_Z = 40106 INTEGER, PARAMETER :: ID_RIGHT = 40200 INTEGER, PARAMETER :: ID_RIGHT_ROTATE = 40201 INTEGER, PARAMETER :: ID_RIGHT_PAN = 40202 INTEGER, PARAMETER :: ID_RIGHT_ZOOM = 40203 INTEGER, PARAMETER :: ID_RIGHT_X = 40204 INTEGER, PARAMETER :: ID_RIGHT_Y = 40205 INTEGER, PARAMETER :: ID_RIGHT_Z = 40206 INTEGER, PARAMETER :: ID_CURSOR = 40300 INTEGER, PARAMETER :: ID_CURSOR_ROTATE = 40301 INTEGER, PARAMETER :: ID_CURSOR_PAN = 40302 INTEGER, PARAMETER :: ID_CURSOR_ZOOM = 40303 INTEGER, PARAMETER :: ID_CURSOR_X = 40304 INTEGER, PARAMETER :: ID_CURSOR_Y = 40305 INTEGER, PARAMETER :: ID_CURSOR_Z = 40306 INTEGER, PARAMETER :: ID_VIEW_POINTS = 40028 INTEGER, PARAMETER :: ID_VIEW_WIREFRAME = 40032 INTEGER, PARAMETER :: ID_VIEW_SOLID = 40033 INTEGER, PARAMETER :: ID_VIEW_RESET = 40007 INTEGER, PARAMETER :: ID_VIEW_AXES = 40011 ! ! Named parameter for PI ! REAL(KIND=gldouble), PARAMETER :: PI = 3.141592653589793_gldouble ! ! Derived types for co-ordinates ! TYPE :: cart2D ! 2D cartesian coordinates REAL(kind=gldouble) :: x REAL(kind=gldouble) :: y END TYPE cart2D ! TYPE :: cart3D ! 3D cartesian coordinates REAL(KIND=gldouble) :: x REAL(KIND=gldouble) :: y REAL(KIND=gldouble) :: z END TYPE cart3D ! TYPE :: sphere3D ! 3D spherical coordinates REAL(KIND=gldouble) :: theta REAL(KIND=gldouble) :: phi REAL(KIND=gldouble) :: rho END TYPE sphere3D ! ! Co-ordinate variables ! TYPE (cart2D), SAVE :: angle TYPE (cart3D), SAVE :: shift ! REAL(KIND=gldouble), SAVE :: xscale_factor REAL(KIND=gldouble), SAVE :: yscale_factor REAL(KIND=gldouble), SAVE :: zscale_factor ! LOGICAL, SAVE :: moving_left LOGICAL, SAVE :: moving_right ! TYPE(cart2D), SAVE :: begin_left TYPE(cart2D), SAVE :: begin_right ! ! Overloaded operators for adding and subtracting 3D co-ordinates ! INTERFACE OPERATOR(+) MODULE PROCEDURE CART3D_PLUS_CART3D END INTERFACE ! INTERFACE OPERATOR(-) MODULE PROCEDURE CART3D_MINUS_CART3D END INTERFACE ! ! ------- Initial configuration ------- ! ! Set the initial operation performed by each button and the cursor keys. ! The operations are ZOOM, PAN, ROTATE, SCALEX, SCALEY, and SCALEZ INTEGER, SAVE :: left_button_func = ROTATE INTEGER, SAVE :: right_button_func = ZOOM INTEGER, SAVE :: cursor_key_func = PAN ! ! Set the initial view as the point you are looking at, the point you are ! looking from, and the scale factors ! TYPE (cart3D), PARAMETER :: init_lookat = cart3D(0.0_gldouble, & 0.0_gldouble, & 0.0_gldouble) TYPE (cart3D), PARAMETER :: init_lookfrom = cart3D( 10.0_gldouble, & -20.0_gldouble, & 5.0_gldouble) ! ! Initial scale factors ! REAL(KIND=gldouble), PARAMETER :: init_xscale_factor = 1.0_gldouble REAL(KIND=gldouble), PARAMETER :: init_yscale_factor = 1.0_gldouble REAL(KIND=gldouble), PARAMETER :: init_zscale_factor = 1.0_gldouble ! ! Rendering type ! INTEGER, SAVE :: IVIEW = ID_VIEW_SOLID ! ! Display Axes ! LOGICAL, SAVE :: AXES = .TRUE. ! ! -------- end of Initial configuration ------ ! CONTAINS ! !****************************************************************************** ! FUNCTION cart2sphere(cpoint) RESULT(spoint) ! ! This converts a 3D point from cartesean to spherical coordinates ! TYPE (cart3D), intent(in) :: cpoint TYPE (sphere3D) :: spoint real(kind=gldouble) :: x,y,z ! x = cpoint%x y = cpoint%y z = cpoint%z ! spoint%rho = sqrt(x*x+y*y+z*z) IF (x==0.0_gldouble .and. y==0.0_gldouble) THEN spoint%theta = 0.0_gldouble ELSE spoint%theta = atan2(y,x) END IF IF (spoint%rho == 0.0_gldouble) THEN spoint%phi = 0.0_gldouble ELSE spoint%phi = acos(z/spoint%rho) END IF ! RETURN END FUNCTION cart2sphere ! !***************************************************************************** ! FUNCTION CART3D_PLUS_CART3D(cart1,cart2) RESULT(cart3) ! ! Compute the sum of two 3D cartesean points ! type(cart3D), intent(in) :: cart1, cart2 type(cart3D) :: cart3 ! cart3%x = cart1%x + cart2%x cart3%y = cart1%y + cart2%y cart3%z = cart1%z + cart2%z ! RETURN END FUNCTION CART3D_PLUS_CART3D ! !***************************************************************************** ! FUNCTION CART3D_MINUS_CART3D(cart1,cart2) RESULT(cart3) ! ! Compute the difference of two 3D cartesean points ! type(cart3D), intent(in) :: cart1, cart2 type(cart3D) :: cart3 ! cart3%x = cart1%x - cart2%x cart3%y = cart1%y - cart2%y cart3%z = cart1%z - cart2%z ! RETURN END FUNCTION CART3D_MINUS_CART3D ! END MODULE TEAPOT_MOD ! !****************************************************************************** ! PROGRAM TEAPOT ! USE TEAPOT_MOD ! IMPLICIT NONE TYPE(WIN_MESSAGE) :: MESSAGE INTEGER :: ITYPE ! INTEGER(glsizei) :: IWIDTH, IHEIGHT ! ! Initialise Winteracter and open root window ! CALL WInitialise() ! Initialise Winteracter CALL WindowOpen(MENUID=IDR_MENU1,TITLE='Teapot') ! ! Check screen colour depth. ! OpenGL doesn't work particularly well on 16-colour displays ! IF (WInfoScreen(ScreenColours).LE.16) & CALL WMessageBox(OKOnly,InformationIcon,CommonOK, & 'Your video driver is configured'//CHAR(13)// & 'for 16 colours or less.'//CHAR(13)// & 'For best results run in a higher colour mode.', & 'Limited Colour Warning') ! ! Initialise Open-GL ! CALL WglSelect(1,0,2) ! ! Set up display and use it ! CALL SetupDisplay() ! ! Enable MouseButUp message ! CALL WMessageEnable(MouseButUp,1) ! ! Main message loop ! DO CALL WMessage(ITYPE, MESSAGE) SELECT CASE (ITYPE) CASE (KeyDown) CALL ProcessKeys(MESSAGE%VALUE1) CASE (MouseButDown,MouseButUp) CALL ProcessMouseButton(ITYPE,MESSAGE%VALUE1,MESSAGE%X,MESSAGE%Y) CASE (MouseMove) CALL ProcessMouseMove(MESSAGE%XPIX,MESSAGE%YPIX) CASE (MenuSelect) IF (MESSAGE%VALUE1 == ID_EXIT) THEN EXIT ELSE CALL ProcessMenu(MESSAGE%VALUE1) END IF CASE (Expose) CALL DISPLAY() ! Re-do present display CASE (Resize) IWIDTH = MESSAGE%WPIX ! Get new window size IHEIGHT = MESSAGE%HPIX CALL glDrawBuffer(GL_FRONT_AND_BACK) CALL glViewPort(0_glsizei,0_glsizei,IWIDTH,IHEIGHT) ! Adjust viewport CALL glDrawBuffer(GL_BACK) CALL DISPLAY() ! Re-do current display CASE (CloseRequest) EXIT ! Exit program (e.g. Alt/F4) END SELECT END DO ! CALL WglSelect(0) CALL WindowClose() ! Remove program window STOP ! CONTAINS ! !****************************************************************************** ! SUBROUTINE ProcessKeys(IKEY) ! ! Process keyboard messages ! ! (I ) IKEY = Code corresponding to key pressed ! USE TEAPOT_MOD ! IMPLICIT NONE INTEGER, INTENT(IN) :: IKEY ! REAL :: factor ! ! Action to take depends on selected function and key pressed ! SELECT CASE(cursor_key_func) CASE (ZOOM) SELECT CASE(IKEY) CASE(KeyCursorDown) factor = 1.0_gldouble + .02_gldouble CASE (KeyCursorUp) factor = 1.0_gldouble/(1.0_gldouble + .02_gldouble) CASE DEFAULT factor = 1.0_gldouble END SELECT shift%z = factor*shift%z CASE (PAN) SELECT CASE(IKEY) CASE (KeyCursorLeft) shift%x = shift%x - .02 CASE (KeyCursorRight) shift%x = shift%x + .02 CASE (KeyCursorDown) shift%y = shift%y - .02 CASE (KeyCursorUp) shift%y = shift%y + .02 END SELECT CASE (ROTATE) SELECT CASE(IKEY) CASE (KeyCursorLeft) angle%x = angle%x - 1.0_gldouble CASE (KeyCursorRight) angle%x = angle%x + 1.0_gldouble CASE (KeyCursorDown) angle%y = angle%y + 1.0_gldouble CASE (KeyCursorUp) angle%y = angle%y - 1.0_gldouble END SELECT CASE (SCALEX) SELECT CASE(IKEY) CASE (KeyCursorDown) factor = 1.0_gldouble/(1.0_gldouble + .02_gldouble) CASE (KeyCursorUp) factor = 1.0_gldouble + .02_gldouble CASE DEFAULT factor = 1.0_gldouble END SELECT xscale_factor = xscale_factor * factor CASE (SCALEY) SELECT CASE(IKEY) CASE (KeyCursorDown) factor = 1.0_gldouble/(1.0_gldouble + .02_gldouble) CASE (KeyCursorUp) factor = 1.0_gldouble + .02_gldouble CASE DEFAULT factor = 1.0_gldouble END SELECT yscale_factor = yscale_factor * factor CASE (SCALEZ) SELECT CASE(IKEY) CASE (KeyCursorDown) factor = 1.0_gldouble/(1.0_gldouble + .02_gldouble) CASE (KeyCursorUp) factor = 1.0_gldouble + .02_gldouble CASE DEFAULT factor = 1.0_gldouble END SELECT zscale_factor = zscale_factor * factor END SELECT ! ! Update display ! CALL DISPLAY() RETURN END SUBROUTINE ProcessKeys ! !****************************************************************************** ! SUBROUTINE ProcessMouseButton(ITYPE,IBUTTON,X_WINT,Y_WINT) ! ! Process mouse button messages ! USE TEAPOT_MOD ! IMPLICIT NONE INTEGER, INTENT(IN) :: ITYPE INTEGER, INTENT(IN) :: IBUTTON INTEGER, INTENT(IN) :: X_WINT INTEGER, INTENT(IN) :: Y_WINT ! INTEGER :: X INTEGER :: Y ! ! Convert Winteracter window units to pixels ! CALL WindowUnitsToPixels(X_WINT,Y_WINT,X,Y) ! SELECT CASE (ITYPE) CASE (MouseButDown) SELECT CASE (IBUTTON) CASE (LeftButton) moving_left = .TRUE. begin_left = cart2D(X,Y) CASE (RightButton) moving_right = .TRUE. begin_right = cart2D(X,Y) END SELECT CALL WMessageEnable(MouseMove,1) CASE (MouseButUp) SELECT CASE (IBUTTON) CASE (LeftButton) moving_left = .FALSE. CASE (RightButton) moving_right = .FALSE. END SELECT CALL WMessageEnable(MouseMove,0) END SELECT ! RETURN END SUBROUTINE ProcessMouseButton ! !****************************************************************************** ! SUBROUTINE ProcessMouseMove(X,Y) ! ! Process mouse movement messages ! USE TEAPOT_MOD ! IMPLICIT NONE INTEGER, INTENT(IN) :: X,Y ! integer :: button_function type(cart2D) :: begin real(kind=gldouble) :: factor ! ! Determine and apply the button function ! IF (moving_left) THEN button_function = left_button_func begin = begin_left ELSE IF (moving_right) THEN button_function = right_button_func begin = begin_right END IF ! SELECT CASE(button_function) CASE (ZOOM) IF (y < begin%y) THEN factor = 1.0_gldouble/(1.0_gldouble + .002_gldouble*(begin%y-y)) ELSE IF (y > begin%y) THEN factor = 1.0_gldouble + .002_gldouble*(y-begin%y) ELSE factor = 1.0_gldouble END IF shift%z = factor*shift%z CASE (PAN) shift%x = shift%x + .01*(x - begin%x) shift%y = shift%y - .01*(y - begin%y) CASE (ROTATE) angle%x = angle%x + (x - begin%x) angle%y = angle%y + (y - begin%y) CASE (SCALEX) IF (y < begin%y) THEN factor = 1.0_gldouble + .002_gldouble*(begin%y-y) ELSE IF (y > begin%y) THEN factor = 1.0_gldouble/(1.0_gldouble + .002_gldouble*(y-begin%y)) ELSE factor = 1.0_gldouble END IF xscale_factor = xscale_factor * factor CASE (SCALEY) IF (y < begin%y) THEN factor = 1.0_gldouble + .002_gldouble*(begin%y-y) ELSE IF (y > begin%y) THEN factor = 1.0_gldouble/(1.0_gldouble + .002_gldouble*(y-begin%y)) ELSE factor = 1.0_gldouble END IF yscale_factor = yscale_factor * factor CASE (SCALEZ) IF (y < begin%y) THEN factor = 1.0_gldouble + .002_gldouble*(begin%y-y) ELSE IF (y > begin%y) THEN factor = 1.0_gldouble/(1.0_gldouble + .002_gldouble*(y-begin%y)) ELSE factor = 1.0_gldouble END IF zscale_factor = zscale_factor * factor END SELECT ! ! Update variables and redisplay ! IF (moving_left) THEN begin_left = cart2D(x,y) ELSE IF (moving_right) THEN begin_right = cart2D(x,y) END IF IF (moving_left .or. moving_right) CALL DISPLAY() RETURN END SUBROUTINE ProcessMouseMove ! !****************************************************************************** ! SUBROUTINE ProcessMenu(IDENT) ! ! Process menu selection messages ! USE TEAPOT_MOD ! IMPLICIT NONE INTEGER, INTENT(IN) :: IDENT ! INTEGER :: IOPT ! SELECT CASE (IDENT) CASE (ID_LEFT_ROTATE:ID_LEFT_Z) DO IOPT = ID_LEFT_ROTATE,ID_LEFT_Z CALL WMenuSetState(IOPT,ItemChecked,WintOff) END DO CALL WMenuSetState(IDENT,ItemChecked,WintOn) left_button_func = IDENT - ID_LEFT CASE (ID_RIGHT_ROTATE:ID_RIGHT_Z) DO IOPT = ID_RIGHT_ROTATE,ID_RIGHT_Z CALL WMenuSetState(IOPT,ItemChecked,WintOff) END DO CALL WMenuSetState(IDENT,ItemChecked,WintOn) right_button_func = IDENT - ID_RIGHT CASE (ID_CURSOR_ROTATE:ID_CURSOR_Z) DO IOPT = ID_CURSOR_ROTATE,ID_CURSOR_Z CALL WMenuSetState(IOPT,ItemChecked,WintOff) END DO CALL WMenuSetState(IDENT,ItemChecked,WintOn) cursor_key_func = IDENT - ID_CURSOR CASE (ID_VIEW_SOLID,ID_VIEW_WIREFRAME,ID_VIEW_POINTS) CALL WMenuSetState(ID_VIEW_SOLID, ItemChecked,WintOff) CALL WMenuSetState(ID_VIEW_WIREFRAME,ItemChecked,WintOff) CALL WMenuSetState(ID_VIEW_POINTS, ItemChecked,WintOff) CALL WMenuSetState(IDENT,ItemChecked,WintOn) IVIEW = IDENT CALL Display() CASE (ID_VIEW_AXES) AXES = .NOT.AXES IF (AXES) THEN CALL WMenuSetState(ID_VIEW_AXES,ItemChecked,WintOn) ELSE CALL WMenuSetState(ID_VIEW_AXES,ItemChecked,WintOff) END IF CALL Display() CASE (ID_VIEW_RESET) CALL RESET_TO_INIT() END SELECT ! RETURN END SUBROUTINE ProcessMenu ! !****************************************************************************** ! SUBROUTINE SetupDisplay() ! ! Sets up display. ! ! This routine doesn't actually produce any output, that is done by the ! Display() routine. ! USE TEAPOT_MOD ! IMPLICIT NONE ! ! Colors for bronze from Redbook teapots ! REAL(KIND=glfloat), DIMENSION(3) :: ambient = (/0.2125_glfloat, & 0.1275_glfloat, & 0.054_glfloat/) REAL(KIND=glfloat), DIMENSION(3) :: diffuse = (/0.714_glfloat, & 0.4284_glfloat, & 0.18144_glfloat/) REAL(KIND=glfloat), DIMENSION(3) :: specular = (/0.393548_glfloat, & 0.271906_glfloat, & 0.166721_glfloat/) REAL(KIND=glfloat), DIMENSION(4) :: pos = (/1.0_glfloat, & 1.0_glfloat, & 1.0_glfloat, & 0.0_glfloat/) REAL(KIND=glfloat), DIMENSION(4) :: white = (/1.0_glfloat, & 1.0_glfloat, & 1.0_glfloat, & 1.0_glfloat/) ! ! Since we are using animation we will use double-buffering to eliminate flicker. ! To do this we should set the Draw and Read buffers to the back buffer. ! CALL glReadBuffer(GL_BACK) CALL glDrawBuffer(GL_BACK) ! ! Set the perspective ! CALL glMatrixMode(GL_PROJECTION) CALL gluPerspective(10.0_gldouble, 1.0_gldouble, 0.1_gldouble, 200.0_gldouble) ! ! Set the initial view ! CALL glMatrixMode(GL_MODELVIEW) CALL glPushMatrix() CALL RESET_TO_INIT() ! ! Create display list for axes ! CALL glNewList(1,GL_COMPILE) ! ! Draw axes so we know the orientation ! CALL glBegin(GL_LINES) CALL glVertex3f(0.0_glfloat,0.0_glfloat,0.0_glfloat) CALL glVertex3f(2.0_glfloat,0.0_glfloat,0.0_glfloat) CALL glVertex3f(0.0_glfloat,0.0_glfloat,0.0_glfloat) CALL glVertex3f(0.0_glfloat,2.0_glfloat,0.0_glfloat) CALL glVertex3f(0.0_glfloat,0.0_glfloat,0.0_glfloat) CALL glVertex3f(0.0_glfloat,0.0_glfloat,2.0_glfloat) ! ! Draw crude X, Y and Z to label the axes ! CALL glVertex3f( 2.1_glfloat,-0.1_glfloat, 0.1_glfloat) ! X CALL glVertex3f( 2.1_glfloat, 0.1_glfloat,-0.1_glfloat) CALL glVertex3f( 2.1_glfloat,-0.1_glfloat,-0.1_glfloat) CALL glVertex3f( 2.1_glfloat, 0.1_glfloat, 0.1_glfloat) CALL glVertex3f( 0.1_glfloat, 2.1_glfloat, 0.1_glfloat) ! Y CALL glVertex3f( 0.0_glfloat, 2.1_glfloat, 0.0_glfloat) CALL glVertex3f(-0.1_glfloat, 2.1_glfloat, 0.1_glfloat) CALL glVertex3f( 0.1_glfloat, 2.1_glfloat,-0.1_glfloat) CALL glVertex3f(-0.1_glfloat, 0.1_glfloat, 2.1_glfloat) ! Z CALL glVertex3f( 0.1_glfloat, 0.1_glfloat, 2.1_glfloat) CALL glVertex3f( 0.1_glfloat, 0.1_glfloat, 2.1_glfloat) CALL glVertex3f(-0.1_glfloat,-0.1_glfloat, 2.1_glfloat) CALL glVertex3f(-0.1_glfloat,-0.1_glfloat, 2.1_glfloat) CALL glVertex3f( 0.1_glfloat,-0.1_glfloat, 2.1_glfloat) CALL glEnd() ! CALL glEndList() ! ! Create display list for solid teapot ! CALL glNewList(ID_VIEW_SOLID,GL_COMPILE) ! ! Rotate so the z-axis comes out the top, x-axis out the spout ! CALL glRotated(90.0_gldouble,1.0_gldouble,0.0_gldouble,0.0_gldouble) CALL glMaterialfv(GL_FRONT, GL_AMBIENT, ambient) CALL glMaterialfv(GL_FRONT, GL_DIFFUSE, diffuse) CALL glMaterialfv(GL_FRONT, GL_SPECULAR, specular) CALL glMaterialf (GL_FRONT, GL_SHININESS, 25.6_glfloat) ! ! Draw a teapot ! CALL DrawTeapot(14, 1.0_gldouble, GL_FILL) ! CALL glEndList() ! ! Create display list for wireframe teapot ! CALL glNewList(ID_VIEW_WIREFRAME,GL_COMPILE) ! ! Rotate so the z-axis comes out the top, x-axis out the spout ! CALL glRotated(90.0_gldouble,1.0_gldouble,0.0_gldouble,0.0_gldouble) CALL glMaterialfv(GL_FRONT, GL_AMBIENT, ambient) CALL glMaterialfv(GL_FRONT, GL_DIFFUSE, diffuse) CALL glMaterialfv(GL_FRONT, GL_SPECULAR, specular) CALL glMaterialf (GL_FRONT, GL_SHININESS, 25.6_glfloat) ! ! Draw a teapot ! CALL DrawTeapot(10, 1.0_gldouble, GL_LINE) ! CALL glEndList() ! ! Create display list for teapot drawn using points only ! CALL glNewList(ID_VIEW_POINTS,GL_COMPILE) ! ! Rotate so the z-axis comes out the top, x-axis out the spout ! CALL glRotated(90.0_gldouble,1.0_gldouble,0.0_gldouble,0.0_gldouble) CALL glMaterialfv(GL_FRONT, GL_AMBIENT, ambient) CALL glMaterialfv(GL_FRONT, GL_DIFFUSE, diffuse) CALL glMaterialfv(GL_FRONT, GL_SPECULAR, specular) CALL glMaterialf (GL_FRONT, GL_SHININESS, 25.6_glfloat) ! ! Draw a teapot ! CALL DrawTeapot(10, 1.0_gldouble, GL_POINT) ! CALL glEndList() ! ! Set the lighting ! CALL glClearColor(1.0_glclampf, 1.0_glclampf, 1.0_glclampf, 1.0_glclampf) CALL glLightfv(GL_LIGHT0, GL_DIFFUSE, white) CALL glLightfv(GL_LIGHT0, GL_POSITION, pos) CALL glEnable(GL_LIGHTING) CALL glEnable(GL_LIGHT0) CALL glEnable(GL_DEPTH_TEST) ! ! Draw initial display ! CALL DISPLAY() RETURN END SUBROUTINE SetupDisplay ! !****************************************************************************** ! SUBROUTINE DISPLAY() ! ! Draw display using information already set up in SetupDisplay() ! USE TEAPOT_MOD ! CALL RESET_VIEW() ! CALL glClear(ior(GL_COLOR_BUFFER_BIT,GL_DEPTH_BUFFER_BIT)) IF (AXES) CALL glCallList(1) CALL glCallList(IVIEW) CALL WglSwapBuffers() RETURN END SUBROUTINE DISPLAY ! !****************************************************************************** ! SUBROUTINE RESET_TO_INIT() ! ! This resets the view to the initial configuration ! USE TEAPOT_MOD ! IMPLICIT NONE TYPE (sphere3D) :: slookfrom ! slookfrom = cart2sphere(init_lookfrom-init_lookat) angle%x = -180.0_gldouble*slookfrom%theta/PI - 90.0_gldouble angle%y = -180.0_gldouble*slookfrom%phi/PI shift%x = 0.0_gldouble shift%y = 0.0_gldouble shift%z = -slookfrom%rho xscale_factor = init_xscale_factor yscale_factor = init_yscale_factor zscale_factor = init_zscale_factor call DISPLAY() RETURN END SUBROUTINE RESET_TO_INIT ! !****************************************************************************** ! SUBROUTINE RESET_VIEW() ! ! This routine resets the view to the current orientation and scale ! USE TEAPOT_MOD ! CALL glMatrixMode(GL_MODELVIEW) CALL glPopMatrix() CALL glPushMatrix() CALL glTranslated(shift%x, shift%y, shift%z) CALL glRotated(angle%x, 0.0_gldouble, 0.0_gldouble, 1.0_gldouble) CALL glRotated(angle%y, cos(PI*angle%x/180.0_gldouble), & -sin(PI*angle%x/180.0_gldouble), 0.0_gldouble) CALL glTranslated(-init_lookat%x, -init_lookat%y, -init_lookat%z) CALL glScaled(xscale_factor,yscale_factor,zscale_factor) RETURN END SUBROUTINE RESET_VIEW ! !****************************************************************************** ! SUBROUTINE DrawTeapot(grid,scale,type) ! ! Draw a teapot ! USE TEAPOT_MOD ! IMPLICIT NONE INTEGER(KIND=GLint) , INTENT(IN) :: grid REAL (KIND=GLdouble), INTENT(IN) :: scale INTEGER(KIND=GLenum) , INTENT(IN) :: type ! INTEGER :: I,J,K,L ! ! Rim, body, lid, and bottom data must be reflected in x and y ! handle and spout data across the y axis only. ! INTEGER, SAVE, DIMENSION (0:15,0:9) :: patchdata = RESHAPE( & (/102,103,104,105, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, &! rim 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, &! body 24, 25, 26, 27, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, &! lid 96, 96, 96, 96, 97, 98, 99,100,101,101,101,101, 0, 1, 2, 3, & 0, 1, 2, 3,106,107,108,109,110,111,112,113,114,115,116,117, &! bottom 118,118,118,118,124,122,119,121,123,126,125,120, 40, 39, 38, 37, &! handle 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, & 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 28, 65, 66, 67, &! spout 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, & 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95/),& (/16,10/)) ! REAL, SAVE, DIMENSION(0:2,0:126) :: cpdata = RESHAPE( & (/0.2, 0.0, 2.7 , 0.2, -0.112,2.7 , 0.112,-0.2, 2.7 , 0.0, -0.2, 2.7 ,& 1.3375,0.0, 2.53125, 1.3375,-0.749,2.53125, 0.749,-1.3375,2.53125, 0.0, -1.3375,2.53125,& 1.4375,0.0, 2.53125, 1.4375,-0.805,2.53125, 0.805,-1.4375,2.53125, 0.0, -1.4375,2.53125,& 1.5, 0.0, 2.4 , 1.5, -0.84, 2.4 , 0.84, -1.5, 2.4 , 0.0, -1.5, 2.4 ,& 1.75, 0.0, 1.875 , 1.75, -0.98, 1.875 , 0.98, -1.75, 1.875 , 0.0, -1.75, 1.875 ,& 2.0, 0.0, 1.35 , 2.0, -1.12, 1.35 , 1.12, -2.0, 1.35 , 0.0, -2.0, 1.35 ,& 2.0, 0.0, 0.9 , 2.0, -1.12, 0.9 , 1.12, -2.0, 0.9 , 0.0, -2.0, 0.9 ,& -2.0, 0.0, 0.9 , 2.0, 0.0, 0.45 , 2.0, -1.12, 0.45 , 1.12, -2.0, 0.45 ,& 0.0, -2.0, 0.45 , 1.5, 0.0, 0.225 , 1.5, -0.84, 0.225 , 0.84, -1.5, 0.225 ,& 0.0, -1.5, 0.225 , 1.5, 0.0, 0.15 , 1.5, -0.84, 0.15 , 0.84, -1.5, 0.15 ,& 0.0, -1.5, 0.15 ,-1.6, 0.0, 2.025 ,-1.6, -0.3, 2.025 ,-1.5, -0.3, 2.25 ,& -1.5, 0.0, 2.25 ,-2.3, 0.0, 2.025 ,-2.3, -0.3, 2.025 ,-2.5, -0.3, 2.25 ,& -2.5, 0.0, 2.25 ,-2.7, 0.0, 2.025 ,-2.7, -0.3, 2.025 ,-3.0, -0.3, 2.25 ,& -3.0, 0.0, 2.25 ,-2.7, 0.0, 1.8 ,-2.7, -0.3, 1.8 ,-3.0, -0.3, 1.8 ,& -3.0, 0.0, 1.8 ,-2.7, 0.0, 1.575 ,-2.7, -0.3, 1.575 ,-3.0, -0.3, 1.35 ,& -3.0, 0.0, 1.35 ,-2.5, 0.0, 1.125 ,-2.5, -0.3, 1.125 ,-2.65, -0.3, 0.9375 ,& -2.65, 0.0, 0.9375 ,-2.0, -0.3, 0.9 ,-1.9, -0.3, 0.6 ,-1.9, 0.0, 0.6 ,& 1.7, 0.0, 1.425 , 1.7, -0.66, 1.425 , 1.7, -0.66, 0.6 , 1.7, 0.0, 0.6 ,& 2.6, 0.0, 1.425 , 2.6, -0.66, 1.425 , 3.1, -0.66, 0.825 , 3.1, 0.0, 0.825 ,& 2.3, 0.0, 2.1 , 2.3, -0.25, 2.1 , 2.4, -0.25, 2.025 , 2.4, 0.0, 2.025 ,& 2.7, 0.0, 2.4 , 2.7, -0.25, 2.4 , 3.3, -0.25, 2.4 , 3.3, 0.0, 2.4 ,& 2.8, 0.0, 2.475 , 2.8, -0.25, 2.475 , 3.525,-0.25, 2.49375, 3.525, 0.0, 2.49375,& 2.9, 0.0, 2.475 , 2.9, -0.15, 2.475 , 3.45, -0.15, 2.5125 , 3.45, 0.0, 2.5125 ,& 2.8, 0.0, 2.4 , 2.8, -0.15, 2.4 , 3.2, -0.15, 2.4 , 3.2, 0.0, 2.4 ,& 0.0, 0.0, 3.15 , 0.8, 0.0, 3.15 , 0.8, -0.45, 3.15 , 0.45, -0.8, 3.15 ,& 0.0, -0.8, 3.15 , 0.0, 0.0, 2.85 , 1.4, 0.0, 2.4 , 1.4, -0.784, 2.4 ,& 0.784,-1.4, 2.4 , 0.0, -1.4, 2.4 , 0.4, 0.0, 2.55 , 0.4, -0.224, 2.55 ,& 0.224,-0.4, 2.55 , 0.0, -0.4, 2.55 , 1.3, 0.0, 2.55 , 1.3, -0.728, 2.55 ,& 0.728,-1.3, 2.55 , 0.0, -1.3, 2.55 , 1.3, 0.0, 2.4 , 1.3, -0.728, 2.4 ,& 0.728,-1.3, 2.4 , 0.0, -1.3, 2.4 , 0.0, 0.0, 0.0 , 1.425,-0.798, 0.0 ,& 1.5, 0.0, 0.075 , 1.425, 0.0, 0.0 , 0.798,-1.425, 0.0 , 0.0, -1.5, 0.075 ,& 0.0, -1.425,0.0 , 1.5, -0.84, 0.075 , 0.84, -1.5, 0.075 /), & (/3,127/)) ! REAL(KIND=GLfloat), SAVE, DIMENSION (0:1,0:1,0:1) :: tex = & RESHAPE((/0.0,0.0,1.0,0.0,0.0,1.0,1.0,1.0/),(/2,2,2/)) ! REAL(KIND=GLfloat), DIMENSION(0:2,0:3,0:3) :: p, q, r, s ! CALL glPushAttrib(IOR(GL_ENABLE_BIT,GL_EVAL_BIT)) CALL glEnable(GL_AUTO_NORMAL) CALL glEnable(GL_NORMALIZE) CALL glEnable(GL_MAP2_VERTEX_3) CALL glEnable(GL_MAP2_TEXTURE_COORD_2) CALL glPushMatrix() CALL glRotatef(270.0, 1.0, 0.0, 0.0) CALL glScaled(0.5_GLDouble * scale, 0.5_GlDouble * scale, 0.5_GLDouble * scale) CALL glTranslatef(0.0, 0.0, -1.5) DO I = 0,9 DO J = 0,3 DO K = 0,3 DO L = 0,2 p(l,k,j) = cpdata(l,patchdata(j * 4 + k,i)) q(l,k,j) = cpdata(l,patchdata(j * 4 + (3 - k),i)) IF (l == 1) q(l,k,j) = -1.0 * q(l,k,j) IF (I < 6) THEN r(l,k,j) = cpdata(l,patchdata(j * 4 + (3 - k),i)) IF (l == 0) r(l,k,j) = -1.0 * r(l,k,j) s(l,k,j) = cpdata(l,patchdata(j * 4 + k,i)) IF (l == 0 .OR. l == 1) s(l,k,j) = -1.0 * s(l,k,j) END IF END DO END DO END DO CALL glMap2f(GL_MAP2_TEXTURE_COORD_2,1.0_GLfloat,0.0_GLfloat, & 2_GLint, 2_GLint, & 1.0_GLfloat,0.0_GLfloat, & 4_GLint, 2_GLint, & RESHAPE(tex,(/8/))) CALL glMap2f(GL_MAP2_VERTEX_3,0.0_GLfloat,1.0_GLfloat, & 3_GLint, 4_GLint, & 0.0_GLfloat,1.0_Glfloat, & 12_GLint, 4_GLint, & RESHAPE(p,(/48/))) CALL glMapGrid2f(grid, 0.0, 1.0, grid, 0.0, 1.0) CALL glEvalMesh2(type, 0, grid, 0, grid) CALL glMap2f(GL_MAP2_VERTEX_3,0.0_GLfloat,1.0_GLfloat, & 3_GLint, 4_GLint, & 0.0_GLfloat,1.0_GLfloat, & 12_GLint, 4_GLint, & RESHAPE(q,(/48/))) CALL glEvalMesh2(type, 0, grid, 0, grid) IF (I < 6) THEN CALL glMap2f(GL_MAP2_VERTEX_3,0.0_GLfloat,1.0_GLfloat, & 3_GLint, 4_GLint, & 0.0_GLfloat,1.0_GLfloat, & 12_GLint, 4_GLint, & RESHAPE(r,(/48/))) CALL glEvalMesh2(type, 0, grid, 0, grid) CALL glMap2f(GL_MAP2_VERTEX_3,0.0_GLfloat,1.0_GLfloat, & 3_GLint, 4_GLint, & 0.0_GLfloat,1.0_GLfloat, & 12_GLint, 4_GLint, & RESHAPE(s,(/48/))) CALL glEvalMesh2(type, 0, grid, 0, grid) END IF END DO CALL glPopMatrix() CALL glPopAttrib() RETURN END SUBROUTINE DrawTeapot ! END PROGRAM TEAPOT