!  ********************************************************************
!  * 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 is a product of Interactive Software Services Ltd.   *
!  * email : support@issltd.demon.co.uk                               *
!  *   www : 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 GEARS_MOD
!
      USE WINTERACTER
      USE OPENGL
!
      IMPLICIT NONE
      LOGICAL        :: doubleBuffer = .TRUE.   ! Use double buffering
!
      REAL(glfloat)  :: pos(4)       = (/5.0, 5.0, 10.0, 0.0/)
      REAL(glfloat)  :: red(4)       = (/0.8, 0.1, 0.0, 1.0/)
      REAL(glfloat)  :: green(4)     = (/0.0, 0.8, 0.2, 1.0/)
      REAL(glfloat)  :: blue(4)      = (/0.2, 0.2, 1.0, 1.0/)
!
      REAL(glfloat)  :: angle        =  0.0
!
      REAL(glfloat)  :: view_rotx    = 20.0
      REAL(glfloat)  :: view_roty    = 30.0
      REAL(glfloat)  :: view_rotz    =  0.0
!
      INTEGER(glint) :: theGear1,theGear2,theGear3
!
      INTERFACE
!
        SUBROUTINE ProcessKey(IDENT)
        IMPLICIT NONE
        INTEGER, INTENT(IN) :: IDENT
        END SUBROUTINE ProcessKey
!
        SUBROUTINE Display()
        END SUBROUTINE Display
!
        SUBROUTINE DisplaySetup()
        END SUBROUTINE DisplaySetup
!
        SUBROUTINE DisplayResize(IWIDTH,IHEIGHT)
        IMPLICIT NONE
        INTEGER,  INTENT(IN) :: IWIDTH,IHEIGHT
        END SUBROUTINE DisplayResize
!
        SUBROUTINE Idle()
        END SUBROUTINE Idle
!
        SUBROUTINE Gear(INNRADIUS,OUTRADIUS,WIDTH,TEETH,TOOTHDEPTH)
        IMPLICIT NONE
        REAL,    INTENT(IN) :: INNRADIUS,OUTRADIUS,WIDTH
        INTEGER, INTENT(IN) :: TEETH
        REAL,    INTENT(IN) :: TOOTHDEPTH
        END SUBROUTINE Gear
!
        SUBROUTINE Vertex(R,ANGL,WIDTH)
        IMPLICIT NONE
        REAL, INTENT(IN) :: R,ANGL,WIDTH
        END SUBROUTINE Vertex
!
      END INTERFACE
!
      END MODULE GEARS_MOD
!
!*****************************************************************************
!
      PROGRAM GEARS
!
! Animated 3D Gear Wheels
!
      USE GEARS_MOD
      IMPLICIT NONE
!
      TYPE(WIN_MESSAGE) :: MESSAGE
      INTEGER           :: IFLAGS,ITYPE
!
!  Initialise Winteracter.
!
      CALL WInitialise('')
!
!  Open root window.
!
      CALL WindowOpen(WIN_STYLE(SysMenuOn + &  ! System menu
                                MinButton + &  ! Minimize button
                                MaxButton + &  ! Maximize button
                                StatusBar,  &  ! Status bar
                                -1,-1,      &  ! Centre window
                                400,400,    &  ! Sensible size for scene
                                0,          &  ! No Menu
                                'Animated Gear Wheels'))
!
!  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
!
      IF (doubleBuffer) THEN
          IFLAGS = 2
      ELSE
          IFLAGS = 0
      END IF
      CALL WglSelect(1,0,IFLAGS)
!
!  Display prompt in status bar
!
      CALL WindowOutStatusBar(1,"Use the cursor keys, 'z' and 'Z' to rotate image")
!
!  Set up display
!
      CALL DisplaySetup()
      CALL DisplayResize(400,400)
!
!  Draw initial display
!
      CALL Display()
!
! Main message loop
!
      DO
          CALL WMessagePeek(ITYPE,MESSAGE)
          SELECT CASE (ITYPE)
              CASE (NoMessage)
                  CALL Idle()
              CASE (Expose)
                  CALL Display()
              CASE (Resize)
                  CALL DisplayResize(MESSAGE%VALUE1,MESSAGE%VALUE2)
              CASE (KeyDown)
                  CALL ProcessKey(MESSAGE%VALUE1)
              CASE (CloseRequest)
                  EXIT
          END SELECT
      END DO
!
!  Terminate Open-GL and Winteracter
!
      CALL WglSelect(0)
      CALL WindowClose()
!
      STOP
      END PROGRAM GEARS
