!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief This module contains functions to print out calculation settings

module fstr_debug_dump
  use m_fstr

  integer(kind=kint), save :: monolis_current_hash_size = 10
  integer(kind=kint), parameter :: monolis_hash_size(22) = (/&
  &     1021,     2039,      4093,      8191,     16381, &
  &    32749,    65521,    131071,    262139,    524287, &
  &  1048573,  2097143,   4194301,   8388593,  16777213, &
  & 33554393, 67108859, 134217689, 268435399, 536870909, 1073741789, 2147483647/)

  type type_monolis_hash_list
    integer(kind=kint) :: hash = 0
    character :: key*27 = "                           "
    integer(kind=kint) :: val  = 0
  end type type_monolis_hash_list

  type type_monolis_hash_bin
    integer(kind=kint) :: n = 0
    type(type_monolis_hash_list), pointer :: list(:) => null()
  end type type_monolis_hash_bin

  type type_monolis_hash_tree
    integer(kind=kint) :: n_put = 0
    integer(kind=kint) :: tree_size = 0
    type(type_monolis_hash_bin), pointer :: bin(:) => null()
  end type type_monolis_hash_tree

  type(type_monolis_hash_tree), save :: monolis_hash_tree

contains

  subroutine hecmw_tet_tet2(hecMESH, fstrPARAM)
    use fstr_setup_util
    use mContact
    implicit none
    type(hecmwST_local_mesh) :: hecMESH
    type(fstr_param) :: fstrPARAM
    type(fstr_info_contactChange) :: infoCTChange
    integer(kind=kint) :: i, j, k, is_tet_tet2, nnode_old, nelem_old
    integer(kind=kint) :: itype, ic_type, icel, iS, iE, iiS, in, jn, nn
    integer(kind=kint) :: nnode, nelem, i1, i2, i3, nmin, nmax, newid, itable(3,6), nid(6)
    integer(kind=kint) :: enode(20), lenode(20)
    integer(kind=kint), allocatable :: hexid(:), hexelem(:,:), itemp1(:), itemp2(:,:), output_id(:)
    real(kind=kreal),   allocatable :: tmp(:), hexnode(:,:), rtemp(:)
    logical :: is_341, is_pushed, is_exist
    logical, allocatable :: is_output_id(:)
    character :: citer*4, c1*9, c2*9, c3*9, cl1*13, cl2*13, ckey*27
    character(len=HECMW_NAME_LEN) :: gname, fname

    call hecmw_ctrl_is_tet_tet2(is_tet_tet2)

    if(is_tet_tet2 == 1)then
      if(hecMESH%my_rank == 0) write(*,"(a)")"** TET_TET2 conversion"
      if(hecMESH%my_rank /= 0) stop &
      & "error: parallel computation of tet_tet2 conversion is not supported."

      is_341 = .false.
      do itype = 1, hecMESH%n_elem_type
        ic_type = hecMESH%elem_type_item(itype)
        if(ic_type == 341)then
          is_341 = .true.
        else
          stop "ERROR: TET_TET2 is available for only TET mesh"
        endif
      enddo

      call monolis_hash_init()

      nmax = maxval(hecMESH%global_node_ID)

      itable(1,1) = 2; itable(2,1) = 3
      itable(1,2) = 3; itable(2,2) = 1
      itable(1,3) = 1; itable(2,3) = 2
      itable(1,4) = 1; itable(2,4) = 4
      itable(1,5) = 2; itable(2,5) = 4
      itable(1,6) = 3; itable(2,6) = 4

      jn = 0
      newid = 0
      do itype = 1, hecMESH%n_elem_type
        iS = hecMESH%elem_type_index(itype-1) + 1
        iE = hecMESH%elem_type_index(itype  )
        ic_type = hecMESH%elem_type_item(itype)
        nn = hecmw_get_max_node(ic_type)

        if(ic_type == 341)then
          nelem = iE - iS + 1
          allocate(hexnode(3,6*nelem))
          allocate(hexid  (  6*nelem))
          allocate(hexelem(10, nelem))
          allocate(is_output_id(6*nelem))
          allocate(output_id(6*nelem))
          hexnode = 0.0d0
          hexid = 0
          hexelem = 0
          output_id = 0
          is_output_id = .true.

          do icel = iS, iE
            jn = jn + 1
            iiS = hecMESH%elem_node_index(icel-1)
            do j = 1, nn
              k = hecMESH%elem_node_item (iiS+j)
               enode(j) = hecMESH%global_node_ID(k)
              lenode(j) = k
            enddo

            do i = 1, 6
              i1 = lenode(itable(1, i))
              i2 = lenode(itable(2, i))
              if(i2 < i1)then
                in = i2
                i2 = i1
                i1 = in
              endif
              write(cl1,"(i13.13)")i1
              write(cl2,"(i13.13)")i2
              ckey = cl1//cl2//" "

              is_exist = .false.
              call monolis_hash_get(ckey, in, is_exist)
              if(is_exist)then
                !hexid(newid) = in
                nid(i) = in
                is_output_id(newid) = .false.
              else
                newid = newid + 1
                nid(i) = hecMESH%n_node + newid
                !hexid(newid) = nmax + newid
                hexnode(1,newid) = (hecMESH%node(3*i1-2) + hecMESH%node(3*i2-2))/2.0d0
                hexnode(2,newid) = (hecMESH%node(3*i1-1) + hecMESH%node(3*i2-1))/2.0d0
                hexnode(3,newid) = (hecMESH%node(3*i1  ) + hecMESH%node(3*i2  ))/2.0d0
                call monolis_hash_push(ckey, nid(i), is_pushed, is_exist)
              endif
            enddo

            hexelem( 1,jn) = lenode(1)
            hexelem( 2,jn) = lenode(2)
            hexelem( 3,jn) = lenode(3)
            hexelem( 4,jn) = lenode(4)
            hexelem( 5,jn) = nid(3)
            hexelem( 6,jn) = nid(1)
            hexelem( 7,jn) = nid(2)
            hexelem( 8,jn) = nid(4)
            hexelem( 9,jn) = nid(5)
            hexelem(10,jn) = nid(6)
          enddo
        endif
      enddo

      nnode_old = hecMESH%n_node

      !> count node
      nmin = minval(hexelem)
      nmax = maxval(hexelem)
      allocate(itemp1(nmin:nmax)); itemp1 = 0
      do i = 1, nelem
        do j = 1, 10
          in = hexelem(j,i)
          itemp1(in) = 1
        enddo
      enddo

      nnode = 0
      do i = nmin, nmax
        if(itemp1(i) == 1) nnode = nnode + 1
      enddo
      deallocate(itemp1)

      !> node section
      hecMESH%n_node = nnode
      hecMESH%n_node_gross = nnode
      hecMESH%nn_middle = nnode
      hecMESH%nn_internal = nnode

      deallocate(hecMESH%node_ID)
      allocate(hecMESH%node_ID(2*nnode)); hecMESH%node_ID = 0
      do i = 1, nnode
        hecMESH%node_ID(2*i-1) = i
      enddo

      nmax = maxval(hecMESH%global_node_ID)
      allocate(itemp1(nnode_old)); itemp1 = hecMESH%global_node_ID
      deallocate(hecMESH%global_node_ID)
      allocate(hecMESH%global_node_ID(nnode)); hecMESH%global_node_ID = 0
      do i = 1, nnode_old
        hecMESH%global_node_ID(i) = itemp1(i)
      enddo

      in = 1
      do i = nnode_old+1, nnode
        hecMESH%global_node_ID(i) = nmax + in
        in = in + 1
      enddo
      deallocate(itemp1)

      allocate(rtemp(3*nnode_old)); rtemp = 0.0d0
      do i = 1, nnode_old
        rtemp(3*i-2) = hecMESH%node(3*i-2)
        rtemp(3*i-1) = hecMESH%node(3*i-1)
        rtemp(3*i  ) = hecMESH%node(3*i  )
      enddo
      deallocate(hecMESH%node)
      allocate(hecMESH%node(3*nnode)); hecMESH%node = 0.0d0
      do i = 1, nnode_old
        hecMESH%node(3*i-2) = rtemp(3*i-2)
        hecMESH%node(3*i-1) = rtemp(3*i-1)
        hecMESH%node(3*i  ) = rtemp(3*i  )
      enddo
      deallocate(rtemp)

      in = nnode_old + 1
      do i = 1, nnode - nnode_old
        hecMESH%node(3*in-2) = hexnode(1,i)
        hecMESH%node(3*in-1) = hexnode(2,i)
        hecMESH%node(3*in  ) = hexnode(3,i)
        in = in + 1
      enddo

      allocate(itemp1(0:nnode_old)); itemp1 = hecMESH%node_init_val_index
      deallocate(hecMESH%node_init_val_index)
      allocate(hecMESH%node_init_val_index(0:nnode)); hecMESH%node_init_val_index = 0
      do i = 1, nnode_old
        hecMESH%node_init_val_index(i) = itemp1(i)
      enddo

      do i = nnode_old+1, nnode
        hecMESH%node_init_val_index(i) = 0
      enddo
      deallocate(itemp1)

      !> element section
      deallocate(hecMESH%elem_node_index)
      deallocate(hecMESH%elem_node_item)
      allocate(hecMESH%elem_node_index(0:hecMESH%n_elem)); hecMESH%elem_node_index = 0
      allocate(hecMESH%elem_node_item(10*hecMESH%n_elem)); hecMESH%elem_node_item = 0

      do i = 1, hecMESH%n_elem
        hecMESH%elem_node_index(i) = 10*i
      enddo

      in = nnode_old + 1
      do i = 1, 6*nelem
        if(is_output_id(i))then
          output_id(i) = in
          in = in + 1
        endif
      enddo

      in = 1
      do i = 1, hecMESH%n_elem
        do j = 1, 10
          hecMESH%elem_node_item(in) = hexelem(j,i)
          in = in + 1
        enddo
      enddo

      hecMESH%elem_type_item = 342
      hecMESH%elem_type = 342

      call monolis_hash_finalize()

      deallocate(hexnode)
      deallocate(hexid  )
      deallocate(hexelem)
      deallocate(is_output_id)
      deallocate(output_id)
    endif
  end subroutine hecmw_tet_tet2

  subroutine fstr_mesh_doctor(hecMESH, hecMAT, fstrSOLID, fstrRESULT)
    use m_fstr
    use m_hecmw_matrix_ordering_METIS
    use m_hecmw_matrix_get_fillin
    use hecmw_matrix_reorder
    use m_hecmw2fstr_mesh_conv
    use hecmw_util
    implicit none
    type (hecmwST_local_mesh) :: hecMESH
    type (hecmwST_matrix )    :: hecMAT
    type (hecmwST_matrix)     :: hecT
    type (fstr_solid )        :: fstrSOLID
    type(hecmwST_result_data) :: fstrRESULT
    integer(kind=kint ) :: N, NP, NDOF, NNDOF
    integer(kind=kint ) :: ITERlog, TIMElog
    integer(kind=kint) :: NPU, NPL, nS
    integer(kind=kint) :: i, j, k, in, iS, iE, jn, jS, jE, is_checked
    integer(kind=kint) :: itype, icel, ic_type, is_elem
    integer(kind=kint) :: minv, maxv, domid, iiS, isect, cid
    integer(kind=kint) :: ig0, ig, ik, ityp, idofS, idofE, iS0, iE0, ntemp(10)
    real(kind=kreal) :: t1, t2
    real(kind=kreal) :: rho, ee, pp
    real(kind=kreal) :: alpo(3), ina
    integer(kind=kint), pointer :: idxUp(:)  => null()
    integer(kind=kint), pointer :: itemUp(:) => null()
    integer(kind=kint), pointer :: idxU(:)  => null()
    integer(kind=kint), pointer :: itemU(:) => null()
    integer(kind=kint), pointer :: perm(:)  => null()
    integer(kind=kint), pointer :: iperm(:) => null()
    integer(kind=kint), pointer :: ifill(:) => null()
    integer(kind=kint), allocatable :: domain_id(:), elem_id(:)
    integer(kind=kint), allocatable :: temp(:)
    real(kind=kreal), pointer :: AU(:) => null()
    real(kind=kreal), pointer :: AD(:) => null()
    logical :: ierr

    write(*,*)""
    if(myrank == 0) write(*,*)"** mesh doctor"

    if(hecmw_comm_get_size() /= 1)then
      if(myrank == 0) write(*,*)"** error: this routine is only for a entire domain"
      stop
    endif

    N      = hecMAT%N
    NP     = hecMAT%NP
    NDOF   = hecMAT%NDOF
    NNDOF  = N * NDOF
    myrank = hecMESH%my_rank

    t1 = HECMW_WTIME()
    allocate( perm(NP))
    allocate(iperm(NP))
    call hecmw_matrix_ordering_METIS_from_MAT(NP, hecMAT%NPU, hecMAT%indexL, hecMAT%itemL, &
         hecMAT%indexU, hecMAT%itemU, perm, iperm)
    t2 = HECMW_WTIME()
    if(myrank == 0) write(*,"(a,1pe11.4)")"    * metis      time: ", t2-t1

    t1 = HECMW_WTIME()
    call hecmw_matrix_reorder_matrix(hecMESH, hecMAT, hecT, perm, iperm)
    t2 = HECMW_WTIME()
    if(myrank == 0) write(*,"(a,1pe11.4)")"    * reordering time: ", t2-t1

    !> find some element which has rigid body module
    t1 = HECMW_WTIME()
    call hecmw_matrix_get_fillin_bin(hecMESH, hecT%N, hecT%indexU, hecT%itemU, idxU, itemU, NPU)
    t2 = HECMW_WTIME()
    if(myrank == 0) write(*,"(a,1pe11.4)")"    * fill-in    time: ", t2-t1

    t1 = HECMW_WTIME()
    allocate(domain_id(N))
    domain_id = 0

    do
      is_checked = 0
      aa:do i=N,1,-1
        nS = i-1
        if(domain_id(i) == 0)then
          domain_id(i) = i
          is_checked = 1
          exit aa
        endif
      enddo aa
      if(is_checked == 0) exit

      do i=nS,1,-1
        if(domain_id(i) /= 0) cycle
        jS = idxU(i-1)+2
        jE = idxU(i)
        if(jS <= jE)then
          in = jS + 1
          domain_id(i) = domain_id(itemU(in))
        endif
      enddo
    enddo

