module cc_restriction_module

  use bl_constants_module
  use bl_error_module
  use bl_types

  implicit none

contains

  subroutine cc_restriction_1d(cc, loc, ff, lof, lo, hi, ir)
    integer,     intent(in)    :: loc(:)
    integer,     intent(in)    :: lof(:)
    integer,     intent(in)    :: lo(:), hi(:)
    real (dp_t), intent(inout) :: cc(loc(1):)
    real (dp_t), intent(in)    :: ff(lof(1):)
    integer,     intent(in)    :: ir(:)

    real (dp_t) :: fac
    integer     :: i, l

    fac = one/real(product(ir),kind=dp_t)

    do i = lo(1), hi(1)
       cc(i) = zero
       do l = 0, ir(1)-1
          cc(i) = cc(i) + ff(ir(1)*i+l)
       end do
       cc(i) = cc(i)*fac
    end do

  end subroutine cc_restriction_1d

  subroutine cc_restriction_2d(cc, loc, ff, lof, lo, hi, ir)
    integer,     intent(in)    :: loc(:)
    integer,     intent(in)    :: lof(:)
    integer,     intent(in)    :: lo(:), hi(:)
    real (dp_t), intent(inout) :: cc(loc(1):,loc(2):)
    real (dp_t), intent(in)    :: ff(lof(1):,lof(2):)
    integer,     intent(in)    :: ir(:)

    real (dp_t) :: fac
    integer     :: i, j, l, m, twoi, twoj, twoip1, twojp1

    if ( ir(1) == 2 .and. ir(2) == 2 ) then

       do j = lo(2), hi(2)
             twoj   = 2*j
             twojp1 = 2*j+1

          do i = lo(1), hi(1)
             twoi   = 2*i
             twoip1 = 2*i+1

             cc(i,j) = FOURTH * ( ff(twoi,twoj) + ff(twoip1,twoj) + ff(twoi,twojp1) + ff(twoip1,twojp1) )
          end do
       end do

    else

       fac = one/real(product(ir),kind=dp_t)

       do j = lo(2), hi(2)
          do i = lo(1), hi(1)
             cc(i,j) = zero
             do m = 0, ir(2)-1
                do l = 0, ir(1)-1
                   cc(i,j) = cc(i,j) + ff(ir(1)*i+l,ir(2)*j+m)
                end do
             end do
             cc(i,j) = cc(i,j)*fac
          end do
       end do

    end if

  end subroutine cc_restriction_2d

  subroutine cc_restriction_3d(cc, loc, ff, lof, lo, hi, ir)
    integer,     intent(in)    :: loc(:)
    integer,     intent(in)    :: lof(:)
    integer,     intent(in)    :: lo(:),hi(:)
    real (dp_t), intent(inout) :: cc(loc(1):,loc(2):,loc(3):)
    real (dp_t), intent(in)    :: ff(lof(1):,lof(2):,lof(3):)
    integer,     intent(in)    :: ir(:)

    real (dp_t) :: fac
    integer     :: i, j, k, l, m, n, twoi, twoj, twoip1, twojp1, twok, twokp1

    if ( ir(1) == 2 .and. ir(2) == 2 .and. ir(3) == 2 ) then

       do k = lo(3),hi(3)
          twok   = 2*k
          twokp1 = 2*k+1

          do j = lo(2),hi(2)
             twoj   = 2*j
             twojp1 = 2*j+1

             do i = lo(1),hi(1)
                twoi   = 2*i
                twoip1 = 2*i+1

                cc(i,j,k) = EIGHTH * ( &
                     ff(twoi,   twoj,   twok  ) + &
                     ff(twoip1, twoj,   twok  ) + &
                     ff(twoi,   twojp1, twok  ) + &
                     ff(twoip1, twojp1, twok  ) + &
                     ff(twoi,   twoj,   twokp1) + &
                     ff(twoip1, twoj,   twokp1) + &
                     ff(twoi,   twojp1, twokp1) + &
                     ff(twoip1, twojp1, twokp1) )
             end do
          end do
       end do

    else

       fac = one/real(product(ir),kind=dp_t)

       do k = lo(3),hi(3)
          do j = lo(2),hi(2)
             do i = lo(1),hi(1)
                cc(i,j,k) = zero
                do n = 0, ir(3)-1
                   do m = 0, ir(2)-1
                      do l = 0, ir(1)-1
                         cc(i,j,k) = cc(i,j,k) + ff(ir(1)*i+l,ir(2)*j+m,ir(3)*k+n)
                      end do
                   end do
                end do
                cc(i,j,k) = cc(i,j,k)*fac
             end do
          end do
       end do

    end if

  end subroutine cc_restriction_3d

  subroutine edge_restriction_1d(cc, loc, ff, lof, lo, hi, ir)
    integer,     intent(in)    :: loc(:)
    integer,     intent(in)    :: lof(:)
    integer,     intent(in)    :: lo(:), hi(:)
    real (dp_t), intent(inout) :: cc(loc(1):)
    real (dp_t), intent(in)    :: ff(lof(1):)
    integer,     intent(in)    :: ir(:)

    integer :: i

    do i = lo(1), hi(1)
       cc(i) = ff(ir(1)*i)
    end do

  end subroutine edge_restriction_1d

  subroutine edge_restriction_2d(cc, loc, ff, lof, lo, hi, ir, face)
    integer,     intent(in)    :: loc(:)
    integer,     intent(in)    :: lof(:)
    integer,     intent(in)    :: lo(:), hi(:)
    integer,     intent(in)    :: face
    real (dp_t), intent(inout) :: cc(loc(1):,loc(2):)
    real (dp_t), intent(in)    :: ff(lof(1):,lof(2):)
    integer,     intent(in)    :: ir(:)

    real (dp_t) :: fac
    integer     :: i, j, l, m

    fac = one

    if (face .eq. 1) then
       fac = fac/real(ir(2),kind=dp_t)
    else if (face .eq. 2) then
       fac = fac/real(ir(1),kind=dp_t)
    else
       call bl_error('edge_restriction_2d: face must be 1 or 2')
    end if

    if ( face .eq. 1 ) then
       do j = lo(2), hi(2)
          do i = lo(1), hi(1)
             cc(i,j) = zero
             do m = 0, ir(2)-1
                cc(i,j) = cc(i,j) + ff(ir(1)*i,ir(2)*j+m)
             end do
             cc(i,j) = cc(i,j)*fac
          end do
       end do
    else if ( face .eq. 2 ) then
       do j = lo(2), hi(2)
          do i = lo(1), hi(1)
             cc(i,j) = zero
             do l = 0, ir(1)-1
                cc(i,j) = cc(i,j) + ff(ir(1)*i+l,ir(2)*j)
             end do
             cc(i,j) = cc(i,j)*fac
          end do
       end do
    end if

  end subroutine edge_restriction_2d

  subroutine edge_restriction_3d(cc, loc, ff, lof, lo, hi, ir, face)
    integer,     intent(in)    :: loc(:)
    integer,     intent(in)    :: lof(:)
    integer,     intent(in)    :: lo(:),hi(:)
    integer,     intent(in)    :: face
    real (dp_t), intent(inout) :: cc(loc(1):,loc(2):,loc(3):)
    real (dp_t), intent(in)    :: ff(lof(1):,lof(2):,lof(3):)
    integer,     intent(in)    :: ir(:)

    real (dp_t) :: fac
    integer     :: i, j, k, l, m, n

    fac = one

    if ( face .eq. 1 ) then
       fac = fac/real(ir(2)*ir(3),kind=dp_t)
    else if (face .eq. 2) then
       fac = fac/real(ir(1)*ir(3),kind=dp_t)
    else if (face .eq. 3) then
       fac = fac/real(ir(1)*ir(2),kind=dp_t)
    else
       call bl_error('edge_restriction_3d: face must be 1, 2 or 3')
    end if

    if ( face .eq. 1 ) then
       do k = lo(3),hi(3)
          do j = lo(2),hi(2)
             do i = lo(1),hi(1)
                cc(i,j,k) = zero
                do n = 0, ir(3)-1
                   do m = 0, ir(2)-1
                      cc(i,j,k) = cc(i,j,k) + ff(ir(1)*i,ir(2)*j+m,ir(3)*k+n)
                   end do
                end do
                cc(i,j,k) = cc(i,j,k)*fac
             end do
          end do
       end do
    else if ( face .eq. 2 ) then
       do k = lo(3),hi(3)
          do j = lo(2),hi(2)
             do i = lo(1),hi(1)
                cc(i,j,k) = zero
                do n = 0, ir(3)-1
                   do l = 0, ir(1)-1
                      cc(i,j,k) = cc(i,j,k) + ff(ir(1)*i+l,ir(2)*j,ir(3)*k+n)
                   end do
                end do
                cc(i,j,k) = cc(i,j,k)*fac
             end do
          end do
       end do
    else if ( face .eq. 3 ) then
       do k = lo(3),hi(3)
          do j = lo(2),hi(2)
             do i = lo(1),hi(1)
                cc(i,j,k) = zero
                do m = 0, ir(2)-1
                   do l = 0, ir(1)-1
                      cc(i,j,k) = cc(i,j,k) + ff(ir(1)*i+l,ir(2)*j+m,ir(3)*k)
                   end do
                end do
                cc(i,j,k) = cc(i,j,k)*fac
             end do
          end do
       end do
    end if

  end subroutine edge_restriction_3d

