namelist_19.f90

来自「用于进行gcc测试」· F90 代码 · 共 136 行

!{ dg-do run }
! Test namelist error trapping.
! provided by Paul Thomas - [e-mail]

program namelist_19
  character*80 wrong, right
  
! "=" before any object name
  wrong = "&z = i = 1,2 /"
  right = "&z i = 1,2 /"
  call test_err(wrong, right)
  
! &* instead of &end for termination 
  wrong = "&z i = 1,2 &xxx"
  right = "&z i = 1,2 &end"
  call test_err(wrong, right)
  
! bad data 
  wrong = "&z i = 1,q /"
  right = "&z i = 1,2 /"
  call test_err(wrong, right)
  
! object name not matched 
  wrong = "&z j = 1,2 /"
  right = "&z i = 1,2 /"
  call test_err(wrong, right)

! derived type component for intrinsic type
  wrong = "&z i%j = 1,2 /"
  right = "&z i = 1,2 /"
  call test_err(wrong, right)

! step other than 1 for substring qualifier
  wrong = "&z ch(1:2:2) = 'a'/"
  right = "&z ch(1:2) = 'ab' /"
  call test_err(wrong, right)

! qualifier for scalar 
  wrong = "&z k(2) = 1 /"
  right = "&z k    = 1 /"
  call test_err(wrong, right)

! no '=' after object name 
  wrong = "&z i   1,2 /"
  right = "&z i = 1,2 /"
  call test_err(wrong, right)

! repeat count too large 
  wrong = "&z i = 3*2 /"
  right = "&z i = 2*2 /"
  call test_err(wrong, right)

! too much data 
  wrong = "&z i = 1 2 3 /"
  right = "&z i = 1 2 /"
  call test_err(wrong, right)

! no '=' after object name 
  wrong = "&z i   1,2 /"
  right = "&z i = 1,2 /"
  call test_err(wrong, right)

! bad number of index fields
  wrong = "&z i(1,2) = 1 /"
  right = "&z i(1)   = 1 /"
  call test_err(wrong, right)

! bad character in index field 
  wrong = "&z i(x) = 1 /"
  right = "&z i(1) = 1 /"
  call test_err(wrong, right)

! null index field 
  wrong = "&z i( ) = 1 /"
  right = "&z i(1) = 1 /"
  call test_err(wrong, right)

! null index field 
  wrong = "&z i(1::)   = 1 2/"
  right = "&z i(1:2:1) = 1 2 /"
  call test_err(wrong, right)

! null index field 
  wrong = "&z i(1:2:)  = 1 2/"
  right = "&z i(1:2:1) = 1 2 /"
  call test_err(wrong, right)

! index out of range 
  wrong = "&z i(10) = 1 /"
  right = "&z i(1)  = 1 /"
  call test_err(wrong, right)

! index out of range 
  wrong = "&z i(0:1) = 1 /"
  right = "&z i(1:1) = 1 /"
  call test_err(wrong, right)

! bad range
  wrong = "&z i(1:2:-1) = 1 2 /"
  right = "&z i(1:2: 1) = 1 2 /"
  call test_err(wrong, right)

! bad range
  wrong = "&z i(2:1: 1) = 1 2 /"
  right = "&z i(2:1:-1) = 1 2 /"
  call test_err(wrong, right)

contains
  subroutine test_err(wrong, right)
    character*80 wrong, right
    integer            :: i(2) = (/0, 0/)
    integer            :: k =0
    character*2        :: ch = "  "
    namelist /z/ i, k, ch

! Check that wrong namelist input gives an error

    open (10, status = "scratch")
    write (10, '(A)') wrong
    rewind (10)
    read (10, z, iostat = ier)
    close(10)
    if (ier == 0) call abort ()

! Check that right namelist input gives no error

    open (10, status = "scratch")
    write (10, '(A)') right
    rewind (10)
    read (10, z, iostat = ier)
    close(10)
    if (ier /= 0) call abort ()
  end subroutine test_err
  
end program namelist_19