1! { dg-do run }
2!
3! PR fortran/56737
4!
5! Contributed by Jonathan Hogg
6!
7module hsl_mc73_single
8   implicit none
9   integer, parameter, private :: wp = kind(0.0)
10contains
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
61end module hsl_mc73_single
62
63program 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()
80end program test
81