■ - fortran66のブログ

Fortranへの移植。
MODULE m_callback
USE opengl_gl
USE opengl_glu
USE opengl_glut
IMPLICIT NONE
INTEGER(GLint), PARAMETER :: KEY_ESC = 27
INTEGER(GLint) :: ixBegin = 0, iyBegin = 0
INTEGER(GLint) :: mButton
REAL(GLfloat) :: distance, twist, elevation, azimuth
REAL(GLdouble) :: xnear = 1.0_gldouble, farw = 30.0_gldouble, fovy = 60.0_gldouble
REAL(glfloat) :: greenDiffuse(4)  = (/ 0.0_glfloat, 1.0_glfloat, 0.5_glfloat, 1.0_glfloat /)
REAL(glfloat) :: whiteSpecular(4) = (/ 1.0_glfloat, 1.0_glfloat, 1.0_glfloat, 1.0_glfloat /)
REAL(glfloat) :: whiteAmbient(4)  = (/ 0.1_glfloat, 0.1_glfloat, 0.1_glfloat, 1.0_glfloat /)
REAL(GLfloat) :: cpoint(4, 4, 4) = & 
[ [ [ 1.0_glfloat, -1.0_glfloat,  0.0_glfloat, 1.0_glfloat], &
    [ 0.5_glfloat, -1.0_glfloat,  0.0_glfloat, 1.0_glfloat], &
    [-0.5_glfloat, -1.0_glfloat,  0.0_glfloat, 1.0_glfloat], &
    [-1.0_glfloat, -1.0_glfloat,  0.0_glfloat, 1.0_glfloat]  &
  ],  &
  [ [ 1.0_glfloat, -0.5_glfloat,  1.0_glfloat, 1.0_glfloat], &
    [ 0.5_glfloat, -0.5_glfloat,  1.0_glfloat, 1.0_glfloat], &
    [-0.5_glfloat, -0.5_glfloat,  1.0_glfloat, 1.0_glfloat], &
    [-1.0_glfloat, -0.5_glfloat,  1.0_glfloat, 1.0_glfloat]  &
  ],  &
  [ [ 1.0_glfloat,  0.5_glfloat, -1.0_glfloat, 1.0_glfloat], &
    [ 0.5_glfloat,  0.5_glfloat, -1.0_glfloat, 1.0_glfloat], &
    [-0.5_glfloat,  0.5_glfloat, -1.0_glfloat, 1.0_glfloat], &
    [-1.0_glfloat,  0.5_glfloat, -1.0_glfloat, 1.0_glfloat]  &
  ],  &
  [ [ 1.0_glfloat,  1.0_glfloat,  0.0_glfloat, 1.0_glfloat], &
    [ 0.5_glfloat,  1.0_glfloat,  0.0_glfloat, 1.0_glfloat], &
    [-0.5_glfloat,  1.0_glfloat,  0.0_glfloat, 1.0_glfloat], &
    [-1.0_glfloat,  1.0_glfloat,  0.0_glfloat, 1.0_glfloat]  &
  ] ]  
!
REAL(GLfloat) :: knotvec_u(8) = [ 0.0_glfloat, 0.0_glfloat, 0.0_glfloat, 0.0_glfloat, & 
                                  1.0_glfloat, 1.0_glfloat, 1.0_glfloat, 1.0_glfloat  ]
REAL(GLfloat) :: knotvec_v(8) = [ 0.0_glfloat, 0.0_glfloat, 0.0_glfloat, 0.0_glfloat, & 
                                  1.0_glfloat, 1.0_glfloat, 1.0_glfloat, 1.0_glfloat  ]
TYPE (GLUnurbsObj), POINTER :: nrb_obj
INTEGER (GLint) :: icp = 1, jcp = 1, icpNo = 0
CONTAINS
!---------------------------------------------------------
SUBROUTINE create_nurbs()
IMPLICIT NONE
nrb_obj => gluNewNurbsRenderer()
CALL gluNurbsProperty( nrb_obj, GLU_SAMPLING_TOLERANCE, 25.0_glfloat )
CALL gluNurbsProperty( nrb_obj, GLU_DISPLAY_MODE      , REAL(GLU_FILL, GLfloat) )
!CALL gluNurbsProperty( nrb_obj, GLU_DISPLAY_MODE      , REAL(GLU_OUTLINE_POLYGON,  GLfloat) )
RETURN
END SUBROUTINE create_nurbs
!---------------------------------------------------------
SUBROUTINE drawCP()
IMPLICIT NONE
INTEGER :: i, j
REAL(glfloat) :: x, y, z
CALL glColor3f( 1.0_glfloat, 1.0_glfloat, 0.0_glfloat )
CALL glPointSize( 5.0_glfloat )
CALL glBegin( GL_POINTS )
DO i = 1, 4
 DO j = 1, 4
  x = cpoint(1, j, i) / cpoint(4, j, i)
  y = cpoint(2, j, i) / cpoint(4, j, i)
  z = cpoint(3, j, i) / cpoint(4, j, i)
  CALL glVertex3f( x, y, z )
 END DO
