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