!  ********************************************************************
!  * 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.                   *
!  *                                                                  *
!  ********************************************************************
!
      PROGRAM MOLEHILL
!
      USE WINTERACTER
      USE OPENGL
!
      IMPLICIT NONE
      TYPE(WIN_MESSAGE) :: MESSAGE
      INTEGER           :: ITYPE
!
      INTEGER(glsizei)  :: IWIDTH,IHEIGHT
!
!  Initialise Winteracter
!
      CALL WInitialise()
!
!  Open root window
!
      CALL WindowOpen(TITLE='Molehill')
!
!  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)
!
!  Setup display
!
      CALL SetupDisplay()
!
!  Draw Display
!
      CALL Display()
!
!  Main message loop
!
      DO
        CALL WMessage(ITYPE, MESSAGE)
        SELECT CASE (ITYPE)
            CASE (Expose)
              CALL Display()                                      ! Re-do current display
            CASE (Resize)
              IWIDTH  = MESSAGE%WPIX                              ! Get new window size
              IHEIGHT = MESSAGE%HPIX
              CALL glViewPort(0_glsizei,0_glsizei,IWIDTH,IHEIGHT) ! Adjust viewport
              CALL Display()                                      ! Re-do current display
            CASE (CloseRequest)
              EXIT
        END SELECT
      END DO
!
!  Terminate Open-GL and Winteracter
!
      CALL WglSelect(0)
      CALL WindowClose()
!
      STOP
!
      CONTAINS
!
!******************************************************************************
!
      SUBROUTINE SetupDisplay()
!
!  Sets up display. Nothing is actually drawn until Display() is called.
!
      USE OPENGL
      IMPLICIT NONE
!
      REAL(glfloat), DIMENSION(4) :: mat_red_diffuse    = (/0.7,0.0,0.1,1.0/)
      REAL(glfloat), DIMENSION(4) :: mat_green_diffuse  = (/0.0,0.7,0.1,1.0/)
      REAL(glfloat), DIMENSION(4) :: mat_blue_diffuse   = (/0.0,0.1,0.7,1.0/)
      REAL(glfloat), DIMENSION(4) :: mat_yellow_diffuse = (/0.7,0.8,0.1,1.0/)
!
      REAL(glfloat), DIMENSION(4) :: mat_specular  = (/1.0,1.0,1.0,1.0/)
      REAL(glfloat), DIMENSION(1) :: mat_shininess = (/100.0/)
!
      REAL(glfloat), DIMENSION(8) :: knots = (/0.0,0.0,0.0,0.0,1.0,1.0,1.0,1.0/)
!
      REAL(glfloat), DIMENSION(3,4,4) :: pts1,   pts2,   pts3,   pts4
      REAL(glfloat), DIMENSION(48)    :: pts11d, pts21d, pts31d, pts41d
!
      TYPE (GLUnurbsObj), POINTER :: nurb
      INTEGER                     :: u, v
      REAL(glfloat)               :: real_glu_fill
!
      CALL glMaterialfv(GL_FRONT,GL_SPECULAR,mat_specular)
      CALL glMaterialfv(GL_FRONT,GL_SHININESS,mat_shininess)
      CALL glEnable(GL_LIGHTING)
      CALL glEnable(GL_LIGHT0)
      CALL glEnable(GL_DEPTH_TEST)
      CALL glEnable(GL_AUTO_NORMAL)
      CALL glEnable(GL_NORMALIZE)
      nurb => gluNewNurbsRenderer()
      CALL gluNurbsProperty(nurb,GLU_SAMPLING_TOLERANCE,25.0)
      real_glu_fill = GLU_FILL
      CALL gluNurbsProperty(nurb,GLU_DISPLAY_MODE,real_glu_fill)
!
!  Build control points for NURBS mole hills.
!
      DO u=1,4
        DO v=1,4
!
!  Red.
!
          pts1(1,v,u) = 2.0*(u-1)
          pts1(2,v,u) = 2.0*(v-1)
          IF ((u==2 .or. u==3) .and. (v==2 .or. v==3)) THEN
              pts1(3,v,u) = 6.0 ! Stretch up middle.
          ELSE
              pts1(3,v,u) = 0.0
          END IF
!
!  Green.
!
          pts2(1,v,u) = 2.0*(u - 4)
          pts2(2,v,u) = 2.0*(v - 4)
          IF ((u==2 .or. u==3) .and. (v==2 .or. v==3)) THEN
              IF (u == 2 .and. v == 2) THEN
                  pts2(3,v,u) = 15.0 ! Pull hard on single middle square.
              ELSE
                  pts2(3,v,u) = -2.0 ! Push down on other middle squares.
              END IF
          ELSE
              pts2(3,v,u) = 0.0
          END IF
