Hello,
I am attaching an open-source use-as-you-please example of using the C
Interop features of Fortran 2003 in order to directly call OpenGL from
Fortran. There is not a single wrapper and the only C code used is the
trivial attached code OpenGL_c.c used to extract the values of
constants from the OpenGL header files. These are then pasted as
PARAMETER in the Fortran module.
I did not try to provide a full interface to OpenGL. I am hoping some
Perl (or similar language) expert will come up with scripts to
automatically generate the interfaces to save me from typing. Also for
extracting constants from header files and maybe even type definitions.
I don't think it can be fully automated, but most of it can.
The example uses GLUT in order to manipulate windows. Two extra routines
not in classical GLUT, which I added to the freeglut and openglut
libraries [glutGet(Set)WindowData] are used however I provided
replacement stubs at the end of OpenGL.f90 for those using classical
GLUT. On my Linux box it compiles with:
f95 OpenGL.f90 -o OpenGL.x -lglut -lGLU -lGL -L/usr/X11R6/lib -lXmu -lXi
-lX11
and works fine. It is nothing fancy, just a silly sphere whose radius
changes "randomly" in a Markov-chain fashion. But it works!
Best,
Aleksandar
MODULE OpenGL_Binding
USE ISO_C_BINDING
IMPLICIT NONE
PUBLIC
! Kind parameters
! Integer types:
INTEGER, PARAMETER :: GLbyte=C_SIGNED_CHAR, GLshort=C_SHORT, GLint=C_INT, GLsizei=C_INT, &
GLboolean=C_SIGNED_CHAR, GLenum=C_INT, GLbitfield=C_INT
! Real types:
INTEGER, PARAMETER :: GLdouble=C_DOUBLE, GLfloat=C_FLOAT
INTEGER, PARAMETER :: GL_COLOR_BUFFER_BIT=16384, GL_COMPILE=4864, GL_LIGHTING=2896, &
GL_DEPTH_TEST=2929, GL_PROJECTION=5889, GL_MODELVIEW=5888, GLUT_DOUBLE=2, GLUT_RGB=0, &
GL_DIFFUSE=4609, GL_LIGHT0=16384, GL_DEPTH_BUFFER_BIT=256, GLU_FILL=100012
INTERFACE
! void glClear (GLbitfield mask);
SUBROUTINE glClear(mask) BIND(C,NAME="glClear")
IMPORT
INTEGER(GLbitfield), VALUE :: mask
END SUBROUTINE
!void glEnable (GLenum cap);
SUBROUTINE glEnable(cap) BIND(C,NAME="glEnable")
IMPORT
INTEGER(GLenum), VALUE :: cap
END SUBROUTINE
! GLuint glGenLists (GLsizei range);
FUNCTION glGenLists(range) BIND(C,NAME="glGenLists")
IMPORT
INTEGER(GLsizei), VALUE :: range
INTEGER(GLint) :: glGenLists
END FUNCTION
! void glNewList (GLuint list, GLenum mode);
SUBROUTINE glNewList(list, mode) BIND(C,NAME="glNewList")
IMPORT
INTEGER(GLint), VALUE :: list
INTEGER(GLenum), VALUE :: mode
END SUBROUTINE
! void glCallList (GLuint list);
SUBROUTINE glCallList(list) BIND(C,NAME="glCallList")
IMPORT
INTEGER(GLint), VALUE :: list
END SUBROUTINE
! void glEndList(void);
SUBROUTINE glEndList() BIND(C,NAME="glEndList")
END SUBROUTINE
! void glPushMatrix(void);
SUBROUTINE glPushMatrix() BIND(C,NAME="glPushMatrix")
END SUBROUTINE
! void glPopMatrix(void);
SUBROUTINE glPopMatrix() BIND(C,NAME="glPopMatrix")
END SUBROUTINE
! void glScale{fd} (TYPE x, TYPE y, TYPE z);
SUBROUTINE glScalef(x, y, z) BIND(C,NAME="glScalef")
IMPORT
REAL(GLfloat), VALUE :: x, y, z
END SUBROUTINE
! void glTranslate{fd} (TYPE x, TYPE y, TYPE z);
SUBROUTINE glTranslatef(x, y, z) BIND(C,NAME="glTranslatef")
IMPORT
REAL(GLfloat), VALUE :: x, y, z
END SUBROUTINE
! void glColor3{bsifd ubusui} (TYPE red, TYPE green, TYPE blue);
SUBROUTINE glColor3f(red, gree, blue) BIND(C,NAME="glColor3f")
IMPORT
REAL(GLfloat), VALUE :: red, gree, blue
END SUBROUTINE
! void glLight{if}{v} (GLenum light, GLenum pname, TYPE param);
SUBROUTINE glLightfv(light, pname, param) BIND(C,NAME="glLightfv")
IMPORT
INTEGER(GLenum), VALUE :: light, pname
REAL(GLfloat), DIMENSION(*), INTENT(IN) :: param
END SUBROUTINE
! void glViewport (GLint x, GLint y, GLsizei width, GLsizei height);
SUBROUTINE glViewport(x, y, width, height) BIND(C,NAME="glViewport")
IMPORT
INTEGER(GLint), VALUE :: x, y
INTEGER(GLsizei), VALUE :: width, height
END SUBROUTINE
! void glMatrixMode (GLenum mode);
SUBROUTINE glMatrixMode(mode) BIND(C,NAME="glMatrixMode")
IMPORT
INTEGER(GLenum), VALUE :: mode
END SUBROUTINE
! void glLoadIdentity(void);
SUBROUTINE glLoadIdentity() BIND(C,NAME="glLoadIdentity")
END SUBROUTINE
! void glOrtho (GLdouble left, GLdouble right, GLdouble bottom, GLdouble top, GLdouble near, GLdouble far);
SUBROUTINE glOrtho(left, right, bottom, top, near, far) BIND(C,NAME="glOrtho")
IMPORT
REAL(GLdouble), VALUE :: left, right, bottom, top, near, far
END SUBROUTINE
! void gluPerspective (GLdouble fovy, GLdouble aspect, GLdouble zNear, GLdouble zFar);
SUBROUTINE gluPerspective(fovy, aspect, zNear, zFar) BIND(C,NAME="gluPerspective")
IMPORT
REAL(GLdouble), VALUE :: fovy, aspect, zNear, zFar
END SUBROUTINE
! void gluLookAt (GLdouble eyex, GLdouble eyey, GLdouble eyez, GLdouble centerx, \
! GLdouble centery, GLdouble centerz, GLdouble upx, GLdouble upy, GLdouble upz);
SUBROUTINE gluLookAt(eyex, eyey, eyez, centerx, centery, centerz, upx, upy, upz) BIND(C,NAME="gluLookAt")
IMPORT
REAL(GLdouble), VALUE :: eyex, eyey, eyez, centerx, centery, centerz, upx, upy, upz
END SUBROUTINE
! void glRect{sifd} (TYPE x1, TYPE y1, TYPE x2, TYPE y2);
SUBROUTINE glRectf(x1, y1, x2, y2) BIND(C,NAME="glRectf")
IMPORT
REAL(GLfloat), VALUE :: x1, y1, x2, y2
END SUBROUTINE
! GLUquadricObj* gluNewQuadric (void);
FUNCTION gluNewQuadric() BIND(C,NAME="gluNewQuadric")
IMPORT
TYPE(C_PTR) :: gluNewQuadric ! Opaque object pointer
END FUNCTION
! void gluDeleteQuadric (GLUquadricObj *qobj);
SUBROUTINE gluDeleteQuadric(qobj) BIND(C,NAME="gluDeleteQuadric")
IMPORT
TYPE(C_PTR), VALUE :: qobj
END SUBROUTINE
! void gluQuadricDrawStyle (GLUquadricObj *qobj, GLenum drawStyle);
SUBROUTINE gluQuadricDrawStyle(qobj, drawStyle) BIND(C,NAME="gluQuadricDrawStyle")
IMPORT
TYPE(C_PTR), VALUE :: qobj
INTEGER(GLenum), VALUE :: drawStyle
END SUBROUTINE
! void gluSphere (GLUquadricObj *qobj, GLdouble radius, GLint slices, GLint stacks);
SUBROUTINE gluSphere(qobj, radius, slices, stacks) BIND(C,NAME="gluSphere")
IMPORT
TYPE(C_PTR), VALUE :: qobj
REAL(GLdouble), VALUE :: radius
INTEGER(GLint), VALUE :: slices, stacks
END SUBROUTINE
! void glutSphere (GLdouble radius, GLint slices, GLint stacks);
SUBROUTINE glutSolidSphere(radius, slices, stacks) BIND(C,NAME="glutSolidSphere")
IMPORT
REAL(GLdouble), VALUE :: radius
INTEGER(GLint), VALUE :: slices, stacks
END SUBROUTINE
! void glutInit(int *argcp, char **argv);
SUBROUTINE glutInit(argcp,argv) BIND(C,NAME="glutInit")
IMPORT
INTEGER(C_INT), INTENT(INOUT) :: argcp
TYPE(C_PTR), VALUE :: argv
END SUBROUTINE
! void glutSwapBuffers(void);
SUBROUTINE glutSwapBuffers() BIND(C,NAME="glutSwapBuffers")
END SUBROUTINE
! void glutPostRedisplay(void);
SUBROUTINE glutPostRedisplay() BIND(C,NAME="glutPostRedisplay")
END SUBROUTINE
! void glutMainLoop(void);
SUBROUTINE glutMainLoop() BIND(C,NAME="glutMainLoop")
END SUBROUTINE
! void glutInitDisplayMode(unsigned int mode);
SUBROUTINE glutInitDisplayMode(mode) BIND(C,NAME="glutInitDisplayMode")
IMPORT
INTEGER(C_INT), VALUE :: mode
END SUBROUTINE
! int glutCreateWindow(char *name);
SUBROUTINE glutCreateWindow(name) BIND(C,NAME="glutCreateWindow")
! CHANGE LATER
IMPORT
TYPE(C_PTR), VALUE :: name
END SUBROUTINE
! void glutDisplayFunc(func);
SUBROUTINE glutDisplayFunc(func) BIND(C,NAME="glutDisplayFunc")
IMPORT
TYPE(C_FUNPTR), VALUE :: func
END SUBROUTINE
! void glutReshapeFunc(func);
SUBROUTINE glutReshapeFunc(func) BIND(C,NAME="glutReshapeFunc")
IMPORT
TYPE(C_FUNPTR), VALUE :: func
END SUBROUTINE
! void glutIdleFunc(func);
SUBROUTINE glutIdleFunc(func) BIND(C,NAME="glutIdleFunc")
IMPORT
TYPE(C_FUNPTR), VALUE :: func
END SUBROUTINE
! These are additions to the GLUT API in freeglut
! void* glutGetWindowData(void);
FUNCTION glutGetWindowData() BIND(C,NAME="glutGetWindowData")
IMPORT
TYPE(C_PTR) :: glutGetWindowData
END FUNCTION
! void glutSetWindowData(void* data);
SUBROUTINE glutSetWindowData(data) BIND(C,NAME="glutSetWindowData")
IMPORT
TYPE(C_PTR), VALUE :: data
END SUBROUTINE
END INTERFACE
END MODULE
MODULE OpenGL_Example
USE ISO_C_BINDING
USE OpenGL_Binding
IMPLICIT NONE
PRIVATE
TYPE, PUBLIC :: SpinningSphere
TYPE(C_PTR) :: quadric=C_NULL_PTR
INTEGER(KIND=GLint) :: gl_list=-1
REAL(GLfloat) :: radius=1.0_glfloat ! It will change randomly
END TYPE
PUBLIC :: TestGL
CONTAINS
SUBROUTINE Display() BIND(C) ! Private so no binding label
! Display GLUT callback
TYPE(C_PTR) :: handle
TYPE(SpinningSphere), POINTER :: sphere
handle=glutGetWindowData() ! A GLUT extension
CALL C_F_POINTER(cptr=handle, fptr=sphere)
CALL glClear(IOR(GL_COLOR_BUFFER_BIT,GL_DEPTH_BUFFER_BIT))
CALL glPushMatrix()
CALL glScalef(sphere%radius, sphere%radius, sphere%radius)
CALL glCallList(sphere%gl_list)
CALL glPopMatrix()
CALL glutSwapBuffers()
END SUBROUTINE
SUBROUTINE Idle() BIND(C) ! Private so no binding label
! Idle GLUT callback
TYPE(C_PTR) :: handle
TYPE(SpinningSphere), POINTER :: sphere
REAL(GLfloat) :: dice
handle=glutGetWindowData() ! A GLUT extension
CALL C_F_POINTER(cptr=handle, fptr=sphere)
CALL RANDOM_NUMBER(dice)
sphere%radius=ABS(1.0_glfloat+0.01_glfloat*(dice-0.5_glfloat))*sphere%radius
CALL glutPostRedisplay()
END SUBROUTINE
SUBROUTINE Reshape(width, height) BIND(C)
! Reshape GLUT callback
INTEGER(GLsizei), VALUE :: width, height
TYPE(C_PTR) :: handle
TYPE(SpinningSphere), POINTER :: sphere
handle=glutGetWindowData() ! A GLUT extension
CALL C_F_POINTER(cptr=handle, fptr=sphere)
CALL glViewport (0_glint, 0_glint, width, height)
END SUBROUTINE
SUBROUTINE TestGL(sphere)
TYPE(SpinningSphere), INTENT(INOUT), TARGET :: sphere
! We do not pass command arguments for simplicity
INTEGER(C_INT) :: argcp=1
TYPE(C_PTR), DIMENSION(1), TARGET :: argv=C_NULL_PTR
CHARACTER(C_CHAR), DIMENSION(1), TARGET :: empty_string=C_NULL_CHAR
argv(1)=C_LOC(empty_string)
CALL glutInit(argcp, C_LOC(argv))
CALL glutInitDisplayMode(IOR(GLUT_DOUBLE,GLUT_RGB))
CALL glutCreateWindow(C_LOC(empty_string)) ! CHANGE LATER!
CALL glutSetWindowData(C_LOC(sphere))
sphere%gl_list=glGenLists(1)
CALL glNewList(sphere%gl_list, GL_COMPILE)
sphere%quadric=gluNewQuadric()
CALL gluQuadricDrawStyle(sphere%quadric, GLU_FILL)
CALL gluSphere(sphere%quadric, 1.0_gldouble, 25_glint, 25_glint)
CALL glEndList()
CALL glLightfv(GL_LIGHT0, GL_DIFFUSE, REAL((/0.8, 0.0, 0.6, 1.0/), glfloat))
CALL glEnable(GL_LIGHTING)
CALL glEnable(GL_LIGHT0)
CALL glEnable(GL_DEPTH_TEST)
! Set the viewing parameters (is this really needed?)
CALL glMatrixMode(GL_PROJECTION)
CALL gluPerspective(40.0_gldouble, 1.0_gldouble, 1.0_gldouble, 10.0_gldouble)
CALL glMatrixMode(GL_MODELVIEW)
CALL gluLookat(0.0_gldouble, 0.0_gldouble, 5.0_gldouble, &
0.0_gldouble, 0.0_gldouble, 0.0_gldouble, &
0.0_gldouble, 1.0_gldouble, 1.0_gldouble)
call glTranslatef(0.0, 0.0, -1.0)
! Set callbacks
CALL glutDisplayFunc(C_FUNLOC(Display))
CALL glutReshapeFunc(C_FUNLOC(Reshape))
CALL glutIdleFunc(C_FUNLOC(Idle))
CALL glutMainLoop() ! Classical GLUT won't return
CALL gluDeleteQuadric(sphere%quadric) ! Avoid memory leaks
WRITE(*,*) "glutMainLoop returned!"
END SUBROUTINE
END MODULE
PROGRAM OpenGL_Test
USE ISO_C_BINDING
USE OpenGL_Example
IMPLICIT NONE
TYPE(SpinningSphere), TARGET :: sphere
CALL TestGL(sphere)
END PROGRAM
MODULE glutExtensions
USE ISO_C_BINDING
TYPE(C_PTR), SAVE :: window_data
END MODULE
! void* glutGetWindowData(void);
FUNCTION glutGetWindowData() RESULT(data) BIND(C,NAME="glutGetWindowData")
!FUNCTION glutGetWindowData_dummy() RESULT(data)
! If using freeglut or openglut uncomment the first line
USE ISO_C_BINDING
USE glutExtensions
IMPLICIT NONE
TYPE(C_PTR) :: data
data=window_data
END FUNCTION
! void glutSetWindowData(void* data);
SUBROUTINE glutSetWindowData(data) BIND(C,NAME="glutSetWindowData")
!SUBROUTINE glutSetWindowData_dummy(data)
! If using freeglut or openglut uncomment the first line
USE ISO_C_BINDING
USE glutExtensions
IMPLICIT NONE
TYPE(C_PTR), VALUE :: data
window_data=data
END SUBROUTINE
|