end module cc_restriction_module


      program prog
      complex zero, one_two, three_four
      parameter(zero=(0.0e+0,0.0e+0))
      parameter(three=3)
      parameter(four=three+1)
      parameter(one_two=(1.0e+0,2.0e+0), three_four=(three,four))
      write(6, *) zero
      write(6, *) one_two
      write(6, *) three_four
      end


module mesh
  ! ############################################################################
  ! Create the cell indexing for the problem
  ! ############################################################################

  use control, only : dp

  implicit none

  real(kind=dp) :: &
      width_x,   & ! Total width of the problem in x direction
      width_y      ! Total width of the problem in y direction
  real(kind=dp), allocatable, dimension(:) :: &
      dx,         & ! Width of each cell in EW direction
      dy            ! Width of each cell in NS direction
  integer, allocatable, dimension(:) :: &
      mMap          ! Material within each cell

  contains

  ! Compute the cell size and material map for the problem
  subroutine create_mesh()
    ! ##########################################################################
    ! Compute the widths of each cell and the total number of cells
    ! ##########################################################################

    ! Use Statements
    use control, only : number_cells, number_cells_x, number_cells_y, fine_mesh_x, &
                        fine_mesh_y, coarse_mesh_x, coarse_mesh_y, material_map, &
                        spatial_dimension, boundary_north, boundary_south

    ! Variable definitions
    real(kind=dp) :: &
        ddx, & ! Temporary variable for x cell width
        ddy    ! Temporary variable for y cell width
    integer :: &
        nx,  & ! number of coarse mesh regions in x direction
        ny,  & ! number of coarse mesh regions in y direction
        c,   & ! counting index for total cells
        cx,  & ! counting index for x cells
        cy,  & ! counting index for y cells
        ix,  & ! coarse cell index for x cells
        iy,  & ! coarse cell index for y cells
        jx,  & ! fine cell index for x cells
        jy     ! fine cell index for y cells

    ! Check for 1D problem
    if (spatial_dimension == 1) then
      ! Set the y direction to a single spatial cell with reflective contitions
      boundary_north = 1.0_8
      boundary_south = 1.0_8

      if (allocated(fine_mesh_y)) deallocate(fine_mesh_y)
      if (allocated(coarse_mesh_y)) deallocate(coarse_mesh_y)

      allocate(fine_mesh_y(1), coarse_mesh_y(2))
      fine_mesh_y(1) = 1
      coarse_mesh_y = [0.0_8, 1.0_8]

    end if

    nx = size(fine_mesh_x)  ! Number of coarse mesh regions in x
    ny = size(fine_mesh_y)  ! Number of coarse mesh regions in x

    number_cells_x = sum(fine_mesh_x)
    number_cells_y = sum(fine_mesh_y)
    number_cells = number_cells_x * number_cells_y
    allocate(dx(number_cells_x), dy(number_cells_y), mMap(number_cells))

    ! Compute the mesh widths and read materials
    c = 1  ! Initialize counting variable for all cells
    cy = 1  ! Initialize counting variable for y cells

    do iy = 1, ny  ! Loop over the coarse y cells
      ddy = (coarse_mesh_y(iy+1) - coarse_mesh_y(iy)) / fine_mesh_y(iy)
      do jy = 1, fine_mesh_y(iy)  ! Loop over the fine y cells in region iy
        cx = 1  ! Initialize counting variable for x cells
        do ix = 1, nx  ! Loop over the coarse x cells
          ddx = (coarse_mesh_x(ix+1) - coarse_mesh_x(ix)) / fine_mesh_x(ix)
          do jx = 1, fine_mesh_x(ix)  ! Loop over the fine x cells in region ix
            mMap(c) = material_map((iy - 1) * nx + ix)
            dx(cx) = ddx  ! Store cell size in x direction
            cx = cx + 1  ! Increment x cells
            c = c + 1  ! Increment all cells
          end do  ! End jx loop
        end do  ! End ix loop
        dy(cy) = ddy  ! Store cell size in y direction
        cy = cy + 1  ! Increment y cells
      end do  ! End jy loop
    end do  ! End iy loop

    ! Store the total width of the problem
    width_x = coarse_mesh_x(nx + 1) - coarse_mesh_x(1)
    width_y = coarse_mesh_y(ny + 1) - coarse_mesh_y(1)

  end subroutine create_mesh

  subroutine finalize_mesh()
    ! ##########################################################################
    ! Deallocate any used arrays
    ! ##########################################################################

    if (allocated(dx)) then
      deallocate(dx)
    end if
    if (allocated(dy)) then
      deallocate(dy)
    end if
    if (allocated(mMap)) then
      deallocate(mMap)
    end if
  end subroutine finalize_mesh

