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