OSDN Git Service

2013-04-03 Tobias Burnus <burnus@net-b.de>
[pf3gnuchains/gcc-fork.git] / gcc / testsuite / gfortran.dg / fmt_cache_3.f90
1 ! { dg-do run }
2 !
3 ! PR fortran/56737
4 !
5 ! Contributed by Jonathan Hogg
6 !
7 module hsl_mc73_single
8    implicit none
9    integer, parameter, private :: wp = kind(0.0)
10 contains
11    subroutine mc73_fiedler(n,lirn,irn,ip,list)
12       integer,  intent (in) :: n
13       integer,  intent (in) :: lirn
14       integer,  intent (in) :: irn(*)
15       integer,  intent (in) :: ip(*)
16       integer, intent (out) :: list(*)
17
18       integer :: icntl(10)
19
20       call fiedler_graph(icntl)
21    end subroutine mc73_fiedler
22
23    subroutine mc73_order
24       integer :: icntl(10)
25
26       call fiedler_graph(icntl)
27    end subroutine mc73_order
28
29    subroutine fiedler_graph(icntl)
30       integer,  intent (in) :: icntl(10)
31
32       real (kind = wp)  :: tol
33       real (kind = wp)  :: tol1
34       real (kind = wp)  :: rtol
35
36       call multilevel_eig(tol,tol1,rtol,icntl)
37    end subroutine fiedler_graph
38
39    subroutine multilevel_eig(tol,tol1,rtol,icntl)
40       real (kind = wp), intent (in) :: tol,tol1,rtol
41       integer,  intent(in) :: icntl(10)
42
43       call level_print(6,'end of level ',1)
44    end subroutine multilevel_eig
45
46    subroutine level_print(mp,title1,level)
47       character (len = *), intent(in) :: title1
48       integer,  intent(in) :: mp,level
49       character(len=80) fmt
50       integer :: char_len1,char_len2
51
52       char_len1=len_trim(title1)
53
54       write (fmt,"('(',i4,'(1H ),6h===== ,a',i4,',i4,6h =====)')") &
55            level*3, char_len1
56 !      print *, "fmt = ", fmt
57 !      print *, "title1= ", title1
58 !      print *, "level = ", level
59       write (66,fmt) title1,level
60    end subroutine level_print
61 end module hsl_mc73_single
62
63 program test
64    use hsl_mc73_single
65    implicit none
66    character(len=200) :: str(2)
67    integer, parameter :: wp = kind(0.0)
68
69    integer :: n, lirn
70    integer :: irn(1), ip(1), list(1)
71
72    str = ""
73    open (66, status='scratch')
74    call mc73_order
75    call mc73_fiedler(n,lirn,irn,ip,list)
76    rewind (66)
77    read (66, '(a)') str
78    close (66)
79    if (any (str /= "   ===== end of level   1 =====")) call abort()
80 end program test