end module mesh


      program toder

      implicit real*8(a-h,o-z)

      integer NN, NNELEM, IA(200), JA(5000), ierr
      real*8  A(5000), b(200)
      integer nfirst,iperm(200),mask(200),riord(200),levels(200),
     *     nlev,maskval

      open(UNIT = 1, FILE = 'system2.bin', STATUS = 'unknown')
      write(*,*)'Chargement du systeme : SYSTEM2.BIN'

C     Dimensions du système :

      read(1,*) NN
      read(1,*) NNELEM
      write(*,*)'Dimension :',NN
      write(*,*)'NNZ       :',NNELEM

C      if((NN.NE.NELEM)) then
C         write(*,*)'Out of memory !'
C         write(*,*)'Dim. max =',N
C         write(*,*)'NNZ  max =',NELEM
C         ierr=1
C      else

C        Chargement de la matrice :

         do 11 j = 1,NNELEM
            read(1,*) A(j)
            read(1,*) JA(j)
11       continue
         do 12 j = 1,NN+1
            read(1,*) IA(j)
12       continue

C        Chargement du vecteur b :

         do 30 j = 1,NN
            read(1,*) b(j)
30       continue

C        Fermeture du fichier

         close (UNIT = 1)
         write(*,*)'Ok..'
         ierr=0
