path: root/hl/fortran/test/tstimage.F90

! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!   Copyright by The HDF Group.                                               *
!   Copyright by the Board of Trustees of the University of Illinois.         *
!   All rights reserved.                                                      *
!                                                                             *
!   This file is part of HDF5.  The full HDF5 copyright notice, including     *
!   terms governing use, modification, and redistribution, is contained in    *
!   the files COPYING and Copyright.html.  COPYING can be found at the root   *
!   of the source code distribution tree; Copyright.html can be found at the  *
!   root level of an installed copy of the electronic HDF5 document set and   *
!   is linked from the top-level documents page.  It can also be found at     *
!   http://hdfgroup.org/HDF5/doc/Copyright.html.  If you do not have          *
!   access to either file, you may request a copy from help@hdfgroup.org.     *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
! This file contains the FORTRAN90 tests for H5LT
!

program image_test

call make_image1()

end program image_test


!-------------------------------------------------------------------------
! make_image1
!-------------------------------------------------------------------------

subroutine make_image1()

use h5im ! module of H5IM
use hdf5 ! module of HDF5 library

implicit none

character(len=8), parameter :: filename = "f1img.h5" ! file name
character(len=4), parameter :: dsetname1 = "img1"    ! dataset name
character(len=4), parameter :: dsetname2 = "img2"    ! dataset name
character(len=15), parameter :: il ="INTERLACE_PIXEL"! dataset name
integer(hid_t) :: file_id                            ! file identifier
integer(hsize_t), parameter :: width  = 500          ! width of image
integer(hsize_t), parameter :: height = 200          ! height of image
integer, parameter :: pal_entries = 9                ! palette number of entries
integer, dimension(width*height) :: buf1             ! data buffer
integer, dimension(width*height) :: bufr1            ! data buffer
integer, dimension(width*height*3) :: buf2           ! data buffer
integer, dimension(width*height*3) :: bufr2          ! data buffer
integer(hsize_t) :: widthr                           ! width of image
integer(hsize_t) :: heightr                          ! height of image
integer(hsize_t) :: planesr                          ! color planes
integer(hsize_t) :: npalsr                           ! palettes
character(len=15) :: interlacer                      ! interlace
integer :: errcode                                   ! error flag
integer :: is_image                                  ! error flag
integer :: i, j, n                                   ! general purpose integers
!
! palette
! create a 9 entry palette
!
character(len=4), parameter :: pal_name = "pal1"     ! dataset name
integer(hsize_t), dimension(2) :: pal_dims = (/pal_entries,3/) ! palette dimensions
integer(hsize_t), dimension(2) :: pal_dims_out       ! palette dimensions
integer, dimension(pal_entries*3) :: pal_data_out    ! data buffer
integer(hsize_t) :: npals                            ! number of palettes
integer          :: pal_number                       ! palette number
integer          :: is_palette                       ! is palette
integer          :: space
integer, dimension(pal_entries*3) :: pal_data_in = (/&
 0,0,168,&      ! dark blue
 0,0,252,&      ! blue
 0,168,252,&    ! ocean blue
 84,252,252,&   ! light blue
 168,252,168,&  ! light green
 0,252,168,&    ! green
 252,252,84,&   ! yellow
 252,168,0,&    ! orange
 252,0,0/)      ! red


! create an 8bit image of 9 values divided evenly by the array
!
space = width*height / pal_entries;
n = 0; j = 0;
do i = 1, width*height
  buf1(i) = n
  if ( j > space ) then
   n = n + 1;
   j = 0;
  endif
  if (n>pal_entries-1) n=0;
  j = j +1;
end do

!
! create a 3 byte rgb image
!
n = 0; j = 0;
do i = 1, width*height*3
  buf2(i) = n;
  if (j == 3) then
   n = n + 1;
   j = 0;
  endif
  if (n>255) n=0;
  j = j +1;
end do


! Initialize FORTRAN predefined datatypes.
!
call h5open_f(errcode)
!
! Create a new file using default properties.
!
call h5fcreate_f(filename, H5F_ACC_TRUNC_F, file_id, errcode)

!-------------------------------------------------------------------------
! indexed image
!-------------------------------------------------------------------------

call test_begin(' Make/Read image 8bit           ')

!
! write image.
!
call h5immake_image_8bit_f(file_id,dsetname1,width,height,buf1,errcode)
!
! read image.
!
call h5imread_image_f(file_id,dsetname1,bufr1,errcode)
!
! compare read and write buffers.
!
do i = 1, width*height
 if ( buf1(i) /= bufr1(i) ) then
   print *, 'read buffer differs from write buffer'
   print *,  bufr1(i), ' and ',   buf1(i)
   stop
  endif
