Mercurial > hg > CbC > CbC_gcc
view gcc/testsuite/gfortran.dg/namelist_28.f90 @ 128:fe568345ddd5
fix CbC-example
author | mir3636 |
---|---|
date | Wed, 11 Apr 2018 19:32:28 +0900 |
parents | 04ced10e8804 |
children | 84e7813d76e9 |
line wrap: on
line source
! { dg-do run } ! PR31052 Bad IOSTAT values when readings NAMELISTs past EOF. ! Patch derived from PR, submitted by Jerry DeLisle <jvdelisle@gcc.gnu.org> program gfcbug61 implicit none integer, parameter :: nmlunit = 12 ! Namelist unit integer :: stat open (nmlunit, status="scratch") write(nmlunit, '(a)') "&REPORT type='report1' /" write(nmlunit, '(a)') "&REPORT type='report2' /" write(nmlunit, '(a)') "!" rewind (nmlunit) ! The call to position_nml is contained in the subroutine call read_report (nmlunit, stat) rewind (nmlunit) call position_nml (nmlunit, 'MISSING', stat) rewind (nmlunit) call read_report (nmlunit, stat) ! gfortran fails here contains subroutine position_nml (unit, name, status) ! Check for presence of namelist 'name' integer :: unit, status character(len=*), intent(in) :: name character(len=255) :: line integer :: ios, idx, k logical :: first first = .true. status = 0 do k=1,25 line = "" read (unit,'(a)',iostat=ios) line if (ios < 0) then ! EOF encountered! backspace (unit) status = -1 return else if (ios > 0) then ! Error encountered! status = +1 return end if idx = index (line, "&"//trim (name)) if (idx > 0) then backspace (unit) return end if end do if (k.gt.10) call abort end subroutine position_nml subroutine read_report (unit, status) integer :: unit, status integer :: iuse, ios, k !------------------ ! Namelist 'REPORT' !------------------ character(len=12) :: type namelist /REPORT/ type !------------------------------------- ! Loop to read namelist multiple times !------------------------------------- iuse = 0 do k=1,25 !---------------------------------------- ! Preset namelist variables with defaults !---------------------------------------- type = '' !-------------- ! Read namelist !-------------- call position_nml (unit, "REPORT", status) if (stat /= 0) then ios = status if (iuse /= 2) call abort() return end if read (unit, nml=REPORT, iostat=ios) if (ios /= 0) exit iuse = iuse + 1 end do if (k.gt.10) call abort status = ios end subroutine read_report end program gfcbug61