fortran66のブログ

fortran について書きます。

Fortranへの移植。


MODULE m_callback
USE opengl_gl
USE opengl_glu
USE opengl_glut
IMPLICIT NONE
REAL(GLdouble), PARAMETER :: pi = 3.141592653589793238_GLdouble
REAL(GLdouble), PARAMETER :: G = 9.80665_GLdouble
REAL(GLdouble), PARAMETER :: TICK = 1.0e-3_GLdouble
!
INTEGER(GLint), PARAMETER :: KEY_ESC = 27
REAL(GLfloat) :: xOrigin = 0.0_GLfloat, yOrigin = 0.0_GLfloat
INTEGER(GLint) :: ixStart = 0, iyStart = 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 /)
!
TYPE :: t_pendulum
 REAL(GLdouble) :: m_x, m_y, m_z
 REAL(GLdouble) :: m_dia
 REAL(GLdouble) :: m_length
 REAL(GLdouble) :: m_mass
 REAL(GLdouble) :: m_th
 REAL(GLdouble) :: m_dth 
END TYPE
TYPE (t_pendulum) :: pdlm0, pdlm1, pdlm2, pdlm3, pdlm4
LOGICAL :: push_flag = .FALSE.
!
CONTAINS
!---------------------------------------------------------
SUBROUTINE createPendulum( x, y, z, dia, dlength, dmass, p )
IMPLICIT NONE
REAL(GLdouble), INTENT(IN) :: x, y, z, dia, dlength, dmass
TYPE (t_pendulum), INTENT(OUT) :: p
p = t_pendulum(x, y, z, dia, dlength, dmass, &
               60.0_GLdouble / 180.0_GLdouble * pi, 0.0_GLdouble )
RETURN
END SUBROUTINE createPendulum
!---------------------------------------------------------
SUBROUTINE stepPendulum( p )
IMPLICIT NONE
TYPE (t_pendulum), INTENT(IN OUT) :: p
REAL(GLdouble) :: theta, omega
theta = p%m_th
omega = p%m_dth
p%m_th  = p%m_th  + omega * TICK
p%m_dth = p%m_dth + TICK * (-G / p%m_length) * SIN(theta) 
IF (push_flag) THEN
 p%m_dth = p%m_dth + TICK * ( (-G / p%m_length) * SIN(theta) - 0.1_GLfloat * omega - 50.0_GLfloat )
ELSE
 p%m_dth = p%m_dth + TICK * ( (-G / p%m_length) * SIN(theta) - 0.1_GLfloat * omega )
END IF
RETURN
END SUBROUTINE stepPendulum
!---------------------------------------------------------
SUBROUTINE drawPendulum( p )
IMPLICIT NONE
TYPE (t_pendulum), INTENT(IN) :: p
CALL glPushMatrix()
CALL glDisable( GL_LIGHTING )
CALL glColor3f( 1.0_glfloat, 0.0_glfloat, 0.0_glfloat )
CALL glBegin( GL_LINES )
 CALL glVertex3d( p%m_x, p%m_y, p%m_z )
 CALL glVertex3d( p%m_x + p%m_length * SIN(p%m_th), p%m_y - p%m_length * COS(p%m_th), p%m_z )
