fortran66のブログ

fortran について書きます。

OpenGLによる3次元CGプログラミング
作者: 林武文, 加藤清敬
出版社/メーカー: コロナ社

MODULE m_callback
USE opengl_gl
USE opengl_glu
USE opengl_glut
IMPLICIT NONE
INTEGER(GLCINT), PARAMETER :: KEY_ESC = 27
LOGICAL :: wireFlag = GL_TRUE
REAL(glfloat) :: theta = 0.0_glfloat
REAL(glfloat) :: xOrig = 0.0_glfloat, yOrig = 0.0_glfloat
REAL(glfloat) :: rColor = 1.0_glfloat, gColor = 1.0_glfloat, bColor = 1.0_glfloat
CONTAINS
!---------------------------
SUBROUTINE display()
IMPLICIT NONE
CALL glClear( GL_COLOR_BUFFER_BIT )
CALL glPushMatrix()
CALL glTranslatef( xOrig, yOrig, -10.0_glfloat )
CALL glRotatef( theta, 0.0_glfloat, 1.0_glfloat, 0.0_glfloat )
CALL glColor3f( rColor, gColor, bColor )
IF (wireFlag == GL_TRUE) THEN
 CALL glutWireTeapot( 1.0_gldouble )
ELSE
 CALL glutSolidTeapot( 1.0_gldouble )
END IF
CALL glPopMatrix()
CALL glutSwapBuffers()
RETURN
END SUBROUTINE display
!---------------------------
SUBROUTINE changeColor()
IMPLICIT NONE
CALL RANDOM_NUMBER(rColor)
CALL RANDOM_NUMBER(gColor)
CALL RANDOM_NUMBER(bColor)
RETURN
END SUBROUTINE changeColor
!---------------------------
SUBROUTINE myKbd(key, ix, iy)
IMPLICIT NONE
INTEGER(GLCINT), INTENT(IN OUT) :: key, ix, iy
SELECT CASE(key)
 CASE (ICHAR('w'))
 wireFlag = .NOT. wireFlag
 CASE (ICHAR('c'))
 CALL changeColor()
 CASE (ICHAR('R'))
 wireFlag = GL_TRUE
 theta = 0.0_glfloat
 xOrig = 0.0_glfloat
 yOrig = 0.0_glfloat
 rColor = 1.0_glfloat
 gColor = 1.0_glfloat
 bColor = 1.0_glfloat
 CASE (KEY_ESC)
 STOP
 CASE DEFAULT
 CONTINUE
END SELECT
CALL glutPostRedisplay()
RETURN
END SUBROUTINE myKbd
!---------------------------
SUBROUTINE mySkey(key, ix, iy)
IMPLICIT NONE
INTEGER, INTENT(IN OUT) :: key, ix, iy
SELECT CASE(key)
 CASE (GLUT_KEY_LEFT ) ! left arrow
  xOrig = xOrig - 0.2_glfloat
  IF (xOrig <= -2.0_glfloat) xOrig = -2.0_glfloat
 CASE (GLUT_KEY_RIGHT) ! right arrow
  xOrig = xOrig + 0.2_glfloat
  IF (xOrig >=  2.0_glfloat) xOrig =  2.0_glfloat
 CASE (GLUT_KEY_UP) ! up arrow
  yOrig = yOrig + 0.2_glfloat
  IF (yOrig >=  2.0_glfloat) yOrig =  2.0_glfloat
 CASE (GLUT_KEY_DOWN) ! up down
  yOrig = yOrig - 0.2_glfloat
  IF (yOrig <= -2.0_glfloat) yOrig = -2.0_glfloat
 CASE (GLUT_KEY_F1)
  theta = AMOD(theta + 10.0_glfloat, 360.0_glfloat)
 CASE (GLUT_KEY_F2)
  theta = AMOD(theta - 10.0_glfloat, 360.0_glfloat)
 CASE DEFAULT
END SELECT
CALL glutPostRedisplay()
RETURN
END SUBROUTINE mySkey
!---------------------------
END MODULE m_callback
!=========================================================
MODULE m_subs
USE m_callback
IMPLICIT NONE
CONTAINS
!---------------------------
SUBROUTINE myInit(progname)
IMPLICIT NONE
CHARACTER(LEN = *), INTENT(IN) :: progname
INTEGER(GLCINT) :: iwidth = 600, iheight = 600
INTEGER(GLCINT) :: iwin
REAL(GLDOUBLE) :: aspect
aspect = REAL(iwidth, glfloat) / REAL(iheight, glfloat)
CALL glutInitWindowPosition( 0_glfloat, 0_glfloat )
CALL glutInitWindowSize( iwidth, iheight )
CALL glutInitDisplayMode( IOR(GLUT_RGBA, 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 glMatrixMode( GL_PROJECTION )
CALL glLoadIdentity()
CALL gluPerspective( 30.0_gldouble, aspect, 1.0_gldouble, 20.0_gldouble )
CALL glMatrixMode( GL_MODELVIEW )
RETURN
END SUBROUTINE myInit
!---------------------------
END MODULE m_subs
!=========================================================
PROGRAM GLUT5
USE m_subs
IMPLICIT NONE
CALL glutInit()
CALL myInit("GLUT5")
CALL glutDisplayFunc( display )
CALL glutMainLoop()
STOP
END PROGRAM GLUT5