!=======================================================================
!
!  PROGRAM  PHASE/0 2018.01 ($Rev: 577 $)
!
!  MODULE: m_Stress
!
!  AUTHOR(S): H. Sawada   August/20/2003
!  
!  Contact address :  Phase System Consortium
!                     E-mail: phase_system@nims.go.jp URL https://azuma.nims.go.jp
!  
!
!
!=======================================================================
!
!     The original version of this set of the computer programs "PHASE"
!  was developed by the members of the Theory Group of Joint Research
!  Center for Atom Technology (JRCAT), based in Tsukuba, in the period
!  1993-2001.
!
!     Since 2002, this set has been tuned and new functions have been
!  added to it as a part of the national project "Frontier Simulation 
!  Software for Industrial Science (FSIS)",  which is supported by
!  the IT program of the Ministry of Education, Culture, Sports,
!  Science and Technology (MEXT) of Japan. 
!     Since 2006, this program set has been developed as a part of the
!  national project "Revolutionary Simulation Software (RSS21)", which
!  is supported by the next-generation IT program of MEXT of Japan.
!   Since 2013, this program set has been further developed centering on PHASE System
!  Consortium.
!   The activity of development of this program set has been supervised by Takahisa Ohno.
!
! *************************************************************
!
! =========== Contributions ===================================
!
! Through the courtesy of contributors, the following functions are added.
!
! Company:  ASMS Co.,Ltd.
! Functions:  [Identifier: 13.0B]
!                 stress terms are avaiable in the case of DFT-D2 calculations
!
! =============================================================

module m_Stress
  use m_Const_Parameters,     only : DP, PAI, PAI2, PAI4, SKIP, zi &
                                  &, Valence_plus_PC_Charge &
!!$ASASASASAS
!!$                                  &, EXC_ONLY,STRESS_, CRDTYP, GAMMA
                                  &, EXC_ONLY,STRESS_, CRDTYP, GAMMA &
                                  &, MAPPED,NOTMAPPED, ON
  use m_Kpoints,              only : k_symmetry
  use m_PseudoPotential,      only : nlmt,nlmta,lmta,ilmt,lmtt,ltp,mtp,il2p,isph &
                                  &, iqitg,taup,dl2p &
                                  &, q,dion,psc_l,psc_diff_l &
                                  &, qitg_l,qitg_diff_l, modnrm &
                                  &, itpcc,rhpcg_l,rhpcg_diff_l,epc,etot1,ival &
                                  &, m_PP_find_maximum_l, m_PP_include_vanderbilt_pot &
                                  &, ipaw,dion_paw, flg_paw

  use m_NonLocal_Potential,   only : snld
  use m_XC_Potential,         only : vxc_l, vxcpc_l, exc, s_gga1, s_gga2

#ifndef DISABLE_VDWDF
  use m_vdWDF,  only : s_cnl1, s_cnl2, s_cnl1_pc, s_cnl2_pc, ecnl_vdwdf
#endif

  use m_Charge_Density,       only : chgq_l, hsr, chgsoft
  use m_Crystal_Structure,    only : altv,rltv,univol,nopr,op, p2bmat, b2pmat
  use m_Ionic_System,         only : ntyp, natm,ityp,iwei,pos,zfm3_l,s_ew
  use m_PlaneWaveBasisSet,    only : kg1,kg,kgp,ngabc,iba,nbase,nbmx,gr_l,ylm_l &
                                  &, m_pwBS_sphrp2_3D,m_pwBS_sphrp2_diff_3D &
                                  &, ngabc_kngp_l
  use m_Electronic_Structure, only : zaj_l,occup_l,eko_l,totch &
                                  &, fsr_l,fsi_l,fsr_l_2D,fsi_l_2D &
                                  &, m_ES_alloc_fsri_l_2D, m_ES_dealloc_fsri_l_2D &
                                  &, m_ES_gather_f_3d_to_2d, m_ES_alloc_fsr_l_2d &
                                  &, m_ES_alloc_fsi_l_2d, m_ES_gather_f_3d_to_2d_blk
  use m_ES_nonlocal,          only :                                            &
 &                                   m_ES_betar_dot_WFs_4_lmta_k_3D             &
 &                                 , G_dot_R                                    &
 &                                 , m_ES_alloc_zfsincos, m_ES_dealloc_zfsincos &
 &                                 , m_ES_alloc_arai_3D, m_ES_dealloc_arai_3D   &
 &                                 , alloc_zfsincos_mpi, dealloc_zfsincos_mpi   &
 &                                 , m_ES_betar_dot_WFs_4_each_k_3D

  use m_Control_Parameters,   only : nspin,ipri,kimg,af,nel_Ylm,sw_screening_correction,nhistory_stress, printable &
                                  &, sw_optimize_lattice,sw_uniform &
 &                                 , ke_e0,ke_sigma,ke_a, xctype, nblocksize_gather_f_is_given, nblocksize_gather_f
  use m_Timing,               only : tstatc0_begin, tstatc0_end
  use m_Parallelization,      only : mpi_comm_group,map_k,myrank_k,np_e,ierr,ista_k,iend_k &
                                  &, ista_kngp,iend_kngp,ista_snl,iend_snl,npes,mype &
                                  &, ista_g1k, iend_g1k, np_g1k, mpi_ke_world, mpi_kg_world  &
                                  &, mpi_ge_world,nrank_g, mpi_chg_world
  use m_Screening,            only : screening


! =================================== Added by K. Tagami ============== p1100
  use m_Electronic_Structure,  only : dhub
  use m_Ionic_System,          only : ihubbard
  use m_Control_Parameters,    only : proj_attribute
! ===================================================================== p1100

  use m_Control_Parameters,   only : noncol
  use m_Control_Parameters,    only : external_stress, &
       &                              sw_fix_lattice_angles, sw_vdw_correction, &
       &                              sw_fix_lattice_lengths, &
       &                              fix_angle_alpha, fix_angle_beta, fix_angle_gamma, &
       &                              fix_length_a, fix_length_b, fix_length_c, &
       &                              sw_neglect_stress_offdiagonal
  use m_Ionic_System,          only : s_vdw

  implicit none
  include 'mpif.h'

  integer,      private,pointer, dimension(:)   :: il3
  real(kind=DP),private,pointer, dimension(:)   :: vlength,wkc
  real(kind=DP),private,pointer, dimension(:)   :: grinv,zfsin_tmp,zfcos_tmp
  real(kind=DP),private,pointer, dimension(:)   :: flchgq
  real(kind=DP),private,pointer, dimension(:,:) :: g,alinvt,vloc
  real(kind=DP),private,pointer, dimension(:,:) :: s_ke,s_or,s_nl
  real(kind=DP),private,pointer, dimension(:,:) :: s_h1,s_h2,s_loc1,s_loc2
  real(kind=DP),private,pointer, dimension(:,:) :: s_xc1,s_xc2
  real(kind=DP),private,pointer, dimension(:,:) :: s_pc
  real(kind=DP),private,allocatable, dimension(:,:,:) :: fsr_diff_l,fsi_diff_l,ylmd
  real(kind=DP),private,pointer, dimension(:)   :: ylm
  real(kind=DP),private,pointer, dimension(:,:,:) :: flchgqd
  real(kind=DP),public, pointer, dimension(:,:,:,:,:,:) :: hsrd,esrd

! ========================= added by K. Tagami =========================== 11.0
  real(kind=DP),public, allocatable, dimension(:,:,:,:,:,:) :: hsid, esid
! ======================================================================== 11.0

  real(kind=DP),private,pointer, dimension(:,:) :: s_0,s_1,s_2
  real(kind=DP),private,pointer, dimension(:,:) :: s_tmp,s_up,s_dn,s
  character(len=2) ,private                     :: stress_name

! ====================== Added by K. Tagami ========================= p1100
  real(kind=DP),private,allocatable, dimension(:,:) :: s_hub
! =================================================================== p1100
  real(kind=DP),private,allocatable, dimension(:,:) :: s_vdwdf

  real(kind=DP),private :: stressmx=-1
  real(kind=DP),dimension(3,3),private :: currstress

contains
  subroutine m_Stress_alloc
    allocate(s_ke(3,3)); s_ke = 0.d0
    allocate(s_or(3,3)); s_or = 0.d0
    allocate(s_nl(3,3)); s_nl = 0.d0
    allocate(s_xc1(3,3)); s_xc1 = 0.d0
    allocate(s_xc2(3,3)); s_xc2 = 0.d0
    allocate(s_h1 (3,3)); s_h1  = 0.d0
    allocate(s_h2 (3,3)); s_h2  = 0.d0
    allocate(s_loc1(3,3)); s_loc1 = 0.d0
    allocate(s_loc2(3,3)); s_loc2 = 0.d0
    allocate(s_pc(3,3)); s_pc = 0.d0

    allocate(hsrd(natm,nlmt,nlmt,nspin,3,3)); hsrd = 0.d0
    allocate(esrd(natm,nlmt,nlmt,nspin,3,3)); esrd = 0.d0

    allocate(s_0(3,3)); s_0 = 0.d0
    allocate(s_1(3,3)); s_1 = 0.d0
    allocate(s_2(3,3)); s_2 = 0.d0
    allocate(s_tmp(3,3)); s_tmp = 0.d0
    allocate(s_up(3,3)); s_up = 0.d0
    allocate(s_dn(3,3)); s_dn = 0.d0
    allocate(s(3,3)); s = 0.d0
    allocate(alinvt(3,3)); alinvt = rltv / PAI2

! =========================================== Added by K.Tagami ==== p1100
    allocate(s_hub(3,3)); s_hub = 0.d0
! ================================================================== p1100
    allocate(s_vdwdf(3,3)); s_vdwdf = 0.d0

  end subroutine m_Stress_alloc

  subroutine m_Stress_dealloc
    deallocate(s_ke)
    deallocate(s_or)
    deallocate(s_nl)
    deallocate(s_xc1)
    deallocate(s_xc2)
    deallocate(s_h1)
    deallocate(s_h2)
    deallocate(s_loc1)
    deallocate(s_loc2)
    deallocate(s_pc)
    deallocate(hsrd)
    deallocate(esrd)

