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
INTEGER(glcint) :: ixBegin, iyBegin, mButton
REAL(glfloat) :: distance, twist, elevation, azimuth
CONTAINS
!---------------------------------------------------------
SUBROUTINE display()
IMPLICIT NONE
CALL glClear( IOR(GL_COLOR_BUFFER_BIT, GL_DEPTH_BUFFER_BIT) )
CALL glPushMatrix()
CALL polarview(distance, twist, elevation, azimuth)
CALL glEnable( GL_DEPTH_TEST )
CALL glEnable( GL_LIGHTING   )

CALL glBegin( GL_POLYGON )
CALL glNormal3f( 0.0_glfloat, 1.0_glfloat, 0.0_glfloat )
 CALL glVertex3f(  1.0_glfloat, 0.0_glfloat,  1.0_glfloat )
 CALL glVertex3f(  1.0_glfloat, 0.0_glfloat, -1.0_glfloat )
 CALL glVertex3f( -1.0_glfloat, 0.0_glfloat, -1.0_glfloat )
 CALL glVertex3f( -1.0_glfloat, 0.0_glfloat,  1.0_glfloat )
CALL glEnd()

CALL glDisable( GL_LIGHTING )
CALL drawNormal( 0.0_glfloat, 0.0_glfloat, 0.0_glfloat,  &
                0.0_glfloat, 1.0_glfloat, 0.0_glfloat )
CALL glPopMatrix()
CALL glDisable( GL_DEPTH_TEST )
CALL glutSwapBuffers()
RETURN
END SUBROUTINE display
!---------------------------------------------------------
SUBROUTINE drawNormal(x0, y0, z0, x1, y1, z1)
IMPLICIT NONE
REAL(glfloat), INTENT(IN) :: x0, y0, z0, x1, y1, z1
CALL glColor3f( 1.0_glfloat, 0.0_glfloat, 0.0_glfloat )
CALL glLineWidth( 2.0_glfloat )
CALL glPushMatrix()
CALL glTranslatef( x0, y0, z0 )
CALL glBegin( GL_LINES )
 CALL glVertex3f( 0.0_glfloat, 0.0_glfloat, 0.0_glfloat )
 CALL glVertex3f( x1, y1, z1 )
CALL glEnd()
CALL glPopMatrix()
RETURN
END SUBROUTINE drawNormal
!---------------------------------------------------------
SUBROUTINE myKbd(key, ix, iy)
IMPLICIT NONE
INTEGER(GLCINT), INTENT(IN OUT) :: key, ix, iy
SELECT CASE(key)
 CASE (ICHAR('R'))
 CALL resetview()
 CALL glutPostRedisplay()
 CASE (KEY_ESC)
 STOP
 CASE DEFAULT
 CONTINUE
END SELECT
CALL glutPostRedisplay()
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   + REAL(ixDisp, glfloat) / 5.0_glfloat
 elevation = elevation - REAL(iyDisp, glfloat) / 5.0_glfloat
 CASE (GLUT_MIDDLE_BUTTON)
 twist    = AMOD(twist + REAL(ixDisp, glfloat) / 3.0_glfloat, 360.0_glfloat)
 CASE (GLUT_RIGHT_BUTTON)
 distance = distance - REAL(ixDisp + iyDisp, glfloat) / 60.0_glfloat
END SELECT
ixBegin = ix
iyBegin = iy
CALL glutPostRedisplay()
RETURN
END SUBROUTINE myMotion
!---------------------------------------------------------
SUBROUTINE polarview(distance, twist, elevation, azimuth)
IMPLICIT NONE
REAL(glfloat), INTENT(IN) :: distance, twist, elevation, azimuth
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  =   6.0_glfloat
twist     =   0.0_glfloat
elevation = -45.0_glfloat
azimuth   =  30.0_glfloat
RETURN
END SUBROUTINE resetview
!---------------------------------------------------------
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(IOR(GLUT_RGBA, GLUT_DOUBLE), GLUT_DEPTH) )
iwin = glutCreateWindow( progname )
CALL glClearColor( 0.0_glfloat, 0.0_glfloat, 0.0_glfloat, 1.0_glfloat )
CALL glutKeyboardFunc( myKbd )
CALL glutMouseFunc( myMouse )
CALL glutMotionFunc( myMotion )
CALL resetView()
CALL glShadeModel( GL_FLAT )
CALL glEnable( GL_LIGHT0 )
RETURN
END SUBROUTINE myInit
!---------------------------------------------------------
SUBROUTINE myReshape(iwidth, iheight)
IMPLICIT NONE
INTEGER(GLCINT), INTENT(IN) :: 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( 40.0_gldouble, aspect, 1.0_gldouble, 10.0_gldouble )
CALL glMatrixMode( GL_MODELVIEW )
RETURN
END SUBROUTINE myReshape
!---------------------------------------------------------
END MODULE m_subs
!=========================================================
PROGRAM GLUT6
USE m_subs
IMPLICIT NONE
CALL glutInit()
CALL myInit( 'GLUT6' )
CALL glutReshapeFunc( myReshape )
CALL glutDisplayFunc( display )
CALL glutMainLoop()
STOP
END PROGRAM GLUT6