!
!*****************************************************************************
!
      SUBROUTINE ProcessKey(IDENT)
!
! Process keydown events
!
      USE GEARS_MOD, NotRequired=>ProcessKey
!
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: IDENT
!
      SELECT CASE (IDENT)
          CASE (KeyCursorUp)
              view_rotx = view_rotx + 5.0
          CASE (KeyCursorDown)
              view_rotx = view_rotx - 5.0
          CASE (KeyCursorRight)
              view_roty = view_roty + 5.0
          CASE (KeyCursorLeft)
              view_roty = view_roty - 5.0
          CASE (122)   ! If the letter 'z' is pressed
              view_rotz = view_rotz + 5.0
          CASE (90)    ! If the letter 'Z' is pressed
              view_rotz = view_rotz - 5.0
      END SELECT
!
      RETURN
      END SUBROUTINE ProcessKey
!
!*****************************************************************************
!
      SUBROUTINE Display()
!
! Draw the display list
!
      USE GEARS_MOD, NotRequired=>Display
      IMPLICIT NONE
!
      CALL glClear(ior(GL_COLOR_BUFFER_BIT,GL_DEPTH_BUFFER_BIT))
!
      CALL glPushMatrix()
      CALL glRotatef(view_rotx, 1.0_glfloat, 0.0_glfloat, 0.0_glfloat)
      CALL glRotatef(view_roty, 0.0_glfloat, 1.0_glfloat, 0.0_glfloat)
      CALL glRotatef(view_rotz, 0.0_glfloat, 0.0_glfloat, 1.0_glfloat)
!
      CALL glPushMatrix()
      CALL glTranslatef(-3.0_glfloat, -2.0_glfloat, 0.0_glfloat)
      CALL glRotatef(angle, 0.0_glfloat, 0.0_glfloat, 1.0_glfloat)
      CALL glCallList(theGear1)
      CALL glPopMatrix()
!
      CALL glPushMatrix()
      CALL glTranslatef(3.1_glfloat, -2.0_glfloat, 0.0_glfloat)
      CALL glRotatef(-2.0_glfloat*angle-9.0_glfloat, 0.0_glfloat, 0.0_glfloat, 1.0_glfloat)
      CALL glCallList(theGear2)
      CALL glPopMatrix()
!
      CALL glPushMatrix()
      CALL glTranslatef(-3.1_glfloat, 4.2_glfloat, 0.0_glfloat)
      CALL glRotatef(-2.0_glfloat*angle-25.0_glfloat, 0.0_glfloat, 0.0_glfloat, 1.0_glfloat)
      CALL glCallList(theGear3)
      CALL glPopMatrix()
!
      CALL glPopMatrix()
!
      IF (doubleBuffer) THEN
          CALL WglSwapBuffers()
      ELSE
          CALL glFlush()
      END IF
!
      RETURN
      END SUBROUTINE Display
!
!*****************************************************************************
!
      SUBROUTINE DisplaySetup()
!
! Initialise the objects that are drawn
!
      USE GEARS_MOD, NotRequired=>DisplaySetup
      IMPLICIT NONE
!
! If double-buffering is enabled then we need to set the Read and Draw buffers
! to the back buffer. Using double-buffering eliminates flicker.
!
      IF (doublebuffer) THEN
          CALL glReadBuffer(GL_BACK)
          CALL glDrawBuffer(GL_BACK)
      END IF
!
      CALL glLightfv(GL_LIGHT0, GL_POSITION, pos)
      CALL glEnable(GL_CULL_FACE)
      CALL glEnable(GL_LIGHTING)
      CALL glEnable(GL_LIGHT0)
      CALL glEnable(GL_DEPTH_TEST)
!
! Create the gears
!
      theGear1 = glGenLists(1)
      CALL glNewList(theGear1, GL_COMPILE)
      CALL glMaterialfv(GL_FRONT, GL_AMBIENT_AND_DIFFUSE, red)
      CALL Gear( 1.0, 4.0, 1.0, 20, 0.7)
      CALL glEndList()
!
      theGear2 = glGenLists(1)
      CALL glNewList(theGear2, GL_COMPILE)
      CALL glMaterialfv( GL_FRONT, GL_AMBIENT_AND_DIFFUSE, green)
      CALL Gear( 0.5, 2.0, 2.0, 10, 0.7)
      CALL glEndList()