! ============================== added by K. Tagami ============= 11.0
    if ( allocated(hsid) ) deallocate(hsid)
    if ( allocated(esid) ) deallocate(esid)
! =============================================================== 11.0

    deallocate(s_0)
    deallocate(s_1)
    deallocate(s_2)
    deallocate(s_tmp)
    deallocate(s_up)
    deallocate(s_dn)
    deallocate(s)
    deallocate(alinvt)

! =========================================== Added by K.Tagami ==== p1100
    deallocate(s_hub)
! ================================================================== p1100
    deallocate(s_vdwdf)

  end subroutine m_Stress_dealloc

  subroutine m_Stress_alloc_grinv_g
    integer :: i
    real(kind=DP) :: ga,gb,gc
    allocate(grinv(ista_kngp:iend_kngp)); grinv = 0.d0
    allocate(g(ista_kngp:iend_kngp,3)); g = 0.d0
    do i = ista_kngp, iend_kngp  !for mpi
      if(gr_l(i).lt.1.0d-20) then
        grinv(i)=0.d0
      else
        grinv(i)=1.d0/gr_l(i)
      endif
    enddo
    do i = ista_kngp, iend_kngp  !for mpi
      ga = ngabc_kngp_l(i,1)
      gb = ngabc_kngp_l(i,2)
      gc = ngabc_kngp_l(i,3)
      g(i,1) = rltv(1,1)*ga+rltv(1,2)*gb+rltv(1,3)*gc
      g(i,2) = rltv(2,1)*ga+rltv(2,2)*gb+rltv(2,3)*gc
      g(i,3) = rltv(3,1)*ga+rltv(3,2)*gb+rltv(3,3)*gc
    enddo
  end subroutine m_Stress_alloc_grinv_g

  subroutine m_Stress_dealloc_grinv_g
    deallocate(grinv)
    deallocate(g)
  end subroutine m_Stress_dealloc_grinv_g

  subroutine m_Stress_ke(nfout,kv3,kp_crdtyp,vkxyz)
    integer, intent(in) :: nfout, kv3, kp_crdtyp
    real(kind=DP), intent(in), dimension(kv3,3,kp_crdtyp) :: vkxyz
    real(kind=DP)       :: fac
    integer             :: ik,i,j,ib,ig
    real(kind=DP),pointer,dimension(:,:) :: s_ke_mpi   ! MPI
    integer :: is,ie
    integer             :: id_sname = -1

    call tstatc0_begin('m_Stress_ke ',id_sname)

    allocate(s_ke_mpi(3,3))
    allocate(g(maxval(np_g1k),3)); g = 0.d0
    allocate(vlength(maxval(np_g1k))); vlength = 0.d0
    allocate(wkc(maxval(np_g1k)));  wkc  = 0.d0
    s_ke = 0.d0
    do ik = 1, kv3, af+1
       if(map_k(ik) /= myrank_k) cycle               ! MPI  
       call k_plus_G_vectors_3D(ik,kg,kg1,kv3,iba,nbase,vkxyz,ngabc,rltv&
            &,g(1,1),g(1,2),g(1,3),vlength)                            ! ->(bottom_Subr.)
       do ig = 1,np_g1k(ik)
          wkc(ig) = 1.d0 &
               &  + 2.d0*ke_a/sqrt(PAI)/ke_sigma  &
               &  * exp(-((vlength(ig)**2/2.d0-ke_e0)/ke_sigma)**2)
       end do
       if(k_symmetry(ik) == GAMMA) then
          is = 1
          if (ista_g1k(ik) == 1) is = 2
          
          do ig = is,np_g1k(ik)
             wkc(ig) = wkc(ig)*2.d0
          end do
       end if

       do i = 1, 3
       do j = 1, 3
       if(kimg.eq.1) then
          do ib = 1, np_e                           ! MPI
             do ig =1,np_g1k(ik)
                fac = wkc(ig)*g(ig,i)*(g(ig,1)*alinvt(1,j) &
                     &                +g(ig,2)*alinvt(2,j)+g(ig,3)*alinvt(3,j))
                s_ke(i,j) = s_ke(i,j) &
                     &        - fac*occup_l(ib,ik)*zaj_l(ig,ib,ik,1)**2
             end do
          end do
       elseif(kimg.eq.2) then
          do ib = 1, np_e                           ! MPI
             do ig =1,np_g1k(ik)
                fac = wkc(ig)*g(ig,i)*(g(ig,1)*alinvt(1,j) &
                     &       +g(ig,2)*alinvt(2,j)+g(ig,3)*alinvt(3,j))
                s_ke(i,j) = s_ke(i,j) &
                     &        - fac*occup_l(ib,ik) &
                     &        *(zaj_l(ig,ib,ik,1)**2+zaj_l(ig,ib,ik,2)**2)
             end do
          end do
       endif
       enddo
       enddo
    enddo

    call mpi_allreduce(s_ke,s_ke_mpi,3*3,mpi_double_precision,mpi_sum,mpi_comm_group,ierr) !MPI
    s_ke = s_ke_mpi  ! MPI

    s_ke=s_ke/dble(kv3)*2.d0

    stress_name = 'KI'
    if(af == 0) then
       s_0 = s_ke
       call check_stress(nfout)
    else
       s_up = s_ke
       call check_af(nfout)
    endif

    deallocate(s_ke_mpi)
    deallocate(g)
    deallocate(vlength)
    deallocate(wkc)

    call tstatc0_end(id_sname)
  end subroutine m_Stress_ke

  subroutine m_Stress_hsr_diff(nfout,kv3)
    integer, intent(in) :: nfout,kv3
!!$ASASASASAS
    !!$integer    :: i1,i2,ia,it,ispin,ik,i,lmt1,lmt2,lmta1,lmta2,iksnl
    integer    :: i1,i2,ia,it,ispin,ik,i,lmt1,lmt2,lmta1,lmta2,iksnl,mapmode
!!$ASASASASAS
    integer    :: id_sname = -1
    real(kind=DP) :: fac, w_n, ek_n, c
    real(kind=DP),pointer,dimension(:,:,:,:,:,:) :: hsrd_mpi, esrd_mpi  ! MPI
    real(kind=DP),pointer,dimension(:,:,:)       :: snld_mpi            ! MPI
!!$ASASASASAS
    real(kind=DP) :: dtmp1=0.d0
    real(kind=DP) :: dtmp2=0.d0
!!$ASASASASAS
    integer         :: lnblck, lnb1, lnb2, lnsize,ib

    call tstatc0_begin('m_Stress_hsr_diff ',id_sname)

    allocate(hsrd_mpi(natm,nlmt,nlmt,nspin,3,3))   ! MPI
    allocate(esrd_mpi(natm,nlmt,nlmt,nspin,3,3))   ! MPI

    call m_ES_alloc_zfsincos(0)
    call m_ES_alloc_arai_3D(0)
!!$ASASASASAS
    call alloc_zfsincos_mpi()
!!$ASASASASAS
    allocate(fsr_diff_l(np_e,nlmta,ista_k:iend_k)); fsr_diff_l = 0.d0
    allocate(fsi_diff_l(np_e,nlmta,ista_k:iend_k)); fsi_diff_l = 0.d0

    fac = 2.d0/dble(kv3)
    hsrd = 0.d0
    esrd = 0.d0
    do i1 = 1, 3
    do i2 = 1, 3
      do ia = 1, natm
        it = ityp(ia)
!!$ASASASASAS
!!$        call G_dot_R(natm,ia,pos,kgp,nbmx,ngabc,zfcos,zfsin)
        if ( kv3/nspin == 1 ) then
          call G_dot_R(ia,mapmode,1)
          mapmode = MAPPED
        else
          call G_dot_R(ia,mapmode)
          mapmode = NOTMAPPED
        endif
!!$ASASASASAS
        do ispin = 1, nspin, af+1
        do ik = ispin, kv3+ispin-nspin, nspin
          if(map_k(ik) /= myrank_k) cycle         ! MPI
!          call m_ES_betar_dot_WFs_4_each_k_3D(nfout,ik,.false.)

!          if(.not. allocated(fsr_l_2D)) allocate(fsr_l_2D(np_e, nlmta))
!          call m_ES_gather_f_3d_to_2d(fsr_l, fsr_l_2D, ik)
!          if(.not. (kv3/nspin == 1 .and. k_symmetry(1) == GAMMA .and. kimg == 2)) then
!             if(.not. allocated(fsi_l_2D)) allocate(fsi_l_2D(np_e, nlmta))
!             call m_ES_gather_f_3d_to_2d(fsi_l, fsi_l_2D, ik)
!          endif
          if(nblocksize_gather_f_is_given) then
             lnblck = nblocksize_gather_f
             if(np_e < lnblck) then
                lnblck = np_e
             end if
             if(1 > lnblck) then
                lnblck = np_e
             end if
          else
             lnblck = np_e
          end if
          call m_ES_alloc_fsr_l_2d(lnblck, nlmta)
          if(k_symmetry(ik) /= GAMMA) then
             call m_ES_alloc_fsi_l_2d(lnblck, nlmta)
          end if
          iksnl = (ik-1)/nspin + 1
          snld_mpi => snld(:,:,ista_snl:iend_snl,i1,i2)   ! MPI
          call m_ES_betar_dot_WFs_4_lmta_k_3D &
!!$ASASASASAS
!!$           & (ista_k,iend_k,ik,zaj_l,ia,iksnl,snld_mpi,fsr_diff_l,fsi_diff_l,0)  ! MPI
           & (ista_k,iend_k,ik,zaj_l,ia,iksnl,snld_mpi,fsr_diff_l,fsi_diff_l,mapmode)  ! MPI
