Problem with a program: zero-sized array?

[Arjen Markus]

Hello,

I have run into a peculiar problem with the gfortran compiler (both on
Windows and Linux).
I have reduced the program to a bare minimum and that has made the
crash (access violation or
something similarly fatal) disappear, but the bug is still there. Here
is the output from the
program as I get it:

 after retrieve int1d:           1           2           3           4
          5           6           7           8           9
10
 shape:          10
 shape:          10
 shape: ...
 size:            1

This output is written by the following statements:

    write(*,*) 'after retrieve int1d:', INT1D_RETRIEVED
    write(*,*) 'shape:', shape(INT1D_RETRIEVED)
    write(*,*) 'shape:', shape(INT1D)
    write(*,*) 'shape:', shape(int1d_retrieved) == shape(INT1D), ' ...'
    write(*,*) 'size: ', size(shape(int1d_retrieved) == shape(int1d))

(there is NOTHING in between)

The odd thing is the fourth line - it should have contained the one
logical value of the comparison.
In the full program a similar comparison causes the crash.

As you can see: the shape information is there on the third line and
the array int1d is simply a
fixed array.

I have tried the program with other compilers and they gave no problems.

I suspect this is caused by a bug in the gfortran compiler, but I
hesitate to draw that conclusion
right now - I have been too hasty with such conclusions in the past.

I'd appreciate any comments that can shed light on this.

Regards,

Arjen

---------
Source code for the  program:

! test_store.f90 --
!     Test program for the ftnunit_store module
!
module ftnunit_utilities

contains

subroutine ftnunit_get_lun( lun )
    integer, intent(out) :: lun

    lun = 10

end subroutine ftnunit_get_lun

end module ftnunit_utilities

module ftnunit_store
    use ftnunit_utilities

    implicit none

    private
    integer, parameter :: single = kind(1.0)
    integer, parameter :: double = kind(1.0d0)

    character(len=40), parameter :: ftnunit_header    = 'FTNUNIT 1.0'
    character(len=10), parameter :: ftnunit_integer   = 'INTEGER'

    interface test_retrieve_data
        module procedure test_retrieve_data_integer1d
    end interface

    interface test_store_data
        module procedure test_store_data_integer1d
    end interface

    public :: test_retrieve_data, test_store_data
    public :: test_open_storage_file, test_close_storage_file

contains

subroutine test_open_storage_file( filename, lun, desc, output )
    character(len=*), intent(in)    :: filename
    integer, intent(out)            :: lun
    character(len=*), intent(inout) :: desc
    logical, intent(in), optional   :: output

    logical                         :: output_
    character(len=80)               :: desc_
    character(len=40)               :: header
    integer                         :: ierr

    output_ = .false.
    if ( present(output) ) then
        output_ = output
    endif

    !
    ! Get a LU-number, open the file and check
    !
    call ftnunit_get_lun( lun )

    if ( output_ ) then
        open( lun, file = filename, form = 'unformatted', status =
'new', iostat = ierr )
        write( lun ) ftnunit_header
        desc_ = desc
        write( lun ) desc_  ! Ensure a known length of the description

    else
        open( lun, file = filename, form = 'unformatted', status =
'old', iostat = ierr )
        read( lun, iostat = ierr ) header
        read( lun, iostat = ierr ) desc_  ! Ensure a known length of
the description
        desc = desc_
    endif

end subroutine test_open_storage_file

subroutine test_close_storage_file( lun )
    integer, intent(in)             :: lun

    close( lun )

end subroutine test_close_storage_file

subroutine test_store_data_integer1d( lun, data, desc )
    integer, intent(in)               :: lun
    integer, intent(in), dimension(:) :: data
    character(len=*), intent(in)      :: desc

    character(len=40)                 :: desc_
    integer, dimension(10)            :: dimensions

    desc_ = desc
    dimensions = 0
    dimensions(1:1) = shape(data)

    write( lun ) ftnunit_integer, 0, 1, dimensions, desc_
    write( lun ) data

end subroutine test_store_data_integer1d

subroutine test_retrieve_data_integer1d( lun, data, desc )
    integer, intent(in)               :: lun
    integer, pointer, dimension(:)    :: data
    character(len=*)                  :: desc

    character(len=10)                 :: type
    character(len=40)                 :: desc_
    integer, dimension(10)            :: dimensions
    integer                           :: ierr
    integer                           :: char_length
    integer                           :: number_dims

    read( lun, iostat = ierr ) type, char_length, number_dims, dimensions, desc_

    allocate( data(dimensions(1)) )

    read( lun ) data
    desc = desc_

end subroutine test_retrieve_data_integer1d

end module ftnunit_store

!------------------------------------------------------------

program test_store

    use ftnunit_store

    implicit none

    integer                            :: i, j, k
    integer, dimension(10)             :: int1d
    integer, dimension(:), pointer     :: int1d_retrieved

    integer                            :: lun
    character(len=60)                  :: description
    character(len=80)                  :: desc_retrieved ! Different
length than description

    description = 'Test file for ftnunit_store module'

    int1d  = (/ (i, i=1,10) /)

    call test_open_storage_file( 'test_store.bin', lun, description, .true. )

    call test_store_data( lun, int1d,  'integer array int1d' )

    call test_close_storage_file( lun )

    !
    ! Now retrieve the data and compare
    !

    call test_open_storage_file( 'test_store.bin', lun,
desc_retrieved, .false. )

    if ( desc_retrieved /= description ) then
        write(*,*) 'Difference in file description'
        write(*,*) '    Expected: ', description
        write(*,*) '    Actual:   ', desc_retrieved
    endif

    call test_retrieve_data( lun, int1d_retrieved, desc_retrieved )
    write(*,*) 'after retrieve int1d:', INT1D_RETRIEVED
    write(*,*) 'shape:', shape(INT1D_RETRIEVED)
    write(*,*) 'shape:', shape(INT1D)
    write(*,*) 'shape:', shape(int1d_retrieved) == shape(INT1D), ' ...'
    write(*,*) 'size: ', size(shape(int1d_retrieved) == shape(int1d))

    call test_close_storage_file( lun )

end program