!
      theGear3 = glGenLists(1)
      CALL glNewList(theGear3, GL_COMPILE)
      CALL glMaterialfv( GL_FRONT, GL_AMBIENT_AND_DIFFUSE, blue)
      CALL Gear( 1.3, 2.0, 0.5, 10, 0.7)
      CALL glEndList()
!
      CALL glEnable(GL_NORMALIZE)
!
      RETURN
      END SUBROUTINE DisplaySetup
!
!*****************************************************************************
!
      SUBROUTINE DisplayResize(IWIDTH,IHEIGHT)
!
! Resize the OpenGL image to fit the window
!
      USE GEARS_MOD, NotRequired=>DisplayResize
!
      IMPLICIT NONE
      INTEGER,  INTENT(IN) :: IWIDTH
      INTEGER,  INTENT(IN) :: IHEIGHT
!
      INTEGER(glsizei)     :: IGWIDTH, IGHEIGHT
      REAL(gldouble)       :: RGWIDTH, RGHEIGHT, RGASPECT
!
      IGWIDTH  = IWIDTH
      IGHEIGHT = IHEIGHT
!
      RGWIDTH  = IWIDTH
      RGHEIGHT = IHEIGHT
!
      RGASPECT = RGHEIGHT/RGWIDTH
!
      IF (doubleBuffer) &
          CALL glDrawBuffer(GL_FRONT_AND_BACK)
      CALL glViewport(0_glsizei, 0_glsizei, IGWIDTH, IGHEIGHT)
      IF (doubleBuffer) &
          CALL glDrawBuffer(GL_BACK)
!
      CALL glMatrixMode(GL_PROJECTION)
      CALL glLoadIdentity()
      CALL glFrustum( -1.0_gldouble, &
                       1.0_gldouble, &
                      -RGASPECT,     &
                       RGASPECT,     &
                       5.0_gldouble, &
                      60.0_gldouble)
      CALL glMatrixMode(GL_MODELVIEW)
      CALL glLoadIdentity()
      CALL glTranslatef( 0.0_glfloat, 0.0_glfloat, -40.0_glfloat)
      CALL glClear(ior(GL_COLOR_BUFFER_BIT,GL_DEPTH_BUFFER_BIT))
!
      CALL Display()
!
      RETURN
      END SUBROUTINE DisplayResize
!
!*****************************************************************************
!
      SUBROUTINE Idle()
!
! If there are no messages to process, draw another frame of the animation
!
      USE GEARS_MOD, NotRequired=>Idle
!
      IMPLICIT NONE
!
      angle = angle + 2.0_glfloat
!
      CALL Display()
!
      RETURN
      END SUBROUTINE Idle
!
!*****************************************************************************
!
      SUBROUTINE Gear(INNRADIUS,OUTRADIUS,WIDTH,TEETH,TOOTHDEPTH)
!
! Draw a gear wheel.
!
      USE GEARS_MOD, NotRequired=>Gear
!
      IMPLICIT NONE
      REAL,    INTENT(IN) :: INNRADIUS  ! Radius of hole at center
      REAL,    INTENT(IN) :: OUTRADIUS  ! Radius at center of teeth
      REAL,    INTENT(IN) :: WIDTH      ! Width of gear
      INTEGER, INTENT(IN) :: TEETH      ! Number of teeth
      REAL,    INTENT(IN) :: TOOTHDEPTH ! Depth of tooth
!
      REAL                :: R0, R1, R2
      REAL                :: ANGL, DA
      REAL                :: U, V, LEN
      INTEGER             :: I
!
      REAL(glfloat)       :: x, y, z
!
      REAL                :: PI = 3.14159265
!
      R0 = INNRADIUS
      R1 = OUTRADIUS - TOOTHDEPTH/2.0
      R2 = OUTRADIUS + TOOTHDEPTH/2.0
!
      DA    = 2.0*PI/(TEETH*4.0)
!
      CALL glShadeModel(GL_FLAT)
      CALL glNormal3f(0.0_glfloat, 0.0_glfloat, 1.0_glfloat)
!
! Draw the front face
!
      CALL glBegin(GL_QUAD_STRIP)
!
      DO I = 0,TEETH
          ANGL = I*2.0*PI/TEETH
!
          CALL Vertex(R0,ANGL,WIDTH)
          CALL Vertex(R1,ANGL,WIDTH)
          CALL Vertex(R0,ANGL,WIDTH)
          CALL Vertex(R1,ANGL+3.0*DA,WIDTH)
      END DO
!
      CALL glEnd()
!
! Draw front sides of teeth
!
      CALL glBegin(GL_QUADS)
!
      DO I = 0,TEETH-1
          ANGL = I*2.0*PI/TEETH