!!$ASASASASAS
!!$           & (ista_k,iend_k,ik,zaj_l,ia,snld(1,1,ista_snl,i1,i2),fsr_diff_l,fsi_diff_l)  ! MPI
          do lnb1 = 1, np_e, lnblck                          ! MPI
             lnb2=min( lnb1+lnblck-1,np_e )
             lnsize = lnb2-lnb1 + 1
             call m_ES_gather_f_3d_to_2d_blk(fsr_l, fsr_l_2D, ik, lnblck, lnb1, lnsize)
             if( k_symmetry(ik) /= GAMMA ) then
                call m_ES_gather_f_3d_to_2d_blk(fsi_l, fsi_l_2D, ik, lnblck, lnb1, lnsize)
             endif
             do ib=lnb1,lnb2
             w_n = occup_l(ib,ik) * fac
             ek_n = eko_l(ib,ik)
             do lmt1 = 1,ilmt(it)
               lmta1    = lmta(lmt1,ia)
               do lmt2 = lmt1,ilmt(it)
                 lmta2    = lmta(lmt2,ia)
!!$ASASASASAS
!          if(.not. allocated(fsr_l_2D)) allocate(fsr_l_2D(np_e, nlmta))
                 if (k_symmetry(ik) /= GAMMA) then
                   dtmp1 = fsi_l_2D(ib,lmta2)
                   dtmp2 = fsi_l_2D(ib,lmta1)
                 else
                   dtmp1 = 0.d0
                   dtmp2 = 0.d0
                 endif
!!$                 c= w_n * &
!!$                  &     (  fsr_diff_l(i,lmta1,ik)*fsr_l(i,lmta2,ik) &
!!$                  &     +  fsi_diff_l(i,lmta1,ik)*fsi_l(i,lmta2,ik) &
!!$                  &     +  fsr_diff_l(i,lmta2,ik)*fsr_l(i,lmta1,ik) &
!!$                  &     +  fsi_diff_l(i,lmta2,ik)*fsi_l(i,lmta1,ik) )
                 c= w_n * &
                  &     (  fsr_diff_l(ib,lmta1,ik)*fsr_l_2D(ib,lmta2) &
                  &     +  fsi_diff_l(ib,lmta1,ik)*dtmp1 &
                  &     +  fsr_diff_l(ib,lmta2,ik)*fsr_l_2D(ib,lmta1) &
                  &     +  fsi_diff_l(ib,lmta2,ik)*dtmp2 )
