gcc/testsuite/gfortran.dg/direct_io_10.f

   1 ! { dg-do run }
   2 ! pr35699 run-time abort writing zero sized section to direct access file
   3       program directio
   4       call       qi0010 (  10,   1,   2,   3,   4,  9,   2)
   5       end
   6
   7       subroutine qi0010 (nf10, nf1, nf2, nf3, nf4,nf9, np2)
   8       character(10) bda(nf10)
   9       character(10) bda1(nf10), bval
  10
  11       integer  j_len
  12       bda1(1) = 'x'
  13       do i = 2,10
  14         bda1(i) = 'x'//bda1(i-1)
  15       enddo
  16       bda = 'unread'
  17
  18       inquire(iolength = j_len) bda1(nf1:nf10:nf2), bda1(nf4:nf3),
  19      $                               bda1(nf2:nf10:nf2)
  20
  21       open (unit=48,
  22      $      access='direct',
  23      $      status='scratch',
  24      $      recl = j_len,
  25      $      iostat = istat,
  26      $      form='unformatted',
  27      $      action='readwrite')
  28
  29       write (48,iostat = istat, rec = 3) bda1(nf1:nf10:nf2),
  30      $                    bda1(nf4:nf3), bda1(nf2:nf10:nf2)
  31       if ( istat .ne. 0) then
  32         STOP 1
  33       endif
  34       istat = -314
  35
  36       read (48,iostat = istat, rec = np2+1) bda(nf1:nf9:nf2),
  37      $                       bda(nf4:nf3), bda(nf2:nf10:nf2)
  38       if ( istat .ne. 0) then
  39         STOP 2
  40       endif
  41
  42       do j1 = 1,10
  43         bval = bda1(j1)
  44         if (bda(j1) .ne. bval) STOP 3
  45       enddo
  46       end subroutine