File: blockerrors.f

package info (click to toggle)
ftnchek 3.1.2-2
  • links: PTS
  • area: main
  • in suites: woody
  • size: 6,436 kB
  • ctags: 5,393
  • sloc: ansic: 24,609; fortran: 5,565; yacc: 3,682; sh: 2,518; makefile: 772; lisp: 264; f90: 94; perl: 76
file content (92 lines) | stat: -rw-r--r-- 2,755 bytes parent folder | download | duplicates (6)
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
      program blocks
! program with various errors in balancing block structures
        real x
        integer n
        x = bar(1.0)
        if( x .gt. 0 ) then
           call baz(x)
           n = int(x)
           select case (n)
              case(1)
                 call baz(2.0)
              case(2:10)
                 call baz(3.0)
              case(-1,11:100,300)
                 call baz(4.0)
              case default
                 call baz(5.0)
           end select
        else
           k = 0
           loop1: do i=1,100
              loop2:    do j=1,10
                 write(*,*) i,j,i*j
                 if( i .eq. 50 ) exit loopdedo   ! wrong construct name
                 k = k + j
                 if( k .eq. 50) cycle loop2
              end do loop2
              write(*,*) k*i**2
           enddo foop1
           case2: select case (n)
              case(1) case2
                 call baz(2.0)
              case(2:10) caseZ
                 call baz(3.0)
              case(-1,11:100,300) case2
                 call baz(4.0)
              case default case2
!  do-loops with shared terminator
                 do 100 i=1,10
                    do 100 j=1,10
                       print *, i, j, i*j
 100             continue
                 do 200 i=1,10
                    do 250 j=1,10
                       print *, i, j, i*j
 200                continue                  ! terminators out of order
 250             end do
           end select case2
        end if
        if( x .eq. 0) exit                    ! no enclosing DO
        else if( x .lt. 0 ) then              ! else has no matching then
           print *, 'Hello'
        end select                            ! should be end if
      end program blocks
      function bar(c)
        real a, b, c ,d
        read *, a
! This block is from section 8.1.2.3 of the F90 standard, except for
! removing space between some keywords
        if ( a .gt. 0 ) then
           b = c/a
           if (b .gt. 0) then
              d = 1.0
           endif
        elseif (c .gt. 0) then
           b = a/c
           d = -1.0
        else
           b = abs (max (a, c))
           d = 0
        endif
        bar = d*b
      end subroutine
      subroutine baz(c)
        real a, b, c ,d
        read *, a
! Same as above but with spaces restored and construct names added
        first_if: if ( a .gt. 0 ) then
           b = c/a
           second_if: if (b .gt. 0) then
              d = 1.0
           end if second_if
        else if (c .gt. 0) then firstif
           b = a/c
           d = -1.0
        else first_if
           b = abs (max (a, c))
           d = 0
        end if
        print *, a, b, c, d
      end subroutine bazz