!!$ASASASASAS
                 hsrd(ia,lmt1,lmt2,ispin,i1,i2)=hsrd(ia,lmt1,lmt2,ispin,i1,i2) &
                                  &     + c
                 esrd(ia,lmt1,lmt2,ispin,i1,i2)=esrd(ia,lmt1,lmt2,ispin,i1,i2) &
                                  &     + ek_n * c
               enddo
             enddo    ! lmt2
             enddo    ! lmt1
          enddo    ! i
       enddo    ! ik
       enddo    ! ispin
    enddo    !ia
    enddo    !i2
    enddo    !i1

    call mpi_allreduce(hsrd,hsrd_mpi,natm*nlmt*nlmt*nspin*3*3,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
    call mpi_allreduce(esrd,esrd_mpi,natm*nlmt*nlmt*nspin*3*3,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
    hsrd = hsrd_mpi/dble(nrank_g)
    esrd = esrd_mpi/dble(nrank_g)

!!$ASASASASAS
    call dealloc_zfsincos_mpi()
!!$ASASASASAS
    call m_ES_dealloc_arai_3D()
    call m_ES_dealloc_zfsincos()
    deallocate(fsr_diff_l); deallocate(fsi_diff_l)
    deallocate(hsrd_mpi); deallocate(esrd_mpi)

    call tstatc0_end(id_sname)
  end subroutine m_Stress_hsr_diff

  subroutine m_Stress_lclchg_diff(nfout)
    integer, intent(in) :: nfout
    integer    :: n,ilm3,i,it,ik,mdvdb,ia,is,mspin,i1,i2
    integer    :: lmt1,lmt2,il1,il2,tau1,tau2,l3,iiqitg
    real(kind=DP) :: fac,dga,c1,c2
    real(kind=DP), pointer, dimension(:)          :: drhodh
    real(kind=DP),allocatable,target,dimension(:) :: ylm_t
    real(kind=DP), pointer, dimension(:,:)        :: ylmd_mpi
    integer    :: id_sname = -1

    if(modnrm == SKIP) return

    call tstatc0_begin('m_Stress_lclchg_diff ',id_sname)

    allocate(drhodh(nspin))
    allocate(zfcos_tmp(ista_kngp:iend_kngp))
    allocate(zfsin_tmp(ista_kngp:iend_kngp))
    zfcos_tmp = 0.d0; zfsin_tmp = 0.d0
    allocate(vloc(ista_kngp:iend_kngp,kimg)); vloc = 0.d0

    allocate(flchgq(nspin)); flchgq = 0.d0
    allocate(flchgqd(3,3,nspin)); flchgqd = 0.d0

    do ik = 1, kimg
      do it = 1, ntyp
         do i = ista_kngp, iend_kngp  !for mpi
            vloc(i,ik)=vloc(i,ik)+psc_l(i,it)*zfm3_l(i,it,ik)
            if(sw_screening_correction==ON) then
               vloc(i,ik)=vloc(i,ik)-ival(it)*screening%phik(i)/univol*zfm3_l(i,it,ik)
            end if
        enddo
      enddo
    enddo

    call m_PP_find_maximum_l(n)   ! n-1: maximum l
    n = (n-1) + (n-1) + 1
    allocate(il3(n**2)); call substitute_il3(n**2,il3) ! -(b_Elec..)
    allocate(ylm_t(ista_kngp:iend_kngp)); ylm_t = 0.d0
    allocate(ylmd(ista_kngp:iend_kngp,3,n**2)); ylmd = 0.d0
    allocate(ylmd_mpi(ista_kngp:iend_kngp,3)); ylmd_mpi = 0.d0
    do ilm3 = 1, n**2
!mpi       call m_pwBS_sphrp2(ilm3,rltv,ista_kngp,iend_kngp,ylm2(1,ilm3))
!!$       call m_pwBS_sphrp2(ilm3,rltv,ylm2_mpi)
!!$       do i = ista_kngp, iend_kngp  !for mpi
!!$          ylm2(i,ilm3) = ylm2_mpi(i)
!!$       enddo
!mpi       call m_pwBS_sphrp2_diff(ilm3,rltv,ylmd(1,1,ilm3))
       call m_pwBS_sphrp2_diff_3D(ilm3,rltv,ylmd_mpi)
       do i = ista_kngp, iend_kngp  !for mpi
          ylmd(i,1,ilm3) = ylmd_mpi(i,1)
          ylmd(i,2,ilm3) = ylmd_mpi(i,2)
          ylmd(i,3,ilm3) = ylmd_mpi(i,3)
       enddo
    end do
    deallocate(ylmd_mpi)

    do ia = 1, natm
       it = ityp(ia)
       mdvdb = m_PP_include_vanderbilt_pot(it)
       if(mdvdb == SKIP) cycle
       call calc_phase2(natm,pos,ia,kgp,ngabc_kngp_l,ista_kngp,iend_kngp,zfcos_tmp,zfsin_tmp)
                         ! -(b_Elec.)  -> zfcos_tmp, zfsin_tmp
       do lmt1 = 1,ilmt(it)
          il1 = ltp(lmt1,it); tau1 = taup(lmt1,it)
          do lmt2 = lmt1, ilmt(it)
            il2 = ltp(lmt2,it); tau2 = taup(lmt2,it)
            fac = 2.d0 ; if(lmt1 == lmt2) fac = 1.d0
            do n = 1, il2p(lmt1,lmt2,it)
              ilm3 = isph(lmt1,lmt2,n,it)
              l3   =  il3(ilm3)
              iiqitg = iqitg(il1,tau1,il2,tau2,l3+1,it)
              if(iiqitg == 0) cycle
              if(ilm3 <= nel_Ylm) then
                 ylm => ylm_l(ista_kngp:iend_kngp,ilm3)
              else
                 call m_pwBS_sphrp2_3D(ilm3,rltv,ista_kngp,iend_kngp,ylm_t)
                 ylm => ylm_t(ista_kngp:iend_kngp)
              end if
              dga = dl2p(lmt1,lmt2,n,it)

              if (mod(il1+il2,2) == 0) then
                 call even_case
              else
                 call odd_case
              endif

            enddo
          enddo
       enddo
    enddo

    s_xc1  = s_xc1  * univol
    s_h1   = s_h1   * univol * PAI4
    s_loc1 = s_loc1 * univol

    if(af == 0) then
       s_0 = s_xc1
       stress_name = 'X1'
       call check_stress(nfout)
       s_0 = s_h1
       stress_name = 'H1'
       call check_stress(nfout)
       s_0 = s_loc1
       stress_name = 'L1'
       call check_stress(nfout)
    else
       s_up = s_xc1
       stress_name = 'X1'
       call check_af(nfout)
       s_up = s_h1
       stress_name = 'H1'
       call check_af(nfout)
       s_up = s_loc1
       stress_name = 'L1'
       call check_af(nfout)
    endif

    deallocate(zfsin_tmp); deallocate(zfcos_tmp)
    deallocate(vloc)
    deallocate(flchgq); deallocate(flchgqd)
    deallocate(il3)
    deallocate(ylm_t)
    deallocate(ylmd)
    deallocate(drhodh)

    call tstatc0_end(id_sname)

  contains

    subroutine even_case
      do is=1,nspin,af+1
         flchgq(is) = fac*real(zi**(-l3))*dga &
              & *hsr(ia,lmt1,lmt2,is)
         do i1=1,3
            do i2=1,3
               flchgqd(i1,i2,is) = fac*real(zi**(-l3))*dga &
                    & *hsrd(ia,lmt1,lmt2,is,i1,i2)
            enddo
         enddo
      enddo
      if(kimg == 1) then
         call real_case(ilm3,iiqitg,zfcos_tmp)
      else
         call complex_case(ilm3,iiqitg,zfcos_tmp,-zfsin_tmp)
      endif
    end subroutine even_case

    subroutine odd_case
      do is=1,nspin,af+1
         flchgq(is) = fac*aimag(zi**(-l3))*dga &
              & *hsr(ia,lmt1,lmt2,is)
         do i1=1,3
            do i2=1,3
               flchgqd(i1,i2,is) = fac*aimag(zi**(-l3))*dga &
                    & *hsrd(ia,lmt1,lmt2,is,i1,i2)
            enddo
         enddo
      enddo
      if(kimg == 1) then
         call real_case(ilm3,iiqitg,zfsin_tmp)
      else
         call complex_case(ilm3,iiqitg,zfsin_tmp,zfcos_tmp)
      endif
    end subroutine odd_case
    
    subroutine real_case(ilm3,iiqitg,zf)
      integer,       intent(in) :: ilm3,iiqitg
      real(kind=DP), intent(in), dimension(ista_kngp:iend_kngp) :: zf
      real(kind=DP), pointer, dimension(:,:) :: s_xc1_mpi1, s_xc1_mpi2
      real(kind=DP), pointer, dimension(:,:) :: s_h1_mpi1, s_h1_mpi2
      real(kind=DP), pointer, dimension(:,:) :: s_loc1_mpi1, s_loc1_mpi2
      integer :: iy

      allocate(s_xc1_mpi1(3,3)); s_xc1_mpi1 = 0.d0
      allocate(s_h1_mpi1(3,3)); s_h1_mpi1 = 0.d0
      allocate(s_loc1_mpi1(3,3)); s_loc1_mpi1 = 0.d0
      allocate(s_xc1_mpi2(3,3)); s_xc1_mpi2 = 0.d0
      allocate(s_h1_mpi2(3,3)); s_h1_mpi2 = 0.d0
      allocate(s_loc1_mpi2(3,3)); s_loc1_mpi2 = 0.d0

      do is=1,nspin,af+1
        flchgq(is) = flchgq(is) * dble(iwei(ia))
        do i1=1,3
        do i2=1,3
          flchgqd(i1,i2,is) = flchgqd(i1,i2,is) * dble(iwei(ia))
        enddo
        enddo
      enddo

      do i1=1,3
      do i2=1,3
      if(nspin==1 .or. af==1) then
         mspin=(nspin+1)/nspin
         do i = ista_kngp, iend_kngp  !for mpi
            iy = i - ista_kngp+1
            c1=(  g(i,1)*alinvt(1,i2) &
             &  + g(i,2)*alinvt(2,i2) &
             &  + g(i,3)*alinvt(3,i2) )  *g(i,i1) * grinv(i)
            c2=(  ylmd(i,1,ilm3)*alinvt(1,i2) &
             &  + ylmd(i,2,ilm3)*alinvt(2,i2) &
             &  + ylmd(i,3,ilm3)*alinvt(3,i2) )  *g(i,i1)
            drhodh(1) =  &
             &  - flchgq(1) &
             &  *(ylm(iy)*(qitg_l(i,iiqitg)*alinvt(i1,i2) &
             &  +qitg_diff_l(i,iiqitg)*c1) &
             &  +c2*qitg_l(i,iiqitg)) &
             &  + flchgqd(i1,i2,1)*ylm(iy)*qitg_l(i,iiqitg)

            s_xc1_mpi1(i1,i2)=s_xc1_mpi1(i1,i2) &
                 &  +drhodh(1)*vxc_l(i,1,1)*zf(i)
            s_h1_mpi1(i1,i2)=s_h1_mpi1(i1,i2) &
                 &  +grinv(i)**2*drhodh(1) &
                 &  *(chgq_l(i,1,1)+chgq_l(i,1,nspin))/mspin &
                 &  *zf(i)
            s_loc1_mpi1(i1,i2)=s_loc1_mpi1(i1,i2) &
                 &  +drhodh(1)*zf(i)*vloc(i,1)
         enddo
!xocl end spread sum(s_xc1),sum(s_loc1),sum(s_h1)
      else  ! nspin ==2 and af /= 1
         do i = ista_kngp, iend_kngp  !for mpi
            iy = i - ista_kngp + 1
            c1=(  g(i,1)*alinvt(1,i2) &
             &  + g(i,2)*alinvt(2,i2) &
             &  + g(i,3)*alinvt(3,i2) )  *g(i,i1) * grinv(i)
            c2=(  ylmd(i,1,ilm3)*alinvt(1,i2) &
             &  + ylmd(i,2,ilm3)*alinvt(2,i2) &
             &  + ylmd(i,3,ilm3)*alinvt(3,i2) )  *g(i,i1)
            drhodh(1) =  &
             &  - flchgq(1) &
             &  *(ylm(iy)*(qitg_l(i,iiqitg)*alinvt(i1,i2) &
             &  +qitg_diff_l(i,iiqitg)*c1) &
             &  +c2*qitg_l(i,iiqitg)) &
             &  + flchgqd(i1,i2,1)*ylm(iy)*qitg_l(i,iiqitg)
            drhodh(nspin) = &
             &  - flchgq(nspin) &
             &  *(ylm(iy)*(qitg_l(i,iiqitg)*alinvt(i1,i2) &
             &  +qitg_diff_l(i,iiqitg)*c1) &
             &  +c2*qitg_l(i,iiqitg)) &
             &  + flchgqd(i1,i2,nspin)*ylm(iy)*qitg_l(i,iiqitg)

            s_xc1_mpi1(i1,i2)=s_xc1_mpi1(i1,i2) &
                 &  +(drhodh(1)*vxc_l(i,1,1) &
                 &   +drhodh(nspin)*vxc_l(i,1,nspin)) &
                 &   *zf(i)
            s_h1_mpi1(i1,i2)=s_h1_mpi1(i1,i2) &
                 &  +grinv(i)**2*(drhodh(1)+drhodh(nspin)) &
                 &  *(chgq_l(i,1,1)+chgq_l(i,1,nspin))*zf(i)
            s_loc1_mpi1(i1,i2)=s_loc1_mpi1(i1,i2) &
                 &  +(drhodh(1)+drhodh(nspin)) &
                 &  *zf(i)*vloc(i,1)
         enddo
!xocl end spread sum(s_xc1),sum(s_loc1),sum(s_h1)
      endif
      enddo
      enddo
      call mpi_allreduce(s_xc1_mpi1,s_xc1_mpi2,9 &
                   &  ,mpi_double_precision,mpi_sum,mpi_chg_world,ierr)
      call mpi_allreduce(s_h1_mpi1,s_h1_mpi2,9 &
                   &  ,mpi_double_precision,mpi_sum,mpi_chg_world,ierr)
      call mpi_allreduce(s_loc1_mpi1,s_loc1_mpi2,9 &
                   &  ,mpi_double_precision,mpi_sum,mpi_chg_world,ierr)
      s_xc1 = s_xc1 + s_xc1_mpi2
      s_h1 = s_h1 + s_h1_mpi2
      s_loc1 = s_loc1 + s_loc1_mpi2
      deallocate(s_xc1_mpi1); deallocate(s_xc1_mpi2)
      deallocate(s_h1_mpi1); deallocate(s_h1_mpi2)
      deallocate(s_loc1_mpi1); deallocate(s_loc1_mpi2)
    end subroutine real_case

    subroutine complex_case(ilm3,iiqitg,zf1,zf2)
      integer,       intent(in) :: ilm3,iiqitg
      real(kind=DP), intent(in), dimension(ista_kngp:iend_kngp) &
           &  :: zf1,zf2
      real(kind=DP), pointer, dimension(:,:) :: s_xc1_mpi1, s_xc1_mpi2
      real(kind=DP), pointer, dimension(:,:) :: s_h1_mpi1, s_h1_mpi2
      real(kind=DP), pointer, dimension(:,:) :: s_loc1_mpi1, s_loc1_mpi2
      integer :: iy

      allocate(s_xc1_mpi1(3,3)); s_xc1_mpi1 = 0.d0
      allocate(s_h1_mpi1(3,3)); s_h1_mpi1 = 0.d0
      allocate(s_loc1_mpi1(3,3)); s_loc1_mpi1 = 0.d0
      allocate(s_xc1_mpi2(3,3)); s_xc1_mpi2 = 0.d0
      allocate(s_h1_mpi2(3,3)); s_h1_mpi2 = 0.d0
      allocate(s_loc1_mpi2(3,3)); s_loc1_mpi2 = 0.d0

      do i1=1,3
      do i2=1,3
      if(nspin.eq.1 .or. af.eq.1) then
         mspin=(nspin+1)/nspin
         do i = ista_kngp, iend_kngp  !for mpi
            iy = i - ista_kngp + 1
            c1=(  g(i,1)*alinvt(1,i2) &
             &  + g(i,2)*alinvt(2,i2) &
             &  + g(i,3)*alinvt(3,i2) )  *g(i,i1) * grinv(i)
            c2=(  ylmd(i,1,ilm3)*alinvt(1,i2) &
             &  + ylmd(i,2,ilm3)*alinvt(2,i2) &
             &  + ylmd(i,3,ilm3)*alinvt(3,i2) )  *g(i,i1)
            drhodh(1) =  &
             &  - flchgq(1) &
             &  *(ylm(iy)*(qitg_l(i,iiqitg)*alinvt(i1,i2) &
             &  +qitg_diff_l(i,iiqitg)*c1) &
             &  +c2*qitg_l(i,iiqitg)) &
             &  + flchgqd(i1,i2,1)*ylm(iy)*qitg_l(i,iiqitg)

            s_xc1_mpi1(i1,i2)=s_xc1_mpi1(i1,i2) &
                 &  +drhodh(1) &
                 &  *(vxc_l(i,1,1)*zf1(i)+vxc_l(i,2,1)*zf2(i))
            s_h1_mpi1(i1,i2)=s_h1_mpi1(i1,i2) &
                 &  +grinv(i)**2*drhodh(1) &
                 &  *((chgq_l(i,1,1)+chgq_l(i,1,nspin))/mspin*zf1(i) &
                 &   +(chgq_l(i,2,1)+chgq_l(i,2,nspin))/mspin*zf2(i))
            s_loc1_mpi1(i1,i2)=s_loc1_mpi1(i1,i2) &
                 &  +drhodh(1) &
                 &  *(zf1(i)*vloc(i,1)+zf2(i)*vloc(i,2))
         enddo
!xocl end spread sum(s_xc1),sum(s_loc1),sum(s_h1)
      else  ! nspin ==2 and af /= 1
         do i = ista_kngp, iend_kngp  !for mpi
            iy = i - ista_kngp + 1
            c1=(  g(i,1)*alinvt(1,i2) &
             &  + g(i,2)*alinvt(2,i2) &
             &  + g(i,3)*alinvt(3,i2) )  *g(i,i1) * grinv(i)
            c2=(  ylmd(i,1,ilm3)*alinvt(1,i2) &
             &  + ylmd(i,2,ilm3)*alinvt(2,i2) &
             &  + ylmd(i,3,ilm3)*alinvt(3,i2) )  *g(i,i1)
            drhodh(1) =  &
             &  - flchgq(1) &
             &  *(ylm(iy)*(qitg_l(i,iiqitg)*alinvt(i1,i2) &
             &  +qitg_diff_l(i,iiqitg)*c1) &
             &  +c2*qitg_l(i,iiqitg)) &
             &  + flchgqd(i1,i2,1)*ylm(iy)*qitg_l(i,iiqitg)
            drhodh(nspin) = &
             &  - flchgq(nspin) &
             &  *(ylm(iy)*(qitg_l(i,iiqitg)*alinvt(i1,i2) &
             &  +qitg_diff_l(i,iiqitg)*c1) &
             &  +c2*qitg_l(i,iiqitg)) &
             &  + flchgqd(i1,i2,nspin)*ylm(iy)*qitg_l(i,iiqitg)

            s_xc1_mpi1(i1,i2)=s_xc1_mpi1(i1,i2) &
                 &  +drhodh(1) &
                 &  *(vxc_l(i,1,1)*zf1(i)+vxc_l(i,2,1)*zf2(i)) &
                 &  +drhodh(nspin) &
                 &  *(vxc_l(i,1,nspin)*zf1(i)+vxc_l(i,2,nspin)*zf2(i))
            s_h1_mpi1(i1,i2)=s_h1_mpi1(i1,i2) &
                 &  +grinv(i)**2*(drhodh(1)+drhodh(nspin)) &
                 &  *((chgq_l(i,1,1)+chgq_l(i,1,nspin))*zf1(i) &
                 &   +(chgq_l(i,2,1)+chgq_l(i,2,nspin))*zf2(i))
            s_loc1_mpi1(i1,i2)=s_loc1_mpi1(i1,i2) &
                 &  +(drhodh(1)+drhodh(nspin)) &
                 &  *(zf1(i)*vloc(i,1)+zf2(i)*vloc(i,2))
         enddo
!xocl end spread sum(s_xc1),sum(s_loc1),sum(s_h1)
      endif
      enddo
      enddo
      call mpi_allreduce(s_xc1_mpi1,s_xc1_mpi2,9 &
                   &  ,mpi_double_precision,mpi_sum,mpi_chg_world,ierr)
      call mpi_allreduce(s_h1_mpi1,s_h1_mpi2,9 &
                   &  ,mpi_double_precision,mpi_sum,mpi_chg_world,ierr)
      call mpi_allreduce(s_loc1_mpi1,s_loc1_mpi2,9 &
                   &  ,mpi_double_precision,mpi_sum,mpi_chg_world,ierr)
      s_xc1 = s_xc1 + s_xc1_mpi2
      s_h1 = s_h1 + s_h1_mpi2
      s_loc1 = s_loc1 + s_loc1_mpi2
      deallocate(s_xc1_mpi1); deallocate(s_xc1_mpi2)
      deallocate(s_h1_mpi1); deallocate(s_h1_mpi2)
      deallocate(s_loc1_mpi1); deallocate(s_loc1_mpi2)
    end subroutine complex_case

  end subroutine m_Stress_lclchg_diff

  subroutine m_Stress_check_g12(nfout)
    integer, intent(in) :: nfout
    if(af == 0) then
       s_0 = s_gga1
       stress_name = 'G1'
       call check_stress(nfout)
       s_0 = s_gga2
       stress_name = 'G2'
       call check_stress(nfout)
    else
       s_up = s_gga1
       stress_name = 'G1'
       call check_af(nfout)
       s_up = s_gga2
       stress_name = 'G2'
       call check_af(nfout)
    endif
  end subroutine m_Stress_check_g12

  subroutine m_Stress_xc(nfout)
    integer, intent(in) :: nfout
    integer    :: is,ig,i,j,ia,it,ipc
    real(kind=DP) :: vxcp,pc
    integer    :: id_sname = -1
    integer       :: iend  !mpi
    real(kind=DP) :: vxcp_mpi
    real(kind=DP), pointer, dimension(:,:) :: s_xc2_mpi1, s_xc2_mpi2
    real(kind=DP), pointer, dimension(:,:) :: s_pc_mpi1, s_pc_mpi2

    call tstatc0_begin('m_Stress_xc ',id_sname)

    allocate(zfcos_tmp(ista_kngp:iend_kngp))
    allocate(zfsin_tmp(ista_kngp:iend_kngp))
    zfcos_tmp = 0.d0; zfsin_tmp = 0.d0

    vxcp_mpi = 0.d0
    vxcp=0.d0
    if(kimg==1) then
       do is=1,nspin
          iend = iend_kngp
          if( iend_kngp > kg ) iend = kg
          if( ista_kngp <= iend ) then
             do i = ista_kngp, iend  !for mpi
                vxcp_mpi=vxcp_mpi+vxc_l(i,1,is)*chgsoft(i,1,is)
             enddo
          endif
!xocl end spread sum(vxcp)
       enddo
    else
       do is=1,nspin
          iend = iend_kngp
          if( iend_kngp > kg ) iend = kg
          if( ista_kngp <= iend ) then
             do i = ista_kngp, iend  !for mpi
                vxcp_mpi=vxcp_mpi+vxc_l(i,1,is)*chgsoft(i,1,is) &
                     &    +vxc_l(i,2,is)*chgsoft(i,2,is)
             enddo
          endif
!xocl end spread sum(vxcp)
       enddo
    endif
    call mpi_allreduce(vxcp_mpi,vxcp,1 &
         &  ,mpi_double_precision,mpi_sum,mpi_chg_world,ierr)

!    s_xc2 = ( exc +ecnl_vdwdf -vxcp *univol ) *alinvt
#ifndef DISABLE_VDWDF
    s_xc2 = ( exc +ecnl_vdwdf -vxcp *univol ) *alinvt
#else
    s_xc2 = ( exc -vxcp *univol ) *alinvt
#endif

    allocate(s_xc2_mpi1(3,3)); s_xc2_mpi1 = 0.d0
    allocate(s_xc2_mpi2(3,3)); s_xc2_mpi2 = 0.d0
    allocate(s_pc_mpi1(3,3)); s_pc_mpi1 = 0.d0
    allocate(s_pc_mpi2(3,3)); s_pc_mpi2 = 0.d0

    do ia = 1, natm
    it=ityp(ia)
    if(itpcc(it).ne.0) then
       call calc_phase2(natm,pos,ia,kgp,ngabc_kngp_l,ista_kngp,iend_kngp,zfcos_tmp,zfsin_tmp)
                         ! -(b_Elec.)  -> zfcos_tmp, zfsin_tmp       
       ipc=itpcc(it)
       if(kimg==1) then
          do is=1,nspin
          do i=1,3
          do j=1,3
             do ig = ista_kngp, iend_kngp  !for mpi
                pc = (rhpcg_l(ig,ipc)*alinvt(i,j) &
                     &   +rhpcg_diff_l(ig,ipc)*grinv(ig)*g(ig,i) &
                     &   *(g(ig,1)*alinvt(1,j)+g(ig,2)*alinvt(2,j) &
                     &    +g(ig,3)*alinvt(3,j))) &
                     &   *univol &
                     &   * dble(iwei(ia))
                s_xc2_mpi1(i,j) = s_xc2_mpi1(i,j) &
                     &   - vxc_l(ig,1,is) * zfcos_tmp(ig) * pc / nspin
                s_pc_mpi1(i,j) = s_pc_mpi1(i,j) &
                     &   - vxcpc_l(ig,1) * zfcos_tmp(ig) * pc / nspin
             enddo
          enddo
          enddo
          enddo
!xocl end spread sum(s_xc2),sum(s_pc)
       else
          do is=1,nspin
          do i=1,3
          do j=1,3
             do ig = ista_kngp, iend_kngp  !for mpi
                pc = (rhpcg_l(ig,ipc)*alinvt(i,j) &
                     &   +rhpcg_diff_l(ig,ipc)*grinv(ig)*g(ig,i) &
                     &   *(g(ig,1)*alinvt(1,j)+g(ig,2)*alinvt(2,j) &
                     &    +g(ig,3)*alinvt(3,j))) &
                     &   *univol &
                     &   * dble(iwei(ia))
                s_xc2_mpi1(i,j) = s_xc2_mpi1(i,j) &
                     &   - (vxc_l(ig,1,is) * zfcos_tmp(ig) &
                     &    - vxc_l(ig,2,is) * zfsin_tmp(ig) ) * pc / nspin
                s_pc_mpi1(i,j) = s_pc_mpi1(i,j) &
                     &   - (vxcpc_l(ig,1) * zfcos_tmp(ig) &
                     &    - vxcpc_l(ig,2) * zfsin_tmp(ig) ) * pc / nspin
             enddo
          enddo
          enddo
          enddo
!xocl end spread sum(s_xc2),sum(s_pc)
       endif
    endif
    enddo

    call mpi_allreduce(s_xc2_mpi1,s_xc2_mpi2,9 &
         &  ,mpi_double_precision,mpi_sum,mpi_chg_world,ierr)
    call mpi_allreduce(s_pc_mpi1,s_pc_mpi2,9 &
         &  ,mpi_double_precision,mpi_sum,mpi_chg_world,ierr)

    s_xc2 = s_xc2 + s_xc2_mpi2
    s_pc = s_pc + s_pc_mpi2 + epc * alinvt
    deallocate(s_xc2_mpi1); deallocate(s_xc2_mpi2)
    deallocate(s_pc_mpi1); deallocate(s_pc_mpi2)

    s_0 = s_pc
    stress_name = 'PC'
    call check_stress(nfout)
    s_0 = s_xc1
    stress_name = 'X1'
    call check_stress(nfout)
    s_0 = s_xc2
    stress_name = 'X2'
    call check_stress(nfout)
    if(af == 0) then
       s_0 = s_xc1 + s_xc2 + s_gga1 + s_gga2
       stress_name = 'XC'
       call check_stress(nfout)
    else
       s_0 = s_xc2
       stress_name = 'X2'
       call check_stress(nfout)
    endif

    deallocate(zfsin_tmp); deallocate(zfcos_tmp)

    call tstatc0_end(id_sname)
  end subroutine m_Stress_xc

  subroutine m_Stress_loc(nfout)
    integer, intent(in) :: nfout
    integer    :: i,j,it,is,ik,ig
    real(kind=DP) :: rsv
    integer    :: id_sname = -1
    integer    :: ist  !mpi
    real(kind=DP), pointer, dimension(:,:) :: s_loc2_mpi
    real(kind=DP) :: rsv_mpi

! ========================= added by K. Tagami =========== 11.0
    integer :: ismax
! ======================================================== 11.0

    call tstatc0_begin('m_Stress_loc ',id_sname)

    allocate(s_loc2_mpi(3,3)); s_loc2_mpi = 0.d0

! ========================= added by K. Tagami =========== 11.0
    if ( noncol ) then
       ismax = 1
    else
       ismax = nspin
    endif
! ======================================================== 11.0

! ======================== modified by K. Tagami ======== 11.0
!    do is=1,nspin
    do is=1, ismax
! ======================================================== 11.0
       do i=1,3
          do j=1,3
             do it=1,ntyp
                do ik=1,kimg
                   ist = ista_kngp
                   if(ista_kngp==1) ist = 2
                   do ig = ist, iend_kngp  !for mpi
                      s_loc2_mpi(i,j) = s_loc2_mpi(i,j) &
                           &  - univol  &
                           &    * chgq_l(ig,ik,is)*zfm3_l(ig,it,ik)*psc_diff_l(ig,it) &
                           &    * 2.d0 * g(ig,i) &
                           &    * (g(ig,1)*alinvt(1,j)+g(ig,2)*alinvt(2,j) &
                           &      +g(ig,3)*alinvt(3,j))
                   enddo
!xocl end spread sum(s_loc2)
                enddo
             enddo
          enddo
       enddo
    enddo
    
    call mpi_allreduce( s_loc2_mpi, s_loc2, 9, &
         &              mpi_double_precision, mpi_sum, mpi_chg_world, ierr )
    deallocate(s_loc2_mpi)

    rsv_mpi = 0.d0
    rsv = 0.d0

    ist = ista_kngp
    if(ista_kngp==1) ist = 2

! ======================== modified by K. Tagami ======== 11.0
!    do is=1,nspin
    do is=1, ismax
! ======================================================== 11.0

      do it=1,ntyp
         do ik=1,kimg
            do ig = ist, iend_kngp  !for mpi
               rsv_mpi = rsv_mpi + chgsoft(ig,ik,is)*zfm3_l(ig,it,ik)*psc_l(ig,it)
              if(sw_screening_correction==ON) then
                  rsv_mpi = rsv_mpi - chgsoft(ig,ik,is)*zfm3_l(ig,it,ik)*ival(it)*Screening%phik(i)/univol
              end if
            enddo
         enddo
      enddo
    enddo

    call mpi_allreduce( rsv_mpi, rsv, 1, &
         &              mpi_double_precision, mpi_sum, mpi_chg_world, ierr )

    s_loc2 = s_loc2 - (etot1*totch + univol*rsv) * alinvt

    if(af == 0) then
       s_0 = s_loc1 + s_loc2
       stress_name = 'LO'
       call check_stress(nfout)
    else
       s_0 = s_loc2
       stress_name = 'L2'
       call check_stress(nfout)
    endif

    call tstatc0_end(id_sname)
  end subroutine m_Stress_loc

  subroutine m_Stress_h(nfout)
    integer, intent(in) :: nfout
    integer    :: i,j,ik,ig
    integer    :: id_sname = -1
    real(kind=DP) :: eh
    integer       :: ist  !mpi
    real(kind=DP) :: eh_mpi
    real(kind=DP), pointer, dimension(:,:) :: s_h2_mpi1, s_h2_mpi2

    call tstatc0_begin('m_Stress_h ',id_sname)

    ist = ista_kngp
    if(ista_kngp==1) ist = 2

    eh = 0.d0
    do ik = 1,kimg
! ========================== modified by K. Tagami ========== 11.0
!       if(nspin.eq.1) then
       if ( nspin.eq.1 .or. noncol ) then
! ============================================================ 11.0
          do i = ist, iend_kngp  !for mpi
             eh = eh + (chgq_l(i,ik,1)*grinv(i))**2
          enddo
       else if(nspin.eq.2) then
          do i = ist, iend_kngp  !for mpi
             eh = eh + ((chgq_l(i,ik,1)+chgq_l(i,ik,nspin))*grinv(i))**2
          enddo
       endif
    enddo

    do ik = 1, kimg
! ========================== modified by K. Tagami ========== 11.0
!       if(nspin.eq.1) then
       if ( nspin.eq.1 .or. noncol ) then
! ============================================================ 11.0
          do i = ist, iend_kngp  !for mpi
             eh = eh - 2 * chgq_l(i,ik,1)*chgsoft(i,ik,1)*grinv(i)**2
          enddo
       else if(nspin.eq.2) then
          do i = ist, iend_kngp  !for mpi
             eh = eh - 2 * (chgq_l(i,ik,1)+chgq_l(i,ik,nspin)) &
                  &  * (chgsoft(i,ik,1)+chgsoft(i,ik,nspin)) * grinv(i)**2
          enddo
      endif
    enddo

    if(npes > 1) then
       call mpi_allreduce(eh,eh_mpi,1 &
            &  ,mpi_double_precision,mpi_sum,mpi_chg_world,ierr)
       eh = eh_mpi
    end if

    eh = univol*pai4*eh*0.5d0
    s_h2 = s_h2 + eh * alinvt

    allocate(s_h2_mpi1(3,3)); s_h2_mpi1 = 0.d0
    allocate(s_h2_mpi2(3,3)); s_h2_mpi2 = 0.d0

    do i=1,3
       do j=1,3
          do ik=1,kimg
! ========================== modified by K. Tagami ========== 11.0
!             if(nspin.eq.1) then
             if ( nspin.eq.1 .or. noncol ) then
! ============================================================ 11.0
                do ig = ist, iend_kngp  !for mpi
                   s_h2_mpi1(i,j) = s_h2_mpi1(i,j) &
                        &   + univol*pai4 &
                        &   *chgq_l(ig,ik,1)**2*grinv(ig)**4 &
                        &   *g(ig,i) &
                        &   *(g(ig,1)*alinvt(1,j)+g(ig,2)*alinvt(2,j)+g(ig,3)*alinvt(3,j))
                enddo
             else if(nspin.eq.2) then
                do ig = ist, iend_kngp  !for mpi
                   s_h2_mpi1(i,j) = s_h2_mpi1(i,j) &
                        &   + univol*pai4 &
                        &   *(chgq_l(ig,ik,1)+chgq_l(ig,ik,nspin))**2*grinv(ig)**4 &
                        &   *g(ig,i) &
                        &   *(g(ig,1)*alinvt(1,j)+g(ig,2)*alinvt(2,j)+g(ig,3)*alinvt(3,j))
                enddo
             endif
          enddo
       enddo
    enddo

    if(npes > 1) then
       call mpi_allreduce(s_h2_mpi1,s_h2_mpi2,9 &
            &  ,mpi_double_precision,mpi_sum,mpi_chg_world,ierr)
    else
       s_h2_mpi2 = s_h2_mpi1
    end if

    s_h2 = s_h2 + s_h2_mpi2
    deallocate(s_h2_mpi1); deallocate(s_h2_mpi2)

    if(af == 0) then
       s_0 = s_h1 +s_h2
       stress_name = 'HA'
       call check_stress(nfout)
       s_0 = s_h2
       stress_name = 'H2'
       call check_stress(nfout)
    else
       s_0 = s_h2
       stress_name = 'H2'
       call check_stress(nfout)
    endif

    call tstatc0_end(id_sname)
  end subroutine m_Stress_h

  subroutine m_Stress_ew(nfout)
    integer, intent(in) :: nfout

    s_0 = s_ew
    stress_name = 'EW'
    call check_stress(nfout)

  end subroutine m_Stress_ew

! =================================== KT_add ====================== 13.0B
  subroutine m_Stress_vdw(nfout)
    integer, intent(in) :: nfout
    integer :: i, j

    s_0 = s_vdw
    stress_name = 'VDW'

!    call check_stress(nfout)
    if(ipri >= 1) write(nfout,'(''  STRESS TENSOR'',5x,A2,/,(3f20.10))') &
         &     stress_name,((s_0(i,j),j=1,3),i=1,3)

  end subroutine m_Stress_vdw
! ================================================================= 13.0B
#ifndef DISABLE_VDWDF
  subroutine m_Stress_vdwdf(nfout)
    integer, intent(in) :: nfout
    integer :: i, j

!    s_vdwdf = s_cnl1 +s_cnl2 -s_cnl1_pc -s_cnl2_pc
    s_vdwdf = s_cnl1 +s_cnl2
    s_0 = s_vdwdf
!
    stress_name = 'VDWDF'

!    call check_stress(nfout)
    if(ipri >= 1) write(nfout,'(''  STRESS TENSOR'',5x,A2,/,(3f20.10))') &
         &     stress_name,((s_0(i,j),j=1,3),i=1,3)

  end subroutine m_Stress_vdwdf
#endif

  subroutine m_Stress_nl(nfout)
    integer, intent(in) :: nfout
    integer    :: i,j,ia,it,ispin,lmt1,lmt2,il1,il2,im1,im2
    integer    :: id_sname = -1
    real(kind=DP) :: fac

    call tstatc0_begin('m_Stress_nl ',id_sname)

    do i = 1, 3
    do j = 1, 3
    do ispin = 1, nspin, af+1
    do it = 1, ntyp
    do lmt1 = 1, ilmt(it)
    il1 = ltp(lmt1,it)
    im1 = mtp(lmt1,it)
    do lmt2 = lmt1, ilmt(it)
    il2 = ltp(lmt2,it)
    im2 = mtp(lmt2,it)
    if(ipaw(it)==0) then
        if(il1==il2 .and. im1==im2) then
           do ia = 1, natm
           if(ityp(ia)==it) then
              fac = 2.d0*dble(iwei(ia))
              if(lmt1==lmt2) fac = fac*0.5d0
              s_nl(i,j) = s_nl(i,j) &
                & + fac * dion(lmt1,lmt2,it) * hsrd(ia,lmt1,lmt2,ispin,i,j)

!              write(980,*) 'i j it = ', i, j, it
!              write(980,*) 'lmt1 kmt2 ia = ', lmt1, lmt2, ia
!              write(980,*) 'dion= ', dion(lmt1,lmt2,it)
!              write(980,*) 'hsrd= ', hsrd(ia,lmt1,lmt2,1,i,j), &       
!                   &                 hsrd(ia,lmt1,lmt2,2,i,j)
           endif
           enddo
!
        endif
    else
! --- Check ---
       do ia = 1, natm
       if(ityp(ia)==it) then
          fac = 2.d0*dble(iwei(ia))
          if(lmt1==lmt2) fac = fac*0.5d0
          s_nl(i,j) = s_nl(i,j) &
            & + fac * dion_paw(lmt1,lmt2,ispin,ia) * hsrd(ia,lmt1,lmt2,ispin,i,j)
       endif
       enddo
    endif
    enddo  ! lmt2
    enddo  ! lmt1
    enddo  ! it
    enddo  ! ispin
    enddo  ! j
    enddo  ! i

    if(af == 0) then
       s_0 = s_nl
       stress_name = 'NL'
       call check_stress(nfout)
    else
       s_up = s_nl
       stress_name = 'NL'
       call check_af(nfout)
    endif

    call tstatc0_end(id_sname)
  end subroutine m_Stress_nl

  subroutine m_Stress_or(nfout)
    integer, intent(in) :: nfout
    integer    :: i,j,ia,it,ispin,lmt1,lmt2,il1,il2,im1,im2
    integer    :: id_sname = -1
    real(kind=DP) :: fac

    call tstatc0_begin('m_Stress_or ',id_sname)

    do i = 1, 3
    do j = 1, 3
    do ispin = 1, nspin, af+1
    do it = 1, ntyp
    do lmt1 = 1, ilmt(it)
    il1 = ltp(lmt1,it)
    im1 = mtp(lmt1,it)
    do lmt2 = lmt1, ilmt(it)
    il2 = ltp(lmt2,it)
    im2 = mtp(lmt2,it)
    if(il1==il2 .and. im1==im2) then
       do ia = 1, natm
       if(ityp(ia)==it) then
          fac = 2.d0*dble(iwei(ia))
          if(lmt1==lmt2) fac = fac*0.5d0
          s_or(i,j) = s_or(i,j) &
            & + fac * q(lmt1,lmt2,it) * esrd(ia,lmt1,lmt2,ispin,i,j)
       endif
       enddo
    endif
    enddo  ! lmt2
    enddo  ! lmt1
    enddo  ! it
    enddo  ! ispin
    enddo  ! j
    enddo  ! i

    if(af == 0) then
       s_0 = s_or
       stress_name = 'OR'
       call check_stress(nfout)
    else
       s_up = s_or
       stress_name = 'OR'
       call check_af(nfout)
    endif

    call tstatc0_end(id_sname)
  end subroutine m_Stress_or

! =========================== Added by K. Tagami =========== p1100
  subroutine m_Stress_Hub(nfout)
    integer, intent(in) :: nfout
    integer    :: i,j,ia,it,ispin,lmt1,lmt2,il1,il2,im1,im2
!
    integer ih, l1p
!
    integer    :: id_sname = -1
    real(kind=DP) :: fac

    call tstatc0_begin('m_Stress_Hub ',id_sname)

    do i = 1, 3
       do j = 1, 3
          do ispin = 1, nspin, af+1
             do ia = 1, natm
                ih = ihubbard(ia)
                if(ih == 0) cycle
                it = ityp(ia)
                l1p = proj_attribute(ih)%l+1
                do lmt1 = 1, ilmt(it)
                   il1 = ltp(lmt1,it); im1 = mtp(lmt1,it)
                   if(il1 /= l1p) cycle
                   do lmt2 = lmt1, ilmt(it)
                      il2 = ltp(lmt2,it); im2 = mtp(lmt2,it)
                      if(il2 /= l1p) cycle
      !!$if(im1 /= im2) cycle
                      fac = 2.d0*iwei(ia); if(lmt1 == lmt2) fac = fac*0.5d0
                      s_hub(i,j) = s_hub(i,j) &
                           & + fac * dhub(lmt1,lmt2,ia,ispin)  &
                           &       * hsrd(ia,lmt1,lmt2,ispin,i,j)
                   end do
                end do
             end do
          end do
       enddo
    enddo
! --
!    if ( nspin==1 ) then
!       s_hub =s_hub * 2.0d0
!    endif
!    s_hub = 0.0d0
    ! --
    if(af == 0) then
       s_0 = s_hub
       stress_name = 'HU'
       call check_stress(nfout)
    else
       s_up = s_hub
       stress_name = 'HU'
       call check_af(nfout)
    endif

    call tstatc0_end(id_sname)
  end subroutine m_Stress_Hub

  subroutine check_stress(nfout)
    integer, intent(in) :: nfout
    integer             :: i,j,k,l,iopr

    s_1 = 0.d0
    s_2 = 0.d0
    do i=1,3
    do j=1,3
      do k=1,3
      s_1(i,j)=s_1(i,j)-s_0(i,k)*altv(j,k)/univol
      enddo
    enddo
    enddo

    do i=1,3
    do j=1,3
      do k=1,3
      do l=1,3
        do iopr=1,nopr
        s_2(i,j)=s_2(i,j) + op(i,k,iopr)*op(j,l,iopr)*s_1(k,l)
        enddo
      enddo
      enddo
    s_2(i,j)=s_2(i,j)/nopr
    enddo
    enddo

    if(ipri >= 1) write(nfout,'(''  STRESS TENSOR'',5x,A2,/,(3f20.10))') &
         &     stress_name,((s_2(i,j),j=1,3),i=1,3)
  end subroutine check_stress

  subroutine check_af(nfout)
    integer, intent(in) :: nfout
    integer             :: i,j,k,l,iopr

    s_1 = 0.d0
    s_2 = 0.d0
    s_dn = 0.d0

    do i=1,3
    do j=1,3
      do k=1,3
      s_1(i,j)=s_1(i,j)-s_up(i,k)*altv(j,k)/univol
      enddo
    enddo
    enddo

    iopr = nopr +af
    do i=1,3
    do j=1,3
      do k=1,3
      do l=1,3
        s_dn(i,j)=s_dn(i,j) + op(i,k,iopr)*op(j,l,iopr)*s_1(k,l)
      enddo
      enddo
    enddo
    enddo

    s_1 = s_1 + s_dn

    do i=1,3
    do j=1,3
      do k=1,3
      do l=1,3
        do iopr=1,nopr
        s_2(i,j)=s_2(i,j) + op(i,k,iopr)*op(j,l,iopr)*s_1(k,l)
        enddo
      enddo
      enddo
    s_2(i,j)=s_2(i,j)/nopr
    enddo
    enddo

    if(ipri >= 1) write(nfout,'(''  STRESS TENSOR'',5x,A2,/,(3f20.10))') &
         &     stress_name,((s_2(i,j),j=1,3),i=1,3)
  end subroutine check_af

  subroutine m_Stress_sum(nfout)
    integer, intent(in) :: nfout
    integer             :: i,j,k,l,iopr
    real(kind=DP) :: c1
    real(kind=DP) :: altv_brav(3,3)

    s_tmp=0.d0
    s=0.d0
    if(af==0) then
       s = s_ke + s_xc1 + s_xc2 + s_gga1 + s_gga2 + s_loc1 + s_loc2 &
         &  + s_h1 + s_h2 + s_nl - s_or + s_ew

! ================================== Added by K. Tagami ======= p1100
       s = s + s_hub
! ============================================================== p1100

       do i=1,3
         do j=1,3
           do k=1,3
             s_tmp(i,j) = s_tmp(i,j) - s(i,k) * altv(j,k) / univol
           enddo
         enddo
       enddo
    else
       s_up = s_ke + s_xc1 + s_gga1 + s_gga2 + s_loc1 &
         &  + s_h1 + s_nl - s_or

! ================================== Added by K. Tagami ======= p1100
       s_up = s_up + s_hub
! ============================================================= p1100

       do i=1,3
         do j=1,3
           do k=1,3
             s_tmp(i,j) = s_tmp(i,j) - s_up(i,k) * altv(j,k) / univol
           enddo
         enddo
       enddo
       iopr = nopr + af
       s_dn = 0.d0
       do i=1,3
         do j=1,3
           do k=1,3
             do l=1,3
               s_dn(i,j) = s_dn(i,j) + op(i,k,iopr)*op(j,l,iopr)*s_tmp(k,l)
             enddo
           enddo
         enddo
       enddo
       s_tmp = s_tmp + s_dn
       s = s_xc2 + s_loc2 + s_h2 + s_ew

       do i=1,3
         do j=1,3
           do k=1,3
             s_tmp(i,j) = s_tmp(i,j) - s(i,k) * altv(j,k) / univol
           enddo
         enddo
       enddo
    endif

! ================================== KT_add  =============== 13.0B
    if ( sw_vdw_correction == ON ) s_tmp = s_tmp +s_vdw
! ========================================================== 13.0B
!    if ( xctype == "vdwdf" ) s = s +s_vdwdf

    s = 0.d0
    do i=1,3
      do j=1,3
        do k=1,3
          do l=1,3
            do iopr=1,nopr
              s(i,j) = s(i,j) + op(i,k,iopr)*op(j,l,iopr)*s_tmp(k,l)
            enddo
          enddo
        enddo
      enddo
    enddo
    s = s / nopr

    if ( xctype == "vdwdf" ) s = s +s_vdwdf

    if(ipri >= 1) write(nfout,'(''  STRESS TENSOR'',/,(3f20.10))') &
         &     ((s(i,j),j=1,3),i=1,3)

! ============================= KT_add ======================== 13.0B
    if (ipri >= 1) then
       write(nfout,*) '-------------------------- '
       write(nfout,'(''  External STRESS TENSOR'',/,(3f20.10))') &
            &            ( ( -external_stress(i,j),j=1,3),i=1,3)
       write(nfout,'(''  Total STRESS TENSOR'',/,(3f20.10))') &
            &            ( ( s(i,j)-external_stress(i,j),j=1,3),i=1,3)
       write(nfout,*) '-------------------------- '
    endif
! ============================================================= 13.0B

! ================================ KT_mod ================== 13.0B
!    stressmx = abs(s(1,1))
!    do i=1,3
!       do j=1,3
!          if(abs(s(j,i))>stressmx) stressmx = abs(s(j,i))
!       enddo
!    enddo
!    currstress(:,:) = s(:,:)
!    if(sw_uniform==ON)then
!       stressmx = abs(currstress(1,1)+currstress(2,2)+currstress(3,3))/3.0d0
!    endif

    currstress = s -external_stress
!
    stressmx = abs(currstress(1,1))
    do i=1,3
       do j=1,3
          if(abs(currstress(j,i))>stressmx) stressmx = abs(currstress(j,i))
       enddo
    enddo
    if ( sw_uniform == ON ) then
       stressmx = abs(currstress(1,1)+currstress(2,2)+currstress(3,3))/3.0d0
    endif

! === KT_add === 13.1AS
    if ( sw_neglect_stress_offdiagonal == ON ) then
       s_tmp = 0.0d0
       s_tmp(1,1) = currstress(1,1)
       s_tmp(2,2) = currstress(2,2)
       s_tmp(3,3) = currstress(3,3)

       stressmx = 0.0d0
       do i=1,3
          c1 = sqrt( s_tmp(i,1)**2 +s_tmp(i,2)**2 +s_tmp(i,3)**2 )
          if ( c1 > stressmx ) stressmx = c1
       enddo
    endif

    if ( sw_fix_lattice_angles == ON .or. sw_fix_lattice_lengths == ON ) then
       call get_latvec_from_prim_to_brav( p2bmat, altv, altv_brav )

       s_tmp = projected_stress_along_latvecs( altv_brav, currstress )
       stressmx = 0.0d0

       if ( sw_fix_lattice_angles == ON ) then
          s_tmp = constrain_on_stress_type1( altv_brav, s_tmp )
       endif
       if ( sw_fix_lattice_lengths == ON ) then
          s_tmp = constrain_on_stress_type2( altv_brav, s_tmp )
       endif

       do i=1,3
          c1 = sqrt( s_tmp(i,1)**2 +s_tmp(i,2)**2 +s_tmp(i,3)**2 )
          if ( c1 > stressmx ) stressmx = c1
       enddo
    endif
! ============= 13.1AS

! ================================================================= 13.0B

  end subroutine m_Stress_sum

  function m_Stress_get_stressmx() result(res)
     real(kind=DP) :: res
     res = stressmx
  end function m_Stress_get_stressmx

  subroutine m_Stress_set_stressmx(strmx)
    real(kind=DP), intent(in) :: strmx
    stressmx = strmx
  end subroutine m_Stress_set_stressmx

  function m_Stress_get_curr_stress() result(res)
     real(kind=DP), dimension(3,3) :: res
     res = currstress
  end function m_Stress_get_curr_stress

! === KT_add ==== 13.1AS
function projected_stress_along_latvecs(altv_in,stress) result(ret)
  real(kind=DP), dimension(3,3), intent(in) :: stress, altv_in
  real(kind=DP), dimension(3,3) :: ret

  integer :: i
  real(kind=DP) :: normalized_lat_vec(3,3), c1
!
  Do i=1, 3
     c1 = sqrt( altv_in(1,i)**2 +altv_in(2,i)**2 + altv_in(3,i)**2 )
     normalized_lat_vec(:,i) = altv_in(:,i) / c1
  End do

  ret = 0.0d0

  do i=1,3
     ret(1,i) = dot_product(stress(i,:),normalized_lat_vec(:,1)) ! a-vec
     ret(2,i) = dot_product(stress(i,:),normalized_lat_vec(:,2)) ! b-vec
     ret(3,i) = dot_product(stress(i,:),normalized_lat_vec(:,3)) ! c-vec
  enddo
end function projected_stress_along_latvecs

function constrain_on_stress_type1(altv_in,s_in) result(s_out)
  real(kind=DP), intent(in) :: s_in(3,3), altv_in(3,3)
  real(kind=DP) :: s_out(3,3)

  integer :: i
  real(kind=DP) :: c1, c2, c3
  real(kind=DP) :: normalized_lat_vec(3,3), vectmp(3), vectmp2(3)
!
  s_out = s_in
!
  Do i=1, 3
     c1 = sqrt( altv_in(1,i)**2 +altv_in(2,i)**2 + altv_in(3,i)**2 )
     normalized_lat_vec(:,i) = altv_in(:,i) / c1
  End do

! -----------------------------------
  if ( fix_angle_alpha .and. fix_angle_beta .and. fix_angle_gamma ) then
     Do i=1, 3
        c1 = dot_product( s_out(i,:), normalized_lat_vec(:,i) )
        s_out(i,:) = c1 *normalized_lat_vec(:,i)
     End do
     return
  endif

! -----------------------------------
  if ( fix_angle_alpha ) then
     vectmp(:) = normalized_lat_vec(:,2) + normalized_lat_vec(:,3)

     Do i=2, 3
        c1 = dot_product( vectmp(:), normalized_lat_vec(:,i) )
        vectmp2(:) = vectmp(:) - c1*normalized_lat_vec(:,i)

        c2 = sqrt( vectmp2(1)**2 + vectmp2(2)**2 + vectmp2(3)**2 )
        vectmp2 = vectmp2 /c2

        c3 = dot_product( s_out(i,:), vectmp2(:) )
        s_out(i,:) = s_out(i,:) - c3 *vectmp2(:)
     End do
  endif

! -----------------------------------
  if ( fix_angle_beta ) then
     vectmp(:) = normalized_lat_vec(:,1) + normalized_lat_vec(:,3)

     Do i=1, 3, 2
        c1 = dot_product( vectmp(:), normalized_lat_vec(:,i) )
        vectmp2(:) = vectmp(:) - c1*normalized_lat_vec(:,i)

        c2 = sqrt( vectmp2(1)**2 + vectmp2(2)**2 + vectmp2(3)**2 )
        vectmp2 = vectmp2 /c2

        c3 = dot_product( s_out(i,:), vectmp2(:) )
        s_out(i,:) = s_out(i,:) - c3 *vectmp2(:)
     End do
  endif

! -----------------------------------
  if ( fix_angle_gamma ) then
     vectmp(:) = normalized_lat_vec(:,1) + normalized_lat_vec(:,2)

     Do i=1, 2
        c1 = dot_product( vectmp(:), normalized_lat_vec(:,i) )
        vectmp2(:) = vectmp(:) - c1*normalized_lat_vec(:,i)

        c2 = sqrt( vectmp2(1)**2 + vectmp2(2)**2 + vectmp2(3)**2 )
        vectmp2 = vectmp2 /c2

        c3 = dot_product( s_out(i,:), vectmp2(:) )
        s_out(i,:) = s_out(i,:) - c3 *vectmp2(:)
     End do

  endif

end function constrain_on_stress_type1

function constrain_on_stress_type2(altv_in,s_in) result(s_out)
  real(kind=DP), intent(in) :: s_in(3,3), altv_in(3,3)
  real(kind=DP) :: s_out(3,3)

  integer :: i
  real(kind=DP) :: c1, c2, c3
  real(kind=DP) :: normalized_lat_vec(3,3), vectmp(3), vectmp2(3)
!
  s_out = s_in
!
  Do i=1, 3
     c1 = sqrt( altv_in(1,i)**2 +altv_in(2,i)**2 + altv_in(3,i)**2 )
     normalized_lat_vec(:,i) = altv_in(:,i) / c1
  End do

! -----------------------------------
  if ( fix_length_a ) then
     c1 = dot_product( s_out(1,:), normalized_lat_vec(:,1) )
     s_out(1,:) = s_out(1,:) -c1 *normalized_lat_vec(:,1)
  endif
  if ( fix_length_b ) then
     c1 = dot_product( s_out(2,:), normalized_lat_vec(:,2) )
     s_out(2,:) = s_out(2,:) -c1 *normalized_lat_vec(:,2)
  endif
  if ( fix_length_c ) then
     c1 = dot_product( s_out(3,:), normalized_lat_vec(:,3) )
     s_out(3,:) = s_out(3,:) -c1 *normalized_lat_vec(:,3)
  endif
end function constrain_on_stress_type2
! ====== 13.1AS

end module m_Stress