end do

!
! get image info.
!
call h5imget_image_info_f(file_id,dsetname1,widthr,heightr,planesr,interlacer,npalsr,errcode)

if ( (widthr /= widthr) .or. (heightr /= height) .or. (planesr /= 1)) then
 print *, 'h5imget_image_info_f bad value'
 stop
endif

is_image = h5imis_image_f(file_id,dsetname1)
if ( is_image /= 1) then
 print *, 'h5imis_image_f bad value'
 stop
endif


call passed()

!-------------------------------------------------------------------------
! true color image
!-------------------------------------------------------------------------

call test_begin(' Make/Read image 24bit          ')

!
! write image.
!
call h5immake_image_24bit_f(file_id,dsetname2,width,height,il,buf2,errcode)

!
! read image.
!
call h5imread_image_f(file_id,dsetname2,bufr2,errcode)

!
! compare read and write buffers.
!
do i = 1, width*height*3
 if ( buf2(i) /= bufr2(i) ) then
   print *, 'read buffer differs from write buffer'
   print *,  bufr2(i), ' and ',   buf2(i)
   stop
  endif
end do

!
! get image info.
!
call h5imget_image_info_f(file_id,dsetname2,widthr,heightr,planesr,interlacer,npalsr,errcode)

if ( (widthr /= widthr) .or. (heightr /= height) .or. (planesr /= 3)) then
 print *, 'h5imget_image_info_f bad value'
 stop
endif

is_image = h5imis_image_f(file_id,dsetname2)
if ( is_image /= 1) then
 print *, 'h5imis_image_f bad value'
 stop
endif



call passed()

!-------------------------------------------------------------------------
! palette
!-------------------------------------------------------------------------

call test_begin(' Make palette                   ')

!
! make palette.
!
call h5immake_palette_f(file_id,pal_name,pal_dims,pal_data_in,errcode)

call passed()


call test_begin(' Link/Unlink palette            ')

!
! link palette.
!
call h5imlink_palette_f(file_id,dsetname1,pal_name,errcode)


!
! read palette.
!
pal_number = 0
call h5imget_palette_f(file_id,dsetname1,pal_number,pal_data_out,errcode)

!
! compare read and write buffers.
!
do i = 1, pal_entries*3
 if ( pal_data_in(i) /= pal_data_out(i) ) then
   print *, 'read buffer differs from write buffer'
   print *,  pal_data_in(i), ' and ',   pal_data_out(i)
   stop
  endif
end do

!
! get number of palettes
!
call h5imget_npalettes_f(file_id,dsetname1,npals,errcode)

if ( npals /= 1) then
 print *, 'h5imget_npalettes_f bad value'
 stop
endif

!
! get palette info
!
pal_number = 0
call h5imget_palette_info_f(file_id,dsetname1,pal_number,pal_dims_out,errcode)

if ( (pal_dims_out(1) /= pal_dims(1)) .or. (pal_dims_out(2) /= pal_dims(2))) then
 print *, 'h5imget_palette_info_f bad value'
 stop
endif

!
! is palette
!
is_palette = h5imis_palette_f(file_id,pal_name)

if ( is_palette /= 1 ) then
 print *, 'h5imis_palette_f bad value'
 stop
endif

!
! unlink palette.
!
call h5imunlink_palette_f(file_id,dsetname1,pal_name,errcode)

!
! get number of palettes
!
call h5imget_npalettes_f(file_id,dsetname1,npals,errcode )

if ( npals /= 0) then
 print *, 'h5imget_npalettes_f bad value'
 stop
endif


!
! link palette again
!
call h5imlink_palette_f(file_id,dsetname1,pal_name,errcode)

call passed()


!-------------------------------------------------------------------------
! end
!-------------------------------------------------------------------------

!
! Close the file.
!
call h5fclose_f(file_id, errcode)

!
! Close FORTRAN predefined datatypes.
!
call h5close_f(errcode)

!
! end function.
!
end subroutine make_image1

!-------------------------------------------------------------------------
! test_begin
!-------------------------------------------------------------------------

subroutine test_begin(string)
character(len=*), intent(in) :: string
write(*, fmt = '(14a)', advance = 'no') string
write(*, fmt = '(40x,a)', advance = 'no') ' '
end subroutine test_begin

!-------------------------------------------------------------------------
! passed
!-------------------------------------------------------------------------

subroutine passed()
write(*, fmt = '(6a)')  'PASSED'
end subroutine passed