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), PARAMETER :: imageWidth = 8, imageHeight = 8
INTEGER(GLbyte) :: image(4, imageWidth, imageHeight)
INTEGER(GLcint) :: ixBegin = 0, iyBegin = 0
INTEGER(GLcint) :: mButton
REAL(GLfloat) :: distance, twist, elevation, azimuth
REAL(GLdouble) :: znear = 1.0_gldouble, zfar = 80.0_gldouble, fovy = 40.0_gldouble
INTEGER(GLcint) :: ibitmapNo = 0
INTEGER(GLcint) :: ifilterNo = 0
INTEGER(GLcint) :: itexmodeNo = 3
!
INTEGER(GLbyte) :: bitmap1(imageWidth, imageHeight) = &
(/                                             & 
  (/255, 255, 255, 255,   0,   0,   0,   0 /), &
  (/255, 255, 255, 255,   0,   0,   0,   0 /), &
  (/255, 255, 255, 255,   0,   0,   0,   0 /), &
  (/255, 255, 255, 255,   0,   0,   0,   0 /), &
  (/  0,   0,   0,   0, 255, 255, 255, 255 /), &
  (/  0,   0,   0,   0, 255, 255, 255, 255 /), &
  (/  0,   0,   0,   0, 255, 255, 255, 255 /), &
  (/  0,   0,   0,   0, 255, 255, 255, 255 /)  &
/)
INTEGER(GLbyte) :: bitmap2(imageWidth, imageHeight) = &
(/                                             & 
  (/  0,   0,   0, 255, 255,   0,   0,   0 /), &
  (/  0,   0, 255, 255, 255, 255,   0,   0 /), &
  (/  0, 255, 255, 255, 255, 255, 255,   0 /), &
  (/255, 255, 255, 255, 255, 255, 255, 255 /), &
  (/255, 255, 255, 255, 255, 255, 255, 255 /), &
  (/  0, 255, 255, 255, 255, 255, 255,   0 /), &
  (/  0,   0, 255, 255, 255, 255,   0,   0 /), &
  (/  0,   0,   0, 255, 255,   0,   0,   0 /)  &
/)
INTEGER(GLbyte) :: bitmap3(imageWidth, imageHeight) = &
(/                                             & 
  (/255, 255, 255,   0, 255, 255, 255, 255 /), &
  (/255, 255, 255,   0, 255, 255, 255, 255 /), &
  (/255, 255, 255,   0, 255, 255, 255, 255 /), &
  (/  0,   0,   0,   0,   0,   0,   0,   0 /), &
  (/255, 255, 255,   0, 255, 255, 255, 255 /), &
  (/255, 255, 255,   0, 255, 255, 255, 255 /), &
  (/255, 255, 255,   0, 255, 255, 255, 255 /), &
  (/255, 255, 255,   0, 255, 255, 255, 255 /)  &
/)
CONTAINS
!---------------------------------------------------------
SUBROUTINE display()
IMPLICIT NONE
REAL(glfloat) :: diffuse(4)  = (/ 1.0_glfloat, 1.0_glfloat, 1.0_glfloat, 1.0_glfloat /)
REAL(glfloat) :: specular(4) = (/ 1.0_glfloat, 1.0_glfloat, 1.0_glfloat, 1.0_glfloat /)
REAL(glfloat) :: ambient(4)  = (/ 0.1_glfloat, 0.1_glfloat, 0.1_glfloat, 1.0_glfloat /)
REAL(glfloat) :: texcolor(4) = (/ 1.0_glfloat, 0.0_glfloat, 0.0_glfloat, 1.0_glfloat /)
CALL glClear( IOR(GL_COLOR_BUFFER_BIT, GL_DEPTH_BUFFER_BIT) )
SELECT CASE (itexmodeNo)
 CASE (1)
  CALL glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE)
 CASE (2) 
  CALL glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_DECAL   )
 CASE (3)
  CALL glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_BLEND   )
 CASE (4)
  CALL glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE )
 CASE DEFAULT
  CONTINUE