!> find a dominant domain
    minv = minval(domain_id)
    maxv = maxval(domain_id)
    allocate(temp(minv:maxv))

    temp = 0
    do i=1,N
      in = domain_id(i)
      temp(in) = temp(in) + 1
    enddo
    in = maxloc(temp,1)
    domid = minv+in-1
    !write(*,*)"maxloc", in, domid
    deallocate(temp)

    allocate(temp(N))
    temp = 0
    do i=1,N
      temp(i) = domain_id(i)
    enddo
    do i=1,N
      in = iperm(i)
      domain_id(i) = temp(in)
    enddo
    deallocate(temp)

!> find some element which has rigid body mode
    allocate(elem_id(hecMESH%n_elem))
    allocate(temp(N))
    elem_id = 0
    temp = 0

    do itype=1, hecMESH%n_elem_type
      iS=hecMESH%elem_type_index(itype-1) + 1
      iE=hecMESH%elem_type_index(itype  )
      ic_type=hecMESH%elem_type_item(itype)
      do icel=iS,iE
        iiS=hecMESH%elem_node_index(icel-1)
        is_elem = 1
        do j=1,hecmw_get_max_node(ic_type)
          if(domain_id(hecMESH%elem_node_item(iiS+j)) /= domid) is_elem = 0
        enddo

        if(is_elem == 1)then
          elem_id(icel) = 1
          do j=1,hecmw_get_max_node(ic_type)
            in = hecMESH%elem_node_item(iiS+j)
            temp(in) = temp(in) + 1
          enddo
        endif
      enddo
    enddo

    do itype=1, hecMESH%n_elem_type
      iS=hecMESH%elem_type_index(itype-1) + 1
      iE=hecMESH%elem_type_index(itype  )
      ic_type=hecMESH%elem_type_item(itype)
      do icel=iS,iE
        iiS=hecMESH%elem_node_index(icel-1)
        if(elem_id(icel) == 1)then
          jn = 0
          do j=1,hecmw_get_max_node(ic_type)
            in = hecMESH%elem_node_item(iiS+j)
            jn = jn + temp(in)
          enddo
          if(ic_type == 342)then
            if(jn < hecmw_get_max_node(ic_type)+6) elem_id(icel) = 0
          elseif(ic_type == 361)then
            if(jn < hecmw_get_max_node(ic_type)+4) elem_id(icel) = 0
          else
            if(jn < hecmw_get_max_node(ic_type)+3) elem_id(icel) = 0
          endif
        endif
      enddo
    enddo

    deallocate(temp)

