summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.dg/namelist_27.f90
blob: 06381b116344c8a51db9a64c48194a3be53b3548 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
! { 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            :: stat

  open (12, status="scratch")
  write (12, '(a)')"!================"
  write (12, '(a)')"! Namelist REPORT"
  write (12, '(a)')"!================"
  write (12, '(a)')" &REPORT type     = 'SYNOP' "
  write (12, '(a)')"         use      = 'active'"
  write (12, '(a)')"         max_proc = 20"
  write (12, '(a)')" /"
  write (12, '(a)')"! Other namelists..."
  write (12, '(a)')" &OTHER  i = 1 /"
  rewind (12)

  ! Read /REPORT/ the first time
  rewind (12)
  call position_nml (12, "REPORT", stat)
  if (stat.ne.0) call abort()
  if (stat == 0)  call read_report (12, stat)

  ! Comment out the following lines to hide the bug
  rewind (12)
  call position_nml (12, "MISSING", stat)
  if (stat.ne.-1)  call abort ()

  ! Read /REPORT/ again
  rewind (12)
  call position_nml (12, "REPORT", stat)
  if (stat.ne.0)  call abort()

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
    ios = 0
    line = ""
    do k=1,10
       read (unit,'(a)',iostat=ios) line
       if (first) then
          first = .false.
       end if
       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
  end subroutine position_nml

  subroutine read_report (unit, status)
    integer :: unit, status

    integer            :: iuse, ios, k
    !------------------
    ! Namelist 'REPORT'
    !------------------
    character(len=12) :: type, use
    integer           :: max_proc
    namelist /REPORT/ type, use, max_proc
    !-------------------------------------
    ! Loop to read namelist multiple times
    !-------------------------------------
    iuse = 0
    do k=1,5
       !----------------------------------------
       ! Preset namelist variables with defaults
       !----------------------------------------
       type      = ''
       use       = ''
       max_proc  = -1
       !--------------
       ! Read namelist
       !--------------
       read (unit, nml=REPORT, iostat=ios)
       if (ios /= 0) exit
       iuse = iuse + 1
    end do
    if (iuse.ne.1) call abort()
    status = ios
  end subroutine read_report

end program gfcbug61