END DO
CALL glEnd()
!
CALL glColor3f( 1.0_glfloat, 0.5_glfloat, 0.5_glfloat )
CALL glPointSize( 10.0_glfloat )
CALL glBegin( GL_POINTS )
 x = cpoint(1, jcp, icp) / cpoint(4, jcp, icp)
 y = cpoint(2, jcp, icp) / cpoint(4, jcp, icp)
 z = cpoint(3, jcp, icp) / cpoint(4, jcp, icp)
 CALL glVertex3f( x, y, z )
CALL glEnd()
!
CALL glDisable( GL_DEPTH_TEST )
CALL glColor3f( 1.0_glfloat, 1.0_glfloat, 1.0_glfloat )
CALL glPointSize( 3.0_glfloat )
CALL glBegin( GL_POINTS )
 x = cpoint(1, jcp, icp) / cpoint(4, jcp, icp)
 y = cpoint(2, jcp, icp) / cpoint(4, jcp, icp)
 z = cpoint(3, jcp, icp) / cpoint(4, jcp, icp)
 CALL glVertex3f( x, y, z )
CALL glEnd()
CALL glEnable( GL_DEPTH_TEST )
RETURN
END SUBROUTINE drawCP
!---------------------------------------------------------
SUBROUTINE display()
IMPLICIT NONE
CALL glClear( IOR(GL_COLOR_BUFFER_BIT, GL_DEPTH_BUFFER_BIT) )
CALL glPushMatrix()
CALL polarview( )
CALL glEnable( GL_DEPTH_TEST )
CALL glEnable( GL_LIGHTING   )
!
CALL glLightModeli( GL_LIGHT_MODEL_TWO_SIDE, 1 ) ! 1 <- GL_TRUE
CALL glMaterialfv( GL_FRONT_AND_BACK, GL_DIFFUSE , greenDiffuse  )
CALL glMaterialfv( GL_FRONT_AND_BACK, GL_SPECULAR, whiteSpecular )
CALL glMaterialfv( GL_FRONT_AND_BACK, GL_AMBIENT , whiteAmbient  )
CALL glMaterialf ( GL_FRONT_AND_BACK, GL_SHININESS, 128.0_glfloat )
!
CALL glEnable( GL_NORMALIZE )
CALL glEnable( GL_AUTO_NORMAL )
CALL glPushMatrix()
!
CALL gluBeginSurface( nrb_obj )
CALL gluNurbsSurface( nrb_obj, 8, knotvec_u, 8, knotvec_v, & 
                      4 * 4, 4, cpoint(:, 1, 1), 4, 4, GL_MAP2_VERTEX_4 )
CALL gluEndSurface( nrb_obj )
!
CALL glPopMatrix()
CALL glDisable( GL_LIGHTING )
CALL drawCP()
CALL glDisable( GL_DEPTH_TEST )
CALL glPopMatrix()
CALL glutSwapBuffers() 
RETURN
END SUBROUTINE display
!---------------------------------------------------------
SUBROUTINE mySkey(key, ix, iy)
IMPLICIT NONE
INTEGER(GLcint), INTENT(IN OUT) :: key, ix, iy
SELECT CASE(key)
 CASE (GLUT_KEY_RIGHT)
  distance = distance + 0.1_glfloat
 CASE (GLUT_KEY_LEFT)
  distance = distance - 0.1_glfloat
 CASE (GLUT_KEY_UP)
 CASE (GLUT_KEY_DOWN)
 CASE DEFAULT
END SELECT
CALL glutPostRedisplay()
RETURN
END SUBROUTINE mySkey
!---------------------------------------------------------
SUBROUTINE myKbd(key, ix, iy)
IMPLICIT NONE
INTEGER(GLcint), INTENT(IN OUT) :: key, ix, iy
SELECT CASE(key)
 CASE (KEY_ESC) 
  STOP
 CASE (ICHAR('x'))
  icpNo = icpNo + 1
  IF (icpNo >= 16) icpNo = 0
  icp = icpNo / 4 
  jcp = icpNo - 4 * icp
  icp = icp + 1
  jcp = jcp + 1
  CALL glutPostRedisplay()
 CASE (ICHAR('z'))
  icpNo = icpNo - 1
  IF (icpNo < 0 ) icpNo = 15
  icp = icpNo / 4
  jcp = icpNo - 4 * icp
  icp = icp + 1
  jcp = jcp + 1
  CALL glutPostRedisplay()
 CASE DEFAULT
END SELECT
RETURN
END SUBROUTINE myKbd
!---------------------------------------------------------
SUBROUTINE myMouse( ibutton, istate, ix, iy )
IMPLICIT NONE
INTEGER(GLcint), INTENT(IN OUT) :: ibutton, istate, ix, iy 
IF (istate == GLUT_DOWN) THEN
 ixBegin = ix
 iyBegin = iy
 mButton = ibutton
