fortran66のブログ

fortran について書きます。

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

ロケット形状の定義ファイル。
MyShape.f90

MODULE m_myShape
USE opengl_gl
USE opengl_glu
IMPLICIT NONE
REAL(gldouble) :: pi2 = 2.0_gldouble * 3.14159265358979_gldouble ! 4.0d0 * ATAN(1.0d0)
CONTAINS
!----------------------------
SUBROUTINE myCircle(r, n)
IMPLICIT NONE
REAL(glfloat), INTENT(IN) :: r
INTEGER, INTENT(IN) :: n
REAL(glfloat) :: x, y, z, dq
INTEGER :: i
dq = pi2 / REAL(n, glfloat)
CALL glPushMatrix()
y = 0.0_glfloat
CALL glBegin( GL_LINE_LOOP )
 DO i = 0, n - 1
 x = r * COS( dq * i )
 z = r * SIN( dq * i )
 CALL glVertex3f(x, y, z )
 END DO
CALL glEnd()
CALL glPopMatrix()
RETURN
END SUBROUTINE myCircle
!----------------------------
SUBROUTINE myDisc( r, n )
IMPLICIT NONE
REAL(glfloat), INTENT(IN) :: r
INTEGER, INTENT(IN) :: n
REAL(glfloat) :: x, y, z, dq
INTEGER :: i
CALL glEnable( GL_NORMALIZE )
dq = pi2 / REAL(n, glfloat)
CALL glPushMatrix()
y = 0.0_glfloat
CALL glBegin( GL_POLYGON )
CALL glNormal3f( 0.0_glfloat, 1.0_glfloat, 0.0_glfloat )
 DO i = 0, n - 1
 x = r * COS( dq * i )
 z = r * SIN( dq * i )
 CALL glVertex3f(x, y, z )
 END DO
CALL glEnd()
CALL glPopMatrix()
CALL glDisable( GL_NORMALIZE )
RETURN
END SUBROUTINE myDisc
!----------------------------
SUBROUTINE mySolidCylinder( r, h, n )
IMPLICIT NONE
REAL(glfloat), INTENT(IN) :: r, h
INTEGER, INTENT(IN) :: n
REAL(glfloat) :: x, y, z, dq
INTEGER :: i
CALL glEnable( GL_NORMALIZE )
dq = pi2 / REAL(n, glfloat)
y = 0.5_glfloat * h
CALL glPushMatrix()
CALL glRotatef( -dq * 180.0_glfloat / REAL(pi2, glfloat), 0.0_glfloat, 1.0_glfloat, 0.0_glfloat )
CALL glBegin( GL_QUAD_STRIP )
 DO i = 0, n - 1
 x = r * COS( dq * i )
 z = r * SIN( dq * i )
 CALL glNormal3f( x, 0.0_glfloat, z)
 CALL glVertex3f( x,  y, z )
 CALL glVertex3f( x, -y, z )
 END DO
CALL glEnd()
CALL glBegin( GL_POLYGON )
 CALL glNormal3f( 0.0_glfloat, -1.0_glfloat, 0.0_glfloat )
 DO i = 0, n - 1
 x = r * COS( dq * i )
 z = r * SIN( dq * i )
 CALL glVertex3f( x, -y, z )
 END DO
CALL glEnd()
CALL glBegin( GL_POLYGON )
 CALL glNormal3f( 0.0_glfloat, 1.0_glfloat, 0.0_glfloat )
 DO i = 0, n - 1
 x = r * COS( dq * i )
 z = r * SIN( dq * i )
 CALL glVertex3f( x, y, z )
 END DO