C      endif

      nfirst=1
      iperm(1)=0
      riord(1)=98
      do i=1,nn
         mask(i)=1
      enddo
      maskval=1

      call BFS(nn,ja,ia,nfirst,iperm,mask,maskval,riord,levels,
     *     nlev)
      open(UNIT = 1, FILE = 'perm.m', STATUS = 'unknown')
      do i=1,nn
         WRITE(1,*)'P(',i,')=',riord(i),';'
      enddo
      close(UNIT=1)
      end


!! R722 expr
!    is [ expr defined-binary-op ] level-5-expr
CHARACTER(LEN=10) :: H
LOGICAL :: a
INTEGER :: i
TYPE(set) :: s

s = (1 .intersect. 2) .UNION. (3 - 4)
a = 1 + 2 == 2 * 4
s = .inverse. (1 + 2)
a = ((1+2) .EQ. 3) .AND. ((3*4) .EQ. 12)
a = "E" // "G" == H (1:10)
i = 1 + 2 * 3
i = (1 + 2) * 3

end


!-----------------------------------------------------------------------
!     Subroutine:    drkhvg
!     Authors:       Y. Suzuki
!     Date:          12/28/2002
!     Description:   Sixth order 8-stage Runge-Kutta-Huta forumla.
!
! $Revision: 118 $
! $Id: drkhvg.f90 119 2011-12-13 01:11:13Z suzuki $
!
!    This subroutine is written by Y. Suzuki
!        at Graduate School of Energy Science (Kyoto Univ)
!         2002/12/28
!
!    Based program is wrtten by K. Hamamatsu
!        at Faculty of Science (Hiroshima Univ.)
!          1980/12/18
!
!  Runge-Kutta-Huta Formulas  ( Sixth order 8-stage )
!
!  " Improved Sixth-order Runge-kutta formulas and Approximate
!    Continuous Solution of Ordinary Differential Equation "
!  by D. Sarafyan:  J. Math. Anal. Appl. 40, 436-455 (1972)
!
!  Ported by S. Lazerson (lazerson@pppl.gov) 04/25/12
!
!-----------------------------------------------------------------------
subroutine drkhvg ( x0, y0, ln, h, lnx, fun, & !(in)
  &                 y,                       & !(inout)
  &                 icount, iout             & !(out)
  &               )