CALL glEnd()
CALL glEnable( GL_LIGHTING )
CALL glTranslated( p%m_x, p%m_y, p%m_z )
CALL glutSolidCube( 0.02_gldouble )
CALL glRotated( p%m_th * 180.0_gldouble / pi, 0.0_gldouble, 0.0_gldouble, 1.0_gldouble )
CALL glTranslated( 0.0_gldouble, - p%m_length, 0.0_gldouble )
CALL glutSolidSphere( p%m_dia, 10, 10 )
CALL glPopMatrix()
RETURN
END SUBROUTINE drawPendulum
!---------------------------------------------------------
SUBROUTINE createWorld()
IMPLICIT NONE
CALL createPendulum( 0.0_gldouble, 1.0_gldouble, 0.0_gldouble, 0.10_gldouble, 2.0_gldouble, 0.1_gldouble, pdlm0 )
CALL createPendulum( 0.0_gldouble, 1.0_gldouble, 0.2_gldouble, 0.10_gldouble, 1.0_gldouble, 0.1_gldouble, pdlm1 )
CALL createPendulum( 0.0_gldouble, 1.0_gldouble, 0.4_gldouble, 0.05_gldouble, 1.0_gldouble, 0.1_gldouble, pdlm2 )
CALL createPendulum( 0.0_gldouble, 1.0_gldouble, 0.6_gldouble, 0.05_gldouble, 0.4_gldouble, 0.1_gldouble, pdlm3 )
CALL createPendulum( 0.0_gldouble, 1.0_gldouble, 0.8_gldouble, 0.05_gldouble, 0.2_gldouble, 0.1_gldouble, pdlm4 )
RETURN
END SUBROUTINE createWorld
!---------------------------------------------------------
SUBROUTINE drawWorld()
IMPLICIT NONE
INTEGER :: i
REAL(glfloat) :: x, y, z
DO i = 1, 30
 CALL stepPendulum( pdlm0 )
 CALL stepPendulum( pdlm1 )
 CALL stepPendulum( pdlm2 )
 CALL stepPendulum( pdlm3 )
 CALL stepPendulum( pdlm4 )
 push_flag = .FALSE.
END DO
CALL drawPendulum( pdlm0 )
CALL drawPendulum( pdlm1 )
CALL drawPendulum( pdlm2 )
CALL drawPendulum( pdlm3 )
CALL drawPendulum( pdlm4 )
RETURN
END SUBROUTINE drawWorld
!---------------------------------------------------------
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 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 drawWorld()
!
CALL glPopMatrix()
CALL glDisable( GL_LIGHTING )
CALL glDisable( GL_DEPTH_TEST )
CALL glutSwapBuffers() 
RETURN
END SUBROUTINE display
!---------------------------------------------------------
SUBROUTINE myKbd(key, ix, iy)
IMPLICIT NONE
INTEGER(GLcint), INTENT(IN OUT) :: key, ix, iy
SELECT CASE(key)
 CASE (KEY_ESC) 
  STOP
 CASE (ICHAR('p'))
  push_flag = .TRUE.
 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
 ixStart = ix
 iyStart = iy
 mButton = ibutton
END IF
RETURN
END SUBROUTINE myMouse
!---------------------------------------------------------
SUBROUTINE myMotion( ix, iy )
IMPLICIT NONE
INTEGER(GLcint), INTENT(IN OUT) :: ix, iy
INTEGER(GLcint) :: ixOffset, iyOffset
ixOffset = ix - ixStart
iyOffset = iy - iyStart
SELECT CASE (mButton)
 CASE (GLUT_LEFT_BUTTON)
  azimuth   = azimuth   + ixOffset / 2.0_GLfloat
  elevation = elevation - iyOffset / 2.0_GLfloat
 CASE (GLUT_MIDDLE_BUTTON)
  twist = AMOD( twist + ixOffset, 360.0_GLfloat )
 CASE (GLUT_RIGHT_BUTTON)
  distance = distance - iyOffset / 40.0_GLfloat
 CASE DEFAULT
END SELECT 
ixStart = ix
iyStart = 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 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 )
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
!---------------------------------------------------------
RECURSIVE SUBROUTINE timer( ivalue )
IMPLICIT NONE
INTEGER(GLint), INTENT(IN) :: ivalue
IF (ivalue == 1) THEN
 CALL glutTimerFunc( 30, timer, 1 )
 CALL glutPostRedisplay()
END IF
RETURN
END SUBROUTINE timer
!---------------------------------------------------------
END MODULE m_callback
!=========================================================
PROGRAM GLUT10
USE m_callback
IMPLICIT NONE
CALL glutInit()
CALL myInit( 'GLUT10-4ex' )
CALL createWorld()
CALL glutReshapeFunc( myReshape )
CALL glutDisplayFunc( display )
CALL glutTimerFunc( 30, timer, 1 )
CALL glutMainLoop()
STOP
END PROGRAM GLUT10