!> output section

    call hecmw_ctrl_make_subdir(adjustl("output/test.msh"), i)

    if(.true.)then
      open(50,file="output/mesh.msh", status="replace")
        !> node
        write(50,"(a)")"!NODE"
        do i=1,N
          if(domain_id(i) == domid) write(50,"(i0,a,1pe12.5,a,1pe12.5,a,1pe12.5)")hecMESH%global_node_ID(i),",",&
          & hecMESH%node(3*i-2),",",hecMESH%node(3*i-1),",",hecMESH%node(3*i)
        enddo

        !> elem
        do itype=1, hecMESH%n_elem_type
          iS=hecMESH%elem_type_index(itype-1) + 1
          iE=hecMESH%elem_type_index(itype  )
          ic_type=hecMESH%elem_type_item(itype)
          write(50,"(a,i0)")"!ELEMENT,TYPE=",ic_type
          do icel=iS,iE
            iiS=hecMESH%elem_node_index(icel-1)
            if(elem_id(icel) == 1)then
              write(50,"(i0,$)")hecMESH%global_elem_ID(icel)
              if(ic_type == 342)then
                do j=1,hecmw_get_max_node(ic_type)
                  ntemp(j) = hecMESH%global_node_ID(hecMESH%elem_node_item(iiS+j))
                enddo
                  write(50,"(a,i0,a,i0,a,i0,a,i0,a,i0,a,i0,a,i0,a,i0,a,i0,a,i0)")",",ntemp(1),",",ntemp(2),",",ntemp(3),",", &
                  & ntemp(4),",",ntemp(6),",",ntemp(7),",",ntemp(5),",",ntemp(8),",",ntemp(9),",",ntemp(10)
              else
                do j=1,hecmw_get_max_node(ic_type)
                  write(50,"(a,i0,$)")",",hecMESH%global_node_ID(hecMESH%elem_node_item(iiS+j))
                enddo
                write(50,*)
              endif
            endif
          enddo
        enddo

        !> elem group
        do i=1,hecMESH%n_elem
          if(elem_id(i) == 1)then
            write(50,"(a,i0)")"!EGROUP, EGRP=E",hecMESH%global_elem_ID(i)
            write(50,"(i0)")hecMESH%global_elem_ID(i)
          endif
        enddo

        !> section
        do i=1,hecMESH%n_elem
          if(elem_id(i) == 1)then
            write(50,"(a,i0,a,i0)")"!SECTION, TYPE=SOLID, EGRP=E",hecMESH%global_elem_ID(i),", MATERIAL=M",hecMESH%global_elem_ID(i)
          endif
        enddo

        !> material
        do i=1,hecMESH%n_elem
          if(elem_id(i) == 1)then
            isect = hecMESH%section_ID(i)
            cid   = hecMESH%section%sect_mat_ID_item(isect)
            ee    = fstrSOLID%materials(cid)%variables(M_YOUNGS)
            pp    = fstrSOLID%materials(cid)%variables(M_POISSON)
            rho   = fstrSOLID%materials(cid)%variables(M_DENSITY)
            write(50,"(a,i0,a)")"!MATERIAL, NAME=M",hecMESH%global_elem_ID(i),", ITEM=2"
            write(50,"(a)")"!ITEM=1, SUBITEM=2"
            write(50,"(1pe12.5,a,1pe12.5)")ee, ",", pp
            write(50,"(a)")"!ITEM=2, SUBITEM=1"
            write(50,"(1pe12.5)")rho
          endif
        enddo

        !> initial condition
        if(1 < size(hecMESH%node_init_val_item))then
          write(50,"(a)")"!INITIAL CONDITION, TYPE=TEMPERATURE"
          do i=1,size(hecMESH%node_init_val_item)
            if(domain_id(i) == domid)then
              in = hecMESH%node_init_val_index(i)
              write(50,"(i0,a,1pe12.5)")hecMESH%global_node_ID(i),",",hecMESH%node_init_val_item(in)
            endif
          enddo
        endif

        write(50,"(a)")"!END"

      close(50)

      if(.true.)then
        call hecmw_nullify_result_data(fstrRESULT)
        fstrRESULT%nn_component = 0
        fstrRESULT%ne_component = 1
        allocate(fstrRESULT%ne_dof(1))
        allocate(fstrRESULT%elem_label(1))
        allocate(fstrRESULT%elem_val_item(hecMESH%n_elem))
        fstrRESULT%ne_dof(1) = 1
        fstrRESULT%elem_label(1) = "domain_id"
        do i = 1, hecMESH%n_elem
          fstrRESULT%elem_val_item(i) = elem_id(i)
        enddo
        !call fstr_make_static_result(hecMESH, fstrSOLID, fstrRESULT)
        call fstr2hecmw_mesh_conv(hecMESH)
        call hecmw_visualize_init
        call hecmw_visualize(hecMESH, fstrRESULT, 1)
        call hecmw_visualize_finalize
        call hecmw2fstr_mesh_conv(hecMESH)
        call hecmw_result_free(fstrRESULT)
      endif
    endif

    if(.true.)then
      open(50,file="output/mesh.cnt", status="replace")
        write(50,"(a)")"!VERSION"
        write(50,"(a)")"3"
        write(50,"(a)")"!SOLUTION, TYPE=STATIC"
        write(50,"(a)")"!WRITE,RESULT"
        write(50,"(a)")"!WRITE,VISUAL"
        write(50,"(a)")"!OUTPUT_RES"
        write(50,"(a)")"ESTRAIN, ON"

        !> boundary
        if(fstrSOLID%BOUNDARY_ngrp_tot > 0) write(50,"(a)")"!BOUNDARY"
        do ig0 = 1, fstrSOLID%BOUNDARY_ngrp_tot
          ig   = fstrSOLID%BOUNDARY_ngrp_ID(ig0)
          ityp = fstrSOLID%BOUNDARY_ngrp_type(ig0)
          idofS = ityp/10
          idofE = ityp - idofS*10
          iS0 = hecMESH%node_group%grp_index(ig-1) + 1
          iE0 = hecMESH%node_group%grp_index(ig  )
          do ik = iS0, iE0
            in = hecMESH%node_group%grp_item(ik)
            if(domain_id(in) == domid)then
              write(50,"(i0,a,i0,a,i0,a,1pe12.5)")hecMESH%global_node_ID(in),",",idofS,",",idofE,",", 0.0d0
            endif
          enddo
        enddo

        !> temprature
        if(size(fstrSOLID%temperature) > 1) write(50,"(a)")"!TEMPERATURE"
        if(1 < size(fstrSOLID%temperature))then
          do i=1,hecMESH%n_node
            if(domain_id(i) == domid)then
              write(50,"(i0,a,1pe12.5)")hecMESH%global_node_ID(i),",",fstrSOLID%temperature(i)
            endif
          enddo
        endif

        !> orientation
        if(associated(g_LocalCoordSys))then
          do i=1,hecMESH%n_elem
            if(elem_id(i) == 1)then
              write(50,"(a,i0)")"!ORIENTATION, DEFINITION=COORDINATES, NAME=ORIENT",hecMESH%global_elem_ID(i)
              write(50,"(1pe12.5,a,1pe12.5,a,1pe12.5,a,1pe12.5,a,1pe12.5,a,1pe12.5,a)") &
              & g_LocalCoordSys(i)%CoordSys(1,1),",",g_LocalCoordSys(i)%CoordSys(2,1),",",g_LocalCoordSys(i)%CoordSys(3,1),",", &
              & g_LocalCoordSys(i)%CoordSys(1,2),",",g_LocalCoordSys(i)%CoordSys(2,2),",",g_LocalCoordSys(i)%CoordSys(2,2), &
              & ",0.0,0.0,0.0"
            endif
          enddo

          !> section
          in = 1
          do i=1,hecMESH%n_elem
            if(elem_id(i) == 1)then
              write(50,"(a,i0,a,i0)")"!SECTION,SECNUM=",in,",ORIENTATION=ORIENT",hecMESH%global_elem_ID(i)
              in = in + 1
            endif
          enddo
       endif

        !> material
        do i=1,hecMESH%n_elem
          if(elem_id(i) == 1)then
            call fetch_TableData( MC_ORTHOEXP, fstrSOLID%elements(i)%gausses(1)%pMaterial%dict, alpo(:), ierr )
            if(ierr) cycle
            write(50,"(a,i0)")"!MATERIAL, NAME=M",hecMESH%global_elem_ID(i)
            write(50,"(a)")"!EXPANSION_COEFF, TYPE=ORTHOTROPIC"
            write(50,"(1pe12.5,a,1pe12.5,a,1pe12.5)")alpo(1),",",alpo(2),",",alpo(3)
          endif
        enddo

        !> solver
        write(50,"(a,i0,a,i0,a)")"!SOLVER,METHOD=",hecmw_mat_get_method(hecMAT),",PRECOND=", &
        & hecmw_mat_get_precond(hecMAT),",ITERLOG=YES,TIMELOG=YES"
        write(50,"(i0,a)")hecmw_mat_get_iter( hecMAT ),", 1"
        write(50,"(1pe12.4,a)")hecmw_mat_get_resid(hecMAT),", 1.0, 0.0"
        write(50,"(a)")"!VISUAL, method=PSR"
        write(50,"(a)")"!surface_num = 1"
        write(50,"(a)")"!surface 1"
        write(50,"(a)")"!output_type = BIN_VTK"
        write(50,"(a)")"!END"
      close(50)
    endif

    t2 = HECMW_WTIME()
    if(myrank == 0) write(*,"(a,1pe11.4)")"    * output     time: ", t2-t1

    deallocate(domain_id)
    deallocate(perm)
    deallocate(iperm)
  end subroutine fstr_mesh_doctor

  subroutine imf_load_coo(filename, A)
    implicit none
    type(imf_coo) :: A
    character*256 :: filename
    character*256 :: buf
    integer(kind=kint) :: row, col, NZ, i, NDOF, NDOF2

    open(18, file = filename, status = "old")
    do
      read(18,*) row, col, NZ
      if (0 < row .and. 0 < col .and. 0 < NZ)then
        exit
      endif
      if(is_iostat_end(18)) exit
    enddo

    NDOF = 1
    A%ROW  = row
    A%COL  = col
    A%NP   = NZ
    A%NDOF = NDOF
    NDOF2  = NDOF*NDOF
    allocate(A%I(NDOF2*NZ))
    allocate(A%J(NDOF2*NZ))
    allocate(A%A(NDOF2*NZ))

    A%A = 0.0d0
    A%I = 0
    A%J = 0
    do i = 1, NZ
      read(18,*) A%I(i), A%J(i), A%A(i)
    enddo
    close(18)
  end subroutine imf_load_coo

  subroutine imf_convert_coo2smat(COO, hecMAT)
    implicit none
    type(imf_coo) :: COO
    type(hecmwST_matrix) :: hecMAT
    integer(kind=kint) :: i, j, in, jS, jE, N, k, l, NZ
    integer(kind=kint) :: NPL, NPU, CL, CU, NDOF, NDOF2
    integer(kind=kint), pointer :: vi(:), vj(:), it(:), index(:), perm(:), item(:), indexL(:), indexU(:), itemL(:), itemU(:)
    real(kind=kreal), pointer :: rt(:), A(:), AL(:), AU(:), D(:)

    NDOF = COO%NDOF
    NDOF2 = NDOF*NDOF
    N = COO%ROW
    NZ = COO%NP
    NPL = 0
    NPU = 0
    do k = 1, NZ
      if(COO%I(k) < COO%J(k))then
        NPL = NPL+1
      elseif (COO%J(k) < COO%I(k))then
        NPU = NPU+1
      endif
    enddo
    vi => COO%I
    item => COO%J
    A => COO%A

    allocate(rt(NZ))
    allocate(it(NZ))
    allocate(perm(NZ))
    allocate(index(0:N))
    do k = 1, NZ
      perm(k) = k
    enddo

    l = 1
    call quicksort_int_array_perm(vi, perm, l, NZ)
    index = 0
    do k = 1, NZ
      index(vi(k)) = k
      it(k) = item(perm(k))
    enddo
    deallocate(item)
    item => it

    do k = 1, N
      call quicksort_int_array_perm(item, perm, index(k-1)+1, index(k))
    enddo
    do k = 1, NZ
      rt(k) = A(perm(k))
    enddo
    deallocate(A)
    A => rt
    deallocate(perm)

    if(associated(hecMAT%D)) deallocate(hecMAT%D)
    if(associated(hecMAT%AL)) deallocate(hecMAT%AL)
    if(associated(hecMAT%AU)) deallocate(hecMAT%AU)
    if(associated(hecMAT%indexL)) deallocate(hecMAT%indexL)
    if(associated(hecMAT%itemL)) deallocate(hecMAT%itemL)
    if(associated(hecMAT%indexU)) deallocate(hecMAT%indexU)
    if(associated(hecMAT%itemU)) deallocate(hecMAT%itemU)
    if(associated(hecMAT%X)) deallocate(hecMAT%X)
    if(associated(hecMAT%B)) deallocate(hecMAT%B)

    allocate(D(NDOF2*N))
    allocate(AL(NDOF2*NPL))
    allocate(AU(NDOF2*NPU))
    allocate(indexL(0:N))
    allocate(itemL(NPL))
    allocate(indexU(0:N))
    allocate(itemU(NPU))
    allocate(hecMAT%X(NDOF*N))
    allocate(hecMAT%B(NDOF*N))
    hecMAT%N = N
    hecMAT%NP = N
    hecMAT%NDOF = NDOF
    hecMAT%NPL = NPL
    hecMAT%NPU = NPU
    hecMAT%D => D
    hecMAT%AL => AL
    hecMAT%AU => AU
    hecMAT%indexL => indexL
    hecMAT%itemL => itemL
    hecMAT%indexU => indexU
    hecMAT%itemU => itemU
    hecMAT%X = 0.0d0
    hecMAT%B = 0.0d0

    D = 0.0d0
    AL = 0.0d0
    AU = 0.0d0
    CL = 0
    CU = 0
    indexL(0) = 0
    indexU(0) = 0

    do i = 1, N
      jS = index(i-1) + 1
      jE = index(i  )
      do j = jS, jE
        in = item(j)
        if(i < in)then
          CL = CL + 1
          itemL(CL) = in
          do k = 1,NDOF2
            AL(NDOF2*CL - NDOF2 + k) = A(NDOF2*j - NDOF2 + k)
          enddo
        elseif(in < i)then
          CU = CU + 1
          itemU(CU) = in
          do k = 1, NDOF2
            AU(NDOF2*CU - NDOF2 + k) = A(NDOF2*j - NDOF2 + k)
          enddo
        elseif(i == in)then
          do k = 1, NDOF2
            D(NDOF2*i - NDOF2 + k) = A(NDOF2*j - NDOF2 + k)
          enddo
        endif
      enddo
      indexL(i) = CL
      indexU(i) = CU
    enddo
    deallocate(index)
  end subroutine imf_convert_coo2smat

  recursive subroutine quicksort_int_array_perm(a, perm, first, last)
    implicit none
    integer(kind=kint) :: a(*)
    integer(kind=kint) :: perm(*)
    integer(kind=kint) :: first, last
    integer(kind=kint) :: i, j
    integer(kind=kint) :: x, t

    if (first >= last) then
      return
    endif

    x = a((first+last) / 2)
    i = first
    j = last
    do
      do while(a(i) < x)
        i = i + 1
      enddo
      do while(x < a(j))
        j = j - 1
      enddo
      if(i >= j) exit
      t = a(i); a(i) = a(j); a(j) = t
      t = perm(i); perm(i) = perm(j); perm(j) = t
      i = i + 1
      j = j - 1
    enddo
    if(first < i - 1) call quicksort_int_array_perm(a,perm, first, i - 1)
    if(j + 1 < last)  call quicksort_int_array_perm(a,perm, j + 1, last)
  end subroutine quicksort_int_array_perm

  !> This subroutine prints out global control parameters
  subroutine dump_fstr_global
    implicit none

    write(*,*) 'global parameters dump ***********'
    write(*,*)
    write(*,*) 'IECHO   ',IECHO
    write(*,*) 'IRESULT ',IRESULT
    write(*,*) 'IVISUAL ',IVISUAL
    write(*,*)
    write(*,*) 'for heat ...'
    write(*,*) 'INEUTRAL ', INEUTRAL
    write(*,*) 'IRRES    ', IRRES
    write(*,*) 'IWRES    ', IWRES
    write(*,*) 'NRRES    ', NRRES
    write(*,*) 'NPRINT   ', NPRINT
    write(*,*)
    write(*,*) 'REF_TEMP ', REF_TEMP
    write(*,*)
    write(*,*) 'ANALYSIS CONTROL for NLGEOM and HEAT'
    write(*,*) 'DT     ',DT
    write(*,*) 'ETIME  ',ETIME
    write(*,*) 'ITMAX  ',ITMAX
    write(*,*) 'EPS    ',EPS
    write(*,*)
  end subroutine dump_fstr_global

  !> This subroutine prints out solution control parameters
  subroutine dump_fstr_param( p )
    implicit none
    type( fstr_param ) :: p

    write(*,*) 'fstrPARAM dump ********************'
    write(*,*)
    write(*,*) 'solution_type ',p%solution_type
    write(*,*) 'solver_method ',p%solver_method
    write(*,*)
    write(*,*) '!!STATIC !HEAT'
    write(*,*) p%analysis_n
    if( associated( P%dtime))  write(*,*) 'dtime ', p%dtime
    if( associated( P%etime))  write(*,*) 'etime', p%etime
    if( associated( P%dtmin))  write(*,*) 'dtmin ', p%dtmin
    if( associated( P%delmax))   write(*,*) 'delmax ', p%delmax
    if( associated( P%itmax))  write(*,*) 'itmax ', p%itmax
    if( associated( P%eps))    write(*,*) 'eps ', p%eps
    write(*,*) 'ref_temp ', p%ref_temp
    write(*,*)
    write(*,*) 'output control'
    write(*,*) 'fg_echo ', p%fg_echo
    write(*,*) 'fg_result ', p%fg_result
    write(*,*) 'fg_visual ', p%fg_visual
    write(*,*)
    write(*,*) 'for heat ...'
    write(*,*) 'fg_neutral ', p%fg_neutral
    write(*,*) 'fg_irres ', p%fg_irres
    write(*,*) 'fg_iwres ', p%fg_iwres
    write(*,*) 'nrres ', p%nrres
    write(*,*) 'nprint ', p%nprint
    write(*,*)
    write(*,*) 'for couple ...'
    write(*,*) 'fg_couple ',p%fg_couple
    write(*,*)
    write(*,*) 'ndex table for global node ID sorting'
    write(*,*) 'n_node ', p%n_node
    if( associated( P%global_local_ID)) write(*,*) 'global_local_ID ', p%global_local_ID
  end subroutine dump_fstr_param

  !> This subroutine prints out data for static analysis
  subroutine dump_fstr_solid( s )
    implicit none
    type( fstr_solid ) :: s

    write(*,*) 'fstrSOLID dump ********************'
    write(*,*)
    write(*,*) 'file_type ', s%file_type
    write(*,*)
    write(*,*) '!!BOUNDARY'
    write(*,*) 'BOUNDARY_ngrp_tot ', s%BOUNDARY_ngrp_tot
    if( s%BOUNDARY_ngrp_tot /= 0 ) then
      write(*,*) 'BOUNDARY_ngrp_ID ', s%BOUNDARY_ngrp_ID
      write(*,*) 'BOUNDARY_ngrp_type ',s%BOUNDARY_ngrp_type
      write(*,*) 'BOUNDARY_ngrp_val ',s%BOUNDARY_ngrp_val
      write(*,*) 'BOUNDARY_ngrp_amp ',s%BOUNDARY_ngrp_amp
    end if
    write(*,*)
    write(*,*) '!!VELOCITY'
    write(*,*) 'VELOCITY_ngrp_tot ', s%VELOCITY_ngrp_tot
    if( s%VELOCITY_ngrp_tot /= 0 ) then
      write(*,*) 'VELOCITY_ngrp_ID ', s%VELOCITY_ngrp_ID
      write(*,*) 'VELOCITY_ngrp_type ',s%VELOCITY_ngrp_type
      write(*,*) 'VELOCITY_ngrp_val ',s%VELOCITY_ngrp_val
      write(*,*) 'VELOCITY_ngrp_amp ',s%VELOCITY_ngrp_amp
    end if
    write(*,*)
    write(*,*) '!!ACCELERATION'
    write(*,*) 'ACCELERATION_ngrp_tot ', s%ACCELERATION_ngrp_tot
    if( s%ACCELERATION_ngrp_tot /= 0 ) then
      write(*,*) 'ACCELERATION_ngrp_ID ', s%ACCELERATION_ngrp_ID
      write(*,*) 'ACCELERATION_ngrp_type ',s%ACCELERATION_ngrp_type
      write(*,*) 'ACCELERATION_ngrp_val ',s%ACCELERATION_ngrp_val
      write(*,*) 'ACCELERATION_ngrp_amp ',s%ACCELERATION_ngrp_amp
    end if
    write(*,*)
    write(*,*) '!!CLOAD'
    write(*,*) 'CLOAD_ngrp_tot ', s%CLOAD_ngrp_tot
    if( s%CLOAD_ngrp_tot /= 0 ) then
      write(*,*) 'CLOAD_ngrp_ID ', s%CLOAD_ngrp_ID
      write(*,*) 'CLOAD_ngrp_DOF ', s%CLOAD_ngrp_DOF
      write(*,*) 'CLOAD_ngrp_val ',s%CLOAD_ngrp_val
      write(*,*) 'CLOAD_ngrp_amp ',s%CLOAD_ngrp_amp
    end if
    write(*,*)
    write(*,*) '!!DLOAD'
    write(*,*) 'DLOAD_ngrp_tot ', s%DLOAD_ngrp_tot
    if( s%DLOAD_ngrp_tot/= 0 ) then
      write(*,*) 'DLOAD_ngrp_ID ',s%DLOAD_ngrp_ID
      write(*,*) 'DLOAD_ngrp_LID ',s%DLOAD_ngrp_LID
      write(*,*) 'DLOAD_ngrp_params ', s%DLOAD_ngrp_params
      write(*,*) 'DLOAD_ngrp_amp ',s%DLOAD_ngrp_amp
    end if
    write(*,*)
    write(*,*) '!!TEMPERATURE'
    write(*,*) 'TEMP_ngrp_tot ',s%TEMP_ngrp_tot
    if( s%TEMP_ngrp_tot/= 0 ) then
      write(*,*) 'TEMP_ngrp_ID ',s%TEMP_ngrp_ID
      write(*,*) 'TEMP_ngrp_val ', s%TEMP_ngrp_val
    end if
    write(*,*)
    write(*,*) '!!STATIC'
    write(*,*) 'restart_nout ',s%restart_nout
    write(*,*)
    write(*,*) '!!COUPLE'
    write(*,*) 'COUPLE_ngrp_tot ',s%COUPLE_ngrp_tot
    if( s%COUPLE_ngrp_tot>0 ) then
      write(*,*) 'COUPLE_ngrp_ID ', s%COUPLE_ngrp_ID
    endif
    write(*,*)
  end subroutine dump_fstr_solid

  !> This subroutine prints out data for heat conductive analysis
  subroutine dump_fstr_heat( h )
    implicit none
    type( fstr_heat ) :: h

    write(*,*) 'fstrHEAT dump ********************'
    write(*,*)
    write(*,*) 'TIME CONTROL'
    write(*,*) 'STEPtot ', h%STEPtot
    if( h%STEPtot /= 0 ) then
      write(*,*) 'STEP_DLTIME ', h%STEP_DLTIME
      write(*,*) 'STEP_EETIME ', h%STEP_EETIME
      write(*,*) 'STEP_DELMIN ', h%STEP_DELMIN
      write(*,*) 'STEP_DELMAX ', h%STEP_DELMAX
    end if
    write(*,*)
    write(*,*) 'MATERIAL'
    write(*,*) 'ATERIALtot ', h%MATERIALtot
    if( h%MATERIALtot /= 0 ) then
      write(*,*) 'RHO ', h%RHO
      write(*,*) 'RHOtemp ', h%RHOtemp
      write(*,*) 'CP ',h%CP
      write(*,*) 'CPtemp ', h%CPtemp
      write(*,*) 'COND ', h%COND
      write(*,*) 'CONDtemp ',h%CONDtemp
      write(*,*)
      write(*,*) 'RHOtab ', h%RHOtab
      write(*,*) 'CPtab ', h%CPtab
      write(*,*) 'CONDtab ',h%CONDtab
      write(*,*)
      write(*,*) 'RHOfuncA ', h%RHOfuncA
      write(*,*) 'RHOfuncB ', h%RHOfuncB
      write(*,*) 'CPfuncA ',h%CPfuncA
      write(*,*) 'CPfuncB ',h%CPfuncB
      write(*,*) 'CONDfuncA ',h%CONDfuncA
      write(*,*) 'CONDfuncB ',h%CONDfuncB
    end if
    write(*,*)
    write(*,*) 'AMPLITUDE'
    write(*,*) 'AMPLITUDEtot ',h%AMPLITUDEtot
    if( h%AMPLITUDEtot /=0 ) then
      write(*,*) 'AMPL ',h%AMPL
      write(*,*) 'AMPLtime ',h%AMPLtime
      write(*,*) 'AMPLtab ', h%AMPLtab
      write(*,*) 'AMPLfuncA ', h%AMPLfuncA
      write(*,*) 'AMPLfuncB ', h%AMPLfuncB
    end if
    write(*,*)
    write(*,*) 'VALUE'
    if( associated(h%TEMP)) then
      write(*,*) 'TEMP ',h%TEMP
      write(*,*) 'TEMP0 ',h%TEMP0
      write(*,*) 'TEMPC ',h%TEMPC
    end if
    write(*,*)
    write(*,*) 'BOUNDARY CONDTIONS -------'
    write(*,*)
    write(*,*) '!FIXTEMP '
    write(*,*) 'T_FIX_tot ',h%T_FIX_tot
    if( h%T_FIX_tot /= 0 ) then
      write(*,*) 'T_FIX_node ',h%T_FIX_node
      write(*,*) 'T_FIX_ampl ',h%T_FIX_ampl
      write(*,*) 'T_FIX_val ',h%T_FIX_val
    end if
    write(*,*)
    write(*,*) '!CFLUX'
    write(*,*) 'Q_NOD_tot ',h%Q_NOD_tot
    if( h%Q_NOD_tot /= 0 ) then
      write(*,*) 'Q_NOD_node ', h%Q_NOD_node
      write(*,*) 'Q_NOD_ampl ',h%Q_NOD_ampl
      write(*,*) 'Q_NOD_val ', h%Q_NOD_val
    end if
    write(*,*)
    write(*,*) '!DFLUX (not used)'
    write(*,*) 'Q_VOL_tot ',h%Q_VOL_tot
    if( h%Q_VOL_tot /= 0 ) then
      write(*,*) 'Q_VOL_elem ',h%Q_VOL_elem
      write(*,*) 'Q_VOL_ampl ',h%Q_VOL_ampl
      write(*,*) 'Q_VOL_val ',h%Q_VOL_val
    end if
    write(*,*)
    write(*,*) '!DFLUX, !SFLUX'
    write(*,*) 'Q_SUF_tot ', h%Q_SUF_tot
    if( h%Q_SUF_tot /= 0 ) then
      write(*,*) 'Q_SUF_elem ', h%Q_SUF_elem
      write(*,*) 'Q_SUF_ampl ',h%Q_SUF_ampl
      write(*,*) 'Q_SUF_surf ',h%Q_SUF_surf
      write(*,*) 'Q_SUF_val ',h%Q_SUF_val
    end if
    write(*,*)
    write(*,*) '!RADIATE, !SRADIATE'
    write(*,*) 'R_SUF_tot ',h%R_SUF_tot
    if( h%R_SUF_tot /= 0 ) then
      write(*,*) 'R_SUF_elem ',h%R_SUF_elem
      write(*,*) 'R_SUF_ampl ', h%R_SUF_ampl
      write(*,*) 'R_SUF_surf ',h%R_SUF_surf
      write(*,*) 'R_SUF_val ',h%R_SUF_val
    end if
    write(*,*)
    write(*,*) '!FILM, SFILM'
    write(*,*) 'H_SUF_tot ',h%H_SUF_tot
    if( h%H_SUF_tot /= 0 ) then
      write(*,*) 'H_SUF_elem ',h%H_SUF_elem
      write(*,*) 'H_SUF_ampl ',h%H_SUF_ampl
      write(*,*) 'H_SUF_surf ',h%H_SUF_surf
      write(*,*) 'H_SUF_val ',h%H_SUF_val
    end if
    write(*,*)
  end subroutine dump_fstr_heat

  !> This subroutine prints out parameters for eigen analysis
  subroutine dump_fstr_eigen( e )
    implicit none
    type( fstr_eigen ) :: e

    write(*,*) 'lczparam dump ********************'
    write(*,*)
    write(*,*) 'nget    ', e%nget
    write(*,*)
  end subroutine dump_fstr_eigen

  !> This subroutine prints out data for dynamic analysis
  subroutine dump_fstr_dynamic( d )
    implicit none
    type( fstr_dynamic ) :: d

    write(*,*) 'fstrDYNAMIC dump ********************'
    write(*,*)
    write(*,*) 'idx_eqa  ', d%idx_eqa
    write(*,*) 'idx_resp ', d%idx_resp
    write(*,*) 'n_step   ', d%n_step
    write(*,*) 't_start  ', d%t_start
    write(*,*) 't_end    ', d%t_end
    write(*,*) 't_delta  ', d%t_delta
    write(*,*) 'ganma    ', d%ganma
    write(*,*) 'beta     ', d%beta
    write(*,*) 'idx_mas  ', d%idx_mas
    write(*,*) 'idx_dmp  ', d%idx_dmp
    write(*,*) 'ray_m    ', d%ray_m
    write(*,*) 'ray_k    ', d%ray_k
    write(*,*) 'restart_nout',d%restart_nout
    write(*,*) 'nout     ', d%nout
    write(*,*) 'ngrp_monit  ', d%ngrp_monit
    write(*,*) 'nout_monit  ', d%nout_monit
    write(*,*) 'iout_list   ', d%iout_list
    write(*,*)
  end subroutine dump_fstr_dynamic

  !> This subroutine prints out coupleing analysis
  subroutine dump_fstr_couple( c )
    implicit none
    type( fstr_couple ) :: c
    integer( kind=kint) :: i,j
    write(*,*) 'fstrCLP dump ********************'
    write(*,*)
    write(*,*) 'dof ', c%dof
    write(*,*) 'ndof ', c%ndof
    write(*,*) 'coupled_node_n ', c%coupled_node_n
    if( c%coupled_node_n >0 ) then
      write(*,*) 'coupled_node'
      write(*,*) c%coupled_node
    endif
    write(*,*) 'trac'
    do i=1, c%coupled_node_n
      j = c%dof * i;
      write(*,*)  c%trac(j-2),' ',c%trac(j-1),' ',c%trac(j)
    end do
    write(*,*) 'velo'
    do i=1, c%coupled_node_n
      j = c%dof * i;
      write(*,*)  c%velo(j-2),' ',c%velo(j-1),' ',c%velo(j)
    end do
  end subroutine dump_fstr_couple

  subroutine monolis_hash_init()
    implicit none
    type(type_monolis_hash_bin), pointer :: bin(:)

    monolis_hash_tree%n_put = 0
    monolis_hash_tree%tree_size = monolis_hash_size(monolis_current_hash_size)
    allocate(bin(monolis_hash_tree%tree_size))
    monolis_hash_tree%bin => bin
    nullify(bin)
  end subroutine monolis_hash_init

  subroutine monolis_hash_finalize()
    implicit none
    integer(kind=kint) :: i
    type(type_monolis_hash_list), pointer :: list(:)
    do i = 1, monolis_hash_tree%tree_size
      if(0 < monolis_hash_tree%bin(i)%n)then
        list => monolis_hash_tree%bin(i)%list
        if(associated(list)) deallocate(list)
      endif
    enddo
    deallocate(monolis_hash_tree%bin)
    nullify(list)
  end subroutine monolis_hash_finalize

  subroutine monolis_hash_get(key, val, is_exist)
    implicit none
    integer(kind=kint) :: hash, val
    character :: key*27
    logical :: is_exist

    val = 0
    is_exist = .false.
    call monolis_hash_key(key, hash)
    call monolis_hash_list_get(key, hash, val, is_exist)
  end subroutine monolis_hash_get

  subroutine monolis_hash_push(key, val, is_pushed, is_exist)
    implicit none
    integer(kind=kint) :: hash, val
    character :: key*27
    logical :: is_exist, is_pushed

    is_exist  = .false.
    is_pushed = .false.
    if(0.75d0*dble(monolis_hash_size(monolis_current_hash_size)) < dble(monolis_hash_tree%n_put))then
      call monolis_hash_resize()
    endif

    call monolis_hash_key(key, hash)
    call monolis_hash_list_get(key, hash, val, is_exist)

    if(.not. is_exist)then
      call monolis_hash_list_push(key, hash, val)
      monolis_hash_tree%n_put = monolis_hash_tree%n_put + 1
      is_pushed = .true.
    endif
  end subroutine monolis_hash_push

  subroutine monolis_hash_resize()
    implicit none
    integer(kind=kint) :: i, j, n, hash, val
    integer(kind=kint) :: new_size_id, new_size, old_size
    type(type_monolis_hash_bin), pointer :: new_bin(:), old_bin(:)
    type(type_monolis_hash_list), pointer :: list(:)
    character :: key*27

    old_size = monolis_hash_tree%tree_size
    if(monolis_current_hash_size < 22)then
      monolis_current_hash_size = monolis_current_hash_size + 1
    else
      return
    endif
    new_size_id = monolis_current_hash_size
    new_size = monolis_hash_size(new_size_id)
    monolis_hash_tree%tree_size = new_size

    allocate(new_bin(new_size))
    old_bin => monolis_hash_tree%bin
    monolis_hash_tree%bin => new_bin

    do i = 1, old_size
      do j = 1, old_bin(i)%n
        hash = old_bin(i)%list(j)%hash
        key  = old_bin(i)%list(j)%key
        val  = old_bin(i)%list(j)%val
        call monolis_hash_list_push(key, hash, val)
      enddo
    enddo

    do i = 1, old_size
      list => old_bin(i)%list
      if(associated(list)) deallocate(list)
    enddo
    deallocate(old_bin)
    nullify(old_bin)
    nullify(new_bin)
  end subroutine monolis_hash_resize

  subroutine monolis_hash_list_get(key, hash, val, is_exist)
    implicit none
    integer(kind=kint) :: n, i
    integer(kind=kint) :: index, hash, val
    character :: key*27
    logical :: is_exist

    is_exist = .false.
    call monolis_index_key(hash, index)
    n = monolis_hash_tree%bin(index)%n
    do i = 1, n
      if(monolis_hash_tree%bin(index)%list(i)%key == key)then
        val = monolis_hash_tree%bin(index)%list(i)%val
        is_exist = .true.
      endif
    enddo
  end subroutine monolis_hash_list_get

  subroutine monolis_hash_list_push(key, hash, val)
    implicit none
    integer(kind=kint) :: i, iold, inew
    integer(kind=kint) :: index, hash, val
    character :: key*27
    type(type_monolis_hash_list), pointer :: old_list(:), new_list(:)

    call monolis_index_key(hash, index)
    iold = monolis_hash_tree%bin(index)%n
    old_list => monolis_hash_tree%bin(index)%list

    inew = iold + 1
    allocate(new_list(inew))
    do i = 1, iold
      new_list(i)%hash = old_list(i)%hash
      new_list(i)%key  = old_list(i)%key
      new_list(i)%val  = old_list(i)%val
    enddo

    new_list(inew)%hash = hash
    new_list(inew)%key  = key
    new_list(inew)%val  = val

    monolis_hash_tree%bin(index)%n = inew
    monolis_hash_tree%bin(index)%list => new_list
    if(associated(old_list)) deallocate(old_list)
    nullify(old_list)
    nullify(new_list)
  end subroutine monolis_hash_list_push

  !> BJD2 hash function
  subroutine monolis_hash_key(key, hash)
    implicit none
    character :: key*27
    integer(kind=kint) :: hash, i, t
    hash = 5381
    do i = 1, 27
      t = mod(hash*33, 65536_4)
      hash = mod(t + iachar(key(i:i)), 65536_4)
    enddo
  end subroutine monolis_hash_key

  subroutine monolis_index_key(hash, index)
    implicit none
    integer(kind=kint) :: hash, index
    index = mod(hash, monolis_hash_tree%tree_size) + 1
  end subroutine monolis_index_key

end module fstr_debug_dump