END IF
RETURN
END SUBROUTINE myMouse
!---------------------------------------------------------
SUBROUTINE myMotion( ix, iy )
IMPLICIT NONE
INTEGER(GLcint), INTENT(IN OUT) :: ix, iy
INTEGER(GLcint) :: ixDisp, iyDisp
ixDisp = ix - ixBegin
iyDisp = iy - iyBegin
SELECT CASE (mButton)
 CASE (GLUT_LEFT_BUTTON)
  azimuth   = azimuth   + ixDisp / 2.0_GLfloat
  elevation = elevation - iyDisp / 2.0_GLfloat
 CASE (GLUT_MIDDLE_BUTTON)
  cpoint(1, jcp, icp) = cpoint(1, jcp, icp) + ixDisp / 180.0_GLfloat
  cpoint(2, jcp, icp) = cpoint(2, jcp, icp) - iyDisp / 180.0_GLfloat
 CASE (GLUT_RIGHT_BUTTON)
  cpoint(3, jcp, icp) = cpoint(3, jcp, icp) + ixDisp / 180.0_GLfloat
!  distance = distance - iyDisp / 40.0_GLfloat
 CASE DEFAULT
END SELECT 
ixBegin = ix
iyBegin = iy
CALL glutPostRedisplay()
RETURN
END SUBROUTINE myMotion
!---------------------------------------------------------
SUBROUTINE myInit(progname)
IMPLICIT NONE
CHARACTER(LEN = *), INTENT(IN) :: progname
INTEGER(GLcint) :: iwidth = 400, iheight = 400
INTEGER(GLcint) :: iwin
CALL glutInitWindowPosition( 0_glfloat, 0_glfloat )
CALL glutInitWindowSize( iwidth, iheight )
CALL glutInitDisplayMode( IOR(IOR(GLUT_RGBA, GLUT_DEPTH), GLUT_DOUBLE) )
iwin = glutCreateWindow( progname )
CALL glClearColor( 0.0_glfloat, 0.0_glfloat, 0.0_glfloat, 1.0_glfloat )
CALL glutKeyboardFunc( myKbd )
CALL glutSpecialFunc( mySkey )
CALL glutMouseFunc( myMouse )
CALL glutMotionFunc( myMotion )
CALL resetview()
CALL glShadeModel( GL_SMOOTH )
CALL glEnable( GL_LIGHT0 )
RETURN
END SUBROUTINE myInit
!---------------------------------------------------------
SUBROUTINE myReshape(iwidth, iheight)
IMPLICIT NONE
INTEGER(glcint), INTENT(IN OUT) :: iwidth, iheight
REAL(GLDOUBLE) :: aspect 
aspect = REAL(iwidth, glfloat) / REAL(iheight, glfloat)
CALL glViewport( 0, 0, iwidth, iheight )
CALL glMatrixMode( GL_PROJECTION )
CALL glLoadIdentity()
CALL gluPerspective( fovy, aspect, xnear, farw )
CALL glMatrixMode( GL_MODELVIEW )
CALL glEnable( GL_MODELVIEW )
RETURN
END SUBROUTINE myReshape
!---------------------------------------------------------
SUBROUTINE polarview()
IMPLICIT NONE
CALL glTranslatef( 0.0_glfloat, 0.0_glfloat, -distance )
CALL glRotatef(-twist    , 0.0_glfloat, 0.0_glfloat, 1.0_glfloat )
CALL glRotatef(-elevation, 1.0_glfloat, 0.0_glfloat, 0.0_glfloat )
CALL glRotatef(-azimuth  , 0.0_glfloat, 1.0_glfloat, 0.0_glfloat )
RETURN
END SUBROUTINE polarview
!---------------------------------------------------------
SUBROUTINE resetview()
IMPLICIT NONE
distance  =   3.0_glfloat
twist     =   0.0_glfloat
elevation = -45.0_glfloat
azimuth   =  30.0_glfloat
RETURN
END SUBROUTINE resetview
!---------------------------------------------------------
SUBROUTINE printHelp()
IMPLICIT NONE
PRINT *
PRINT *, "*            z, x  key         ...   CP selection                 *"
PRINT *, "*     Middle Mouse Button Drag ... x, y position of CP change     *"
PRINT *, "*     Right Mouse Button Drag  ... z    position of CP change     *"
PRINT *, "*     <-  key   ...  zoom in                                      *"
PRINT *, "*     ->  key   ...  zoom out                                     *"
RETURN
END SUBROUTINE printHelp
!---------------------------------------------------------
END MODULE m_callback
!=========================================================
PROGRAM GLUT9
USE m_callback
IMPLICIT NONE
CALL glutInit()
CALL printHelp()
CALL myInit( 'GLUT9-2ex' )
CALL create_nurbs()
CALL glutReshapeFunc( myReshape )
CALL glutDisplayFunc( display )
CALL glutMainLoop()
STOP
END PROGRAM GLUT9