!-----------------------------------------------------------------------
!     Libraries (none)
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!     Input Parameters
!
!  y0(n)    real*8       initial value of y  ( start point )
!  n        integer*4    dimension of defferential equation
!  h        real*8       step size
!  f(n,nl)  real*8       work aray for calculation ( nl >= 9 )
!  y(n)     real*8       end point  ( if j=1, y(n)=y0(n) )
!  nx       integer*4    final value of x is h*(nx-1) ( end point )
!  icount   integer*4    end step
!  iout     integer*4    flag of calculation
!
!-----------------------------------------------------------------------
  implicit none
  integer, parameter :: ikind =  4,    &
    &                   rkind =  8,    &
    &                   dp    =  rkind
  integer(kind=ikind), intent(in) :: ln,  &
    &                                lnx
  integer(kind=ikind), intent(out) :: icount, &
    &                                 iout
  real(kind=rkind), intent(in) :: x0,    &
    &                             h,     &
    &                             y0(ln)
  real(kind=rkind), intent(out) :: y(ln,lnx)
!-----------------------------------------------------------------------
!     External Functions
!          fun           RHS of ODE
!-----------------------------------------------------------------------
  external fun
!-----------------------------------------------------------------------
!     Local Variables
!          i            Dummy Index
!-----------------------------------------------------------------------
  integer(kind=ikind) :: i
  real(kind=rkind) :: x,   &
    &                 x1,  &
    &                 c01, &
    &                 c02, &
    &                 c03, &
    &                 c04, &
    &                 c05, &
    &                 c06, &
    &                 c07, &
    &                 c08, &
    &                 c09, &
    &                 c10, &
    &                 c11, &
    &                 c12, &
    &                 c13, &
    &                 c14, &
    &                 c15, &
    &                 c16, &
    &                 c17, &
    &                 c18, &
    &                 c19, &
    &                 c20, &
    &                 c21, &
    &                 c22, &
    &                 c23, &
    &                 c24, &
    &                 c25, &
    &                 c26, &
    &                 c27
  real(kind=rkind), allocatable :: f(:,:)