END SELECT
CALL glTexEnvfv( GL_TEXTURE_ENV, GL_TEXTURE_ENV_COLOR, texcolor)
CALL glEnable( GL_TEXTURE_2D )
!
CALL glPushMatrix()
CALL polarview( )
!
CALL glMaterialfv( GL_FRONT, GL_DIFFUSE  , diffuse   ) 
CALL glMaterialfv( GL_FRONT, GL_SPECULAR , specular  )
CALL glMaterialfv( GL_FRONT, GL_AMBIENT  , ambient   )
CALL glMaterialf ( GL_FRONT, GL_SHININESS, 128.0_glfloat )
!
CALL glEnable( GL_LIGHTING )
CALL glEnable( GL_DEPTH_TEST )
CALL glNormal3f( 0.0_glfloat, 1.0_glfloat, 0.0_glfloat )
CALL glBegin( GL_QUADS )
 CALL glTexCoord2f( 0.0_glfloat, 0.0_glfloat )
 CALL glVertex3f( 1.0_glfloat, 0.0_glfloat,  1.0_glfloat )
 CALL glTexCoord2f( 0.0_glfloat, 5.0_glfloat )
 CALL glVertex3f( 1.0_glfloat, 0.0_glfloat, -1.0_glfloat )
 CALL glTexCoord2f( 5.0_glfloat, 5.0_glfloat )
 CALL glVertex3f(-1.0_glfloat, 0.0_glfloat, -1.0_glfloat )
 CALL glTexCoord2f( 5.0_glfloat, 0.0_glfloat )
 CALL glVertex3f(-1.0_glfloat, 0.0_glfloat,  1.0_glfloat )
CALL glEnd()
CALL glPopMatrix()
!
CALL glDisable( GL_TEXTURE_2D )
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 (ICHAR('R'))
  CALL resetview()
 CASE (ICHAR('s'))
  CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP)
  PRINT *, "GL_TEXTURE_WRAP_S ... GL_CLAMP"
 CASE (ICHAR('S'))
  CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT)
  PRINT *, "GL_TEXTURE_WRAP_S ... GL_REPEAT"
 CASE (ICHAR('t'))
  CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP)
  PRINT *, "GL_TEXTURE_WRAP_T ... GL_CLAMP"
 CASE (ICHAR('T'))
  CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT)
  PRINT *, "GL_TEXTURE_WRAP_T ... GL_REPEAT"
 CASE (ICHAR(' '))
  ibitmapNo = ibitmapNo + 1 
  print *, ibitmapNo
  IF ( ibitmapNo >= 3 ) ibitmapNo = 0
  CALL initTexture()
 CASE (ICHAR('f'))
  ifilterNo = ifilterNo + 1
  IF ( ifilterNo >= 2 ) THEN
   ifilterNo = 0;
   PRINT *, "GL_TEXTURE_FILTER ...  GL_NEAREST "
  ELSE
   PRINT *, "GL_TEXTURE_FILTER ...  GL_LINEAR "
  END IF
  CALL initTexture()
 CASE (ICHAR('h'))
  CALL printHelp()
 CASE (ICHAR('1'))
  itexmodeNo = 1
  PRINT *, "TGL_EXTURE_ENV_MODE ... GL_MODULATE"
 CASE (ICHAR('2'))
  itexmodeNo = 2
  PRINT *, "GL_TEXTURE_ENV_MODE ... GL_DECAL"
 CASE (ICHAR('3'))
  itexmodeNo = 3
  PRINT *, "GL_TEXTURE_ENV_MODE ... GL_BLEND"
 CASE (ICHAR('4'))
  itexmodeNo = 4
  PRINT *, "GL_TEXTURE_ENV_MODE ... GL_REPLACE"
 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   + ixDisp / 2.0_GLfloat
  elevation = elevation - iyDisp / 2.0_GLfloat
 CASE (GLUT_MIDDLE_BUTTON)
  twist = AMOD( twist + ixDisp / 3.0_GLfloat, 360.0_GLfloat )
 CASE (GLUT_RIGHT_BUTTON)
  distance = distance - iyDisp / 60.0_GLfloat
 CASE DEFAULT
  CONTINUE
