■

• ネタ元

http://www.dolfyn.net/dolfyn/f03gl_en.html

いわゆる Green Book からのサンプルのつづき。
元プログラムからの修正点は、RESHAPE ルーチンの引数の value 属性を消したこと。C Binding の削除。

program fgl06

  use opengl_gl
  use opengl_glu
  use opengl_glut
    
  interface 
    subroutine polyhedra()
    end subroutine polyhedra

    subroutine reshape(w,h)
      use opengl_gl
      integer(glcint), intent(in) :: w,h
    end subroutine reshape
  end interface 

  integer(kind=GLint)  :: winWidth = 300, winHeight = 300
  integer(kind=GLint) :: iwin

  real(kind=GLdouble) :: x0 = 100.0, y0 = 50.0, z0 = 50.0 ! viewing coor. origin
  real(kind=GLdouble) :: xr =  50.0, yr = 50.0, zr =  0.0 ! look at this point
  real(kind=GLdouble) :: Vx =   0.0, Vy =  1.0, Vz =  0.0 ! view-up vector
  real(kind=GLdouble) :: xwmin = -40.0, ywmin = -60.0, &
                         xwmax =  40.0, ywmax =  60.0, &
                         dnear =  25.0, dfar  = 125.0
    
  call glutInit
  call glutInitDisplayMode(GLUT_SINGLE + GLUT_RGB )
  call glutInitWindowPosition( 100, 100)
  call glutInitWindowSize( winWidth, winHeight )
  iwin = glutCreateWindow("fgl06 GLUT Polyhedra"//char(0))

  call glClearColor(1.0,1.0,1.0,0.0)
  
  call glutDisplayFunc( polyhedra )
  call glutReshapeFunc( reshape )

  call glutMainLoop()
  
end program
subroutine polyhedra

  use OpenGL_GL
  use OpenGL_GLU
  use OpenGL_GLUT

  call glClear(GL_COLOR_BUFFER_BIT)

  call glLoadIdentity()
  
  call glColor3f(0.0,0.0,1.0)

  call gluLookAt( 5.0_gldouble, 5.0_gldouble, 5.0_gldouble, &
                  0.0_gldouble, 0.0_gldouble, 0.0_gldouble, &
                  0.0_gldouble, 1.0_gldouble, 0.0_gldouble  )

  call glScalef( 1.5, 2.0, 1.0 )
  call glutWirecube( 1.0_gldouble ) 

  call glColor3f(0.0,1.0,1.0)

  call glScalef( 0.8, 0.5, 0.8 )
  call glTranslatef( -6.0, -5.0, 0.0 )
  call glutWireDodecahedron( ) 

  call glColor3f(1.0,0.0,1.0)

  call glTranslatef( 8.6, 8.6, 2.0 )
  call glScalef( 0.75, 0.75, 0.75 )
  call glutWireTetrahedron( ) 
  call glScalef( 1.333, 1.333, 1.333 )

  call glColor3f(1.0,0.0,0.0)

  call glTranslatef( -3.0, -1.0, 0.0 )
  call glutWireOctahedron( ) 

  call glColor3f(0.0,0.0,0.0)

  call glScalef( 0.8, 0.8, 1.0 )
  call glTranslatef( 4.3, -2.0, 0.5 )
  call glutWireIcosahedron( ) 
  
  call glFlush()

end subroutine polyhedra
subroutine reshape(newWidth, newHeight)

  use OpenGL_GL

  integer(kind=GLcint), intent(IN) :: newWidth, newHeight

  call glviewport(0,0,newWidth,newHeight)

  call glMatrixMode(GL_PROJECTION)
  
  call glLoadIdentity()

  call glFrustum( -1.0_gldouble,  1.0_gldouble, &
                  -1.0_gldouble,  1.0_gldouble, &
                   2.0_gldouble, 20.0_gldouble  )
  
  call glMatrixMode(GL_MODELVIEW)
  
  call glClear(GL_COLOR_BUFFER_BIT)
  
end subroutine reshape

DOS窓は略

• f03gl と f90gl での定義の違いの修正。

!  type(C_PTR) :: ptr = c_null_ptr 
  TYPE (GLUQuadricObj), POINTER :: ptr

　 ptr => gluNewQuadric() 

program fgl07

  use opengl_gl
  use opengl_glu
  use opengl_glut
    
  interface 
    subroutine quadrics()
    end subroutine quadrics

    subroutine reshape(w,h)
      use opengl_gl
      integer(glcint), intent(in) :: w,h
    end subroutine reshape
  end interface 

  integer(kind=GLint) :: winWidth = 300, winHeight = 300
  integer(kind=GLint) :: iwin
    
  call glutInit
  call glutInitDisplayMode(GLUT_SINGLE + GLUT_RGB )
  call glutInitWindowPosition( 100, 100)
  call glutInitWindowSize( winWidth, winHeight )
  iwin = glutCreateWindow("fgl07 Quadric Surfaces"//char(0))

  call glClearColor(1.0,1.0,1.0,0.0)
  
  call glutDisplayFunc( quadrics )
  call glutReshapeFunc( reshape )

  call glutMainLoop()
  
end program

subroutine quadrics
  USE, INTRINSIC :: ISO_C_BINDING
  use OpenGL_GL
  use OpenGL_GLU
  use OpenGL_GLUT

!  type(C_PTR) :: ptr = c_null_ptr 
  TYPE (GLUQuadricObj), POINTER :: ptr

  call glClear(GL_COLOR_BUFFER_BIT)
  
  call glLoadIdentity()

  call glColor3f(0.0,0.0,1.0)

  call gluLookAt( 2.0_gldouble, 2.0_gldouble, 2.0_gldouble, &
                  0.0_gldouble, 0.0_gldouble, 0.0_gldouble, &
                  0.0_gldouble, 0.0_gldouble, 1.0_gldouble  )

  call glPushMatrix()
  call glTranslatef( 1.0, 1.0, 0.0 )
  call glutWireSphere( 0.75_gldouble, 8, 6 ) 
  call glPopMatrix()

  call glPushMatrix()
  call glTranslatef( 1.0, -0.5, 0.5 )
  call glutWireCone( 0.7_gldouble, 2.0_gldouble, 7, 6 ) 
  call glPopMatrix()

  call glPushMatrix()
  call glTranslatef( 0.0, 1.2, 0.8 )

  ptr => gluNewQuadric()
  call gluQuadricDrawStyle(ptr, GLU_LINE)
  call gluCylinder(ptr,0.6_gldouble,0.6_gldouble,1.5_gldouble,6,4)

  call glPopMatrix()

  call glFlush()

end subroutine quadrics
subroutine reshape(newWidth, newHeight)

  use OpenGL_GL

  integer(kind=GLcint), intent(IN) :: newWidth, newHeight

  call glviewport(0,0,newWidth,newHeight)

  call glMatrixMode(GL_PROJECTION)
  
  call glLoadIdentity()

  call glOrtho( -2.0_gldouble,  2.0_gldouble, &
                -2.0_gldouble,  2.0_gldouble, &
                 0.0_gldouble,  5.0_gldouble  )
  
  call glMatrixMode(GL_MODELVIEW)
  
  call glClear(GL_COLOR_BUFFER_BIT)
  
end subroutine reshape