!
          CALL Vertex(R1,ANGL,WIDTH)
          CALL Vertex(R2,ANGL+DA,WIDTH)
          CALL Vertex(R2,ANGL+2.0*DA,WIDTH)
          CALL Vertex(R1,ANGL+3.0*DA,WIDTH)
      END DO
!
      CALL glEnd()
!
      CALL glNormal3f( 0.0_glfloat, 0.0_glfloat, -1.0_glfloat)
!
! Draw back face
!
      CALL glBegin(GL_QUAD_STRIP)
!
      DO I = 0, TEETH
          ANGL = I*2.0*PI/TEETH
!
          CALL Vertex(R1,ANGL,-WIDTH)
          CALL Vertex(R0,ANGL,-WIDTH)
          CALL Vertex(R1,ANGL+3.0*DA,-WIDTH)
          CALL Vertex(R0,ANGL,-WIDTH)
      END DO
!
      CALL glEnd()
!
! Draw back sides of teeth
!
      CALL glBegin(GL_QUADS)
!
      DO I= 0, TEETH-1
          ANGL = I*2.0*PI/TEETH
!
          CALL Vertex(R1,ANGL+3.0*DA,-WIDTH)
          CALL Vertex(R2,ANGL+2.0*DA,-WIDTH)
          CALL Vertex(R2,ANGL+DA,-WIDTH)
          CALL Vertex(R1,ANGL,-WIDTH)
      END DO
!
      CALL glEnd()
!
! Draw outward faces of teeth
!
      CALL glBegin(GL_QUAD_STRIP)
!
      DO I = 0, TEETH-1
          ANGL = I*2.0*PI/TEETH
!
          CALL Vertex(R1,ANGL,WIDTH)
          CALL Vertex(R1,ANGL,-WIDTH)
!
          U   = R2*COS(ANGL+DA) - R1*COS(ANGLE)
          V   = R2*SIN(ANGL+DA) - R1*SIN(ANGLE)
          LEN = SQRT( U*U + V*V )
!
          x = U/LEN
          y = V/LEN
          z = 0.0
!
          CALL glNormal3f( y, -x, z)
!
          CALL Vertex(R2,ANGL+DA,WIDTH)
          CALL Vertex(R2,ANGL+DA,-WIDTH)
!
          x = COS(ANGL)
          y = SIN(ANGL)
          z = 0.0
          CALL glNormal3f(x, y, z)
!
          CALL Vertex(R2,ANGL+2.0*DA,WIDTH)
          CALL Vertex(R2,ANGL+2.0*DA,-WIDTH)
!
          x = R1*COS(ANGL+3.0*DA) - R2*COS(ANGL+2.0*DA)
          y = R1*SIN(ANGL+3.0*DA) - R2*SIN(ANGL+2.0*DA)
          z = 0.0
          CALL glNormal3f( y, -x, z)
!
          CALL Vertex(R1,ANGL+3.0*DA,WIDTH)
          CALL Vertex(R1,ANGL+3.0*DA,-WIDTH)
!
          x = COS(ANGL)
          y = SIN(ANGL)
          z = 0.0
          CALL glNormal3f(x, y, z)
      END DO
!
      CALL Vertex(R1,0.0,WIDTH)
      CALL Vertex(R1,0.0,-WIDTH)
!
      CALL glEnd()
!
      CALL glShadeModel(GL_SMOOTH)
!
! Draw inside radius cylinder
!
      CALL glBegin(GL_QUAD_STRIP)
!
      DO I = 0,TEETH
          ANGL = I*2.0*PI/TEETH
!
          x = -COS(ANGL)
          y = -SIN(ANGL)
          z = 0.0
          CALL glNormal3f(x, y, z)
!
          CALL Vertex(R0,ANGL,-WIDTH)
          CALL Vertex(R0,ANGL,WIDTH)
      END DO
!
      CALL glEnd()
!
      RETURN
      END SUBROUTINE Gear
!
!*****************************************************************************
!
      SUBROUTINE Vertex(R,ANGL,WIDTH)
!
! Specify a vertex
!
      USE GEARS_MOD, NotRequired=>Vertex
!
      IMPLICIT NONE
      REAL, INTENT(IN) :: R,ANGL,WIDTH
!
      REAL(glfloat) :: x, y, z
!
      x = R*COS(ANGL)
      y = R*SIN(ANGL)
      z = WIDTH*0.5
!
      CALL glVertex3f(x, y, z)
!
      RETURN
      END SUBROUTINE Vertex