!
!  Blue.
!
          pts3(1,v,u) = 2.0*(u - 4)
          pts3(2,v,u) = 2.0*(v-1)
          IF ((u==2 .or. u==3) .and. (v==2 .or. v==3)) THEN
              IF (u == 2 .and. v == 3) THEN
                  pts3(3,v,u) = 11.0 ! Pull up on single middple square.
              ELSE
                  pts3(3,v,u) =  2.0 ! Pull up slightly on other middle squares.
              END IF
          ELSE
              pts3(3,v,u) = 0.0
          END IF
!
!  Yellow.
!
          pts4(1,v,u) = 2.0*(u-1)
          pts4(2,v,u) = 2.0*(v - 4)
          IF ((u==2 .or. u==3 .or. u==4) .and. (v==2 .or. v==3)) THEN
              IF (v == 2) THEN
                 pts4(3,v,u) = -2.0 ! Push down front middle and right squares.
              ELSE
                  pts4(3,v,u) = 5.0 ! Pull up back middle and right squares.
              END IF
          ELSE
              pts4(3,v,u) = 0.0
          END IF
        END DO
      END DO
!
!  Stretch up red's far right corner.
!
      pts1(3,4,4) = 6.0
!
!  Pull down green's near left corner a little.
!
      pts2(3,1,1) = -2.0
!
!  Turn up meeting of four corners.
!
      pts1(3,1,1) = 1.0
      pts2(3,4,4) = 1.0
      pts3(3,1,4) = 1.0
      pts4(3,4,1) = 1.0
!
!  gluNurbsSurface expects an array of rank 1
!  Reshape the pts arrays into 1D arrays
!
      pts11d = reshape(pts1,(/48/))
      pts21d = reshape(pts2,(/48/))
      pts31d = reshape(pts3,(/48/))
      pts41d = reshape(pts4,(/48/))
!
      CALL glMatrixMode(GL_PROJECTION)
      CALL gluPerspective(55.0_gldouble,1.0_gldouble,2.0_gldouble,24.0_gldouble)
      CALL glMatrixMode(GL_MODELVIEW)
      CALL glTranslatef(0.0,0.0,-15.0)
      CALL glRotatef(330.0,1.0,0.0,0.0)
!
      CALL glNewList(1, GL_COMPILE)
!
!  Render red hill.
!
      CALL glMaterialfv(GL_FRONT,GL_DIFFUSE,mat_red_diffuse)
      CALL gluBeginSurface(nurb)
      CALL gluNurbsSurface(nurb,8,knots,8,knots,4*3,3,pts11d,4,4,GL_MAP2_VERTEX_3)
      CALL gluEndSurface(nurb)
!
!  Render green hill.
!
      CALL glMaterialfv(GL_FRONT,GL_DIFFUSE,mat_green_diffuse)
      CALL gluBeginSurface(nurb)
      CALL gluNurbsSurface(nurb,8,knots,8,knots,4*3,3,pts21d,4,4,GL_MAP2_VERTEX_3)
      CALL gluEndSurface(nurb)
!
!  Render blue hill.
!
      CALL glMaterialfv(GL_FRONT,GL_DIFFUSE,mat_blue_diffuse)
      CALL gluBeginSurface(nurb)
      CALL gluNurbsSurface(nurb,8,knots,8,knots,4*3,3,pts31d,4,4,GL_MAP2_VERTEX_3)
      CALL gluEndSurface(nurb)
!
!  Render yellow hill.
!
      CALL glMaterialfv(GL_FRONT,GL_DIFFUSE,mat_yellow_diffuse)
      CALL gluBeginSurface(nurb)
      CALL gluNurbsSurface(nurb,8,knots,8,knots,4*3,3,pts41d,4,4,GL_MAP2_VERTEX_3)
      CALL gluEndSurface(nurb)
      CALL glEndList()
      RETURN
      END SUBROUTINE SetupDisplay
!
!******************************************************************************
!
      SUBROUTINE Display()
!
!  Draws display, using details set in SetupDisplay()
!
      USE OPENGL
!
      CALL glClear(ior(GL_COLOR_BUFFER_BIT,GL_DEPTH_BUFFER_BIT))
      CALL glCallList(1)
      CALL glFlush()
      RETURN
      END SUBROUTINE Display
!
      END PROGRAM MOLEHILL