!-----------------------------------------------------------------------
!     Begin Subroutine
!-----------------------------------------------------------------------

  if(ln > 0)then
     allocate(f(ln,9))
  end if

  c01 =  h / 9.0_rkind
  c02 =  h * 0.4166666666666667e-01_rkind
  c03 =  h * 0.125_rkind
  c04 =  h / 6.0_rkind
  c05 =  h * 0.5_rkind
  c06 =  h * 0.6666666666666667_rkind
  c07 =  h / 3.0_rkind
  c08 =  h * 0.375_rkind
  c09 =  h * 0.1333333333333333e+01_rkind
  c10 =  h * 0.3333333333333333e+01_rkind
  c11 =  h * 0.7e+01_rkind
  c12 =  h * 0.9666666666666667e+01_rkind
  c13 =  h * 0.1533333333333333e+02_rkind
  c14 =  h * 0.6111111111111111_rkind
  c15 =  h * 0.1166666666666667e+01_rkind
  c16 =  h * 0.1375e+01_rkind
  c17 =  h * 0.8333333333333333_rkind
  c18 =  h * 0.4390243902439024_rkind
  c19 =  h * 0.8780487804878049_rkind
  c20 =  h * 0.1304878048780488e+01_rkind
  c21 =  h * 0.2097560975609756e+01_rkind
  c22 =  h * 0.2963414634146341e+01_rkind
  c23 =  h * 0.4317073170731707e+01_rkind
  c24 =  h * 0.3214285714285714e-01_rkind
  c25 =  h * 0.4880952380952381e-01_rkind
  c26 =  h * 0.2571428571428571_rkind
  c27 =  h * 0.3238095238095238_rkind

  iout   =  0
  icount =  1
  y      =  0.0_rkind
  y(:,1) =  y0(:)
  f(:,1) =  y0(:)

  do i=2,lnx
!
!... 1-stage
!
     x  =  x0 + real(i-2, rkind) * h
     call fun(x, f(:,1), f(:,3), iout)
     if(iout == 1) return
     f(:,2) =  c01 * f(:,3) + f(:,1)
!
!... 2-stage
!
     x1 =  x + c01
     call fun(x1, f(:,2), f(:,4), iout)
     if(iout == 1) return
     f(:,2) =  c02 * f(:,3) + c03 * f(:,4) + f(:,1)
!
!... 3-stage
!
     x1 =  x + c04
     call fun(x1, f(:,2), f(:,5), iout)
     if(iout == 1) return
     f(:,2) =  c04 * f(:,3) - c05 * f(:,4) + c06 * f(:,5) + f(:,1)
!
!... 4-stage
!
     x1 =  x + c07
     call fun(x1, f(:,2), f(:,6), iout)
     if(iout == 1) return
     f(:,2) =  c03 * f(:,3) + c08 * f(:,6) + f(:,1)
!
!... 5-stage
!
     x1 =  x + c05
     call fun(x1, f(:,2), f(:,7), iout)
     if(iout == 1) return
     f(:,2) = -c09 * f(:,3) + c10 * f(:,7) - c11 * f(:,4) - c12 * f(:,6) &
       &    +  c13 * f(:,5) +       f(:,1)
!
!... 6-stage
!
     x1 =  x + c06
     call fun(x1, f(:,2), f(:,8), iout)
     if(iout == 1) return
     f(:,2) = -c01 * f(:,3) + c03 * f(:,8) + c14 * f(:,7) - c15 * f(:,5) &
       &    +  c16 * f(:,4) +       f(:,1)
!
!... 7-stage
!
     x1 =  x + c17
     call fun(x1, f(:,2), f(:,9), iout)
     if(iout == 1) return
     f(:,2) = -c18 * f(:,8) + c19 * f(:,9) +  c20 * f(:,3) - c21 * f(:,7) &
       &    -  c22 * f(:,4) + c23 * f(:,6) +        f(:,1)
!
!... 8-stage
!
     x1 =  x + h
     call fun(x1, f(:,2), f(:,4), iout)
     if(iout == 1) return
     f(:,1) = (f(:,6) + f(:,8)) * c24 + (f(:,3) + f(:,4)) * c25          &
       &    + (f(:,5) + f(:,9)) * c26 +           f(:,7)  * c27 + f(:,1)
     icount =  i
     y(:,i) =  f(:,1)
  end do

  deallocate(f)

  return
!-----------------------------------------------------------------------
!     End Subroutine
!-----------------------------------------------------------------------
end subroutine drkhvg