END SELECT 
ixBegin = ix
iyBegin = iy
CALL glutPostRedisplay()
RETURN
END SUBROUTINE myMotion
!---------------------------------------------------------
SUBROUTINE makeImage()
IMPLICIT NONE
INTEGER(GLcint) :: i, j
SELECT CASE (ibitmapNo)
 CASE(0)
  DO i = 1, imageHeight
   DO j = 1, imageWidth
    image(1, j, i) = bitmap1(j, i)
    image(2, j, i) = bitmap1(j, i)
    image(3, j, i) = bitmap1(j, i)
    image(4, j, i) = 50_GLbyte
   END DO
  END DO
 CASE(1)
  DO i = 1, imageHeight
   DO j = 1, imageWidth
    image(1, j, i) = bitmap2(j, i)
    image(2, j, i) = bitmap2(j, i)
    image(3, j, i) = bitmap2(j, i)
    image(4, j, i) = 50_GLbyte
   END DO
  END DO
 CASE(2)
  DO i = 1, imageHeight
   DO j = 1, imageWidth
    image(1, j, i) = bitmap3(j, i)
    image(2, j, i) = bitmap3(j, i)
    image(3, j, i) = bitmap3(j, i)
    image(4, j, i) = 50_GLbyte
   END DO
  END DO
 CASE DEFAULT
  CONTINUE 
END SELECT
RETURN
END SUBROUTINE makeImage
!---------------------------------------------------------
SUBROUTINE initTexture()
IMPLICIT NONE
CALL makeImage()
CALL glPixelStorei(GL_UNPACK_ALIGNMENT, 1)
CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT)
CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT)	
IF (ifilterNo == 0) THEN
 CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST)
 CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST)
ELSE
 CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR)
 CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR)
END IF
CALL glTexImage2D(GL_TEXTURE_2D, 0, 4, imageWidth, imageHeight, 0,    & 
                  GL_RGBA, GL_UNSIGNED_BYTE, RESHAPE(image, (/4 * imageWidth * imageHeight/)))
RETURN
END SUBROUTINE initTexture
!---------------------------------------------------------
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 printHelp()
IMPLICIT NONE
PRINT *
PRINT *, "*   t key ... GL_CLAMP  t-direction                      *"
PRINT *, "*   T key ... GL_REPEAT t-direction                      *"
PRINT *, "*   s key ... GL_CLAMP  s-direction                      *"
PRINT *, "*   S key ... GL_REPEAT s-direction                      *"
PRINT *, "*   1 key ... GL_MODULATE                                *"
PRINT *, "*   2 key ... GL_DECAL                                   *"
PRINT *, "*   3 key ... GL_BLEND                                   *"
PRINT *, "*   4 key ... GL_REPLACE                                 *"
PRINT *, "*   SPACE key ...  -> bitmap2 -> bitmap3 -> bitmap1 ->   *"
PRINT *, "*   f key ...  GL_NEAREST  <--->  GL_LINEAR              *"
PRINT *, "*   h key ...  Print this help message.                  *"
PRINT *
RETURN
END SUBROUTINE printHelp
!---------------------------------------------------------
SUBROUTINE resetview()
IMPLICIT NONE
distance  =   6.0_glfloat
twist     =   0.0_glfloat
elevation = -45.0_glfloat
azimuth   =  30.0_glfloat
RETURN
END SUBROUTINE resetview
!---------------------------------------------------------
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, znear, zfar )
CALL glMatrixMode( GL_MODELVIEW )
RETURN
END SUBROUTINE myReshape
!---------------------------------------------------------
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 initTexture()
CALL resetview()
CALL glEnable( GL_LIGHT0 )
RETURN
END SUBROUTINE myInit
!---------------------------------------------------------
END MODULE m_callback
!=========================================================
PROGRAM GLUT8
USE m_callback
IMPLICIT NONE
CALL glutInit()
CALL printHelp()
CALL myInit( 'GLUT8' )
CALL glutReshapeFunc( myReshape )
CALL glutDisplayFunc( display )
CALL glutMainLoop()
STOP
END PROGRAM GLUT8