CALL glEnd()
CALL glPopMatrix()
CALL glDisable( GL_NORMALIZE )
RETURN
END SUBROUTINE mySolidCylinder
!----------------------------
SUBROUTINE myWireCylinder( r, h, n )
IMPLICIT NONE
REAL(glfloat), INTENT(IN) :: r, h
INTEGER, INTENT(IN) :: n
REAL(glfloat) :: x, y, z, dq
INTEGER :: i
CALL glEnable( GL_NORMALIZE )
dq = pi2 / REAL(n, glfloat)
y = 0.5_glfloat * h
CALL glPushMatrix()
CALL glRotatef( -dq * 180.0_glfloat / REAL(pi2, glfloat), 0.0_glfloat, 1.0_glfloat, 0.0_glfloat )
CALL glBegin( GL_LINES )
 DO i = 0, n - 1
 x = r * COS( dq * i )
 z = r * SIN( dq * i )
 CALL glVertex3f( x,  y, z )
 CALL glVertex3f( x, -y, z )
 END DO
CALL glEnd()
CALL glBegin( GL_LINE_LOOP )
 DO i = 0, n - 1
 x = r * COS( dq * i )
 z = r * SIN( dq * i )
 CALL glVertex3f( x, y, z )
 END DO
CALL glEnd()
CALL glBegin( GL_LINE_LOOP )
 DO i = 0, n - 1
 x = r * COS( dq * i )
 z = r * SIN( dq * i )
 CALL glVertex3f( x, -y, z )
 END DO
CALL glEnd()
CALL glPopMatrix()
RETURN
END SUBROUTINE myWireCylinder
!----------------------------
END MODULE m_myShape
MODULE m_callback
USE opengl_glut
USE m_myShape
IMPLICIT NONE
INTEGER(GLCINT), PARAMETER :: KEY_ESC = 27
CONTAINS
!---------------------------
SUBROUTINE display()
IMPLICIT NONE
CALL glClear( IOR(GL_COLOR_BUFFER_BIT, GL_DEPTH_BUFFER_BIT) )
CALL glPushMatrix()
CALL glTranslatef( 0.0_glfloat, 0.0_glfloat, -20.0_glfloat )

CALL glPushMatrix()

CALL glTranslatef( 0.0_glfloat, 1.0_glfloat,   0.0_glfloat )
CALL myWireCylinder( 1.0_glfloat, 2.0_glfloat, 12 )
CALL glTranslatef( 0.0_glfloat, 1.0_glfloat,   0.0_glfloat )
CALL glRotatef( -90.0_glfloat, 1.0_glfloat, 0.0_glfloat, 0.0_glfloat )
CALL glutWireCone( 1.0_gldouble, 2.0_gldouble, 12, 3 )

CALL glPopMatrix()
CALL glTranslatef( 0.0_glfloat, -1.0_glfloat,   0.0_glfloat )
CALL myWireCylinder( 1.0_glfloat, 2.0_glfloat, 12 )

CALL glPopMatrix()
CALL glFlush()
RETURN
END SUBROUTINE display
!---------------------------
SUBROUTINE myKbd(key, ix, iy)
IMPLICIT NONE
INTEGER(GLCINT), INTENT(IN OUT) :: key, ix, iy
IF (key == KEY_ESC) STOP
RETURN
END SUBROUTINE myKbd
!---------------------------
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 = 300, 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( GLUT_RGBA )
iwin = glutCreateWindow( progname )
CALL glClearColor( 0.0_glfloat, 0.0_glfloat, 0.0_glfloat, 1.0_glfloat )
CALL glutKeyboardFunc( myKbd )
!
CALL glMatrixMode( GL_PROJECTION )
CALL glLoadIdentity()
CALL gluPerspective( 30.0_gldouble, aspect, 1.0_gldouble, 50.0_gldouble )
CALL glMatrixMode( GL_MODELVIEW )
RETURN
END SUBROUTINE myInit
!---------------------------
END MODULE m_subs
!=========================================================
PROGRAM GLUT3
USE m_subs
IMPLICIT NONE
CALL glutInit()
CALL myInit("GLUT3")
CALL glutDisplayFunc( display )
CALL glutMainLoop()
STOP
END PROGRAM GLUT3