!=======================================================================
!
!  PROGRAM  PHASE/0 2019.01 ($Rev: 590 $)
!
!  MODULE: m_Ionic_System
!
!  AUTHOR(S): T. Yamasaki  K, Betsuyaku, T. Uchiyama, Y. Morikawa,  August/20/2003
!  
!  FURTHER MODIFICATION: T. Yamasaki, T. Yamamoto,  January/13/2004, April/10/2007
!
!  Contact address :  Phase System Consortium
!                     E-mail: phase_system@nims.go.jp URL https://azuma.nims.go.jp
!  
!
!
! =========================================
!   patch 0.1 by K. Tagami@adv    2009/10/19
!
!   patch 0.1:  correction for phonon with DFT+U
!=======================================================================
!
!     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
!
! Functions:  [Identifier: 13.3B]
!                 amion is automatically set when it is not set by the user
!
! =============================================================

module m_Ionic_System
!     (m_IS)
!  $Id: m_Ionic_System.F90 590 2018-11-06 04:20:58Z jkoga $
!
!  This module is for structure factor, ewald energy,
!  and motions of atoms.
!  Original files are "md","md_ext","md_nebm1","md_nebm2",
!  "md_qn_gdiis", and "mdexpl", which were coded using VPP-fortran.
!  Subroutines contained in the files "md" and "md_ext" had been 
!  translated into this module coded using f90+mpi by T. Yamasaki
!  and T. Uchiyama in 1999. Other files will be translated and be
!  contained in this module.
!
! ------------------------------
! "md" --
!!$c     #1) imdtyp=10: structure optimization with a constraint
!!$c         on a bond length between two atoms.
!!$c         Y.Morikawa 24th July 1995.
!!$c     #2) imdtyp=8:  In a case that a force direction is parallel to
!!$c              a constraint vector (fcvect), the atom is not
!!$c              constraint the movement.
!!$c         T. Yamasaki 12th Jan. 1996.
!!$c     #3) imdtyp=101: quenched motion of atoms, of which 
!!$c                      center-of-mass is constrained.
!!$c         T. Uchiyama, November 9, 1997.
! ------------------------------
! "md_ext"
!!$c This file contains three md subroutines coded by T. Uchiyama
!!$c (JRCAT-ATP) in 1997-1999.
!!$c   1. md_thermo
!!$c   2. md_bluem
!!$c   3. md_cnstr
!!$c******************************************************************
!!$      subroutine md_thermo
!!$c For imdalg= -1 ; Constant temperature molecular dynamics.
!!$c   imdtyp=    0 ; fixed,         imdtyp=    1 ; free, 
!!$c   imdtyp= 1001 ; thermostat#1,  imdtyp= 1002 ; thermostat#2,
!!$c    ....
!!$c   imdtyp= 1000+nrsv, where nrsv= No. of thermostats.
!!$c
!!$c  Ref). S. Nose, Mol. Phys. 52 (1984) 255, 
!!$c                 J. Chem. Phys. 81 (1984) 511.
!!$c
!!$c     Released.    Dec. 12, 1997,   by T. Uchiyama
!!$c     Bug fixed.   Aug.  6, 1998,   by T. Uchiyama
!!$c******************************************************************
!!$      subroutine md_bluem
!!$c   nrsv=      1 ; No. of thermostat
!!$c   imdtyp=    0 ; fixed
!!$c   imdtyp= 1001 ; thermostat
!!$c
!!$c     Released.      Sep. 21, 1998.   by T. Uchiyama
!!$c     Bug fixed.     Nov.  3, 1998.   by T. Uchiyama
!!$c******************************************************************
!!$      subroutine md_cnstr
!!$c   imdtyp= 0 ; fixed
!!$c   imdtyp= 1 ; quenched
!!$c
!!$c     Released.      Sep. 21, 1998,   by T. Uchiyama
!!$c     Bug fixed.     Nov.  4, 1998,   by T. Uchiyama
!!$c******************************************************************
! "md_nebm1"
!!$C Nudged Elastic Band method after Hannes Jonsson.
!!$c                           29th Feb. 1996 Y.M
!!$c                           @(#)md_nebm1.f 9.2 97/12/08 11:42:46
!!$c  1) open command is commented out by T. Yamasaki. 22nd May. 1996
! "md_nebm2"
!!$C (1) Nudged Elastic Band method after Hannes Jonsson.
!!$c                           29th Feb. 1996 Y.M
!!$c                   revised 14th Oct. 1996 Y.M
!!$c (2)               Aug. 1996 T. Yamasaki
!!$c    cpd --> cpd_l, forc --> forc_l
!!$c
!!$c (3)               revised 14th Oct. 1996 Y.M
!!$*                           @(#)md_nebm2.f 9.2 97/11/21 17:32:00

  use m_Crystal_Structure,  only : nopr, tau, op, altv, rltv, univol, nbztyp &
       &                         , inversion_symmetry, p2bmat & ! inverse transformation matrix
       &                         , b2pmat &
       &                         , sw_supercell, n1_sc, n2_sc, n3_sc &
       &                         , nlpnt, lpnt, altv_prim, m_CS_set_inv_sym_off &
       &                         , symmetry_check_criterion, ngen_tl,tau_tl,op_tl &
       &                         , m_CS_altv_2_rltv, sw_supercell_symmetry
  use m_Files,              only : nfout, nfmode, m_Files_open_nfmode &
                                 , nfimage, m_Files_open_nfimage, nfdynm_cif
  use m_Timing,             only : tstatc0_begin, tstatc0_end
  use m_Control_Parameters, only : ipri,ipriinputfile, iprimd, dtio,icond, ipriforce &
       &                         , forccr, istress, kimg, af, iprigdiis,ipristrcfctr &
       &                         , kqnmditer_p, gdiis_hownew, c_forc2GDIIS &
       &                         , c_forc_prop_region_high, c_forc_prop_region_low &
       &                         , factor_prop_region, imdalg &
       &                         , sw_calc_force, sw_displace_atom &
       &                         , sw_calc_force_all, sw_phonon_oneshot &
       &                         , sw_vibrational_mode, with_mode_effchg &
       &                         , sw_polynomial_fit, num_phonon_calc_mode, norder &
! === Apply modifications for vdW function. by tkato 2012/06/14 ================
!      &                         , sw_screening_correction, sw_pair_vdw &
       &                         , sw_screening_correction, sw_vdw_correction &
! ==============================================================================
       &                         , etol,printable, m_CtrlP_what_is_mdalg &
       &                         , mode_fi_coefficient, fi_coefficient &
       &                         , multiple_replica_mode &
       &                         , sw_correct_eigenvalue, eigenvalue_threshold &
       &                         , sw_extrapolate_charge,rms_threshold, sw_wf_predictor &
       &                         , sw_optimize_alpha, vdw_method, xctype, iprivdw &
#ifndef _EMPIRICAL_
       &                         , ipriphonon &
       &                         , m_CtrlP_check_matm
#else
       &                         , ipriphonon
#endif
#ifndef _EMPIRICAL_
  use m_Control_Parameters, only : sw_aldos, sw_pdos, sw_orb_popu, sw_hubbard &
       &                         , proj_attribute, proj_group &
       &                         , num_projectors &
       &                         , num_proj_group, num_proj_elems &
       &                         , m_CtrlP_set_proj_ityp &
#ifdef ENABLE_ESM_PACK
       &                         , driver,sw_optimize_lattice,ipripredictor,sw_esm
#else
       &                         , driver,sw_optimize_lattice,ipripredictor
#endif
#endif
  use m_IterationNumbers,   only : iteration_ionic
  use m_Const_Parameters,   only : DP, FIX, RELAX, VERLET, QUENCHED_MD,CG_STROPT,SD_MD &
       &                         , FIX_IN_A_PLANE, FIXED_NORMAL_HYPERVECTOR &
       &                         , NUDGED_ELASTIC_BAND_METHOD &
       &                         , COG_FIX, COG_CNTR, BONDLENGTH_FIX, BONDLENGTH_FIX_1 &
       &                         , BONDLENGTH_FIX_2, COG_FIX_L, PAI2, PAI &
       &                         , ORDINA, CNSTRA, FIX_HBATH, RELAX_HBATH &
       &                         , HEXAGONAL,ORTHORHOMBIC,HEX1FOLD, GDIIS, BFGS, CARTS &
       &                         , INITIAL, DELTA, DELTA10 &
       &                         , BLUEMOON, QUENCHED_CONSTRAINT,T_CONTROL &
       &                         , ANEW, RENEW, HEAT_BATH, PUCV, FMAXVALLEN, FMAXUNITLEN &
       &                         , NOCONV, LOWER, UPPER, NOSE, NOSE_HOOVER &
       &                         , SmallestPositiveNumber, ON, OFF, YES, NO &
       &                         , unit_conv_byname, DIRECTIN, FROM_ENDPOINTS, FILE &
       &                         , STEEPEST_DESCENT, PROPORTIONAL, CONST_kB, VELOCITY_SCALING &
       &                         , CONTINUATION, DRIVER_MTD, COORDINATE_CONTINUATION, AUTOMATIC &
       &                         , CG_STROPT2,BOHR, PT_CONTROL, P_CONTROL &
       &                         , GaussLegendre, SphericalHarmonicsExpansion &
       &                         , CYLINDER, BOX &
       &                         , VDW_DFTD3

  use m_Parallelization,    only : mpi_comm_group,ista_kngp, iend_kngp, npes,mype,ierr, ista_atm, iend_atm, ista_atm2, iend_atm2 &
       &                         , mype_conf, nrank_conf, conf_para

! =============================== added by K. Tagami =================== 11.0
  use m_Control_Parameters,     only : noncol, SpinOrbit_mode, sw_calc_core_energy
  use m_Const_Parameters,       only : ByProjector, ByPawPot, ZeffApprox, ReadFromPP
! ====================================================================== 11.0

! === KT_add ==== 2014/07/14
  use m_Files,  only : nfhypervec, m_Files_open_nfhypervec, m_Files_close_nfhypervec
! =============== 2014/07/14
! === KT_add === 13.2S
  use m_Crystal_Structure,  only : sw_spinorbit_force_theorem, &
       &                           sw_fix_global_quantz_axis, &
       &                           Global_Quantz_Axis_Fixed, additional_charge
! ============== 13.2S

  use m_Files, only : m_Files_open_dftd3par,m_Files_close_dftd3par,nfdftd3par
  implicit none
  include 'mpif.h'

#ifdef PGI
  external ibath
  integer :: ibath
#endif

  integer :: input_coordinate_system = PUCV       ! ncord

  integer ::                                      ntyp = 1
  integer ::                                      natm = 1, natm2 = 1
  integer ::                                      natm_prim = 1
  integer ::                                      natm2_prim = 1
  integer ::                                      natm_super = 1
  integer ::                                      natm2_super = 1
  integer ::                                      natmorg = 1

  character(len("Ionic System")),private,parameter :: tag_ionic_system = "Ionic System"
  character(len("Ionic System Attributes")),private,parameter ::  &
      & tag_ionic_system_attributes = "Ionic System Attributes"
  character(len("-- forcp --")),private,parameter  :: tag_forcp        = "-- forcp --"

  real(kind=DP), allocatable,dimension(:,:)   ::  pos, cps  ! d(natm,3)
  real(kind=DP), allocatable,dimension(:,:)   ::  pos_in, cps_in
  ! pos : atomic coordinates in a unit cell vector system
  ! cps : atomic coordinates in the cartesian system
  real(kind=DP), allocatable,dimension(:,:)   ::  pos_end0, pos_end1, cps_end0, cps_end1 ! d(natm,3)
  real(kind=DP), allocatable,dimension(:,:,:) ::  pos_image, cps_image ! d(:,natm,3)
  real(kind=DP), allocatable,dimension(:,:,:) ::  normal_hypervector ! d(natm,3,PUCV:CARTS)
  real(kind=DP), allocatable,dimension(:,:)   ::  pos_prim, cps_prim  ! d(natm_prim,3)
  real(kind=DP), allocatable,dimension(:,:)   ::  pos_super, cps_super  ! d(natm_super,3)
  real(kind=DP), allocatable,dimension(:)     ::  ionic_mass ! d(natm)
  real(kind=DP), allocatable,dimension(:,:)   ::  cpd_l     ! d(natm,3)
  real(kind=DP), allocatable,dimension(:,:,:) ::  cpo_l     ! d(natm,3,3)
  real(kind=DP), allocatable,dimension(:,:,:) ::  cps_history
  integer,private :: ncps_history=0
  integer,private,parameter ::                    LEN_ATOMNAME = 4
  character(len=LEN_ATOMNAME),allocatable, dimension(:) ::  speciesname ! d(ntyp)
  character(len=LEN_ATOMNAME),private,allocatable,dimension(:) :: species_work ! d(natm)
  character(len=LEN_ATOMNAME),private,allocatable,dimension(:) :: species_indp ! d(natm)

  real(kind=DP), allocatable, dimension(:) ::     iatomn, iatom      ! d(ntyp)
  integer, allocatable, dimension(:) ::           ivan               ! d(ntyp)
  real(kind=DP),allocatable,dimension(:) ::       alfa, amion, zeta1, qex ! d(ntyp)
  integer, allocatable, dimension(:) ::           iwei, imdtyp, ityp ! d(natm)
  integer, allocatable, dimension(:,:) ::         imdtypxyz
#ifndef _EMPIRICAL_
  integer, allocatable, dimension(:) ::           if_pdos, if_aldos ! d(natm)
#endif
  integer, allocatable, dimension(:) ::           numlay             ! d(natm)

  integer ::                                      nfcatm = 0

  real(kind=DP) ::                                ekina
  integer ::                                      mdmode = ORDINA

  integer,       allocatable, dimension(:,:)   :: napt   !d(natm,nopr+af)
  integer,       allocatable, dimension(:,:)   :: napt_tl!d(natm,ngen_tl)
  integer,       allocatable, dimension(:,:)   :: napt_prim !d(natm_prim,nopr+af)

  integer                                      :: nopr_supercell
  integer,       allocatable, dimension(:,:)   :: napt_supercell !d(natm,nopr_supercell_red)
  integer,       allocatable, dimension(:)     :: iop_supercell  !d(nopr_supercell)
!!$  real(kind=dP), allocatable, dimension(:,:)   :: tau_supercell  !d(3,nopr_supercell)
!!$  integer                                      :: mnope_supercell !=maxval(nope_supercell(:))
!!$  integer,       allocatable, dimension(:)     :: nope_supercell !d(nopr)
!!$  integer,       allocatable, dimension(:,:)   :: pope_supercell !d(mnope_supercell,nopr)

  real(kind=DP), allocatable, dimension(:,:,:) :: zfm3_l !d(ista_kngp:iend_kngp,ntyp,kimg)
  real(kind=DP)                                :: eewald
  real(kind=DP), allocatable, dimension(:,:)   :: fxyzew_l ! d(natm,3)
  real(kind=DP),private,pointer,dimension(:,:) :: cpd_old  ! d(natm,3)
  integer,      private,allocatable,dimension(:)   :: ipcpd    ! d(natm2)
  real(kind=DP), dimension(3,3)                :: s_ew
  integer                                      :: displaced_atom = 0
  real(kind=DP), dimension(3)                  :: displacement(3)

  character(len=9), public       :: lattice_system_from_m_CS_SG = 'none'

! -- Temperature Control
  integer         ::                                  t_ctrl_method = NOSE_HOOVER

  integer         ::                                  nrsv = 1  ! number of heat bath
  integer         ::                                  set_initial_velocity = ON  ! (by J. Koga)
  integer         ::                                  sw_read_velocities = OFF  ! (by T. Yamamoto)
  integer         ::                                  sw_shift_velocities = OFF
  integer         ::                                  nchain = 1
  real(kind=DP),private ::                            tk_initial = 0.d0
!!$  real(kind=DP),private,allocatable,dimension(:)   :: qmass,tkb,cprv,frsv ! d(nrsv)
  real(kind=DP),allocatable,dimension(:)   :: qmass,tkb,cprv,frsv ! d(nrsv)
  integer, allocatable,dimension(:)        :: natm_per_thermo
  real(kind=DP),private,allocatable,dimension(:,:) :: cpqr                ! d(nrsv,2)
  real(kind=DP),private,allocatable,dimension(:,:) :: forcp               ! d(natm,3)
  real(kind=DP),private,allocatable,dimension(:,:) :: qmass_c,cprv_c,cpqr_c
  real(kind=DP),private                            :: qfactor

  real(kind=DP),private                            :: ekinq,ekbt
  real(kind=DP)                                    :: ega,almda
  real(kind=DP)                                    :: forcmx_constraint_quench = 1.d+2
! -->   T. Yamasaki 18 July 2008
  real(kind=DP),private                            :: forc_norm_hyperplane_vert = 1.d+2
  real(kind=DP)                                    :: forcmx_hyperplane_vert = 1.d+2
! <--
  real(kind=DP),private,allocatable,dimension(:,:) :: gca                 ! d(natm,3)
  integer,      private,allocatable,dimension(:)   :: ia_cnst             ! d(nfcatm)
  real(kind=DP),private,allocatable,dimension(:,:) :: fcvect              ! d(nfcatm,4)
!!$  real(kind=DP),private,allocatable,dimension(:,:) :: fcvect_tmp          ! d(num_planes_atoms_are_fixed,4)
  integer,      private,allocatable,dimension(:)   :: ipfixedplane        ! d(nfcatm)
  real(kind=DP),private,dimension(4)               :: sgmc
  character(len("forcmx_constraint_quench")),private,parameter :: &
       &                              tag_forcmx_const = "forcmx_constraint_quench"
  character(len("structure_evolution")),private,parameter :: &
       &                              tag_structure_evolution = "structure_evolution"
  character(len("temperature_control")),private,parameter :: &
       &                              tag_temperature_control = "temperature_control"
  character(len("method")),private,parameter ::       tag_method          = "method"
  character(len("num_thermostat")),private,parameter :: tag_num_thermostat = "num_thermostat"
  character(len("num_thermo")),private,parameter :: tag_num_thermo  = "num_thermo"
  character(len("num_chain")),private,parameter :: tag_num_chain  = "num_chain"
  character(len("thermostat")),private,parameter :: tag_thermostat  = "thermostat"
  character(*),private,parameter ::                 tag_weight_thermo = "weight_thermo"
  character(*),private,parameter ::                 tag_weight_thermostat = "weight_thermostat"
  character(len("weight")),private,parameter ::     tag_weight = "weight"
  character(len("qmass")),private,parameter ::      tag_qmass  = "qmass"
  character(len("temperature")),private,parameter :: tag_temperature = "temperature"
  character(len("temp")),private,parameter ::       tag_temp   = "temp"
  character(len("T")),private,parameter ::          tag_T      = "T"
  character(len("NOSE_HOOVER")),private,parameter :: tag_Nose_Hoover = "nose_hoover"
  character(len("HOOVER")),private,parameter ::     tag_Hoover = "hoover"
  character(len("Nose")),private,parameter ::       tag_Nose   = "nose"
  character(len("velocity_scaling")),private,parameter :: tag_velocity_scaling = "velocity_scaling"
  character(len("tdamp")),private,parameter :: tag_tdamp = "tdamp"

  character(len("lattice_vector")),private,parameter :: tag_lattice_vector = "lattice_vector"

! === KT_add === 2014/06/10
  character(len("duration")),private,parameter ::      tag_duration  = "duration"
  character(len("temp_s")),private,parameter ::        tag_temp_s  = "temp_s"
  character(len("temp_e")),private,parameter ::        tag_temp_e  = "temp_e"
  character(len("sw_change_temperature_by_step")), private,parameter :: &
       &        tag_sw_change_temp_bystep  = "sw_change_temperature_by_step"

  integer, allocatable :: mdstep_at_start_thermostat(:)
  integer, allocatable :: mdstep_at_end_thermostat(:)
  real(kind=DP), allocatable :: temp_at_start_thermostat(:)
  real(kind=DP), allocatable :: temp_at_end_thermostat(:)

  integer :: sw_change_temperature_by_step = OFF
  integer :: ithermo_now = 1
! ============== 2014/06/10

  logical ::            tag_T_cntrl_is_found
  character(len("Temperature Control")),private,parameter :: tag_T_cntrl = "Temperature Control"
  character(len("temperature_control")),private,parameter :: tag_T_cntrl2 = "temperature_control"
  character(len("nrsv")),private,parameter ::                tag_nrsv = "nrsv"
  character(len("heat bath")),private,parameter ::           tag_heat_bath = "heat bath"
  character(len("atom")),private,parameter ::                tag_atom_velocity = "atom"
  character(len("set_initial_velocity")),private,parameter :: tag_set_initial_velocity = "set_initial_velocity" ! (by J. Koga)
  character(len("sw_read_velocities")),private,parameter :: tag_sw_read_velocities = "sw_read_velocities"
  character(len("initial_temperature")),private,parameter :: tag_initial_temperature = "initial_temperature"
  character(len("sw_shift_velocities")),private,parameter :: tag_sw_shift_velocities = "sw_shift_velocities"

  !     constraint             sigma                       sgmc
  ! 1. BONDLENGTH_FIX_1 
  !       (sigma)        $|\vec{r_1} - \vec{r_2}| - b $
  !       (sgmc)              sgmc(1) = b
  ! 2. BONDLENGTH_FIX_2
  !       (sigma)        $|\vec{r_1} - \vec{r_2}|^2 - b $
  !       (sgmc)              sgmc(1) = b
  ! 3. COG_FIX_L
  !       (sigma)        $(\vec{r_c} - \vec{r_o})\cdot\vec{a} - b$
  !                where,
  !                  $\vec{r_c} = (m_1\vec{r_1}+m_2\vec{r_2})/m_g$
  !                  $\vec{r_o} = \sum_{All except fixed}m_i \vec{r_i}/m_r
  !                            m_g = (m_t m_r)/(m_t + m_r)
  !                            m_r = \sum_{All except fixed} m_i
  !                            m_t = m_1 + m_2
  !       (sgmc)            sgmc(1:3) = \vec{a}
  !                           sgmc(4) = b

  integer                                  :: cnst_typ

! -- Work_arrays for GDIIS
!!$  integer, private, parameter :: kqnmditer_p  = 4
  real(kind=DP),private,allocatable,dimension(:,:,:):: u_l ! d(natm,3,kqnmditer_p)
  real(kind=DP),private,allocatable,dimension(:,:,:):: w_l ! d(natm,3,kqnmditer_p)

!! for continuation
  real(kind=DP),private,allocatable,dimension(:,:,:):: u_l_buf ! d(natm,3,kqnmditer_p)
  real(kind=DP),private,allocatable,dimension(:,:,:):: w_l_buf ! d(natm,3,kqnmditer_p)
  integer, private, allocatable, dimension(:) ::       ncrspd_buf ! d(kqnmditer_p)
  logical, private :: diis_continuable = .false.

  real(kind=DP),private,allocatable,dimension(:,:) ::  fc_l ! d(natm,3)
  integer, private, allocatable, dimension(:) ::       ncrspd ! d(kqnmditer_p)
  real(kind=DP),private,allocatable,dimension(:,:) ::  f_gdiis ! d(kqnmditer_p,kqnmditer_p)
  real(kind=DP),private,allocatable,dimension(:,:) ::  f_wk ! d(kqnmditer_p**2,2)
  real(kind=DP),private,allocatable,dimension(:)   ::  f_rslv ! d(kqnmditer_p**2)
  real(kind=DP),private,allocatable,dimension(:) ::    g,e_wk,ww1,etot_trial
  real(kind=DP),private,allocatable,dimension(:,:) ::  forc_g ! d(natm,3)
  integer, private, allocatable, dimension(:) ::       ip ! d(kqnmditer_p)
  integer, private, parameter ::                       UNIT = 1
!!$  real(kind=DP),private,parameter ::              c_forc_prop_region_high = 0.1d0
!!$  real(kind=DP),private,parameter ::            c_forc_prop_region_low = 0.0001d0
!!$  real(kind=DP),private,parameter ::                   factor_prop_region = 0.02d0
!!$  real(kind=DP),private,parameter ::            c_forc_QUENCH2GDIIS = 0.0008d0
  integer,private,parameter ::                         ic_E_overshoot = 3
  real(kind=DP),private,save ::                        etot_previous = 1.d+3
  integer,private,save ::                              iincre_at_forc_cal = 0
  integer,private,save ::                              iter_gdiis = 0
  integer,private,save ::                              if_allocated=0
  real(kind=DP) :: min_alpha = 1.d0,max_alpha = 2.0d0
  real(kind=DP) :: wolfe_c1=1.d-4,wolfe_c2=0.9
! -- Work arrays
  real(kind=DP),private,pointer, dimension(:)     :: ekr                 ! d(nrsv)
  integer,      private,pointer, dimension(:)     :: nathm               ! d(nrsv)

  integer,      parameter   :: len_str = 132
  character(len=len_str)       :: str

  ! ---> input tag terms
  integer, private,save ::                          howtogive_coordinates = DIRECTIN ! {DIRECTIN|FROM_ENDPOINTS}
  integer, private,save ::                          endpoint_images  = NO            ! {NO|FILE|DIRECTIN}
  ! --- Structure ---
#ifndef _GNU_FORTRAN_
  character(len("structure")),private ::            tag_structure = "structure"
#else
  character(9),private ::            tag_structure = "structure"
#endif
  character(len("atom_list")),private,parameter ::  tag_atomlist = "atom_list"
  character(len("howtogive_coordinates")),private,parameter :: tag_howtogive_coordinates = "howtogive_coordinates"
  character(len("from_endpoint_images")),private,parameter :: tag_from_endpoint_images = "from_endpoint_images"
  character(len("from_endpoints")),private,parameter :: tag_from_endpoints = "from_endpoints"
  character(len("atom_list_end0")),private,parameter :: tag_atom_list_end0 = "atom_list_end0"
  character(len("atom_list_end1")),private,parameter :: tag_atom_list_end1 = "atom_list_end1"
  character(len("endpoint_images")),private,parameter :: tag_endpoint_images = "endpoint_images"
  character(len("directin")),private,parameter ::   tag_directin = "directin"
  character(len("file")),private,parameter ::       tag_file     = "file"
  character(len("nothing")),private,parameter ::    tag_nothing  = "nothing"

  character(len("atom_duplication")),private,parameter ::tag_atomduplication = "atom_duplication"
  character(len("symmetry")),private,parameter ::   tag_ad_symmetry = "symmetry"
  character(len("num_atoms")),private,parameter ::  tag_numatoms     = "num_atoms"
  character(len("coordinate_system")),private,parameter :: tag_coordinate_system = "coordinate_system"
  character(len("cartesian")),private,parameter ::  tag_cartesian = "cartesian"
  character(len("id")),private,parameter ::         tag_id        = "id"
  character(len("no")),private,parameter ::         tag_no        = "no"
  character(len("element")),private,parameter ::    tag_element   = "element"
  character(len("XYZ")),private,parameter ::        tag_XYZ       = "xyz"
  character(len("pucv")),private,parameter ::       tag_pucv      = "pucv"
  character(len("internal")),private,parameter ::   tag_internal  = "internal"
  character(len("relative")),private,parameter ::   tag_relative  = "relative"
  character(len("atoms")),private,parameter ::      tag_atoms     = "atoms"
  character(len("rx")),private,parameter ::         tag_rx        = "rx"
  character(len("ry")),private,parameter ::         tag_ry        = "ry"
  character(len("rz")),private,parameter ::         tag_rz        = "rz"
  character(len("vx")),private,parameter ::         tag_vx        = "vx"
  character(len("vy")),private,parameter ::         tag_vy        = "vy"
  character(len("vz")),private,parameter ::         tag_vz        = "vz"
  character(len("fx")),private,parameter ::         tag_fx        = "fx"
  character(len("fy")),private,parameter ::         tag_fy        = "fy"
  character(len("fz")),private,parameter ::         tag_fz        = "fz"
  character(len("mobile")),private,parameter ::     tag_mobile    = "mobile"
  character(len("mobilex")),private,parameter ::     tag_mobilex    = "mobilex"
  character(len("mobiley")),private,parameter ::     tag_mobiley    = "mobiley"
  character(len("mobilez")),private,parameter ::     tag_mobilez    = "mobilez"
  character(len("weight")),private,parameter ::     tag_a_weight  = "weight"
  character(len("pdos")),private,parameter ::       tag_pdos      = "pdos"
  character(len("aldos")),private,parameter ::      tag_aldos     = "aldos"
  character(len("thermo_group")),private,parameter :: tag_thermo_group = "thermo_group"
  character(len("thermo_g")),private,parameter ::   tag_thermo_g = "thermo_g"
  character(len("num_layer")),private,parameter ::  tag_num_layer = "num_layer"
  character(len("displacement")),private,parameter :: tag_displacement = "displacement"
  character(len("sw_displace_atom")),private,parameter :: tag_sw_displace_atom = "sw_displace_atom"
  character(len("displaced_atom")),private,parameter :: tag_displaced_atom = "displaced_atom"
! === KT_add === 2015/03/14
  character(len("sw_displacement_in_carts")), private,parameter :: &
       &              tag_sw_displacement_in_carts = "sw_displacement_in_carts"
  integer :: sw_displacement_in_carts = off
! ============== 2015/03/14
  character(len("ux")),private,parameter :: tag_ux = "ux"
  character(len("uy")),private,parameter :: tag_uy = "uy"
  character(len("uz")),private,parameter :: tag_uz = "uz"
  character(len("vibrational_mode")),private,parameter :: tag_vibrational_mode = "vibrational_mode"
  character(len("sw_vibrational_mode")),private,parameter :: tag_sw_vibrational_mode = "sw_vibrational_mode"
  character(len("mode_index")),private,parameter :: tag_mode_index = "mode_index"
  character(len("normal_coordinate")),private,parameter :: tag_normal_coordinate = "normal_coordinate"
  character(len("with_mode_effchg")),private,parameter :: tag_with_mode_effchg = "with_mode_effchg"

  logical,public ::                                 constraints_exist = .false.
  logical,public ::                                 move_constrained_plane = .false.
  integer,private ::                                constraint_type   = 0
  integer,private ::                                num_planes_atoms_are_fixed = 0
  integer,private ::                                num_fixed_bonds  = 0
  integer,private,allocatable,dimension(:,:)  ::    bondlength_fix_set  ! (1:2,num_bonds)
  real(kind=DP),private :: fcg(3), fcg_mdfy(3)
  real(kind=DP),private ::  tmass, rtmass = 0.d0 ! rtmass = 1/tmass

  character(len("constraint")),private,parameter :: tag_constraint = "constraint"
  character(len("num_fixed_bonds")),private,parameter:: tag_num_fixed_bonds = "num_fixed_bonds"
  character(len("fixed_bond")),private,parameter :: tag_fixed_bond = "fixed_bond"
  character(len("fix_bondlength")),private,parameter :: tag_fix_bondlength = "fix_bondlength"
  character(len("fixed_normal_hypervector")),private,parameter :: &
       &                                            tag_fixed_normal_hypervector = "fixed_normal_hypervector"

! === KT_add === 2014/07/14
  character(len("hypervec_from_file")),private,parameter :: &
       &                      tag_hypervec_from_file = "hypervec_from_file"
  integer :: hypervec_from_file = OFF
! ============== 2014/07/14

!!! nudged_elastic_band_method
  character(len("accuracy")),private,parameter :: tag_accuracy = "accuracy"
  !!!character(len("constraint")),private,parameter :: tag_constraint = "constraint"
  !!!character(len("structure")),private,parameter :: tag_structure = "structure"

  integer :: neb_max_iteration = 10
  character(len("neb_max_iteration")),private,parameter :: tag_neb_max_iteration = "neb_max_iteration"
  real(kind=DP) :: neb_dt = 20.0d0
  character(len("dt")),private,parameter :: tag_neb_dt = "dt"
  integer :: ci_neb = OFF
  character(len("neb_time_integral")),private,parameter :: tag_neb_time_integral = "neb_time_integral"
  integer :: neb_time_integral = 12
  character(len("ci_neb")),private,parameter :: tag_ci_neb = "ci_neb"
  real(kind=DP) :: sp_k_init = 1.0d0, sp_k_min = 1.0d0, sp_k_max = 1.0d0
  character(len("sp_k_init")),private,parameter :: tag_sp_k_init = "sp_k_init"
  character(len("sp_k_min")),private,parameter :: tag_sp_k_min = "sp_k_min"
  character(len("sp_k_max")),private,parameter :: tag_sp_k_max = "sp_k_max"
  integer :: sp_k_variable = OFF
  character(len("sp_k_variable")),private,parameter :: tag_sp_k_variable = "sp_k_variable"
  integer :: penalty_function = OFF
  character(len("penalty_function")),private,parameter :: tag_penalty_function = "penalty_function"
  integer :: neb_convergence_condition = 1
  character(len("neb_convergence_condition")),private,parameter :: tag_neb_convergence_condition = "neb_convergence_condition"
  real(kind=DP) :: neb_convergence_threshold
  character(len("neb_convergence_threshold")),private,parameter :: tag_neb_convergence_threshold = "neb_convergence_threshold"
  character(len("coefficient")),private,parameter :: tag_coefficient = "coefficient"
  character(len("mode_coefficient")),private,parameter :: tag_mode_coefficient = "mode_coefficient"
  character(len("bondlength_fix")),private,parameter :: tag_bondlength_fix = "bondlength_fix"
  character(len("cog_fix")),private,parameter ::    tag_cog_fix    = "cog_fix"
  character(len("cog_fix_l")),private,parameter ::  tag_cog_fix_l  = "cog_fix_l"
  character(len("cog_fix_in_a_plane")),private,parameter :: tag_cog_fix_in_a_plane = "cog_fix_in_a_plane"
  character(len("type")),private,parameter ::       tag_type       = "type"
  character(len("absolute")),private,parameter ::   tag_absolute   = "absolute"
  character(len("square")),private,parameter ::     tag_square     = "square"
  character(len("atom1")),private,parameter ::       tag_atom1      = "atom1"
  character(len("atom2")),private,parameter ::       tag_atom2      = "atom2"
  character(len("atom3")),private,parameter ::       tag_atom3      = "atom3"
  character(len("atom4")),private,parameter ::       tag_atom4      = "atom4"
  character(len("length")),private,parameter ::     tag_length     = "length"
  character(len("num_planes")),private,parameter :: tag_num_planes = "num_planes"
  character(len("fix_in_a_plane")),private,parameter :: tag_fix_in_a_plane = "fix_in_a_plane"
  character(len("fixed_plane")),private,parameter :: tag_fixed_plane = "fixed_plane"
  character(len("nx")),private,parameter ::         tag_nx         = "nx"
  character(len("ny")),private,parameter ::         tag_ny         = "ny"
  character(len("nz")),private,parameter ::         tag_nz         = "nz"
  character(len("delta")),private,parameter ::      tag_delta      = "delta"
  
  character(len("element_list")),private,parameter :: tag_element_list = "element_list"
  character(len("atomicnumber")),private,parameter :: tag_atomicnumber = "atomicnumber"
  character(len("mass")),private,parameter ::       tag_mass      = "mass"
  character(len("zeta")),private,parameter ::       tag_zeta      = "zeta"
!!$  character(len("variance")),private,parameter ::   tag_variance  = "variance"
  character(len("deviation")),private,parameter ::  tag_deviation = "deviation"
  character(len("standard_deviation")),private,parameter :: tag_standard_deviation = "standard_deviation"
  character(len("dev")),private,parameter ::        tag_dev       = "dev"
  character(len("qex")),private,parameter ::        tag_qex       = "qex"

  ! --- PHONON FORCE ---
  integer :: num_force_data
  integer :: num_force_calc
  integer :: istart_phonon = -1
  integer :: iend_phonon   = -1
  integer, allocatable, dimension(:) :: phonon_atom ! dim(num_force_data)
  real(kind=DP), allocatable, dimension(:,:) :: phonon_displacement ! dim(num_force_data,3)
  real(kind=DP) :: u = 0.d0
  integer,       allocatable, dimension(:,:) :: napt_phonon !d(natm_super,num_force_data)
  integer,       allocatable, dimension(:)   :: iequconf !d(num_force_data)
  integer,       allocatable, dimension(:)   :: iopr_equconf !d(num_force_data)
  integer,       allocatable, dimension(:)   :: iconf !d(num_force_calc)

  ! --- Vibrational mode ---
  integer            :: mode_index = 1
  real(kind=DP)      :: normal_coordinate = 0.d0
  real(kind=DP), allocatable, dimension(:,:) :: xi_mode ! dim(natm,3)

  ! --- NEB or Multiple replica ---
  integer :: number_of_replicas = 1
  integer, allocatable, dimension(:) :: replica_howtogive_coordinates ! d(number_of_replica)
  integer, allocatable, dimension(:,:) :: replica_endpoints           ! d(2,number_of_replica)
  character(len("multiple_replica")),private,parameter :: tag_multiple_replica = "multiple_replica"
  character(len("number_of_replicas")),private,parameter :: tag_number_of_replicas = "number_of_replicas"
  character(len("replicas")),private,parameter :: tag_replicas = "replicas"
  character(len("replica_numbers")),private,parameter :: tag_replica_numbers = "replica_numbers"
  character(len("proportional")),private,parameter :: tag_proportional = "proportional"
  character(len("end0")),private,parameter ::         tag_end0 = "end0"
  character(len("end1")),private,parameter ::         tag_end1 = "end1"

  ! --- approximate DFT+U : Hubbard model ---
  integer, allocatable :: ihubbard(:)  ! d(natm)
  character(len("hubbard")),private,parameter :: tag_hubbard = "hubbard"

  ! --- Projector group
  integer, allocatable :: iproj_group(:) ! dim(natm)
  character(len("proj_group")),private,parameter :: tag_proj_group = "proj_group"

! ================================== added by K. Tagami =============== 11.0
!
!!  -- NonCollinear --
!
  character(len("mdx")),private,parameter :: tag_mdx = "mdx"
  character(len("mdy")),private,parameter :: tag_mdy = "mdy"
  character(len("mdz")),private,parameter :: tag_mdz = "mdz"
  character(len("theta")),private,parameter :: tag_theta = "theta"
  character(len("phi")),private,parameter :: tag_phi = "phi"

  character(len("moment")),private,parameter :: tag_moment = "moment"
  character(len("mx")),private,parameter :: tag_mx = "mx"
  character(len("my")),private,parameter :: tag_my = "my"
  character(len("mz")),private,parameter :: tag_mz = "mz"
!
  real(kind=DP), allocatable :: mag_direction0_atomtyp(:,:)
  real(kind=DP), allocatable :: magmom_local_now(:,:)
!
! --
  character(len("lcore_parfil")),private,parameter :: &
       &                         tag_lcore_parfil = "lcore_parfil"
  integer, allocatable :: has_partially_filled_lcore(:)
! ===================================================================== 11.0

! ================ KT_add ===================== 13.0U
!
!! -- Initial Charge --
!
  character(len("ion_charge")),private,parameter :: tag_ion_charge = "ion_charge"
!
  logical :: mag_zeta1_atomtyp_is_defined = .false.
  logical :: mag_moment0_atomtyp_is_defined = .false.
  logical :: mag_moment0_atoms_is_defined = .false.
!
  real(kind=DP), allocatable :: mag_moment0_atomtyp(:,:)
  real(kind=DP), allocatable :: mag_moment0_atoms(:,:)
  real(kind=DP), allocatable :: mag_direction0_atoms(:,:)
  real(kind=DP), allocatable :: ionic_charge_atoms(:)
  real(kind=DP), allocatable :: ionic_charge_atomtyp(:)
! ============================================= 13.0U

! ================================ added by K. Tagami ============= 11.0
!
!! --- Spin-Orbit  ---
!
  integer, allocatable :: itab_spinorbit_addition(:)  ! d(natm)
!
  character(len("scaling_so")),private,parameter :: tag_scaling_so = "scaling_so"
  real(kind=DP), allocatable :: scaling_so(:)
! ================================================================= 11.0

  ! --- van der Waals
  integer :: ntyp_vdw
  integer, allocatable :: ityp_vdw(:) !d(natm)
  real(kind=DP) :: evdw ! vdW energy
  real(kind=DP), allocatable, dimension(:,:) :: fxyzvdw_l ! d(natm,3)
  real(kind=DP), allocatable :: cvdw(:,:) !d(ntyp_vdw,ntyp_vdw)
  real(kind=DP), allocatable :: rvdw(:,:) !d(ntyp_vdw,ntyp_vdw)
! === Apply modifications for vdW function. by tkato 2012/06/14 ================
  real(kind=DP), allocatable :: c6vdw(:) !d(ntyp_vdw)
  real(kind=DP), allocatable :: r0vdw(:) !d(ntyp_vdw)
  real(kind=DP), allocatable :: pvdw(:) !d(ntyp_vdw)
! ==============================================================================
  character(len=LEN_ATOMNAME),allocatable, dimension(:) ::  speciesname_vdw ! d(ntyp_vdw)
  character(len=LEN_ATOMNAME),private,allocatable,dimension(:) :: species_vdw_work ! d(natm)
  character(len=LEN_ATOMNAME),private,allocatable,dimension(:) :: species_vdw_indp ! d(natm)
  character(len("vdw")),private,parameter :: tag_vdw = "vdw"
  character(len("vdw_list")),private,parameter :: tag_vdw_list = "vdw_list"
! === Apply modifications for vdW function. by tkato 2012/06/14 ================
! character(len("type1")),private,parameter :: tag_type1 = "type1"
! character(len("type2")),private,parameter :: tag_type2 = "type2"
  !!character(len("type")),private,parameter :: tag_type = "type"
! ==============================================================================
  character(len("c6")),private,parameter :: tag_c6 = "c6"
  character(len("r0")),private,parameter :: tag_r0 = "r0"
! === Apply modifications for vdW function. by tkato 2012/06/14 ================
  character(len("p")),private,parameter :: tag_p = "p"
! ==============================================================================

! ======================================== KT_add ================ 13.0B
  real(kind=DP) :: s_vdw(3,3)
! ================================================================ 13.0B

  real(kind=DP), allocatable, dimension(:) :: ival

  ! --- for storing/retrieving atomic coordinates
  type atomic_configuration_t
    integer :: id
    integer :: group
    character(len=LEN_ATOMNAME) :: element
    character(len=LEN_ATOMNAME) :: element_vdw
    real(kind=DP),dimension(3) :: pos,cps,pos_in,cps_in,cpd_l
    real(kind=DP),dimension(3,3) :: cpo_l
    integer :: iwei,imdtyp,ityp,if_pdos,if_aldos,ihubbard,iproj_group,numlay,exclusion_target
    integer,dimension(3) :: imdtypxyz
    real(kind=DP) :: ionic_mass
    real(kind=DP) :: nvalence
  end type atomic_configuration_t
  type(atomic_configuration_t), allocatable, dimension(:) :: config_buf
  integer :: nconfig_buf

  ! --- for dynamical addition/removal of atoms 
  type(atomic_configuration_t), allocatable, dimension(:) :: atom_reservoir
  integer :: natom_reservoir = -1
  integer :: curr_atom_reservoir = 1
  integer :: natom_group = -1
  integer,allocatable,dimension(:) :: natm_per_group
  integer,allocatable,dimension(:,:) :: atomid_in_group
  character(len("reservoir")),private,parameter :: tag_reservoir = "reservoir"
  character(len("frequency")),private,parameter :: tag_frequency = "frequency"
  character(len("sw_rotate_reservoir")),private,parameter :: tag_sw_rotate_reservoir = "sw_rotate_reservoir"
  character(len("atom_addition_criteria")),private,parameter :: &
 & tag_atom_addition_criteria = "atom_addition_criteria"
  character(len("curr_atom_reservoir")), private, parameter :: tag_curr_atom_reservoir = "curr_atom_reservoir"
  character(len("reservoir_group")),private,parameter :: tag_reservoir_group = "reservoir_group"

  character(len("atom_exclusion_criteria")),private,parameter :: &
 & tag_atom_exclusion_criteria = "atom_exclusion_criteria"
  character(len("exclusion_target")),private,parameter :: &
 & tag_exclusion_target="exclusion_target"
  character(len("sw_atom_excludable")),private,parameter :: &
 & tag_sw_atom_excludable="sw_atom_excludable"
  character(len("x_greater_than")),private,parameter :: tag_x_greater_than = "x_greater_than"
  character(len("y_greater_than")),private,parameter :: tag_y_greater_than = "y_greater_than"
  character(len("z_greater_than")),private,parameter :: tag_z_greater_than = "z_greater_than"
  character(len("x_less_than")),private,parameter :: tag_x_less_than = "x_less_than"
  character(len("y_less_than")),private,parameter :: tag_y_less_than = "y_less_than"
  character(len("z_less_than")),private,parameter :: tag_z_less_than = "z_less_than"
  integer :: sw_atom_excludable = OFF
  integer, allocatable, dimension(:) :: exclusion_target
  real(kind=DP), dimension(3) :: exclusion_criteria_min
  real(kind=DP), dimension(3) :: exclusion_criteria_max

  integer :: addition_frequency = -1
  integer :: sw_rotate_reservoir = OFF
  real(kind=DP) :: neg_incre
  
! === check of atomic coordinates ===
  integer :: sw_check_coordinates = ON
  real(kind=DP) :: bond_length_min = 0.1
  character(len("sw_check_coordinates")),private,parameter :: tag_sw_check_coordinates = "sw_check_coordinates"
  character(len("bond_length_min")),private,parameter :: tag_bond_length_min = "bond_length_min"

  ! for the new CG optimizer
  integer, save :: iter_CG = 1, iter_linmin = 1, iter_CG_max = 1

  real(kind=DP),dimension(3) :: latconst_len,latconst_angle

  real(kind=DP) :: tdamp

  ! parameters for NPT
  real(kind=DP) :: m_baro = 1.d0
  real(kind=DP) :: target_pressure = 0.d0
  character(len("temperature_pressure_control")), private, parameter :: tag_temperature_pressure_control = &
  & "temperature_pressure_control"
  character(len("temperature_pressure_control")), private, parameter :: tag_pressure_temperature_control = &
  & "pressure_temperature_control"
  character(len("pressure_control")), private, parameter :: tag_pressure_control = &
  & "pressure_control"
  character(len("mass_baro")), private, parameter :: tag_m_baro = "mass_baro"
  character(len("pressure")), private, parameter :: tag_pressure = "pressure"
  character(len("m11")), private, parameter :: tag_m11 = 'm11'
  character(len("m22")), private, parameter :: tag_m22 = 'm22'
  character(len("m33")), private, parameter :: tag_m33 = 'm33'
  character(len("m12")), private, parameter :: tag_m12 = 'm12'
  character(len("m13")), private, parameter :: tag_m13 = 'm13'
  character(len("m23")), private, parameter :: tag_m23 = 'm23'
  character(len("control_pressure")), private, parameter :: tag_control_pressure = "control_pressure"
  integer, dimension(3,3) :: mobility_cell
  integer :: control_pressure = ON ! for debugging purposes

! paw
  integer, allocatable, dimension(:) :: surface_integral_method_paw
  character(len("surface_integral_method")), private, parameter :: tag_surface_integral_method = &
            & "surface_integral_method"
  character(len("sph")), private, parameter :: tag_sph = "sph"
  character(len("gl")), private, parameter :: tag_gl = "gl"

  character(len("sw_temperature_profile")), private, parameter ::tag_sw_temperature_profile = "sw_temperature_profile"
  integer :: sw_temperature_profile = OFF

! tags for temperature profile
  character(len("tempi")), private, parameter :: tag_tempi = "tempi"
  character(len("tempf")), private, parameter :: tag_tempf = "tempf"
  character(len("till_n")), private, parameter :: tag_till_n = "till_n"

! type for specifying the temperature profile
  type temperature_profile_t
    integer :: no
    real(kind=DP), pointer, dimension(:) :: tempi,tempf
    real(kind=DP), pointer, dimension(:) :: qmass,tdamp
    integer, pointer, dimension(:) :: till_n
    integer :: nprof, currprof, natm
  end type temperature_profile_t
  
  type(temperature_profile_t), allocatable, dimension(:) :: temperature_profile

! tags for defining regions
  character(len("region")),      private, parameter :: tag_region="region"
  character(len("cylinder")),    private, parameter :: tag_cylinder="cylinder"
  character(len("box")),         private, parameter :: tag_box="box"
  character(len("xmin")),        private, parameter :: tag_xmin="xmin"
  character(len("xmax")),        private, parameter :: tag_xmax="xmax"
  character(len("ymin")),        private, parameter :: tag_ymin="ymin"
  character(len("ymax")),        private, parameter :: tag_ymax="ymax"
  character(len("zmin")),        private, parameter :: tag_zmin="zmin"
  character(len("zmax")),        private, parameter :: tag_zmax="zmax"
  character(len("radius")),      private, parameter :: tag_radius="radius"
  character(len("orientation")), private, parameter :: tag_orientation="orientation"
  character(len("cylx")),        private, parameter :: tag_cylx="cylx"
  character(len("cyly")),        private, parameter :: tag_cyly="cyly"
  character(len("cylzmin")),     private, parameter :: tag_cylzmin="cylzmin"
  character(len("cylzmax")),     private, parameter :: tag_cylzmax="cylzmax"
  character(len("sigma")),       private, parameter :: tag_sigma="sigma"
  character(len("epsilon")),     private, parameter :: tag_epsilon="epsilon"
  character(len("sw_tally")),       private, parameter :: tag_sw_tally="sw_tally"
  character(len("region_group")),private, parameter :: tag_region_group = "region_group"

  type region_t
    integer :: no
    integer :: region_group
    integer :: region_type
    real(kind=DP) :: xmin,ymin,zmin
    real(kind=DP) :: xmax,ymax,zmax
    real(kind=DP) :: radius
    integer :: orientation
    real(kind=DP) :: cylx,cyly
    real(kind=DP) :: cylzmin,cylzmax
    real(kind=DP) :: sigma,epsi
    real(kind=DP) :: energy
    real(kind=DP), pointer, dimension(:,:) :: forc
    integer :: i1,i2,i3
    logical :: tally
    integer :: ntarget_atoms
    integer, pointer, dimension(:) :: target_atoms
  end type region_t
  type(region_t), allocatable, dimension(:) :: regions
  integer :: num_regions = 0

  character(len("dftd3")), private, parameter :: tag_dftd3="dftd3"
  character(len("k1")), private, parameter :: tag_k1 = "k1"
  character(len("k2")), private, parameter :: tag_k2 = "k2"
  character(len("k3")), private, parameter :: tag_k3 = "k3"
  character(len("s6")), private, parameter :: tag_s6 = "s6"
  character(len("s8")), private, parameter :: tag_s8 = "s8"
  character(len("sr6")), private, parameter :: tag_sr6 = "sr6"
  character(len("sr8")), private, parameter :: tag_sr8 = "sr8"
  character(len("alpha6")), private, parameter :: tag_alpha6 = "alpha6"
  character(len("alpha8")), private, parameter :: tag_alpha8 = "alpha8"
  character(len("rcut")), private, parameter :: tag_rcut = "rcut"
  type dftd3par_t
    integer :: maxelem,maxmaxnc,nlines
    integer, pointer, dimension(:) :: maxnc
    real(kind=DP), pointer, dimension(:,:,:,:) :: c6ab,nc1,nc2
    real(kind=DP), pointer, dimension(:,:) :: r0ab
    real(kind=DP), pointer, dimension(:) :: r2r4,covrad
    real(kind=DP) :: k1,k2,k3,s6,sr6,s8,sr8,sr9,alpha6,alpha8,alpha9
    real(kind=DP) :: rcut_nc,rcut_vdw
  end type dftd3par_t
  type(dftd3par_t) :: dftd3par

! subroutines contained here
!     m_IS_set_iatom
!     m_IS_rd_n
!        -- specify_ityp, wd_atom_list, count_species, set_input_coordinate_system,
!           set_atompos_and_etc, set_element_detail
!     m_IS_alloc_iatomn_etc
!     m_IS_alloc_napt
!     m_IS_alloc_fxyzew
!     m_IS_alloc_zfm3
!     m_IS_gdiis_alloc
!   1.m_IS_rd_pos_and_v
!   2.m_IS_wd_pos_and_v
!     - copy_cpd_l_to_pwork, - copy_cpo_l_to_pwork
!   3.m_IS_alloc_pos_and_v          <-(InputData_Analysis)
!   4.m_IS_cp_cps2cpo
!   5.m_IS_md                            ->(8,7,12,11,10,6,9)
!   7.  check_if_bondlength_fix_exist <-(5)
!
!   8.  md1_alloc
!   9.  md1_dealloc
!  10.  quench_velocities
!  11.  get_ekina
!  12.  evolve_velocities
!  13.m_IS_structure_factor
!     - structure_factor1,   - structure_factor2,  - wd_zfm3
!  14.m_IS_ewald
!     - wd_eewald_and_fxyzew, - ewald_Rspace_summation, - ewald_Gspace_summation
!     - get_zsum, - add_exp_G2_zsum, - ewald_force_Gspace_summation,
!     - set_ewald_parameters, - cpspac, - decide_newldg,  - decide_alf
!  15.m_IS_symm_check_of_pos
!     - symm_check_of_ions_positions_c
!  16.  decide_rxyz_size
!  17.  substitute_rxyz
!  18.m_IS_initialize_mdmode   <-(Initialization)
!  19.m_IS_initialize_cpd_l
!  20.m_IS_cps_to_pos
!  21.m_IS_wd_forc
!
!  --> temparature control
!  22.m_IS_rd_T_parameters
!  23.  T_control_alloc
!  23b. forcp_alloc
!  24.m_IS_rd_forcp_etc
!  25.m_IS_wd_forcp_etc
!  26.  check_imdtyp
!  27.  vlcty_accrd2_vVerlet
!  28.  ekina_ekinq_ekbt_and_ega
!  29.  evolve_crdn_ACCRD2_vVerlet
!  30.  evolve_cprv
!  31.  md2_alloc
!  32.  md2_dealloc
!  33.  heatrsv
!  34.m_IS_md_thermo
!     - check_nrsv
!  35.  rattle_v
!  36.  rattle_r
!     - stop0, evolve_almda, evolve_cps
!  38.m_IS_md_bluem
!     - print_frsv_and_cpqr, - init_md_bluem
!  39.m_IS_md_cnstr
!     - evaluate_forcmx, - quench_velocity_using_ifq, - init_md_cnstr
!  40.m_IS_force_check_md_cnstr
!  41.m_IS_alloc_cnstrvectors_etc
!  42.m_IS_cp_works2fcvect_etc
!  43.m_IS_init_cnstrnt
!  44.m_IS_wd_cpo_and_forc
!     m_IS_gdiis
!       forc_check
!       cps_check
!       cpd_check
!
contains
  subroutine m_IS_put_latconst_len_angle(length,angle)
    real(kind=DP), intent(in), dimension(3) :: length, angle
    latconst_len   = length
    latconst_angle = angle
  end subroutine m_IS_put_latconst_len_angle

  subroutine m_IS_put_lattice_system(lattice_system)
    character(len=9), intent(in) :: lattice_system
    lattice_system_from_m_CS_SG = lattice_system
  end subroutine m_IS_put_lattice_system

  subroutine alloc_normal_hypervector()
    if ( .not. allocated(normal_hypervector) ) then
       allocate(normal_hypervector(natm,3,PUCV:CARTS))
    endif
    normal_hypervector = 0.0d0
  end subroutine alloc_normal_hypervector

  subroutine set_normal_hypervector()
    integer :: i, j
    real(kind=DP) :: r
    do j = 1, 3
       do i = 1, natm
          if(imdtyp(i) == FIX) then
             normal_hypervector(i,j,PUCV) = 0.d0
          else
             r = pos_end1(i,j) - pos_end0(i,j)
             if(r > 0.5d0) then
                normal_hypervector(i,j,PUCV) = r - floor(r+0.5d0)
             else if( r <= -0.5d0) then
                normal_hypervector(i,j,PUCV) = r + floor(-r+0.5d0)
             else
                normal_hypervector(i,j,PUCV) = r
             end if
          end if
       end do
    end do
    call change_of_coordinate_system(altv,normal_hypervector(1,1,PUCV),natm,natm,normal_hypervector(1,1,CARTS))
  end subroutine set_normal_hypervector

! ===== KT_add === 2014/07/14
  subroutine read_hypervec_from_file
    integer :: i, j

    normal_hypervector = 0.0d0
    if ( mype == 0 ) then
       Do i=1, natm
          read(nfhypervec,*) ( normal_hypervector(i,j,CARTS),j=1,3 )
       End do
    endif

    if ( npes > 1 ) then
       call mpi_bcast( normal_hypervector, natm*3*2, &
            &          mpi_double_precision, 0, mpi_comm_group, ierr )
    endif
  end subroutine read_hypervec_from_file
! ================ 2014/07/14

  subroutine wd_normal_hypervector()
    integer :: i, j
    write(nfout,'(" !** == hypervector ==")')
    write(nfout,'(" !**     no.",10x,"(internal)",25x,"(cartesian)")')
    do i = 1, natm
       write(nfout,'(" !** ",i5," : ", 3f12.8," : ",3f12.8)') i &
            & , (normal_hypervector(i,j,PUCV),j=1,3), (normal_hypervector(i,j,CARTS),j=1,3)
    end do
  end subroutine wd_normal_hypervector

  subroutine alloc_bondlength_fix_set()
    allocate(bondlength_fix_set(2,num_fixed_bonds))
  end subroutine alloc_bondlength_fix_set

  subroutine m_IS_set_iatom(nfout)
    integer, intent(in) :: nfout
    integer :: i, k, mm
    do k = 1, ntyp
       iatom(k) = 0.d0
       do i = 1, natm
          if(ityp(i) /= k) cycle
          iatom(k) = iatom(k) + iwei(i)
       end do
    end do
! -- check of iwei
    mm = nint(sum(iatom(1:ntyp)))
    if(mm /= natm2 .and. printable) write(nfout,340) mm, natm2
340 format(' ',' sum of iwei .ne. natm2 mm,natm2=',2i6)
  end subroutine m_IS_set_iatom

  subroutine m_IS_rd_n(nfout)
    ! <m_IS_rd_n> reads atomic coorindates and information of species from an input file 
    !     formatted in a new style.
    ! This subroutine was coded by T. Yamasaki (FUJITSU LABORATORIES LTD.), Jun. 2003

    integer, intent(in) :: nfout
    character(len=FMAXVALLEN) :: rstr
    integer :: iret, icounted, i
    real(kind=DP) :: dret
    integer :: f_selectTop, f_selectBlock, f_getIntValue, f_getRealValue, f_getStringValue, f_selectParentBlock
    logical :: tf, number_is_given, prealloc
    real(kind=DP), allocatable, dimension(:,:) :: work
    real(kind=DP), allocatable, dimension(:,:) :: rltv_t
    real(kind=DP), allocatable, dimension(:,:) :: fcvect_work
    integer, allocatable, dimension(:,:) :: iwork
    integer :: fixed_atoms, input_coordinate_system_t, istat
    integer :: ig

    iret = f_selectTop()

    if(ipriinputfile >= 2 .and. printable) write(nfout,'(" !** << m_IS_rd_n >>")')
    ! --- Structure ---
    if( f_selectBlock( tag_structure) == 0) then
       if(ipriinputfile >= 2 .and. printable) write(nfout,'(" !** -- tag_structure --")')

       ! --- check whether the atoms can be excluded during MD ---
       if( f_getIntValue(tag_sw_atom_excludable,iret)==0) sw_atom_excludable=iret

       ! --- atom_list ---
       if( f_selectBlock( tag_atomlist) == 0) then
          ! --- count total number of atoms ---
          prealloc = .true.
          number_is_given = f_getIntValue( tag_numatoms, iret) == 0
          if(number_is_given) natm = iret

          if( f_getStringValue( tag_coordinate_system, rstr, LOWER) == 0) then
             call set_input_coordinate_system(rstr) ! -> input_coordinate_system
          end if

          if( f_selectBlock(tag_displacement) == 0) then
             call set_displacement()
             iret = f_selectParentBlock()
          end if
          if( f_selectBlock(tag_vibrational_mode) == 0) then
             call set_vibrational_mode()
             iret = f_selectParentBlock()
          end if
          if( f_selectBlock(tag_atoms) == 0) then
             call set_atompos_and_etc(prealloc, natm, iret)
             if(iret <= 0) stop ' atomic coordinates are not given properly <<m_IS_rd_n>>'
             if(number_is_given .and. natm > iret) then
                natm = iret
             else if(.not.number_is_given) then
                natm = iret
             end if
             natmorg = natm
             iret = f_selectParentBlock()
          else
             stop ' tag_atom is not given <<m_IS_rd_n>>'
          end if

          if(ipriinputfile >= 1 .and. printable) write(nfout,'(" !** number of atoms = ",i5)') natm
          allocate(work(natm,3), stat=istat)
          if (istat /= 0) then 
             if(printable) write(nfout,*) 'Allocation error in sub.set_atompos_and_etc',natm,istat
             stop
          end if

          call m_IS_alloc_pos_and_v(nfout) ! d(natm)
          call alloc_species_work()   ! d(natm)
          call alloc_species_vdw_work()   ! d(natm)

!          if( f_getStringValue( tag_coordinate_system, rstr, LOWER) == 0) then
!             call set_input_coordinate_system(rstr) ! -> input_coordinate_system
!          end if

          if( f_getStringValue( tag_howtogive_coordinates, rstr, LOWER) == 0) then
             call set_howtogive_coordinates(rstr)   ! -> howtogive_coordinates
             if(ipriinputfile >= 0 .and. printable) &
                  & write(nfout,'(" !* howtogive_coordinates = ",i5)') howtogive_coordinates
          end if

          ! --- setting atomic coordinates and etc.
          if( f_selectBlock(tag_atoms) == 0) then
             prealloc = .false.
             call set_atompos_and_etc(prealloc, natm, iret) ! -> pos,imdtyp,element,natm2
             iret = f_selectParentBlock()
          else
             stop ' atom coordinates are not given properly in the inputfile'
          end if
          call count_species()        ! -> ntyp
          call count_species_vdw()    ! -> ntyp_vdw
          deallocate(work)
          iret = f_selectParentBlock()
       else
          stop ' no atom_list <<m_IS_rd_n>>'
       end if

       if(mype_conf>0.and.driver==DRIVER_MTD)then
          if(f_selectBlock(tag_atomlist)==0)then
             write(rstr,*) mype_conf
             if(f_selectBlock(tag_atoms//trim(adjustl(rstr)))==0)then
!!                if(printable) write(nfout,'(a)') 'reading coodinates from : '//tag_atoms//trim(adjustl(rstr))
                call set_atompos_and_etc(prealloc,natm,iret)
                iret=f_selectParentBlock()
             endif
             iret = f_selectParentBlock()
          endif
       endif

       allocate(work(natm,3), stat=istat)
       if (istat /= 0) then 
          if(printable) write(nfout,*) 'Allocation error in sub.set_atompos_and_etc',natm,istat
          stop
       end if
       if(endpoint_images /= NO) then
          call alloc_endpoint_pos(nfout)
          if(endpoint_images == DIRECTIN) then
             input_coordinate_system_t = input_coordinate_system
             if( f_selectBlock( tag_atom_list_end0) == 0) then
                if( f_getStringValue( tag_coordinate_system, rstr, LOWER) == 0)  &
                     call set_input_coordinate_system(rstr) ! -> input_coordinate_system
                if( f_selectBlock(tag_atoms) == 0) then
                   prealloc = .false.
                   call set_endpoint_atompos(natm,pos_end0, cps_end0) ! -> pos,imdtyp,element,natm2
                   iret = f_selectParentBlock()
                else
                   stop ' endpoint atom coordinates are not given properly in the inputfile'
                end if
                iret = f_selectParentBlock()
             end if

             if( f_selectBlock( tag_atom_list_end1) == 0) then
                if( f_getStringValue( tag_coordinate_system, rstr, LOWER) == 0)  &
                     call set_input_coordinate_system(rstr) ! -> input_coordinate_system
                if( f_selectBlock(tag_atoms) == 0) then
                   prealloc = .false.
                   call set_endpoint_atompos(natm,pos_end1, cps_end1) ! -> pos,imdtyp,element,natm2
                   iret = f_selectParentBlock()
                else
                   stop ' endpoint atom coordinates are not given properly in the inputfile'
                end if
                iret = f_selectParentBlock()
             end if
             input_coordinate_system = input_coordinate_system_t
          else if(endpoint_images == FILE) then
             ! .....
             ! .....
             ! .....
          end if
          if(howtogive_coordinates == FROM_ENDPOINTS) then
             call set_atompos_from_endpoints() ! pos <- pos_end0, pos_end1
          else if(howtogive_coordinates == DIRECTIN) then
             call set_atompos2()
          end if
       else
          if(sw_displace_atom == ON) call set_displacement2()
          if(sw_vibrational_mode == ON) call set_vibrational_mode2()
          call set_atompos2() 
       end if

       deallocate(work)

       constraints_exist = .false.

       ! --- constraint ---
       call initialize_constraint_param     ! use this for cell optimization

       if( f_selectBlock( tag_constraint) == 0) then
          if(ipriinputfile >= 1) write(nfout,'(" !** -- tag_constraint is found --")')
          if(imdalg == CG_STROPT) then
             if(ipriinputfile >= 1) write(nfout,' &
                  & (" !** The constraint tag block is skipped, because imdalg == CG")')
             goto 1004
          elseif(imdalg == CG_STROPT2) then
             if(ipriinputfile >= 1) write(nfout,' &
                  & (" !** The constraint tag block is skipped, because imdalg == CG2")')
             goto 1004
          else if(imdalg == T_CONTROL) then
             if(ipriinputfile >= 1) write(nfout,' &
                  & (" !** The constraint tag block is skipped, because imdalg == T_CONTROL")')
             goto 1004
          end if

          ! --- bondlength_fix ---
          ! --- count total number of conditions of bondlength fix ---
          number_is_given = f_getIntValue( tag_num_fixed_bonds, iret) == 0
          if(number_is_given) num_fixed_bonds = iret

          tf = f_selectBlock( tag_fixed_bond) == 0
          if(.not.tf) tf = f_selectBlock( tag_fix_bondlength) == 0
          if(.not.tf) tf = f_selectBlock( tag_bondlength_fix) == 0
          if(tf) then
             if(ipriinputfile >= 1 .and. printable) write(nfout,'(" !** --tag_bondlength_fix or resembling tag is found --")')
             prealloc = .true.
             call set_fixed_bond_atoms(prealloc,num_fixed_bonds,iret,fixed_atoms)
             if(iret <= 0) stop ' fixed_bond is not given properly <<m_IS_rd_n>>'
             nfcatm = fixed_atoms
             if(number_is_given .and. num_fixed_bonds > iret) then
                num_fixed_bonds = iret
             else if(.not.number_is_given) then
                num_fixed_bonds = iret
             end if
             if(ipriinputfile >= 1 .and. printable) &
                  & write(nfout,'(" !** number of fixed bonds = ",i5)') num_fixed_bonds
             iret = f_selectParentBlock()
          end if
          ! --- setting bondlength fix sets ---
          if (tf) call alloc_bondlength_fix_set()  ! allocate(bondlength_fix_set(2,num_fixed_bonds))
          tf = f_selectBlock( tag_fixed_bond) == 0
          if(.not.tf) tf = f_selectBlock( tag_fix_bondlength) == 0
          if(.not.tf) tf = f_selectBlock( tag_bondlength_fix) == 0
          if(tf) then
             prealloc = .false.
             call set_fixed_bond_atoms(prealloc,num_fixed_bonds,iret)
             constraints_exist = .true.
             constraint_type = BONDLENGTH_FIX

             call m_IS_alloc_cnstrvectors_etc(imdalg)
             call substitute_ia_cnst()
             iret = f_selectParentBlock()

             if(ipriinputfile >= 1 .and. printable) then
                write(nfout,'(" !*  bondlength fix")') 
                write(nfout,'(" !** number of fixed_atoms = ",i5)') fixed_atoms
                write(nfout,'(" !** nfcatm                = ",i5)') nfcatm
                do i = 1, nfcatm
                   write(nfout,'(" !** ia_cnst(",i5,") = ",i5)') i, ia_cnst(i)
                end do
             end if
          end if

          if(constraints_exist) goto 1003

!!$          ! --- cog_fix ---
!!$          tf = f_selectBlock( tag_cog_fix) == 0
!!$          if(tf) then
!!$             constraints_exist = .true.
!!$             constraint_type = COG_FIX
!!$             call set_cog_fix(fixed_atoms)
!!$             nfcatm = fixed_atoms
!!$             call m_IS_alloc_cnstrvectors_etc()
!!$             call substitute_ia_cnst()
!!$             if(ipriinputfile >= 1) then
!!$                write(nfout,'(" !* cog_fix")')
!!$                write(nfout,'(" !** nfcatm = ",i5)') nfcatm
!!$                do i = 1, nfcatm
!!$                   write(nfout,'(" !** ia_cnst(",i5," ) = ",i5)') i, ia_cnst(i)
!!$                end do
!!$             end if
!!$             iret = f_selectParentBlock()
!!$          end if
!!$          if(constraints_exist) goto 1003

          ! --- cog_fix_l ---
          ! --- count total number of planes in which cog's are fixed ---
          number_is_given = f_getIntValue( tag_num_planes, iret) == 0
          if(number_is_given) num_planes_atoms_are_fixed = iret
          tf = f_selectBlock( tag_cog_fix) == 0
          if(.not.tf) tf = f_selectBlock( tag_cog_fix_l) == 0
          if(.not.tf) tf = f_selectBlock( tag_cog_fix_in_a_plane) == 0
          if(tf) then
             if(printable) write(nfout,'(" !* tag_cog_fix_l or tag_cog_fix_in_a_plane is found")')
             prealloc = .true.
             call set_fixed_planes(prealloc,COG_FIX_L,num_planes_atoms_are_fixed,iret,nfcatm)
             if(iret <= 0) stop ' cog_fix_planes are not given properly <<m_IS_rd_n>>'
             if(number_is_given .and. num_planes_atoms_are_fixed > iret) then
                num_planes_atoms_are_fixed = iret
             else if(.not.number_is_given) then
                num_planes_atoms_are_fixed = iret
             end if
             if(ipriinputfile >= 1 .and. printable) &
                  & write(nfout,'(" !** number of planes in which COGs are fixed = ",i5)') num_planes_atoms_are_fixed
             iret = f_selectParentBlock()
          end if

          ! --- setting cog fixed planes and constrained atoms ---
          tf = f_selectBlock( tag_cog_fix) == 0
          if(.not.tf) tf = f_selectBlock( tag_cog_fix_l) == 0
          if(.not.tf) tf = f_selectBlock( tag_cog_fix_in_a_plane) == 0
          if(tf) then
             call m_IS_alloc_cnstrvectors_etc(imdalg)
             if(printable) write(nfout,'(" !* tag_cog_fix_l or tag_cog_fix_in_a_plane is found (2)")')
             prealloc = .false.
             call set_fixed_planes(prealloc,COG_FIX_L,num_planes_atoms_are_fixed, iret)
             constraints_exist = .true.
             constraint_type = COG_FIX_L

             move_constrained_plane = .false.
             do i = 1, nfcatm
                if(abs(fcvect(i,4)) > SmallestPositiveNumber*1.d5) move_constrained_plane = .true.
             end do
             if(ipriinputfile >= 1 .and. printable) then
                write(nfout,'(" !** nfcatm = ",i5, " (cog_fix)")') nfcatm
                do i = 1, nfcatm
                   write(nfout,'(" !** ia_cnst(",i4,") = ",i5," , fcvect = ",4f6.3," , ipfixedplane = ",i5," (1)")') &
                        & i,ia_cnst(i),fcvect(i,1:4), ipfixedplane(i)
                end do
             end if
             iret = f_selectParentBlock()
          end if

          ! --- fix_in_a_plane ---
          ! --- count total number of planes in which atoms are fixed ---
          prealloc = .true.
          number_is_given = f_getIntValue( tag_num_planes, iret) == 0
          if(number_is_given) num_planes_atoms_are_fixed = iret
          tf = f_selectBlock( tag_fix_in_a_plane) == 0
          if(.not.tf) tf = f_selectBlock( tag_fixed_plane) == 0
          if(tf) then
             if(ipriinputfile>=1) write(nfout,'(" !* tag_fix_in_a_plane or tag_fixed_plane is found")')
             call set_fixed_planes(prealloc,FIX_IN_A_PLANE &
                  & ,num_planes_atoms_are_fixed,iret, nfcatm)
             if(iret <= 0) stop ' planes are not given properly <<m_IS_rd_n>>'
             if(number_is_given .and. num_planes_atoms_are_fixed > iret) then
                num_planes_atoms_are_fixed = iret
             else if(.not.number_is_given) then
                num_planes_atoms_are_fixed = iret
             end if
             iret = f_selectParentBlock()
             if(ipriinputfile >= 1) &
               & write(nfout,'(" !** number of planes in which atoms are fixed = ",i5)') num_planes_atoms_are_fixed
          end if

          ! --- setting fixed planes and constrained atoms ---
!!$          call alloc_fcvect_tmp()
          tf = f_selectBlock( tag_fix_in_a_plane) == 0
          if(.not.tf) tf = f_selectBlock( tag_fixed_plane) == 0
          if(tf) then
             call m_IS_alloc_cnstrvectors_etc(imdalg)
             prealloc = .false.
             call set_fixed_planes(prealloc, FIX_IN_A_PLANE &
                  & , num_planes_atoms_are_fixed, iret)
             constraints_exist = .true.
             constraint_type = FIX_IN_A_PLANE
             iret = f_selectParentBlock()

             move_constrained_plane = .false.
             do i = 1, nfcatm
                if(abs(fcvect(i,4)) > SmallestPositiveNumber*1.d5) move_constrained_plane = .true.
             end do

             if(ipriinputfile >= 1 .and. printable) then
                write(nfout,'(" !** nfcatm = ",i5)') nfcatm
                do i = 1, nfcatm
                   write(nfout,'(" !** ia_cnst(",i4,") = ",i5," , fcvect = ",4f6.3," , ipfixedplane = ",i5," (2)")') &
                        & i,ia_cnst(i),fcvect(i,1:4), ipfixedplane(i)
                end do
             end if
          end if

          if(constraints_exist) goto 1003

          ! --- setting a fixed normal hypervector ---
          tf = f_selectBlock( tag_fixed_normal_hypervector) == 0
          if(tf) then
             call alloc_normal_hypervector()

! ======== KT_mod ==== 2014/07/14
!             if(endpoint_images /= NO) then
!                call set_normal_hypervector()
!             else
!                stop ' endpoint_images are not given'
!             end if

             if ( f_getIntValue( tag_hypervec_from_file,iret )== 0 ) then
                write(nfout,*) '*** hypervec_from_file is ', iret
                hypervec_from_file = iret
             endif
             if ( hypervec_from_file == ON ) then
                call m_Files_open_nfhypervec()
                call read_hypervec_from_file
                call m_Files_close_nfhypervec()
             else
                if(endpoint_images /= NO) then
                   call set_normal_hypervector()
                else
                   stop ' endpoint_images are not given'
                end if
             endif
! ===================== 2014/07/14

!!$             tf = f_getIntValue(tag_mode_coefficient,iret)== 0
!!$             if(tf) mode_fi_coefficient = iret
!!$             if(mode_fi_coefficient == ON) then
!!$                tf = f_getRealValue(tag_coefficient,dret,'') == 0
!!$                if(tf) fi_coefficient = dret
!!$             end if
             iret = f_selectParentBlock()
             constraints_exist = .true.
             constraint_type = FIXED_NORMAL_HYPERVECTOR

             if(ipriinputfile >= 1) then
                call wd_normal_hypervector()
!!$                write(nfout,'(" !** mode_fi_coefficient = ",i5)') mode_fi_coefficient
!!$                write(nfout,'(" !**      fi_coefficient = ",f8.4)') fi_coefficient
             end if
          end if

1003      continue
          if(ipriinputfile >=1 ) then
             if(move_constrained_plane) then
                write(nfout,'(" !** move_constrained_plane = .true.")')
             else
                write(nfout,'(" !** move_constrained_plane = .false.")')
             end if
          end if

          if(.not.constraints_exist .and. ipriinputfile>=1) &
               & write(nfout,'(" !** constraint details are not described")')
1004      iret = f_selectParentBlock()
       else
          if(ipriinputfile >= 1) write(nfout,'(" !** -- tag_constraint is not found --")')
          if(imdalg == QUENCHED_CONSTRAINT) then
             imdalg = QUENCHED_MD
             if(ipriinputfile >= 1 ) write(nfout,&
                  & '(" !** imdalg is set QUENCHED_MD (from QUENCHED_CONSTRAINT)")')
          end if
       end if

       if(sw_vdw_correction == ON .and. vdw_method == VDW_DFTD3)then
          call m_IS_alloc_vdwdf3()
          call resolve_dftd3_parameters()
          call read_dftd3_parameters()
       endif
       ! ---- vdw_list ----
       if(vdw_method /= VDW_DFTD3 .and. ntyp_vdw>0) then
          call alloc_speciesname_vdw()     ! d(ntyp_vdw)
          call m_IS_alloc_vdw() ! cvdw, rvdw, ityp_vdw, fxyzvdw_l
! === Apply modifications for vdW function. by tkato 2012/06/14 ================
!         if( f_selectBlock( tag_vdw_list) == 0) then
!            call set_vdw_parameters()   ! -> cvdw, rvdw
!            iret = f_selectParentBlock()
!         else
!            stop ' the vdW list is not given properly in the inputfile'
!         end if
          call set_vdw_parameters()   ! -> cvdw, rvdw
! ==============================================================================
          call specify_ityp_vdw()  ! -> itpy_vdw
          call dealloc_species_vdw_work()
       end if

       ! --- element_list ---
       call alloc_speciesname()     ! d(ntyp)
       call m_IS_alloc_iatomn_etc() ! iatomn, iatom, ivan, alfa, amion, zeta1, qex
       if( f_selectBlock( tag_element_list) == 0) then
          call set_element_detail()   ! -> iatomn, alfa, amion, zeta1,qex
          iret = f_selectParentBlock()
       else
          stop ' the element list is not given properly in the inputfile'
       end if
       call specify_ityp()  ! -> itpy
       if(ipriinputfile >= 1 .and. printable) call wd_atom_list()
       call m_IS_set_iatom(nfout) ! -> iatom
       call dealloc_species_work()

#ifndef _EMPIRICAL_
       !! Projector: set proj_attribute(:)%ityp
       do i=1,natm
          call m_CtrlP_set_proj_ityp(iproj_group(i),ityp(i))
       end do
#endif
       if(sw_atom_excludable==ON)then
           if(sum(exclusion_target)==0)then
               if(printable)then
                   write(nfout,'(a)') ' !** sw_atom_excludable is ON, but exclusion target is undefined.'
               endif
               sw_atom_excludable = OFF
           endif
       endif
       if(sw_atom_excludable==ON)then
           call set_atm_exclusion_criteria()
           if(printable)then
              write(nfout,'(a)') ' !** atoms are excludable during MD simulation '
              write(nfout,'(a)') ' !** atoms targeted for exclusion '
              do i=1,natm
                 if(exclusion_target(i)==ON) write(nfout,'(i8)') i
              enddo
              write(nfout,'(a)') ' !** an atom will be excluded if it is located outside the following box:'
              write(nfout,'(a,e20.10,a,e20.10,a,e20.10)') &
           & ' !** x greater than ',exclusion_criteria_min(1),' and less than ',exclusion_criteria_max(1)
              write(nfout,'(a,e20.10,a,e20.10,a,e20.10)') &
           & ' !** y greater than ',exclusion_criteria_min(2),' and less than ',exclusion_criteria_max(2)
              write(nfout,'(a,e20.10,a,e20.10,a,e20.10)') &
           & ' !** z greater than ',exclusion_criteria_min(3),' and less than ',exclusion_criteria_max(3)
           endif
       endif

       if(f_selectBlock(tag_reservoir)==0.and.icond/=COORDINATE_CONTINUATION) then
          call set_atompos_and_etc_reservoir()
          iret = f_selectParentBlock()
       endif

       ! --- atom addition criteria
       if(f_selectBlock(tag_atom_addition_criteria)==0)then
          if(f_getIntValue(tag_sw_rotate_reservoir,iret)==0) sw_rotate_reservoir = iret
          if(f_getIntValue(tag_frequency,iret)==0) addition_frequency = iret
          iret = f_selectParentBlock()
       endif
       !if(printable .and. addition_frequency>0) write(nfout,'(a,i8)') '!** addition frequency : ',addition_frequency
       if(printable) write(nfout,'(a,i8)') ' !** addition frequency : ',addition_frequency
       pos_in = pos;cps_in=cps

       if(f_getIntValue(tag_sw_check_coordinates,iret)==0) sw_check_coordinates = iret
       if(f_getRealValue(tag_bond_length_min,dret,'bohr')==0) bond_length_min = dret
       !check validity of atomic coordinates

       ! read and allocate 'regions'
       call set_regions(nfout)

       if(sw_check_coordinates==ON) call check_coor()

       iret = f_selectParentBlock()
    end if


    ! --- multiple replica for new format --
    if(multiple_replica_mode == ON) then

      if( f_selectBlock( tag_multiple_replica) == 0) then
      if(ipriinputfile >= 2 .and. printable) write(nfout,'(" !*  tag_multiple_replica")')

        if( f_selectBlock( tag_structure) == 0) then
        ! -- count total number of replicas
          prealloc = .true.
          number_is_given = f_getIntValue( tag_number_of_replicas, iret) == 0
          if(number_is_given) number_of_replicas = iret
          if( f_selectBlock(tag_replicas)  == 0) then
            call set_replica_input_method(prealloc, number_of_replicas, iret)
            if(number_is_given .and. number_of_replicas > iret) then
               number_of_replicas = iret
            else if(.not.number_is_given) then
               number_of_replicas = iret
            end if
            iret = f_selectParentBlock()
          else
            stop ' tag_replicas is not given <<m_IS_rd_n>>'
          end if
          if(ipriinputfile >= 1 .and. printable) &
              & write(nfout,'(" !** number of replicas = ",i5)') number_of_replicas
          ! <--

	  if(number_of_replicas > 1) then
            allocate(replica_howtogive_coordinates(number_of_replicas), stat=istat)
            if (istat /= 0) then 
              if(printable) write(nfout,*) 'Allocation error of replica_howtogive_coordinates in <<m_IS_rd_n>>'&
                   & ,number_of_replicas,istat
                stop
              end if
              replica_howtogive_coordinates(:) = PROPORTIONAL
              allocate(replica_endpoints(2,number_of_replicas), stat=istat)
              if (istat /= 0) then 
                if(printable) write(nfout,*) 'Allocation error of replica_endpoints in <<m_IS_rd_n>>' &
                     & ,number_of_replicas,istat
                stop
              end if
              replica_endpoints(1,:) = 0
              replica_endpoints(2,:) = -1

              ! 0 represents the right-most image, while -1represents the
              ! left-most image
              ! --- setting replica_howtogive_coordinates and endpoints --
              if( f_selectBlock(tag_replicas)  == 0) then
                prealloc = .false.
                call set_replica_input_method(prealloc, number_of_replicas, iret)
                            ! -> replica_howtogive_coordinates, replica_endpoints
                iret = f_selectParentBlock()
              else
                stop ' replicas are not given properly in the inputfile'
              end if
	    else
              number_of_replicas = 1
              allocate(replica_howtogive_coordinates(number_of_replicas), stat=istat)
              allocate(replica_endpoints(2,number_of_replicas), stat=istat)
              replica_howtogive_coordinates(1) = DIRECTIN
            end if

            if(ipriinputfile >= 1 .and. printable) then
              if(number_of_replicas > 1) then 
                write(nfout,'(" !**   ---  howtogive_coordinates ---")')
                write(nfout,'(" !**         DIRECTIN : ",i4)') DIRECTIN
                write(nfout,'(" !**     PROPORTIONAL : ",i4)') PROPORTIONAL
                write(nfout,'(" !**   FROM_ENDPOINTS : ",i4)') FROM_ENDPOINTS
                write(nfout,'(" !**            FILE  : ",i4)') FILE
              end if
              do i = 1, number_of_replicas
                write(nfout,'(" !** id = ",i8, " howtogive_coordinates = ",i4, " endpoints = ",2i5 )') &
      &            i, replica_howtogive_coordinates(i), replica_endpoints(1:2,i)
              end do
	    end if

            if(number_of_replicas > 1) then 
	      tf = .false.
              do i = 1, number_of_replicas
		if(replica_howtogive_coordinates(i) == FILE) then
		  tf = .true.
		  exit
		end if
	      end do
	      if(tf) then
		allocate(pos_image(number_of_replicas,natm,3))
		allocate(cps_image(number_of_replicas,natm,3))
	      if(printable) write(nfout,'(" !** pos_image and cps_image are allocated. ")')
	        do i = 1, number_of_replicas
  		  if(replica_howtogive_coordinates(i) == FILE) then
	            input_coordinate_system_t = input_coordinate_system
		    call m_Files_open_nfimage(i)
                    call set_endpoint_atompos_from_file(nfimage,natm, &
				pos_image(i,:,:),cps_image(i,:,:))
		    close(nfimage)		    
                    input_coordinate_system = input_coordinate_system_t
		  end if
	        end do
	      end if
            end if

            if( f_getStringValue( tag_endpoint_images, rstr, LOWER) == 0) &
                 & call set_endpoint_images(rstr)  ! -> endpoint_images
            if(ipriinputfile >= 1) write(nfout,'(" !** set_endpoint_images = ",i5)') endpoint_images

            if( f_getStringValue( tag_howtogive_coordinates, rstr, LOWER) == 0) then
              call set_howtogive_coordinates(rstr)   ! -> howtogive_coordinates
              if(ipriinputfile >= 0 .and. printable) &
                  & write(nfout,'(" !* howtogive_coordinates = ",i5)') howtogive_coordinates
            end if

	    allocate(work(natm,3), stat=istat)
            if (istat /= 0) then 
              if(printable) write(nfout,*) 'Allocation error in sub.set_atompos_and_etc',natm,istat
              stop
            end if

            if(endpoint_images /= NO) then
              call alloc_endpoint_pos(nfout)
              if(endpoint_images == DIRECTIN) then
                input_coordinate_system_t = input_coordinate_system

                if( f_selectBlock( tag_atom_list_end0) == 0) then
                  if( f_getStringValue( tag_coordinate_system, rstr, LOWER) == 0)  &
                    call set_input_coordinate_system(rstr) ! -> input_coordinate_system
                  if( f_selectBlock(tag_atoms) == 0) then
                    prealloc = .false.
                    call set_endpoint_atompos(natm,pos_end0, cps_end0) ! -> pos,imdtyp,element,natm2
                    iret = f_selectParentBlock()
                  else
                    stop ' endpoint atom coordinates are not given properly in the inputfile'
                  end if
                  iret = f_selectParentBlock()
                end if

                if( f_selectBlock( tag_atom_list_end1) == 0) then
                  if( f_getStringValue( tag_coordinate_system, rstr, LOWER) == 0)  &
                    call set_input_coordinate_system(rstr) ! -> input_coordinate_system
                  if( f_selectBlock(tag_atoms) == 0) then
                    prealloc = .false.
                    call set_endpoint_atompos(natm,pos_end1, cps_end1) ! -> pos,imdtyp,element,natm2
                    iret = f_selectParentBlock()
                  else
                    stop ' endpoint atom coordinates are not given properly in the inputfile'
                  end if
                  iret = f_selectParentBlock()
                end if
                input_coordinate_system = input_coordinate_system_t

              else if(endpoint_images == FILE) then
                input_coordinate_system_t = input_coordinate_system

		call m_Files_open_nfimage(0)
                call set_endpoint_atompos_from_file(nfimage,natm,pos_end0,cps_end0)
		close(nfimage)

		call m_Files_open_nfimage(-1)
                call set_endpoint_atompos_from_file(nfimage,natm,pos_end1,cps_end1)
		close(nfimage)

                input_coordinate_system = input_coordinate_system_t
              end if
              if(howtogive_coordinates == FROM_ENDPOINTS) then
                call set_atompos_from_endpoints() ! pos <- pos_end0, pos_end1
              else if(howtogive_coordinates == DIRECTIN) then
                call set_atompos2()
              end if
           else
             if(sw_displace_atom == ON) call set_displacement2()
             if(sw_vibrational_mode == ON) call set_vibrational_mode2()
             call set_atompos2() 
           end if

           deallocate(work)

           iret = f_selectParentBlock()

         end if   ! tag_structure

         if( f_selectBlock( tag_constraint) == 0) then
	     if(f_getIntValue(tag_ci_neb, iret) == 0) ci_neb = iret
             if(f_getRealValue(tag_sp_k_init,dret,'') == 0) sp_k_init = dret
             if(f_getRealValue(tag_sp_k_min,dret,'') == 0) sp_k_min = dret
             if(f_getRealValue(tag_sp_k_max,dret,'') == 0) sp_k_max = dret
	     if(f_getIntValue(tag_sp_k_variable, iret) == 0) sp_k_variable = iret
	     iret = f_selectParentBlock()
	 end if   ! tag_constraint

         if( f_selectBlock( tag_accuracy) == 0) then
             if(f_getRealValue(tag_neb_dt,dret,'au_time') == 0) neb_dt = dret
             if( f_getStringValue(tag_neb_time_integral, rstr, LOWER) == 0 ) then
		call set_neb_time_integral(rstr)
	     end if
	     if(f_getIntValue(tag_penalty_function, iret) == 0) penalty_function = iret
!!             if(f_getIntValue(tag_neb_convergence_condition,iret) == 0) &
!!			neb_convergence_condition = iret
             if( f_getStringValue(tag_neb_convergence_condition, rstr, LOWER) == 0 ) then
	        call set_neb_convergence_condition(rstr)
	     end if
             if(f_getRealValue(tag_neb_convergence_threshold,dret,'') == 0) &
			neb_convergence_threshold = dret
	     iret = f_selectParentBlock()
	 end if   ! tag_constraint

         iret = f_selectParentBlock()
       end if  ! tag_multiple_replica

    end if   ! multiple_replica_mode

    if(nfcatm >= 1) then
       cnst_typ = imdtyp(ia_cnst(1))
       imdtypxyz(ia_cnst(1),:) = imdtyp(ia_cnst(1))
       if(cnst_typ > HEAT_BATH) then
          cnst_typ = cnst_typ - HEAT_BATH
       end if
       if(imdalg == QUENCHED_CONSTRAINT) then
          if(cnst_typ /= COG_FIX_L .and. cnst_typ /= BONDLENGTH_FIX_1 &
               & .and. cnst_typ /= BONDLENGTH_FIX_2) then
             imdalg = QUENCHED_MD
             if(iprimd >= 1) write(nfout,'(" !** imdalg is reset ",i5 &
                  & ," (= QUENCHED_MD), because cnst_typ is not proper")') imdalg
          end if
       end if

       if(iprimd>=1) then
          cnstrainttype: select case (cnst_typ)
          case(COG_FIX)
             write(nfout,'(" !** cnst_typ = ",i5," (= COG_FIX)")') cnst_typ
          case (COG_FIX_L)
             write(nfout,'(" !** cnst_typ = ",i5," (= COG_FIX_L)")') cnst_typ
          case (FIX_IN_A_PLANE)
             write(nfout,'(" !** cnst_typ = ",i5," (= FIX_IN_A_PLANE)")') cnst_typ
          case (BONDLENGTH_FIX)
             write(nfout,'(" !** cnst_typ = ",i5," (= BONDLENGTH_FIX)")') cnst_typ
          case (BONDLENGTH_FIX_1)
             write(nfout,'(" !** cnst_typ = ",i5," (= BONDLENGTH_FIX_1)")') cnst_typ
          case (BONDLENGTH_FIX_2)
             write(nfout,'(" !** cnst_typ = ",i5," (= BONDLENGTH_FIX_2)")') cnst_typ
          case (FIXED_NORMAL_HYPERVECTOR)
             write(nfout,'(" !** cnst_typ = ",i5," (= FIXED_NORMAL_HYPERVECTOR)")') cnst_typ
          case default
             write(nfout,'(" !** cnst_typ = ",i5)') cnst_typ
          end select cnstrainttype
       end if
       allocate(fcvect_work(natm,4)); fcvect_work = 0.d0
       fcvect_work(1:nfcatm,1:4) = fcvect(1:nfcatm,1:4)
       call m_IS_init_cnstrnt(natm,fcvect_work) ! -> sgmc
       deallocate(fcvect_work)
    end if

    ! --- Structure_evolution ---
    if(imdalg == T_CONTROL .or. imdalg == VERLET .or. imdalg == VELOCITY_SCALING .or. &
    &  imdalg == PT_CONTROL .or. imdalg == P_CONTROL) then
       mobility_cell(:,:) = ON
       iret = f_selectTop()
       if( f_selectBlock( tag_structure_evolution) == 0) then
          if(ipriinputfile >= 1 .and. printable) write(nfout,'(" !* tag_structure_evolution is found")')
          ! --- Pressure control ---
          if( f_selectBlock( tag_pressure_control) == 0 )then
             if(ipriinputfile >= 1 .and. printable) write(nfout,'(" !* tag_pressure_control is found")')
             if(f_getRealValue(tag_m_baro,dret,"") == 0) m_baro = dret
             if(f_getRealValue(tag_pressure,dret,"hartree/bohr3") == 0) target_pressure = dret
             if(f_getIntValue(tag_control_pressure,iret) == 0) control_pressure = iret
             if(f_getIntValue(tag_m11,iret) == 0 ) mobility_cell(1,1) = iret
             if(f_getIntValue(tag_m22,iret) == 0 ) mobility_cell(2,2) = iret
             if(f_getIntValue(tag_m33,iret) == 0 ) mobility_cell(3,3) = iret
             if(f_getIntValue(tag_m12,iret) == 0 ) then
                mobility_cell(1,2) = iret
                mobility_cell(2,1) = iret
             endif
             if(f_getIntValue(tag_m13,iret) == 0 ) then
                mobility_cell(1,3) = iret
                mobility_cell(3,1) = iret
             endif
             if(f_getIntValue(tag_m23,iret) == 0 ) then
                mobility_cell(2,3) = iret
                mobility_cell(3,2) = iret
             endif
             iret = f_selectParentBlock()
          endif
          ! --- Temperature_Control ---
          if( f_selectBlock( tag_temperature_control) == 0) then
             if(ipriinputfile >= 1 .and. printable) write(nfout,'(" !* tag_temperature_control is found")')
             ! --- Method ---
             if( f_getStringValue( tag_method, rstr, LOWER) == 0) then
                call strncmp0(trim(rstr), tag_nose_hoover,tf)
                if(.not.tf) call strncmp0(trim(rstr), tag_hoover,tf)
                if(tf) then
                   t_ctrl_method = NOSE_HOOVER
                   goto 1001
                end if
                call strncmp0(trim(rstr),tag_nose, tf)
                if(tf) then
                   t_ctrl_method = NOSE
                   goto 1001
                end if
                call strncmp0(trim(rstr),tag_velocity_scaling, tf)
                if(tf) then
                   t_ctrl_method = VELOCITY_SCALING
                   goto 1001
                end if
1001            continue
             else
                if(ipriinputfile >= 1 .and. printable) write(nfout,'(" !* tag_method is not found")')
                t_ctrl_method = NOSE_HOOVER
             end if
             ! --- count total number of thermostat ---
             ! --- num_thermostat ---

             number_is_given = f_getIntValue( tag_num_thermostat, iret) == 0
             if(.not.number_is_given) &
                  & number_is_given = f_getIntValue( tag_num_thermo,iret) == 0
             if(number_is_given)  nrsv = iret

             if(t_ctrl_method == NOSE) nrsv = 1
             if(printable) write(nfout,'(" !** t_ctrl_method = ",i5)') t_ctrl_method
             if(printable) write(nfout,'(" !** num_Tresrvoir = ",i5)') nrsv

             if(f_getIntValue(tag_num_chain,iret) == 0) nchain = iret
             if(printable) write(nfout,'(" !** num_chain = ",i5)') nchain

             if (f_getIntValue(tag_sw_temperature_profile,iret) == 0) then
                sw_temperature_profile = iret
             endif

             if(sw_temperature_profile == OFF) then
             tdamp = 50.d0*dtio
             if(f_getRealValue(tag_tdamp,dret,'')==0) tdamp = dret
             prealloc = .true.
             call set_thermostat(prealloc,nrsv,icounted)
             if(ipriinputfile >= 1 .and. printable) &
                  & write(nfout,'(" !** icounted = ",i6," at set_thermostat <<m_IS_rd_n>>")') icounted
             if(.not.number_is_given) then
                if(printable) write(nfout,'(" !** number_is_given is .false.")')
                nrsv = icounted
             else
                if(printable) write(nfout,'(" !** number_is_given is .true.")')
             end if
             if(icounted < 0) nrsv = 1
             if(ipriinputfile >= 1 .and. printable) write(nfout,'(" !** nrsv = ",i6," <<m_IS_rd_n>>")') nrsv

             ! --- allocation and initialization of qmass, tkb, etc.
             call T_control_alloc(nrsv)
             if(ipriinputfile >= 1 .and. printable) write(nfout,'(" !** number of T-reserver = ",i6)') nrsv
             ! --- substitution for qmass(es) and temperature(s) of the reserver(s)
             prealloc = .false.
             call set_thermostat(prealloc,nrsv,icounted) ! -> qmass, tkb
             if(printable) write(nfout,'(" !** icounted = ",i6," <<set_thermostat>>")') icounted
             if(icounted < 0) then
                call set_qmass_and_temp(1)
             end if
             if(ipriinputfile >= 1 .and. printable) then
                do i = 1, nrsv
                   write(nfout,'(" !** reserver_id = ",i3," qmass = ",f20.6," tkb = ",f12.6)') i, qmass(i), tkb(i)
                end do
             end if
! new way of defining thermostats
             else
             nrsv = get_nthermo(nfout)
             call alloc_temperature_profile(nrsv)
             call set_temperature_profile_no(nfout,nrsv,temperature_profile)
             call set_temperature_profile(nfout,nrsv,temperature_profile)
             call set_new_temperature(nfout,nrsv,temperature_profile)
             endif

! ==== KT_add == 2014/06/10
             if ( f_getIntValue(tag_sw_change_temp_bystep,iret) == 0 ) then
                 sw_change_temperature_by_step = iret
                 write(nfout,*) '*** sw_change_temperature_by_step is ', iret
             endif
             if ( sw_change_temperature_by_step == ON ) then
                Do i=1, nrsv
                   write(nfout,'(A,i8,A,i8,A,F8.1,A,F8.1)') &
                        &           '!** MD Step (start): ', &
                        &              mdstep_at_start_thermostat(i), &
                        &           ', (end): ', &
                        &               mdstep_at_end_thermostat(i), &
                        &           ", Temp (start): ", &
                        &              temp_at_start_thermostat(i), &
                        &           ", (end): ", &
                        &              temp_at_end_thermostat(i)
                End Do
             endif
! ============== 2014/06/10

             ! set initial velocity or not --> by J. Koga 2005
             if ( f_getIntValue(tag_set_initial_velocity,iret) == 0 ) then
                 set_initial_velocity = iret
             endif
             if ( f_getIntValue(tag_sw_read_velocities,iret) == 0 ) then
                 sw_read_velocities = iret
             endif
             if ( f_getIntValue(tag_sw_shift_velocities,iret) == 0 ) then
                 sw_shift_velocities = iret
             endif 
             if( f_getRealValue(tag_initial_temperature,dret,"") == 0 ) then
                tk_initial = dret * CONST_kB
                if(ipriinputfile >= 1 .and. printable) then
                   write(nfout,'(" !** initial_temperature = ",f18.10)') dret
                   write(nfout,'(" !** tk_initial          = ",f18.10)') tk_initial
                end if
             end if
             
             if ( m_CtrlP_what_is_mdalg() == T_CONTROL .and. set_initial_velocity == ON ) then
                call set_initial_velocities(1)
             else if( m_CtrlP_what_is_mdalg() == VELOCITY_SCALING .and. set_initial_velocity == ON ) then
                call set_initial_velocities(1)
             else if( m_CtrlP_what_is_mdalg() == PT_CONTROL .and. set_initial_velocity == ON ) then
                call set_initial_velocities(1)
             else if( m_CtrlP_what_is_mdalg() == P_CONTROL .and. set_initial_velocity == ON ) then
                call set_initial_velocities(1)
             else if( m_CtrlP_what_is_mdalg() == VERLET .and. set_initial_velocity == ON ) then
                call set_initial_velocities(2)
             endif
             ! <--

             iret = f_selectParentBlock()
          end if
          iret = f_selectParentBlock()
       end if
    end if

  contains
    subroutine set_endpoint_images(rstr)
      character(*),intent(in) :: rstr
      call strncmp0(trim(rstr),tag_no,tf)
      if(tf) then
         endpoint_images = NO
         goto 1001
      end if
      call strncmp0(trim(rstr),tag_nothing,tf)
      if(tf) then
         endpoint_images = NO
         goto 1001
      end if
      call strncmp0(trim(rstr),tag_file,tf)
      if(tf) then
         endpoint_images = FILE
         goto 1001
      end if
      call strncmp0(trim(rstr),tag_directin,tf)
      if(tf) then
         endpoint_images = DIRECTIN
         goto 1001
      end if
1001  continue
    end subroutine set_endpoint_images

    subroutine set_fixed_planes(prealloc,constraint_type, num,countedplanes,countedatoms)
      ! This subroutine was coded by T. Yamasaki (FUJITSU LABORATORIES LTD.), 1st Aug. 2003
      logical, intent(in) ::  prealloc
      integer, intent(in) ::  constraint_type, num
      integer, intent(out) :: countedplanes
      integer, intent(out),optional :: countedatoms

      integer :: i, no, iret, j, icatm
      integer :: f_selectFirstTableLine,f_selectNextTableLine,f_getRealValue,f_getIntValue
      logical :: tf
      real(kind=dP) :: dret, normalvx,normalvy,normalvz,dlt

      character(len=FMAXUNITLEN) :: unit_f

      unit_f = 'bohr'

      icatm = 0
      i = 1
      do while(.true.)
         if(i == 1) then
            if( f_selectFirstTableLine() /= 0 ) then
               exit
            end if
         else
            if( f_selectNextTableLine() /= 0 ) then
               exit
            end if
         end if
         if(prealloc) then
            if(f_getIntValue(tag_atom1,iret) == 0) then
               icatm = icatm + 1
               if(f_getIntValue(tag_atom2,iret) == 0) then
                  icatm = icatm + 1
                  if(f_getIntValue(tag_atom3,iret) == 0) then
                     icatm = icatm + 1
                     if(f_getIntValue(tag_atom4,iret) == 0) then
                        icatm = icatm + 1
                     end if
                  end if
               end if
            end if
         else
            if(printable) write(nfout,'(" !** i = ",i5,"  num = ",i5)') i, num
            if(i > num) exit
            no = i
            if(f_getIntValue(tag_no, iret) == 0) then
               no = iret
            else if(f_getIntValue(tag_id, iret) == 0) then
               no = iret
            end if
            if(no <= num) then
               normalvx = 0.d0; normalvy = 0.d0; normalvz = 0.d0; dlt = 0.d0
               tf = f_getRealValue(tag_nx,dret,unit_f) == 0
               if(.not.tf) tf = f_getRealValue(tag_vx,dret,unit_f) == 0
               if(tf) normalvx = dret

               tf = f_getRealValue(tag_ny,dret,unit_f) == 0
               if(.not.tf) tf = f_getRealValue(tag_vy,dret,unit_f) == 0
               if(tf) normalvy = dret

               tf = f_getRealValue(tag_nz,dret,unit_f) == 0
               if(.not.tf) tf = f_getRealValue(tag_vz,dret,unit_f) == 0
               if(tf) normalvz = dret

               ! -- normalization of a normal vector --
               dret = normalvx**2 + normalvy**2 + normalvz**2
               if(dret < SmallestPositiveNumber*1.d5) then
                  normalvx = 1.d0; normalvy = 0.d0; normalvz = 0.d0
               else
                  dret = dsqrt(dret)
                  normalvx = normalvx/dret
                  normalvy = normalvy/dret
                  normalvz = normalvz/dret
               end if

               if( f_getRealValue(tag_delta,dret,unit_f) == 0)  dlt = dret

               tf = f_getIntValue(tag_atom1,iret) == 0
               do j = 1, 4
                  if(tf) then
                     icatm = icatm + 1
                     ia_cnst(icatm) = iret
                     fcvect(icatm,1) = normalvx
                     fcvect(icatm,2) = normalvy
                     fcvect(icatm,3) = normalvz
                     fcvect(icatm,4) = dlt
                     ipfixedplane(icatm) = i
                     imdtyp(iret) = constraint_type
                     imdtypxyz(iret,:) = constraint_type
                     if(j == 1) tf = f_getIntValue(tag_atom2,iret) == 0
                     if(j == 2) tf = f_getIntValue(tag_atom3,iret) == 0
                     if(j == 3) tf = f_getIntValue(tag_atom4,iret) == 0
                     if(printable) write(nfout,'(" !** j = ",i5," normalvectors = ",3f8.4," dlt = ",f8.4)') &
                          & j, normalvx,normalvy,normalvz,dlt
                  else
                     exit
                  end if
               end do
            end if
         end if
         i = i+1
      end do
      countedplanes = i - 1
      if(prealloc) countedatoms = icatm
    end subroutine set_fixed_planes

    subroutine set_cog_fix(countedatoms)
      ! This subroutine was coded by T. Yamasaki (FUJITSU LABORATORIES LTD.), 2nd Aug. 2003
      integer, intent(out) :: countedatoms

      integer :: i, no, iret, j
      integer :: f_selectFirstTableLine,f_selectNextTableLine,f_getIntValue
      logical :: tf

!!$      character(len=FMAXUNITLEN) :: unit_f
!!$      unit_f = 'bohr'

      i = 0
      countedatoms = 0
      if( f_selectBlock(tag_thermostat) == 0) then
         i = 1
         do while(.true.)
            if(i == 1) then
               if( f_selectFirstTableLine() /= 0 ) then
                  exit
               end if
            else
               if( f_selectNextTableLine() /= 0 ) then
                  exit
               end if
            end if
!!$            if(i > num) exit
            no = i
            if(f_getIntValue(tag_no, iret) == 0) then
               no = iret
            else if(f_getIntValue(tag_id, iret) == 0) then
               no = iret
            end if
            if(no <= natm) then
               tf = f_getIntValue(tag_atom1,iret) == 0
               do j = 1, 4
                  if(tf) then
                     countedatoms = countedatoms + 1
!!$                     ia_cnst(countedatoms) = iret
                     imdtyp(iret) = COG_FIX
                     imdtypxyz(iret,:) = COG_FIX
                     if(j == 1) tf = f_getIntValue(tag_atom2,iret) == 0
                     if(j == 2) tf = f_getIntValue(tag_atom3,iret) == 0
                     if(j == 3) tf = f_getIntValue(tag_atom4,iret) == 0
                  else
                     exit
                  end if
               end do
            end if
            i = i+1
         end do
         iret = f_selectParentBlock()
      end if
    end subroutine set_cog_fix

    function get_nthermo(nfout) result(res)
      integer, intent(in) :: nfout
      integer :: f_selectFirstTableLine, f_selectNextTableLine
      integer :: i,j,ithermo,iret,iiret
      integer, allocatable, dimension(:) :: thermo_ids
      integer :: max_nthermo
      logical :: found 
      integer :: res
      max_nthermo = natm
      allocate(thermo_ids(max_nthermo));thermo_ids = 0
      if( f_selectBlock(tag_thermostat) == 0) then
         i = 1
         ithermo = 0
         do while(.true.)
            if(i == 1) then
               if( f_selectFirstTableLine() /= 0 ) then
                  exit
               end if
            else
               if( f_selectNextTableLine() /= 0 ) then
                  exit
               end if
            end if
            i = i+1
            iiret = f_getIntValue(tag_no,iret)
            if(iiret /= 0) iiret = f_getIntValue(tag_id,iret)
            if(iiret /= 0) iret = 1
            found = .false.
            do j=1,max_nthermo
                if(thermo_ids(j) == iret)then
                call flush(0)
                   found = .true.
                   exit
                endif
            enddo
            if(.not. found) then
                if(ithermo>max_nthermo)then
                   write(nfout,'(a,i5)') ' !** exceeded maximum number of thermostats : ',max_nthermo
                   exit
                endif
                ithermo = ithermo+1
                thermo_ids(ithermo) = iret
            endif
         end do
         iiret = f_selectParentBlock()
      end if
      res = ithermo
      deallocate(thermo_ids)
    end function get_nthermo

    subroutine set_temperature_profile_no(nfout,nrsv,temperature_profile)
      integer, intent(in) :: nfout,nrsv
      type(temperature_profile_t), intent(inout), dimension(nrsv) :: temperature_profile
      integer :: f_selectFirstTableLine, f_selectNextTableLine
      integer :: i,j,ithermo,iret,iiret
      logical :: found 
      integer, parameter :: max_nthermo = 100
      if( f_selectBlock(tag_thermostat) == 0) then
         i = 1
         ithermo = 0
         do while(.true.)
            if(i == 1) then
               if( f_selectFirstTableLine() /= 0 ) then
                  exit
               end if
            else
               if( f_selectNextTableLine() /= 0 ) then
                  exit
               end if
            end if
            i = i+1
            iiret = f_getIntValue(tag_no,iret)
            if(iiret /= 0) iiret = f_getIntValue(tag_id,iret)
            if(iiret /= 0) iiret = f_getIntValue(tag_thermo_group,iret)
            if(iiret /= 0) iret = 1
            found = .false.
            do j=1,nrsv
                if(temperature_profile(j)%no == iret)then
                   found = .true.
                   exit
                endif
            enddo
            if(.not. found) then
               ithermo = ithermo+1
               temperature_profile(ithermo)%no = iret
            endif
         end do
         iiret = f_selectParentBlock()
      end if
    end subroutine set_temperature_profile_no

    subroutine set_temperature_profile(nfout,nrsv,temperature_profile)
      integer, intent(in) :: nfout,nrsv
      type(temperature_profile_t), intent(inout), dimension(nrsv) :: temperature_profile
      integer :: i,j,k,iiret,iret
      integer :: nprof,currprof
      real(kind=DP) :: dret
      integer :: f_selectFirstTableLine,f_selectNextTableLine
     
      ! first count the number of profiles for each thermostat
      if( f_selectBlock(tag_thermostat) == 0) then
         i = 1
         do while(.true.)
            if(i == 1) then
               if( f_selectFirstTableLine() /= 0 ) then
                  exit
               end if
            else
               if( f_selectNextTableLine() /= 0 ) then
                  exit
               end if
            end if
            i = i+1
            iiret = f_getIntValue(tag_no,iret)
            if(iiret /= 0) iiret = f_getIntValue(tag_id,iret)
            if(iiret /= 0) iret = 1
            do j=1,nrsv 
                if(temperature_profile(j)%no == iret)then
                   temperature_profile(j)%nprof = temperature_profile(j)%nprof + 1
                endif
            enddo
         end do
         iiret = f_selectParentBlock()
      end if

      ! allocate
      do j=1,nrsv
         nprof = temperature_profile(j)%nprof
         allocate(temperature_profile(j)%tempi(nprof));temperature_profile(j)%tempi = -1.d0
         allocate(temperature_profile(j)%tempf(nprof));temperature_profile(j)%tempf = -1.d0
         allocate(temperature_profile(j)%till_n(nprof));temperature_profile(j)%till_n = -1
         allocate(temperature_profile(j)%qmass(nprof));temperature_profile(j)%qmass = -1.d0
         allocate(temperature_profile(j)%tdamp(nprof));temperature_profile(j)%tdamp = 50.d0*dtio
         temperature_profile(j)%currprof = 0
      enddo
     
      if( f_selectBlock(tag_thermostat) == 0) then
         i = 1
         do while(.true.)
            if(i == 1) then
               if( f_selectFirstTableLine() /= 0 ) then
                  exit
               end if
            else
               if( f_selectNextTableLine() /= 0 ) then
                  exit
               end if
            end if
            i = i+1
            iiret = f_getIntValue(tag_no,iret)
            if(iiret /= 0) iiret = f_getIntValue(tag_id,iret)
            if(iiret /= 0) iret = 1
            do j=1,nrsv 
               if(temperature_profile(j)%no == iret)then
                  temperature_profile(j)%currprof = temperature_profile(j)%currprof+1
                  currprof = temperature_profile(j)%currprof
                  if(f_getRealValue(tag_temp,dret,'K') == 0) then
                     temperature_profile(j)%tempi(currprof) = dret * CONST_kB
                     temperature_profile(j)%tempf(currprof) = dret * CONST_kB
                  endif
                  if(f_getRealValue(tag_tempi,dret,'K') == 0) then
                      temperature_profile(j)%tempi(currprof) = dret * CONST_kB
                      temperature_profile(j)%tempf(currprof) = dret * CONST_kB
                  endif
                  if(f_getRealValue(tag_tempf,dret,'K') == 0) &
                  &  temperature_profile(j)%tempf(currprof) = dret * CONST_kB
                  if(f_getIntValue(tag_till_n,iret) == 0) &
                  &  temperature_profile(j)%till_n(currprof) = iret
                  if(f_getRealValue(tag_tdamp,dret,'au_time') == 0)then
                      temperature_profile(j)%tdamp(currprof) = dret
                  endif
                  if(f_getRealValue(tag_qmass,dret,'au_mass') == 0)then
                     temperature_profile(j)%qmass(currprof) = dret
                  endif
               endif
            enddo
         end do
         iiret = f_selectParentBlock()
         if(printable)then
             write(nfout,'(a,i4)')    ' !** number of thermostats ',nrsv
             do j=1,nrsv
                write(nfout,'(a,i4)') ' !** status of thermostat no. ',j
                write(nfout,'(a,i4)') ' !** number of profiles : ',temperature_profile(j)%nprof
                write(nfout,'(a,i8)') ' !** number of atoms    : ',temperature_profile(j)%natm
                do k=1,temperature_profile(j)%nprof
                   write(nfout,'(a,i4)') ' !** profile no. ',k
                   write(nfout,'(a,2f20.3,i8)') ' !** tempi, tempf, till_n : '    &
                   &                           , temperature_profile(j)%tempi(k)/CONST_kB &
                   &                           , temperature_profile(j)%tempf(k)/CONST_kB &
                   &                           , temperature_profile(j)%till_n(k)
                   write(nfout,'(a,2f20.3)') ' !** qmass, tdamp: ', temperature_profile(j)%qmass(k) &
                   &                           , temperature_profile(j)%tdamp(k)
                   if(temperature_profile(j)%tempi(k) <= 0)then
                      stop 'initial temperature must be positive '
                   endif
                   if(temperature_profile(j)%tempf(k) <= 0)then
                      stop 'final temperature must be positive '
                   endif
                enddo
             enddo
         endif
      end if
    end subroutine set_temperature_profile
        
    subroutine set_thermostat(prealloc, num, icounted)
      ! This subroutine was coded by T. Yamasaki (FUJITSU LABORATORIES LTD.), 1st Aug. 2003
      logical, intent(in) ::  prealloc
      integer, intent(in) ::  num
      integer, intent(out) :: icounted

      integer :: i, no, iret

      integer :: f_selectFirstTableLine, f_selectNextTableLine
      i = 0
      if( f_selectBlock(tag_thermostat) == 0) then
         i = 1
         do while(.true.)
            if(i == 1) then
               if( f_selectFirstTableLine() /= 0 ) then
                  exit
               end if
            else
               if( f_selectNextTableLine() /= 0 ) then
                  exit
               end if
            end if
            if(.not.prealloc) then
               if(i > num) exit
               no = i
               if(f_getIntValue(tag_no, iret) == 0) then
                  no = iret
               else if(f_getIntValue(tag_id, iret) == 0) then
                  no = iret
               end if
               if(no <= num) then
                  call set_qmass_and_temp(no)
               end if
            end if
            i = i+1
         end do
         iret = f_selectParentBlock()
      end if
      icounted = i - 1
    end subroutine set_thermostat

    subroutine set_qmass_and_temp(no)
      ! This subroutine was coded by T. Yamasaki (FUJITSU LABORATORIES LTD.), 29th Jul. 2003
      integer, intent(in) :: no

      real(kind=DP) :: dret
      integer :: f_getRealValue

      character(len=FMAXUNITLEN) :: unit_f
      real(kind=DP) :: tdam
      integer :: i,ir,j
      logical :: temp_is_set

      ! --- temperature ---
      temp_is_set = .false.

      unit_f = 'K'
      number_is_given = f_getRealValue(tag_temperature,dret,unit_f) == 0
      if(.not.number_is_given) number_is_given = f_getRealValue(tag_temp,dret,unit_f) == 0
      if(.not.number_is_given) number_is_given = f_getRealValue(tag_T,dret,unit_f) == 0
      if(number_is_given) then
         tkb(no) = dret * CONST_kB
         temp_is_set = .true.
      endif

      ! --- qmass ---
      unit_f = 'au_mass'
      number_is_given = f_getRealValue(tag_weight_thermostat,dret,unit_f) == 0
      if(.not.number_is_given) number_is_given = f_getRealValue(tag_weight_thermo,dret,unit_f) == 0
      if(.not.number_is_given) number_is_given = f_getRealValue(tag_weight,dret,unit_f) == 0
      if(.not.number_is_given) number_is_given = f_getRealValue(tag_qmass,dret,unit_f) == 0
      if(number_is_given) then
         qmass(no) = dret
      else
         tdam = tdamp
         if(f_getRealValue(tag_tdamp,dret,'au_time')==0) tdam = dret
         qmass(no) = (2.d0*3.d0*natm_per_thermo(no)*(tdam/PAI2)**2) * tkb(no)
         if(printable) write(nfout,'(a,i3,a,f20.5)') ' !** resolved Qmass for thermostat ',no,' : ',qmass(no)
      endif
      if(nchain>1)then
         qmass_c(1:nrsv,1) = qmass(1:nrsv)
         do i=2,nchain
            qmass_c(1:nrsv,i) = qfactor * qmass(1:nrsv)
         enddo
      endif
      if(printable .and. iprimd>=2) then
        if(nchain==1) then
          do i=1,nrsv
            write(nfout,'(a,i5,a,f20.5)') ' !** qmass for thermostat ',i,':',qmass(i)
          enddo
        else
          do j=1,nchain 
            do i=1,nrsv
              write(nfout,'(a,i5,a,i5,a,f20.5)') ' !** qmass for chain ',j,' thermostat ',i,':',qmass_c(i,j)
            enddo
          enddo
        endif
      endif

! ==== KT_add === 2014/06/10
      if (f_getIntValue(tag_duration,iret)==0) then
         if ( no == 1 ) then
            mdstep_at_start_thermostat(no) = 1
            mdstep_at_end_thermostat(no) = iret
         else
            mdstep_at_start_thermostat(no) = mdstep_at_end_thermostat(no-1) +1
            mdstep_at_end_thermostat(no)   = mdstep_at_end_thermostat(no-1) +iret
         endif
      endif

      temp_at_start_thermostat(no) = tkb(no) /const_kB    ! default
      temp_at_end_thermostat(no) = tkb(no) /const_kB

      if ( temp_is_set ) return

      if ( f_getRealValue(tag_temp_s,dret,unit_f) == 0 ) then
         temp_at_start_thermostat(no) = dret
         tkb(no) = dret * CONST_kB
      endif
      if ( f_getRealValue(tag_temp_e,dret,unit_f) == 0 ) then
         temp_at_end_thermostat(no) = dret
         temp_is_set = .true.
      endif
! =============== 2014/06/10
      if ( .not. temp_is_set ) then
         if (printable) write(nfout,'(a)') '!** temperature undefined'
         stop
      endif

    end subroutine set_qmass_and_temp

    subroutine specify_ityp()
      integer :: i, k, icount
      icount = 0
      do i = 1, natm
         type: do k = 1, ntyp
            if(trim(species_work(i)) == trim(speciesname(k))) then
               icount = icount + 1
               ityp(i) = k
               exit type
            end if
         end do type
      end do
      if(ipriinputfile >= 2 .and. printable) write(nfout,'(" !** specified atom number = ",i6)') icount
      if(icount < natm) then
         stop ' element names in the atom_list and in the element_list are inconsistent <<m_IS_rd_n.specify_ityp>>'
      end if

    end subroutine specify_ityp

    subroutine specify_ityp_vdw()
      integer :: i, k, icount

      icount = 0
      do i = 1, natm
         type: do k = 1, ntyp_vdw
            if(trim(species_vdw_work(i)) == trim(speciesname_vdw(k))) then
               icount = icount + 1
               ityp_vdw(i) = k
               exit type
            end if
         end do type
      end do
      if(ipriinputfile >= 2 .and. printable) write(nfout,'(" !** specified atom number = ",i6)') icount
      if(icount < natm) then
         stop ' vdW-type names in the atom_list and in the vdw_list are inconsistent <<m_IS_rd_n.specify_ityp_vdw>>'
      end if

    end subroutine specify_ityp_vdw

    subroutine wd_atom_list()
      integer :: i
      if(ipriinputfile >= 3) then
         write(nfout,'(" !** === Atomic coordinates expressed in the internal system ===")')
         write(nfout,'(" !** id,  rx,    ry,    rz,    weight,  imdtyp, ityp,  species")')
         do i = 1, natm
            write(nfout,210) i,pos(i,1),pos(i,2),pos(i,3),iwei(i),imdtyp(i),ityp(i),species_work(i)
         end do
210      format(' !** ',i5,3f18.10,i3,i6,i3,3x,a4)
         write(nfout,'(" !** === Atomic coordinates expressed in the cartesian system ===")')
         write(nfout,'(" !** id,  rx,    ry,    rz,    weight,  imdtyp, ityp,  species")')
         do i = 1, natm
            write(nfout,210) i,cps(i,1),cps(i,2),cps(i,3),iwei(i),imdtyp(i),ityp(i),species_work(i)
         end do
      else
         write(nfout,'(" !** === Atomic coordinates ==")')
         write(nfout,'(" !**   id  ( coordinates_in_Intrnal_sys  ) (  coordinates_in_Cartsian_system  ) weight    ityp")')
         write(nfout,'(" !**       (   rx         ry         rz  ) (    rx          ry          rz    )      imdtyp    species")')
!!$                             -----                                 ------------------------------------   ------   --- 
!!$                             123451234567890112345678901123456789011234567890121234567890121234567890121231234561231231234
         do i = 1, natm
            write(nfout,211) i, pos(i,1:3), cps(i,1:3), iwei(i), imdtyp(i), ityp(i), species_work(i)
         end do
211      format(' !** ',i5,3f11.6,3f12.4,i3,i6,i3,3x,a4)
      end if

      do i = 1, ntyp
         write(nfout,'(" !** i = ",i5," element_name = ",a4)') i, speciesname(i)
      end do

    end subroutine wd_atom_list

    subroutine count_species()
      integer :: i, k, kcount
      kcount = 0

      species_indp(1) = species_work(1)
      kcount = kcount + 1
      do i = 2, natm
         Registered :do k = 1, kcount
            if(species_indp(k) == species_work(i)) goto 1000
         end do Registered
         kcount = kcount + 1
         species_indp(kcount) = species_work(i)
1000     continue
      end do
      ntyp = kcount
      if(ipriinputfile >= 2 .and. printable) write(nfout,'(" !** ntyp = ",i6, " << count_species>>")') ntyp
    end subroutine count_species

    subroutine count_species_vdw()
      integer :: i, k, kcount
      kcount = 0

! === Apply modifications for vdW function. by tkato 2012/06/14 ================
!     if(sw_pair_vdw==OFF) then
      if(sw_vdw_correction==OFF .or. vdw_method == VDW_DFTD3) then
! ==============================================================================
         ntyp_vdw = 0
         return
      end if

      species_vdw_indp(1) = species_vdw_work(1)
      kcount = kcount + 1
      do i = 2, natm
         Registered :do k = 1, kcount
            if(species_vdw_indp(k) == species_vdw_work(i)) goto 1001
         end do Registered
         kcount = kcount + 1
         species_vdw_indp(kcount) = species_vdw_work(i)
1001     continue
      end do
      ntyp_vdw = kcount
      if(ipriinputfile >= 2 .and. printable) write(nfout,'(" !** ntyp_vdw = ",i6, " << count_species>>")') ntyp_vdw
    end subroutine count_species_vdw
      
    subroutine set_input_coordinate_system(rstr)
      character(*),intent(in) :: rstr
      call strncmp0(trim(rstr),tag_cartesian,tf)
      if(.not.tf) call strncmp0(trim(rstr),tag_XYZ,tf)
      if(tf) then
         input_coordinate_system = CARTS
         goto 1001
      end if
      call strncmp0(trim(rstr),tag_pucv,tf)
      if(tf) then
         input_coordinate_system = PUCV
         goto 1001
      end if
      call strncmp0(trim(rstr),tag_internal,tf)
      if(tf) then
         input_coordinate_system = PUCV
         goto 1001
      end if
      call strncmp0(trim(rstr),tag_relative,tf)
      if(tf) then
         input_coordinate_system = PUCV
         goto 1001
      end if
      if(ipriinputfile >= 0 .and. printable) &
           & write(nfout,'(" !* input_coordinate_system is not defined properly in the input file!")')
      if(ipriinputfile >= 0 .and. printable) &
           & write(nfout,'(" !* So default value of PUCV is assinged")')
1001  continue
    end subroutine set_input_coordinate_system

    subroutine set_howtogive_coordinates(rstr)
      character(*),intent(in) :: rstr
      call strncmp0(trim(rstr),tag_directin,tf)
      if(tf) then
         howtogive_coordinates = DIRECTIN
         goto 1001
      end if
      call strncmp0(trim(rstr),tag_from_endpoint_images,tf)
      if(.not.tf) call strncmp0(trim(rstr),tag_from_endpoints,tf)
      if(tf) then
         howtogive_coordinates = FROM_ENDPOINTS
         goto 1001
      end if
1001  continue
    end subroutine set_howtogive_coordinates

    subroutine set_displacement()
      character(len=FMAXUNITLEN) :: unit_f
      integer :: f_getIntValue, f_getRealValue
      integer :: iret
      real(kind=DP) :: dret

      unit_f = ''
      if(input_coordinate_system == CARTS) unit_f = 'bohr'

      if(f_getIntValue(tag_sw_displace_atom,iret)==0) sw_displace_atom = iret
      displaced_atom = 0         ! defalut value
      displacement(1:3) = 0.d0   ! defalut values

! === KT_add === 2015/03/14
      if ( input_coordinate_system == CARTS ) sw_displacement_in_carts = ON
      if ( f_getIntValue( tag_sw_displacement_in_carts, iret ) == 0 ) then
         sw_displacement_in_carts = iret
      endif
      if ( sw_displacement_in_carts == ON ) then
         unit_f = 'bohr'
      else
         unit_f = ''
      endif
      write(nfout,*) '!** sw_displacement_in_carts = ', sw_displacement_in_carts
! ============= 2015/03/14

      if(sw_displace_atom == ON) then
         if(f_getIntValue(tag_displaced_atom,iret)==0) displaced_atom = iret
         if(f_getRealValue(tag_ux,dret,unit_f) == 0) displacement(1) = dret
         if(f_getRealValue(tag_uy,dret,unit_f) == 0) displacement(2) = dret
         if(f_getRealValue(tag_uz,dret,unit_f) == 0) displacement(3) = dret
      end if

    end subroutine set_displacement

    subroutine set_displacement2()
      integer :: i, istat
      real(kind=DP) :: cvec(3), rltv_t(3,3)

      if(displaced_atom < 1 .or. displaced_atom > natm) then
         if(printable) &
              & write(nfout,'("Because ",i4,"-th atom does not exist, no atom have been displaced.")') displaced_atom
         displaced_atom = 0
         displacement(1:3) = 0.d0
      else
#if 0
         pos(displaced_atom,1:3) =  pos(displaced_atom,1:3) + displacement(1:3)
         if(printable) write(6,'(i4,"-th atom was displaced; the displacement =",3(1x,f10.5))') &
              & displaced_atom, displacement(1:3)
         if(input_coordinate_system == PUCV) then
            do i=1,3
               work(1,i) = sum(p2bmat(1:3,i)*displacement(1:3))
            end do
            displacement(1:3) = work(1,1:3)
            do i=1,3
               work(1,i) = sum(altv(i,1:3)*displacement(1:3))
            end do
            displacement(1:3) = work(1,1:3) ! the displacement vector is expressed in the catesian system
         end if
#else
         if(printable) then
            write(6,'(i4,"-th atom was displaced; the displacement =",3(1x,f10.5))') &
                 &  displaced_atom, displacement(1:3)
         endif
         if (input_coordinate_system == PUCV ) then
            if ( sw_displacement_in_carts == OFF ) then
               pos(displaced_atom,1:3) = pos(displaced_atom,1:3) +displacement(1:3)
            else
               rltv_t = transpose(rltv) /PAI2
               call change_of_coordinate_system(rltv_t,displacement,1,1,cvec)
               do i=1,3
                  work(1,i) = sum(b2pmat(1:3,i)*cvec(1:3))
               end do
               cvec(1:3) = work(1,1:3)
               pos(displaced_atom,1:3) = pos(displaced_atom,1:3) +cvec(1:3)
            endif

         else if ( input_coordinate_system == CARTS ) then
            if ( sw_displacement_in_carts == ON ) then
               pos(displaced_atom,1:3) = pos(displaced_atom,1:3) +displacement(1:3)
            else
               do i=1,3
                  work(1,i) = sum(p2bmat(1:3,i)*displacement(1:3))
               end do
               displacement(1:3) = work(1,1:3)
               do i=1,3
                  work(1,i) = sum(altv(i,1:3)*displacement(1:3))
               end do
               displacement(1:3) = work(1,1:3)
                      ! the displacement vector is expressed in the catesian system
               pos(displaced_atom,1:3) = pos(displaced_atom,1:3) + displacement(1:3)
            end if
         endif
#endif
      end if

    end subroutine set_displacement2

    subroutine set_vibrational_mode()
      character(len=FMAXUNITLEN) :: unit_f = 'bohr'
      integer :: f_getIntValue, f_getRealValue
      integer :: iret
      real(kind=DP) :: dret

      if(f_getIntValue(tag_sw_vibrational_mode,iret)==0) sw_vibrational_mode = iret
      if(sw_vibrational_mode == ON) then
         if(f_getIntValue(tag_mode_index,iret)==0) mode_index = iret
         if(f_getRealValue(tag_normal_coordinate,dret,unit_f) == 0) normal_coordinate = dret
         if(f_getIntValue(tag_with_mode_effchg,iret)==0) with_mode_effchg = iret
      end if

      if(printable) then
         write(nfout,'(" !** sw_vibrational_mode   = ",i1)') sw_vibrational_mode
         write(nfout,'(" !** mode_index            = ",i4)') mode_index
         write(nfout,'(" !** normal_coordinate (Q) = ",f10.5)') normal_coordinate
         write(nfout,'(" !** with_mode_effchg      = ",i1)') with_mode_effchg
      end if

    end subroutine set_vibrational_mode

    subroutine set_vibrational_mode2()
      real(kind=DP) :: dret
      integer :: i, j

      call m_Files_open_nfmode()
      allocate(xi_mode(natm,3))
      call read_mode_vector(nfmode,natm,xi_mode)
      if(input_coordinate_system == PUCV) then
         do i=1,natm
            work(i,1:3) = (rltv(1,1:3)*xi_mode(i,1) &
                 & + rltv(2,1:3)*xi_mode(i,2) &
                 & + rltv(3,1:3)*xi_mode(i,3) )/PAI2
         end do
         do j = 1, 3
            do i = 1, natm
               work(i,j) = sum(b2pmat(:,j)*work(i,:))
            end do
         end do
      else
         work = xi_mode
      end if
      do i=1,natm
         pos(i,1:3) = pos(i,1:3) + work(i,1:3)
      end do

      if(printable) then
         do i = 1, natm
            write(nfout,'(" !** i = ",i4,"  pos = ",3f8.4, " <<set_vibrational_mode2>>")') &
                 & i, pos(i,1),pos(i,2),pos(i,3)
         end do
      end if
    end subroutine set_vibrational_mode2

    subroutine read_mode_vector(nfmode,natm,xi)
      integer, intent(in) :: nfmode
      integer, intent(in) :: natm
      real(kind=DP), intent(out) :: xi(natm,3)

      integer :: im,ia,idummy
      real(kind=DP) :: xi_tmp(natm,3),mass(natm)
 
      if(mype == 0) then
      rewind nfmode
      do i=1,6
         read(nfmode,*)
      end do
      do ia=1,natm
         read(nfmode,*) idummy,xi_tmp(ia,1:3),mass(ia)
      end do
      read(nfmode,*)
      read(nfmode,*)
      do im=1,natm*3
         read(nfmode,*)
         read(nfmode,*)
         do ia=1,natm
            read(nfmode,*) idummy,xi_tmp(ia,1:3)
         end do
         if(im == mode_index) xi(1:natm,1:3) = xi_tmp(1:natm,1:3)
         if(with_mode_effchg == YES) then
            read(nfmode,*)
            read(nfmode,*)
         end if
      end do
      end if
      if(npes > 1 ) then
         call mpi_bcast(xi,natm*3 &
                     & ,mpi_double_precision,0,mpi_comm_group,ierr)
         call mpi_bcast(mass,natm &
                     & ,mpi_double_precision,0,mpi_comm_group,ierr)
      end if

      if(printable) then
         write(nfout,'(1x,i4,"-th normal mode eigenvector:")') mode_index
         write(nfout,'(3x,"ia",5x,"x",15x,"y",15x,"z")')
         do ia=1,natm
            write(nfout,'(1x,i4,3(1x,f15.10))') ia,xi(ia,1:3)
         end do
      end if
 
      do ia=1,natm
         xi(ia,1:3) = normal_coordinate*xi(ia,1:3)/sqrt(mass(ia))
      end do

      if(printable) then
         write(nfout,'(1x,"Atomic displacements when Q = ",f10.5,":")') &
              & normal_coordinate
         write(nfout,'(3x,"ia",5x,"x",16x,"y",16x,"z")')
         do ia=1,natm
            write(nfout,'(1x,i4,3(1x,f15.10))') ia,xi(ia,1:3)
         end do
      end if
 
    end subroutine read_mode_vector

    subroutine set_replica_input_method(prealloc,m,iret)
      logical, intent(in) :: prealloc
      integer, intent(in) :: m
      integer, intent(out) :: iret
      integer :: i, ip, rint
      integer :: f_selectFirstTableLine, f_selectNextTableLine, f_getRealValue

      i = 1
      do while(.true.)
         if (i == 1) then
            if(f_selectFirstTableLine() /=0) then
               exit
            end if
         else
            if(f_selectNextTableLine() /= 0) then
               exit
            end if
         end if
         if(.not.prealloc) then
            if(i > m) exit
            ip = i
            iret = f_getIntValue(tag_replica_numbers,rint)
            if(iret == 0) ip = rint
            if( f_getStringValue(tag_howtogive_coordinates,rstr,LOWER) == 0) then
               call strncmp0(trim(rstr),tag_proportional, tf)
               if(tf) then
                  replica_howtogive_coordinates(ip) = PROPORTIONAL
                  goto 1001
               end if
               call strncmp0(trim(rstr),tag_file,tf)
               if(tf) then
                  replica_howtogive_coordinates(ip) = FILE
                  goto 1001
               end if
1001           continue
            end if
            if( f_getIntValue(tag_end0,rint) == 0 ) replica_endpoints(1,ip) = rint
            if( f_getIntValue(tag_end1,rint) == 0 ) replica_endpoints(2,ip) = rint
         end if
         i = i + 1
      end do
      iret = i - 1
    end subroutine set_replica_input_method

    subroutine set_atompos_and_etc(prealloc, m, iret)
!   Partially revised for the transformation from Bravais to Primitive system 
!   by BETSUYAKU, K. (Fuji Research Institute Co., Ltd.), July 2003.
!      use m_Crystal_Structure, only : p2bmat ! inverse transformation matrix
      use m_Files, only : nfmode,m_Files_open_nfmode
      logical, intent(in) :: prealloc
      integer, intent(in) :: m
      integer, intent(out) :: iret
      integer :: i, rint, ip, len_rstrtrimmed, n_cp_name, j, istat = 0
      integer :: f_selectFirstTableLine, f_selectNextTableLine, f_getRealValue
      character(len=FMAXVALLEN) :: rstr
      real(kind=DP) :: rx, ry, rz, dret
      real(kind=DP) :: vx, vy, vz
      character(len=FMAXUNITLEN) :: unit_f
      logical :: tf

      real(kind=DP), allocatable, dimension(:,:) :: work
      integer :: ir
      integer :: nthermocount

      unit_f = ''
      if(input_coordinate_system == CARTS) unit_f = 'bohr'

      i = 1
      nthermocount=0
      do while(.true.)
         if (i == 1) then
            if(f_selectFirstTableLine() /= 0) then
               exit
            end if
         else
            if(f_selectNextTableLine() /= 0) then
               exit
            end if
         end if
!!$         if(printable) write(nfout,'(" !!! i = ",i6," <<set_atompos_and_etc>>")') i
         if(.not.prealloc) then
            if(i > m) exit
            ip = i
            iret = f_getIntValue(tag_id,rint)
            if(iret == 0) ip = rint
            if(imdalg==VERLET .or. imdalg==T_CONTROL.or.imdalg==VELOCITY_SCALING.or.imdalg==PT_CONTROL)then
               imdtyp(ip) = ON
               imdtypxyz(ip,1:3) = ON
            endif
            if( f_getIntValue(tag_mobile, rint) == 0) then
               imdtyp(ip) = rint
               imdtypxyz(ip,1) = rint
               imdtypxyz(ip,2) = rint
               imdtypxyz(ip,3) = rint
            endif
            if( f_getIntValue(tag_mobilex, rint) == 0) imdtypxyz(ip,1) = rint
            if( f_getIntValue(tag_mobiley, rint) == 0) imdtypxyz(ip,2) = rint
            if( f_getIntValue(tag_mobilez, rint) == 0) imdtypxyz(ip,3) = rint
#ifndef _EMPIRICAL_
            if( f_getIntValue(tag_pdos, rint) == 0) if_pdos(ip) = rint
            if( f_getIntValue(tag_aldos, rint) == 0) if_aldos(ip) = rint
            if( f_getIntValue(tag_proj_group, rint) == 0) iproj_group(ip) = rint
#endif
            if( f_getRealValue(tag_mass, dret, 'au_mass') == 0) ionic_mass(ip) = dret
            if( f_getIntValue(tag_a_weight, rint) == 0) then
               if(inversion_symmetry == 0) then
                  if(rint /= 1) then
                     if(printable) then
                        write(nfout,'(" !** iwei(",i5,") = ",i3)') ip,rint
                        write(nfout,'(" !* iwei should be 1 when sw_inversion == OFF")')
                     end if
                  end if
                  iwei(ip) = 1
               else
                  if(rint > 2 .or. rint < 1) then
                     if(printable) then
                        write(nfout,'(" !** iwei(",i5,") = i3")') ip,rint
                        write(nfout,'(" !* iwei should be 1 or 2 ")')
                     end if
                  else
                     iwei(ip) = rint
                  end if
               end if
            end if

            if( f_getIntValue(tag_num_layer, rint) == 0) numlay(ip) = rint ! layer_dos
               
            if( f_getStringValue(tag_element, rstr, NOCONV) == 0) then
               len_rstrtrimmed = len_trim(rstr)
               if(len_rstrtrimmed > LEN_ATOMNAME) then
                  if(ipriinputfile >= 1 .and. printable) write(nfout,'(" !* element name is larger than ",i6)') LEN_ATOMNAME
                  n_cp_name = LEN_ATOMNAME
               else
                  n_cp_name = len_rstrtrimmed
               end if
               species_work(ip)(1:n_cp_name) = rstr(1:n_cp_name)
            end if

            if( f_getStringValue(tag_vdw, rstr, NOCONV) == 0) then
               len_rstrtrimmed = len_trim(rstr)
               if(len_rstrtrimmed > LEN_ATOMNAME) then
                  if(ipriinputfile >= 1 .and. printable) write(nfout,'(" !* vdW-type name is larger than ",i6)') LEN_ATOMNAME
                  n_cp_name = LEN_ATOMNAME
               else
                  n_cp_name = len_rstrtrimmed
               end if
               species_vdw_work(ip)(1:n_cp_name) = rstr(1:n_cp_name)
            end if

! === KT_add === 2014/12/29
#ifdef INIT_CHARGE_ATOM_BY_ATOM
            call set_initial_ioncharge_atoms( ip )
            call set_initial_magmom_atoms( ip )
#endif
! ============== 2014/12/29

            if( endpoint_images == NO .or. howtogive_coordinates == DIRECTIN) then
               if( f_getRealValue( tag_rx, rx, unit_f) == 0) pos(ip,1) = rx
               if( f_getRealValue( tag_ry, ry, unit_f) == 0) pos(ip,2) = ry
               if( f_getRealValue( tag_rz, rz, unit_f) == 0) pos(ip,3) = rz
               if( f_getRealValue( tag_vx, vx, '') == 0) cpd_l(ip,1) = vx
               if( f_getRealValue( tag_vy, vy, '') == 0) cpd_l(ip,2) = vy
               if( f_getRealValue( tag_vz, vz, '') == 0) cpd_l(ip,3) = vz
            end if

            if(imdalg == T_CONTROL .or. imdalg == PT_CONTROL) then
!        === modified by T. Y. 2015/01/16 ===
#ifdef THERMOGROUP_DEFAULT_SETTING_FOR_NO_SPECIFIED_ATOMS
               if(imdtyp(ip)/=0)then
                 imdtyp(ip) = NOSE_HOOVER + 1 ! the default is to use the first thermostat !
               endif
#endif
!        ====================================
               tf = f_getIntValue(tag_thermo_group, rint) == 0
               if(.not.tf) tf = f_getIntValue(tag_thermo_g, rint) == 0
               if(tf) then
                  if(imdtyp(ip) /= 0) then
                     imdtyp(ip) = NOSE_HOOVER + rint
!                     imdtypxyz(ip,:) = NOSE_HOOVER + rint
                     nthermocount=nthermocount+1
                  end if
               end if
            end if
            if(sw_atom_excludable==ON)then
                if (f_getIntValue(tag_exclusion_target,iret)==0) then
                    exclusion_target(ip) = iret
                endif
            endif

         end if
         i = i + 1
      end do
      iret = i - 1

      if(.not.prealloc.and.(imdalg == T_CONTROL .or. imdalg==PT_CONTROL) .and. nthermocount==0) then
          stop '!** at least one atom must be assigned to a thermostat when using temperature_control'
      endif
      if(.not.prealloc) then
         natm2 = 0
         do i = 1, natm
            if(iwei(i) <= 0) then
               if(ipriinputfile >= 0 .and. printable) &
                    & write(nfout,'(" !* iwei(",i4,") should be positive value")') i
               stop ' stopped due to illegal value of iwei <<set_atompos_and_etc(m_IS)>>'
            end if
            natm2 = natm2 + iwei(i)
         end do
         if(printable) write(nfout,'(" !** natm2, natm = ",2i6)') natm2,natm

#ifndef _EMPIRICAL_
         if(sw_pdos == ON .or. sw_orb_popu == ON) then
            iret = 0
            do i=1,natm
               iret = iret + if_pdos(i)
            end do
            if(iret == 0) stop 'if_pdos are 0.'
            if(printable) then
               if(iret == natm) then
                  write(nfout,'(" !** pdos switches for all atoms are ON <<set_atompos_and_etc>>")')
               else
                  do i = 1, natm
                     write(nfout,'(" !** i =",i5," pdos=",i1, " <<set_atompos_and_etc>>")') &
                          & i,if_pdos(i)
                  end do
               end if
            end if
         end if

         if(printable) then
            if(sw_aldos == ON) then
               iret = 0
               do i = 1, natm
                  iret = iret + if_aldos(i)
               end do
               if(iret == 0) then
                  write(nfout,'(" !** aldos switches for all atoms are OFF <<set_atompos_and_etc>>")')
               else if(iret == natm) then
                  write(nfout,'(" !** aldos switches for all atoms are ON <<set_atompos_and_etc>>")')
               else
                  write(nfout,'(" !** aldos <<set_atompos_and_etc>>")')
                  write(nfout,'(" !** ",10i8)') (if_aldos(i),i=1,natm)
!!$               do i=1,natm
!!$                  write(nfout,'(" !** i =",i5," aldos=",i1)') i,if_aldos(i)
!!$               end do
               end if
            end if
         end if

         if(sw_hubbard == ON) then
            do i=1,natm
               ig = iproj_group(i)
               if(ig==0) cycle
               do j=1,num_proj_elems(ig)
                  ip=proj_group(j,ig)
                  if(proj_attribute(ip)%strong_correlated) then
                     ihubbard(i) = ip
                  end if
               end do
            end do
         end if

! ============================ added by K. Tagami ================ 11.0
         if ( SpinOrbit_mode == ByProjector ) then
            do i=1,natm
               ig = iproj_group(i)
               if (ig==0) cycle
               do j=1,num_proj_elems(ig)
                  ip=proj_group(j,ig)
!!!!!!!!!                  if ( proj_attribute(ip)%activate_soc ) then

                     itab_spinorbit_addition(i) = ip
!                     write(*,*) 'itab_spinorb = ', i, itab_spinorbit(i)

!!!!!!!!!!!!!!!!!!                  end if
               end do
            end do
         end if
! ================================================================ 11.0

         if(num_projectors > 0.and.printable) then
            iret = 0
            do i=1,natm
               if(ipri>=2 .or. (ipri==1 .and. iproj_group(i) > 0)) then
                  iret = iret+1
                  if(sw_hubbard == ON) then
                     write(nfout,'(" !** i =",i5," iproj_group=",i3," ihubbard=",i3)') i,iproj_group(i),ihubbard(i)
                  else
                     write(nfout,'(" !** i =",i5," iproj_group=",i3)') i,iproj_group(i)
                  end if
               end if
            end do
            if(ipri==1 .and. iret < natm) then
               write(nfout,'(" !** the other iproj_groups being not printed here are all 0")')
            end if

! =================================== added by K. Tagami ========== 11.0
            if ( SpinOrbit_mode == ByProjector ) then
               write(nfout,*) '! ---- Info of projector for Spin-Orbit '
               do i=1,natm
                  write(nfout,'(" !** i =",i5," iproj_group=",i3, &
                       & " itab_spinorbit_addition =",i3)') &
                       &         i,iproj_group(i),itab_spinorbit_addition(i)
               end do
            end if
! ================================================================== 11.0

         end if
#endif

         allocate(work(natm,3), stat=istat)
         if (istat /= 0) then 
            if(printable) write(nfout,*) 'Allocation error in sub.set_atompos_and_etc',natm,istat
            stop
         end if

         natm2 = 0
         do i = 1, natm
            if(iwei(i) <= 0) then
               if(ipriinputfile >= 0 .and. printable) &
                    & write(nfout,'(" !* iwei(",i4,") should be positive value")') i
               stop ' stopped due to illegal value of iwei <<set_atompos_and_etc(m_IS)>>'
            end if
            natm2 = natm2 + iwei(i)
         end do
         if(printable) write(nfout,'(" !** natm2, natm = ",2i6," <<set_atompos_and_etc>>")') natm2,natm

!!$         if(input_coordinate_system == PUCV) then
!!$            do j = 1, 3
!!$               do i = 1, natm
!!$                  work(i,j) = sum(p2bmat(:,j)*pos(i,:))
!!$               end do
!!$            end do
!!$            pos = work
!!$            call change_of_coordinate_system(altv,pos,natm,natm,cps) !-(b_I.S.) pos -> cps
!!$!!$            if(printable) then
!!$!!$               do i = 1, natm
!!$!!$                  write(nfout,*) cps(i,:)
!!$!!$               end do
!!$!!$            end if
!!$         else if(input_coordinate_system == CARTS) then
!!$            cps = pos
!!$            allocate(rltv_t(3,3))
!!$            rltv_t = transpose(rltv)/PAI2
!!$            call change_of_coordinate_system(rltv_t,cps,natm,natm,pos) !-(b_I.S.) cps -> pos
!!$            deallocate(rltv_t)
!!$         end if
         deallocate(work)
      end if
    end subroutine set_atompos_and_etc

    subroutine set_regions(nfout)
      integer, intent(in) :: nfout
      character(len=FMAXVALLEN) :: rstr
      character(len=256) :: str,strstr
      integer :: i,j,ip,iret
      real(kind=DP) :: dret
      integer :: f_selectBlock,f_selectParentBlock, &
   &             f_getIntValue,f_getRealValue,f_getStringValue, &
   &             f_selectFirstTableLine, f_selectNextTableLine
      i=0
      do while(.true.)
        i = i+1
        write(str,*) i
        strstr = trim(adjustl(str))
        if(f_selectBlock(tag_region//strstr)==0)then
          iret = f_selectParentBlock()
        else
          exit
        endif
      enddo
      num_regions = i-1
      if (num_regions < 1) return
      allocate(regions(num_regions))
      do i=1,num_regions
         regions(i)%no = i
         regions(i)%region_group = i
         regions(i)%region_type = BOX
         regions(i)%xmin = -1.d+10
         regions(i)%xmax =  1.d+10
         regions(i)%ymin = -1.d+10
         regions(i)%ymax =  1.d+10
         regions(i)%zmin = -1.d+10
         regions(i)%zmax =  1.d+10
         regions(i)%orientation = 3
         regions(i)%cylx = altv(1,1)
         regions(i)%cyly = altv(2,2)
         regions(i)%cylzmin = -1.d+10
         regions(i)%cylzmax =  1.d+10
         regions(i)%sigma = 1.d0
         regions(i)%epsi = 1.d-3
         regions(i)%energy = 0.d0
         regions(i)%i1 = 1
         regions(i)%i2 = 2
         regions(i)%i3 = 3
         regions(i)%tally = .false.
         allocate(regions(i)%forc(natm,3));regions(i)%forc(natm,3) = 0.d0
         allocate(regions(i)%target_atoms(natm));regions(i)%target_atoms=0
         regions(i)%ntarget_atoms = 0
         
         write(str,*) i
         strstr = trim(adjustl(str))
         iret = f_selectBlock(tag_region//strstr)
         if(f_getStringValue(tag_type,rstr,LOWER)==0)then
            if(rstr == tag_cylinder) regions(i)%region_type = CYLINDER 
         endif
         if(f_getIntValue(tag_region_group,iret)==0)then
            regions(i)%region_group = iret
         endif
         if(f_getIntValue(tag_sw_tally,iret)==0) then
            if(iret == ON) regions(i)%tally = .true.
         endif
         if(regions(i)%region_type == BOX) then
            if(f_getRealValue(tag_xmin,dret,'bohr')==0) regions(i)%xmin = dret
            if(f_getRealValue(tag_xmax,dret,'bohr')==0) regions(i)%xmax = dret
            if(f_getRealValue(tag_ymin,dret,'bohr')==0) regions(i)%ymin = dret
            if(f_getRealValue(tag_ymax,dret,'bohr')==0) regions(i)%ymax = dret
            if(f_getRealValue(tag_zmin,dret,'bohr')==0) regions(i)%zmin = dret
            if(f_getRealValue(tag_zmax,dret,'bohr')==0) regions(i)%zmax = dret
         endif
         if(regions(i)%region_type == CYLINDER) then
            if(f_getRealValue(tag_radius,dret,'bohr')==0) regions(i)%radius = dret
            if(f_getIntValue(tag_orientation,iret)==0) regions(i)%orientation = iret
            if(f_getRealValue(tag_cylx,dret,'bohr')==0) regions(i)%cylx = dret
            if(f_getRealValue(tag_cyly,dret,'bohr')==0) regions(i)%cyly = dret
            if(f_getRealValue(tag_cylzmin,dret,'bohr')==0) regions(i)%cylzmin = dret
            if(f_getRealValue(tag_cylzmax,dret,'bohr')==0) regions(i)%cylzmax = dret
            if(f_getRealValue(tag_sigma,dret,'bohr')==0) regions(i)%sigma = dret
            if(f_getRealValue(tag_epsilon,dret,'hartree')==0) regions(i)%epsi = dret
            if(regions(i)%orientation==1)then
               regions(i)%i1 = 2
               regions(i)%i2 = 3
               regions(i)%i3 = 1
            else if (regions(i)%orientation==2) then
               regions(i)%i1 = 3
               regions(i)%i2 = 1
               regions(i)%i3 = 2
            endif
         endif
         iret = f_selectParentBlock()
      enddo
      i = 1
      iret = f_selectBlock(tag_atomlist)
      iret = f_selectBlock(tag_atoms)
      do while(.true.)
         if (i == 1) then
            if(f_selectFirstTableLine() /= 0) then
               exit
            end if
         else
            if(f_selectNextTableLine() /= 0) then
               exit
            end if
         end if
         ip = i
         if(f_getIntValue(tag_id,iret)==0) ip = iret
         if(f_getIntValue(tag_region_group,iret) == 0)then
           do j=1,num_regions
              if(regions(j)%region_group == iret)then
                 regions(j)%ntarget_atoms = regions(j)%ntarget_atoms+1
                 regions(j)%target_atoms(regions(j)%ntarget_atoms) = ip
              endif
           enddo
         endif
         i = i+1
      enddo
      iret = f_selectParentBlock()
      iret = f_selectParentBlock()
      if(num_regions>0 .and. ipriinputfile>0 .and. printable)then
         write(nfout,'(a)')               ' !** region statistics'
         write(nfout,'(a,i5)')            ' !** num_regions = ',num_regions
         do i=1,num_regions
            write(nfout,'(a,i5)')         ' !** status for region group ',regions(i)%region_group
            if(regions(i)%region_type == BOX) then
               write(nfout,'(a)')         ' !** region type : BOX'
               write(nfout,*) '!** xmin, xmax  : ',regions(i)%xmin,regions(i)%xmax
               write(nfout,*) '!** ymin, ymax  : ',regions(i)%ymin,regions(i)%ymax
               write(nfout,*) '!** zmin, zmax  : ',regions(i)%zmin,regions(i)%zmax
            else if (regions(i)%region_type == CYLINDER)then
               write(nfout,'(a)')         ' !** region type     : CYLINDER'
               write(nfout,'(a,i3,a)')    ' !** orientation     : ',regions(i)%orientation &
                                      & , ' (1->x, 2->y, 3->z)'
               write(nfout,'(a,f20.10)')  ' !** radius          : ',regions(i)%radius
               write(nfout,'(a,2f20.10)') ' !** cylx,cyly       : ',regions(i)%cylx,regions(i)%cyly
               write(nfout,*)             '!** cylzmin,cylzmax : ',regions(i)%cylzmin,regions(i)%cylzmax
            endif
            write(nfout,'(a,2f20.10)')    ' !** sigma, epsilon  : ',regions(i)%sigma,regions(i)%epsi
            write(nfout,'(a,l2)')         ' !** tally           : ',regions(i)%tally
            write(nfout,'(a,i8)')         ' !** n target atoms  : ',regions(i)%ntarget_atoms
            write(nfout,'(8i8)')        (regions(i)%target_atoms(j), j=1,regions(i)%ntarget_atoms)
         enddo
      endif
    end subroutine set_regions

! ===== KT_add ==== 2014/12/29 & 13.2S
#ifdef INIT_CHARGE_ATOM_BY_ATOM
    subroutine set_initial_ioncharge_atoms( ip )
      integer, intent(in) :: ip
      real(kind=DP) :: dret

      if ( f_getRealValue( tag_ion_charge, dret, "" ) == 0 ) then
         ionic_charge_atoms(ip) = dret
         mag_moment0_atoms_is_defined = .true.
      endif
    end subroutine set_initial_ioncharge_atoms

    subroutine set_initial_magmom_atoms( ip )
      integer, intent(in) :: ip
      integer :: mode = 0

      real(kind=DP) :: cnorm, mx, my, mz, theta, phi
      real(kind=DP) :: mdx, mdy, mdz, c1

      cnorm = 0.0d0

      if ( noncol ) then

         if ( f_getRealValue( tag_moment, dret, "" ) == 0 ) then
            cnorm = dret;  mode = 2
         else
            mx = 0.0d0; my = 0.0d0; mz = 0.0d0
            if( f_getRealValue( tag_mx, dret, '') == 0 ) then
               mx = dret;  mode = 1
            endif
            if( f_getRealValue( tag_my, dret, '') == 0 ) then
               my = dret;  mode = 1
            endif
            if( f_getRealValue( tag_mz, dret, '') == 0 ) then
               mz = dret;  mode = 1
            endif
            cnorm = sqrt( mx**2 + my**2 + mz**2 )
         endif

         if ( mode == 2 ) then
            mdx = 0.0d0;  mdy = 0.0d0;  mdz = 0.0d0
            theta = 0.0d0; phi = 0.0d0

            if ( f_getRealValue( tag_theta, dret, "" ) == 0 ) then
               theta = dret

               if ( f_getRealValue( tag_phi, dret, "" ) == 0 )   phi = dret
               theta = theta /180.0d0 *PAI;  phi = phi /180.0d0 *PAI

               mdx = sin( theta ) *cos( phi )
               mdy = sin( theta ) *sin( phi )
               mdz = cos( theta )

            else
               if ( f_getRealValue( tag_mdx, dret, "" ) == 0 ) mdx = dret
               if ( f_getRealValue( tag_mdy, dret, "" ) == 0 ) mdy = dret
               if ( f_getRealValue( tag_mdz, dret, "" ) == 0 ) mdz = dret

               c1 = sqrt( mdx**2 +mdy**2 + mdz**2 )
               if ( c1 > 1.0D-4 ) then
                  mdx = mdx /c1
                  mdy = mdy /c1
                  mdz = mdz /c1
               else
                  mdx = 0.0d0;  mdy = 0.0d0;  mdz = 1.0d0
               endif
            endif
         endif

         if ( cnorm > 1.0E-8 ) then
            if ( mode == 1 ) then
               mag_moment0_atoms(ip,1) = mx
               mag_moment0_atoms(ip,2) = my
               mag_moment0_atoms(ip,3) = mz
            else if ( mode == 2 ) then
               mag_moment0_atoms(ip,1) = cnorm *mdx
               mag_moment0_atoms(ip,2) = cnorm *mdy
               mag_moment0_atoms(ip,3) = cnorm *mdz
            endif
         endif

         if ( sw_fix_global_quantz_axis == ON ) then
            mx = mag_moment0_atoms(ip,1)
            my = mag_moment0_atoms(ip,2)
            mz = mag_moment0_atoms(ip,3)
            cnorm = sqrt( mx**2 +my**2 +mz**2 )

            c1 = mag_moment0_atoms(ip,1) * Global_Quantz_Axis_Fixed(1) &
                 & +mag_moment0_atoms(ip,2) * Global_Quantz_Axis_Fixed(2) &
                 & +mag_moment0_atoms(ip,3) * Global_Quantz_Axis_Fixed(3)
            if ( c1 > 0.0 ) then
               mag_moment0_atoms(ip,1:3) =  cnorm *Global_Quantz_Axis_Fixed(1:3)
            else
               mag_moment0_atoms(ip,1:3) = -cnorm *Global_Quantz_Axis_Fixed(1:3)
            endif
         endif

      else
         if ( f_getRealValue( tag_moment, dret, "" ) == 0 ) then
            cnorm = dret;  mode = 1
            if ( abs(cnorm) > 1.0E-8 ) then
               mag_moment0_atoms(ip,1) = dret
            endif
         endif
      endif

      if ( mode /= 0 ) then
         mag_moment0_atoms_is_defined = .true.
         if ( noncol ) then
            mx = mag_moment0_atoms(ip,1)
            my = mag_moment0_atoms(ip,2)
            mz = mag_moment0_atoms(ip,3)
            cnorm = sqrt( mx**2 +my**2 +mz**2 )
            if ( cnorm > 1.0D-4 ) then
               mag_direction0_atoms(ip,1) = mx /cnorm
               mag_direction0_atoms(ip,2) = my /cnorm
               mag_direction0_atoms(ip,3) = mz /cnorm
            else
               mag_direction0_atoms(ip,1) = 0.0d0
               mag_direction0_atoms(ip,2) = 0.0d0
               mag_direction0_atoms(ip,3) = 1.0d0
            endif
         endif
      endif
    end subroutine set_initial_magmom_atoms
#endif
! ================= 2014/12/29 & 13.2S

    subroutine set_atompos_and_etc_reservoir()
!   Partially revised for the transformation from Bravais to Primitive system 
!   by BETSUYAKU, K. (Fuji Research Institute Co., Ltd.), July 2003.
!      use m_Crystal_Structure, only : p2bmat ! inverse transformation matrix
      use m_Files, only : nfmode,m_Files_open_nfmode
      integer :: i, rint, ip, len_rstrtrimmed, n_cp_name, j, istat = 0
      integer :: f_selectFirstTableLine, f_selectNextTableLine, f_getRealValue,f_getNumRows
      character(len=FMAXVALLEN) :: rstr
      real(kind=DP) :: rx, ry, rz, dret
      real(kind=DP) :: vx, vy, vz
      character(len=FMAXUNITLEN) :: unit_f
      logical :: tf
      real(kind=DP),allocatable,dimension(:,:) :: cpstt,postt
      real(kind=DP), allocatable, dimension(:,:) :: wk
      real(kind=DP), dimension(3,3) :: rltmp

      i=1
      do 
         if(i==1)then
            if(f_selectFirstTableLine()/=0)then
               exit
            endif
         else
            if(f_selectNextTableLine()/=0)then
               exit
            endif
         endif
         i=i+1
      enddo
      natom_reservoir = i-1
      if(allocated(atom_reservoir)) deallocate(atom_reservoir)
      allocate(atom_reservoir(natom_reservoir))
      do i=1,natom_reservoir
         call init_atom(i,atom_reservoir(i))
      enddo

      unit_f = ''
      if(input_coordinate_system == CARTS) unit_f = 'bohr'

      i = 1
      do while(.true.)
         if (i == 1) then
            if(f_selectFirstTableLine() /= 0) then
               exit
            end if
         else
            if(f_selectNextTableLine() /= 0) then
               exit
            end if
         end if
!!$         if(printable) write(nfout,'(" !!! i = ",i6," <<set_atompos_and_etc>>")') i
         if(i > natom_reservoir) exit
         ip = i
         iret = f_getIntValue(tag_id,rint)
         if(iret == 0) ip = rint
         if(imdalg==VERLET .or. imdalg==T_CONTROL.or.imdalg==VELOCITY_SCALING.or.imdalg==PT_CONTROL)then
            atom_reservoir(ip)%imdtyp = ON
            atom_reservoir(ip)%imdtypxyz(1:3) = ON
         endif
         if( f_getIntValue(tag_mobile, rint) == 0) then
            atom_reservoir(ip)%imdtyp = rint
            atom_reservoir(ip)%imdtypxyz(1:3) = rint
         endif
         if( f_getIntValue(tag_mobilex, rint) == 0) atom_reservoir(ip)%imdtypxyz(1) = rint
         if( f_getIntValue(tag_mobiley, rint) == 0) atom_reservoir(ip)%imdtypxyz(2) = rint
         if( f_getIntValue(tag_mobilez, rint) == 0) atom_reservoir(ip)%imdtypxyz(3) = rint
#ifndef _EMPIRICAL_
         if( f_getIntValue(tag_pdos, rint) == 0) atom_reservoir(ip)%if_pdos = rint
         if( f_getIntValue(tag_aldos, rint) == 0) atom_reservoir(ip)%if_aldos = rint
         if( f_getIntValue(tag_proj_group, rint) == 0) atom_reservoir(ip)%iproj_group = rint
#endif
         if( f_getRealValue(tag_mass, dret, 'au_mass') == 0) atom_reservoir(ip)%ionic_mass = dret
         if( f_getIntValue(tag_a_weight, rint) == 0) then
            if(inversion_symmetry == 0) then
               if(rint /= 1) then
                  if(printable) then
                     write(nfout,'(" !** iwei(",i5,") = ",i3)') ip,rint
                     write(nfout,'(" !* iwei should be 1 when sw_inversion == OFF")')
                  end if
               end if
               atom_reservoir(ip)%iwei = 1
            else
               if(rint > 2 .or. rint < 1) then
                  if(printable) then
                     write(nfout,'(" !** iwei(",i5,") = i3")') ip,rint
                     write(nfout,'(" !* iwei should be 1 or 2 ")')
                  end if
               else
                  atom_reservoir(ip)%iwei = rint
               end if
            end if
         end if

         if( f_getIntValue(tag_num_layer, rint) == 0) atom_reservoir(ip)%numlay = rint ! layer_dos
            
         if( f_getStringValue(tag_element, rstr, NOCONV) == 0) then
            len_rstrtrimmed = len_trim(rstr)
            if(len_rstrtrimmed > LEN_ATOMNAME) then
               if(ipriinputfile >= 1 .and. printable) write(nfout,'(" !* element name is larger than ",i6)') LEN_ATOMNAME
               n_cp_name = LEN_ATOMNAME
            else
               n_cp_name = len_rstrtrimmed
            end if
            atom_reservoir(ip)%element(1:n_cp_name) = rstr(1:n_cp_name)
         end if

         if( f_getStringValue(tag_vdw, rstr, NOCONV) == 0) then
            len_rstrtrimmed = len_trim(rstr)
            if(len_rstrtrimmed > LEN_ATOMNAME) then
               if(ipriinputfile >= 1 .and. printable) write(nfout,'(" !* vdW-type name is larger than ",i6)') LEN_ATOMNAME
               n_cp_name = LEN_ATOMNAME
            else
               n_cp_name = len_rstrtrimmed
            end if
            atom_reservoir(ip)%element_vdw(1:n_cp_name) = rstr(1:n_cp_name)
         end if

         if( f_getRealValue( tag_rx, rx, unit_f) == 0) atom_reservoir(ip)%pos(1) = rx
         if( f_getRealValue( tag_ry, ry, unit_f) == 0) atom_reservoir(ip)%pos(2) = ry
         if( f_getRealValue( tag_rz, rz, unit_f) == 0) atom_reservoir(ip)%pos(3) = rz
         if( f_getRealValue( tag_vx, vx, '') == 0) atom_reservoir(ip)%cpd_l(1) = vx
         if( f_getRealValue( tag_vy, vy, '') == 0) atom_reservoir(ip)%cpd_l(2) = vy
         if( f_getRealValue( tag_vz, vz, '') == 0) atom_reservoir(ip)%cpd_l(3) = vz

         if( f_getIntValue(tag_reservoir_group,iret)==0) atom_reservoir(ip)%group = iret
         if(imdalg == T_CONTROL .or. imdalg==PT_CONTROL) then
            atom_reservoir(ip)%imdtyp = NOSE_HOOVER + 1
!            atom_reservoir(ip)%imdtypxyz(:) = NOSE_HOOVER + 1
            tf = f_getIntValue(tag_thermo_group, rint) == 0
            if(.not.tf) tf = f_getIntValue(tag_thermo_g, rint) == 0
            if(tf) then
               if(imdtyp(ip) /= 0) then
                  atom_reservoir(ip)%imdtyp = NOSE_HOOVER + rint
!                  atom_reservoir(ip)%imdtypxyz(:) = NOSE_HOOVER + rint
               end if
            end if
         end if
         if(sw_atom_excludable==ON) then
            if (f_getIntValue(tag_exclusion_target,iret)==0) &
          &     atom_reservoir(ip)%exclusion_target = iret
         endif
      i = i + 1
      end do
      iret = i - 1

#ifndef _EMPIRICAL_
      if(sw_hubbard == ON) then
         do i=1,natom_reservoir
            ig = atom_reservoir(i)%iproj_group
            if(ig==0) cycle
            do j=1,num_proj_elems(ig)
               ip=proj_group(j,ig)
               if(proj_attribute(ip)%strong_correlated) then
                  atom_reservoir(i)%ihubbard= ip
               end if
            end do
         end do
      end if
#endif
      do i=1,natom_reservoir
         do j=1,ntyp
            if(trim(atom_reservoir(i)%element)==trim(speciesname(j)))then
               atom_reservoir(i)%ityp = j
               exit
            endif
         enddo
      enddo

      allocate(wk(natom_reservoir,3))
      allocate(cpstt(natom_reservoir,3));cpstt=0.d0
      allocate(postt(natom_reservoir,3));postt=0.d0

      if(input_coordinate_system == PUCV) then
         do j = 1, 3
            do i = 1, natom_reservoir
               wk(i,j) = sum(p2bmat(:,j)*atom_reservoir(i)%pos(:))
            end do
         end do
         do i=1,natom_reservoir
            atom_reservoir(i)%pos(:) = wk(i,:)
         enddo
         do i=1,natom_reservoir
            postt(i,:) = atom_reservoir(i)%pos(:)
         enddo
         call change_of_coordinate_system(altv,postt,natom_reservoir,natom_reservoir,cpstt)!-(b_I.S.) pos -> cps
         do i=1,natom_reservoir 
            atom_reservoir(i)%cps(:) = cpstt(i,:)
         enddo
      else if(input_coordinate_system == CARTS) then
         do i=1,natom_reservoir
            atom_reservoir(i)%cps(:) = atom_reservoir(i)%pos(:)
         enddo
         do i=1,natom_reservoir
            cpstt(i,:) = atom_reservoir(i)%cps(:)
         enddo
         rltmp = transpose(rltv)/PAI2
         call change_of_coordinate_system(rltmp,cpstt,natom_reservoir,natom_reservoir,postt) !-(b_I.S.) cps -> pos
      end if

      deallocate(wk)
      deallocate(cpstt)
      deallocate(postt)

      if(printable .and. iprimd>=1)then
         write(nfout,'(a)') ' !** atom reservoir defined in the input file '
         do i=1,natom_reservoir
            call print_atom(atom_reservoir(i))
         enddo
      endif
      call resolve_reservoir_group()
    end subroutine set_atompos_and_etc_reservoir

    subroutine resolve_reservoir_group()
       integer :: i,j,k
       integer, allocatable, dimension(:) :: inds0,inds1,inds2
       integer :: icount
       allocate(inds0(natom_reservoir))
       do i=1,natom_reservoir
          inds0(i) = i
       enddo

       do i=1,natom_reservoir
          if(atom_reservoir(i)%group>0)then
             inds0(i) = atom_reservoir(i)%group
          else
             atom_reservoir(i)%group = i
          endif
       enddo

       natom_group = 0
       allocate(inds1(natom_reservoir));inds1=0
       allocate(inds2(natom_reservoir));inds2=0
       do i=1,natom_reservoir
          if (.not.check_dupli(inds0(i),inds1,natom_reservoir))then
             natom_group = natom_group+1
             inds1(natom_group) = inds0(i)
          endif
          inds2(inds0(i)) = inds2(inds0(i))+1
       enddo

       allocate(natm_per_group(natom_group));natm_per_group = 0
       allocate(atomid_in_group(natom_group,natom_reservoir));atomid_in_group = 0
       do i=1,natom_group
          natm_per_group(i) = inds2(i)
       enddo
       do i=1,natom_group
          icount=0
          loopj:do j=1,natm_per_group(i)
             loopk:do k=1,natom_reservoir
                if(atom_reservoir(k)%group==i .and. &
                & .not.check_dupli(k,atomid_in_group(i,:),natom_reservoir)) then
                   atomid_in_group(i,j) = k
                   icount = icount+1
                   exit loopk
                endif
                if(icount==natm_per_group(i)) exit loopj
             enddo loopk
          enddo loopj
       enddo

       if(printable)then
          write(nfout,'(a,i5)') ' !** number of atom groups : ',natom_group
          do i=1,natom_group
             write(nfout,'(a,i5,a,i5)') ' !** number of atoms in group ',i,' is ',natm_per_group(i)
             do j=1,natm_per_group(i)
                call print_atom(atom_reservoir(atomid_in_group(i,j)))
             enddo
          enddo
       endif

       deallocate(inds0)
       deallocate(inds1)
       deallocate(inds2)
    end subroutine resolve_reservoir_group

    subroutine set_atm_exclusion_criteria()
      real(kind=DP) :: dret
      if(f_selectBlock(tag_atom_exclusion_criteria)==0)then
         if(f_getRealValue(tag_x_greater_than,dret,'bohr')==0)then
             exclusion_criteria_min(1) = dret
         endif
         if(f_getRealValue(tag_y_greater_than,dret,'bohr')==0)then
             exclusion_criteria_min(2) = dret
         endif
         if(f_getRealValue(tag_z_greater_than,dret,'bohr')==0)then
             exclusion_criteria_min(3) = dret
         endif
         if(f_getRealValue(tag_x_less_than,dret,'bohr')==0)then
             exclusion_criteria_max(1) = dret
         endif
         if(f_getRealValue(tag_y_less_than,dret,'bohr')==0)then
             exclusion_criteria_max(2) = dret
         endif
         if(f_getRealValue(tag_z_less_than,dret,'bohr')==0)then
             exclusion_criteria_max(3) = dret
         endif
      endif
    end subroutine set_atm_exclusion_criteria

    ! will return true if inds contain ind.
    logical function check_dupli(ind,inds,n)
      integer, intent(in) :: ind
      integer, dimension(:), intent(in) :: inds
      integer, intent(in) :: n
      integer :: i
      do i=1,n
        if(inds(i).eq.ind)then
          check_dupli = .true.
          return
        endif
      enddo
      check_dupli = .false.
    end function check_dupli

    subroutine set_atompos_from_endpoints()
      integer :: i, j
      do j = 1, 3
         do i = 1, natm
            pos(i,j) = (pos_end0(i,j) + pos_end1(i,j))*0.5d0
            cps(i,j) = (cps_end0(i,j) + cps_end1(i,j))*0.5d0
         end do
      end do

      if(printable) then
         do i = 1, natm
            write(nfout,'(" !** i = ",i4,"  pos = ",3f8.4)') i, pos(i,1),pos(i,2),pos(i,3)
         end do
         write(nfout,*)
         do i = 1, natm
            write(nfout,'(" !** i = ",i4,"  cps = ",3f8.4)') i, cps(i,1),cps(i,2),cps(i,3)
         end do
      end if
    end subroutine set_atompos_from_endpoints

    subroutine set_atompos2()
      integer :: i, j, iret

      if(ipriinputfile >= 3) then
         do i = 1, natm
            write(nfout,'(" !** i = ",i4,"  pos = ",3f10.4, " <<set_atompos2>>")') i, pos(i,1:3)
         end do
      end if

      if(input_coordinate_system == PUCV) then
         do j = 1, 3
            do i = 1, natm
               work(i,j) = sum(p2bmat(:,j)*pos(i,:))
            end do
         end do
         pos = work
         call change_of_coordinate_system(altv,pos,natm,natm,cps) !-(b_I.S.) pos -> cps
      else if(input_coordinate_system == CARTS) then
         cps = pos
         allocate(rltv_t(3,3))
         rltv_t = transpose(rltv)/PAI2
         call change_of_coordinate_system(rltv_t,cps,natm,natm,pos) !-(b_I.S.) cps -> pos
         deallocate(rltv_t)
      end if
    end subroutine set_atompos2

    subroutine set_endpoint_atompos(m, pos_end, cps_end)
!   Partially revised for the transformation from Bravais to Primitive system 
!   by BETSUYAKU, K. (Fuji Research Institute Co., Ltd.), July 2003.
!      use m_Crystal_Structure, only : p2bmat ! inverse transformation matrix
      integer, intent(in) :: m
      real(kind=DP), intent(out), dimension(m,3) :: pos_end, cps_end
      integer :: i, rint, ip,  j
      integer :: f_selectFirstTableLine, f_selectNextTableLine, f_getRealValue
      character(len=FMAXVALLEN) :: rstr
      real(kind=DP) :: rx, ry, rz, dret
      character(len=FMAXUNITLEN) :: unit_f

      unit_f = ''
      if(input_coordinate_system == CARTS) unit_f = 'bohr'

      i = 1
      do while(.true.)
         if (i == 1) then
            if(f_selectFirstTableLine() /= 0) then
               exit
            end if
         else
            if(f_selectNextTableLine() /= 0) then
               exit
            end if
         end if

         if(i > m) exit
         ip = i
         iret = f_getIntValue(tag_id,rint)
         if(iret == 0) ip = rint

         if( f_getRealValue( tag_rx, rx, unit_f) == 0) pos_end(ip,1) = rx
         if( f_getRealValue( tag_ry, ry, unit_f) == 0) pos_end(ip,2) = ry
         if( f_getRealValue( tag_rz, rz, unit_f) == 0) pos_end(ip,3) = rz
            
         i = i + 1
      end do

      if(input_coordinate_system == PUCV) then
         do j = 1, 3
            do i = 1, natm
               work(i,j) = sum(p2bmat(:,j)*pos_end(i,:))
            end do
         end do
         pos_end = work
         call change_of_coordinate_system(altv,pos_end,natm,natm,cps_end) !-(b_I.S.) pos -> cps
      else if(input_coordinate_system == CARTS) then
         cps_end = pos_end
         allocate(rltv_t(3,3))
         rltv_t = transpose(rltv)/PAI2
         call change_of_coordinate_system(rltv_t,cps_end,natm,natm,pos_end) !-(b_I.S.) cps -> pos
         deallocate(rltv_t)
      end if

    end subroutine set_endpoint_atompos

    subroutine set_endpoint_atompos_from_file(nfimage, m, pos_end, cps_end)

      integer, intent(in) :: nfimage, m
      integer :: realConvByUnit
      real(kind=DP), intent(out), dimension(m,3) :: pos_end, cps_end
      character(len=FMAXVALLEN) :: rstr
      integer i, j, id, iret
      character(10) token
      real(kind=DP) :: rx, ry, rz, dret
      character(len=FMAXUNITLEN) :: unit_f, unit_r

      unit_f = ''

      id = 0
      do 
        read(nfimage,'(a)',end=1001) rstr
	if(index(rstr,'!') /= 0) rstr = rstr(1:index(rstr,'!')-1)
        if(len_trim(rstr) == 0) cycle

        if(index(rstr,'coordinate_system') /= 0) then
           call set_input_coordinate_system(trim(rstr(index(rstr,'=')+1:)))
	   write(6,*) 'coord_stystem: ', input_coordinate_system
	   cycle
        end if
        if(index(rstr,'#units') /= 0) then
	   read(rstr,*) token, unit_f
           write(6,*) 'unit: ', unit_f
	   cycle
        end if

	id = id + 1
	read(rstr,*) token, pos_end(id,1),pos_end(id,2),pos_end(id,3)
	write(6,'(i5,3f15.10)') id,pos_end(id,1),pos_end(id,2),pos_end(id,3)
      end do
1001  continue

      ! unit translation
      if(input_coordinate_system == PUCV) unit_f = 'bohr'
      unit_r = 'bohr'
      do i = 1, natm
	do j = 1, 3
	  iret = realConvByUnit(pos_end(i,j),pos_end(i,j),unit_f,unit_r)
        end do
      end do

      if(input_coordinate_system == PUCV) then
         do j = 1, 3
            do i = 1, natm
               work(i,j) = sum(p2bmat(:,j)*pos_end(i,:))
            end do
         end do
         pos_end = work
         call change_of_coordinate_system(altv,pos_end,natm,natm,cps_end) !-(b_I.S.) pos -> cps
      else if(input_coordinate_system == CARTS) then
         cps_end = pos_end
         allocate(rltv_t(3,3))
         rltv_t = transpose(rltv)/PAI2
         call change_of_coordinate_system(rltv_t,cps_end,natm,natm,pos_end) !-(b_I.S.) cps -> pos
         deallocate(rltv_t)
      end if

    end subroutine set_endpoint_atompos_from_file

    subroutine set_neb_convergence_condition(rstr)
      character(len=FMAXVALLEN),intent(in) :: rstr
      logical :: tf

      call strncmp2(rstr, FMAXVALLEN, 'delta_e', len('delta_e'), tf)
      if(.not.tf) call strncmp2(rstr, FMAXVALLEN,'1',1,tf)
      if(tf) then
         neb_convergence_condition = 1
         goto 1001
      end if
	
      call strncmp2(rstr, FMAXVALLEN, 'phase_force', len('phase_force'), tf)
      if(.not.tf) call strncmp2(rstr, FMAXVALLEN,'2',1,tf)
      if(tf) then
         neb_convergence_condition = 2
         goto 1001
      end if
	
      call strncmp2(rstr, FMAXVALLEN, 'neb_force', len('neb_force'), tf)
      if(.not.tf) call strncmp2(rstr, FMAXVALLEN,'3',1,tf)
      if(tf) then
         neb_convergence_condition = 3
         goto 1001
      end if
	
      call strncmp2(rstr, FMAXVALLEN, 'force_at_transition_state', &
	len('force_at_transition_state'), tf)
      if(.not.tf) call strncmp2(rstr, FMAXVALLEN,'4',1,tf)
      if(tf) then
         neb_convergence_condition = 4
         goto 1001
      end if
	
      call strncmp2(rstr, FMAXVALLEN, 'phase_force_normal', &
	len('phase_force_normal'), tf)
      if(.not.tf) call strncmp2(rstr, FMAXVALLEN,'5',1,tf)
      if(tf) then
         neb_convergence_condition = 5
         goto 1001
      end if
	
1001  continue
    end subroutine set_neb_convergence_condition

    subroutine set_neb_time_integral(rstr)
      character(len=FMAXVALLEN),intent(in) :: rstr
      logical :: tf

      call strncmp2(rstr, FMAXVALLEN, 'steepest_descent', len('steepest_descent'), tf)
      if(.not.tf) call strncmp2(rstr, FMAXVALLEN,'12',1,tf)
      if(tf) then
         neb_time_integral = 12
         goto 1001
      end if
	
      call strncmp2(rstr, FMAXVALLEN, 'quench', len('quench'), tf)
      if(.not.tf) call strncmp2(rstr, FMAXVALLEN,'2',1,tf)
      if(tf) then
         neb_time_integral = 2
         goto 1001
      end if
		
1001  continue
    end subroutine set_neb_time_integral

    subroutine set_fixed_bond_atoms(prealloc,num_fixed_bonds,countedbonds,fixed_atoms)
      ! Coded by T. Yamasaki (FUJITSU LABORATORIES LTD.), 2nd Aug. 2003
      logical,intent(in) :: prealloc
      integer,intent(in) :: num_fixed_bonds
      integer,intent(out) :: countedbonds
      integer,intent(out),optional :: fixed_atoms

      integer :: i, fix_type, rint1, rint2, icatm
      integer :: f_getIntValue, f_getStringValue, f_selectFirstTableLine, f_selectNextTableLine
      logical :: tf

      icatm = 0
      i = 1
      do while(.true.)
         if (i == 1) then
            if(f_selectFirstTableLine() /= 0) then
               exit
            end if
         else
            if(f_selectNextTableLine() /= 0) then
               exit
            end if
         end if
         if(.not.prealloc) then
            if(i > num_fixed_bonds) exit
            if(imdalg == QUENCHED_CONSTRAINT) then
               fix_type = BONDLENGTH_FIX_1
               if( f_getStringValue(tag_type,rstr, LOWER) == 0) then
                  call strncmp0(trim(rstr),tag_absolute,tf)
                  if(tf) then
                     fix_type = BONDLENGTH_FIX_1
                     goto 1001
                  end if
                  call strncmp0(trim(rstr),tag_square,tf)
                  if(tf) then
                     fix_type = BONDLENGTH_FIX_2
                     goto 1001
                  end if
1001              continue
               end if
            else
               fix_type = BONDLENGTH_FIX
            end if
         end if
         if(ipriinputfile >= 1) then
            write(nfout,'(" !** i = ",i5)') i
            if(fix_type == BONDLENGTH_FIX) then
               write(nfout,'(" !**   fix_type = BONDLENGTH_FIX")')
            else if(fix_type == BONDLENGTH_FIX_1) then
               write(nfout,'(" !**   fix_type = BONDLENGTH_FIX_1")')
            else if(fix_type == BONDLENGTH_FIX_2) then
               write(nfout,'(" !**   fix_type = BONDLENGTH_FIX_2")')
            end if
         end if

         rint1 = 0
         rint2 = 0
         if( f_getIntValue(tag_atom1,rint1) == 0)  then
            if(rint1 > 0 .and. rint1 <= natm) then
               if(.not.prealloc) then
                  imdtyp(rint1) = fix_type
                  imdtypxyz(rint1,:) = fix_type
                  bondlength_fix_set(1,i) = rint1
               end if
               icatm = icatm + 1
            else
               rint1 = 0
            end if
         end if

         if( f_getIntValue(tag_atom2,rint2) == 0)  then
            if(rint2 > 0 .and. rint2 <= natm) then
               if(.not.prealloc) then
                  imdtyp(rint2) = fix_type
                  imdtypxyz(rint2,:) = fix_type
                  bondlength_fix_set(2,i) = rint2
               end if
               icatm = icatm + 1
            else
               rint2 = 0
            end if
         end if
         if(prealloc) then
            if(rint1 == rint2) then
               if(printable) write(nfout,'(" !* [ atom1 == atom2 (= ",i5 &
                    & ,")] is illegal <<m_IS_rd_n.set_fixed_bond>>")')
               stop ' [atom1 = atom2, this is illegal <<m_IS_rd_n.set_fixed_bond>>'
            else if(rint1 == 0 .or. rint2 == 0) then
               if(printable) write(nfout,'(" !* input atom number is illegal" &
                    & , " <<m_IS_rd_n.set_fixed_bond>>")')
               stop '  atom1 or atom2 is illegal <<m_IS_rd_n.set_fixed_bond>>'
            end if
         end if
         i = i + 1
      end do
      countedbonds = i - 1
      if(prealloc) fixed_atoms = icatm
    end subroutine set_fixed_bond_atoms
         
    subroutine set_element_detail()
      integer :: i, iret, rint, ip, len_rstrtrimmed, n_cp_name, icount
      integer :: f_selectFirstTableLine, f_selectNextTableLine, f_getRealValue
!!$      character(len=FMAXVALLEN) :: rstr
      real(kind=DP) :: dret
!!$      character(len=FMAXUNITLEN) unit_f
!!$      unit_f = ''

      if(ipriinputfile >= 1 .and. printable) &
           & write(nfout,'(" !** -- << set_element_detail >> --")')
      icount = 0
      if(.not.allocated(surface_integral_method_paw)) then
         allocate(surface_integral_method_paw(ntyp))
         surface_integral_method_paw = SphericalHarmonicsExpansion
      endif
      do i = 1, ntyp
         if (i == 1) then
            if(f_selectFirstTableLine() /= 0) then
               exit
            end if
         else
            if(f_selectNextTableLine() /= 0) then
               exit
            end if
         end if
         ip = i
         icount = icount + 1
         iret = f_getIntValue(tag_id,rint)
         if(iret /= 0 ) iret = f_getIntValue(tag_no,rint)
         if(iret == 0 .and. rint > 0 .and. rint <= ntyp) ip = rint
         if( f_getRealValue(tag_atomicnumber, dret, '') == 0) iatomn(ip) = dret

         if(printable) write(nfout,'(" !** iatomn(",i6,") = ",f8.4)') ip,iatomn(ip)

         if( f_getRealValue(tag_mass, dret, 'au_mass') == 0) amion(ip) = dret

! ==== KT_mod ==== 13.3B
!         if( amion(ip) < DELTA) then
         if( dret < DELTA ) then
! ================ 13.3B
            if(printable) write(nfout,'(" !** amion(",i6,") = ",d20.8)') ip,amion(ip)
            stop ' amion is too small <<m_IS_rd_n.set_elelment_detail>>'
         end if

#ifndef _EMPIRICAL_
         ! --- zeta ---
         if( f_getRealValue(tag_zeta, dret, '') == 0) then
            zeta1(ip) = dret
            mag_zeta1_atomtyp_is_defined = .true.
         endif

!!$         if( f_getRealValue(tag_variance, dret, 'bohr') ==0 ) alfa(ip) = 1.d0/(dret*dret)
         ! --- parameter for the initial_charge_density ---
         number_is_given = f_getRealValue(tag_deviation, dret, 'bohr') == 0
         if(.not.number_is_given) &
              number_is_given = f_getRealValue(tag_standard_deviation, dret, 'bohr') == 0
         if(.not.number_is_given) number_is_given = f_getRealValue(tag_dev, dret, 'bohr') == 0 
         if(number_is_given) then
!!$            alfa(ip) = 1.d0/(dret*dret)
            alfa(ip) = 1.d0/(2*dret*dret)
            if(ipriinputfile >= 1 .and. printable) &
                 & write(nfout,'(" !** deviation(",i2, &
                 & ") of the Gauss. distrib. func. for the initial charge construction = ",f10.5)') ip,dret
         end if
         ! -- excess charge ---
         if( f_getRealValue(tag_qex,dret,'') == 0) qex(ip) = dret

! ====================== KT_add ======================== 11.0&13.0U
!!
!!!       set initial values of ionic_charge and magnetic moment
!
         call set_initial_ioncharge_atomtyp(ip)
         call set_initial_magmom_atomtyp(ip)

         if ( noncol ) then
            if ( .not. mag_moment0_atomtyp_is_defined ) then
               call set_initial_orientation_magmom(ip)
            endif
            call set_elemtype_wrt_lcore_filling(ip)
         endif
! ====================================================== 11.0&13.0U

! ==== KT_add ==== 11.0 & 13.2S
!-----------------------------------------------------------------------
!!
!!!       set scaling factor for Spin-orbit 
!!
!----------------------------------------------------------------------
         if ( noncol .or. sw_spinorbit_force_theorem == ON &
                     .or. sw_calc_core_energy == ON ) then
            if ( SpinOrbit_Mode == ByPawPot .or. SpinOrbit_Mode == ZeffApprox &
                 &                          .or. SpinOrbit_Mode == ReadFromPP ) then
               if( f_getRealValue( tag_scaling_so, dret, '' ) == 0) then
                  scaling_so(ip) = dret
               endif
            endif
         endif
! =============== 11.0 & 13.2S

#endif
         if( f_getStringValue(tag_element, rstr, NOCONV) == 0) then
            len_rstrtrimmed = len_trim(rstr)
            if(len_rstrtrimmed > LEN_ATOMNAME) then
               if(ipriinputfile >= 1 .and. printable) &
                    & write(nfout,'(" !* element name is larger than ",i6)') LEN_ATOMNAME
               n_cp_name = LEN_ATOMNAME
            else
               n_cp_name = len_rstrtrimmed
            end if
            speciesname(ip)(1:n_cp_name) = rstr(1:n_cp_name)
         end if
         if( f_getStringValue(tag_surface_integral_method, rstr, LOWER) == 0)then
            if(rstr == tag_sph) surface_integral_method_paw(ip) = SphericalHarmonicsExpansion
            if(rstr == tag_gl)  surface_integral_method_paw(ip) = GaussLegendre
         endif
         if(ipriinputfile >= 1 .and. printable) &
              & write(nfout,'(" !** ityp = ",i6," : iatomn,amion,zeta1,alfa,qex,type = " &
              &              , f8.4,f12.4,3f8.4,3x,a4)') &
              & i,iatomn(ip),amion(ip),zeta1(ip),alfa(ip),qex(ip),speciesname(ip)
      end do

! ================== KT_add =============== 11.0&13.0U
      call message_on_chgmagmom_atomtyp

      if ( noncol ) then
         call print_message_on_magmom_direc
         call print_message_on_lcore_filling
         if ( SpinOrbit_Mode == ByPawPot .or. SpinOrbit_Mode == ZeffApprox &
              &                          .or. SpinOrbit_Mode == ReadFromPP ) then
            call print_message_on_scaling_so
         endif
      else
         if ( SpinOrbit_Mode == ByPawPot .or. SpinOrbit_Mode == ZeffApprox &
              &                          .or. SpinOrbit_Mode == ReadFromPP ) then
            call print_message_on_scaling_so
         endif
      endif
! ========================================= 11.0&13.0U

! === KT_add === 13.3B
#ifdef MASS_AUTOMATIC_SET
      call set_amion_default( ntyp, iatomn, amion )
#endif
! ============== 13.3B

    end subroutine set_element_detail

    subroutine set_vdw_parameters()
! === Apply modifications for vdW function. by tkato 2012/06/14 ================
      use m_Const_Parameters, only : VDW_WILLIAMS, VDW_GRIMME
      use m_Control_Parameters, only : vdw_method, vdw_scaling_factor, vdw_scaling_factor_r
! ==============================================================================
      integer :: i, j, iret, rint, ip, ip1, ip2, len_rstrtrimmed, n_cp_name
      integer :: f_selectFirstTableLine, f_selectNextTableLine, f_getRealValue
      real(kind=DP) :: dret

      if(ipriinputfile >= 1 .and. printable) &
! === Apply modifications for vdW function. by tkato 2012/06/14 ================
           & write(nfout,'(" !** -- << set_default_vdw_parameters >> --")')
      if(ipriinputfile >= 1 .and. printable) &
           & write(nfout,'(" !** -- elements --")')

      do i = 1, ntyp_vdw
	select case(vdw_method)
        case(VDW_WILLIAMS)
          select case(speciesname_vdw(i))
	  case('H')
	    c6vdw(i) = 2.831179918
	    r0vdw(i) = 1.17
	    pvdw(i) = 0.387
	  case('F')
	    c6vdw(i) = 3.94987377
	    pvdw(i) = 0.296
	  case('Cl')
	    c6vdw(i) = 3.94987377
	    pvdw(i) = 2.315
	  case('Br')
	    c6vdw(i) = 128.2756865
	    pvdw(i) = 3.013
	  case('I')
	    c6vdw(i) = 309.0603852
	    pvdw(i) = 5.415
	  case('CTE')
	    c6vdw(i) = 22.67403316 
	    r0vdw(i) = 1.70
	    pvdw(i) = 1.061
	  case('CTR')
	    c6vdw(i) = 32.61525204 
	    r0vdw(i) = 1.70
	    pvdw(i) = 1.352
	  case('CAR')
	    c6vdw(i) = 49.790/vdw_scaling_factor
	    r0vdw(i) = 1.70
	    pvdw(i) = 1.352
	  case('CBR')
	    c6vdw(i) = 54.16430826
	    r0vdw(i) = 1.70
	    pvdw(i) = 1.896
	  case('CDI')
	    c6vdw(i) = 30.15058105
	    r0vdw(i) = 1.70
	    pvdw(i) = 1.283
	  case('NTE')
	    c6vdw(i) = 20.89758657
	    r0vdw(i) = 1.50
	    pvdw(i) = 0.964
	  case('NTR2')
	    c6vdw(i) = 23.08003267
	    r0vdw(i) = 1.50
	    pvdw(i) = 1.030
	  case('NPI2')
	    c6vdw(i) = 25.12582491
	    r0vdw(i) = 1.50
	    pvdw(i) = 1.090
	  case('NDI')
	    c6vdw(i) = 20.63799109
	    r0vdw(i) = 1.50
	    pvdw(i) = 0.956
	  case('OTE')
	    c6vdw(i) = 11.86370812
	    r0vdw(i) = 1.40
	    pvdw(i) = 0.637
	  case('OTR4')
	    c6vdw(i) = 10.01566303
	    r0vdw(i) = 1.40
	    pvdw(i) = 0.569
	  case('OPI2')
	    c6vdw(i) = 3.346856941
	    r0vdw(i) = 1.40
	    pvdw(i) = 0.274
	  case('STE')
	    c6vdw(i) = 121.2531939
	    r0vdw(i) = 1.80
	    pvdw(i) = 3.000
	  case('STR4')
	    c6vdw(i) = 168.0350502
	    r0vdw(i) = 1.80
	    pvdw(i) = 3.729
	  case('SPI2')
	    c6vdw(i) = 103.5277919
	    r0vdw(i) = 1.80
	    pvdw(i) = 2.700
	  case('PTE')
	    c6vdw(i) = 42.11289383
	    r0vdw(i) = 1.80
	    pvdw(i) = 1.538
          end select

	case(VDW_GRIMME)
          select case(speciesname_vdw(i))
	  case('H')
	    c6vdw(i) = 0.14
	    r0vdw(i) = 1.001
	  case('He')
	    c6vdw(i) = 0.08
	    r0vdw(i) = 1.012
	  case('Li')
	    c6vdw(i) = 1.61
	    r0vdw(i) = 0.825
	  case('Be')
	    c6vdw(i) = 1.61
	    r0vdw(i) = 1.408
	  case('B')
	    c6vdw(i) = 3.13
	    r0vdw(i) = 1.485
	  case('C')
	    c6vdw(i) = 1.75
	    r0vdw(i) = 1.452
	  case('N')
	    c6vdw(i) = 1.23
	    r0vdw(i) = 1.397
	  case('O')
	    c6vdw(i) = 0.70
	    r0vdw(i) = 1.342
	  case('F')
	    c6vdw(i) = 0.75
	    r0vdw(i) = 1.287
	  case('Ne')
	    c6vdw(i) = 0.63
	    r0vdw(i) = 1.243
	  case('Na')
	    c6vdw(i) = 5.71
	    r0vdw(i) = 1.144
	  case('Mg')
	    c6vdw(i) = 5.71
	    r0vdw(i) = 1.364
	  case('Al')
	    c6vdw(i) = 10.79
	    r0vdw(i) = 1.716
	  case('Si')
	    c6vdw(i) = 9.23
	    r0vdw(i) = 1.716
	  case('P')
	    c6vdw(i) = 7.84
	    r0vdw(i) = 1.705
	  case('S')
	    c6vdw(i) = 5.57
	    r0vdw(i) = 1.683
	  case('Cl')
	    c6vdw(i) = 5.07
	    r0vdw(i) = 1.639
	  case('Ar')
	    c6vdw(i) = 4.61
	    r0vdw(i) = 1.595
	  case('K')
	    c6vdw(i) = 10.80
	    r0vdw(i) = 1.485
	  case('Ca')
	    c6vdw(i) = 10.80
	    r0vdw(i) = 1.474
	  case('Sc','Ti','V','Cr','Mn','Fe','Co','Ni','Cu','Zn')
	    c6vdw(i) = 10.80
	    r0vdw(i) = 1.562
	  case('Ga')
	    c6vdw(i) = 16.99
	    r0vdw(i) = 1.650
	  case('Ge')
	    c6vdw(i) = 17.10
	    r0vdw(i) = 1.727
	  case('As')
	    c6vdw(i) = 16.37
	    r0vdw(i) = 1.760
	  case('Se')
	    c6vdw(i) = 12.64
	    r0vdw(i) = 1.771
	  case('Br')
	    c6vdw(i) = 12.47
	    r0vdw(i) = 1.749
	  case('Kr')
	    c6vdw(i) = 12.01
	    r0vdw(i) = 1.727
	  case('Rb')
	    c6vdw(i) = 24.67
	    r0vdw(i) = 1.628
	  case('Sr')
	    c6vdw(i) = 24.67
	    r0vdw(i) = 1.606
	  case('Y','Zr','Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd')
	    c6vdw(i) = 24.67
	    r0vdw(i) = 1.639
	  case('In')
	    c6vdw(i) = 37.32
	    r0vdw(i) = 1.672
	  case('Sn')
	    c6vdw(i) = 38.71
	    r0vdw(i) = 1.804 
	  case('Sb')
	    c6vdw(i) = 38.44
	    r0vdw(i) = 1.881
	  case('Te')
	    c6vdw(i) = 31.74
	    r0vdw(i) = 1.892
	  case('I')
	    c6vdw(i) = 31.50
	    r0vdw(i) = 1.892
	  case('Xe')
	    c6vdw(i) = 29.99
	    r0vdw(i) = 1.881
          end select
	end select

        if(ipriinputfile >= 1 .and. printable) &
              & write(nfout,'(" !** ",i6,1x," : c6vdw,r0vdw = " &
              &              , 3f12.4,3x,a4)') &
              & i,c6vdw(i),r0vdw(i),pvdw(i),speciesname_vdw(i)
      end do

      if(ipriinputfile >= 1 .and. printable) &
! ==============================================================================
           & write(nfout,'(" !** -- << set_vdw_parameters >> --")')
! === Apply modifications for vdW function. by tkato 2012/06/14 ================
      if(ipriinputfile >= 1 .and. printable) &
           & write(nfout,'(" !** -- elements --")')

      if( f_selectBlock( tag_vdw_list) == 0) then

! ==============================================================================
      do i = 1, ntyp_vdw
! === Apply modifications for vdW function. by tkato 2012/06/14 ================
!        do j = 1, i
!        if (i == 1 .and. j == 1) then
         if (i == 1) then
! ==============================================================================
            if(f_selectFirstTableLine() /= 0) then
               exit
            end if
         else
            if(f_selectNextTableLine() /= 0) then
               exit
            end if
         end if

         ip1 = 0
! === Apply modifications for vdW function. by tkato 2012/06/14 ================
!        if( f_getStringValue(tag_type1, rstr, NOCONV) == 0) then
         if( f_getStringValue(tag_type, rstr, NOCONV) == 0) then
! ==============================================================================
            len_rstrtrimmed = len_trim(rstr)
            if(len_rstrtrimmed > LEN_ATOMNAME) then
               if(ipriinputfile >= 1 .and. printable) &
! === Apply modifications for vdW function. by tkato 2012/06/14 ================
!                   & write(nfout,'(" !* vdW-type1 name is larger than ",i6)') LEN_ATOMNAME
                    & write(nfout,'(" !* vdW-type name is larger than ",i6)') LEN_ATOMNAME
! ==============================================================================
               n_cp_name = LEN_ATOMNAME
            else
               n_cp_name = len_rstrtrimmed
            end if
            do ip=1,ntyp_vdw
               if(speciesname_vdw(ip)(1:n_cp_name) == rstr(1:n_cp_name)) then
                  ip1 = ip
                  exit
               end if
            end do
            if(ip1 == 0) then
! === Apply modifications for vdW function. by tkato 2012/06/14 ================
!              if(ipriinputfile >= 1 .and. printable) write(nfout,'(" !* vdW-type1 name did not match.")')
!              stop 'vdw-type1 name did not match.'
!           end if
!        end if

!        ip2 = 0
!        if( f_getStringValue(tag_type2, rstr, NOCONV) == 0) then
!           len_rstrtrimmed = len_trim(rstr)
!           if(len_rstrtrimmed > LEN_ATOMNAME) then
!              if(ipriinputfile >= 1 .and. printable) &
!                   & write(nfout,'(" !* vdW-type2 name is larger than ",i6)') LEN_ATOMNAME
!              n_cp_name = LEN_ATOMNAME
!           else
!              n_cp_name = len_rstrtrimmed
!           end if
!           do ip=1,ntyp_vdw
!              if(speciesname_vdw(ip)(1:n_cp_name) == rstr(1:n_cp_name)) then
!                 ip2 = ip
!                 exit
!              end if
!           end do
!           if(ip2 == 0) then
!              if(ipriinputfile >= 1 .and. printable) write(nfout,'(" !* vdW-type2 name did not match.")')
!              stop 'vdw-type2 name did not match.'
               if(ipriinputfile >= 1 .and. printable) write(nfout,'(" !* vdW-type name did not match.")')
               stop 'vdw-type name did not match.'
! ==============================================================================
            end if
         end if

         if( f_getRealValue(tag_c6, dret, '') == 0) then
! === Apply modifications for vdW function. by tkato 2012/06/14 ================
!            cvdw(ip1,ip2) = dret
!            cvdw(ip2,ip1) = dret
             c6vdw(ip1) = dret
! ==============================================================================
         end if
         if( f_getRealValue(tag_r0, dret, '') == 0) then
! === Apply modifications for vdW function. by tkato 2012/06/14 ================
!            rvdw(ip1,ip2) = dret
!            rvdw(ip2,ip1) = dret
             r0vdw(ip1) = dret
         end if
         if( f_getRealValue(tag_p, dret, '') == 0) then
             pvdw(ip1) = dret
! ==============================================================================
         end if

         if(ipriinputfile >= 1 .and. printable) &
! === Apply modifications for vdW function. by tkato 2012/06/14 ================
              & write(nfout,'(" !** ",i6,1x," : c6vdw,r0vdw = " &
              &              , 3f12.4,3x,a4)') &
              & ip1,c6vdw(ip1),r0vdw(ip1),pvdw(ip1),speciesname_vdw(ip1)
      end do

      iret = f_selectParentBlock()
      end if

      if(ipriinputfile >= 1 .and. printable) &
           & write(nfout,'(" !** -- atom pair --")')

      do i = 1, ntyp_vdw
        do j = 1, i
          select case(vdw_method)
          case(VDW_WILLIAMS)
            cvdw(i,j) = -vdw_scaling_factor * (2.0d0*c6vdw(i)*c6vdw(j)*pvdw(i)*pvdw(j)) &
                       / (pvdw(i)**2*c6vdw(i)+pvdw(j)**2*c6vdw(j))
            rvdw(i,j) = vdw_scaling_factor_r * ((2.0d0*r0vdw(i))**3+(2.0d0*r0vdw(j))**3) &
                       / ((2.0d0*r0vdw(i))**2+(2.0d0*r0vdw(j))**2)
          case(VDW_GRIMME)
            cvdw(i,j) = dsqrt(c6vdw(i)*c6vdw(j))
            rvdw(i,j) = r0vdw(i)+r0vdw(j)
            cvdw(i,j) = cvdw(i,j) * 3.8088e-7 * 1.0e6 / 0.5291772480d0**6  ! J/mol nm6 -> hartree A6
          end select

          rvdw(i,j) = rvdw(i,j) / 0.5291772480d0  ! ang -> bohr
          cvdw(j,i) = cvdw(i,j)
          rvdw(j,i) = rvdw(i,j)

          if(ipriinputfile >= 1 .and. printable) &
! ==============================================================================
              & write(nfout,'(" !** ",i6,1x,i6," : cvdw,rvdw = " &
              &              , 2f12.4,3x,a4,1x,a4)') &
! === Apply modifications for vdW function. by tkato 2012/06/14 ================
!             & ip1,ip2,cvdw(ip1,ip2),rvdw(ip1,ip2),speciesname_vdw(ip1),speciesname_vdw(ip2)
!        end do
              & i,j,cvdw(i,j),rvdw(i,j),speciesname_vdw(i),speciesname_vdw(j)
        end do
! ==============================================================================
      end do

    end subroutine set_vdw_parameters

! ============================= added by K. Tagami ======================== 11.0
#ifndef _EMPIRICAL_
    subroutine set_initial_orientation_magmom( ip )
      integer, intent(in) :: ip
      integer :: mode = 0
      
      real(kind=DP) :: cnorm, mdx, mdy, mdz
      real(kind=DP) :: theta, phi
      
      mdx = 0.0d0; mdy = 0.0d0; mdz = 0.0d0

      if( f_getRealValue( tag_mdx, dret, '') == 0 ) then
         mdx = dret;  mode = 1
      endif
      if( f_getRealValue( tag_mdy, dret, '') == 0 ) then
         mdy = dret;  mode = 1
      endif
      if( f_getRealValue( tag_mdz, dret, '') == 0 ) then
         mdz = dret;  mode = 1
      endif

      cnorm = sqrt( mdx**2 + mdy**2 + mdz**2 )

      theta = 0.0d0; phi = 0.0d0
      if ( f_getRealValue( tag_theta, dret, "" ) == 0 ) then
         theta = dret;  mode = 2
      endif
      if ( f_getRealValue( tag_phi, dret, "" ) == 0 )   then
         phi = dret;  mode = 2
      endif

      theta  = theta / 180.0d0 *PAI
      phi  =  phi / 180.0d0 *PAI

      if ( mode == 1 ) then
         if ( abs(cnorm) > 1.0E-4 ) then
            mag_direction0_atomtyp(ip,1) = mdx / cnorm;
            mag_direction0_atomtyp(ip,2) = mdy / cnorm;
            mag_direction0_atomtyp(ip,3) = mdz / cnorm;
         else
            mag_direction0_atomtyp(ip,1) = 0.0d0
            mag_direction0_atomtyp(ip,2) = 0.0d0
            mag_direction0_atomtyp(ip,3) = 1.0d0
         endif
      else if ( mode == 2 ) then
         mag_direction0_atomtyp(ip,1) = sin( theta ) *cos( phi )
         mag_direction0_atomtyp(ip,2) = sin( theta ) *sin( phi )
         mag_direction0_atomtyp(ip,3) = cos( theta )
      endif

    end subroutine set_initial_orientation_magmom

#endif

    subroutine print_message_on_magmom_direc
      integer :: it

      write(nfout,*) '! ------------ Initial Magnetic Orientation --- '
      write(nfout,*) '     id     name        mdx         mdy         mdz  '
      Do it=1, ntyp
         write(nfout,'(I8,3X,A7,3F12.6)') it, speciesname(it), &
              &                         mag_direction0_atomtyp(it,1), &
              &                         mag_direction0_atomtyp(it,2), &
              &                         mag_direction0_atomtyp(it,3)
      End Do
      write(nfout,*) '! ---------------------------------------------'
    end subroutine print_message_on_magmom_direc

    subroutine set_elemtype_wrt_lcore_filling(ip)
      integer, intent(in) :: ip
      integer :: iret

      if( f_getIntValue( tag_lcore_parfil,iret ) == 0 ) then
         has_partially_filled_lcore(ip) = iret
      endif

    end subroutine set_elemtype_wrt_lcore_filling

    subroutine print_message_on_lcore_filling
      integer :: it

      write(nfout,*) '! ----- Info. of localized core orbitals ( such as 4f )--------'
      write(nfout,*) '     id     name    atom_has_partially_filled_lcore_orb (Yes:1)'
      Do it=1, ntyp
         write(nfout,'(I8,3X,A7,5X,I3)') it, speciesname(it), &
              &                             has_partially_filled_lcore(it)
      End Do
      write(nfout,*) '! ---------------------------------------------'

    end subroutine print_message_on_lcore_filling

    subroutine print_message_on_scaling_so
      integer :: it

      write(nfout,*) '! ----- Info. of scaling param. of spin-orbit strength '
      write(nfout,*) '     id     name    scaling_so'
      Do it=1, ntyp
         write(nfout,'(I8,3X,A7,X,F10.4)') it, speciesname(it), scaling_so(it)
      End Do
      write(nfout,*) '! ---------------------------------------------'

    end subroutine print_message_on_scaling_so
! ========================================================================= 11.0

! ===================== KT_add ================================== 13.0U &13.2S
    subroutine set_initial_magmom_atomtyp( ip )
      integer, intent(in) :: ip
      integer :: mode = 0

      real(kind=DP) :: cnorm, mx, my, mz, theta, phi
      real(kind=DP) :: mdx, mdy, mdz, c1

      cnorm = 0.0d0

      if ( noncol ) then
         mode = 0
         if ( f_getRealValue( tag_moment, dret, "" ) == 0 ) then
            cnorm = dret;  mode = 2
         else
            mx = 0.0d0; my = 0.0d0; mz = 0.0d0
            if( f_getRealValue( tag_mx, dret, '') == 0 ) then
               mx = dret;  mode = 1
            endif
            if( f_getRealValue( tag_my, dret, '') == 0 ) then
               my = dret;  mode = 1
            endif
            if( f_getRealValue( tag_mz, dret, '') == 0 ) then
               mz = dret;  mode = 1
            endif
            cnorm = sqrt( mx**2 + my**2 + mz**2 )
         endif

         if ( mag_zeta1_atomtyp_is_defined ) then
            cnorm = abs( zeta1(ip) );  mode = 2
         endif

         if ( mode == 2 ) then
            mdx = 0.0d0;  mdy = 0.0d0;  mdz = 0.0d0
            theta = 0.0d0; phi = 0.0d0

            if ( f_getRealValue( tag_theta, dret, "" ) == 0 ) then
               theta = dret

               if ( f_getRealValue( tag_phi, dret, "" ) == 0 )   phi = dret
               theta = theta /180.0d0 *PAI;  phi = phi /180.0d0 *PAI

               mdx = sin( theta ) *cos( phi )
               mdy = sin( theta ) *sin( phi )
               mdz = cos( theta )

            else
               if ( f_getRealValue( tag_mdx, dret, "" ) == 0 ) mdx = dret
               if ( f_getRealValue( tag_mdy, dret, "" ) == 0 ) mdy = dret
               if ( f_getRealValue( tag_mdz, dret, "" ) == 0 ) mdz = dret

               c1 = sqrt( mdx**2 +mdy**2 + mdz**2 )
               if ( c1 > 1.0D-4 ) then
                  mdx = mdx /c1
                  mdy = mdy /c1
                  mdz = mdz /c1
               else
                  mdx = 0.0d0;  mdy = 0.0d0;  mdz = 1.0d0
               endif
            endif
         endif

         if ( mode == 1 ) then
            mag_moment0_atomtyp(ip,1) = mx
            mag_moment0_atomtyp(ip,2) = my
            mag_moment0_atomtyp(ip,3) = mz
         else if ( mode == 2 ) then
            mag_moment0_atomtyp(ip,1) = cnorm *mdx
            mag_moment0_atomtyp(ip,2) = cnorm *mdy
            mag_moment0_atomtyp(ip,3) = cnorm *mdz
         endif

         if ( sw_fix_global_quantz_axis == ON ) then
            mx = mag_moment0_atomtyp(ip,1)
            my = mag_moment0_atomtyp(ip,2)
            mz = mag_moment0_atomtyp(ip,3)
            cnorm = sqrt( mx**2 +my**2 +mz**2 )

            c1 = mag_moment0_atomtyp(ip,1) * Global_Quantz_Axis_Fixed(1) &
                 & +mag_moment0_atomtyp(ip,2) * Global_Quantz_Axis_Fixed(2) &
                 & +mag_moment0_atomtyp(ip,3) * Global_Quantz_Axis_Fixed(3)
            if ( c1 > 0.0 ) then
               mag_moment0_atomtyp(ip,1:3) =  cnorm *Global_Quantz_Axis_Fixed(1:3)
            else
               mag_moment0_atomtyp(ip,1:3) = -cnorm *Global_Quantz_Axis_Fixed(1:3)
            endif
         endif

      else
         if ( f_getRealValue( tag_moment, dret, "" ) == 0 ) then
            cnorm = dret;  mode = 1
         endif
         mag_moment0_atomtyp(ip,1) = cnorm
      endif

      if ( mode /= 0 ) then
         mag_moment0_atomtyp_is_defined = .true.
         if ( noncol ) then
            mx = mag_moment0_atomtyp(ip,1)
            my = mag_moment0_atomtyp(ip,2)
            mz = mag_moment0_atomtyp(ip,3)
            cnorm = sqrt( mx**2 +my**2 +mz**2 )
            if ( cnorm > 1.0D-4 ) then
               mag_direction0_atomtyp(ip,1) = mx /cnorm
               mag_direction0_atomtyp(ip,2) = my /cnorm
               mag_direction0_atomtyp(ip,3) = mz /cnorm
            else
               mag_direction0_atomtyp(ip,1) = 0.0d0
               mag_direction0_atomtyp(ip,2) = 0.0d0
               mag_direction0_atomtyp(ip,3) = 1.0d0
            endif
         endif
      endif

    end subroutine set_initial_magmom_atomtyp

    subroutine set_initial_ioncharge_atomtyp( ip )
      integer, intent(in) :: ip
      real(kind=DP) :: dret

      if ( f_getRealValue( tag_ion_charge, dret, "" ) == 0 ) then
         ionic_charge_atomtyp(ip) = dret
      endif

    end subroutine set_initial_ioncharge_atomtyp

    subroutine message_on_chgmagmom_atomtyp
      integer :: it

      if ( noncol ) then
         write(nfout,*) '! ------------ Initial Charge/Magnetic Moment (atomtyp) --- '
         write(nfout,*) '     id     name       ion         mx          my          mz'
         Do it=1, ntyp
            write(nfout,'(I8,3X,A7,4F12.6)') it, speciesname(it), &
                 &                         ionic_charge_atomtyp(it), &
                 &                         mag_moment0_atomtyp(it,1), &
                 &                         mag_moment0_atomtyp(it,2), &
                 &                         mag_moment0_atomtyp(it,3)
         End Do
      else if ( sw_fix_global_quantz_axis == ON ) then
         write(nfout,*) '! ------------ Initial Charge/Magnetic Moment (atomtyp) --- '
         write(nfout,*) '     id     name       ion         mx          my          mz'
         Do it=1, ntyp
            write(nfout,'(I8,3X,A7,4F12.6)') it, speciesname(it), &
                 &         ionic_charge_atomtyp(it), &
                 &         mag_moment0_atomtyp(it,1)*Global_Quantz_Axis_Fixed(1), &
                 &         mag_moment0_atomtyp(it,1)*Global_Quantz_Axis_Fixed(2), &
                 &         mag_moment0_atomtyp(it,1)*Global_Quantz_Axis_Fixed(3)
         End Do
      else
         write(nfout,*) '! ------------ Initial Charge/Magnetic Moment (atomtyp) --- '
         write(nfout,*) '     id     name       ion        moment '
         Do it=1, ntyp
            write(nfout,'(I8,3X,A7,2F12.6)') it, speciesname(it), &
                 &                         ionic_charge_atomtyp(it), &
                 &                         mag_moment0_atomtyp(it,1)
         End Do
      endif
      write(nfout,*) '! ---------------------------------------------'

    end subroutine message_on_chgmagmom_atomtyp
! =============================================================== 13.0U & 13.2S

    subroutine set_initial_velocities(imode)
      integer, intent(in) :: imode
      integer :: i,j,ia,ir, irp
      integer,dimension(natm) :: imdt
      integer :: icnstrnt_typ
      real(kind=DP) :: a,b,p
      real(kind=DP) :: xn 
      real(kind=DP),dimension(nrsv,natm,3) :: random
      real(kind=DP)   :: sumt
      real(kind=DP)   :: mcom
      real(kind=DP),dimension(3)   :: pcom
      real(kind=DP),dimension(nrsv)   :: tkin
      integer, dimension(nrsv) :: nir
      integer nrsv_atom, imdalg_t
      integer :: rand_seed = 9
      real(kind=DP), parameter :: eps = 1.d-12

      if(conf_para)then
         rand_seed=rand_seed+mype_conf
      endif

      if(imode == 1) then
         do i=1,natm
            if ( imdtyp(i) .le. NOSE_HOOVER ) then
               imdt(i) = NOSE_HOOVER + 1
            else 
               imdt(i) = imdtyp(i)
            endif
         enddo
         imdalg_t = T_CONTROL
      else
         do i=1, natm
            imdt(i) = imdtyp(i)
         end do
         imdalg_t = VERLET
      end if

      if(sw_read_velocities == OFF) then

         xn = 0.d0
         a  = 32771.d0
         b  = 1234567891.d0 + dble(rand_seed)*2
         p  = 214783648.d0
         sumt = 0.d0

         ! create normal random numbers.
         do i=1,3 
            do ia=1,natm
               ir = icnstrnt_typ(imdt(ia),imdalg_t)
               if ( ir >= 1 ) then
                  do j=1,12
                     xn = dble(mod(xn*a+b,p))
                     sumt = sumt+xn/p
                  enddo
                  random(ir,ia,i) = (sumt-6.0d0)/6.0d0
                  sumt = random(ir,ia,i)
               endif
            enddo
         enddo

         ! randomize velocity
         cpd_l = 0.d0
         do i=1,3
            pcom(i) = 0.d0
            do ia=1,natm
               ir = icnstrnt_typ(imdt(ia),imdalg_t)
               if ((imode == 1 .and. ir >= 1 .and. imdtyp(ia).ne.0).or. &
             &     (imode == 2 .and. ir == 1 .and. imdtyp(ia).ne.0)) then
                  cpd_l(ia,i) = random(ir,ia,i)
                  if(iprimd >= 2) write(nfout,'(" !!! ia, ir = ",2i8," cpd_l(ia,",i3,") = " &
                       & ,f12.6, " <<set_initial_velocities>>")') ia, ir, i, cpd_l(ia,i)
                  pcom(i) = pcom(i) + amion(ityp(ia))*cpd_l(ia,i)
               else
                  if(iprimd >= 2) write(nfout,'(" !!! ia, ir = ",2i8," cpd_l(ia,",i3,") = " &
                       & ,f12.6, " * <<set_initial_velocities>>")') ia, ir, i, cpd_l(ia,i)
               endif
            enddo
         enddo

      else ! sw_read_velocities == ON

         ! sum of momenta
         do i=1,3
            pcom(i) = 0.d0
            do ia=1,natm
               ir = icnstrnt_typ(imdt(ia),imdalg_t)
               if (  ir >= 1 ) then
                   pcom(i) = pcom(i) + amion(ityp(ia))*cpd_l(ia,i)
               endif
            enddo
         enddo
 
      end if

      mcom = 0.d0
      if(imode == 1) then
         do ia=1,natm
            ir = icnstrnt_typ(imdt(ia),imdalg_t)
            if (  ir >= 1 .and. imdtyp(ia).ne.0 ) then
               mcom = mcom + amion(ityp(ia))
            end if
         end do
      else
         do ia=1,natm
            ir = icnstrnt_typ(imdt(ia),imdalg_t)
            if (  ir == 1 .and. imdtyp(ia).ne.0 ) then
               mcom = mcom + amion(ityp(ia))
            end if
         end do
      end if

      ! shift velocity
      if(mcom.gt.eps) pcom(:) = pcom(:)/mcom

      if(imode == 1) then
         do ia=1,natm
            ir = icnstrnt_typ(imdt(ia),imdalg_t)
            if (   ir >= 1 .and. imdtyp(ia).ne.0 ) then
               cpd_l(ia,:) = cpd_l(ia,:) - pcom(:)
            endif
         enddo
      else
         do ia=1,natm
            ir = icnstrnt_typ(imdt(ia),imdalg_t)
            if (   ir == 1 .and. imdtyp(ia).ne.0 ) then
               cpd_l(ia,:) = cpd_l(ia,:) - pcom(:)
            endif
         enddo
      end if

      ! scale velocity
      nir = 0
      tkin = 0.d0
      if(imode == 1) then
         do ia=1,natm
            ir = icnstrnt_typ(imdt(ia),imdalg_t)
            if (  ir >= 1 .and. imdtyp(ia).ne.0 )  then
               irp = ir
               if(irp > nrsv) irp = 1
               tkin(irp) = tkin(irp)+dot_product(cpd_l(ia,1:3),cpd_l(ia,1:3)) &
                    &               * amion(ityp(ia))*iwei(ia)*0.5d0
               nir(irp) = nir(irp) + iwei(ia)
            endif
         enddo
      else
         do ia=1,natm
            ir = icnstrnt_typ(imdt(ia),imdalg_t)
            if (  ir == 1 .and. imdtyp(ia).ne.0 )  then
               tkin(ir) = tkin(ir)+dot_product(cpd_l(ia,1:3),cpd_l(ia,1:3)) &
                    &               * amion(ityp(ia))*iwei(ia)*0.5d0
               nir(ir) = nir(ir) + iwei(ia)
            endif
         enddo
      end if

      if(iprimd >= 1) then
         do ir = 1, nrsv
            if ( natm_per_thermo(ir) == 0 ) cycle
            write(nfout,'(" !! tkin(",i3,")  = ",d20.8)') ir,tkin(ir)
            write(nfout,'(" !! nir( ",i3,")  = ",i8)') ir,nir(ir)
            write(nfout,'(" !! tkb( ",i3,")  = ",d20.8)') ir,tkb(ir)
            write(nfout,'(" !! dsqrt(1.5d0*nir(ir)*tkb(ir)/tkin(ir)) = ",d20.8)') dsqrt(1.5d0*nir(ir)*tkb(ir)/tkin(ir))
         end do
      end if

      if(imode == 1) then
         do ia=1,natm
            ir = icnstrnt_typ(imdt(ia),imdalg_t)
            if (  ir >= 1 .and. imdtyp(ia).ne.0 ) then
               irp = ir
               if(irp > nrsv) irp = 1
               if(tkin(irp).gt.1e-12) &
             & cpd_l(ia,:) = cpd_l(ia,:) * dsqrt(1.5d0*nir(irp)*tkb(irp)/tkin(irp))
            endif
         enddo
      else
         do ia=1,natm
            ir = icnstrnt_typ(imdt(ia),imdalg_t)
            if (  ir == 1 .and. imdtyp(ia).ne.0 ) then
               if(tkin(ir).gt.1e-12) &
             & cpd_l(ia,:) = cpd_l(ia,:) * dsqrt(1.5d0*nir(ir)*tkb(ir)/tkin(ir))
            endif
         enddo
      end if

      if(iprimd >= 1) then
         write(nfout,*) 'initial velocities (at m_Ionic_System.set_initial_velocities)'
         write(nfout,'("Translational velocity = ",3(1x,e18.9))') pcom(1:3)
         write(nfout,'(" --- initial velocities ---")')
         do ia=1,natm
            write(nfout,'(i5,3(1x,e18.9))') ia,cpd_l(ia,1:3)
         end do
      end if

    end subroutine set_initial_velocities

  end subroutine m_IS_rd_n

  subroutine m_IS_scale_magmom0_atomtyp
    integer :: it
    real(kind=DP) :: c1

    if ( mag_moment0_atomtyp_is_defined ) then
       if ( mag_zeta1_atomtyp_is_defined ) then
          if ( noncol ) then
             Do it=1, ntyp
                c1 = ival(it) +qex(it) -additional_charge/dble(natm)
                mag_moment0_atomtyp(it,1:3) = mag_moment0_atomtyp(it,1:3) *c1
             End Do
          else
             Do it=1, ntyp
                c1 = ival(it) +qex(it) -additional_charge/dble(natm)
                mag_moment0_atomtyp(it,1) = mag_moment0_atomtyp(it,1) *c1
             End Do
          endif
       endif
    endif
  end subroutine m_IS_scale_magmom0_atomtyp

  subroutine shift_velocities(imode)
      integer, intent(in) :: imode
      integer :: i,j,ia,ir
      real(kind=DP)   :: mcom
      integer,dimension(natm) :: imdt
      integer :: icnstrnt_typ
      integer :: imdalg_t
      real(kind=DP),dimension(3)   :: pcom
      real(kind=DP), parameter :: eps = 1.d-12
      if(imode == 1) then
         do i=1,natm
            if ( imdtyp(i) .le. NOSE_HOOVER ) then
               imdt(i) = NOSE_HOOVER + 1
            else 
               imdt(i) = imdtyp(i)
            endif
         enddo
         imdalg_t = T_CONTROL
      else
         do i=1, natm
            imdt(i) = imdtyp(i)
         end do
         imdalg_t = VERLET
      end if

      do i=1,3
         pcom(i) = 0.d0
         do ia=1,natm
            ir = icnstrnt_typ(imdt(ia),imdalg_t)
            if ((imode == 1 .and. ir >= 1 .and. imdtyp(ia).ne.0).or. &
          &     (imode == 2 .and. ir == 1 .and. imdtyp(ia).ne.0)) then
              pcom(i) = pcom(i) + amion(ityp(ia))*cpd_l(ia,i)
            endif
         enddo
      enddo

      mcom = 0.d0
      if(imode == 1) then
         do ia=1,natm
            ir = icnstrnt_typ(imdt(ia),imdalg_t)
            if (  ir >= 1 .and. imdtyp(ia).ne.0 ) then
               mcom = mcom + amion(ityp(ia))
            end if
         end do
      else
         do ia=1,natm
            ir = icnstrnt_typ(imdt(ia),imdalg_t)
            if (  ir == 1 .and. imdtyp(ia).ne.0 ) then
               mcom = mcom + amion(ityp(ia))
            end if
         end do
      end if

      ! shift velocity
      if(mcom.gt.eps) pcom(:) = pcom(:)/mcom

      if(imode == 1) then
         do ia=1,natm
            ir = icnstrnt_typ(imdt(ia),imdalg_t)
            if (   ir >= 1 .and. imdtyp(ia).ne.0 ) then
               cpd_l(ia,:) = cpd_l(ia,:) - pcom(:)
            endif
         enddo
      else
         do ia=1,natm
            ir = icnstrnt_typ(imdt(ia),imdalg_t)
            if (   ir == 1 .and. imdtyp(ia).ne.0 ) then
               cpd_l(ia,:) = cpd_l(ia,:) - pcom(:)
            endif
         enddo
      end if
  end subroutine shift_velocities

!!$ 2011.06.06
  subroutine scale_velocity()
     integer :: ia,ir,irp
     integer, dimension(nrsv) :: nir
     real(kind=DP),dimension(nrsv)   :: tkin
      integer,dimension(natm) :: imdt
     integer :: icnstrnt_typ
     do ia=1,natm
        if ( imdtyp(ia) .le. NOSE_HOOVER ) then
           imdt(ia) = NOSE_HOOVER + 1
        else 
           imdt(ia) = imdtyp(ia)
        endif
     enddo
     nir = 0
     tkin = 0.d0
     do ia=1,natm
        ir = icnstrnt_typ(imdt(ia),T_CONTROL)
        if (  ir >= 1 .and. imdtyp(ia).ne.0 )  then
           irp = ir
           if(irp > nrsv) irp = 1
           tkin(irp) = tkin(irp)+dot_product(cpd_l(ia,1:3),cpd_l(ia,1:3)) &
                &               * amion(ityp(ia))*iwei(ia)*0.5d0
           nir(irp) = nir(irp) + iwei(ia)
        endif
     enddo

     do ia=1,natm
        ir = icnstrnt_typ(imdt(ia),T_CONTROL)
        if (  ir >= 1 .and. imdtyp(ia).ne.0 )  then
           irp = ir
           if(irp > nrsv) irp = 1
           if(tkin(irp).gt.1e-12) &
           & cpd_l(ia,:) = cpd_l(ia,:) * dsqrt(1.5d0*nir(irp)*tkb(irp)/tkin(irp))
        endif
     enddo

     if(iprimd >= 1) then
        write(nfout,'(a)') 'scaled the velocities'
        do ir = 1, nrsv
           if ( natm_per_thermo(ir) == 0 ) cycle
           write(nfout,'(" !! tkin(",i3,")  = ",d20.8)') ir,tkin(ir)
           write(nfout,'(" !! nir( ",i3,")  = ",i8)') ir,nir(ir)
           write(nfout,'(" !! tkb( ",i3,")  = ",d20.8)') ir,tkb(ir)
           write(nfout,'(" !! dsqrt(1.5d0*nir(ir)*tkb(ir)/tkin(ir)) = ",d20.8)') dsqrt(1.5d0*nir(ir)*tkb(ir)/tkin(ir))
        end do
     end if
  end subroutine scale_velocity
!!$ 2011.06.06

!!$  subroutine alloc_fcvect_tmp()
!!$    allocate(fcvect_tmp(num_planes_atoms_are_fixed,4))
!!$  end subroutine alloc_fcvect_tmp
!!$ 
!!$  subroutine dealloc_fcvect_tmp()
!!$    deallocate(fcvect_tmp)
!!$  end subroutine dealloc_fcvect_tmp

  subroutine m_IS_alloc_iatomn_etc
    allocate(iatomn(ntyp));iatomn=0.d0
    allocate(iatom(ntyp))
!!$    allocate(iloc_inputf(ntyp))
    allocate(ivan(ntyp)); ivan = 1
    allocate(alfa(ntyp)); alfa = 0.15

! ==== KT_mod ==== 13.3B
!    allocate(amion(ntyp)); amion = 51577.50
!    allocate(amion(ntyp)); amion = 51196.421251715d0 ! mass of Si
!
#ifdef MASS_AUTOMATIC_SET
    allocate(amion(ntyp)); amion = -100.0d0
#else
    allocate(amion(ntyp)); amion = 51196.421251715d0 ! mass of Si
#endif
! ================= 13.3B

    allocate(zeta1(ntyp)); zeta1 = 0.0
    allocate(qex(ntyp)); qex = 0.d0

! ===================================== added by K. Tagami ========== 11.0
    if ( noncol ) then
       allocate( mag_direction0_atomtyp(ntyp,3) )
       mag_direction0_atomtyp(:,1) = 0.0d0
       mag_direction0_atomtyp(:,2) = 0.0d0
       mag_direction0_atomtyp(:,3) = 1.0d0
!
       allocate( has_partially_filled_lcore(ntyp) )
       has_partially_filled_lcore = 0
    endif
! =================================================================== 11.0
! ===================================== added by K. Tagami ========== 11.0 & 13.2S
    if ( noncol .or. sw_spinorbit_force_theorem == ON &
         &      .or. sw_calc_core_energy == ON ) then
       if ( SpinOrbit_Mode == ByPawPot .or. SpinOrbit_Mode == ZeffApprox &
            &                          .or. SpinOrbit_Mode == ReadFromPP ) then
          allocate( scaling_so(ntyp) )
          scaling_so(:) = 1.0d0
       endif
    endif
! =================================================================== 11.0 & 13.2S

! ====================== KT_add ================ 13.0U
    if ( noncol ) then
       allocate( mag_moment0_atomtyp(ntyp,3) )
    else
       allocate( mag_moment0_atomtyp(ntyp,1) )
    endif
    mag_moment0_atomtyp = 0.0d0

    allocate( ionic_charge_atomtyp( ntyp) ); ionic_charge_atomtyp = 0.0d0
! ============================================== 13.0U

  end subroutine m_IS_alloc_iatomn_etc

  subroutine m_IS_dealloc_iatomn_etc
    if(allocated(iatomn)) deallocate(iatomn)
    if(allocated(iatom)) deallocate(iatom)
    if(allocated(ivan)) deallocate(ivan)
    if(allocated(alfa)) deallocate(alfa)
    if(allocated(amion)) deallocate(amion)
    if(allocated(zeta1)) deallocate(zeta1)
    if(allocated(qex)) deallocate(qex)

! ===== KT_ add =========== 2013/10/30
    if ( noncol ) then
       if (allocated(mag_direction0_atomtyp))     deallocate(mag_direction0_atomtyp)
       if (allocated(has_partially_filled_lcore)) deallocate(has_partially_filled_lcore)
    endif
    if (allocated(scaling_so)) deallocate(scaling_so)
! ========================= 2013/10/30

! ================= KT_add ================ 13.0U
    if ( allocated(mag_moment0_atomtyp) ) deallocate( mag_moment0_atomtyp )
    if ( allocated(ionic_charge_atomtyp) ) deallocate( ionic_charge_atomtyp )
! ========================================= 13.0U

  end subroutine m_IS_dealloc_iatomn_etc

! ===================================== added by K. Tagami ========== 11.0
  subroutine m_IS_alloc_magmom_local
!    allocate( magmom_local_now(ista_atm:iend_atm,3) )
    allocate( magmom_local_now(1:natm,3) )
    magmom_local_now = 0.0d0
  end subroutine m_IS_alloc_magmom_local
! ============================================================ 11.0

! ====== KT_add ==================== 2013/10/31
  subroutine m_IS_dealloc_magmom_local
    deallocate( magmom_local_now )
  end subroutine m_IS_dealloc_magmom_local
! ================================== 2013/10/31

! ======================== added by K. Tagami ===================== 11.0 & 13.2S
  subroutine m_IS_init_magmom_local
    magmom_local_now = 0.0d0

    if ( noncol ) then
       call case_noncol
    else if ( sw_spinorbit_force_theorem == ON ) then
       call case_col
    endif

  contains

    subroutine case_noncol
      integer :: ia, it

      Do ia=1, natm
         it = ityp(ia)
         magmom_local_now(ia,:) = mag_moment0_atomtyp(it,:)
      End Do
! == KT_add == 2014/12/29
      if ( mag_moment0_atoms_is_defined ) then
         Do ia=1, natm
            it = ityp(ia)
            magmom_local_now(ia,:) = mag_moment0_atoms(ia,:)
         End Do
      endif
! ============ 2014/12/29
    end subroutine case_noncol

    subroutine case_col
      integer :: ia, it

      Do ia=1, natm
         it = ityp(ia)
         magmom_local_now(ia,:) = mag_moment0_atomtyp(it,1)*Global_Quantz_Axis_Fixed(:)
      End Do
! == KT_add == 2014/12/29
      if ( mag_moment0_atoms_is_defined ) then
         Do ia=1, natm
            it = ityp(ia)
            magmom_local_now(ia,:) = mag_moment0_atoms(ia,1)*Global_Quantz_Axis_Fixed(:)
         End Do
      endif
! ============ 2014/12/29
    end subroutine case_col

  end subroutine m_IS_init_magmom_local
! ============================================================ 11.0 & 13.2S

  subroutine m_IS_alloc_vdw
    allocate(cvdw(ntyp_vdw,ntyp_vdw))
    allocate(rvdw(ntyp_vdw,ntyp_vdw))
! === Apply modifications for vdW function. by tkato 2012/06/14 ================
    allocate(c6vdw(ntyp_vdw))
    allocate(r0vdw(ntyp_vdw))
    allocate(pvdw(ntyp_vdw))
! ==============================================================================
    allocate(ityp_vdw(natm)); ityp_vdw = 1
    allocate(fxyzvdw_l(natm,3))
  end subroutine m_IS_alloc_vdw

  subroutine m_IS_alloc_vdwdf3
    allocate(fxyzvdw_l(natm,3))
  end subroutine m_IS_alloc_vdwdf3

! =========================== KT_add ======================= 13.0B
  subroutine m_IS_dealloc_vdw
    if ( allocated(cvdw) ) deallocate(cvdw)
    if ( allocated(rvdw) ) deallocate(rvdw)
    if ( allocated(c6vdw) ) deallocate(c6vdw)
    if ( allocated(r0vdw) ) deallocate(r0vdw)
    if ( allocated(pvdw) )  deallocate(pvdw)
    if ( allocated(ityp_vdw) ) deallocate(ityp_vdw)
    if ( allocated(fxyzvdw_l) ) deallocate(fxyzvdw_l)
  end subroutine m_IS_dealloc_vdw
! ========================================================= 13.0B

  subroutine m_IS_alloc_napt
    if(printable) then
       write(nfout,'(" -- allocation of napt --")')
       write(nfout,'(" !! natm = ",i5," nopr+af = ",i5)') natm,nopr+af
       if(ngen_tl > 0) write(nfout,'(" !! natm = ",i5," nopr+af+ngen_tl = ",i5)') natm,nopr+af+ngen_tl
    end if
    if(.not.allocated(napt)) allocate(napt(natm,nopr+af))
    if(nopr == 0) stop ' nopr == 0'
    if(ngen_tl > 0) then
       if(.not.allocated(napt_tl)) allocate(napt_tl(natm,ngen_tl))
    else
       if(.not.allocated(napt_tl)) allocate(napt_tl(natm,1))
    end if
  end subroutine m_IS_alloc_napt

  subroutine m_IS_alloc_fxyzew
    if(allocated(fxyzew_l)) deallocate(fxyzew_l)
    allocate(fxyzew_l(natm,3))
  end subroutine m_IS_alloc_fxyzew

  subroutine m_IS_alloc_zfm3
    if(.not.allocated(zfm3_l)) allocate(zfm3_l(ista_kngp:iend_kngp,ntyp,kimg)); zfm3_l = 0.d0
  end subroutine m_IS_alloc_zfm3

  subroutine m_IS_dealloc_zfm3
    if(allocated(zfm3_l)) deallocate(zfm3_l)
  end subroutine m_IS_dealloc_zfm3

  subroutine m_IS_gdiis_alloc(mode_init,if_allocated)
    integer, intent(in) ::  mode_init
    integer, intent(out) :: if_allocated
    integer ::             i,j
    real(kind=DP) ::       fac
    if(kqnmditer_p <= 0) stop ' kqnmditer_p is illegal (m_IS_gdiis_alloc)'
    if(printable) write(nfout,'(" !! kqnmditer_p = ",i6," <<m_IS_gdiis_alloc>>")') kqnmditer_p
    if(.not.allocated(u_l)) allocate(u_l(natm,3,kqnmditer_p));u_l=0.d0
    if(.not.allocated(w_l)) allocate(w_l(natm,3,kqnmditer_p));w_l=0.d0
    if(.not.allocated(fc_l)) allocate(fc_l(natm,3))
    do i = 1, natm
       do j=1,3
          if(imdtypxyz(i,j) == 0) then
             fac = 0.d0
          else
             if(mode_init == UNIT) then
                fac = 1.d0
             else
                fac = dtio*dtio/amion(ityp(i))
             end if
          end if
          fc_l(i,j) = -fac
       enddo
    end do

    if(.not.allocated(ncrspd)) allocate(ncrspd(kqnmditer_p))
    ncrspd(:) = (/(i,i=1,kqnmditer_p)/)
    if(.not.allocated(f_gdiis)) allocate(f_gdiis(kqnmditer_p,kqnmditer_p))
    if(.not.allocated(g)) allocate(g(kqnmditer_p))
    if(.not.allocated(f_wk)) allocate(f_wk(kqnmditer_p*kqnmditer_p,2))
    if(.not.allocated(f_rslv)) allocate(f_rslv(kqnmditer_p*kqnmditer_p))
    if(.not.allocated(e_wk)) allocate(e_wk(kqnmditer_p*kqnmditer_p))
    if(.not.allocated(ww1)) allocate(ww1(kqnmditer_p))
    if(.not.allocated(etot_trial)) allocate(etot_trial(0:2))
    if(.not.allocated(forc_g)) allocate(forc_g(natm,3))
    if(.not.allocated(ip)) allocate(ip(kqnmditer_p))
    if_allocated = 1
    if(icond==CONTINUATION .or. icond==AUTOMATIC .and. diis_continuable)then
        u_l(:,:,:) = u_l_buf(:,:,:)
        w_l(:,:,:) = w_l_buf(:,:,:)
        ncrspd(:) = ncrspd_buf(:)
    endif
    if(allocated(u_l_buf))    deallocate(u_l_buf)
    if(allocated(w_l_buf))    deallocate(w_l_buf)
    if(allocated(ncrspd_buf)) deallocate(ncrspd_buf)
  end subroutine m_IS_gdiis_alloc

  subroutine m_IS_gdiis_reset()
     iter_gdiis = 0
     if(if_allocated==0) return
     call m_IS_gdiis_dealloc(if_allocated)
  end subroutine m_IS_gdiis_reset

  subroutine m_IS_freeze()
    integer :: i
    do i=1,natm
       imdtyp(i) = 0
       imdtypxyz(i,1) = 0
       imdtypxyz(i,2) = 0
       imdtypxyz(i,3) = 0
    enddo
  end subroutine m_IS_freeze

  subroutine m_IS_gdiis_dealloc(if_allocated)
    integer, intent(out) :: if_allocated
    deallocate(ip);  deallocate(forc_g);   deallocate(etot_trial)
    deallocate(ww1);   deallocate(e_wk);    deallocate(f_rslv)
    deallocate(f_wk);   deallocate(g);     deallocate(f_gdiis)
    deallocate(ncrspd);   deallocate(fc_l);    deallocate(w_l)
    deallocate(u_l)
    if_allocated = 0
  end subroutine m_IS_gdiis_dealloc

  subroutine m_IS_wd_speciesname_etc(nfdynm)
    integer, intent(in) :: nfdynm
    integer :: i
    if(mype == 0) then
       write(nfdynm,'("#")')
       write(nfdynm,'("#   a_vector = ",3f20.10)') altv(1:3,1)
       write(nfdynm,'("#   b_vector = ",3f20.10)') altv(1:3,2)
       write(nfdynm,'("#   c_vector = ",3f20.10)') altv(1:3,3)
       write(nfdynm,'("#   ntyp = ",i8, " natm = ",i8)') ntyp, natm
       write(nfdynm,'("# (natm->type) ",10i5)') (ityp(i),i=1,natm)
       do i = 1, ntyp
          write(nfdynm,'("# (speciesname) ",i5," :   ", a4)') i,speciesname(i)
       end do
       write(nfdynm,'("#")')
    end if
  end subroutine m_IS_wd_speciesname_etc

  subroutine m_IS_rd_pos_and_v(nfcntn)
    integer, intent(in) :: nfcntn
    integer             :: i, k, natm_t
    logical             :: tag_is_found, EOF_reach
    if(mype==0)then
       call rewind_to_tag0(nfcntn,len(tag_ionic_system),tag_ionic_system &
            &, EOF_reach, tag_is_found, str,len_str)
       if(.not.tag_is_found) then
          stop ' tag_ionic_system is not found'
       else
          read(nfcntn,*)
          read(nfcntn,*) natm_t
       endif
    endif
    if(npes>1)then
       call mpi_bcast(natm_t,1 &
            & ,mpi_integer,0,mpi_comm_group,ierr)
    endif
    if(natm_t.ne.natm)then
       if(printable)then
          write(nfout,'(a)') ' !** natm_t .ne. natm'
       endif
       natmorg = natm
       natm = natm_t
       call m_IS_dealloc_pos_and_v(nfout)
       call m_IS_alloc_pos_and_v(nfout)
       if(mype==0)then
          call rewind_to_tag0(nfcntn,len(tag_ionic_system_attributes),tag_ionic_system_attributes &
               &, EOF_reach, tag_is_found, str,len_str)
          read(nfcntn,*) &
         & (iwei(i),imdtyp(i),ityp(i),if_pdos(i),if_aldos(i),ihubbard(i), &
         & iproj_group(i),numlay(i),imdtypxyz(i,1:3),i=1,natm)
          natm2 = 0
          do i=1,natm
             natm2 = natm2+iwei(i)
          enddo
       endif
       if(npes>1)then
          call mpi_bcast(natm2,1,mpi_integer,0,mpi_comm_group,ierr)
          call mpi_bcast(iwei,natm,mpi_integer,0,mpi_comm_group,ierr)
          call mpi_bcast(imdtyp,natm,mpi_integer,0,mpi_comm_group,ierr)
          call mpi_bcast(ityp,natm,mpi_integer,0,mpi_comm_group,ierr)
          call mpi_bcast(if_pdos,natm,mpi_integer,0,mpi_comm_group,ierr)
          call mpi_bcast(if_aldos,natm,mpi_integer,0,mpi_comm_group,ierr)
          call mpi_bcast(ihubbard,natm,mpi_integer,0,mpi_comm_group,ierr)
          call mpi_bcast(iproj_group,natm,mpi_integer,0,mpi_comm_group,ierr)
          call mpi_bcast(numlay,natm,mpi_integer,0,mpi_comm_group,ierr)
       endif
       if(printable)then
          write(nfout,'(a,i8,a,i8)') ' !** natm : ',natm,' natm2 ',natm2
       endif
    endif

    if(mype==0) then
       call rewind_to_tag0(nfcntn,len(tag_ionic_system),tag_ionic_system &
            &, EOF_reach, tag_is_found, str,len_str)
       if(.not.tag_is_found) then
          stop ' tag_ionic_system is not found'
       else
          read(nfcntn,*)
          read(nfcntn,*) natm_t
          read(nfcntn,*)
          read(nfcntn,*) (pos(i,1),pos(i,2),pos(i,3),i=1,natm_t)
          read(nfcntn,*)
          read(nfcntn,*) (cps(i,1),cps(i,2),cps(i,3),i=1,natm_t)
          read(nfcntn,*)
          read(nfcntn,*) (cpd_l(i,1),cpd_l(i,2),cpd_l(i,3),i=1,natm_t)
          do k = 1, 3
             read(nfcntn,*)
             read(nfcntn,*) (cpo_l(i,1,k),cpo_l(i,2,k),cpo_l(i,3,k),i=1,natm_t)
          end do
       end if
       if(imdalg == QUENCHED_CONSTRAINT) then
          call rewind_to_tag0(nfcntn,len(tag_forcmx_const),tag_forcmx_const &
               &,  EOF_reach, tag_is_found, str, len_str)
          if(.not.tag_is_found) then
             forcmx_constraint_quench= forcmx_constraint_quench-1
          else
             read(nfcntn,*) forcmx_constraint_quench
          end if
       end if
       if(sw_optimize_lattice==ON)then
          call rewind_to_tag0(nfcntn,len(tag_lattice_vector),tag_lattice_vector &
               &,  EOF_reach, tag_is_found, str, len_str)
          if(tag_is_found)then
             read(nfcntn,*) altv(1,1),altv(2,1),altv(3,1)
             read(nfcntn,*) altv(1,2),altv(2,2),altv(3,2)
             read(nfcntn,*) altv(1,3),altv(2,3),altv(3,3)
          endif
       endif
    end if

    if(npes > 1) then
       call mpi_bcast(pos,natm*3 &
            & ,mpi_double_precision,0,mpi_comm_group,ierr)
       call mpi_bcast(cps,natm*3 &
            & ,mpi_double_precision,0,mpi_comm_group,ierr)
       call mpi_bcast(cpd_l,natm*3 &
            & ,mpi_double_precision,0,mpi_comm_group,ierr)
       call mpi_bcast(cpo_l,natm*3*3 &
            & ,mpi_double_precision,0,mpi_comm_group,ierr)
       call mpi_bcast(forcmx_constraint_quench,1 &
            & ,mpi_double_precision,0,mpi_comm_group,ierr)
       if(sw_optimize_lattice==ON)then
          call mpi_bcast(altv,9,mpi_double_precision,0,mpi_comm_group,ierr)
       endif
    end if

    if(sw_optimize_lattice==ON)then
       call m_CS_altv_2_rltv()
    endif

    call m_IS_set_iatom(nfout)

    if(ipriinputfile >= 1 .and. printable) call wd_atom_list()

  contains
    subroutine wd_atom_list()
      integer :: i
      write(nfout,'(" wd_atom_list from m_Ionic_rd_pos_and_v")')
      if(ipriinputfile >= 3) then
         write(nfout,'(" !** === Atomic coordinates expressed in the internal system ===")')
         write(nfout,'(" !** id,  rx,    ry,    rz,    weight,  imdtyp, ityp,  species")')
         do i = 1, natm
            write(nfout,210) i,pos(i,1),pos(i,2),pos(i,3),iwei(i),imdtyp(i),ityp(i),species_indp(i)
         end do
210      format(' !** ',i5,3f18.10,i3,i6,i3,3x,a4)
         write(nfout,'(" !** === Atomic coordinates expressed in the cartesian system ===")')
         write(nfout,'(" !** id,  rx,    ry,    rz,    weight,  imdtyp, ityp,  species")')
         do i = 1, natm
!!$            write(nfout,210) i,cps(i,1),cps(i,2),cps(i,3),iwei(i),imdtyp(i),ityp(i),species_indp(i)
            write(nfout,210) i,cps(i,1),cps(i,2),cps(i,3),iwei(i),imdtyp(i),ityp(i),species_indp(i)
         end do
      else
         write(nfout,'(" !** === Atomic coordinates ==")')
         write(nfout,'(" !**   id  ( coordinates_in_Intrnal_sys  ) (  coordinates_in_Cartsian_system  ) weight    ityp")')
         write(nfout,'(" !**       (   rx         ry         rz  ) (    rx          ry          rz    )      imdtyp    species")')
         do i = 1, natm
!!$            write(nfout,211) i, pos(i,1:3), cps(i,1:3), iwei(i), imdtyp(i), ityp(i), species_indp(i)
            write(nfout,211) i, pos(i,1:3), cps(i,1:3), iwei(i), imdtyp(i), ityp(i)
         end do
211      format(' !** ',i5,3f11.6,3f12.4,i3,i6,i3,3x,a4)
      end if

      do i = 1, ntyp
         write(nfout,'(" !** i = ",i5," element_name = ",a4)') i, speciesname(i)
      end do

    end subroutine wd_atom_list

  end subroutine m_IS_rd_pos_and_v

  subroutine m_IS_wd_pos_and_v(nfcntn)
    integer, intent(in) :: nfcntn
    integer             :: i, k
    if(iprimd >= 2) write(nfout,'(" tag_ionic_system")')
    if(mype==0) then
       write(nfcntn,*) tag_ionic_system
       write(nfcntn,'("  (natm)",/,i10)') natm
       write(nfcntn,'("  (pos)")')
       write(nfcntn,'(3d24.16)') (pos(i,1),pos(i,2),pos(i,3),i=1,natm)
       write(nfcntn,'("  (cps)")')
       write(nfcntn,'(3d24.16)') (cps(i,1),cps(i,2),cps(i,3),i=1,natm)
       write(nfcntn,'("  (cpd)")')
       write(nfcntn,'(3d24.16)') (cpd_l(i,1),cpd_l(i,2),cpd_l(i,3),i=1,natm)
       do k = 1, 3
          write(nfcntn,'("  (cpo(",i3,"))")') k
          write(nfcntn,'(3d24.16)') &
               & (cpo_l(i,1,k),cpo_l(i,2,k),cpo_l(i,3,k),i=1,natm)
       end do
       write(nfcntn,*) tag_forcmx_const
       write(nfcntn,'(d24.16)') forcmx_constraint_quench
       write(nfcntn,*) tag_ionic_system_attributes
       write(nfcntn,'(11i8)') &
      & (iwei(i),imdtyp(i),ityp(i),if_pdos(i),if_aldos(i),ihubbard(i), &
      & iproj_group(i),numlay(i),imdtypxyz(i,1:3),i=1,natm)
       if(sw_optimize_lattice==ON)then
          write(nfcntn,*) tag_lattice_vector
          write(nfcntn,'(3d24.16)') altv(1,1),altv(2,1),altv(3,1)
          write(nfcntn,'(3d24.16)') altv(1,2),altv(2,2),altv(3,2)
          write(nfcntn,'(3d24.16)') altv(1,3),altv(2,3),altv(3,3)
       endif
    endif

  end subroutine m_IS_wd_pos_and_v

  subroutine alloc_endpoint_pos(nfout)
    integer, intent(in) :: nfout
    allocate(pos_end0(natm,3))
    allocate(pos_end1(natm,3))
    allocate(cps_end0(natm,3))
    allocate(cps_end1(natm,3))
    if(printable) write(nfout,'(" !** pos_end0, pos_end1, cps_end0, and cps_end1 are allocated "&
         & ," <<alloc_endpoint_pos>>")')
  end subroutine alloc_endpoint_pos

  subroutine m_IS_alloc_pos_and_v(nfout)
    integer, intent(in) :: nfout
    allocate(iwei(natm)); iwei = 1
    allocate(imdtyp(natm)); imdtyp = 0
    allocate(imdtypxyz(natm,3));imdtypxyz = 0
    allocate(ityp(natm)); ityp = 1
#ifndef _EMPIRICAL_
    allocate(if_pdos(natm)); if_pdos = 1
    allocate(if_aldos(natm)); if_aldos = 1
    allocate(ihubbard(natm)); ihubbard = 0
    allocate(iproj_group(natm)); iproj_group = 0

! ============================ added by K. Tagami ================== 11.0
    allocate(itab_spinorbit_addition(natm))
    itab_spinorbit_addition = 0
! ================================================================== 11.0
#endif
    allocate(ionic_mass(natm)); ionic_mass = -1.d0
    allocate(pos(natm,3))
    allocate(cps(natm,3))
    if(.not.allocated(cpd_l)) then
       allocate(cpd_l(natm,3));   cpd_l = 0.d0
    endif
    allocate(cpo_l(natm,3,3)); cpo_l = 0.d0
    allocate(numlay(natm)); numlay = 1
    allocate(pos_in(natm,3))
    allocate(cps_in(natm,3))
    if(sw_atom_excludable == ON)then
        allocate(exclusion_target(natm));exclusion_target = 0
        exclusion_criteria_min(:) = -1.e+30 ! we don't want to exclude atoms unless explicitly specified
        exclusion_criteria_max(:) = +1.e+30
    endif
    if(sw_extrapolate_charge==ON.or.sw_wf_predictor==ON)then
       allocate(cps_history(natm,3,3));cps_history=0.d0
    endif

! === KT_add === 2014/12/29
#ifdef INIT_CHARGE_ATOM_BY_ATOM
    allocate( ionic_charge_atoms(natm) ); ionic_charge_atoms = -100.0d0
    if ( noncol ) then
       allocate( mag_moment0_atoms(natm,3) ); mag_moment0_atoms = -100.0
    else
       allocate( mag_moment0_atoms(natm,1) ); mag_moment0_atoms = -100.0
    endif
    if ( noncol ) then
       allocate( mag_direction0_atoms(natm,3) ); mag_direction0_atoms = 0.0d0
    endif
#endif
! ============== 2014/12/29

    if(ipri >= 3 .and. printable) write(nfout,'(" !** natm = ",i6," <<m_IS_alloc_pos_and_v>>")') natm
    call forcp_alloc()
  end subroutine m_IS_alloc_pos_and_v
  
  subroutine m_IS_dealloc_pos_and_v(nfout)
    integer, intent(in) :: nfout
    integer :: i
    deallocate(iwei)
    deallocate(imdtyp)
    deallocate(imdtypxyz)
    deallocate(ityp)
    deallocate(if_pdos)
    deallocate(if_aldos)
    deallocate(ihubbard)
    deallocate(iproj_group)

! =========================== added by K. Tagami ================= 11.0
    deallocate( itab_spinorbit_addition )
! ================================================================= 11.0
    deallocate(ionic_mass)
    deallocate(pos)
    deallocate(cps)
    if(sw_extrapolate_charge==ON.or.sw_wf_predictor==ON) deallocate(cps_history)
    deallocate(pos_in)
    deallocate(cps_in)
!    deallocate(cpd_l)
    deallocate(cpo_l)
    deallocate(numlay)
    if(sw_atom_excludable==ON) deallocate(exclusion_target)

! === KT_add === 2014/12/29
#ifdef INIT_CHARGE_ATOM_BY_ATOM
    deallocate( ionic_charge_atoms )
    deallocate( mag_moment0_atoms )
    if ( noncol ) deallocate( mag_direction0_atoms )
#endif
! ============== 2014/12/29
    if(num_regions>0) then
       do i=1,num_regions
          deallocate(regions(i)%forc)
          deallocate(regions(i)%target_atoms)
       enddo
       deallocate(regions)
    endif
  end subroutine m_IS_dealloc_pos_and_v

! === KT_add === 2014/12/29 & 13.2S
#ifdef INIT_CHARGE_ATOM_BY_ATOM
  subroutine m_IS_set_ionic_charge_atoms(nfout)
    integer, intent(in) :: nfout

    integer :: ia, it

    if ( .not. mag_moment0_atoms_is_defined ) return

    do ia = 1,natm
       if ( ionic_charge_atoms(ia) < -99.d0 ) then
          it = ityp(ia)
          ionic_charge_atoms(ia) = ionic_charge_atomtyp(it)
       endif
    end do

  end subroutine m_IS_set_ionic_charge_atoms

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

    integer :: ia, it

    if ( .not. mag_moment0_atoms_is_defined ) return

    do ia = 1,natm
       if ( mag_moment0_atoms(ia,1) < -99.d0 ) then
          it = ityp(ia)
          if ( noncol ) then
             mag_moment0_atoms(ia,1:3) = mag_moment0_atomtyp(it,1:3)
          else
             mag_moment0_atoms(ia,1) = mag_moment0_atomtyp(it,1)
          endif
       endif
    end do

    if ( noncol ) then
       write(nfout,*) '! ------------ Initial Charge/Magnetic Moment (atoms) --- '
       write(nfout,*) '     id     name       ion         mx          my          mz'
       Do ia=1, natm
          it = ityp(ia)
          write(nfout,'(I8,3X,A7,4F12.6)') ia, speciesname(it), &
               &                         ionic_charge_atoms(ia), &
               &                         mag_moment0_atoms(ia,1), &
               &                         mag_moment0_atoms(ia,2), &
               &                         mag_moment0_atoms(ia,3)
       End Do
    else if ( sw_fix_global_quantz_axis == ON ) then
       write(nfout,*) '! ------------ Initial Charge/Magnetic Moment (atoms) --- '
       write(nfout,*) '     id     name       ion         mx          my          mz'
       Do ia=1, natm
          it = ityp(ia)
          write(nfout,'(I8,3X,A7,4F12.6)') ia, speciesname(it), &
               &           ionic_charge_atoms(ia), &
               &           mag_moment0_atoms(ia,1) *Global_Quantz_Axis_Fixed(1), &
               &           mag_moment0_atoms(ia,1) *Global_Quantz_Axis_Fixed(2), &
               &           mag_moment0_atoms(ia,1) *Global_Quantz_Axis_Fixed(3)
       End Do
    else
       write(nfout,*) '! ------------ Initial Charge/Magnetic Moment (atoms) --- '
       write(nfout,*) '     id     name       ion        moment '
       Do ia=1, natm
          it = ityp(ia)
          write(nfout,'(I8,3X,A7,2F12.6)') ia, speciesname(it), &
               &                         ionic_charge_atoms(ia), &
               &                         mag_moment0_atoms(ia,1)
       End Do
    endif

    write(nfout,*) '! ---------------------------------------------'

  end subroutine m_IS_set_mag_moment0_atoms
#endif
! ================= 2014/12/29

! ====== KT_add === 2014/06/10
  subroutine m_IS_reassgin_thermog
    integer :: i, ia, num
    integer, save :: ithermo_old = 1
    real(kind=DP) :: c1, c2, temp_now

    ithermo_now = 1

    if ( iteration_ionic > mdstep_at_end_thermostat(nrsv) ) then
       ithermo_now = nrsv
    else
       Do i=1, nrsv
          if ( iteration_ionic <= mdstep_at_end_thermostat(i) ) then
             ithermo_now = i
             exit
          endif
       End Do
    endif
!
    if ( ithermo_now /= ithermo_old ) then
       write(nfout,*) '***** Thermo group is changed to ', ithermo_now
    endif
    ithermo_old = ithermo_now

    num = 0
    Do ia=1, natm
       if (imdtyp(ia) > NOSE_HOOVER ) then
          imdtyp(ia) = NOSE_HOOVER + ithermo_now
          num = num +1
       end if
    End Do
    natm_per_thermo = 0
    natm_per_thermo(ithermo_now) = num
!
    c1 = iteration_ionic -mdstep_at_start_thermostat(ithermo_now)
    c2 = mdstep_at_end_thermostat(ithermo_now) -iteration_ionic
!
    temp_now = temp_at_end_thermostat(ithermo_now) *c1 &
         &   + temp_at_start_thermostat(ithermo_now) *c2
    temp_now = temp_now /( c2+c1)
!
    write(nfout,*) "!** temperature is now ", temp_now , " K"

    tkb(ithermo_now) = temp_now *const_KB
    if ( qmass(ithermo_now) < 1.0D-4 ) then
       qmass(ithermo_now) = (2.d0*3.d0*natm_per_thermo(ithermo_now)*(tdamp/PAI2)**2) &
            &             *tkb(ithermo_now)
    endif

  end subroutine m_IS_reassgin_thermog
! =============== 2014/06/10

  subroutine m_IS_recover(n,exclude)
    integer, intent(in) :: n
    logical, dimension(n), intent(in) :: exclude
    integer :: i,ii
    ii=0
    do i=1,n
       if(exclude(i)) cycle
       ii=ii+1
       iwei(ii) = config_buf(i)%iwei 
       imdtyp(ii) = config_buf(i)%imdtyp 
       imdtypxyz(ii,:) = config_buf(i)%imdtypxyz(:)
       ityp(ii) = config_buf(i)%ityp 
       if_pdos(ii) = config_buf(i)%if_pdos 
       if_aldos(ii) = config_buf(i)%if_aldos 
       ihubbard(ii) = config_buf(i)%ihubbard 
       iproj_group(ii) = config_buf(i)%iproj_group 
       ionic_mass(ii) = config_buf(i)%ionic_mass 
       numlay(ii) = config_buf(i)%numlay 
       if(sw_atom_excludable==ON) exclusion_target(ii) = config_buf(i)%exclusion_target
       pos(ii,:)  = config_buf(i)%pos(:)
       cps(ii,:) = config_buf(i)%cps(:)
       pos_in(ii,:) = config_buf(i)%pos_in(:)
       cps_in(ii,:) = config_buf(i)%cps_in(:)
       cpd_l(ii,:) = config_buf(i)%cpd_l(:) 
       cpo_l(ii,:,:) = config_buf(i)%cpo_l(:,:)
    enddo
  end subroutine m_IS_recover

  subroutine m_IS_store_current_config()
    integer :: i
    if(allocated(config_buf)) deallocate(config_buf)
    allocate(config_buf(natm))
    nconfig_buf = natm
    do i=1,natm
       !config_buf(i)%element = species_work(i)
       config_buf(i)%iwei = iwei(i)
       config_buf(i)%imdtyp = imdtyp(i)
       config_buf(i)%imdtypxyz(:) = imdtypxyz(i,:)
       config_buf(i)%ityp = ityp(i)
       config_buf(i)%if_pdos = if_pdos(i)
       config_buf(i)%if_aldos = if_aldos(i)
       config_buf(i)%ihubbard = ihubbard(i)
       config_buf(i)%iproj_group = iproj_group(i)
       config_buf(i)%ionic_mass = ionic_mass(i)
       config_buf(i)%numlay = numlay(i)
       config_buf(i)%pos(:) = pos(i,:)
       config_buf(i)%cps(:) = cps(i,:)
       config_buf(i)%pos_in(:) = pos_in(i,:)
       config_buf(i)%cps_in(:) = cps_in(i,:)
       config_buf(i)%cpd_l(:) = cpd_l(i,:)
       config_buf(i)%cpo_l(:,:) = cpo_l(i,:,:)
       !config_buf(i)%nvalence = ival(ityp(i))
    enddo
  end subroutine m_IS_store_current_config

  logical function m_IS_change_natm()
     integer :: i
     m_IS_change_natm = .false.
     if(.not.m_IS_natm_can_change()) return
     natmorg = natm
     if(sw_atom_excludable==ON)then
        do i=1,natm
           if(out_of_bounds(i))then
               if(printable) then
                  write(nfout,'(a,i8,a)') ' !** atom no ',i,'is out of bounds, and will be excluded.'
               endif
               call m_IS_remove_atom(i)
           endif
        enddo
     endif
     if(mod(iteration_ionic,addition_frequency)==0.and.icond/=CONTINUATION)then
        neg_incre = 0
        if(natom_reservoir<curr_atom_reservoir) then
           if(printable .and. iprimd>=1) write(nfout,'(a)') ' !** atom reservoir exhausted.'
        else
           if(printable .and. iprimd>=1) then
              write(nfout,'(a)') ' !** adding new atom(s) from the atom reservoir'
              write(nfout,'(a)') ' !** element fracx fracy fracz cartx carty cartz'
              do i=1,natm_per_group(curr_atom_reservoir)
                 call print_atom(atom_reservoir(atomid_in_group(curr_atom_reservoir,i)))
              enddo
           endif
           do i=1,natm_per_group(curr_atom_reservoir)
              call m_IS_add_atom(atom_reservoir(atomid_in_group(curr_atom_reservoir,i)))
           enddo
           curr_atom_reservoir = curr_atom_reservoir+1
           if(curr_atom_reservoir>natom_group .and. sw_rotate_reservoir==ON) curr_atom_reservoir = 1
           m_IS_change_natm = .true.
        endif
     endif
  end function m_IS_change_natm

  logical function out_of_bounds(iatom)
     integer, intent(in) :: iatom
     integer :: ii
     out_of_bounds = .false.
     do ii=1,3
        if (cps(iatom,ii) .lt. exclusion_criteria_min(ii) ) out_of_bounds = .true.
        if (cps(iatom,ii) .gt. exclusion_criteria_max(ii) ) out_of_bounds = .true.
        if (out_of_bounds) return
     enddo
  end function out_of_bounds

  subroutine m_IS_wd_curr_atom_reservoir(nfcntn)
     integer, intent(in) :: nfcntn
     if(mype==0)then
        write(nfcntn,*) tag_curr_atom_reservoir
        write(nfcntn,'(i8)') curr_atom_reservoir
     endif
  end subroutine m_IS_wd_curr_atom_reservoir

  subroutine m_IS_rd_curr_atom_reservoir(nfcntn)
     integer, intent(in) :: nfcntn
     logical             :: EOF_reach, tag_is_found
     if(mype==0)then
        call rewind_to_tag0(nfcntn,len(tag_curr_atom_reservoir),tag_curr_atom_reservoir & 
     &  , EOF_reach, tag_is_found,str,len_str)
        if(.not.tag_is_found) then
           curr_atom_reservoir = 1
        else
           read(nfcntn,*) curr_atom_reservoir
        endif
     endif
     if(npes>1) call mpi_bcast(curr_atom_reservoir,1,mpi_integer,0,mpi_comm_group,ierr)
  end subroutine m_IS_rd_curr_atom_reservoir

  integer function m_IS_get_neg_incre()
     m_IS_get_neg_incre = neg_incre
     neg_incre=0
  end function m_IS_get_neg_incre

  logical function m_IS_natm_can_change()
    integer :: i
    if(sw_atom_excludable==ON) then
       do i=1,natm
          if(out_of_bounds(i))then
             m_IS_natm_can_change = .true.
             return
          endif
       enddo
    endif
    if(allocated(atom_reservoir) .and. natom_reservoir.gt.0 .and. addition_frequency.gt.1)then
       if(natom_reservoir>=curr_atom_reservoir) then
          m_IS_natm_can_change = .true.
          return
       endif
    endif
    m_IS_natm_can_change = .false.
  end function

  subroutine m_IS_set_ival(nt,iv)
     integer, intent(in) :: nt
     real(kind=DP), dimension(nt),intent(in) :: iv
     integer :: i
     if(.not.allocated(ival)) allocate(ival(nt))
     ival = iv
     if(natom_reservoir>0)then
        do i=1,natom_reservoir
           atom_reservoir(i)%nvalence = ival(atom_reservoir(i)%ityp)
           call print_atom(atom_reservoir(i))
        enddo
     endif
  end subroutine m_IS_set_ival

  subroutine init_atom(i,theatom)
    integer, intent(in) :: i
    type(atomic_configuration_t),intent(inout) :: theatom
    theatom%id = i
    theatom%element = ''
    theatom%group = -1
    theatom%iwei = 1
    theatom%imdtyp = 0
    theatom%imdtypxyz = 0
    theatom%ityp = 1
    theatom%if_pdos = 1
    theatom%if_aldos = 1
    theatom%ihubbard = 0
    theatom%iproj_group = 0
    theatom%exclusion_target = 0
    theatom%ionic_mass = -1.d0
    theatom%numlay = 1
    theatom%pos = 0.0d0
    theatom%cps = 0.0d0
    theatom%pos_in = 0.0d0
    theatom%cps_in = 0.0d0
    theatom%cpd_l = 0.0d0
    theatom%cpo_l = 0.0d0
    theatom%nvalence = 0
  end subroutine init_atom

  subroutine print_atom(theatom)
    type(atomic_configuration_t),intent(in) :: theatom
    integer :: i
    if(printable)then
        write(nfout,'(a,i8,i3,6f10.5,f5.1,i3)') '    '//trim(theatom%element),theatom%id,theatom%ityp,&
       & (theatom%pos(i),i=1,3),(theatom%cps(i),i=1,3),theatom%nvalence,theatom%group
    endif
  end subroutine print_atom

  subroutine resolve_dftd3_parameters()
    integer :: ierr
    integer, parameter     :: len_str = 132
    character(len=len_str) :: str
    logical :: tag_is_found, EOF_reach
    integer :: i,j,ii,jj,kk,ll,ntmp
    real(kind=DP) :: val1,val2,val3
    dftd3par%k1 = 16.d0
    dftd3par%k2 = 4.d0/3.d0
    dftd3par%k3 = 4.d0
    dftd3par%s6 = 1.d0
    dftd3par%alpha6 = 14.d0
    dftd3par%alpha8 = 16.d0
    dftd3par%sr8 = 1.d0
!   parameters for PBE
    dftd3par%s8 = 0.722d0
    dftd3par%sr6 = 1.217d0
    dftd3par%sr9 = 4.d0/3.d0
    dftd3par%alpha9 = 16.d0
    if (xctype == 'revpbe') then
    dftd3par%s8 = 1.010d0
    dftd3par%sr6 = 0.923d0
    else if (xctype == 'rpbe  ') then
    dftd3par%s8 = 0.514d0
    dftd3par%sr6 = 0.872d0
    else if (xctype == 'pbe0  ') then
    dftd3par%s8 = 0.928d0
    dftd3par%sr6 = 1.287d0
    else if (xctype == 'hse06 ') then
    dftd3par%s8 = 0.109d0
    dftd3par%sr6 = 1.129d0
    endif

    dftd3par%rcut_nc = 20.d0
    dftd3par%rcut_vdw = 40.d0
    call m_Files_open_dftd3par()
    if(mype == 0)then
      call rewind_to_tag0(nfdftd3par,len('nlines'),'nlines' &
     & , EOF_reach, tag_is_found, str, len_str)
      read(nfdftd3par,*) dftd3par%nlines
      call rewind_to_tag0(nfdftd3par,len('max_elem'),'max_elem' &
     & , EOF_reach, tag_is_found, str, len_str)
      read(nfdftd3par,*) dftd3par%maxelem
      call rewind_to_tag0(nfdftd3par,len('maxmaxnc'),'maxmaxnc' &
     & , EOF_reach, tag_is_found, str, len_str)
      read(nfdftd3par,*) dftd3par%maxmaxnc
    endif
    if(npes>1)then
       call mpi_bcast(dftd3par%nlines,1,mpi_integer,0,mpi_comm_group,ierr)
       call mpi_bcast(dftd3par%maxelem,1,mpi_integer,0,mpi_comm_group,ierr)
       call mpi_bcast(dftd3par%maxmaxnc,1,mpi_integer,0,mpi_comm_group,ierr)
    endif
    allocate(dftd3par%c6ab(dftd3par%maxelem,dftd3par%maxelem,dftd3par%maxmaxnc,dftd3par%maxmaxnc))
    allocate(dftd3par%nc1 (dftd3par%maxelem,dftd3par%maxelem,dftd3par%maxmaxnc,dftd3par%maxmaxnc))
    allocate(dftd3par%nc2 (dftd3par%maxelem,dftd3par%maxelem,dftd3par%maxmaxnc,dftd3par%maxmaxnc))
    dftd3par%c6ab=0.d0;dftd3par%nc1=0.d0;dftd3par%nc2=0.d0
    allocate(dftd3par%maxnc(dftd3par%maxelem));dftd3par%maxnc=0
    allocate(dftd3par%r2r4(dftd3par%maxelem));dftd3par%r2r4=0.d0
    allocate(dftd3par%covrad(dftd3par%maxelem));dftd3par%covrad=0.d0
    allocate(dftd3par%r0ab(dftd3par%maxelem,dftd3par%maxelem));dftd3par%r0ab=0.d0
    if(mype == 0)then
      call rewind_to_tag0(nfdftd3par,len('maxnc'),'maxnc' &
     & , EOF_reach, tag_is_found, str, len_str)
      do i=1,dftd3par%maxelem
         read(nfdftd3par,*) dftd3par%maxnc(i)
      enddo
      call rewind_to_tag0(nfdftd3par,len('r0ab'),'r0ab' &
     & , EOF_reach, tag_is_found, str, len_str)
      do i=1,dftd3par%maxelem
      do j=1,dftd3par%maxelem
         read(nfdftd3par,*) ii,jj,dftd3par%r0ab(i,j)
      enddo
      enddo
      call rewind_to_tag0(nfdftd3par,len('covrad'),'covrad' &
     & , EOF_reach, tag_is_found, str, len_str)
      do i=1,dftd3par%maxelem
         read(nfdftd3par,*) dftd3par%covrad(i)
      enddo
      call rewind_to_tag0(nfdftd3par,len('r2r4'),'r2r4' &
     & , EOF_reach, tag_is_found, str, len_str)
      do i=1,dftd3par%maxelem
         read(nfdftd3par,*) dftd3par%r2r4(i)
      enddo
    endif
    if(npes>1)then
       call mpi_bcast(dftd3par%maxnc,dftd3par%maxelem,mpi_integer,0,mpi_comm_group,ierr)
       call mpi_bcast(dftd3par%r0ab,dftd3par%maxelem*dftd3par%maxelem,mpi_double_precision,0,mpi_comm_group,ierr)
       call mpi_bcast(dftd3par%covrad,dftd3par%maxelem,mpi_double_precision,0,mpi_comm_group,ierr)
       call mpi_bcast(dftd3par%r2r4,dftd3par%maxelem,mpi_double_precision,0,mpi_comm_group,ierr)
    endif
    if(mype == 0)then
      call rewind_to_tag0(nfdftd3par,len('c6ab'),'c6ab' &
     & , EOF_reach, tag_is_found, str, len_str)
      do i=1,dftd3par%nlines
         read(nfdftd3par,*) val1,ii,jj,kk,ll,val2,val3
         dftd3par%c6ab(ii,jj,kk,ll) = val1
         dftd3par%c6ab(jj,ii,ll,kk) = val1

         dftd3par%nc1(ii,jj,kk,ll) = val2
         dftd3par%nc1(jj,ii,ll,kk) = val3

         dftd3par%nc2(ii,jj,kk,ll) = val3
         dftd3par%nc2(jj,ii,ll,kk) = val2
      enddo
    endif
    if(npes>1)then
       ntmp = size(dftd3par%c6ab)
       call mpi_bcast(dftd3par%c6ab,ntmp,mpi_double_precision,0,mpi_comm_group,ierr)
       call mpi_bcast(dftd3par%nc1 ,ntmp,mpi_double_precision,0,mpi_comm_group,ierr)
       call mpi_bcast(dftd3par%nc2 ,ntmp,mpi_double_precision,0,mpi_comm_group,ierr)
    endif
  end subroutine resolve_dftd3_parameters

  subroutine read_dftd3_parameters()
    integer :: iret
    real(kind=DP) :: dret
    integer :: f_selectBlock, f_selectParentBlock, f_getRealValue
    if(f_selectBlock('dftd3') == 0) then
       if(f_getRealValue(tag_k1,dret,'') == 0)       dftd3par%k1 = dret
       if(f_getRealValue(tag_k2,dret,'') == 0)       dftd3par%k2 = dret
       if(f_getRealValue(tag_k3,dret,'') == 0)       dftd3par%k3 = dret
       if(f_getRealValue(tag_s6,dret,'') == 0)       dftd3par%s6 = dret
       if(f_getRealValue(tag_s8,dret,'') == 0)       dftd3par%s8 = dret
       if(f_getRealValue(tag_sr6,dret,'bohr') == 0)  dftd3par%sr6 = dret
       if(f_getRealValue(tag_sr8,dret,'bohr') == 0)  dftd3par%sr8 = dret
       if(f_getRealValue(tag_alpha6,dret,'') == 0)   dftd3par%alpha6 = dret
       if(f_getRealValue(tag_alpha8,dret,'') == 0)   dftd3par%alpha8 = dret
       if(f_getRealValue(tag_rcut,dret,'bohr') == 0) dftd3par%rcut_vdw = dret
       iret = f_selectParentBlock() 
    endif
    if(printable)then
       write(nfout,'(a)')       ' !** dftd3 parameters'
       write(nfout,'(a,d15.5)') ' !** k1     ', dftd3par%k1
       write(nfout,'(a,d15.5)') ' !** k2     ', dftd3par%k2
       write(nfout,'(a,d15.5)') ' !** k3     ', dftd3par%k3
       write(nfout,'(a,d15.5)') ' !** s6     ', dftd3par%s6
       write(nfout,'(a,d15.5)') ' !** s8     ', dftd3par%s8
       write(nfout,'(a,d15.5)') ' !** sr6    ', dftd3par%sr6
       write(nfout,'(a,d15.5)') ' !** sr8    ', dftd3par%sr8
       write(nfout,'(a,d15.5)') ' !** alpha6 ', dftd3par%alpha6
       write(nfout,'(a,d15.5)') ' !** alpha8 ', dftd3par%alpha8
       write(nfout,'(a,d15.5)') ' !** rcut   ', dftd3par%rcut_vdw
    endif
  end subroutine read_dftd3_parameters

  subroutine alloc_species_work()
    allocate(species_work(natm)); species_work = ""
    allocate(species_indp(natm)); species_indp = ""
  end subroutine alloc_species_work

  subroutine dealloc_species_work()
    if(allocated(species_work)) deallocate(species_work)
    if(allocated(species_indp)) deallocate(species_indp)
  end subroutine dealloc_species_work

  subroutine alloc_speciesname()
    allocate(speciesname(ntyp)); speciesname=''
  end subroutine alloc_speciesname

  subroutine dealloc_speciesname()
    if(allocated(speciesname)) deallocate(speciesname)
  end subroutine dealloc_speciesname

  subroutine alloc_species_vdw_work()
    allocate(species_vdw_work(natm)); species_vdw_work = ""
    allocate(species_vdw_indp(natm)); species_vdw_indp = ""
  end subroutine alloc_species_vdw_work

  subroutine dealloc_species_vdw_work()
    if(allocated(species_vdw_work)) deallocate(species_vdw_work)
    if(allocated(species_vdw_indp)) deallocate(species_vdw_indp)
  end subroutine dealloc_species_vdw_work

  subroutine alloc_speciesname_vdw()
    allocate(speciesname_vdw(ntyp_vdw))
    speciesname_vdw(1:ntyp_vdw) = species_vdw_indp(1:ntyp_vdw)
  end subroutine alloc_speciesname_vdw

! ================================= KT_add ================ 13.0B
  subroutine dealloc_speciesname_vdw()
    if ( allocated(speciesname_vdw) ) deallocate(speciesname_vdw)
  end subroutine dealloc_speciesname_vdw
! ========================================================= 13.0B

  subroutine m_IS_cp_cps2cpo
    cpo_l(1:natm,1:3,1) = cps
  end subroutine m_IS_cp_cps2cpo

  subroutine m_IS_cp_cps2cpo3
    cpo_l(1:natm,1:3,3) = cps
  end subroutine m_IS_cp_cps2cpo3

  subroutine m_IS_rd_atomic_coordinates(nfinp,nfout,work,ia_cnst_work, fcvect_work)
    integer, intent(in)  :: nfinp, nfout
    real(kind=DP), intent(out), dimension(*) :: work
    integer, intent(out)  :: ia_cnst_work(natm)
    real(kind=DP), intent(out) :: fcvect_work(natm,4)

    integer          :: i, imdt, incunt
    real(kind=DP)    :: v
    real(kind=DP),allocatable,dimension(:,:) :: rltv_t

    if(printable) then
       write(nfout,'(" !! << read_atomic_coordinates >>")')
       write(nfout,'(" !! nfinp = ",i6)') nfinp
    end if
    nfcatm = 0
    if(printable) write(nfout,'(" ! -- natm = ",i6)') natm
!!$    read(nfinp,'(a132)') str
!!$    write(nfout,'(" !! str = ",a132," <<read_atomic_coordinates>>")') str
!!$    backspace nfinp
!!$    call cnstr_fcvect_work_alloc    ! -(InputData_Analysis) ->ia_cnst_work, fcvect_work
    do i = 1, natm
!!$       read(nfinp,'(a132)') str
!!$       write(nfout,'(" str = ",a132," i= ",i5)') str,i
!!$       call chnnm(str,len_str,NWK,work,incunt)
!!$       pos(i,1) = work(1); pos(i,2) = work(2); pos(i,3) = work(3)
!!$       iwei(i) = nint(work(4)); imdtyp(i) = nint(work(5)); ityp(i) = nint(work(6))
       read(nfinp,*) pos(i,1),pos(i,2),pos(i,3),iwei(i),imdtyp(i),ityp(i) 
       if(printable) write(nfout,210) pos(i,1),pos(i,2),pos(i,3),iwei(i),imdtyp(i),ityp(i)
!!$       do incunt = 1, 10
!!$          write(nfout,'(" !! incunt = ",i6)') incunt
!!$       end do
       imdt = imdtyp(i)
       if((imdt<HEAT_BATH .and. imdt/=FIX .and. imdt/=RELAX .and.imdt/=BONDLENGTH_FIX) &
            & .or.&
            & (imdt == HEAT_BATH+BONDLENGTH_FIX_1 .or. imdt == HEAT_BATH+BONDLENGTH_FIX_2 &
            &  .or. imdt == HEAT_BATH+COG_FIX_L)) then
          nfcatm = nfcatm + 1
          if(printable) write(nfout,*)' nfcatm = ', nfcatm
          ia_cnst_work(nfcatm) = i
          if(nfcatm == 1) then
             if(imdt > HEAT_BATH) then
                cnst_typ = imdt - HEAT_BATH
             else
                cnst_typ = imdt
             end if
          end if
          backspace nfinp
          read(nfinp,'(a132)') str
          call chnnm(str,len_str,10,work,incunt)
          if(incunt == 7) then
             fcvect_work(nfcatm,1) = work(7)
          else if(incunt >= 9) then
             if(input_coordinate_system == PUCV) then
                work(11:13) = matmul(altv,work(7:9))
             else if(input_coordinate_system == CARTS) then
                work(11:13) = work(7:9)
             end if
    !        ---> Normalization of directional vectors fcvect(*,1:3).
             v = dsqrt(dot_product(work(11:13),work(11:13)))
             fcvect_work(nfcatm,1:3) = work(11:13)/v

             if(incunt == 10) fcvect_work(nfcatm,4) = work(10)
             if(printable) write(nfout,9001) nfcatm &
                  &     ,fcvect_work(nfcatm,1),fcvect_work(nfcatm,2) &
                  &     ,fcvect_work(nfcatm,3),fcvect_work(nfcatm,4)
9001         format(' Fcvect(',i4,') = ',3f8.4, d20.8)
          endif
       endif
    enddo
210 format(' ',3f18.10,i3,i6,i3)

    if(input_coordinate_system == PUCV) then
       call change_of_coordinate_system(altv,pos,natm,natm,cps) !-(b_I.S.)
    else if(input_coordinate_system == CARTS) then
       cps = pos
       allocate(rltv_t(3,3))
       rltv_t = transpose(rltv)/PAI2
       call change_of_coordinate_system(rltv_t,cps,natm,natm,pos) !-(b_I.S.)
       deallocate(rltv_t)
    end if

    if(printable) write(nfout,*) ' ! nfcatm = ', nfcatm
    if(printable) write(nfout,*) ' ! cnst_typ = ', cnst_typ

!!$    call m_IS_init_cnstrnt(natm,fcvect_work)   ! ->sgmc

    if(printable) write(nfout,*) ' ! univol = ', univol
  end subroutine m_IS_rd_atomic_coordinates

  subroutine m_IS_md(mdalg,forc_l_in)
    integer, intent(in)     :: mdalg
    real(kind=DP), intent(in), dimension(natm,3) :: forc_l_in
    real(kind=DP), allocatable, dimension(:,:)   :: forc_l

    integer :: id_sname = -1
    integer :: i
    call tstatc0_begin('m_IS_md ',id_sname)

    call md1_alloc(mdalg)

    allocate(forc_l(natm,3))
    forc_l = forc_l_in

!!$    call check_if_bondlength_fix_exist(ibondlengthfix)
!!$    if(mdmode == ORDINA .and. nfcatm == 0 .and. ibondlengthfix == 0) then
    if(mdmode == ORDINA) then
! -- Following 3 lines have been revised by Mamoru Usami, Oct. 2004. -->>
       if (mdalg .ne. VERLET) then
          cpd_old = cpd_l
          if(iprimd >= 1) then
             write(nfout,'(" -- cpd_l, cpd_old (before evolve_velocities)--")')
             do i  = 1, natm
                write(nfout,'(i5,3f18.5)') i, cpd_l(i,1:3)
             end do
          end if
          call check_constraint(forc_l)  ! -> ipcpd,fcg,fcg_mdfy,tmass
          if(imdalg == STEEPEST_DESCENT .and. mode_fi_coefficient == OFF) then
             fi_coefficient = get_fi_coefficient(sqrt(sum(forc_l(1:natm,1:3)**2)))
             if(iprimd >= 1) write(nfout,'(a19,f20.10)') ' fi_coefficient =  ', fi_coefficient
          end if
!!$          if(constraint_type == FIXED_NORMAL_HYPERVECTOR) call modify_forc_fi(forc_l)
          if(constraint_type == FIXED_NORMAL_HYPERVECTOR) call modify_forc_hyperplane(forc_l)
          call evolve_velocities(mdalg,forc_l) !-(m_Ionic_System)  cpd_l = cpd_l + dtio/mass * forc_l
       end if

! <<--
       if(mdalg == QUENCHED_MD) call quench_velocities(forc_l) ! -->cpd_l

       if(constraint_type == COG_FIX_L) call correct_cog_motion()
       if(mdalg == VERLET .and. &
            &(nbztyp == HEXAGONAL .or. nbztyp == ORTHORHOMBIC .or. &
            & nbztyp >= HEX1fold)) then
          if(nopr_supercell <= nopr .or. sw_supercell_symmetry /= ON) then
             call fd_symmetrize(natm2,natm,natm,napt,nopr+af,nopr,op,iwei &
                  & , cpd_l, cpd_old, ipcpd)  ! -(b_Ionic_System) -->cpd_l
          else
!!$             call fd_symmetrize(natm2,natm,natm,napt_supercell,nopr_supercell,op,nopr+af,iwei &
!!$                  & , cpd_l, cpd_old, ipcpd, iop_supercell)  ! -(b_Ionic_System) -->cpd_l
             call fd_supercell_symmetrize(natm2,natm,natm,napt_supercell,nopr_supercell,op,nopr+af,iwei &
                  & , cpd_l, cpd_old, ipcpd, iop_supercell)
          end if

          if(iprimd >= 1) then
             write(nfout,'(" -- cpd_l, cpd_old (after fd_symmetrize) --")')
             do i  = 1, natm
                write(nfout,'(i5,6f18.5)') i, cpd_l(i,1:3),cpd_old(i,1:3)
             end do
          end if
       end if
       if(constraint_type /= BONDLENGTH_FIX) then
!!$          call evolve_cps()
          cps = cps + dtio*cpd_l
       else
          cpd_old = cpd_l
          call correct_fixed_bond() ! -> cpd_old, cps = cps+dtio*cpd_old, fcvect,cpd,cps
       end if

    else if(mdmode == CNSTRA) then
       call move_atoms_normal_to_plane()
    else
       stop ' Invalid value of mdmode <<m_IS_md>>'
    end if

    if (sw_shift_velocities==ON.and.mdalg==VERLET) call shift_velocities(1)
    deallocate(forc_l)
    call md1_dealloc()
    call tstatc0_end(id_sname)

  contains
    subroutine correct_fixed_bond()
      integer :: ib, ia1, ia2, i
      real(kind=DP) :: pdot, fac
      real(kind=DP),allocatable,dimension(:) :: frc3,frc4,frc1,frc2,cps1,cps2,fcv1,fcv2
      allocate(frc1(3));allocate(frc2(3));allocate(frc3(3));allocate(frc4(3))
      allocate(cps1(3));allocate(cps2(3));allocate(fcv1(3));allocate(fcv2(3))

      do ib = 1, num_fixed_bonds
         ia1 = bondlength_fix_set(1,ib); ia2 = bondlength_fix_set(2,ib)
         pdot = dot_product(forc_l(ia1,1:3)-forc_l(ia2,1:3), fcvect(ia1,1:3)) &
              & /fcvect(ia1,4)**2*0.5d0
         frc3=forc_l(ia1,1:3) - pdot*fcvect(ia1,1:3)
         frc4=forc_l(ia2,1:3) + pdot*fcvect(ia1,1:3)
         frc1=frc3+frc4
         frc2=frc3-frc4  ! frc2 = forc_l(ia1,:)-forc_l(ia2,:) - 2*pdot*fcvect(ia1,1:3)
         pdot = dot_product(frc2,fcvect(ia1,1:3))
         if(dabs(pdot) > 1.d-6) then
            if(iprimd >=1)then
               write(nfout,'(" !! frc2(:)       = ",3f12.6," <<correct_fixed_bond>>")') frc2
               write(nfout,'(" !! fcvect(ia1,:) = ",3f12.6," <<correct_fixed_bond>>")') fcvect(ia1,1:3)
            end if
            if(printable) write(nfout,'(" fcvect times frc2(pdot)=",d16.8)') pdot
            stop ' fcvect is not normal to frc2 <<m_IS_md.correct_fixed_bond>>'
         end if
         pdot = dot_product(cpd_old(ia1,:)-cpd_old(ia2,:),fcvect(ia1,1:3))/fcvect(ia1,4)**2*0.5d0
         cpd_old(ia1,:) = cpd_old(ia1,:) - pdot*fcvect(ia1,1:3)
         cpd_old(ia2,:) = cpd_old(ia2,:) + pdot*fcvect(ia1,1:3)
         cps1=cpd_old(ia1,:)+cpd_old(ia2,:)
         cps2=cpd_old(ia1,:)-cpd_old(ia2,:)
         pdot = dot_product(cps2,fcvect(ia1,1:3))
         if(iprimd >= 2) then
            write(nfout,'(" !! cps(    ",i5,",:) = ",3f12.6," <<correct_fixed_bond>>")') &
                 & ia1,(cps(ia1,1:3))
            write(nfout,'(" !! cps(    ",i5,",:) = ",3f12.6," <<correct_fixed_bond>>")') &
                 & ia2,(cps(ia2,1:3))
            write(nfout,'(" !! cpd_l(  ",i5,",:) = ",3f12.6," <<correct_fixed_bond>>")') &
                 & ia1,(cpd_l(ia1,1:3))
            write(nfout,'(" !! cpd_l(  ",i5,",:) = ",3f12.6," <<correct_fixed_bond>>")') &
                 & ia2,(cpd_l(ia2,1:3))
            write(nfout,'(" !! cpd_old(",i5,",:) = ",3f12.6," <<correct_fixed_bond>>")') &
                 & ia1,(cpd_old(ia1,1:3))
            write(nfout,'(" !! cpd_old(",i5,",:) = ",3f12.6," <<correct_fixed_bond>>")') &
                 & ia2,(cpd_old(ia2,1:3))
            write(nfout,'(" !! cps1            ) = ",3f12.6," <<correct_fixed_bond>>")') cps1
            write(nfout,'(" !! cps2            ) = ",3f12.6," <<correct_fixed_bond>>")') cps2
            write(nfout,'(" !! fcvect(",i5,",:)  = ",4f12.6," <<correct_fixed_bond>>")') &
                 & ia1,(fcvect(ia1,1:4))
            write(nfout,'(" !! fcvect(",i5,",:)  = ",4f12.6," <<correct_fixed_bond>>")') &
                 & ia2,(fcvect(ia2,1:4))
            write(nfout,'(" !! ----------")')
         end if

         if(dabs(pdot).gt.1.d-6) then
            if(printable) write(nfout,'(" fcvect times cps2 (pdot)=",d16.8)') pdot
            stop ' fcvect is not normal to cps2 <<m_IS_md.correct_fixed_bond>>'
         end if
         do i = 1, 3
            if(cps1(i)*frc1(i) < -1.d-6) frc1(i) = 0.d0
            if(cps2(i)*frc2(i) < -1.d-6) frc2(i) = 0.d0
         end do
         fac = dtio/amion(ityp(ia1))
         cps1 = cps1 + fac*frc1
         cps2 = cps2 + fac*frc2
         cpd_old(ia1,:) = (cps1+cps2)*0.5d0
         cpd_old(ia2,:) = (cps1-cps2)*0.5d0
      end do

      if(iprimd >= 2) then
         write(nfout,'(" !! ---")')
         do ia1 = 1, natm
            write(nfout,'(" !! cpd_old(",i5," :) = ",3f12.6," << correct_fixed_bond>>")') ia1,cpd_old(ia1,1:3)
         end do
      end if

      cps = cps + dtio*cpd_old

      do ib = 1, num_fixed_bonds
         ia1 = bondlength_fix_set(1,ib); ia2 = bondlength_fix_set(2,ib)
         fcv1(1:3) = (cps(ia1,1:3) - cps(ia2,1:3))*0.5d0        ! = (c1-c2)/2
         pdot = dsqrt(dot_product(fcv1,fcv1))*2.d0              ! = |c1-c2|
         fcv2(1:3) = (cps(ia1,1:3) + cps(ia2,1:3))*0.5d0        ! = (c1+c2)/2

!!$         fcvect(ia1,1:3) = (cps(ia1,1:3) - cps(ia2,1:3))*0.5d0        ! = (c1-c2)/2
!!$         pdot = dsqrt(dot_product(fcvect(ia1,1:3),fcvect(ia1,1:3)))*2.d0  ! = |c1-c2|
!!$         fcvect(ia2,1:3) = (cps(ia1,1:3) + cps(ia2,1:3))*0.5d0        ! = (c1+c2)/2
         if(iprimd >= 2) then
            write(nfout,'(" !! fcv1(1:3) = ",3f12.6," <<correct_fixed_bond>>")') fcv1
            write(nfout,'(" !! fcv2(1:3) = ",3f12.6," <<correct_fixed_bond>>")') fcv2
            write(nfout,'(" !! cps(",i5,",:) = ",3f12.6," <<correct_fixed_bond>>")') &
                 & ia1,(cps(ia1,1:3))
            write(nfout,'(" !! cps(",i5,",:) = ",3f12.6," <<correct_fixed_bond>>")') &
                 & ia2,(cps(ia2,1:3))
            write(nfout,'(" !! ----------")')
         end if
         cps1 = cps(ia1,:)
         cps2 = cps(ia2,:)
         cps(ia1,:) = fcv2(1:3)+fcv1(1:3)*fcvect(ia1,4)/pdot ! =(c1+c2)/2 + (c1-c2)/2*f4/|c1-c2|
         cps(ia2,:) = fcv2(1:3)-fcv1(1:3)*fcvect(ia1,4)/pdot ! =(c1+c2)/2 - (c1-c2)/2*f4/|c1-c2|
         cpd_old(ia1,:) = cpd_old(ia1,:) + (cps(ia1,:)-cps1)
         cpd_old(ia2,:) = cpd_old(ia2,:) + (cps(ia2,:)-cps2)
         pdot = dot_product(cps(ia1,:)-cps(ia2,:),cps(ia1,:)-cps(ia2,:)) ! =|(c1-c2)*f4/|c1-c2||**2
         if(dabs(dsqrt(pdot)-fcvect(ia1,4)) > 1.d-10) then
            if(printable) then
               write(nfout,'(" !! imdtyp=BONDLENGTH_FIX normalization error")')
               write(nfout,'(" !!   ia1, ia2 = ",2i8)') ia1, ia2
               write(nfout,'(" !!   fcvect(ia1,4) = ",d16.8)') fcvect(ia1,4)
               write(nfout,'(" !!   pdot = ",d16.8)') pdot
               write(nfout,'(" !! fcvect(",i5,",:) = ",4f12.6," <<correct_fixed_bond>>")') &
                    & ia1,(fcvect(ia1,1:4))
               write(nfout,'(" !! fcvect(",i5,",:) = ",4f12.6," <<correct_fixed_bond>>")') &
                    & ia2,(fcvect(ia2,1:4))
            end if
            stop ' normalization error <<m_IS_md.correct_fixed_bond>>'
         end if
         if(iprimd >= 3) &
              & write(nfout,'(" fcvect(",i5,",:) = ",4f12.6," <<correct_fixed_bond>>")') &
                 & ia1,(fcvect(ia1,i),i=1,4)
      end do

      cpd_l = cpd_old

      deallocate(fcv2);deallocate(fcv1);deallocate(cps2);deallocate(cps1)
      deallocate(frc4);deallocate(frc3);deallocate(frc2);deallocate(frc1)
    end subroutine correct_fixed_bond

!!$    subroutine evolve_cps()
!!$      integer ::             ia, it, itcrspd, iaa
!!$      real(kind=DP),allocatable,dimension(:,:) :: cps_old !d(nfcatm,3)
!!$      real(kind=DP),allocatable,dimension(:,:) :: cps_cog !d(num_planes_atoms_are_fixed,3)
!!$      real(kind=DP),allocatable,dimension(:,:) :: cps_cog_perpend !d(num_planes_atoms_are_fixed,3)
!!$      real(kind=DP) :: denom, pdot
!!$
!!$      if(constraint_type == COG_FIX_L &
!!$           & .or. constraint_type == COG_FIX .or. constraint_type == COG_CNTR) then
!!$         allocate(cps_old(nfcatm,3))
!!$         do it = 1, nfcatm
!!$            ia = ia_cnst(it)
!!$            cps_old(it,1:3) = cps(ia,1:3)
!!$         end do
!!$      end if
!!$
!!$      cps = cps + dtio*cpd_l
!!$
!!$      if(constraint_type == COG_FIX_L &
!!$           & .or. constraint_type == COG_FIX .or. constraint_type == COG_CNTR) then
!!$         allocate(cps_cog(num_planes_atoms_are_fixed,3)); cps_cog = 0.d0
!!$         allocate(cps_cog_perpend(num_planes_atoms_are_fixed,3)); cps_cog = 0.d0
!!$         do it = 1, nfcatm
!!$            ia = ia_cnst(it)
!!$            iaa = ipfixedplane(it)
!!$            cps_cog(iaa,1:3) = cps_cog(iaa,1:3) + amion(ityp(ia))*(cps(iaa,1:3)-cps_old(it,1:3))
!!$         end do
!!$         do it = 1, num_planes_atoms_are_fixed
!!$            denom = 0.d0
!!$            do itcrspd = 1, nfcatm
!!$               ia = ia_cnst(itcrspd)
!!$               if(ipfixedplane(itcrspd) == it) then
!!$                  denom = denom+amion(ityp(ia))
!!$                  iaa = itcrspd
!!$               end if
!!$            end do
!!$            cps_cog(it,1:3) = cps_cog(it,1:3)/denom
!!$            pdot = dot_product(fcvect(iaa,1:3),cps_cog(it,1:3))
!!$            cps_cog_perpend(it,1:3) = pdot*fcvect(iaa,1:3)   ! perpendicular components
!!$            if(iprimd >= 1) then
!!$               write(6,'(" !!f denom = ",f8.4)') denom
!!$            end if
!!$         end do
!!$         do it = 1, nfcatm
!!$            ia = ia_cnst(it)
!!$            itcrspd = ipfixedplane(it)
!!$            cps(ia,1:3) = cps(ia,1:3) - cps_cog_perpend(itcrspd,1:3)
!!$            if(iprimd >= 1) then
!!$               write(6,'(" !!f cps(        ",i3,") = ",3f8.4)') ia, cps(ia,1:3)
!!$               write(6,'(" !!f cps-cps_old(",i3,") = ",3f8.4)') ia, cps(ia,1:3)-cps_old(it,1:3)
!!$            end if
!!$         end do
!!$         deallocate(cps_old)
!!$         deallocate(cps_cog_perpend)
!!$         deallocate(cps_cog)
!!$      end if
!!$    end subroutine evolve_cps
      

  end subroutine m_IS_md

  subroutine check_constraint(forc_l)
    real(kind=DP), intent(in), dimension(natm,3) :: forc_l

    integer :: ifcatm, ic_cog, ia, iaa, ib,ia1,ia2

    real(kind=DP) :: pdot

    ! -- ipcpd ---
    ipcpd = 0
    ifcatm = 0
    do ia = 1, natm
       if(imdtyp(ia) == COG_FIX .or. imdtyp(ia) == COG_FIX_L &
            .or. imdtyp(ia) == FIX_IN_A_PLANE) then
          ifcatm = ifcatm + 1
          ipcpd(ia) = ifcatm
          if(imdtyp(ia) == COG_FIX .or. imdtyp(ia) == COG_FIX_L) iaa = ia
       end if
    end do
!!$    if(printable) then
!!$       write(nfout,'(" !D --- ipcpd ----")')
!!$       write(nfout,'(10i5)') (ipcpd(ia),ia=1,natm)
!!$    end if

    if(nfcatm >= 2) then
       tmass = 0.d0
       fcg = 0.d0
       ic_cog = 0
       do ia = 1, natm
          if(imdtyp(ia) == COG_FIX .or. imdtyp(ia) == COG_FIX_L) then
             ic_cog = ic_cog + 1
             tmass = tmass + amion(ityp(ia))
             fcg(1:3) = fcg(1:3) + forc_l(ia,1:3)
          end if
       end do
       if(ic_cog >= 2) then
          ifcatm = ipcpd(iaa)
          pdot = dot_product(fcvect(ifcatm,1:3),fcg)
          fcg_mdfy = fcg - pdot*fcvect(ifcatm,1:3)
       else if(ic_cog == 1) then
          stop ' #ic_cog is not enough'
       end if
       if(ic_cog == 0) tmass = DELTA10
       if(tmass >= (DELTA10-SmallestPositiveNumber) ) then
          rtmass = 1.d0/tmass
       else
          rtmass = 0.d0
       end if
    end if

    ! --- bondlength check ---
    if(constraint_type == BONDLENGTH_FIX) then
       do ib = 1, num_fixed_bonds
          ia1 = bondlength_fix_set(1,ib)
          ia2 = bondlength_fix_set(2,ib)
          ia = ib*2 - 1
          fcvect(ia,1:3) = cps(ia1,1:3) - cps(ia2,1:3)
          fcvect(ia,4)   = dsqrt(fcvect(ia,1)**2 + fcvect(ia,2)**2 + fcvect(ia,3)**2)
          fcvect(ia+1,1:3) = -fcvect(ia,1:3)
          fcvect(ia+1,4) = fcvect(ia,4)
          if(iprimd >= 3) then
             write(nfout,'(" fcvect(",i5,",:) = ",4f12.6," <<check_constraint>>")') &
                  & ia,(fcvect(ia,1:4))
             write(nfout,'(" fcvect(",i5,",:) = ",4f12.6," <<check_constraint>>")') &
                  & ia+1,(fcvect(ia+1,1:4))
          end if
       end do
    end if
  end subroutine check_constraint

  subroutine check_constraint_cog(forc_l)
    real(kind=DP), intent(in), dimension(natm,3) :: forc_l

    integer :: ifcatm, ic_cog, ia, iaa, ib,ia1,ia2

    real(kind=DP) :: pdot

    ! -- ipcpd ---
    ipcpd = 0
    ifcatm = 0
    do ia = 1, natm
       if(imdtyp(ia) == COG_FIX .or. imdtyp(ia) == COG_FIX_L &
            .or. imdtyp(ia) == FIX_IN_A_PLANE) then
          ifcatm = ifcatm + 1
          ipcpd(ia) = ifcatm
          if(imdtyp(ia) == COG_FIX .or. imdtyp(ia) == COG_FIX_L) iaa = ia
       end if
    end do

    if(nfcatm >= 2) then
       tmass = 0.d0
       fcg = 0.d0
       ic_cog = 0
       do ia = 1, natm
          if(imdtyp(ia) == COG_FIX .or. imdtyp(ia) == COG_FIX_L) then
             ic_cog = ic_cog + 1
             tmass = tmass + amion(ityp(ia))
             fcg(1:3) = fcg(1:3) + forc_l(ia,1:3)
          end if
       end do
       if(ic_cog >= 2) then
          ifcatm = ipcpd(iaa)
          pdot = dot_product(fcvect(ifcatm,1:3),fcg)
          fcg_mdfy = fcg - pdot*fcvect(ifcatm,1:3)
       else if(ic_cog == 1) then
          stop ' #ic_cog is not enough'
       end if
       if(ic_cog == 0) tmass = DELTA10
       if(tmass >= (DELTA10-SmallestPositiveNumber) ) then
          rtmass = 1.d0/tmass
       else
          rtmass = 0.d0
       end if
    end if

  end subroutine check_constraint_cog

  real(kind=DP) function get_fi_coefficient(force_t_norm)
    real(kind=DP), intent(in) :: force_t_norm
    if(force_t_norm < 0.008d0) then
       get_fi_coefficient = 3.5d0
    else if (force_t_norm < 0.02d0) then
       get_fi_coefficient = 2.5d0
    else if (force_t_norm < 0.05d0) then
       get_fi_coefficient = 1.5d0
    else
       get_fi_coefficient = 0.8d0
    end if
  end function get_fi_coefficient

  subroutine move_atoms_normal_to_plane()
    integer :: ia, icatm,i
    icatm = 0
    do ia = 1, natm
       if(imdtyp(ia)==FIX_IN_A_PLANE .or. imdtyp(ia)==COG_FIX_L .or. imdtyp(ia)==COG_FIX) then
          icatm = icatm + 1
          cps(ia,1:3) = cps(ia,1:3) + fcvect(icatm,1:3)*fcvect(icatm,4)
          if(iprimd >= 2) then
             write(nfout,'(" ia = ",i8, " cps_diff = ",3f12.6)') ia, (fcvect(icatm,i)*fcvect(icatm,4),i=1,3)
             write(nfout,'(" fcvect = ",4f12.6)') (fcvect(icatm,i),i=1,4)
          end if
          if((fcvect(icatm,1)**2 + fcvect(icatm,2)**2 + fcvect(icatm,3)**2) < 1.d-9) then
             if(iprimd >= 1) write(nfout,'(" fcvect is too small")')
             stop ' fcvect is too small <<move_atoms_normal_to_plane>>'
          end if
       end if
    end do
    cpd_l = 0.d0
  end subroutine move_atoms_normal_to_plane

  subroutine check_if_bondlength_fix_exist(ib)
    integer, intent(out) :: ib
    integer i
    ib = 0
    do i = 1, natm
       if(imdtyp(i) == BONDLENGTH_FIX) ib = ib + 1
    end do
  end subroutine check_if_bondlength_fix_exist

  subroutine md1_alloc(mdalg)
    integer, intent(in) :: mdalg
    allocate(cpd_old(natm,3));cpd_old=0.d0
    if(mdalg == VERLET .and. &
         &(nbztyp == HEXAGONAL .or. nbztyp == ORTHORHOMBIC .or. &
         & nbztyp >= HEX1fold)) then
       allocate(ipcpd(natm2))
    else
       allocate(ipcpd(natm))
    end if
  end subroutine md1_alloc

  subroutine md1_dealloc()
    deallocate(ipcpd)
    deallocate(cpd_old)
  end subroutine md1_dealloc

  subroutine md1_alloc2()
    integer :: ia, ifcatm

    allocate(ipcpd(natm)); ipcpd = 0
    ifcatm = 0
    do ia = 1, natm
       if(imdtyp(ia) == COG_FIX .or. imdtyp(ia) == COG_FIX_L &
            .or. imdtyp(ia) == FIX_IN_A_PLANE) then
          ifcatm = ifcatm + 1
          ipcpd(ia) = ifcatm
       end if
    end do
  end subroutine md1_alloc2

  subroutine md1_dealloc2()
    deallocate(ipcpd)
  end subroutine md1_dealloc2

  subroutine quench_velocities(forc_l) 
    real(kind=DP), intent(in), dimension(natm,3) :: forc_l
    integer       :: ia
    real(kind=DP) :: cpd_parallel(3), cpd_vertical(3), f, fv, fcpd, v(3)
    !  Revised according to an indication by Dr. T. Yamamoto.
    !            T. Yamasaki,   Nov. 2003
    !  Revised according to an indication by Usami-san @adv
    !      An adopted quenching algorithm depends on the nopr value
    !            T. Yamasaki,   Sep. 2006
    !
!!$    real(kind=DP) :: v
!!$    do j = 1, 3
!!$!xocl spread do/ind_natm
!!$       do ia = 1, natm
!!$          if(imdtyp(ia) == BONDLENGTH_FIX) cycle
!!$          v = (cpd_old(ia,j) + cpd_l(ia,j))*0.5
!!$          if(dabs(v) > SmallestPositiveNumber*1.d5 .and. v*forc_l(ia,j) < 0.d0) then
!!$             if(printable) write(nfout,'(" quenched atom = ",i6," --- <<quench_velocities>>")') ia
!!$             cpd_l(ia,j) = 0.d0
!!$          end if
!!$       end do
!!$!xocl end spread
!!$    end do
    if(nopr <= 1) then
!xocl spread do/ind_natm
       do ia = 1, natm
          if(imdtyp(ia) == BONDLENGTH_FIX) cycle
          v(1:3) = (cpd_old(ia,1:3) + cpd_l(ia,1:3))*0.5
          fv = dot_product(forc_l(ia,1:3), v)
          if(fv < 0.d0) then
             if(printable) write(nfout,'(" quenched atom = ",i6," ---<<quench_velocities>>")') ia
             cpd_l(ia,1:3) = 0.d0
          end if
       end do
!xocl end spread
    else
!xocl spread do/ind_natm
       do ia = 1, natm
          if(imdtyp(ia) == BONDLENGTH_FIX) cycle
          v(1:3) = (cpd_old(ia,1:3) + cpd_l(ia,1:3))*0.5
          f = forc_l(ia,1)**2 + forc_l(ia,2)**2 + forc_l(ia,3)**2
          fv = dot_product(forc_l(ia,1:3), v)
          fcpd = dot_product(forc_l(ia,1:3),cpd_l(ia,1:3))
          if(f > SmallestPositiveNumber*1.d5 ) then
             cpd_parallel(1:3) = fcpd/f * forc_l(ia,1:3)
             cpd_vertical(1:3) = cpd_l(ia,1:3) - cpd_parallel(1:3)
             if(fv < 0.d0) then
                cpd_parallel(1:3) = 0.d0
                cpd_l(ia,1:3) = cpd_vertical(1:3)
                if(printable) write(nfout,'(" quenched atom = ",i6," ---<<quench_velocities>>")') ia
             end if
          else
             cpd_l(ia,1:3) = 0.d0
          end if
       end do
!xocl end spread
    end if
    
  end subroutine quench_velocities

  subroutine quench_velocities_cog(forc_l) 
    real(kind=DP), intent(in), dimension(natm,3) :: forc_l
    integer       :: ia, ia_t
    real(kind=DP) :: cpd_parallel(3), cpd_vertical(3), f, fv, fcpd, v(3)
    !  Revised according to an indication by Dr. T. Yamamoto.
    !            T. Yamasaki,   Nov. 2003
    !  Revised according to an indication by Usami-san @adv
    !      An adopted quenching algorithm depends on the nopr value
    !            T. Yamasaki,   Sep. 2006
    !
!!$    real(kind=DP) :: v
!!$    do j = 1, 3
!!$!xocl spread do/ind_natm
!!$       do ia = 1, natm
!!$          if(imdtyp(ia) == BONDLENGTH_FIX) cycle
!!$          v = (cpd_old(ia,j) + cpd_l(ia,j))*0.5
!!$          if(dabs(v) > SmallestPositiveNumber*1.d5 .and. v*forc_l(ia,j) < 0.d0) then
!!$             if(printable) write(nfout,'(" quenched atom = ",i6," --- <<quench_velocities>>")') ia
!!$             cpd_l(ia,j) = 0.d0
!!$          end if
!!$       end do
!!$!xocl end spread
!!$    end do
    if(nopr <= 1) then
       ia_t = 0
!xocl spread do/ind_natm
       do ia = 1, natm
          if(imdtyp(ia) == COG_FIX .or. imdtyp(ia) == COG_FIX_L &
               .or. imdtyp(ia) == FIX_IN_A_PLANE) then
             ia_t = ia_t + 1
             v(1:3) = (cpd_old(ia_t,1:3) + cpd_l(ia,1:3))*0.5
             fv = dot_product(forc_l(ia,1:3), v)
             if(fv < 0.d0) then
                if(printable) write(nfout,'(" quenched atom = ",i6," ---<<quench_velocities>>")') ia
                cpd_l(ia,1:3) = 0.d0
             end if
          end if
       end do
!xocl end spread
    else
       ia_t = 0
!xocl spread do/ind_natm
       do ia = 1, natm
          if(imdtyp(ia) == COG_FIX .or. imdtyp(ia) == COG_FIX_L &
               .or. imdtyp(ia) == FIX_IN_A_PLANE) then
             ia_t = ia_t + 1
             v(1:3) = (cpd_old(ia_t,1:3) + cpd_l(ia,1:3))*0.5
             f = forc_l(ia,1)**2 + forc_l(ia,2)**2 + forc_l(ia,3)**2
             fv = dot_product(forc_l(ia,1:3), v)
             fcpd = dot_product(forc_l(ia,1:3),cpd_l(ia,1:3))
             if(f > SmallestPositiveNumber*1.d5 ) then
                cpd_parallel(1:3) = fcpd/f * forc_l(ia,1:3)
                cpd_vertical(1:3) = cpd_l(ia,1:3) - cpd_parallel(1:3)
                if(fv < 0.d0) then
                   cpd_parallel(1:3) = 0.d0
                   cpd_l(ia,1:3) = cpd_vertical(1:3)
                   if(printable) write(nfout,'(" quenched atom = ",i6," ---<<quench_velocities>>")') ia
                end if
             else
                cpd_l(ia,1:3) = 0.d0
             end if
          end if
       end do
!xocl end spread
    end if
    
  end subroutine quench_velocities_cog

  subroutine correct_cog_motion()
    integer :: ic_cog, ia, ifcatm,iaa
    real(kind=DP) :: amass, pdot, denom
    real(kind=DP),allocatable,dimension(:):: dcg, dcg_n

    allocate(dcg(3)); allocate(dcg_n(3))
    dcg = 0.d0
    denom = 0.d0
    ic_cog = 0
    ifcatm = 0
    do ia = 1, natm
       if(imdtyp(ia) == COG_FIX_L .or. imdtyp(ia) == COG_FIX) then
          iaa = ia
          ifcatm = ifcatm+1
          amass = amion(ityp(ia))
          ic_cog = ic_cog + 1
          dcg(:) = dcg(:) + amass*cpd_l(ia,:)
          denom = denom + amass
       end if
    end do
    if(ic_cog >= 2) then
!!$       dcg = dcg/tmass
       dcg = dcg/denom
       if(printable) write(nfout,'(" !D (dcgx0, dcgy0, dcgz0 ) = (",3f12.8,")")') dcg(1:3)
       if(printable) write(nfout,'(" !D iaa = ",i8)') iaa
       if(iaa > natm) stop ' iaa > natm'
       if(iaa < 1) stop ' iaa < 1'
!!$       ifcatm = ipcpd(iaa)
       if(ifcatm > nfcatm) stop ' ifcatm > nfcatm <<correct_cog_motion>>'
       pdot = dot_product(fcvect(ifcatm,1:3),dcg)
       dcg_n = pdot*fcvect(ifcatm,1:3)
    else if(ic_cog == 1) then
       stop ' #ic_cog is not enough'
    else
       dcg_n = 0.d0
    end if

    do ia = 1, natm
       if(imdtyp(ia) == COG_FIX_L .or. imdtyp(ia) == COG_FIX) &
            & cpd_l(ia,:) = cpd_l(ia,:) - dcg_n(:)
    end do

    deallocate(dcg); deallocate(dcg_n)
  end subroutine correct_cog_motion

  subroutine get_ekina
    integer ia
    ekina = 0.d0
!xocl spread do/ind_natm
    do ia = 1, natm
       if(imdtyp(ia) == BONDLENGTH_FIX) cycle
       ekina = ekina + ( (cpd_old(ia,1) + cpd_l(ia,1))**2 &
            &           +(cpd_old(ia,2) + cpd_l(ia,2))**2 &
            &           +(cpd_old(ia,3) + cpd_l(ia,3))**2)*0.25 & ! v*v
            &          * amion(ityp(ia))*iwei(ia) * 0.5     ! * mass * 1/2
    end do
!!$!xocl end spread sum(ekina)
  end subroutine get_ekina

  subroutine modify_forc_fi(forc_l)
    real(kind=DP), intent(inout), dimension(natm,3) :: forc_l
    real(kind=DP), allocatable, dimension(:,:) :: force_t_para, force_t_vert
    real(kind=DP) :: f_dot_v, vec_norm2, force_t_norm
    integer :: ia

    do ia = 1, natm
       if(imdtyp(ia) == FIX) then
          forc_l(ia,1:3) = 0.d0
       end if
    end do

    allocate(force_t_para(natm,3), force_t_vert(natm,3))

    f_dot_v = sum( forc_l(1:natm,1:3)*normal_hypervector(1:natm,1:3,CARTS) )
    vec_norm2 = sum( normal_hypervector(1:natm,1:3,CARTS)**2 )
    force_t_para = 0.d0; force_t_vert = 0.d0
    if( vec_norm2 > DELTA10) then
       force_t_para(:,:)=f_dot_v/vec_norm2*normal_hypervector(:,:,CARTS)
       force_t_vert(:,:)=forc_l(:,:)-force_t_para(:,:)
       f_dot_v= sum( force_t_para(:,:)*force_t_vert(:,:) )
       if(iprimd >= 1) then
          write(nfout,*) 'opt_mode is FI'
          write(nfout,'(a19,f20.10)') ' true_force =      ', force_t_norm
          write(nfout,'(a19,f20.10)') ' force_parallel =  ' &
               & , sum(force_t_para(:,:)*normal_hypervector(:,:,CARTS))/sqrt(vec_norm2)
          write(nfout,'(a19,f20.10)') ' force_vertical =  ' &
               & , sqrt(sum(force_t_vert(:,:)**2))
          write(nfout,'(a19,f20.10)') ' f_para x f_vert = ', f_dot_v
          if(iprimd >= 2) then
             write(nfout,'(" forc_l, force_t_vert, force_t_para")')
             do ia = 1, natm
                write(nfout,'(i5,9f10.4)') forc_l(ia,1:3), force_t_vert(ia,1:3),force_t_para(ia,1:3)
             end do
          end if
       end if
       forc_l(:,:)=force_t_vert(:,:)-force_t_para(:,:)
       if(iprimd >= 1) write(nfout,'(a19,f20.10)') 'modified force =  ', sqrt(sum(forc_l(:,:)**2))
    else
       if(iprimd >= 1) then
          write(nfout,*) 'vector is strange for FI or NEB !!'
          write(nfout,*) 'vector =', vec_norm2
          write(nfout,*) 'opt_mode is changed to SD'
          write(nfout,*) ' total force =', force_t_norm
       end if
    end if

    deallocate(force_t_vert, force_t_para)

  end subroutine modify_forc_fi

  subroutine modify_forc_hyperplane(forc_l)
    real(kind=DP), intent(inout), dimension(natm,3) :: forc_l
    real(kind=DP), allocatable, dimension(:,:) :: force_t_para, force_t_vert
    real(kind=DP) :: f_dot_v, vec_norm2, force_t_norm, fa
    integer :: ia

    do ia = 1, natm
       if(imdtyp(ia) == FIX) then
          forc_l(ia,1:3) = 0.d0
       end if
    end do

    allocate(force_t_para(natm,3), force_t_vert(natm,3))

    f_dot_v = sum( forc_l(1:natm,1:3)*normal_hypervector(1:natm,1:3,CARTS) )
    force_t_norm = sqrt(sum( forc_l(1:natm,1:3)**2))
    vec_norm2 = sum( normal_hypervector(1:natm,1:3,CARTS)**2 )
    force_t_para = 0.d0; force_t_vert = 0.d0
    if( vec_norm2 > DELTA10) then
       force_t_para(:,:)=f_dot_v/vec_norm2*normal_hypervector(:,:,CARTS)
       force_t_vert(:,:)=forc_l(:,:)-force_t_para(:,:)
       f_dot_v= sum( force_t_para(:,:)*force_t_vert(:,:) )
       if(iprimd >= 1) then
          write(nfout,*) 'opt_mode is fix_in_a_hyperplane'
          write(nfout,'(a19,f20.10)') ' true_force =      ', force_t_norm
          write(nfout,'(a19,f20.10)') ' force_parallel =  ' &
               & , sum(force_t_para(:,:)*normal_hypervector(:,:,CARTS))/sqrt(vec_norm2)
          write(nfout,'(a19,f20.10)') ' force_vertical =  ' &
               & , sqrt(sum(force_t_vert(:,:)**2))
          write(nfout,'(a19,f20.10)') ' f_para x f_vert = ', f_dot_v
! -->   T. Yamasaki 22 Aug 2008
          if(iprimd >= 2) then
             write(nfout,'(" forc_l, force_t_vert, force_t_para")')
             do ia = 1, natm
                write(nfout,'(i5,9f10.4)') ia, forc_l(ia,1:3), force_t_vert(ia,1:3),force_t_para(ia,1:3)
             end do
          end if
! <--
       end if
!!$       forc_l(:,:)=force_t_vert(:,:)-force_t_para(:,:)
       forc_l(:,:)=force_t_vert(:,:)
! -->   T. Yamasaki 18 July 2008
       forc_norm_hyperplane_vert = sqrt(sum(forc_l(:,:)**2))
       forcmx_hyperplane_vert = 0.d0
       do ia= 1, natm
          fa = dsqrt(forc_l(ia,1)**2 + forc_l(ia,2)**2 + forc_l(ia,3)**2)
          if(fa > forcmx_hyperplane_vert) forcmx_hyperplane_vert = fa
       end do
       if(iprimd >= 1) write(nfout,'(a19,f20.10)') 'forc_norm_hp_v =  ', forc_norm_hyperplane_vert
       if(iprimd >= 1) write(nfout,'(a19,f20.10)') 'forcmx_hp_vert =  ', forcmx_hyperplane_vert
! <--
       if(iprimd >= 1) write(nfout,'(a19,f20.10)') 'modified force =  ', sqrt(sum(forc_l(:,:)**2))
    else
       if(iprimd >= 1) then
          write(nfout,*) 'vector is strange for FI or NEB !!'
          write(nfout,*) 'vector =', vec_norm2
          write(nfout,*) 'opt_mode is changed to SD'
          write(nfout,*) ' total force =', force_t_norm
       end if
    end if

    deallocate(force_t_vert, force_t_para)

  end subroutine modify_forc_hyperplane

! -->   T. Yamasaki 18 July 2008
  logical function m_IS_cnstr_is_fixed_nhp()
    if(constraint_type == FIXED_NORMAL_HYPERVECTOR) then
       m_IS_cnstr_is_fixed_nhp = .true.
    else
       m_IS_cnstr_is_fixed_nhp = .false.
    end if
  end function m_IS_cnstr_is_fixed_nhp

  logical function m_IS_force_check_md_nhp()
    if(forcmx_hyperplane_vert < forccr) then
       m_IS_force_check_md_nhp = .true.
    else
       m_IS_force_check_md_nhp = .false.
    end if
    if(iprimd >= 2) write(nfout,'(" !D forcmx_hyperplane_vert = ",d20.12)') forcmx_hyperplane_vert
  end function m_IS_force_check_md_nhp
! <--

  subroutine initialize_constraint_param
    forcmx_constraint_quench = 1.d+2
    forc_norm_hyperplane_vert = 1.d+2
    forcmx_hyperplane_vert = 1.d+2
  end subroutine initialize_constraint_param

  subroutine evolve_velocities(mdalg,forc_l)
    integer, intent(in) ::                          mdalg
    real(kind=DP), intent(inout), dimension(natm,3) :: forc_l
    
    integer  :: ia, ifc,j
    real(kind=DP) :: fac(3), frc(3), rm, pdot
    real(kind=DP) :: f_dot_v, vec_norm2, force_t_norm
    real(kind=DP), allocatable, dimension(:,:) :: force_t_para, force_t_vert

    force_t_norm = sqrt(sum(forc_l(1:natm,1:3)**2))

    do ia = 1, natm
       do j=1,3
          if(imdtypxyz(ia,j) == FIX) then
             forc_l(ia,j) = 0.d0
          end if
       enddo
    end do

    if(mdalg == STEEPEST_DESCENT) then
       cpd_l(:,:)=forc_l(:,:)/dtio*fi_coefficient                   !! moving force cal
    else
!xocl spread do/ind_natm
       do ia = 1, natm
          if(imdtyp(ia) == BONDLENGTH_FIX) cycle

          do j=1,3
          if(imdtypxyz(ia,j) == FIX) then
             fac(j) = 0.d0
          else
             fac(j) = dtio/amion(ityp(ia))
          end if
          enddo
          if(imdtyp(ia)==COG_FIX .or. imdtyp(ia)==COG_FIX_L .or. imdtyp(ia)==FIX_IN_A_PLANE) then
             if(imdtyp(ia)==COG_FIX .or. imdtyp(ia)==COG_FIX_L) then
                rm = amion(ityp(ia))*rtmass
                frc = forc_l(ia,1:3) + rm*(fcg_mdfy(1:3) - fcg(1:3))
             else if(imdtyp(ia)==FIX_IN_A_PLANE) then
                ifc = ipcpd(ia)
                pdot = dot_product(fcvect(ifc,1:3),forc_l(ia,1:3))
                frc = forc_l(ia,1:3) - pdot*fcvect(ifc,1:3)
             end if
          else
             frc = forc_l(ia,1:3)
          end if
!
! -- following 6 lines have been revised by Mamoru Usami, Oct. 2004.--->>
! further modified by T.Yamamoto on Nov. 29, 2005. --->>
          if (mdalg == VERLET .and. iteration_ionic == 1)  then
             !!cpd_l(ia,1:3) = fac*frc(1:3) / 2.d0
             !!cpd_old(ia,1:3) = -cpd_l(ia,1:3)
             cpd_l(ia,1:3) = cpd_l(ia,1:3) + 0.5d0*fac(1:3)*frc(1:3)
          else
             cpd_l(ia,1:3) = cpd_l(ia,1:3) + fac(1:3)*frc(1:3)
          endif

!  <<-----
       end do
!xocl end spread
    end if

  end subroutine evolve_velocities

  subroutine evolve_velocities_cog(forc_l)
    real(kind=DP), intent(inout), dimension(natm,3) :: forc_l
    
    integer  :: ia, ifc, mdalg
    real(kind=DP) :: fac, frc(3), rm, pdot
    real(kind=DP) :: f_dot_v, vec_norm2
    real(kind=DP), allocatable, dimension(:,:) :: force_t_para, force_t_vert

    mdalg = VERLET

    if(nfcatm <= 0) return

    do ia = 1, natm
       fac = dtio/amion(ityp(ia))
       if(imdtyp(ia)==COG_FIX .or. imdtyp(ia)==COG_FIX_L .or. imdtyp(ia)==FIX_IN_A_PLANE) then
          if(imdtyp(ia)==COG_FIX .or. imdtyp(ia)==COG_FIX_L) then
             rm = amion(ityp(ia))*rtmass
             frc = forc_l(ia,1:3) + rm*(fcg_mdfy(1:3) - fcg(1:3))
          else if(imdtyp(ia)==FIX_IN_A_PLANE) then
             ifc = ipcpd(ia)
             pdot = dot_product(fcvect(ifc,1:3),forc_l(ia,1:3))
             frc = forc_l(ia,1:3) - pdot*fcvect(ifc,1:3)
          end if
! -- following 6 lines have been revised by Mamoru Usami, Oct. 2004.--->>
! further modified by T.Yamamoto on Nov. 29, 2005. --->>
          if (mdalg == VERLET .and. iteration_ionic == 1)  then
             !!cpd_l(ia,1:3) = fac*frc(1:3) / 2.d0
             !!cpd_old(ia,1:3) = -cpd_l(ia,1:3)
             cpd_l(ia,1:3) = cpd_l(ia,1:3) + 0.5d0*fac*frc(1:3)
          else
             cpd_l(ia,1:3) = cpd_l(ia,1:3) + fac*frc(1:3)
          endif
       end if
    end do
  end subroutine evolve_velocities_cog

  subroutine m_IS_evaluate_v_verlet(mdalg,forc_l_in)
    ! coded by Usami, Oct. 2004
    ! subroutine name is revised by T. Yamasaki
    ! revised by T. Yamasaki, Jun. 2005
    !    'if(mdalg.ne.VERLET) return' is commented out
    integer, intent(in) :: mdalg
    real(kind=DP), intent(in), dimension(natm,3) :: forc_l_in
    real(kind=DP), allocatable, dimension(:,:)   :: forc_l
!!$    if (mdalg .ne. VERLET) return

    call md1_alloc(mdalg)

    allocate(forc_l(natm,3)); forc_l = forc_l_in
    cpd_old = cpd_l
    call check_constraint(forc_l)
    call evolve_velocities(mdalg,forc_l)
    call get_ekina

    deallocate(forc_l)
    call md1_dealloc
  endsubroutine m_IS_evaluate_v_verlet

  subroutine m_IS_structure_factor(nfout,kgp,ngabc)
    integer, intent(in) :: nfout, kgp
    integer, intent(in) :: ngabc(kgp,3)

    integer             :: id_sname = -1
    real(kind=DP), allocatable, dimension(:,:) :: cps_r
    integer             :: i,j
    call tstatc0_begin('m_IS_structure_factor ',id_sname,1)
#ifdef ENABLE_ESM_PACK
    if(sw_esm==ON) then
       allocate(cps_r(3,natm))
       do i=1,3 
          do j=1,natm
             cps_r(i,j) = cps(j,i)
          enddo
       enddo
       call Esm_interface_set_tau(cps_r)
       deallocate(cps_r)
    endif
#endif
    zfm3_l = 0.d0
    if(kimg == 1) then
#ifdef NEC_TUNE_SMP
       call structure_factor1(zfm3_l,pos,ngabc)
#else
       call structure_factor1
#endif
    else if(kimg == 2) then
#ifdef NEC_TUNE_SMP
       call structure_factor2(zfm3_l,pos,ngabc)
#else
       call structure_factor2
#endif
    endif

    if(ipristrcfctr >= 2 .and. printable) call wd_zfm3(160)
    call tstatc0_end(id_sname)
  contains
#ifdef NEC_TUNE_SMP
    subroutine structure_factor1(zfm3_l,pos,ngabc)
#else
    subroutine structure_factor1
#endif
      integer       :: ia, i, it
      real(kind=DP) :: grt
#ifdef NEC_TUNE_SMP
      real(kind=DP) :: zfm3_l(ista_kngp:iend_kngp,ntyp,kimg)
      real(kind=DP) :: pos(natm,3)
      integer       :: ngabc(kgp,3)
#endif
      do ia = 1, natm
         it = ityp(ia)
#ifdef NEC_TUNE_SMP
!CDIR INNER
#endif
         do i = ista_kngp, iend_kngp  !for mpi
            grt = (pos(ia,1)*ngabc(i,1) + pos(ia,2)*ngabc(i,2) &
            &    + pos(ia,3)*ngabc(i,3))*PAI2
            zfm3_l(i,it,1) = zfm3_l(i,it,1)+dcos(grt)*iwei(ia)
         end do
      end do
    end subroutine structure_factor1

#ifdef NEC_TUNE_SMP
    subroutine structure_factor2(zfm3_l,pos,ngabc)
#else
    subroutine structure_factor2
#endif
      integer       :: ia, i, it
      real(kind=DP) :: grt
#ifdef NEC_TUNE_SMP
      real(kind=DP) :: zfm3_l(ista_kngp:iend_kngp,ntyp,kimg)
      real(kind=DP) :: pos(natm,3)
      integer       :: ngabc(kgp,3)
#endif
      do ia = 1, natm
         it = ityp(ia)
#ifdef NEC_TUNE_SMP
!CDIR INNER
#endif
         do i = ista_kngp, iend_kngp  !for mpi
            grt = (pos(ia,1)*ngabc(i,1) + pos(ia,2)*ngabc(i,2) &
            &    + pos(ia,3)*ngabc(i,3))*PAI2
            zfm3_l(i,it,1)    = zfm3_l(i,it,1)    + dcos(grt)
            zfm3_l(i,it,kimg) = zfm3_l(i,it,kimg) - dsin(grt)
         end do
      end do
    end subroutine structure_factor2

    subroutine wd_zfm3(nelment)
      integer, intent(in) :: nelment

      integer i, it, ij, ik, nnelm
      integer, parameter :: Nwk = 8
      real(kind=DP), pointer, dimension(:) :: zfm3_copy

      nnelm = ((nelment-1)/Nwk + 1)*Nwk
      allocate(zfm3_copy(Nwk))

      write(nfout,'(" === structure factor (first",i5," elements) ===")')&
           &    nnelm
      do it = 1, ntyp
         write(nfout,'(" -- #sp = ",i5," --")') it
         do ik = 1, kimg
            if(kimg == 2) then
               if(ik == 1) then
                  write(nfout,*) ' -- real part      --'
               else
                  write(nfout,*) ' -- imaginary part --'
               endif
            endif
            ij = 1
            do i = 1, nnelm
               if(i >= ista_kngp .and. i <= iend_kngp) then
                  zfm3_copy(ij) = zfm3_l(i,it,ik)
                  if(ij == Nwk) then
                     write(nfout,'(8f10.5)') (zfm3_copy(ij),ij=1,Nwk)
                     ij = 1
                  else
                     ij = ij + 1
                  endif
               end if
            end do
         end do
      end do

      deallocate(zfm3_copy)
    end subroutine wd_zfm3
  end subroutine m_IS_structure_factor

  subroutine m_IS_ewald(nfout,kg,gr_l,kgp,ngabc,ival,alf_out)
    integer, intent(in)                     :: nfout, kg,kgp
    real(kind=DP), intent(in)               :: gr_l(ista_kngp:iend_kngp)
    integer, intent(in)                     :: ngabc(kgp,3)
    real(kind=DP), intent(in), dimension(:) :: ival

    real(kind=DP), pointer, dimension(:,:) :: rxyz
    real(kind=DP), pointer, dimension(:)   :: rr
    real(kind=DP), pointer, dimension(:,:) :: cps_fp    ! d(natm2)
    integer,       pointer, dimension(:)   :: ityp_full ! d(natm2)
    real(kind=DP), pointer, dimension(:,:) :: zsum      ! d(newldg)
    real(kind=DP), parameter :: rsphere_radius = 12.5d0
    real(kind=DP), parameter :: phi            =  6.0d0
    integer                  :: neibrd,  alen(3),  newldg
    real(kind=DP) :: alf, alf2, alf24,alfi,alfi2,c1,c2,c3,c4
    real(kind=DP), pointer, dimension(:)   :: ttr
    integer       :: id_sname = -1
    real(kind=DP),intent(out),optional :: alf_out
    call tstatc0_begin('m_IS_ewald ',id_sname)

    call decide_rxyz_size(rsphere_radius,alen,neibrd)
!!$    if(printable) write(nfout,*) ' ! neibrd = ', neibrd
           allocate(rxyz(neibrd,3))
           allocate(rr(neibrd))
    call substitute_rxyz(alen, neibrd, rxyz, rr)
                   deallocate(rr)
    call decide_alf    ! -> alf
    call decide_newldg ! -> newldg = #Gvectors for summation

           allocate(cps_fp(natm2,3))
           allocate(ityp_full(natm2))
       cps_fp(1:natm,1:3) = pos(1:natm,1:3)
       ityp_full(1:natm)    = ityp(1:natm)
    call rplcps(cps_fp,ityp_full,1,natm2,natm,iwei)
    call cpspac        ! -> cps_fp
    call set_ewald_parameters ! alf2,alf24,alfi,alfi2,c1,c3,c2,c4
    call ewald_Rspace_summation
    if(istress==1) call ewald_Rspace_summation_4_stress
                   deallocate(ityp_full)
                   deallocate(cps_fp)
                   deallocate(rxyz)

           allocate(zsum(newldg,kimg))
           allocate(ttr(6))
#ifdef ENABLE_ESM_PACK
    if(sw_esm==OFF) then
       call ewald_Gspace_summation
       if(istress==1) call ewald_stress_Gspace_summation
    else
        call mpi_allreduce(MPI_IN_PLACE,fxyzew_l,natm*3,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
    endif
#else
    call ewald_Gspace_summation
    if(istress==1) call ewald_stress_Gspace_summation
#endif
    deallocate(ttr)
    deallocate(zsum)
    eewald = eewald*0.5d0
#ifdef ENABLE_ESM_PACK
    if(printable.and.sw_esm==OFF) call wd_eewald_and_fxyzew
#else
    if(printable) call wd_eewald_and_fxyzew
#endif
    if(present(alf_out)) alf_out = alf
    call tstatc0_end(id_sname)
  contains
    subroutine wd_eewald_and_fxyzew
      integer mu

!!$      write(nfout,*) '--- ival --'
!!$      write(nfout,*) ival(1)
      write(nfout,'("  Ewald sum = ",d25.12)') eewald
      if(ipri >= 2) then
         do mu = 1, natm
!xocl spread do/ind_natm
!xocl index mu          
            write(nfout,710) mu &
            &         ,fxyzew_l(mu,1),fxyzew_l(mu,2),fxyzew_l(mu,2)
!xocl end spread
         end do
710      format(' ',i4,3f25.20)
      end if
    end subroutine wd_eewald_and_fxyzew
            
    subroutine ewald_Rspace_summation
      real(kind=DP)  :: etr, z, rnms,rnm,rnmc,fc1,fc2,fc3, rnm1, rnm2, rnm3,e0
      integer        :: nu, in, ia
      real(kind=DP)  :: derfc, eewald_rspace, sum_abc1, sum_abc2, sum_abc3

      e0 = -c2 -c3*c4
      if(ipri >= 2 .and. printable) write(6,'(" !! c2+c3*c4 = ",d12.4," <<ewald_Rspace_summation>>")') c2+c3*c4
      if( sw_screening_correction==ON ) then
         e0 = 0.d0
      end if
      z = ival(ityp(1))
      eewald_rspace = 0.d0
      fxyzew_l = 0.d0
#ifdef NEC_TUNE_SMP
!CDIR PARALLEL DO PRIVATE(etr, z, rxyznm, rnms, rnmc, fc1, fc2, etr, fc3)
#endif
      do nu = ista_atm, iend_atm ! MPI
         etr = 0.d0
         sum_abc1 = 0.d0
         sum_abc2 = 0.d0
         sum_abc3 = 0.d0
if( sw_screening_correction /= ON  ) then
         do in = 1, neibrd
            do ia = 1, natm2
               if(in == 1 .and. ia == nu) cycle
               z = ival(ityp_full(ia))
               rnm1 = cps_fp(nu,1) - cps_fp(ia,1) - rxyz(in,1)
               rnm2 = cps_fp(nu,2) - cps_fp(ia,2) - rxyz(in,2)
               rnm3 = cps_fp(nu,3) - cps_fp(ia,3) - rxyz(in,3)
               rnms = rnm1*rnm1 + rnm2*rnm2 + rnm3*rnm3
               rnm  = dsqrt(rnms)
               rnmc = rnm*rnms
               fc1  = derfc(alfi*rnm)
               fc2  = dexp(-alfi2*rnms)*c3
               etr  = etr + z * fc1/rnm
               fc3  = z * (fc1/rnmc+fc2/rnms)
               sum_abc1 = sum_abc1 + rnm1*fc3
               sum_abc2 = sum_abc2 + rnm2*fc3
               sum_abc3 = sum_abc3 + rnm3*fc3
            end do
         end do
#ifdef NEC_TUNE_SMP
!CDIR ATOMIC
#endif
!!$       eewald = eewald + iwei(nu)*ival(ityp(nu))*etr
         eewald_rspace = eewald_rspace + iwei(nu)*ival(ityp(nu))*etr
         fxyzew_l(nu,1) = sum_abc1*ival(ityp(nu))
         fxyzew_l(nu,2) = sum_abc2*ival(ityp(nu))
         fxyzew_l(nu,3) = sum_abc3*ival(ityp(nu))
else
         do ia = 1, natm2
           if(ia == nu) cycle
           z = ival(ityp_full(ia))
           rnm1 = cps(nu,1) - cps(ia,1)
           rnm2 = cps(nu,2) - cps(ia,2)
           rnm3 = cps(nu,3) - cps(ia,3)
           rnms = rnm1*rnm1 + rnm2*rnm2 + rnm3*rnm3
           rnm  = dsqrt(rnms)
           rnmc = rnm*rnms
           etr  = etr + z/rnm
           fxyzew_l(nu,1) = fxyzew_l(nu,1) + rnm1*ival(ityp(nu))*z/rnmc
           fxyzew_l(nu,2) = fxyzew_l(nu,2) + rnm2*ival(ityp(nu))*z/rnmc
           fxyzew_l(nu,3) = fxyzew_l(nu,3) + rnm3*ival(ityp(nu))*z/rnmc
         end do
         eewald_rspace = eewald_rspace + iwei(nu)*ival(ityp(nu))*etr
end if
      end do

      if(npes > 1) then
         call mpi_allreduce(eewald_rspace, eewald, 1, mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
      else
         eewald = eewald_rspace
      end if
#ifdef ENABLE_ESM_PACK
      if(sw_esm==OFF) eewald = eewald + e0
#else
      eewald = eewald + e0
#endif
      if(ipri >= 2 .and. printable) write(6,'(" !! eewald = ",f12.4," <<ewald_Rspace_summation>>")') eewald

    end subroutine ewald_Rspace_summation

    subroutine ewald_Rspace_summation_4_stress
      real(kind=DP)  :: zu, za, rnms,rnm,rnmc,fc1,fc2,fc3
      integer        :: nu, in, ia, i, j
      real(kind=DP)  :: derfc
      real(kind=DP)  :: rnm1, rnm2, rnm3, s11,s12,s13,s21,s22,s23,s31,s32,s33,f1,f2,f3
      real(kind=DP), pointer, dimension(:,:) :: s_ewt

      s11=0.d0; s12=0.d0; s13=0.d0; s21=0.d0; s22=0.d0; s23=0.d0; s31=0.d0; s32=0.d0; s33=0.d0
      do nu = ista_atm2, iend_atm2 ! MPI
         zu = ival(ityp_full(nu))
         do in = 1, neibrd
            do ia = 1, natm2
               if(in == 1 .and. ia == nu) cycle
               za = ival(ityp_full(ia))
               rnm1 = cps_fp(nu,1) - cps_fp(ia,1) - rxyz(in,1)
               rnm2 = cps_fp(nu,2) - cps_fp(ia,2) - rxyz(in,2)
               rnm3 = cps_fp(nu,3) - cps_fp(ia,3) - rxyz(in,3)
               rnms = rnm1*rnm1 + rnm2*rnm2 + rnm3*rnm3
               rnm  = dsqrt(rnms)
               rnmc = rnm*rnms
               fc1  = derfc(alfi*rnm)
               fc2  = dexp(-alfi2*rnms)*c3
               fc3  = za * zu * (fc1/rnmc+fc2/rnms) * 0.5d0
               f1 = fc3 * (rnm1*rltv(1,1)+rnm2*rltv(2,1)+rnm3*rltv(3,1))/PAI2
               f2 = fc3 * (rnm1*rltv(1,2)+rnm2*rltv(2,2)+rnm3*rltv(3,2))/PAI2
               f3 = fc3 * (rnm1*rltv(1,3)+rnm2*rltv(2,3)+rnm3*rltv(3,3))/PAI2
               s11 = s11 - rnm1 * f1
               s12 = s12 - rnm1 * f2
               s13 = s13 - rnm1 * f3
               s21 = s21 - rnm2 * f1
               s22 = s22 - rnm2 * f2
               s23 = s23 - rnm2 * f3
               s31 = s31 - rnm3 * f1
               s32 = s32 - rnm3 * f2
               s33 = s33 - rnm3 * f3
            end do
         end do
      end do
      s_ew(1,1)=s11; s_ew(1,2)=s12; s_ew(1,3)=s13
      s_ew(2,1)=s21; s_ew(2,2)=s22; s_ew(2,3)=s23
      s_ew(3,1)=s31; s_ew(3,2)=s32; s_ew(3,3)=s33
      if(npes > 1) then
         allocate(s_ewt(3,3))
         call mpi_allreduce(s_ew,s_ewt,9,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
         s_ew = s_ewt
         deallocate(s_ewt)
      end if
      s_ew = s_ew + c2 * 0.5d0 * rltv / PAI2

    end subroutine ewald_Rspace_summation_4_stress

    subroutine ewald_Gspace_summation
      real(kind=DP), pointer, dimension(:,:) :: fxyzew_mpi ! d(natm,3)

      call get_zsum
      if( sw_screening_correction /= ON ) then
      call add_exp_G2_zsum
#if defined(NEC_TUNE2) || defined(NEC_TUNE_SMP)
      call ewald_force_Gspace_summation(ngabc)
#else
      call ewald_force_Gspace_summation
#endif
      end if

      if( sw_screening_correction == ON ) then
      if(npes > 1) then
         allocate(fxyzew_mpi(natm,3))
         call mpi_allreduce(fxyzew_l, fxyzew_mpi, natm*3,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
         fxyzew_l = fxyzew_mpi
         deallocate(fxyzew_mpi)
      end if
      end if

    end subroutine ewald_Gspace_summation

    subroutine get_zsum
      integer mu, in
      real(kind=DP) :: z, phs, cv1,cv2,cv3
      real(kind=DP),pointer, dimension(:,:) :: zsum_mpi
#ifdef NEC_TUNE4
      real(kind=DP) :: tmp_abc1,tmp_abc2,tmp_abc3
      real(kind=DP) :: tmp_phs0,tmp_phs
#endif

      zsum = 0.d0
      if(kimg == 1) then
         do mu = ista_atm, iend_atm
            z = ival(ityp(mu))*iwei(mu)
            cv1= pos(mu,1)*PAI2
            cv2= pos(mu,2)*PAI2
            cv3= pos(mu,3)*PAI2
#ifdef NEC_TUNE4
!CDIR NODEP
            do in = 1, newldg
               tmp_abc1 = dfloat(ngabc(in,1))
               tmp_abc2 = dfloat(ngabc(in,2))
               tmp_abc3 = dfloat(ngabc(in,3))
               tmp_phs0= 0.0000000000000000e+000
               tmp_phs = tmp_phs0+ cv1*tmp_abc1
               tmp_phs = tmp_phs + cv2*tmp_abc2
               tmp_phs = tmp_phs + cv3*tmp_abc3
               zsum(in,1) = zsum(in,1) + z*dcos(tmp_phs)
            end do
#else
            do in = 1, newldg
               phs = cv1*ngabc(in,1)+cv2*ngabc(in,2)+cv3*ngabc(in,3)
               zsum(in,1) = zsum(in,1) + z*dcos(phs)
            end do
#endif
         end do
      else if(kimg == 2) then
         do mu = ista_atm, iend_atm
            z = ival(ityp(mu))*iwei(mu)
            cv1 = pos(mu,1)*PAI2
            cv2 = pos(mu,2)*PAI2
            cv3 = pos(mu,3)*PAI2
#ifdef NEC_TUNE4
!CDIR NODEP
            do in = 1, newldg
               tmp_abc1 = dfloat(ngabc(in,1))
               tmp_abc2 = dfloat(ngabc(in,2))
               tmp_abc3 = dfloat(ngabc(in,3))
               tmp_phs0= 0.0000000000000000e+000
               tmp_phs = tmp_phs0+ cv1*tmp_abc1
               tmp_phs = tmp_phs + cv2*tmp_abc2
               tmp_phs = tmp_phs + cv3*tmp_abc3
               zsum(in,1) = zsum(in,1) + z*dcos(tmp_phs)
               zsum(in,kimg) = zsum(in,kimg) - z*dsin(tmp_phs)
            end do
#else
            do in = 1, newldg
               phs = cv1*ngabc(in,1)+cv2*ngabc(in,2)+cv3*ngabc(in,3)
               zsum(in,1)    = zsum(in,1)    + z*dcos(phs)
               zsum(in,kimg) = zsum(in,kimg) - z*dsin(phs)
            end do
#endif
         end do
      end if
      if(npes > 1) then
         allocate(zsum_mpi(newldg,kimg))
         call mpi_allreduce(zsum, zsum_mpi, newldg*kimg,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
         zsum = zsum_mpi
         deallocate(zsum_mpi)
      end if

    end subroutine get_zsum

    subroutine add_exp_G2_zsum
      real(kind=DP)  :: gsc,fc1,fc2,etr
      integer        :: in
      integer        :: ist, iend  !mpi
      real(kind=DP)  :: etr_mpi

      etr = 0.d0
      ist = ista_kngp
      if(ist == 1) ist = 2
      iend = iend_kngp
      if( iend > newldg ) iend = newldg
      if(kimg == 1) then
         if( ist <= iend ) then
            do in = ist, iend  !for mpi
               gsc = gr_l(in)**2
               fc1 = dexp(-gsc*alf24)/gsc
               fc2 = fc1*zsum(in,1)**2
               etr = etr + fc2
            end do
         endif
      else if(kimg == 2) then
         if( ist <= iend ) then
            do in = ist, iend  !for mpi
               gsc = gr_l(in)**2
               fc1 = dexp(-gsc*alf24)/gsc
               fc2 = fc1*(zsum(in,1)**2 + zsum(in,kimg)**2)
               etr = etr + fc2
            end do
         end if
      end if
      if(npes > 1) then
         call mpi_allreduce(etr,etr_mpi,1,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
         etr = etr_mpi
      end if
      eewald = eewald + etr*c1
!!$      if(printable) write(nfout,'(" !! eewald = ",f8.4," etr, c1 = ",2f8.4 " <<add_exp_G2_zsum>>")') eewald,etr,c1
      if(istress==1) s_ew = s_ew - etr * c1 * 0.5d0 * rltv / PAI2
    end subroutine add_exp_G2_zsum

#if defined(NEC_TUNE2) || defined(NEC_TUNE_SMP)
    subroutine ewald_force_Gspace_summation(ngabc)
#else
    subroutine ewald_force_Gspace_summation
#endif
      integer       :: nu, in
      real(kind=DP) :: fabc(3),gsc,fc1,fc3, phs, g1,g2,g3,p1,p2,p3
      real(kind=DP), pointer, dimension(:,:) :: fxyzew_mpi ! d(natm,3)
      real(kind=DP) :: sum_abc1,sum_abc2,sum_abc3
#ifdef NEC_TUNE4
      real(kind=DP) :: tmp_phs0,tmp_phs
#endif
#if defined(NEC_TUNE2) || defined(NEC_TUNE_SMP)
      integer, intent(in)                     :: ngabc(kgp,3)
#endif

      call getttr(rltv,ttr)

#ifdef NEC_TUNE_SMP
!CDIR PARALLEL DO PRIVATE(fabc,cxyz,sum_abc1,sum_abc2,sum_abc3,tmp_abc1,tmp_abc2,tmp_abc3)
!CDIR&PRIVATE (tmp_phs0,tmp_phs,gsc,fc1,fc3,gabc)
#endif
!xocl spread do/ind_natm
      do nu = ista_atm, iend_atm  ! MPI
         fabc = 0.d0
         p1 = pos(nu,1)*PAI2
         p2 = pos(nu,2)*PAI2
         p3 = pos(nu,3)*PAI2
         sum_abc1 = fabc(1)
         sum_abc2 = fabc(2)
         sum_abc3 = fabc(3)
#ifdef NEC_TUNE4
!CDIR NODEP
         do in = 1, newldg - 1
            g1 = dfloat(ngabc(1+in,1))
            g2 = dfloat(ngabc(1+in,2))
            g3 = dfloat(ngabc(1+in,3))
            tmp_phs0= 0.0000000000000000e+000
            tmp_phs = tmp_phs0+ p1*g1
            tmp_phs = tmp_phs + p2*g2
            tmp_phs = tmp_phs + p3*g3
            gsc =    ttr(1)*g1*g1 + ttr(2)*g2*g2 + ttr(3)*g3*g3 + ttr(4)*g1*g2 &
                 & + ttr(5)*g2*g3 + ttr(6)*g3*g1
            fc1 = dexp((-gsc*alf24))/gsc
            fc3 = fc1*dsin(tmp_phs)*zsum(1+in,1)
            if (kimg .eq. 2) then
               fc3 = fc3 + fc1*dcos(tmp_phs)*zsum(1+in,kimg)
            endif
            sum_abc1 = sum_abc1 + g1*fc3
            sum_abc2 = sum_abc2 + g2*fc3
            sum_abc3 = sum_abc3 + g3*fc3
         end do
#else
         do in = 2, newldg
            g1 = ngabc(in,1); g2 = ngabc(in,2); g3 = ngabc(in,3)
            phs = p1*g1 + p2*g2 + p3*g3
            gsc =    ttr(1)*g1*g1 + ttr(2)*g2*g2 + ttr(3)*g3*g3 + ttr(4)*g1*g2 &
                 & + ttr(5)*g2*g3 + ttr(6)*g3*g1
            fc1 = exp(-gsc*alf24)/gsc
            fc3 = fc1*dsin(phs)*zsum(in,1)
            if(kimg .eq. 2) fc3 = fc3 + fc1*dcos(phs)*zsum(in,kimg)
            sum_abc1 = sum_abc1 + g1*fc3
            sum_abc2 = sum_abc2 + g2*fc3
            sum_abc3 = sum_abc3 + g3*fc3
         end do
#endif
         fabc(1) = sum_abc1
         fabc(2) = sum_abc2
         fabc(3) = sum_abc3
         fxyzew_l(nu,1:3) = fxyzew_l(nu,1:3) + matmul(rltv,fabc)*c1*ival(ityp(nu))
      end do
!xocl end spread

      if(npes > 1) then
         allocate(fxyzew_mpi(natm,3))
         call mpi_allreduce(fxyzew_l, fxyzew_mpi, natm*3,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
         fxyzew_l = fxyzew_mpi
         deallocate(fxyzew_mpi)
      end if

    end subroutine ewald_force_Gspace_summation

    subroutine ewald_stress_Gspace_summation
      real(kind=DP) :: ga,gb,gc,gsc,fc1,fc2,g1,g2,g3,s11,s12,s13,s21,s22,s23,s31,s32,s33,f1,f2,f3,c0
      integer       :: in,i,j
      integer       :: ist, iend !mpi
      real(kind=DP), pointer, dimension(:,:) :: s_ewt, s_ew_mpi2

      allocate(s_ewt(3,3))
      ist = ista_kngp
      if(ist == 1) ist = 2
      iend = iend_kngp
      if( iend > newldg ) iend = newldg
      s11=0.d0;s12=0.d0;s13=0.d0;s21=0.d0;s22=0.d0;s23=0.d0;s31=0.d0;s32=0.d0;s33=0.d0
      if( ist <= iend ) then
         do in = ist, iend  !for mpi
            ga = ngabc(in,1); gb = ngabc(in,2); gc = ngabc(in,3)
            g1 = rltv(1,1)*ga+rltv(1,2)*gb+rltv(1,3)*gc
            g2 = rltv(2,1)*ga+rltv(2,2)*gb+rltv(2,3)*gc
            g3 = rltv(3,1)*ga+rltv(3,2)*gb+rltv(3,3)*gc
            gsc = gr_l(in)**2
            fc1 = dexp(-gsc*alf24)/gsc
            fc2 = fc1*(zsum(in,1)**2+zsum(in,kimg)**2)/(3.d0-kimg)
            c0 = c1*fc2 /PAI2 * (1.d0/gsc + alf24)
            f1 = c0 * (g1*rltv(1,1)+g2*rltv(2,1)+g3*rltv(3,1))
            f2 = c0 * (g1*rltv(1,2)+g2*rltv(2,2)+g3*rltv(3,2))
            f3 = c0 * (g1*rltv(1,3)+g2*rltv(2,3)+g3*rltv(3,3))

            s11 = s11 + g1*f1
            s12 = s12 + g1*f2
            s13 = s13 + g1*f3
            s21 = s21 + g2*f1
            s22 = s22 + g2*f2
            s23 = s23 + g2*f3
            s31 = s31 + g3*f1
            s32 = s32 + g3*f2
            s33 = s33 + g3*f3
         end do
      end if
      s_ewt(1,1)=s11;s_ewt(1,2)=s12;s_ewt(1,3)=s13
      s_ewt(2,1)=s21;s_ewt(2,2)=s22;s_ewt(2,3)=s23
      s_ewt(3,1)=s31;s_ewt(3,2)=s32;s_ewt(3,3)=s33
      if(npes > 1) then
         allocate(s_ew_mpi2(3,3))
         call mpi_allreduce(s_ewt,s_ew_mpi2,9,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
         s_ew = s_ew + s_ew_mpi2
         deallocate(s_ew_mpi2)
      else
         s_ew = s_ew + s_ewt
      end if
      deallocate(s_ewt)
    end subroutine ewald_stress_Gspace_summation

    subroutine set_ewald_parameters
      integer       :: ia
      real(kind=DP) :: z
      alf2 = alf**2
      alf24= alf2*0.25d0
      alfi = 1.d0/alf
      alfi2= alfi**2
      c1   = 4*PAI/univol
      c3   = 2*alfi/dsqrt(PAI)
      c2   = 0.d0
      c4   = 0.d0
      do ia = 1,natm2
         z  = ival(ityp_full(ia))
         c2 = c2 + z
         c4 = c4 + z**2
      end do
      c2 = PAI*alf2/univol*c2**2
      if(ipri >= 2 .and. printable) then
        write(nfout,'(" natm, natm2 = ",2i5)') natm,natm2
        write(nfout,'(" alf, alf2 = ",2d20.10)') alf, alf2
        write(nfout,160) c1,c2,c3,c4
  160   format(' ',' PI4/UNIVOL = ',F12.6,' Z**2*PI*ALF2/UNIVOL = ',&
     &                         F12.6/,' ',' 2/DSQRT(PI)*ALFI = ',&
     &                        F12.6,' SUM Z(NU)**2 = ',F12.6)
      end if

    end subroutine set_ewald_parameters

    subroutine cpspac
      real(kind=DP), dimension(3) :: catoms(3)
      integer                     :: i
      do i = 1, natm2
         catoms = cps_fp(i,1:3)
         catoms = catoms - nint(catoms)      !Packing
         cps_fp(i,1:3) = matmul(altv,catoms) !Change of coordinate system
      end do
    end subroutine cpspac

    subroutine decide_newldg
      integer i
      integer  :: iend, newldg_mpi  !mpi

      newldg_mpi= 1
      newldg= 1
      if(printable) write(nfout,'(" ! kg = ",i9)') kg
      iend = iend_kngp
      if( iend > kg ) iend = kg
      if( ista_kngp <= iend ) then
         do i = ista_kngp, iend  !for mpi
            if(alf*gr_l(i) < phi*2.d0) newldg_mpi = i
         end do
      endif
      if(npes > 1) then
         call mpi_allreduce(newldg_mpi,newldg,1,mpi_integer,mpi_max,mpi_comm_group,ierr)
      else
         newldg = newldg_mpi
      end if
      if(newldg.eq.kg+1) then
         if(printable) write(nfout,'(" **warn alf is too small: alf=",d20.10)') alf
         stop
      endif
      if(printable) write(nfout,440) newldg
  440 format(' ',' newldg = ',i8)
    end subroutine decide_newldg

    subroutine decide_alf
      real(kind=DP)                    :: xalen(3), aamin

      xalen = alen*(abs(int(rsphere_radius/alen)) + 1)
      aamin = minval(xalen)
      alf = aamin/phi
      if(printable) write(nfout,'("  alf = ",f12.6," aamin = ",f12.6)') alf, aamin
    end subroutine decide_alf
  end subroutine m_IS_ewald

  subroutine m_IS_symm_check_of_pos()

    real(kind=DP), pointer, dimension(:,:) :: cps_full
    integer,       pointer, dimension(:)   :: ityp_full
    real(kind=DP), pointer, dimension(:,:) :: rxyz
    real(kind=DP), pointer, dimension(:)   :: rr
    real(kind=DP), parameter :: rsphere_radius = 12.5d0
!      integer, parameter ::  neibr = 3
!      integer, parameter ::  neibrd =(2*neibr+1)**3
    integer neibrd
    integer,dimension(3) :: alen
    integer              :: id_sname = -1
#ifdef __TIMER_SUB__
  call timer_sta(1228)
#endif

    call tstatc0_begin('m_IS_symm_check_of_pos ',id_sname,1)

    allocate(cps_full(natm2,3))
    allocate(ityp_full(natm2))
    call decide_rxyz_size(rsphere_radius,alen,neibrd)
    allocate(rxyz(neibrd,3))
    allocate(rr(neibrd))
    call substitute_rxyz(alen, neibrd, rxyz, rr)
    deallocate(rr)
    cps_full(1:natm,1:3) = cps(1:natm,1:3)
    ityp_full(1:natm) = ityp(1:natm)
    call rplcps(cps_full, ityp_full, 1, natm2, natm, iwei)
    call symm_check_of_ions_positions_c()

    if( ngen_tl >= 1) call wd_napt_tl()

    deallocate(rxyz)
    deallocate(ityp_full)
    deallocate(cps_full)

    call tstatc0_end(id_sname)
#ifdef __TIMER_SUB__
  call timer_end(1228)
#endif
  contains
    subroutine wd_napt_tl()
      integer :: i,j
      write(nfout,'(" --- napt_tl ---")')
      do i = 1, ngen_tl
         write(nfout,'(i3, " : ",25i4)') i,(napt_tl(j,i),j=1,min(natm,25))
      end do
    end subroutine wd_napt_tl

    subroutine symm_check_of_ions_positions_c()
      integer no, i, j, it, jt
      real(kind=DP) :: f(3),f2(3)
!!$      real(kind=DP), parameter :: ddd = 1.d-12, dde = 1.d-6
      real(kind=DP), parameter :: dde = 1.d-6

      do i = 1, natm
!!$         N_operations :  do no = 1, nopr+af
         N_operations :  do no = 1, nopr+af+ngen_tl
            if(no <= nopr+af) then
               f = matmul(op(1:3,1:3,no),cps_full(i,1:3))+tau(1:3,no,CARTS)
            else
               f = matmul(op_tl(1:3,1:3,no-(nopr+af)),cps_full(i,1:3))+tau_tl(1:3,no-(nopr+af),CARTS)
            end if
            !!$print '(" cps             = ",3f12.8)', cps_full(i,1:3)
            !!$print '(" cps(translated) = ",3f12.8)', f
            AtomSearch: do j = 1,natm2
               f2(1) = abs(cos(sum(rltv(1:3,1)*(f - cps_full(j,1:3))))-1.d0)
               f2(2) = abs(cos(sum(rltv(1:3,2)*(f - cps_full(j,1:3))))-1.d0)
               f2(3) = abs(cos(sum(rltv(1:3,3)*(f - cps_full(j,1:3))))-1.d0)
               !!$print '(" cps             = ",3f12.8)', cps_full(i,1:3)
               !!$print '(" f2              = ",3f12.8)', f2
!!$               if(maxval(f2) <= ddd) then
               if(maxval(f2) <= symmetry_check_criterion) then
                  it=ityp_full(i)
                  jt=ityp_full(j)
                  if(ityp_full(i) /= ityp_full(j) .and. (no <= nopr .or. nopr+af+1<=no) ) then
                     if(printable) write(nfout,9001) i, ityp_full(i), j, ityp_full(j), no
                     stop
                  endif
                  if( (abs(iatomn(it) - iatomn(jt)) > 1.d-8) .and. (no > nopr .and. no < nopr+af+1)) then
                     if(printable) write(nfout,9002) i,iatomn(it),j,iatomn(jt),no
                     stop
                  endif
                  if(no<=nopr+af) then
                     napt(i,no) = j
                  else
                     napt_tl(i,no-(nopr+af)) = j
                  end if
                  cycle N_operations
               else if(maxval(f2) <= dde) then
                  if(printable) then
                     write(nfout,'(" -- <<symmetry_check_of_ions_positions_c>> --")')
                     write(nfout,'(" maxval(f2) <= ",d20.8)') dde
                     write(nfout,'(" i = ",i5," no = ",i2," j = ",i5," maxval(f2) = ",d12.5)') i, no, j, maxval(f2)
                     write(nfout,'(" cps(",i5,")        = ",3f20.12)') i,cps_full(i,1:3)
                     write(nfout,'(" op(no)*cps(",i5,") = ",3f20.12)') i,f(1:3)
                     write(nfout,'(" cps(",i5,")        = ",3f20.12)') j,cps_full(j,1:3)
                     write(nfout,'(" f2(1:3)           = ",3f20.12)') f2(1:3)
                  end if
               end if
            end do AtomSearch
            if(printable) then
               write(nfout,*) ' no pair i(atom, no(operation-no.) ', i,no
               write(nfout,'(" cps_full(",i5,")       = ",3f20.12)') i,cps_full(i,1:3)
               write(nfout,'(" op(no)*cps(",i5,")     = ",3f20.12)') i,f(1:3)
            end if
            stop ' no pair of an operated atom <<m_IS_symm_check_of_pos>>'
         enddo N_operations
      enddo
9001  format(i3,'-th site ( atom type = ',i3,' ) is transfered to',/,i3,&
           &     '-th site ( atom type = ',i3,' ) by', i3, '-th operation')
9002  format(i3,'-th site ( atom no.  = ',i3,' ) is transfered to',/,i3,&
           &     '-th site ( atom no.  = ',i3,' ) by', i3, '-th operation')

      if(inversion_symmetry == ON) then
         do i = 1, natm
!!$            N_operations :  do no = 1, nopr+af
            Inv_operations :  do no = 1, 1
               f = -cps_full(i,1:3)
               AtomSearch2: do j = 1,natm2
                  f2(1) = abs(cos(sum(rltv(1:3,1)*(f - cps_full(j,1:3))))-1.d0)
                  f2(2) = abs(cos(sum(rltv(1:3,2)*(f - cps_full(j,1:3))))-1.d0)
                  f2(3) = abs(cos(sum(rltv(1:3,3)*(f - cps_full(j,1:3))))-1.d0)
                  if(maxval(f2) <= symmetry_check_criterion) then
                     it=ityp_full(i)
                     jt=ityp_full(j)
                     if(ityp_full(i) /= ityp_full(j) ) then
                        if(printable) write(nfout,9003) i, ityp_full(i), j, ityp_full(j)
                        stop
                     endif
                     if( (abs(iatomn(it) - iatomn(jt)) > 1.d-8) ) then
                        if(printable) write(nfout,9004) i,iatomn(it),j,iatomn(jt)
                        stop
                     endif
                     cycle Inv_operations
                  else if(maxval(f2) <= dde) then
                     if(printable) then
                        write(nfout,'(" -- <<symmetry_check_of_ions_positions_c>> inversion_symmetry--")')
                        write(nfout,'(" maxval(f2) <= ",d20.8)') dde
                        write(nfout,'(" i = ",i5," j = ",i5," maxval(f2) = ",d12.5)') i, j, maxval(f2)
                        write(nfout,'(" cps(",i5,")        = ",3f20.12)') i,cps_full(i,1:3)
                        write(nfout,'(" -cps(",i5,")       = ",3f20.12)') i,f(1:3)
                        write(nfout,'("  cps(",i5,")       = ",3f20.12)') j,cps_full(j,1:3)
                        write(nfout,'(" f2(1:3)            = ",3f20.12)') f2(1:3)
                     end if
                  end if
               end do AtomSearch2
               if(printable) then
                  write(nfout,*) ' no pair i(atom, inversion_symmetry)', i
                  write(nfout,'(" cps_full(",i5,")       = ",3f20.12)') i,cps_full(i,1:3)
                  write(nfout,'(" op(inv)*cps(",i5,")    = ",3f20.12)') i,f(1:3)
               end if
               stop ' "sw_inversion = ON" is invalid <<m_IS_symm_check_of_pos>>'
            enddo Inv_operations
         enddo
9003     format(i3,'-th site ( atom type = ',i3,' ) is transfered to',/,i3,&
              &     '-th site ( atom type = ',i3,' ) by the inversion_symmetry')
9004     format(i3,'-th site ( atom no.  = ',i3,' ) is transfered to',/,i3,&
           &     '-th site ( atom no.  = ',i3,' ) by the inversion_symmetry')
      end if

      if(printable) write(nfout,*) ' -- OK symmetry check of atomic coordinates'
      if(ipri >= 2 .and. printable) then
         do i = 1, natm
            write(nfout,'(" na = ",i5)') i
            write(nfout,'(8i8)') (napt(i,j),j=1,nopr+af)
         enddo
      endif

    end subroutine symm_check_of_ions_positions_c
  end subroutine m_IS_symm_check_of_pos

  subroutine decide_rxyz_size(rsphere_radius, alen, neibrd)
    real(kind=DP), intent(in)  :: rsphere_radius
    integer,       intent(out) :: neibrd
  
    integer,  intent(out), dimension(3) :: alen
    real(kind=DP)               :: a
    integer i

#ifdef __TIMER_SUB__
  call timer_sta(1252)
#endif

    do i = 1, 3
       a=dabs((rltv(1,i)*altv(1,i)+rltv(2,i)*altv(2,i)+rltv(3,i)*altv(3,i))&
            &/dsqrt(rltv(1,i)*rltv(1,i)+rltv(2,i)*rltv(2,i)+rltv(3,i)*rltv(3,i)))
       alen(i) = abs(int(rsphere_radius/a)) + 1
    enddo

    neibrd = (alen(1)*2+1)*(alen(2)*2+1)*(alen(3)*2+1)
#ifdef __TIMER_SUB__
  call timer_end(1252)
#endif
  end subroutine decide_rxyz_size

  subroutine substitute_rxyz(alen, neibrd, rxyz, rr)
    integer, intent(in), dimension(3) :: alen
    integer, intent(in)               :: neibrd
    real(kind=DP), intent(out), dimension(neibrd,3) :: rxyz
    real(kind=DP), intent(out), dimension(neibrd)   :: rr
    
    integer i, j, k, mm
    real(kind=DP) :: f(3)

#ifdef __TIMER_SUB__
  call timer_sta(1253)
#endif
#ifdef SX
!CDIR SERIAL
#endif
    mm = 0
#ifdef SX
!CDIR NOVECTOR
#endif
    do i = -alen(1), alen(1)
#ifdef SX
!CDIR NOVECTOR
#endif
       do j = -alen(2), alen(2)
#ifdef SX
!CDIR NOVECTOR
#endif
          do k = -alen(3), alen(3)
             f(1) = i; f(2) = j; f(3) = k
             mm = mm + 1
             rxyz(mm,1:3) = matmul(altv,f)
             rr(mm) = dsqrt(dot_product(rxyz(mm,1:3),rxyz(mm,1:3)))
          enddo
       enddo
    enddo

    call hpsort(neibrd,neibrd,rxyz,rr)
#ifdef SX
!CDIR ENDSERIAL
#endif

#ifdef __TIMER_SUB__
  call timer_end(1253)
#endif
  end subroutine substitute_rxyz

  subroutine m_IS_initialize_mdmode
    mdmode = ORDINA
  end subroutine m_IS_initialize_mdmode

  subroutine m_IS_initialize_cpd_l
    cpd_l = 0.d0
  end subroutine m_IS_initialize_cpd_l

  subroutine m_IS_cps_to_pos
    integer ia
    do ia = 1, natm
       pos(ia,1:3) = matmul(transpose(rltv),cps(ia,1:3))/PAI2
    end do
  end subroutine m_IS_cps_to_pos

  subroutine m_IS_wd_forc(forc_l)
    real(kind=DP), intent(in), dimension(natm,3) :: forc_l
    integer :: i,j

    if(printable) then
       write(nfout,'(" -- pos, forc_l --")')
       do i = 1, natm
          write(nfout,'(i5,3e13.5,3e12.4)') i,(pos(i,j),j=1,3),(forc_l(i,j),j=1,3)
       end do
    end if
  end subroutine m_IS_wd_forc

  subroutine m_IS_rd_T_parameters(mdalg,nfinp)
    integer, intent(in) :: mdalg,nfinp

    logical             :: EOF_reach, tag_is_found
    real(kind=DP),pointer, dimension(:) :: wk

    if(.not.tag_T_cntrl_is_found) then
       if(mdalg == QUENCHED_CONSTRAINT) call forcp_alloc !-(m_Ionic_System) ->(forcp)
       return
    end if

    allocate(wk(natm*3+1))
!!$    num_Treservoir = nrsv
    call T_control_alloc(nrsv)   ! -(m_Ionic_System) ->(qmass,tkb,cprv,cpqr,forcp)
    call get_qmass_tkb_cprv_cpqr  ! -(contained here) ->(qmass,tkb,cprv,cpqr)
    if(icond == INITIAL) call get_cpd_l   ! -(contained here) ->(cpd_l)
    deallocate(wk)

  contains
    subroutine get_qmass_tkb_cprv_cpqr
      integer :: n

      qmass = 0.d0; tkb = 0.d0

      call rewind_to_tag0(nfinp,len(tag_T_cntrl),tag_T_cntrl &
           &, EOF_reach, tag_is_found, str,len_str)
      if(.not.tag_is_found) &
           call rewind_to_tag0(nfinp,len(tag_T_cntrl2),tag_T_cntrl2&
           &, EOF_reach, tag_is_found, str, len_str)
      do
         read(nfinp,'(a132)',end=1002) str
         call strncmp2(str,len_str,tag_heat_bath,len(tag_heat_bath),tag_is_found)
         if(tag_is_found) then
            call read_LHS_number(str,len_str,wk,4)
            n = nint(wk(1))
            if(icond == INITIAL) then
               call read_RHS_number(str,len_str,wk,4)
            else
               call read_RHS_number(str,len_str,wk,2)
            end if
            if(dabs(qmass(n)) > DELTA .and. printable) &
                 & write(nfout,'(" !D redundant (qmass, tkb) : n = ")') n
            qmass(n) = wk(1);    tkb(n)   = wk(2)
            if(icond == INITIAL) then
               cprv(n)   = wk(3)
               cpqr(n,1) = wk(4);    cpqr(n,2) = 0.d0
            end if
         end if
      end do
1002  continue

      if(printable) then
         do n = 1, nrsv
            write(nfout,'(" heat bath (qmass, tkb ) (",i5,") = (",2d12.4,")")') &
                 & n,qmass(n),tkb(n)
         end do
      end if
    end subroutine get_qmass_tkb_cprv_cpqr

    subroutine get_cpd_l
      integer :: ipnt, i
! initial velocity
      wk = 0.d0
      call rewind_to_tag0(nfinp,len(tag_T_cntrl),tag_T_cntrl,EOF_reach,tag_is_found &
           &, str, len_str)
      if(.not.tag_is_found) &
           call rewind_to_tag0(nfinp,len(tag_T_cntrl2),tag_T_cntrl2 &
           & ,EOF_reach,tag_is_found, str, len_str)
           
      do while(.true.)
         read(nfinp,'(a132)',end=1003) str
         call strncmp2(str,len_str,tag_atom_velocity,len(tag_atom_velocity),tag_is_found)
         if(tag_is_found) then
            call read_LHS_number(str,len_str,wk(natm*3+1),1)
            i = nint(wk(natm*3+1))
            if(i <= 0) stop ' ! i < 0 (m_IS_rd_T_parameters)'
            ipnt = 3*(i-1) + 1
            if( dabs(wk(ipnt)) + dabs(wk(ipnt+1)) + dabs(wk(ipnt+2)) > DELTA &
                 & .and. printable) &
                 & write(nfout,'(" !D redundant (velocity) : i = ",i5)') i
            call read_RHS_number(str,len_str,wk(ipnt),3)
         end if
      end do
1003  continue

!xocl spread do/ind_natm
      do i = 1, natm
         ipnt = 3*(i-1)+1
         cpd_l(i,1) = wk(ipnt)
         cpd_l(i,2) = wk(ipnt+1)
         cpd_l(i,3) = wk(ipnt+2)
      end do
!xocl end spread

      if(printable) then
         write(nfout,'(" !! initial -- velocity --")')
         do i = 1, natm
!xocl spread do/ind_natm
!xocl index i
            write(nfout,'(" velocity atom ",i2," = ", 3d17.9)') i, cpd_l(i,1),cpd_l(i,2),cpd_l(i,3)
!xocl end spread
         enddo
      end if
    end subroutine get_cpd_l
  end subroutine m_IS_rd_T_parameters

  subroutine T_control_dealloc()
    integer :: i
    if(allocated(qmass)) deallocate(qmass)
    if(allocated(tkb)) deallocate(tkb)
    if(allocated(cprv)) deallocate(cprv)
    if(allocated(frsv)) deallocate(frsv)
    if(allocated(cpqr)) deallocate(cpqr)
    if(allocated(forcp)) deallocate(forcp)
    if(allocated(natm_per_thermo)) deallocate(natm_per_thermo)
! ==== KT_add == 2014/06/10
    if (allocated(mdstep_at_start_thermostat) ) deallocate(mdstep_at_start_thermostat)
    if (allocated(mdstep_at_end_thermostat) ) deallocate(mdstep_at_end_thermostat)
    if (allocated(temp_at_start_thermostat) ) deallocate(temp_at_start_thermostat)
    if (allocated(temp_at_end_thermostat) ) deallocate(temp_at_end_thermostat)
! ============== 2014/06/10
    if(nchain>1)then
      deallocate(qmass_c)
      deallocate(cprv_c)
      deallocate(cpqr_c)
    endif
    if(allocated(temperature_profile)) then
       do i=1,nrsv
          deallocate(temperature_profile(i)%tempi)
          deallocate(temperature_profile(i)%tempf)
          deallocate(temperature_profile(i)%qmass)
          deallocate(temperature_profile(i)%tdamp)
          deallocate(temperature_profile(i)%till_n)
       enddo
       deallocate(temperature_profile)
    endif
  end subroutine T_control_dealloc

  subroutine T_control_alloc(n_Treservoir)
    integer, intent(in) :: n_Treservoir
    integer :: ir,iat,icnstrnt_typ,i

    allocate(qmass(n_Treservoir)); qmass = 10.d0
    allocate(tkb(n_Treservoir));   tkb   = 300  ! (K)
! ==== KT_add == 2014/06/10
    allocate(mdstep_at_start_thermostat(n_Treservoir))
    allocate(mdstep_at_end_thermostat(n_Treservoir))
    mdstep_at_start_thermostat = 1
    mdstep_at_end_thermostat =   1
    allocate(temp_at_start_thermostat(n_Treservoir))
    allocate(temp_at_end_thermostat(n_Treservoir))
    temp_at_start_thermostat = tkb
    temp_at_start_thermostat = tkb
! ============== 2014/06/10

    allocate(cprv(n_Treservoir));  cprv = 0.d0
    allocate(frsv(n_Treservoir));  frsv = 0.d0
    allocate(cpqr(n_Treservoir,2));  cpqr = 0.d0
    allocate(natm_per_thermo(n_Treservoir)); natm_per_thermo=0
    do iat=1,natm
       ir = icnstrnt_typ(imdtyp(iat),imdalg)
       if (ir>=1) natm_per_thermo(ir) = natm_per_thermo(ir)+1
    enddo
    call forcp_alloc()

    if(nchain>1)then
       allocate(qmass_c(n_Treservoir,nchain));qmass_c = 10.d0
       allocate(cprv_c(n_Treservoir,nchain));cprv_c = 0.d0
       allocate(cpqr_c(n_Treservoir,nchain));cpqr_c = 0.d0
       qmass_c(1:nrsv,1) = qmass(1:nrsv)
       qfactor = 0.d0
       do iat=1,natm
          ir = icnstrnt_typ(imdtyp(iat),imdalg)
          if(ir >= 1) then
              qfactor = qfactor+3.d0*iwei(iat)
          endif
       enddo
       qfactor = 1.d0/dsqrt(qfactor) 
       do i=2,nchain
          qmass_c(1:nrsv,i) = qmass(1:nrsv) * qfactor
       enddo
    endif
    !   print *,' -- natm = ',natm
  end subroutine T_control_alloc

  subroutine alloc_temperature_profile(nrsv)
    integer, intent(in) :: nrsv
    integer :: i,iat,ir,icnstrnt_typ
    allocate(temperature_profile(nrsv))
    do i=1,nrsv
       temperature_profile(i)%no = 0
       temperature_profile(i)%natm = 0
       temperature_profile(i)%currprof = 0
       temperature_profile(i)%nprof = 0
    enddo
    do iat=1,natm
       ir = icnstrnt_typ(imdtyp(iat),imdalg)
       if (ir>=1) temperature_profile(ir)%natm = temperature_profile(ir)%natm+1
    enddo
    call T_control_alloc(nrsv)
  end subroutine alloc_temperature_profile

  subroutine forcp_alloc()
    if(allocated(forcp)) deallocate(forcp)
    allocate(forcp(natm,3))
    forcp = 0.d0
    if(ipriinputfile>=2) write(nfout,'(" !! forcp is allocated <<forcp_alloc>>")')
  end subroutine forcp_alloc

  subroutine m_IS_rd_forcp_etc(mdalg,nfcntn)
    integer, intent(in) :: mdalg
    integer, intent(in) :: nfcntn
    integer :: i,j
    logical :: tag_is_found, EOF_reach

    if(iprimd >= 1) write(nfout,'(" -- m_IS_rd_forcp_etc --")')
    if(mype==0) then
       call rewind_to_tag0(nfcntn,len(tag_forcp),tag_forcp, EOF_reach, tag_is_found, str,len_str)
       if(.not.tag_is_found) then
          stop ' tag_forcp is not found <<m_IS_rd_forcp_etc>>'
       else
!!$          read(nfcntn,*)
          if(iprimd >= 1) then
             write(nfout,'(a132)') str
             write(nfout,'(" !** -- forcp -- <<m_IS_rd_forcp_etc>>")')
          end if
          read(nfcntn,*) (forcp(i,1),forcp(i,2),forcp(i,3),i=1,natmorg)
          if(mdalg /= QUENCHED_CONSTRAINT) then
             read(nfcntn,*)
             if(nchain == 1)then
               read(nfcntn,*) (cprv(i),cpqr(i,1),cpqr(i,2),frsv(i),i=1,nrsv)
             else
               read(nfcntn,*) (frsv(i),i=1,nrsv)
               do i=1,nchain
                 read(nfcntn,*) (cprv_c(j,i),cpqr_c(j,i),j=1,nrsv)
               enddo
             endif
          end if
          if(mdalg == BLUEMOON .or. mdalg == QUENCHED_CONSTRAINT) then
             read(nfcntn,*) str
             if(iprimd >= 2) then 
                write(nfout,'(a132)') str
                write(nfout,'(" !** -- gca -- <<m_IS_rd_forcp_etc>>")')
             end if
             read(nfcntn,*) (gca(i,1),gca(i,2),gca(i,3),i=1,natmorg)
          end if
       end if
    end if
    if(npes > 1) then
       call mpi_bcast(forcp,natmorg*3 &
            & ,mpi_double_precision,0,mpi_comm_group,ierr)
       if(nchain==1)then
       call mpi_bcast(cprv,nrsv &
            & ,mpi_double_precision,0,mpi_comm_group,ierr)
       call mpi_bcast(cpqr,nrsv*2 &
            & ,mpi_double_precision,0,mpi_comm_group,ierr)
       else
       call mpi_bcast(cprv_c,nrsv*nchain &
            & ,mpi_double_precision,0,mpi_comm_group,ierr)
       call mpi_bcast(cpqr_c,nrsv*nchain &
            & ,mpi_double_precision,0,mpi_comm_group,ierr)
       endif
       call mpi_bcast(frsv,nrsv &
            & ,mpi_double_precision,0,mpi_comm_group,ierr)
       if(mdalg == BLUEMOON .or. mdalg == QUENCHED_CONSTRAINT) then
         call mpi_bcast(gca,natmorg*3 &
              & ,mpi_double_precision,0,mpi_comm_group,ierr)
       endif
    end if
  end subroutine m_IS_rd_forcp_etc

  subroutine m_IS_wd_forcp_etc(mdalg,nfcntn)
    integer, intent(in) :: mdalg,nfcntn
    integer :: i,j
    if(mype==0) then
       write(nfcntn,'(" -- forcp --")')
       write(nfcntn,'(3d24.16)') (forcp(i,1),forcp(i,2),forcp(i,3),i=1,natm)
       if(mdalg /= QUENCHED_CONSTRAINT) then
          if(nchain == 1)then
            write(nfcntn,'(" -- cprv,cpqr(*,1:2),frsv --")')
            write(nfcntn,'(4d24.16)') &
               & (cprv(i),cpqr(i,1),cpqr(i,2),frsv(i),i=1,nrsv)
          else
            write(nfcntn,'(" -- frsv,cprv_c,cpqr_c --")')
            write(nfcntn,'(4d24.16)') (frsv(i),i=1,nrsv)
            do i=1,nchain
              write(nfcntn,'(4d24.16)') (cprv_c(j,i),cpqr_c(j,i),j=1,nrsv)
            enddo
          endif
       end if
       if(mdalg == BLUEMOON .or. mdalg == QUENCHED_CONSTRAINT) then
          write(nfcntn,'(" -- gca --")')
          write(nfcntn,'(3d24.16)') (gca(i,1),gca(i,2),gca(i,3),i=1,natm)
       end if
    endif
  end subroutine m_IS_wd_forcp_etc

  subroutine m_IS_rd_nrsv(nfcntn)
    integer, intent(in)       :: nfcntn
    logical    :: EOF_reach, tag_is_found

    if(mype==0) then
       call rewind_to_tag0(nfcntn,len(tag_T_cntrl),tag_T_cntrl &
            &, EOF_reach, tag_is_found,str,len_str)
       if(.not.tag_is_found) then
          call rewind_to_tag0(nfcntn,len(tag_T_cntrl2),tag_T_cntrl2&
               &, EOF_reach, tag_is_found, str,len_str)
          if(.not.tag_is_found) then
             stop ' tag_T_cntrl is not found'
          end if
       end if
       read(nfcntn,*)
       read(nfcntn,*) nrsv
    endif
    if(npes > 1) call mpi_bcast(nrsv,1,mpi_integer,0,mpi_comm_group,ierr)
    if(printable) write(nfout,'(i5, " : nrsv")') nrsv
  end subroutine m_IS_rd_nrsv

  subroutine m_IS_wd_nrsv(nfcntn)
    integer, intent(in)       :: nfcntn
    if(mype==0) then
       write(nfcntn,*) tag_T_cntrl
       write(nfcntn,'(" -- nrsv --")')
       write(nfcntn,'(i10)') nrsv
    endif
  end subroutine m_IS_wd_nrsv

  subroutine m_IS_rd_nrsv_stdin(nfinp)
    integer, intent(in)       :: nfinp

    logical :: eof_reach, tag_is_found
    real(kind=DP) :: wk(1)

    if(imdalg /= T_CONTROL .and. imdalg /= BLUEMOON) return
    call rewind_to_tag0(nfinp,len(tag_T_cntrl), tag_T_cntrl &
         &, EOF_reach, tag_T_cntrl_is_found, str, len_str)
    if(.not.tag_T_cntrl_is_found) &
         & call rewind_to_tag0(nfinp,len(tag_T_cntrl2), tag_T_cntrl2 &
         &, EOF_reach, tag_T_cntrl_is_found, str, len_str)
    if(printable) write(nfout,'(" -- after rewind_to_tag0 --")')

    if(.not.tag_T_cntrl_is_found) then
       if(printable) write(nfout,'(" ! NO TAG of (TEMPERATURE_CONTROL)")')
       return
    end if
    if(printable) write(nfout,'(" -tag_T_cntrl_is_found-")')
!!$ after rewind_to_tag0 --'

    nrsv = 1  ! nrsv: number of heat bath
    tag_is_found = .false.
    do while(.not.tag_is_found)
       read(nfinp,'(a132)') str
       call strncmp2(str,len_str,tag_nrsv,len(tag_nrsv),tag_is_found)
       if(tag_is_found) then
          call read_RHS_number(str,len_str,wk,1)
          nrsv = nint(wk(1))
       end if
    end do
    if(nrsv < 1) nrsv = 1
    call f_strcpy(tag_T_cntrl,len(tag_T_cntrl),str,60)
    if(printable) write(nfout,'(a60)') str(1:60)
    if(printable) write(nfout,'(" nrsv = ",i5)') nrsv
  end subroutine m_IS_rd_nrsv_stdin

  subroutine check_imdtyp(mdalg,external_fix_or_free, ifix,ifree,ifix_P_ifree)
    ! check of the #atoms under constraint and #fixed atoms
    external                external_fix_or_free
    integer, intent(in)  :: mdalg
    integer              :: external_fix_or_free
    integer, intent(out) :: ifix, ifree, ifix_P_ifree
    integer              :: ia,ir

    ifix  = 0
    ifree = 0
    do ia = 1, natm
       ir = external_fix_or_free(imdtyp(ia))
       if(ir > nrsv) then
          if(printable) write(nfout,'(" ia, ir, nrsv = ",3i5)') ia,ir,nrsv
          stop
       end if
       if(ir == FIX_HBATH)   ifix  = ifix + 1
       if(ir == RELAX_HBATH) ifree = ifree + 1
    end do
    ifix_P_ifree = ifix + ifree
    if(mdalg == BLUEMOON .and. ifree /= 0) then
       if(printable) write(nfout,'(" *** Some atoms are out of control. *** ")')
       stop
    end if
    if(ifix == natm) then
       if(printable) write(nfout,'(" ** All atoms are fixed. ***")')
       if(printable) write(nfout,'(" ! ifix, natm = ",2i5)') ifix, natm
       stop
    end if
  end subroutine check_imdtyp

  subroutine vlcty_accrd2_vVerlet(mdalg,forc_l,ifq,fcg)
    integer              :: icnstrnt_typ
    integer, intent(in) ::                              mdalg
    real(kind=DP), intent(in),dimension(natm,3) ::      forc_l(natm,3)
    integer, intent(out),optional,dimension(natm,3) ::  ifq
    real(kind=DP), optional,      dimension(3) ::       fcg
    integer              :: ia, ir, j
    real(kind=DP)        :: cpdxyz(natm,3),frcxyz(3)
    real(kind=DP)        :: dtml,dtz
    integer, allocatable, dimension(:,:) :: mxyz 
    allocate(mxyz(natm,3))
    do ia=1,natm
       mxyz(ia,1:3) = 1
       do j=1,3
          if(imdtypxyz(ia,j) == OFF) mxyz(ia,j) = 0
       enddo
    enddo


    do ia = 1, natm
       ir = icnstrnt_typ(imdtyp(ia),mdalg)         !-(b_Ionic_System)
       if(ir == FIX_HBATH) then
          cpd_l(ia,1:3) = 0.d0
       else
          cpdxyz(ia,1:3) = cpd_l(ia,1:3)
          frcxyz(1:3)    = mxyz(ia,1:3) * (forc_l(ia,1:3) + forcp(ia,1:3))/2.d0
          cpd_l(ia,1:3) = cpdxyz(ia,1:3) + dtio/amion(ityp(ia))*frcxyz(1:3)
       end if
    end do

    if(mdalg == T_CONTROL .or. mdalg == BLUEMOON) then
       do ia = 1, natm
          ir = icnstrnt_typ(imdtyp(ia),mdalg)         !-(b_Ionic_System)
          if(ir >= 1) then
             if(nchain==1)then
             dtz = dtio*cpqr(ir,1)/2.d0
             else
             dtz = dtio*cpqr_c(ir,1)/2.d0
             endif
             cpd_l(ia,1:3) = cpd_l(ia,1:3) - mxyz(ia,1:3) * dtz*cpdxyz(ia,1:3)
          end if
       end do
       if(mdalg == BLUEMOON) then
          do ia = 1, natm
             ir = icnstrnt_typ(imdtyp(ia),mdalg)
             if(ir /= FIX_HBATH) then
                dtml = dtio/amion(ityp(ia))*almda/2
                cpd_l(ia,1:3) = cpd_l(ia,1:3) + mxyz(ia,1:3) * dtml*gca(ia,1:3)
             end if
          end do
       end if
    else if(mdalg == QUENCHED_CONSTRAINT) then
       ifq = 0
       do ia = 1, natm
          ir = icnstrnt_typ(imdtyp(ia),mdalg)         !-(b_Ionic_System)
          if(ir /= FIX_HBATH) then
             dtml = dtio/amion(ityp(ia)) * almda/2
             do j = 1, 3
                cpd_l(ia,j) = cpd_l(ia,j) + mxyz(ia,j) * dtml*gca(ia,j)
                fcg(j)      = forcp(ia,j) + mxyz(ia,j) * almda*gca(ia,j)
                if(cpdxyz(ia,j)*fcg(j) < 0.d0) ifq(ia,j) = 1
             end do
          end if
       end do
    end if
    deallocate(mxyz)
  end subroutine vlcty_accrd2_vVerlet

  subroutine ekina_ekinq_ekbt_and_ega(mdalg,external_irtyp_or_ibath,iw_cnst)
    external external_irtyp_or_ibath
    integer ::                     external_irtyp_or_ibath
    integer,intent(in) ::          mdalg
    integer,intent(in),optional :: iw_cnst
    integer ::                     ia, ir, i 
    real(kind=DP) ::               tkin
    nathm = 0      !d(nrsv)
    ekr   = 0.d0   !d(nrsv)
    ekina = 0.d0
    ekbt  = 0.d0
    ekinq = 0.d0

    do ia = 1, natm
       tkin = dot_product(cpd_l(ia,1:3),cpd_l(ia,1:3)) &
            &               * amion(ityp(ia))*iwei(ia)*0.5d0
       ekina = ekina + tkin
       ir = external_irtyp_or_ibath(imdtyp(ia))    !-(b_Ionic_System)
       if(ir >= 1) then
          nathm(ir) = nathm(ir) + iwei(ia)
          ekr(ir)   = ekr(ir) + tkin
          if(nchain==1)then
             ekbt      = ekbt + 3*iwei(ia)*tkb(ir)*cprv(ir)
          else
             ekbt      = ekbt + 3*iwei(ia)*tkb(ir)*cprv_c(ir,1)
          endif
       end if
    end do
    if(nchain>1)then
       do i=2,nchain
          do ir=1,nrsv
             ekbt = ekbt + tkb(ir) * cprv_c(ir,i)
          enddo
       enddo
    endif

    if(nchain == 1)then
    do ir = 1, nrsv
       ekinq = ekinq + qmass(ir)/2.d0 * cpqr(ir,1)*cpqr(ir,1)
       if(mdalg == T_CONTROL) then
          if(nathm(ir) == 0) cycle
          ekr(ir) = ekr(ir)/nathm(ir)/1.5d0
       end if
    end do
    else
    do i=1,nchain
       do ir=1,nrsv
          ekinq = ekinq + qmass_c(ir,i)/2.d0 * cpqr_c(ir,i) **2
       enddo
    enddo
    if(mdalg == T_CONTROL) then
      do ir=1,nrsv
          if(nathm(ir) == 0) cycle
          ekr(ir) = ekr(ir)/nathm(ir)/1.5d0
      enddo
    end if
    end if

    if(mdalg == BLUEMOON .or. mdalg == QUENCHED_CONSTRAINT) then
       ir = 1
       ekbt = ekbt - iw_cnst*tkb(ir)*cprv(ir)
       ekr(ir) = ekr(ir)*2/(3*nathm(ir)-iw_cnst)
    end if

    ega = ekina + ekinq + ekbt

    if(printable) then
       write(nfout,'(" ***** ",i6,"-th time step ; ega= ",1pe16.7 /&
            &," ekina, ekinq, ekbt",3e16.7)') &
            & iteration_ionic, ega, ekina, ekinq, ekbt
       write(nfout,'(" ir, tkb, ekr= ",i3,1p,2e16.7)') (ir,tkb(ir),ekr(ir),ir=1,nrsv)
    end if

    if(ipri >= 2 .and. printable) then
       write(nfout,'(" ! *** ia, cps ***")')
       write(nfout,'(" ",i4,3f20.10)') (ia,cps(ia,1),cps(ia,2),cps(ia,3), ia=1,natm)
       write(nfout,'(" ! *** ir, cprv, cpqr ***")')
       write(nfout,'(" ",i3,2f20.10)') (ir,cprv(ir),cpqr(ir,1), ir=1,nrsv)
    end if
  end subroutine ekina_ekinq_ekbt_and_ega

  subroutine evolve_crdn_ACCRD2_vVerlet(external_irtyp_or_ibath,forc_l)
    external         external_irtyp_or_ibath
    integer       :: external_irtyp_or_ibath
    real(kind=DP),intent(in),dimension(natm,3) :: forc_l
    integer       :: ir, ia, j
    real(kind=DP) :: dtm, dtz
    integer, allocatable, dimension(:,:) :: mxyz 
    allocate(mxyz(natm,3))
    do ia=1,natm
       mxyz(ia,1:3) = 1
       do j=1,3
          if(imdtypxyz(ia,j) == OFF) mxyz(ia,j) = 0
       enddo
    enddo

    do ia = 1, natm
!---*----*----*----*----*----> Velocity Verlet
       ir = external_irtyp_or_ibath(imdtyp(ia))   !-(b_Ionic_System)
       if(ir == FIX_HBATH) cycle
       dtm = dtio/amion(ityp(ia))/2.d0
       cps(ia,1:3) = cps(ia,1:3)+dtio*(cpd_l(ia,1:3)+dtm*forc_l(ia,1:3)) * mxyz(ia,1:3)
!---*----*----*----*----*----< Velocity Verlet
       if(ir >= 1) then
          if(nchain==1)then
          dtz= dtio*dtio*cpqr(ir,1)/2.d0
          else
          dtz= dtio*dtio*cpqr_c(ir,1)/2.d0
          endif
          cps(ia,1:3)= cps(ia,1:3) - dtz*cpd_l(ia,1:3) * mxyz(ia,1:3)
       end if
!!$       print '(" ia, cps = ",i4,3d16.8)',ia,cps(ia,1),cps(ia,2),cps(ia,3)
    end do
    deallocate(mxyz)
  end subroutine evolve_crdn_ACCRD2_vVerlet

  subroutine evolve_cprv
    integer :: i
      if(nchain == 1)then
       Do i=1, nrsv
       if ( natm_per_thermo(i) == 0 ) cycle
         cprv(i) =  cprv(i) &
              & +dtio*(cpqr(i,1) + 0.5d0*dtio/qmass(i)*frsv(i))
       End Do
       if(printable) write(nfout,'(" cprv = ",5d12.4)') cprv
      else
         cprv_c(1:nrsv,1) = cprv_c(1:nrsv,1)+dtio &
                        & *(cpqr_c(1:nrsv,1)+0.5d0*dtio &
                        & *(frsv(1:nrsv)/qmass_c(1:nrsv,1)-cpqr_c(1:nrsv,1)*cpqr_c(1:nrsv,2)))
         do i=2,nchain-1
         cprv_c(1:nrsv,i) = cprv_c(1:nrsv,i)+dtio &
                        & *(cpqr_c(1:nrsv,i) + 0.5d0*dtio &
                        & *((qmass_c(1:nrsv,i-1)*cpqr_c(1:nrsv,i-1)**2-tkb(1:nrsv))/qmass_c(1:nrsv,i) &
                        & - cpqr_c(1:nrsv,i) * cpqr_c(1:nrsv,i+1)))
         enddo
         cprv_c(1:nrsv,nchain) = cprv_c(1:nrsv,nchain) + dtio &
                        & *(cpqr_c(1:nrsv,nchain) + 0.5d0*dtio &
                        & *(qmass_c(1:nrsv,nchain-1)*cpqr_c(1:nrsv,nchain-1)**2-tkb(1:nrsv))/qmass_c(1:nrsv,nchain))
      endif
  end subroutine evolve_cprv

  subroutine md2_alloc
    allocate(ekr(nrsv))
    allocate(nathm(nrsv))
  end subroutine md2_alloc

  subroutine md2_dealloc
    deallocate(nathm)
    deallocate(ekr)
  end subroutine md2_dealloc

  subroutine heatrsv_chain(mdalg,natm,nrsv,iw_cnst)
    implicit none
    integer, intent(in) ::          mdalg,natm,nrsv
    integer, intent(in),optional :: iw_cnst
    real(kind=DP), allocatable, dimension(:,:) :: cpd_t
    real(kind=DP), allocatable, dimension(:,:) :: cpqr_t,cpqr_prev
    integer :: nmax = 100
    real(kind=DP) :: eps = 1.d-12
    real(kind=DP), allocatable, dimension(:) :: frsv_t
    real(kind=DP)            :: dtz
    integer :: i,j,k,ia,ir,icnstrnt_typ,icount
    allocate(cpd_t(natm,3));cpd_t = cpd_l
    allocate(cpqr_t(nrsv,nchain));cpqr_t = cpqr_c
    allocate(cpqr_prev(nrsv,nchain))
    allocate(frsv_t(nrsv));frsv_t = frsv
    do i=1,nmax 
       cpqr_prev = cpqr_t
       do ia=1,natm 
          ir = icnstrnt_typ(imdtyp(ia),mdalg)
          if(ir>=1)then
             !cpd_t(ia,1:3) = cpd_l(ia,1:3) &
             !            & - 0.5d0*(cpd_t(ia,1:3)*cpqr_t(ir,1)+cpd_l(ia,1:3)*cpqr_c(ir,1)) * dtio
             dtz = 1 + dtio*0.5*cpqr_t(ir,1)
             cpd_t(ia,1:3) = cpd_l(ia,1:3)/dtz  
          endif
       enddo
       call forcrsv(natm,ityp,imdtyp,iwei,amion,cpd_t,tkb,nrsv,mdalg &
            & ,frsv,iw_cnst)         ! -(b_Ionic_System) ->(frsv)
       if(nchain==1) then
       cpqr_t(1:nrsv,1) = cpqr_c(1:nrsv,1) + dtio*((0.5d0/qmass_c(1:nrsv,1))*(frsv(1:nrsv)+frsv_t(1:nrsv)))
       else
       cpqr_t(1:nrsv,1) = cpqr_c(1:nrsv,1) + ((0.5d0/qmass_c(1:nrsv,1)) * (frsv(1:nrsv)+frsv_t(1:nrsv)) &
                      & - (cpqr_t(1:nrsv,1)+cpqr_c(1:nrsv,1))*0.5d0 &
                      & * (cpqr_t(1:nrsv,2)+cpqr_c(1:nrsv,2))*0.5d0) * dtio
       do j=2,nchain-1
       cpqr_t(1:nrsv,j) = cpqr_c(1:nrsv,j) &
                      & + ((1.d0/qmass_c(1:nrsv,j)) &
                      & * (qmass_c(1:nrsv,j-1)*(0.5d0*(cpqr_t(1:nrsv,j-1)+cpqr_c(1:nrsv,j-1)))**2 &
                      & - tkb(1:nrsv)) &
                      & - (cpqr_t(1:nrsv,  j)+cpqr_c(1:nrsv,  j))*0.5d0 &
                      & * (cpqr_t(1:nrsv,j+1)+cpqr_c(1:nrsv,j+1))*0.5d0) * dtio
       enddo
       cpqr_t(1:nrsv,nchain) = cpqr_c(1:nrsv,nchain) &
                      &      + dtio * ((1.d0/qmass_c(1:nrsv,nchain)) &
                      &      * (qmass_c(1:nrsv,nchain-1)*(0.5d0*(cpqr_t(1:nrsv,nchain-1) &
                      &      + cpqr_c(1:nrsv,nchain-1)))**2 - tkb(1:nrsv)))
       endif
       if(printable .and. iprimd>=2)then
       do j=1,nchain
          do k=1,nrsv
          write(nfout,'(a,2i5,3f20.10)') 'chain, thermo, cpqr_t, cpqr_prev', &
            & j,k,cpqr_t(k,j),cpqr_prev(k,j),dabs(cpqr_t(k,j)-cpqr_prev(k,j))
          enddo
       enddo
       endif
       icount = 0
       do j = 1,nchain
          do k=1,nrsv
             if(dabs(cpqr_t(k,j))<eps) then
                icount = icount+1
             else if(dabs(cpqr_prev(k,j)-cpqr_t(k,j))<eps) then
                icount = icount+1
             endif
          enddo
       end do
       if (icount == nchain*nrsv) then
          if(printable .and. iprimd>=2) &
       &     write(nfout,'(a,i5,a)') ' !** reservoir iteration converged after ',i,' iterations'
          exit
       endif
    enddo
    cpd_l = cpd_t
    cpqr_c = cpqr_t
    deallocate(cpd_t)
    deallocate(cpqr_t)
    deallocate(cpqr_prev)
    deallocate(frsv_t)
  end subroutine heatrsv_chain

  subroutine heatrsv(mdalg,natm,nrsv,iw_cnst)
    ! INPUT  : natm,ityp,imdtyp,iwei,amion,dtio,qmass,tkb,nrsv,imdalg
    ! OUTPUT : cpd_l,cpqr,frsv (,iw_cnst)
    implicit none
    integer, intent(in) ::          mdalg,natm,nrsv
    integer, intent(in),optional :: iw_cnst

    integer :: icnstrnt_typ
    real(kind=DP) :: cpdcor(natm,3),cpqrpre(nrsv),cpqrcor(nrsv),fchk(nrsv)

    integer,       parameter :: mmin = 5, mmax = 100
    real(kind=DP), parameter :: eps = 1.d-12
    integer                  :: ir,ic,ia
    real(kind=DP)            :: dtz

    cpdcor = cpd_l

    Do ir=1, nrsv
       if ( natm_per_thermo(ir) == 0 ) cycle
       cpqrcor(ir) = cpqr(ir,2) + 2*dtio/qmass(ir)*frsv(ir)
       cpqr(ir,2)  = cpqr(ir,1)
       cpqr(ir,1)  = cpqr(ir,1) + 0.5*dtio/qmass(ir)*frsv(ir)
    End Do

! +++++ predictor-corrector method +++++
    PREDICTOR_CORRECTOR: do ic = 1, mmax
       cpqrpre(1:nrsv)= cpqrcor(1:nrsv)
!xocl spread do/ind_natm
       do ia = 1, natm
          ir = icnstrnt_typ(imdtyp(ia),mdalg)
          if(ir >= 1) then
             dtz = 1 + dtio*0.5*cpqrpre(ir)
             cpdcor(ia,1:3)= cpd_l(ia,1:3)/dtz  
          end if
       end do
!xocl end spread

       call forcrsv(natm,ityp,imdtyp,iwei,amion,cpdcor,tkb,nrsv,mdalg &
            & ,frsv,iw_cnst)         ! -(b_Ionic_System) ->(frsv)

       Do ir=1, nrsv
          if ( natm_per_thermo(ir) == 0 ) cycle
          cpqrcor(ir)= cpqr(ir,1)+frsv(ir)*dtio/qmass(ir)*0.5
       End Do

       if(ic <= mmin) cycle
     
       FCHECK: do ir = 1, nrsv
          if ( natm_per_thermo(ir) == 0 ) cycle
          fchk(ir) = dabs(cpqrpre(ir)/cpqrcor(ir) - 1.d0)
          if(fchk(ir) >= eps) cycle PREDICTOR_CORRECTOR
       end do FCHECK

       go to 300
    end do PREDICTOR_CORRECTOR

    if(printable) then
       write(nfout,'(" ! Warning in heatrsv ***")')
       write(nfout,'(" cpqrpre, cpqrcor = ",2d20.12)') &
            &                  (cpqrpre(ir),cpqrcor(ir),ir=1,nrsv)
    end if
    stop

300 continue
    if(printable) then
       do ir= 1, nrsv
          write(nfout,'(" ic, cpqrcor, fchk= ",i3,d12.4,d12.4)') ic,cpqrcor(ir),fchk(ir)
       end do
    end if

! ++++++++++++++++++++++++++++++++++++++++++++++++++
    cpd_l = cpdcor
    cpqr(1:nrsv,1) = cpqrcor

  end subroutine heatrsv

  subroutine set_new_temperature(nfout,nrsv,temperature_profile)
    integer, intent(in) :: nfout,nrsv
    type(temperature_profile_t), dimension(nrsv), intent(in) :: temperature_profile
    integer :: i,j,nprof,till_n,ir
    integer :: icount,itemp,nat
    real(kind=DP) :: tempi,tempf,delta_temp,qmasst,tdam
    logical :: temp_was_set
    real(kind=DP) :: qfac
    icount = 0
    do i=1,nrsv
       nprof = temperature_profile(i)%nprof
       temp_was_set = .false.
       do j=1,nprof
          till_n = temperature_profile(i)%till_n(j)
          if(till_n<=2)then
             tkb(i) = temperature_profile(i)%tempf(j)
             temp_was_set = .true.
          else if(iteration_ionic<=icount+till_n)then
             tempi = temperature_profile(i)%tempi(j)
             tempf = temperature_profile(i)%tempf(j)
             delta_temp = (tempf-tempi)/dble(till_n-1)
             itemp = iteration_ionic - icount -1
             tkb(i) = tempi + delta_temp * dble(itemp)
             temp_was_set = .true.
          endif
          if(temp_was_set)then
             qmasst = temperature_profile(i)%qmass(j)
             if (qmasst>0) then
                qmass(i) = qmasst
             else
                tdam = temperature_profile(i)%tdamp(j)
                nat = temperature_profile(i)%natm
                qmass(i) = (2.d0*3.d0*nat*(tdam/PAI2)**2) * tkb(i)
             endif
             if(printable) write(nfout,'(a,i5,a,i5,a,f15.3,a,f15.3)') &
           &  ' !** thermostat: ',i,' profile: ',j,' temperature: ',tkb(i)/CONST_kB, ' qmass : ',qmass(i)
             exit
          endif
          icount = icount + till_n
       enddo
       if(.not.temp_was_set)then
          tkb(i) = temperature_profile(i)%tempf(nprof)
          qmasst = temperature_profile(i)%qmass(nprof)
          if (qmasst>0) then
             qmass(i) = qmasst
          else
             tdam = temperature_profile(i)%tdamp(nprof)
             nat = temperature_profile(i)%natm
             qmass(i) = (2.d0*3.d0*nat*(tdam/PAI2)**2) * tkb(i)
          endif
          if(printable) write(nfout,'(a,i5,a,i5,a,f15.3,a,f15.3)') &
        &  ' !** thermostat: ',i,' profile: ',nprof,' temperature: ',tkb(i)/CONST_kB, ' qmass : ',qmass(i)
       endif
    enddo
    if(nchain>1)then
       qmass_c(1:nrsv,1) = qmass(1:nrsv)
       do i=2,nchain
          qmass_c(1:nrsv,i) = qfactor * qmass(1:nrsv)
       enddo
    endif
  end subroutine set_new_temperature

  subroutine m_IS_md_thermo(forc_l)
    external   irtyp
    integer :: irtyp
    real(kind=DP), intent(in), dimension(natm,3) :: forc_l
    integer ::        ifix, ifree
    integer, save  :: ifix_P_ifree = -1
    integer ::        mdalg
    integer ::        id_sname = -1
    call tstatc0_begin('m_IS_md_thermo ',id_sname)

    if(sw_temperature_profile == ON) call set_new_temperature(nfout,nrsv,temperature_profile)

    mdalg = T_CONTROL
    call md2_alloc                       !-(m_Ionic_System)->(ekr,nathm) 

    if(ifix_P_ifree == -1) then
       call check_nrsv                      ! -(contained here)
       call check_imdtyp(mdalg,irtyp,ifix,ifree,ifix_P_ifree) !-(m_Ionic_System)
    end if
    ! --> Velocities at iteration_ionic-th step 
    if(iteration_ionic == 1) then
       call forcrsv(natm,ityp,imdtyp,iwei,amion,cpd_l,tkb,nrsv,mdalg,frsv)
       !  -(b_Ionic_System)(cpd_l,tkb)->(frsv(=force on the thermostat coordinate))
    else
       call vlcty_accrd2_vVerlet(mdalg,forc_l)    !-(m_Ionic_System) ->(cpd_l) 
    end if
!!$ 2011.06.06
    if(t_ctrl_method.ne.VELOCITY_SCALING.and.ifix_P_ifree<natm) then
      if(nchain == 1) then
        call heatrsv(mdalg,natm,nrsv)
      else
        call heatrsv_chain(mdalg,natm,nrsv)
      endif
    endif
!!$ 2011.06.06
         ! natm-(ifix_P_ifree):= #atoms in a heat bath
         ! -(m_Ionic_System) (cpd_l,cpqr,frsv,tkb)->(cpd_l,cpqr,frsv)
    forcp = forc_l
    call ekina_ekinq_ekbt_and_ega(mdalg,irtyp)          !-(m_Ionic_System) ->(ekina,..)
    !     <== Kinetic and thermostat energies at iteration_ionic-th step
    call evolve_crdn_ACCRD2_vVerlet(irtyp,forc_l)       !-(m_Ionic_System) ->(cps)
    !     <== Coordinates at (iteration_ionic+1)-th step
    call evolve_cprv                                    !-(m_Ionic_System) ->(cprv)

    if(t_ctrl_method == VELOCITY_SCALING)then
       call scale_velocity()
    endif
    if (sw_shift_velocities==ON) call shift_velocities(1)
    call md2_dealloc                                    !-(m_Ionic_System)
    call tstatc0_end(id_sname)
  contains

    subroutine check_nrsv
      if(nrsv > natm) then
         if(printable) then
            write(nfout,'(" *** Too many thermostats. ***")')
            write(nfout,'(" ! nrsv, natm = ")') nrsv,natm
         end if
         stop
      end if
    end subroutine check_nrsv

  end subroutine m_IS_md_thermo

  subroutine rattle_v
    real(kind=DP) :: gvu,ggm,dtl,dtlm,almdav
    integer       :: ia, j

    gvu = 0.d0; ggm = 0.d0
    do ia = 1, natm
       gvu = gvu + dot_product(cpd_l(ia,1:3),gca(ia,1:3))
       ggm = ggm + dot_product(gca(ia,1:3),gca(ia,1:3))/amion(ityp(ia))
    end do

    dtl = -gvu/ggm
    do ia = 1, natm
       dtlm  = dtl/amion(ityp(ia))
       cpd_l(ia,1:3)= cpd_l(ia,1:3) + dtlm*gca(ia,1:3)
    end do

    gvu= 0.d0
    do j = 1, 3
       gvu = gvu + dot_product(cpd_l(1:natm,j),gca(1:natm,j))
    end do
    if(ipri >= 2 .and. printable) write(nfout,'(" gvu=",d20.10)') gvu

    almdav= 2.d0* dtl/dtio
    if(ipri >= 2 .and. printable) write(nfout,'(" almdav=",d20.10)') almdav
  end subroutine rattle_v

  subroutine rattle_r(nfcatm)
    integer,       intent(in)          :: nfcatm

    real(kind=DP), allocatable, dimension(:,:) :: gcb
    integer, parameter      :: imax = 50
    real(kind=DP),parameter :: eps  = 1.d-14

    real(kind=DP)  :: dtl,sigma
    integer        :: iter

    allocate(gcb(natm,3))

    dtl = dtio*almda

    iter= 0
!---
    if(cnst_typ == BONDLENGTH_FIX_1 .or. cnst_typ == BONDLENGTH_FIX_2) then
       if(sgmc(1) < DELTA) then
          if(iprimd >= 1) then
             write(nfout,'(" !IS sgmc(1) = ",f12.4)') sgmc(1)
          end if
          stop ' sgmc(1) < DELTA <<rattle_r>>'
       end if
    else if(cnst_typ == COG_FIX_L)then
       if(dabs(sgmc(4)) < DELTA) then
          if(iprimd >= 1) then
             write(nfout,'(" !IS sgmc(1:4) = ",4f12.4)') sgmc(1:4)
          end if
          stop ' sgmc(4) < DELTA <<rattle_r>>'
       end if
    end if

    do while(.true.)
       iter = iter+1
       call evolve_cps    !-(contained here), (dtl,gca,dtio,amion)->(cps)
       ! r_{n+1} = r_{n} + (\Delta t)^2/(2 m_i) \lambda g_{i}
       call cnstrnt(natm,ityp,amion,cps,cnst_typ,nfcatm,ia_cnst,imdtyp &
            &, sgmc,sigma)             !-(b_Ionic_System) ->(sigma)
       if(dabs(sigma) <= eps) exit
       call forc_cnst(natm,ityp,amion,cps,cnst_typ,nfcatm,ia_cnst,imdtyp &
            & ,sgmc,gcb)              !-(b_Ionic_System) ->(gcb)
       call evolve_almda              !-(contained here)
       !            (ia_cnst,dtio,amion,ityp,gcb,gca,sigma)->(dtl,almda)
       if(iter > imax) then
          if(dabs(sigma) <= eps*10.0) then
             call warning0
             exit
          else
             call stop0     !-(contained here)
          end if
       end if
    end do
    if(iprimd >= 2) then
       write(nfout,'(" !Ionic iter = ",i8," <<rattle_r>>")') iter
       write(nfout,'(" !Ionic   dtl, dtio, almda = ",3d20.8)') dtl,dtio, almda
    end if

    deallocate(gcb)

    if(iprimd > 2 .and. printable) &
         & write(nfout,'(" ! iter, almda, sigma = ",i3,2d12.4)') iter,almda,sigma
  contains
    subroutine warning0
      if(iprimd >= 1) then
         write(nfout,'(" !Ionic *** WARNING *** iter, almda, sigma = ",i5,2d12.4)') iter,almda,sigma
      end if
    end subroutine warning0

    subroutine stop0
      if(printable) then
         write(nfout,'(" *** ERROR in rattle_r ***")')
         write(nfout,'(" ! iter, almda, sigma=",i5,2d12.4)') iter,almda,sigma
      end if
      stop '<<rattle_r>>'
    end subroutine stop0

    subroutine evolve_almda
      integer       :: ia
      real(kind=DP) :: ggm
      ggm = 0.d0
      do ia = 1, natm
         ggm = ggm + 0.5*dtio/amion(ityp(ia)) &
              &       * dot_product(gcb(ia,1:3),gca(ia,1:3))
      end do

      dtl = -sigma/ggm
      almda = almda + dtl/dtio
      if(iter >= 4 .and. iprimd >= 1) then
         write(nfout,'(" !IS iter = ", i5)') iter
         write(nfout,'(" !IS sigma = ",d20.8)') sigma
         write(nfout,'(" !IS almda = ",d20.8)') almda
         write(nfout,'(" !IS ggm   = ",d20.8)') ggm
         write(nfout,'(" !IS dtio  = ",d20.8)') dtio
         write(nfout,'(" !IS dtl   = ",d20.8)') dtl
         write(nfout,'(" !IS sgmc(1) = ",d20.8)') sgmc(1)
         if(iprimd >= 3) then
            do ia = 1, natm
               write(nfout,'(" !IS ia = ",i5," gcb, gca = ",6f8.4)') ia, gcb(ia,1:3),gca(ia,1:3)
            end do
            do ia = 1, natm
               write(nfout,'(" !IS ia = ",i5," cps = ",3f12.8)') ia, cps(ia,1:3)
            end do
         end if
      end if
    end subroutine evolve_almda

    subroutine evolve_cps
      integer       :: ia
      do ia = 1, natm
         cps(ia,1:3) = cps(ia,1:3)+(dtl*dtio/amion(ityp(ia))/2.d0)*gca(ia,1:3)
      end do
    end subroutine evolve_cps
  end subroutine rattle_r

  subroutine m_IS_md_bluem(forc_l)
  ! === md_bluem ===
  !  -- variables --
  !      tkb  : $k_B T$, temperature
  !     cprv  : $\eta, the thermostat coordinate
  !     cpqr  : $\dot{\eta}, time-derivative of the thermostat coordinate
  !     frsv  : $f_{\eta}$, force on the thermostat coordinate $\eta$
  !      gca  : $\frac{\partial \sigma(\{ \vec{r} \})}{\partial \vec{r_i}},
  !            derivative of constraint
  !    iw_cnst: weight factor for #constraint atom
#ifndef PGI
    external   ibath
    integer :: ibath
#endif
    real(kind=DP), intent(in), dimension(natm,3) :: forc_l
    integer :: iw_cnst = -1
    integer :: mdalg
    integer :: id_sname = -1
    call tstatc0_begin('m_IS_md_bluemoon ',id_sname)
    mdalg = BLUEMOON
    call md2_alloc                  !-(m_Ionic_System),->(ekr,nathm) 

    nrsv = 1
    if(iw_cnst == -1) call init_md_bluem    !-(contained here) ->(iw_cnst)
    ! --> Velocities at iteration_ionic-th step
    if(iteration_ionic == 1) then
       call forcrsv(natm,ityp,imdtyp,iwei,amion,cpd_l,tkb,nrsv,mdalg&
            &  ,frsv,iw_cnst)       !-(b_Ionic_System) ->(frsv,iw_cnst)
    else
       call vlcty_accrd2_vVerlet(mdalg,forc_l)! -(m_Ionic_System)(forc_l,cpd_l,gca)->(cpd_l) 
    end if
    ! --> Rattle
    call forc_cnst(natm,ityp,amion,cps,cnst_typ,nfcatm,ia_cnst,imdtyp &
         &, sgmc,gca)                  !-(b_Ionic_System) ->(gca)
    if(iteration_ionic /= 1) then
       call rattle_v                   !-(m_Ionic_System)(cpd_l,gca)->(cpd_l)
       call heatrsv(mdalg,natm,nrsv,iw_cnst) !-(m_Ionic_System)
    end if                             !     (tkb)->(cpd_l,cpqr,frsv,iw_cnst)

    forcp = forc_l
    if(printable) call print_frsv_and_cpqr           !-(contained here)
    call ekina_ekinq_ekbt_and_ega(mdalg,ibath,iw_cnst)   !-(m_Ionic_System) ->(ekina,..)
    !     <== Kinetic and thermostat energies at iteration_ionic-th step
    call evolve_crdn_ACCRD2_vVerlet(ibath,forc_l)  !-(m_Ionic_System) ->(cps)
    !     <== Coordinates at (iteration_ionic+1)-th step
    call evolve_cprv            !-(m_Ionic_System)(cprv,cpqr,frsv)->(cprv)
    call rattle_r(nfcatm)           !-(m_Ionic_System) ->(cps,almda)
    if(ipri > 2) print *,' almda = ', almda

    call md2_dealloc
    call tstatc0_end(id_sname)
  contains
    subroutine print_frsv_and_cpqr
      integer :: ir
      do ir = 1, nrsv
         write(nfout,'(" frsv, cpqr= ",2f12.6)') frsv(ir),cpqr(ir,1)
      end do
    end subroutine print_frsv_and_cpqr

    subroutine init_md_bluem
      integer :: ifix, ifree, ifix_P_ifree, m,ia,ir
#ifndef PGI
      external   ibath
      integer :: ibath
#endif

      call check_imdtyp(mdalg,ibath,ifix,ifree,ifix_P_ifree) !-(m_Ionic_System)
      iw_cnst = 1
      do m = 1, nfcatm
         ia = ia_cnst(m)
         ir = ibath(imdtyp(ia))
         if(ir <= RELAX_HBATH) then
            if(printable) then
               write(nfout,'(" *** Inconsistency in imdtyp ***")')
               write(nfout,'(" ! m, ia, ir= ",3i5)') m,ia,ir
            end if
            stop ' ir <= RELAX_HBATH <<m_IS_md_bluem.init_md_bluem>>'
         end if
         if(iwei(ia) == 2) iw_cnst= 2
      end do
      if(printable) write(nfout,'(" ! iw_cnst = ",i5)') iw_cnst
    end subroutine init_md_bluem
  end subroutine m_IS_md_bluem

  subroutine m_IS_md_cnstr(forc_l)
    external   ibath
    integer :: ibath
    real(kind=DP), intent(in), dimension(natm,3) :: forc_l

    integer,       pointer, dimension(:,:)   :: ifq
    real(kind=DP), pointer, dimension(:)     :: fcg
    real(kind=DP), allocatable, dimension(:,:) :: fcvect_work
    integer :: mdalg = QUENCHED_CONSTRAINT
    integer :: id_sname = -1
    call tstatc0_begin('m_IS_md_cnstr ',id_sname)

    if(mdmode == ORDINA) then
    call md2_alloc                  !-(m_Ionic_System)->(ekr,nathm) 
    allocate(ifq(natm,3)); allocate(fcg(3))

    call init_md_cnstr                      !-(contained here)

    ! -- Velocities at iteration_ionic-th step
    if(iteration_ionic == 1) then
       almda = 0.d0
    else
       call vlcty_accrd2_vVerlet(mdalg,forc_l,ifq,fcg) !-(m_I.S.)->(cpd_l,ifq) 
    end if

    ! --> Rattle
    call forc_cnst(natm,ityp,amion,cps,cnst_typ,nfcatm,ia_cnst,imdtyp &
         &, sgmc,gca)                  !-(b_Ionic_System) ->(gca)

    call rattle_v                      !-(m_Ionic_System)(cpd_l,gca)->(cpd_l)
    if(iteration_ionic /= 1) then
       call quench_velocity_using_ifq  !-(contained here) (ifq)->(cpd_l)
    end if

    forcp = forc_l
    call evolve_crdn_ACCRD2_vVerlet(ibath,forc_l)       !-(m_Ionic_System) ->(cps)
    !     <== Coordinates at (iteration_ionic+1)-th step
    call rattle_r(nfcatm)              !-(m_Ionic_System) ->(cps,almda)
    call evaluate_forcmx               !-(contained here) ->(forcmx_constraint_quench)
    deallocate(ifq);deallocate(fcg)
    call md2_dealloc

    else if(mdmode == CNSTRA) then
       call move_atoms_normal_to_plane()
       forcmx_constraint_quench = 1.d0

       sgmc = 0.d0
       allocate(fcvect_work(1,4)); fcvect_work = 0.d0
       fcvect_work(1,1:4) = fcvect(1,1:4)
       call m_IS_init_cnstrnt(1,fcvect_work) ! -> sgmc
       deallocate(fcvect_work)
    else
       stop ' Invalid value of mdmode <<m_IS_md>>'
    end if
  contains
    subroutine evaluate_forcmx
      integer       :: ia,ir,icnstrnt_typ
      real(kind=DP) :: fa
      forcmx_constraint_quench = 0.d0
      if(iprimd >= 3) write(nfout,'(" !Ionic(cnstrnt) forcmx_constraint")')
      do ia = 1, natm
         ir = icnstrnt_typ(imdtyp(ia),mdalg)
         if(ir /= FIX_HBATH) then
            fcg(1:3) = forc_l(ia,1:3) + almda*gca(ia,1:3)
            fa = dsqrt(fcg(1)**2 + fcg(2)**2 + fcg(3)**2)
            if(iprimd >= 3) then
               write(nfout,'(" !     fa(",i4,") = ",d20.8)') ia, fa
            end if
            if(fa > forcmx_constraint_quench) forcmx_constraint_quench = fa
         end if
      end do
    end subroutine evaluate_forcmx

    subroutine quench_velocity_using_ifq
      cpd_l = cpd_l * (1-ifq)
    end subroutine quench_velocity_using_ifq

    subroutine init_md_cnstr
      integer :: ifix, ifree, ifix_P_ifree, m,ia,ir
#ifndef PGI
      external   ibath
      integer :: ibath
#endif

      call check_imdtyp(mdalg,ibath,ifix,ifree,ifix_P_ifree) !-(m_Ionic_System)
      do m = 1, nfcatm
         ia = ia_cnst(m)
         ir = ibath(imdtyp(ia))
         if(ir < RELAX_HBATH) then
            if(printable) then
               write(nfout,'(" *** Inconsistency in imdtyp ***")')
               write(nfout,'(" ! m, ia, ir= ",3i5)') m,ia,ir
            end if
            stop ' ir < RELAX_HBATH <<m_IS_md_cnstr.init_md_cnstr>>'
         end if
      end do
    end subroutine init_md_cnstr

  end subroutine m_IS_md_cnstr

  logical function m_IS_force_check_md_cnstr()
    if(forcmx_constraint_quench < forccr) then
       m_IS_force_check_md_cnstr = .true.
    else
       m_IS_force_check_md_cnstr = .false.
    end if
    if(iprimd >= 2) write(nfout,'(" !D forcmx_constraint_quench = ",d20.12)') forcmx_constraint_quench
  end function m_IS_force_check_md_cnstr

  subroutine m_IS_alloc_cnstrvectors_etc(mdalg)
    integer :: mdalg
    if(nfcatm > 0) then
       if(.not.allocated(ia_cnst)) allocate(ia_cnst(nfcatm))
       if(mdalg == GDIIS .or. mdalg == VERLET .or. mdalg == QUENCHED_MD &
            & .or. mdalg == CG_STROPT .or. mdalg==SD_MD .or. mdalg==QUENCHED_CONSTRAINT .or. mdalg==CG_STROPT2 ) then
          if(printable) write(nfout,'(" !!f nfcatm = ",i5," <<m_IS_alloc_cnstrvectors_etc>>")') nfcatm
          ! --- fcvect --
          if(allocated(fcvect)) then
             if(iprimd >= 1) write(6,'(" !!f fcvect is already allocated")')
          else
             allocate(fcvect(nfcatm,4)); fcvect = 0.d0
             if(iprimd >= 1) write(6,'(" !!f fcvect is allocated and fcvect = 0.d0")')
          end if
          ! --- ipfixedplane --
          if(allocated(ipfixedplane)) then
             if(iprimd >= 1) write(6,'(" !!f ipfixedplane is already allocated")')
          else
             allocate(ipfixedplane(nfcatm)); ipfixedplane = 0
             if(iprimd >= 1) write(6,'(" !!f ipfixedplane is allocated and ipfixedplane = 1")')
          end if
       end if
       if(mdalg == BLUEMOON .or. mdalg == QUENCHED_CONSTRAINT) then
          if(allocated(gca)) then
             if(iprimd >= 1) write(6,'(" !!f gca is already allocated <<m_IS_alloc_cnstrvectors_etc>>")')
          else
             allocate(gca(natm,3));      gca = 0.d0
             if(iprimd >= 1) write(6,'(" !!f gca is allocated and gca = 0.d0 <<m_IS_alloc_cnstrvectors_etc>>")')
          end if
       end if
       call forcp_alloc()
    end if
  end subroutine m_IS_alloc_cnstrvectors_etc

  subroutine substitute_ia_cnst()
    integer :: i, icount
    icount = 0
    do i = 1, natm
       if(imdtyp(i) == BONDLENGTH_FIX .or. imdtyp(i) == BONDLENGTH_FIX_1 &
            & .or. imdtyp(i) == BONDLENGTH_FIX_2 .or. imdtyp(i) == COG_FIX) then
          icount = icount + 1
          if(icount <= nfcatm) ia_cnst(icount) = i
       end if
    end do
  end subroutine substitute_ia_cnst

  subroutine m_IS_cp_works2fcvect_etc(mdalg,n,ia_cnst_work,fcvect_work)
    integer, intent(in) ::                       mdalg,n
    integer, intent(in), dimension(n) ::         ia_cnst_work
    real(kind=DP), intent(in), dimension(n,4) :: fcvect_work
    integer :: i,j

    ia_cnst(1:nfcatm) = ia_cnst_work(1:nfcatm)
    if(mdalg == VERLET .or. mdalg == QUENCHED_MD) then
       fcvect(1:nfcatm,1:4) = fcvect_work(1:nfcatm,1:4)
       if(printable) then
          do i = 1, nfcatm
             write(nfout,'(" fcvect(",i5,",:) = ",4f12.6," <<m_IS_cp_work2fcvect_etc>>")') &
                  & i,(fcvect(i,j),j=1,4)
          end do
       end if
    end if
  end subroutine m_IS_cp_works2fcvect_etc

  subroutine m_IS_init_cnstrnt(n,fcv_wk)
    integer, intent(in)                       :: n
    real(kind=DP), intent(in), dimension(n,4) :: fcv_wk

    real(kind=DP) :: sigma

    sgmc = 0.d0
    if(nfcatm == 0) return

    if(cnst_typ == BONDLENGTH_FIX_1 .or. cnst_typ == BONDLENGTH_FIX_2) then
       sgmc(1) = fcv_wk(1,1)
       if(sgmc(1) < DELTA) then
          sgmc(1) = 0.d0
          call cnstrnt(natm,ityp,amion,cps,cnst_typ,nfcatm,ia_cnst,imdtyp&
               &, sgmc,sigma)     !-(b_Ionic_System) ->sigma
          sgmc(1) = sigma
       end if
    else if(cnst_typ == COG_FIX_L) then
       sgmc(1:3) = fcv_wk(1,1:3)
       call cnstrnt(natm,ityp,amion,cps,cnst_typ,nfcatm,ia_cnst,imdtyp &
            &, sgmc, sigma)      !-(b_Ionic_System) ->sigma
       sgmc(4) = sigma
    end if
    if(iprimd>=1) then
       write(nfout,'(" !IS const. of constraint = ",f16.8," <<m_IS_init_cnstrnt>>")') sigma
       write(nfout,'(" !IS sgmc(1:4) = ",4f12.8)') sgmc(1:4)
    end if
  end subroutine m_IS_init_cnstrnt

  subroutine m_IS_wd_cpo_and_forc(nfdynm,forc_l)
    integer, intent(in)                          :: nfdynm
    real(kind=DP), intent(in), dimension(natm,3) :: forc_l
    integer    :: ia
    if(mype == 0) then
       do ia = 1, natm
!xocl spread do/ind_natm
!xocl index ia
          write(nfdynm,'(" ",i4,3f15.9,3f10.5)') ia &
               &, cpo_l(ia,1,1),cpo_l(ia,2,1),cpo_l(ia,3,1) &
               &, forc_l(ia,1), forc_l(ia,2), forc_l(ia,3)
!xocl end spread
       end do
    end if
  end subroutine m_IS_wd_cpo_and_forc

  subroutine m_IS_rd_diis_history(nfcntn)
    integer, intent(in) :: nfcntn
    integer :: i,j
    logical             :: tag_is_found, EOF_reach
    integer :: ntmp
    if(.not. (imdalg==GDIIS .or. imdalg==BFGS) ) return
    if(printable) write(nfout,'("tag_diis_history")') 
    allocate(u_l_buf(natm,3,kqnmditer_p));u_l_buf=0.0d0
    allocate(w_l_buf(natm,3,kqnmditer_p));w_l_buf=0.0d0
    allocate(ncrspd_buf(kqnmditer_p)); ncrspd_buf(:) = (/(i,i=1,kqnmditer_p)/)
    if(mype==0)then
        call rewind_to_tag0(nfcntn,len('(tag_diis_history)'),'(tag_diis_history)' &
    &   ,EOF_reach,tag_is_found,str,len_str)
        if(tag_is_found) then
           read(nfcntn,*)
           read(nfcntn,*) ntmp
           if(ntmp/=kqnmditer_p)then
              if(printable) write(nfout,*) "!!kqnmditer has been changed"
           endif

           if(ntmp==kqnmditer_p)then
              read(nfcntn,*) 
              read(nfcntn,*) iter_gdiis

              read(nfcntn,*)
              do i=1,kqnmditer_p
                 do j=1,natm
                    read(nfcntn,*) u_l_buf(j,1,i),u_l_buf(j,2,i),u_l_buf(j,3,i)
                 enddo
              enddo
              read(nfcntn,*)
              do i=1,kqnmditer_p
                 do j=1,natm
                    read(nfcntn,*) w_l_buf(j,1,i),w_l_buf(j,2,i),w_l_buf(j,3,i)
                 enddo
              enddo
              read(nfcntn,*)
              do i=1,kqnmditer_p
                  read(nfcntn,*) ncrspd_buf(i)
              enddo
              diis_continuable = .true.
           endif
        endif
    endif
    if(npes>1) call mpi_bcast(diis_continuable,1,mpi_logical,0,mpi_comm_group,ierr)
    if(diis_continuable)then
       if(npes>1)then
           call mpi_bcast(u_l_buf,kqnmditer_p*natm*3,mpi_double_precision,0,mpi_comm_group,ierr)
           call mpi_bcast(w_l_buf,kqnmditer_p*natm*3,mpi_double_precision,0,mpi_comm_group,ierr)
           call mpi_bcast(ncrspd_buf, kqnmditer_p,mpi_integer,0,mpi_comm_group,ierr)
           call mpi_bcast(iter_gdiis,1,mpi_integer,0,mpi_comm_group,ierr)
       endif
    endif
  end subroutine m_IS_rd_diis_history

  subroutine m_IS_wd_diis_history(nfcntn)
    integer, intent(in) :: nfcntn
    integer :: i,j
    if(.not. (imdalg==GDIIS .or. imdalg==BFGS) ) return
    if(.not.allocated(u_l) .or. .not.allocated(w_l) .or. .not.allocated(ncrspd)) then
        if (.not.allocated(u_l_buf) .or. .not.allocated(w_l_buf).or. .not.allocated(ncrspd_buf)) then
            return
        else
            allocate(u_l(natm,3,kqnmditer_p))
            allocate(w_l(natm,3,kqnmditer_p))
            allocate(ncrspd(kqnmditer_p));ncrspd(:) = (/(i,i=1,kqnmditer_p)/)
            u_l = u_l_buf
            w_l = w_l_buf
            ncrspd = ncrspd_buf
            deallocate(u_l_buf)
            deallocate(w_l_buf)
            deallocate(ncrspd_buf)
        endif
    endif
    if(printable) write(nfout,'(" tag_diis_history")')
    if(mype==0)then
        write(nfcntn,*) '(tag_diis_history)'
        write(nfcntn,*) '(kqnmditer_p)'
        write(nfcntn,*) kqnmditer_p
        write(nfcntn,*) '(iter_gdiis)'
        write(nfcntn,*) iter_gdiis
        write(nfcntn,*) '(u)'
        do i=1,kqnmditer_p 
           do j=1,natm
              write(nfcntn,'(3f30.20)') u_l(j,1,i),u_l(j,2,i),u_l(j,3,i)
           enddo
        enddo
        write(nfcntn,*) '(w)'
        do i=1,kqnmditer_p 
           do j=1,natm
              write(nfcntn,'(3f30.20)') w_l(j,1,i),w_l(j,2,i),w_l(j,3,i) 
           enddo
        enddo
        write(nfcntn,*) '(ncrspd)'
        do i=1,kqnmditer_p
           write(nfcntn,'(i8)') ncrspd(i)
        enddo
    endif
  end subroutine m_IS_wd_diis_history

  subroutine m_IS_wd_cps(nf)
    integer, intent(in) :: nf
    integer :: ia
    if(mype == 0) then
       if(iprimd >= 2 .or. natm <= 100) then
          write(nf,'(" !ion cps and pos at the end of this job")')
          do ia = 1, natm
             write(nf,'(" !ion ",i4,3f14.8,3f12.7)') ia, cps(ia,1),cps(ia,2),cps(ia,3) &
                  & ,pos(ia,1),pos(ia,2),pos(ia,3)
          end do
       end if
    end if
  end subroutine m_IS_wd_cps

  subroutine m_IS_wd_pos_brav(nf)
    use m_Control_Parameters,  only : ipribravpos
    use m_Crystal_Structure,    only : kt_iuctype, a, b, c, ca, cb, cc, il

    integer, intent(in) :: nf
    integer :: ia, j, it
    real(kind=DP) :: work1(3,3), work2(3)

    if ( ipribravpos < 1 ) return
    if ( kt_iuctype /= 0 ) return       ! only for bravias

    if (mype == 0) then
       write(nf,'(a)')
       write(nf,'(" -- Bravais lattice info and internal positions at the end of this job--- ")')
       call primitive2bravais( nf, p2bmat, altv(:,1), altv(:,2), altv(:,3), &
            &                  a, b, c, ca, cb, cc, il )
       write(nf,'(a)')
       write(nf,'(a)') ' --- lattice --- '
       write(nf,'(3(a,f18.12))')  '  a     = ', a, ' , b    = ', b, ' ,  c     = ', c
       write(nf,'(3(a,f18.12))')  '  alpha = ', acos(ca)/PAI*180.0d0, &
            &                           ' , beta = ', acos(cb)/PAI*180.0d0, &
            &                           ' ,  gamma = ', acos(cc)/PAI*180.0d0
       write(nf,'(a)')

       work1(1,:) = altv(:,1);    work1(2,:) = altv(:,2);    work1(3,:) = altv(:,3)
       work1 = matmul( p2bmat, work1 )
       write(nf,'(a,3f20.10)') '    a_vector = ',work1(1,1:3)
       write(nf,'(a,3f20.10)') '    b_vector = ',work1(2,1:3)
       write(nf,'(a,3f20.10)') '    c_vector = ',work1(3,1:3)

       write(nf,*)
       write(nf,'(a)') ' --- ionic positions --- '
       Do ia=1, natm
          it = ityp(ia)
          Do j=1, 3
             work2(j) = sum(b2pmat(:,j)*pos(ia,:))
          end do
          write(nf,'(A4,3f22.18)') speciesname(it), work2(1:3)
       ENd Do
       write(nf,'(a)') ' ---------- '
    end if

  end subroutine m_IS_wd_pos_brav

  subroutine m_IS_gdiis(forc_l_in,forcmx,etotal)
!!$   Original program was coded by T. Yamasaki(JRCAT-ATP)
!!$                            @(#)md_qn_gdiis.f 9.1 97/05/08 14:48:50
!    Transformed into this using fortran90
!                 by T. Yamasaki (FUJITSU Laboratories Ltd.)
!                                   29th Apr. 2003
!
    real(kind=DP), intent(in), dimension(natm,3) :: forc_l_in
    real(kind=DP), intent(in)                    :: forcmx, etotal
    real(kind=DP), allocatable, dimension(:,:)   :: forc_l

    integer ::              m, mode_init = 0,sub_optmode,it,nsum,icount,icon, ia, imd_t, ia_t,j
    real(kind=DP) ::        c_dist, forcmx_mdfy
    integer ::              id_sname = -1
    call tstatc0_begin('m_IS_gdiis ',id_sname)

    if(absolute_convergence_of_forc(forc_l_in))then
       write(nfout,'(a)') ' m_IS_gdiis: forces are absolutely converged!! nothing to do...'
       return
    endif

    if(mdmode == ORDINA) then
       allocate(forc_l(natm,3))
       forc_l = forc_l_in

!!$       if(constraint_type == FIXED_NORMAL_HYPERVECTOR) call modify_forc_fi(forc_l)
       if(constraint_type == FIXED_NORMAL_HYPERVECTOR) call modify_forc_hyperplane(forc_l)
       iter_gdiis = iter_gdiis + 1
       if(if_allocated == 0) call m_IS_gdiis_alloc(mode_init,if_allocated)

       forc_g = forc_l
!!$       call mdfy_forc(forcmx,forcmx_mdfy)  ! -> forc_g
       m = mod(iter_gdiis,kqnmditer_p)
       if(m == 0) m = kqnmditer_p

       call d_fc_l(mode_init,forcmx_mdfy) ! -> fc_l
       call rot_ncrspd(nsum)  ! -> ncrspd, nsum
       call d_sub_optmode(etotal,etot_previous,forcmx_mdfy,sub_optmode) ! -> sub_optmode
       it = ncrspd(nsum)
       if(it == 0) it = 1
       call stor_cps_forc(it) ! cps,forc_g -> u_l, w_l
       if(iprigdiis >= 2 .and. printable) write(nfout,'(" sub_optmode = ", i5)') sub_optmode
       if(sub_optmode == QUENCHED_MD) then
          call m_IS_md(sub_optmode,forc_l)
       else if (imdalg==GDIIS)then
          if(nsum > 1) then
             call gdiis_mat(nsum) ! ncrspd,w_l -> f_gdiis
             call getmatinv(nsum,icon) ! -> f_gdiis := f_gdiis^(-1)
             if(icon == 0) then
                call gdiis_g(nsum)   ! -> g
                call opt_forc(nsum)  ! -> forc_g := sum_{it}(g(it)*w_l(,ncrspd(it))
!!$                call mdfy_forc(forcmx,forcmx_mdfy2)
                if(iprigdiis >= 2 .and. printable) call forc_check(" --- new force ---")
                if(iprigdiis >= 1) call cmp_fop_fin(it)
                call opt_geom(nsum)  ! -> cps := sum_{it}(g(it)*u_l(,ncrspd(it))
             else   ! when icon /= 0, f_gdiis matrix is singular
                if(printable) write(nfout,'(" !! f_gdiis matrix is singular <<m_IS_gdiis>>")')
                call m_IS_md(QUENCHED_MD,forc_l)
             end if
          end if
          
! --> T. Yamasaki, 19 Mar 2007
          do ia = 1, natm
             do j=1,3
             imd_t = imdtypxyz(ia,j)
             if(imd_t == 0 .or. imd_t == COG_FIX .or. &
                  & imd_t == COG_FIX_L .or. imd_t == FIX_IN_A_PLANE) cycle
             cpd_l(ia,j) = -fc_l(ia,j)/dtio*forc_g(ia,j)
             cps(ia,j) = cps(ia,j) + dtio*cpd_l(ia,j)
             enddo
          end do

          if(constraint_type == COG_FIX_L .or. constraint_type == FIX_IN_A_PLANE) then
!!$             goto 1002
             if(nfcatm >= 1) allocate(cpd_old(nfcatm,3))
             ia_t = 0
             do ia = 1, natm
                imd_t = imdtyp(ia)
                if(imd_t == COG_FIX .or. imd_t == COG_FIX_L .or. imd_t == FIX_IN_A_PLANE) then
                   ia_t = ia_t + 1
                   cpd_old(ia_t,:) = cpd_l(ia,:)
                end if
             end do

             allocate(ipcpd(natm))
             call check_constraint_cog(forc_l)

             call evolve_velocities_cog(forc_l)

             call quench_velocities_cog(forc_l)
             deallocate(ipcpd)
             do ia = 1, natm
                imd_t = imdtyp(ia)
                if(imd_t == COG_FIX .or. imd_t == COG_FIX_L .or. imd_t == FIX_IN_A_PLANE) then
                   cps(ia,:) = cps(ia,:) + dtio*cpd_l(ia,:)
                   write(6,'(" cps(",i5,",:) = ",3f8.4)') ia, cps(ia,1:3)
                end if
             end do
             if(nfcatm >= 1) deallocate(cpd_old)
!!$1002         continue
          end if
! <---
          if(constraint_type == COG_FIX_L) call check_cog()
       else if(imdalg==BFGS) then
          call do_bfgs(nsum)
       end if
       if(imdalg==GDIIS)then
          if(iprigdiis >= 2 .and. printable) call cps_check(" --- new coordinates ---") ! cps

          c_dist = 0.3d0
          call cps_damp(c_dist,it,icount)
          if(icount >= 1 .and. iprigdiis >= 1 .and. printable) then
             call cps_check(" --- new (damped) coordinates ---") ! cps
          endif
       endif

       if(iprigdiis >= 2 .and. printable) call cpd_check(" --- velocity ---") ! cpd_l

       deallocate(forc_l)
    else if(mdmode == CNSTRA) then
       call move_atoms_normal_to_plane()
       iter_gdiis = 0
       if(if_allocated == 1) call m_IS_gdiis_dealloc(if_allocated)
    else
       stop ' Invalid value of mdmode <<m_IS_gdiis>>'
    end if

    call tstatc0_end(id_sname)
  contains

    subroutine do_bfgs(nsum)
       integer, intent(in) :: nsum
       integer :: i,j,k,i1,j1,itr0,itr1,info
       real(DP) :: xgi,gihg
       real(kind=DP), allocatable, dimension(:) :: gdelta,xdelta
       logical :: corrected_eig
       real(DP), allocatable, dimension(:) :: gdotinvh
       real(DP), allocatable, dimension(:,:) :: tmpforc
       real(DP), allocatable, dimension(:,:) :: ihess
       real(DP), allocatable, dimension(:) :: amat
       real(DP), allocatable, dimension(:) :: eigv
       real(DP), allocatable, dimension(:,:) :: eigvec
       real(DP), allocatable, dimension(:) :: workar
       real(DP) :: maxoptforc,tmpmaxoptforc
       real(DP),save :: maxoptforc_old=1000.d0
       real(DP),save :: energy_old=0.0d0
       real(DP),allocatable, dimension(:,:), save :: force_old
       real(DP),save :: alpha_bfgs = 1.0d0
       integer :: nmobile,icounti,icountj
       real(DP) :: c1,c2,mina,maxa,incre
       real(DP) :: tmpsum1,tmpsum2,e0,f0
       c1 = wolfe_c1
       c2 = wolfe_c2
       mina = min_alpha
       maxa = max_alpha
       incre = 1.1d0
       nmobile=0
       do i=1,natm
          do j=1,3 
             if(imdtypxyz(i,j)==0)cycle
             nmobile = nmobile+1
          enddo
       enddo
       allocate(xdelta(nmobile));xdelta=0.d0
       allocate(gdelta(nmobile));gdelta=0.d0
       allocate(gdotinvh(nmobile));gdotinvh=0.d0
       allocate(tmpforc(natm,3));tmpforc=0.d0
       allocate(ihess(nmobile,nmobile));ihess=0.d0
       if(sw_correct_eigenvalue==ON)then
          allocate(amat(nmobile*(nmobile+1)/2));amat=0.d0
          allocate(eigv(nmobile));eigv=0.0d0
          allocate(eigvec(nmobile,nmobile));eigvec=0.0d0
          allocate(workar(3*nmobile));workar=0.0d0
       endif

!      build inverse of the Hessian
       ihess = 0.d0
       do i=1,nmobile
          ihess(i,i) = 1.0d0
       enddo
       do i=2,nsum
          itr1 = ncrspd(i)
          itr0 = ncrspd(i-1)
          icountj=0
    
          do j=1,natm
             do k=1,3
                if(imdtypxyz(j,k)==0)cycle
                icountj=icountj+1
                xdelta(icountj) =  u_l(j,k,itr1)-u_l(j,k,itr0)
                gdelta(icountj) = -w_l(j,k,itr1)+w_l(j,k,itr0)
             enddo
          enddo
          xgi = 1.0d0/dot_product(xdelta,gdelta)
          if(xgi<0)then
             if(printable .and. iprigdiis>=2)then
                write(nfout,'(a,i3)') '!** WARNING dx dot dg is negative for history ',itr1
                write(nfout,'(a)') 'skipping this update.'
             endif
             cycle
          endif
          do j=1,nmobile
             gdotinvh(j) = dot_product(ihess(j,:),gdelta(:))
          enddo
          gihg = dot_product(gdelta,gdotinvh)
          do j=1,nmobile
             do k=1,nmobile
                ihess(j,k) = ihess(j,k)+xgi*xgi*(1.0d0/xgi+gihg)*xdelta(j)*xdelta(k) &
          &                - (gdotinvh(j)*xdelta(k)+gdotinvh(k)*xdelta(j))*xgi
             enddo
          enddo
       enddo

!      correct bad eigenvalues present in the Hessian 
       if(sw_correct_eigenvalue==ON)then
          corrected_eig=.false.
          do i=1,nmobile
             do j=i,nmobile
                amat(i + (j-1)*j/2) = ihess(i,j)
             enddo
          enddo
          call dspev('V','U',nmobile,amat,eigv,eigvec,nmobile,workar,info)
          if(printable .and. iprigdiis>=2) write(nfout,'(a)') '--- eigenvalues for the approximate Hessian ---'
          do i=1,nmobile
             if(printable.and.iprigdiis>=2) write(nfout,'(i8,f20.10)') i,1.0d0/eigv(i)
             if (1.0d0/eigv(i)<eigenvalue_threshold)then
                eigv(i) = 1.0d0/eigenvalue_threshold
                if(printable.and.iprigdiis>=2) write(nfout,'(a,i8,a,f20.10)') &
                &  'corrected the eigenvalue for the ',i,'-th element to : ',1.0d0/eigv(i)
                corrected_eig=.true.
             endif
          enddo
          if(corrected_eig)then
             ihess=0.d0
             do i=1,nmobile
                do j=1,nmobile
                   do k=1,nmobile
                      ihess(i,j) = ihess(i,j)+eigvec(i,k)*eigvec(j,k)*eigv(k)
                   enddo
                enddo
             enddo
          endif
       endif

!      H^-1 dot g
       maxoptforc=0.d0
       icounti=0
       do i=1,natm
          do j=1,3
             tmpforc(i,j) = 0.d0
             if(imdtypxyz(i,j)==0)cycle
             icounti=icounti+1
             icountj=0
             do i1=1,natm
                do j1=1,3
                   if(imdtypxyz(i1,j1)==0)cycle
                   icountj=icountj+1
                   tmpforc(i,j) = tmpforc(i,j) - ihess(icounti,icountj)*forc_l(i1,j1)
                enddo
             enddo
             tmpmaxoptforc=dsqrt(dot_product(tmpforc(i,:),tmpforc(i,:)))
             if(tmpmaxoptforc>maxoptforc)maxoptforc=tmpmaxoptforc
          enddo
       enddo

       if(printable .and. ipri>=1) then
          write(nfout,'(a,f20.10)') 'max. optimal force obtained from the BFGS update : ',maxoptforc
       endif

       if(sw_optimize_alpha == ON) then
       if(.not.allocated(force_old)) then
          allocate(force_old(nmobile,3))
       else
          tmpsum1 = 0.d0
          tmpsum2 = 0.d0
          do i=1,natm 
             do j=1,3
                if (imdtypxyz(i,j)==0) cycle
                tmpsum1 = tmpsum1 + force_old(i,j)*tmpforc(i,j)
                tmpsum2 = tmpsum2 + forc_l(i,j)*tmpforc(i,j)
             enddo
          enddo
          e0 = energy_old + c1*alpha_bfgs*tmpsum1
          f0 = -c2*tmpsum1
          if(e0>etotal .and. f0>abs(tmpsum2))then
             alpha_bfgs = alpha_bfgs*incre
          else 
             alpha_bfgs = alpha_bfgs/incre
          endif
          if(alpha_bfgs>maxa) alpha_bfgs = maxa
          if(alpha_bfgs<mina) alpha_bfgs = mina
          if(printable)then
             write(nfout,'(a,2f20.10)') 'Wolfe condition  i) : ',e0,etotal
             write(nfout,'(a,2f20.10)') 'Wolfe condition ii) : ',f0,abs(tmpsum2)
             write(nfout,'(a,f20.10)')  'new alpha           : ',alpha_bfgs
          endif
       endif

       energy_old = etotal
       force_old(:,:)  = forc_l(:,:)
       endif

       if(maxoptforc_old*10<maxoptforc)then
          if (printable) write(nfout,'(a)') 'the estimated force seems to be very large; &
         & update will be done by the steepest-descent method'
          do i=1,natm
             do j=1,3
                if (imdtypxyz(i,j)==0) cycle
                cps(i,j) = cps(i,j)+forc_l(i,j)
             enddo
          enddo
       else
          tmpsum1=0.d0
          tmpsum2=0.d0
          do i=1,natm
             do j=1,3
                if (imdtypxyz(i,j)==0) cycle
                cps(i,j) = cps(i,j)-alpha_bfgs*tmpforc(i,j)
             enddo
          enddo
       endif
       maxoptforc_old = maxoptforc

       deallocate(xdelta)
       deallocate(gdelta)
       deallocate(gdotinvh)
       deallocate(tmpforc)
       deallocate(ihess)
       if(sw_correct_eigenvalue==ON)then
          deallocate(amat)
          deallocate(eigv)
          deallocate(eigvec)
          deallocate(workar)
       endif
    end subroutine do_bfgs

    subroutine rot_ncrspd(nsum)
      integer, intent(out) :: nsum
      integer ::              nbox, istrbr, itemp
      nbox = (iter_gdiis-1)/kqnmditer_p
      if(gdiis_hownew == ANEW) then
         istrbr = nbox*kqnmditer_p + 1
      else if (gdiis_hownew == RENEW) then
         if(nbox == 0) then
            istrbr = 1
         else
            istrbr = iter_gdiis - (kqnmditer_p-1)
            itemp = ncrspd(1)
            do it = 1, kqnmditer_p-1
               ncrspd(it) = ncrspd(it+1)
            end do
            ncrspd(kqnmditer_p) = itemp
         end if
      end if
      nsum = iter_gdiis - istrbr + 1
      if(iprigdiis >= 2 .and. printable) then
         write(nfout,'(" -- rot_ncrspd -- ")')
         write(nfout,'("   i  : ",8i8)') (it,it=1,nsum)
         write(nfout,'("ncrspd: ",8i8)') (ncrspd(it),it=1,nsum)
      end if
    end subroutine rot_ncrspd

    subroutine d_fc_l(mode_init,forcmx)
      integer, intent(in) ::        mode_init
      real(kind=DP), intent(in) :: forcmx
      integer ::             ia, j
      do ia = 1, natm
         do j = 1, 3
            if(imdtypxyz(ia,j) == 0) then
               fc_l(ia,j) = 0.d0
            else if(forcmx >= c_forc_prop_region_high) then
               if(mode_init == UNIT) then
                  fc_l(ia,j) = -1.d0
               else
                  fc_l(ia,j) = -dtio*dtio/amion(ityp(ia))
               end if
            else if(forcmx >= c_forc_prop_region_low) then
               fc_l(ia,j) = - factor_prop_region/forcmx
               if(dabs(fc_l(ia,j)) < 1.d0) then
                  fc_l(ia,j) = -1.d0
               end if
            end if
         end do
      end do
    end subroutine d_fc_l

    subroutine d_sub_optmode(etotal,etot_previous,forcmx_mdfy,sub_optmode)
      real(kind=DP),intent(in) :: etotal, etot_previous
      real(kind=DP),intent(in) :: forcmx_mdfy
      integer, intent(out) ::     sub_optmode
      real(kind=DP) ::            edel
!!$      edel = etotal - etot_previous
!!$      if(edel > 0.d0 .and. forcmx <= c_forc2GDIIS) then
!!$         iincre_at_forc_cal = iincre_at_forc_cal + 1
!!$         if(iincre_at_forc_cal >= ic_E_overshoot) then
!!$            sub_optmode = GDIIS
!!$         end if
!!$      else if(sub_optmode /= GDIIS) then
!!$         sub_optmode = QUENCHED_MD
!!$      end if
      sub_optmode = GDIIS
!!$      if(sub_optmode == GDIIS) then
!!$	if(ipriinputfile >= 1) write(nfout,'(" !! sub_optmode = GDIIS")')
!!$      else if(sub_optmode == QUENCHED_MD) then
!!$         if(ipriinputfile >= 1) write(nfout,'(" !! sub_optmode = QUENCHED_MD")')
!!$      end if
    end subroutine d_sub_optmode

    subroutine stor_cps_forc(it)
      integer, intent(in) :: it
!!$      real(kind=DP) :: xmul
!!$      integer  :: i
      u_l(:,:,it) = cps(:,:)
      w_l(:,:,it) = forc_g(:,:)
    end subroutine stor_cps_forc

    subroutine gdiis_mat(nsum)
      integer, intent(in) :: nsum

      integer ::             it, jt, itcrspd, jtcrspd,ia,j, imd_t
      real(kind=DP) ::       xmul

      do it = 1, nsum
         itcrspd = ncrspd(it)
         do jt = it, nsum
            jtcrspd = ncrspd(jt)
            xmul = 0.d0
            do ia = 1, natm
               do j = 1, 3
               imd_t = imdtypxyz(ia,j)
! --> T. Yamasaki, 19 Mar 2007
               if(imd_t /= 0 .and. imd_t /= COG_FIX .and. imd_t /= COG_FIX_L &
                    & .and. imd_t /= FIX_IN_A_PLANE) then
! <---
                     xmul = xmul + w_l(ia,j,jtcrspd)*w_l(ia,j,itcrspd)
               end if
               enddo
            end do
            f_gdiis(it,jt) = xmul
            if(jt /= it) f_gdiis(jt,it) = f_gdiis(it,jt)
         end do
         if(iprigdiis >= 2 .and. printable) then
            if(it == 1) write(nfout,'(" -- f_gdiis -- ")')
            write(nfout,'( 6d12.4)') (f_gdiis(it,jt),jt=1,nsum)
         end if
      end do
    end subroutine gdiis_mat

    subroutine getmatinv(nsum,icon)
      integer ,intent(in) ::  nsum
      integer, intent(out) :: icon

      real(kind=DP) :: div
      integer ::       it, jt, ipfr, ipto
#ifdef _GDIIS_MAT_CHECK_
      integer ::       kt, ik_count, kj_count
#endif

      div = 1.0/f_gdiis(1,1)
      do it = 1, nsum
         do jt = 1, nsum
            ipto = it + (jt-1)*nsum
            f_wk(ipto, 1) = f_gdiis(it,jt)*div
#ifdef _GDIIS_MAT_CHECK_
            f_wk(ipto, 2) = f_gdiis(it,jt)*div
#endif
            if(it == jt) then
               e_wk(ipto) = 1.d0
            else
               e_wk(ipto) = 0.d0
            end if
         end do
      end do

      call rdecomp(nsum,f_wk(1,1),ww1,ip,icon)

      if(icon /= 0) then
         if(printable) then
            write(nfout,'("  [f_wk] after rdecomp <<m_IS_gdiis_getmatinv>>")')
            do it = 1, nsum
               write(nfout,'(" f_wk(:,",i3," ) = ",8d12.4)') it,(f_wk(it+(jt-1)*nsum,1),jt=1,nsum)
            end do
            write(nfout,'(" ip = ",8i6)') (ip(ipto),ipto=1,nsum)
            write(nfout,*) ' LU decomposition is impossible. <<m_IS_gdiis.getmatinv>>'
         end if
         return
!!$         stop ' LU decompoition is impossible <<m_IS_gdiis_getmatinv>>'
      else
         call rsolve(nsum,nsum,f_wk(1,1),e_wk,f_rslv,ip)
      endif
#ifdef _GDIIS_MAT_CHECK_
! ----------- checking of inversion matrix ------------>
      if(printable) then
         write(nfout,*) ' -- below should equal to a unit matrix --'
         do it = 1, nsum
            ww1 = 0.d0
            do jt = 1, nsum
               do kt = 1, nsum
                  ik_count = (kt-1)*nsum + it
                  kj_count = (jt-1)*nsum + kt
                  ww1(jt) = ww1(jt) + f_wk(ik_count,2)*f_rslv(kj_count)
               enddo
            enddo
            write(nfout,9009) it,(ww1(jt),jt=1,nsum)
         enddo
9009     format(i3,8f8.4,/,3x,8f8.4,/,3x,8f8.4,/3x,8f8.4)
      end if
! <--------------------------------------------------
#endif

      do jt = 1, nsum
         do it = 1, nsum
            ipfr = it + (jt-1)*nsum
            f_gdiis(it,jt) = f_rslv(ipfr)
         end do
      end do

      if(iprigdiis >= 2 .and. printable) then
         write(nfout,*) ' **inverse matrix**'
         do jt = 1, nsum
            write(nfout,9008) jt,(f_gdiis(it,jt),it=1,nsum)
         enddo
      end if
 9008 format(i3,(6d12.4))

    end subroutine getmatinv

    subroutine gdiis_g(nsum)
      integer, intent(in) :: nsum
      real(kind=DP) ::       alpha_fac
      integer ::             it,jt
      alpha_fac = 0.d0
      do it = 1, nsum
         do jt = 1, nsum
            alpha_fac = alpha_fac + f_gdiis(it,jt)
         end do
      end do
      alpha_fac = 1.d0/alpha_fac

      g = 0.d0
      do it = 1, nsum
         do jt = 1, nsum
            g(it) = g(it) + alpha_fac*f_gdiis(it,jt)
         end do
      end do

      if(iprigdiis >= 2 .and. printable) then
         write(nfout,*) ' ---- alpha_fac     ----'
         write(nfout,9008) alpha_fac
         write(nfout,*) ' ---- a(1:',nsum,') ----'
         write(nfout,9008) (g(it),it=1,nsum)
      end if
 9008 format(8f20.12)
    end subroutine gdiis_g

    subroutine opt_forc(nsum)
      integer, intent(in) :: nsum
      integer ::             ia, it, itcrspd, imd_t, j

      forc_g = 0.d0
      do ia = 1, natm
         do j=1,3
         imd_t = imdtypxyz(ia,j)
         if(imd_t == 0 .or. imd_t == COG_FIX .or. &
              & imd_t == COG_FIX_L .or. imd_t == FIX_IN_A_PLANE) cycle
         do it = 1, nsum
            itcrspd = ncrspd(it)
            forc_g(ia,j) = forc_g(ia,j) + g(it)*w_l(ia,j,itcrspd)
         end do
         enddo
      end do
    end subroutine opt_forc

    subroutine opt_geom(nsum)
      ! Furthre modification: T. Yamasaki, March/15/2007
      integer, intent(in) :: nsum
      integer ::             ia, ifc, itcrspd, iaa, imd_t,j
      real(kind=DP) :: pdot
      real(kind=DP),allocatable,dimension(:,:) :: cps_cog !d(num_planes_atoms_are_fixed,3)
      real(kind=DP),allocatable,dimension(:,:) :: cps_cog_n !d(num_planes_atoms_are_fixed,3)
      real(kind=DP),allocatable,dimension(:)   :: denom ! d(num_planes_atoms_are_fixed)
      integer, allocatable, dimension(:) ::       itpcd ! d(num_planes_atoms_are_fixed)

      do ia = 1, natm
         do j=1,3
         imd_t = imdtypxyz(ia,j)
         if(imd_t == 0 .or. imd_t == COG_FIX .or. &
              & imd_t == COG_FIX_L .or. imd_t == FIX_IN_A_PLANE) cycle
         cps(ia,j) = 0.d0
         do ifc = 1, nsum
            itcrspd = ncrspd(ifc)
            cps(ia,j) = cps(ia,j) + g(ifc)*u_l(ia,j,itcrspd)
         end do
         enddo
      end do

      goto 1001

      if(constraint_type == COG_FIX_L &
           & .or. constraint_type == COG_FIX .or. constraint_type == COG_CNTR) then
         allocate(itpcd(num_planes_atoms_are_fixed))
         allocate(cps_cog(num_planes_atoms_are_fixed,3)); cps_cog = 0.d0
         allocate(cps_cog_n(num_planes_atoms_are_fixed,3)); cps_cog_n = 0.d0
         allocate(denom(num_planes_atoms_are_fixed)); denom = 0.d0

         do ifc = 1, nfcatm
            ia = ia_cnst(ifc)
            iaa = ipfixedplane(ifc)
            itpcd(iaa) = ifc
            cps_cog(iaa,1:3) = cps_cog(iaa,1:3) + amion(ityp(ia))*(cps(ia,1:3)-u_l(ia,1:3,it))
            denom(iaa) = denom(iaa) + amion(ityp(ia))
         end do
         do ifc = 1, num_planes_atoms_are_fixed
            cps_cog(ifc,1:3) = cps_cog(ifc,1:3)/denom(ifc)
            iaa = itpcd(ifc)
!!$            pdot = dot_product(fcvect(iaa,1:3),cps_cog(ifc,1:3))
!!$            cps_cog_n(ifc,1:3) = pdot*fcvect(iaa,1:3)   ! perpendicular components
            pdot = dot_product(fcvect(1,1:3),cps_cog(ifc,1:3))
            cps_cog_n(ifc,1:3) = pdot*fcvect(1,1:3)   ! perpendicular components
            if(iprigdiis >= 1) then
               write(6,'(" !!f denom = ",f12.4)') denom(ifc)
               write(6,'(" !!f delta cps_cog(    ",i3,") = ",3f8.4)') ifc,cps_cog(ifc,1:3)
               write(6,'(" !!f delta cps_cog_n(  ",i3,") = ",3f8.4)') ifc,cps_cog_n(ifc,1:3)
            end if
         end do
         do ifc = 1, nfcatm
            ia = ia_cnst(ifc)
            itcrspd = ipfixedplane(ifc)
! -------------->
            cps(ia,1:3) = cps(ia,1:3) - cps_cog_n(itcrspd,1:3)
! <-------------
            if(iprigdiis >= 1) then
               write(6,'(" !!f cps(        ",i3,") = ",3f8.4)') ia, cps(ia,1:3)
               write(6,'(" !!f cps-cps_old(",i3,") = ",3f8.4)') ia, cps(ia,1:3)-u_l(ia,1:3,it)
            end if
         end do

         if(iprigdiis >= 1) then
            cps_cog = 0.d0
            cps_cog_n = 0.d0
            do ifc = 1, nfcatm
               ia = ia_cnst(ifc)
               iaa = ipfixedplane(ifc)
               itpcd(iaa) = ifc
               cps_cog(iaa,1:3) = cps_cog(iaa,1:3) + amion(ityp(ia))*cps(ia,1:3)
               cps_cog_n(iaa,1:3) = cps_cog_n(iaa,1:3) + amion(ityp(ia))*u_l(ia,1:3,it)
            end do
            do ifc = 1, num_planes_atoms_are_fixed
               cps_cog(ifc,1:3) = cps_cog(ifc,1:3)/denom(ifc)
               cps_cog_n(ifc,1:3) = cps_cog_n(ifc,1:3)/denom(ifc)
               write(6,'(" !!f real cps_old_cog(    ",i3,") = ",3f8.4)') ifc,cps_cog_n(ifc,1:3)
               write(6,'(" !!f real cps_cog(        ",i3,") = ",3f8.4)') ifc,cps_cog(ifc,1:3)
            end do
         end if
            
         deallocate(denom)
         deallocate(cps_cog_n)
         deallocate(cps_cog)
         deallocate(itpcd)
      end if

1001  continue
    end subroutine opt_geom

    subroutine check_cog()
      integer :: ifc, ia, iaa
      real(kind=DP),allocatable,dimension(:,:) :: cps_cog !d(num_planes_atoms_are_fixed,3)
      real(kind=DP),allocatable,dimension(:,:) :: cps_cog_n !d(num_planes_atoms_are_fixed,3)
      real(kind=DP),allocatable,dimension(:)   :: denom ! d(num_planes_atoms_are_fixed)
      integer, allocatable, dimension(:) ::       itpcd ! d(num_planes_atoms_are_fixed)
      
      if(iprigdiis >= 1) then
         allocate(itpcd(num_planes_atoms_are_fixed))
         allocate(cps_cog(num_planes_atoms_are_fixed,3)); cps_cog = 0.d0
         allocate(cps_cog_n(num_planes_atoms_are_fixed,3)); cps_cog_n = 0.d0
         allocate(denom(num_planes_atoms_are_fixed)); denom = 0.d0
         
         do ifc = 1, nfcatm
            ia = ia_cnst(ifc)
            iaa = ipfixedplane(ifc)
            itpcd(iaa) = ifc
         end do

         cps_cog = 0.d0
         cps_cog_n = 0.d0
         do ifc = 1, nfcatm
            ia = ia_cnst(ifc)
            iaa = ipfixedplane(ifc)
            itpcd(iaa) = ifc
            cps_cog(iaa,1:3) = cps_cog(iaa,1:3) + amion(ityp(ia))*cps(ia,1:3)
            cps_cog_n(iaa,1:3) = cps_cog_n(iaa,1:3) + amion(ityp(ia))*u_l(ia,1:3,it)
            denom(iaa) = denom(iaa) + amion(ityp(ia))
         end do
         do ifc = 1, num_planes_atoms_are_fixed
            cps_cog(ifc,1:3) = cps_cog(ifc,1:3)/denom(ifc)
            cps_cog_n(ifc,1:3) = cps_cog_n(ifc,1:3)/denom(ifc)
            write(6,'(" !!f real cps_old_cog(    ",i3,") = ",3f8.4)') ifc,cps_cog_n(ifc,1:3)
            write(6,'(" !!f real cps_cog(        ",i3,") = ",3f8.4)') ifc,cps_cog(ifc,1:3)
         end do
      end if
            
      deallocate(denom)
      deallocate(cps_cog_n)
      deallocate(cps_cog)
      deallocate(itpcd)
    end subroutine check_cog

    subroutine cmp_fop_fin(it)
      integer, intent(in) :: it
      real(kind=DP) :: xmul, xmul_input_f
      integer :: ia,j
      xmul = 0.d0
      xmul_input_f = 0.d0
      do ia = 1, natm
         do j=1,3
         if(imdtypxyz(ia,j) /= 0) then
            xmul = xmul + forc_g(ia,j)**2
            xmul_input_f = xmul_input_f + w_l(ia,j,it)**2
         end if
         enddo
      end do
      if(printable) write(nfout,*) ' norm of optimal force = ', xmul
      if(printable) write(nfout,*) ' norm of input   force = ', xmul_input_f
    end subroutine cmp_fop_fin

    subroutine cps_damp(c_dist,it,icount)
      real(kind=DP), intent(in) :: c_dist
      integer, intent(in) ::      it
      integer ,intent(out) ::     icount
      integer ::   ia,j, iaa, ifc, itcrspd
      real(kind=DP) :: df
!!$      real(kind=DP) :: pdot
      integer, allocatable, dimension(:) :: sw_damp !d(natm)
!!$      real(kind=DP),allocatable,dimension(:,:) :: cps_cog !d(num_planes_atoms_are_fixed,3)
!!$      real(kind=DP),allocatable,dimension(:,:) :: cps_cog_n !d(num_planes_atoms_are_fixed,3)
!!$      real(kind=DP),allocatable,dimension(:)   :: denom ! d(num_planes_atoms_are_fixed)
!!$      integer, allocatable, dimension(:) ::       itpcd ! d(num_planes_atoms_are_fixed)

      allocate(sw_damp(natm)); sw_damp = YES
      if(constraint_type == COG_FIX_L &
           & .or. constraint_type == COG_FIX .or. constraint_type == COG_CNTR) then
!!$         allocate(itpcd(num_planes_atoms_are_fixed))
!!$         allocate(cps_cog(num_planes_atoms_are_fixed,3)); cps_cog = 0.d0
!!$         allocate(cps_cog_n(num_planes_atoms_are_fixed,3)); cps_cog_n = 0.d0
!!$         allocate(denom(num_planes_atoms_are_fixed)); denom = 0.d0
         do j = 1, nfcatm
            ia = ia_cnst(j)
            sw_damp(ia) = NO
!!$            iaa = ipfixedplane(j)
!!$            itpcd(iaa) = j
!!$            cps_cog(iaa,1:3) = cps_cog(iaa,1:3) + amion(ityp(ia))*(cps(ia,1:3)-u_l(ia,1:3,it))
!!$            denom(iaa) = denom(iaa) + amion(ityp(ia))
         end do
!!$         do ifc = 1, num_planes_atoms_are_fixed
!!$            cps_cog(ifc,1:3) = cps_cog(ifc,1:3)/denom(ifc)
!!$            iaa = itpcd(ifc)
!!$            pdot = dot_product(fcvect(1,1:3),cps_cog(ifc,1:3))
!!$            cps_cog_n(ifc,1:3) = pdot*fcvect(1,1:3)   ! perpendicular components
!!$         end do
!!$         do ifc = 1, nfcatm
!!$            ia = ia_cnst(ifc)
!!$            itcrspd = ipfixedplane(ifc)
!!$            cps(ia,1:3) = cps(ia,1:3) - cps_cog_n(itcrspd,1:3)
!!$         end do
!!$         deallocate(denom)
!!$         deallocate(cps_cog_n)
!!$         deallocate(cps_cog)
!!$         deallocate(itpcd)
      end if

      icount = 0
      do ia = 1, natm
         if(sw_damp(ia) == NO) cycle
         do j = 1, 3
            df = cps(ia,j) - u_l(ia,j,it)
            if(df > c_dist) then
               icount = icount + 1
               cps(ia,j) = u_l(ia,j,it) + c_dist
            else if(df < -c_dist) then
               icount = icount + 1
               cps(ia,j) = u_l(ia,j,it) - c_dist
            end if
         end do
      end do
      deallocate(sw_damp)
    end subroutine cps_damp

  end subroutine m_IS_gdiis

  subroutine  mdfy_forc(forcmx,forcmx_mdfy)
    real(kind=DP), intent(in) ::  forcmx
    real(kind=DP), intent(out) :: forcmx_mdfy

    integer :: iaa, ic_cog, ifcatm, ia
    integer, allocatable, dimension(:) :: npfatm  ! d(natm)
    real(kind=DP), dimension(3) :: fcg, fcg_mdfy
    real(kind=DP) :: pdot, fca
    
    
    if(.not.constraints_exist) then
       forcmx_mdfy = forcmx
    else
!!$       if(constraint_type == NDB) then
!!$       else
       ! -- ipcpd ---
       allocate(npfatm(natm)); npfatm = 0
       ifcatm = 0
       do ia = 1, natm
          if(imdtyp(ia) == COG_FIX .or. imdtyp(ia) == COG_FIX_L &
               .or. imdtyp(ia) == FIX_IN_A_PLANE) then
             ifcatm = ifcatm + 1
             npfatm(ia) = ifcatm
             if(imdtyp(ia) == COG_FIX .or. imdtyp(ia) == COG_FIX_L) iaa = ia
          end if
       end do

       if(constraint_type == COG_CNTR .or. constraint_type == COG_FIX_L ) then
          ic_cog = 0
          do ia = 1, natm
             if(imdtyp(ia) == COG_CNTR .or. imdtyp(ia) == COG_FIX_L) then
                ic_cog = ic_cog + 1
                fcg(1) = fcg(1) + forc_g(ia,1)
                fcg(2) = fcg(2) + forc_g(ia,2)
                fcg(3) = fcg(3) + forc_g(ia,3)
             end if
             ! fcg(1:3) = \sum_{ia} forc_g(ia,1:3)
          end do
          if(ic_cog >= 2) then
             fcg = fcg/ic_cog
             ! fcg(1:3) = \sum_{ia} forc_g(ia,1:3)/(\sum_{ia}) := f
             ifcatm = npfatm(iaa)
             pdot = dot_product(fcvect(ifcatm,1:3),fcg)
             fcg_mdfy = fcg - pdot*fcvect(ifcatm,1:3)   ! parallel components
             ! = f_{parallel}, pdot*fcvect(ifcatm,:) = f_{perpendicular}
          else if(ic_cog == 1) then
             stop ' #ic_cog is not enough <<m_IS_gdiis.mdfy_forc>>'
          else
             fcg_mdfy = 0.d0
          end if
       end if

       do ia = 1, natm
          if(imdtyp(ia) == FIX_IN_A_PLANE .or. imdtyp(ia) == COG_CNTR &
               & .or. imdtyp(ia) == COG_FIX_L) then
             ifcatm = npfatm(ia)
             if(imdtyp(ia) == COG_CNTR .or. imdtyp(ia) == COG_FIX_L) then
!!$                forc_g(ia,1:3) = fcg_mdfy + forc_g(ia,1:3) - fcg
                forc_g(ia,1:3) = forc_g(ia,1:3) - (fcg - fcg_mdfy)
                !  f_{ia} = f_{ia} - f_{perpendicular}
             else
                pdot = dot_product(fcvect(ifcatm,1:3),forc_g(ia,1:3))
                forc_g(ia,1:3) = forc_g(ia,1:3) - pdot*fcvect(ifcatm,1:3)
             end if
           end if
       end do

       forcmx_mdfy = 0.d0
       do ia = 1, natm
          if(imdtyp(ia) /= 0) then
             fca = dsqrt(forc_g(ia,1)**2 + forc_g(ia,2)**2 + forc_g(ia,3)**2)
             if(forcmx_mdfy < fca) forcmx_mdfy = fca
          end if
       end do

       deallocate(npfatm)
    end if
  end subroutine mdfy_forc

  subroutine forc_check(name)
    character(len=*),intent(in) :: name
    integer :: ia,j
    write(nfout,'(a40)') name
    do ia = 1, natm
       write(nfout,'(i4,3f20.12)') ia, (forc_g(ia,j),j=1,3)
    end do
  end subroutine forc_check

  subroutine cps_check(name)
    character(len=*),intent(in) :: name
    integer :: ia,j
    write(nfout,'(a40)') name
    do ia = 1, natm
       write(nfout,'(i4,3f20.12)') ia, (cps(ia,j),j=1,3)
    end do
  end subroutine cps_check

  subroutine cpd_check(name)
    character(len=*),intent(in) :: name
    integer :: ia,j
    write(nfout,'(a40)') name
    do ia = 1, natm
       write(nfout,'(i4,3f20.12)') ia, (cpd_l(ia,j),j=1,3)
    end do
  end subroutine cpd_check

  subroutine m_IS_set_mdmode_cnstra()
    mdmode = CNSTRA
  end subroutine m_IS_set_mdmode_cnstra

  subroutine m_IS_set_mdmode_ordina()
    mdmode = ORDINA
  end subroutine m_IS_set_mdmode_ordina

  subroutine m_IS_phonon_force()
    integer :: id,ic
    id = iteration_ionic + istart_phonon - 1
    ic = iconf(id)
    displaced_atom = phonon_atom(ic)
    cps(displaced_atom,1:3) = cps(displaced_atom,1:3) - phonon_displacement(ic,1:3)
    id = iteration_ionic + istart_phonon
    ic = iconf(id)
    displaced_atom = phonon_atom(ic)
    displacement(1:3) = phonon_displacement(ic,1:3)
    cps(displaced_atom,1:3) = cps(displaced_atom,1:3) + displacement(1:3)
  end subroutine m_IS_phonon_force

  subroutine m_IS_phonon_set_displacement()  ! asms
    integer :: id,ic
    id = iteration_ionic + istart_phonon - 1
    ic = iconf(id)
    displaced_atom    = phonon_atom(ic)
    displacement(1:3) = phonon_displacement(ic,1:3)
  end subroutine m_IS_phonon_set_displacement

  subroutine m_IS_phonon_equilibrium()
    integer :: id,ic
    id = iteration_ionic + istart_phonon - 1
    ic = iconf(id)
    displaced_atom = phonon_atom(ic)
    cps(displaced_atom,1:3) = cps(displaced_atom,1:3) - phonon_displacement(ic,1:3)
  end subroutine m_IS_phonon_equilibrium

  subroutine m_IS_phonon_initialization()
    use m_Files, only : nfout
    use m_Const_Parameters, only : PUCV,PAI2,PHONON_FORCE
    use m_Crystal_Structure, only : rltv,b2pmat

    real(kind=DP) :: work(3)
    integer :: i,ic

    if(sw_calc_force == ON) then
      imdalg = PHONON_FORCE
      if(printable) write(nfout,*) 'PHONON: imdalg = ',imdalg
    end if

    call set_phonon_displacemets()
    call search_equiv_config()
    if(istart_phonon <= 0 .or. istart_phonon > num_force_calc) &
      & istart_phonon=1
    if(iend_phonon <= 0 .or. iend_phonon > num_force_calc) &
      & iend_phonon=num_force_calc
    if(iend_phonon<istart_phonon) iend_phonon=istart_phonon
    if(printable) write(nfout,*) &
      & 'PHONON: istart, iend = ',istart_phonon,iend_phonon
    ic = iconf(istart_phonon)
    displaced_atom = phonon_atom(ic)
    displacement(1:3) = phonon_displacement(ic,1:3)

  contains
    subroutine set_phonon_displacemets()
      ! local variables
      integer :: ia,is,id

      num_force_data = natm_prim*3*norder*2
      if(sw_polynomial_fit == ON) num_force_data = num_force_data + 1
      allocate(phonon_atom(num_force_data))
      allocate(phonon_displacement(num_force_data,3))

      if(sw_polynomial_fit == ON) then
         num_force_data = 1
         phonon_atom(num_force_data) = 1
         phonon_displacement(num_force_data,1:3) = 0.d0
      else
         num_force_data = 0
      end if
      do ia=1,natm_prim
         do id=1,3
            do is=-norder,norder
               if(is == 0) cycle
               num_force_data = num_force_data + 1
               phonon_atom(num_force_data) = ia
               phonon_displacement(num_force_data,1:3) = 0.d0
               phonon_displacement(num_force_data,id) =  u/dble(is)
            end do
         end do
      end do

    end subroutine set_phonon_displacemets

    subroutine search_equiv_config()
      ! local variables
      integer :: i,j,ia,ja,iopr,ia1,ia2,k
      real(kind=DP) :: ui(3),uj(3),t(3),ruj(3),p1(3),p2(3),f(3)
!!$      real(kind=DP), parameter :: ddd = 1.d-12

      allocate(napt_phonon(natm_super,num_force_data)); napt_phonon=0
      allocate(iequconf(num_force_data)); iequconf = 0
      allocate(iopr_equconf(num_force_data)); iopr_equconf = 0

      if(sw_calc_force_all == OFF) then
         do i=2,num_force_data
            ia=phonon_atom(i)
            ui=phonon_displacement(i,1:3)
            Loop_conf: do j=1,i-1
               ja=phonon_atom(j)
               uj=phonon_displacement(j,1:3)
               Loop_op: do iopr=1,nopr
                  if(ia/=napt(ja,iopr)) cycle
                  do k=1,3
                     ruj(k) = dot_product(op(k,1:3,iopr),uj)
                  end do
                  if(sum(abs(ui(1:3)-ruj(1:3)))>1.d-8) cycle
                  do k=1,3
                     t(k) = cps(ia,k) - dot_product(op(k,1:3,iopr),cps(ja,1:3))
                  end do
                  Loop_atom: do ia1=1,natm_super
                     do k=1,3
                        p1(k) = dot_product(op(k,1:3,iopr),cps(ia1,1:3)) + t(k)
                     end do
                     do ia2=1,natm_super
                        if(ityp(ia1) /= ityp(ia2)) cycle
                        p2(1:3) = cps(ia2,1:3)-p1(1:3)
                        f(1) = abs(cos(sum(rltv(1:3,1)*p2))-1.d0)
                        f(2) = abs(cos(sum(rltv(1:3,2)*p2))-1.d0)
                        f(3) = abs(cos(sum(rltv(1:3,3)*p2))-1.d0)
!!$                        if(maxval(f) <= ddd) then
                        if(maxval(f) <= symmetry_check_criterion) then
                           napt_phonon(ia1,i) = ia2
                           cycle Loop_atom
                        end if
                     end do
                     cycle Loop_op
                  end do Loop_atom
                  if(ia==ja .and. sum(abs(ui(1:3)+uj(1:3)))<1.d-8) then
                     iequconf(i) = -j
                  else
                     iequconf(i) = j
                  end if
                  iopr_equconf(i) = iopr
                  exit Loop_conf
               end do Loop_op
            end do Loop_conf
         end do
      end if

      num_force_calc=0
      do i=1,num_force_data
         if(iequconf(i)<=0) num_force_calc=num_force_calc+1
      end do
      allocate(iconf(num_force_calc))
      j=0
      do i=1,num_force_data
         if(iequconf(i)<=0) then
            j = j+1
            iconf(j)=i
         end if
      end do

      if(ipriphonon>=1) then
         write(nfout,'(" PHONON: equivalent configurations")')
         write(nfout,'(" PHONON: i, iequconf, iopr_equconf")')
         do i=1,num_force_data
            write(nfout,'(" PHONON: ",i5,1x,i5,1x,i5)') i,iequconf(i),iopr_equconf(i)
         end do
         write(nfout,'(" PHONON: number of force calculations = ",i5)') num_force_calc
         write(nfout,'(" PHONON: i, iconf")')
         do i=1,num_force_calc
            write(nfout,'(" PHONON: ",i5,1x,i5)') i,iconf(i)
         end do
         do i=1,num_force_data
            write(nfout,'(" PHONON: napt_phonon i=",i5)') i
            write(nfout,'(" PHONON: ",10i5)') napt_phonon(1:natm_super,i)
         end do
      end if
    end subroutine search_equiv_config

  end subroutine m_IS_phonon_initialization

  subroutine m_IS_phonon_initial_disp()
    use m_Crystal_Structure, only : m_CS_phonon_symmetry
    integer :: i, id, ic

! =====ASMS_DEBUG ====================== 2013/02/07
    if ( sw_calc_force == OFF ) return
! =====ASMS_DEBUG ====================== 2013/02/07

    if(sw_phonon_oneshot == ON) then
       id = num_phonon_calc_mode 
       if(id > num_force_calc) id = num_force_calc
       ic = iconf(id)
       if(ipri>=1) write(nfout,'(" ic, id = ", 2i8)') ic, id
       displaced_atom = phonon_atom(ic)
       displacement(1:3) = phonon_displacement(ic,1:3)
       cps(displaced_atom,1:3) = cps(displaced_atom,1:3) + displacement(1:3)
    else
       cps(displaced_atom,1:3) = cps(displaced_atom,1:3) + displacement(1:3)
    end if
    call m_IS_cps_to_pos()
    if(sw_calc_force == ON) then
      call m_CS_phonon_symmetry(OFF)
    end if
  end subroutine m_IS_phonon_initial_disp

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

    integer :: ia, ic, is, ie

    do ia = 1,natm
       if(ionic_mass(ia)<0.d0) ionic_mass(ia) = amion(ityp(ia))
    end do

    if(natom_reservoir>0)then
       do ia=1,natom_reservoir
          if(atom_reservoir(ia)%ionic_mass<0.d0) &
        & atom_reservoir(ia)%ionic_mass = amion(atom_reservoir(ia)%ityp)
       enddo
    endif
    if(printable) then
       if(natm <= 3) then
          write(nfout,'(" !**   ia, ionic_mass ")')
          do ia=1,natm
             write(nfout,'(" !** ",i4,1x,f20.5)') ia,ionic_mass(ia)
          end do
       else
          write(nfout,'(" !**   ia1 - ia2, ityp, ionic_mass ")')
          ic = ityp(1)
          is = 1; ie = 0
          do ia=2,natm
             if(ityp(ia) /= ic) then
                ie = ia-1
                write(nfout,'(" !** ",i4," - ",i4,i4,f20.5)') is,ie,ityp(ie),ionic_mass(ie)
                is = ia
                ic = ityp(ia)
             end if
          end do
          ie = ia-1
          write(nfout,'(" !** ",i4," - ",i4,i4,f20.5)') is,ie,ityp(ie),ionic_mass(ie)
       end if
    end if
  end subroutine m_IS_set_ionic_mass

  subroutine m_IS_pack_all_ions_in_uc(ityp_full_r,cps_full)
    integer, intent(out), dimension(natm2) ::       ityp_full_r
    real(kind=DP),intent(out),dimension(natm2,3) :: cps_full
    ! All packed ion coordinates in the primitive unit cell system 
    real(kind=DP),allocatable,dimension(:,:) :: pos_wk
    real(kind=DP),allocatable,dimension(:)   :: r_wk
    integer :: i, m, ucret

    !!!allocate(r_wk(3))

    allocate(pos_wk(natm2,3))
    pos_wk(1:natm,:) = pos(1:natm,:)

    ityp_full_r(1:natm) = ityp(1:natm)
    if(natm2 > natm) then
       call rplcps(pos_wk,ityp_full_r,1,natm2,natm,iwei)  ! -(b_Ionic_System)
       call rbinuc(pos_wk,natm2)  ! -(b_Ionic_System)
       call change_of_coordinate_system(altv,pos_wk,natm2,natm2,cps_full) ! -(b_Ionic_System)
       !! for unit conversion to angstrom
       !!do i = 1, natm2
       !!   !!!! K.Mae 040315
       !!   do m = 1, 3
       !!      ucret = unit_conv_byname( cps_full(i,m), r_wk(m), 'bohr', 'angstrom' )
       !!   end do
       !!   cps_full(i,1:3) = r_wk(1:3)
       !!end do
    else
       call rbinuc(pos_wk,natm)
       call change_of_coordinate_system(altv,pos_wk,natm,natm,cps_full) ! -(b_C.S.)
       !! for unit conversion to angstrom
       !!do i = 1, natm
       !!   !!! K.Mae 040315
       !!   do m = 1, 3
       !!      ucret = unit_conv_byname( cps_full(i,m), r_wk(m), 'bohr', 'angstrom' )
       !!   end do
       !!   cps_full(i,1:3) = r_wk(1:3)
       !!end do
    end if
    deallocate(pos_wk)
    !!!deallocate(r_wk)
  end subroutine m_IS_pack_all_ions_in_uc

  subroutine m_IS_CG_reset()
     iter_CG = 1
     iter_linmin = 1
     iter_CG_max = 1
  end subroutine m_IS_CG_reset

!! Added by J.N. 6/Jan/2013
!! Previous version of CG installed by T.Y was deleted.
!! If that verson is needed, check out from svn.
  subroutine m_IS_cg2(forc_l_in,etotal)
    real(kind=DP), intent(in), dimension(natm,3) :: forc_l_in
    real(kind=DP), intent(in)                    :: etotal

    real(kind=DP), save :: alpha, alpha2, gamma
    real(kind=DP), save :: f_para1, f_para2, f_para3
    real(kind=DP), save :: vec_h_norm
    real(kind=DP), dimension(:,:), allocatable, save :: vec_g, vec_h          ! dim(natm,3)
    real(kind=DP), dimension(:,:), allocatable, save ::       f_total0        ! dim(natm,3)
    real(kind=DP), dimension(:,:), allocatable, save :: cps1, f_total1        ! dim(natm,3)
    real(kind=DP), dimension(:,:), allocatable, save :: cps2, f_total2        ! dim(natm,3)
    integer :: ia,j


    integer ::              id_sname = -1
    call tstatc0_begin('m_IS_cg2',id_sname)

     if(absolute_convergence_of_forc(forc_l_in))then
       write(nfout,'(a)') ' CG2: forces are absolutely converged!! nothing to do...'
       return
     endif

    if(.not.allocated(vec_g)) allocate(vec_g(natm,3))
    if(.not.allocated(vec_h)) allocate(vec_h(natm,3))
    if(.not.allocated(f_total0)) allocate(f_total0(natm,3))
    if(.not.allocated(cps1)) allocate(cps1(natm,3))
    if(.not.allocated(f_total1)) allocate(f_total1(natm,3))
    if(.not.allocated(cps2)) allocate(cps2(natm,3))
    if(.not.allocated(f_total2)) allocate(f_total2(natm,3))


    f_total0(:,:) = forc_l_in(:,:)


    if(constraint_type == FIXED_NORMAL_HYPERVECTOR) call modify_forc_hyperplane(f_total0)


     do ia=1,natm
       do j=1,3
         if (imdtypxyz(ia,j) == FIX) then
           f_total0(ia,j) = 0.0d0
         endif
       enddo
     end do

     if ( ( iter_CG .eq. 1 ) .and. ( iter_linmin .eq. 1 ) ) then
       call first_cg_step()
     else if ( iter_linmin .eq. 2 ) then
       f_para2 = sum(f_total0(:,:)*vec_h(:,:))/sqrt(sum(vec_h(:,:)**2))
       if(printable) write(nfout,'(a18,2f10.6)') ' CG2: F_parallel =', f_para1, f_para2
       if ( abs(f_para2) .lt. f_para1*0.2d0 ) then
         if(printable) write(nfout,*) 'CG2: F_parallel is small. Then linmin finished.'
         if ( iter_CG .lt. iter_CG_max ) then
           if(printable) write(nfout,*) 'CG2: Go next_cg_step'
           call next_cg_step()
         else
           if(printable) write(nfout,*) 'CG2: Reach to max_CG_step. Go first_cg_step'
           call first_cg_step()
         endif
       else
         call linmin_set_new_cps()
       endif
     else
       f_para3 = sum(f_total0(:,:)*vec_h(:,:))/sqrt(sum(vec_h(:,:)**2))
       if(printable) write(nfout,'(a18,3f10.6)') ' CG2: F_parallel =', f_para1, f_para2, f_para3
       f_para3 = abs(f_para3)
       f_para2 = abs(f_para2)
       if ( ( f_para3 .lt. f_para2 ) .and. ( f_para3 .lt. f_para1 ) ) then
         if ( f_para3 .lt. f_para1*0.2d0 ) then
           if(printable) write(nfout,*) 'CG2: F_parallel is small. Then linmin finished.'
           if ( iter_CG .lt. iter_CG_max ) then
             if(printable) write(nfout,*) 'CG2: Go next_cg_step'
             call next_cg_step()
           else
             if(printable) write(nfout,*) 'CG2: Reach to max_CG_step. Go first_cg_step'
             call first_cg_step()
           endif
         else
           if(printable)then
           write(nfout,*) 'CG2: CG procedure is failed !!'
           write(nfout,*) 'CG2: f_para3 must be less than f_para1*0.2d0.'
           write(nfout,*) 'CG2: Then, new CG procedure starts.'
           endif
           call first_cg_step()
         endif
       else
         if(printable)then
         write(nfout,*) 'CG2: Linmin calc is failed !!'
         write(nfout,*) 'CG2: The 3rd point is not a minimum.'
         write(nfout,*) 'CG2: Then, new CG procedure starts from the 2nd point.'
         endif
         call first_cg_step_from_cps2()
       endif
     endif

  contains

    subroutine first_cg_step()
      f_total1(:,:) = f_total0(:,:)
      vec_g(:,:) = f_total1(:,:)
      vec_h(:,:) = vec_g(:,:)
      cps1(:,:) = cps(:,:)
      vec_h_norm = sqrt( sum( vec_h(1:natm,1:3)**2 ) )
      call set_alpha()
      cps(:,:) = cps1(:,:) + vec_h(:,:) * alpha
      f_para1 = sum(f_total1(:,:)*vec_h(:,:))/sqrt(sum(vec_h(:,:)**2))
      if ( f_para1 .gt. 0.08d0 ) then
        iter_CG_max = 1
      else
        iter_CG_max = 5
      endif
      iter_CG = 1
      iter_linmin = 2
      write(nfout,'(a28,i2,a18,i2)') ' CG2: Next step is iter_CG =', iter_CG, ' and iter_linmin =', iter_linmin
    end subroutine first_cg_step

    subroutine set_alpha()
      if      ( vec_h_norm .lt. 0.004d0 ) then
        alpha = 3.5d0
      else if ( vec_h_norm .lt. 0.007d0 ) then
        alpha = 3.0d0
      else if ( vec_h_norm .lt. 0.010d0 ) then
        alpha = 2.5d0
      else if ( vec_h_norm .lt. 0.015d0 ) then
        alpha = 2.0d0
      else if ( vec_h_norm .lt. 0.020d0 ) then
        alpha = 1.5d0
      else
        alpha = 1.0d0
      endif
    end subroutine set_alpha

    subroutine next_cg_step()
      f_total1(:,:) = f_total0(:,:)
!     gamma = sum(f_total1(:,:)**2) / sum(vec_g(:,:)**2)
      gamma = sum( (f_total1(:,:)-vec_g(:,:))*f_total1(:,:) ) / sum(vec_g(:,:)**2)
      vec_g(:,:) = f_total1(:,:)
      vec_h(:,:) = vec_g(:,:) + gamma * vec_h(:,:)
      cps1(:,:) = cps(:,:)
      vec_h_norm = sqrt( sum( vec_h(1:natm,1:3)**2 ) )
      call set_alpha()
      cps(:,:) = cps1(:,:) + vec_h(:,:) * alpha
      f_para1 = sum(f_total1(:,:)*vec_h(:,:))/sqrt(sum(vec_h(:,:)**2))
      iter_CG = iter_CG + 1
      iter_linmin = 2
     write(nfout,'(a28,i2,a18,i2)') ' CG2: Next step is iter_CG =', iter_CG, ' and iter_linmin =', iter_linmin
    end subroutine next_cg_step

    subroutine linmin_set_new_cps()
      cps2(:,:) = cps(:,:)
      f_total2(:,:) = f_total0(:,:)
      alpha2 = f_para1 * alpha / ( f_para1 - f_para2 )
      write(nfout,*) 'CG2: alpha(force ) =', alpha2
      if ( alpha2 .lt. 0.0d0 ) then
        write(nfout,*) 'CG2: Linmin calc is strange !!'
        write(nfout,*) 'CG2: Alpha must be positive !!'
        write(nfout,'(a13,f15.10)') ' CG2: Alpha =', alpha2
        write(nfout,*) 'CG2: New CG step start from the 2nd point.'
        call first_cg_step()
      else
        if ( alpha2 .gt. 10.0d0*alpha ) then
          write(nfout,*) 'CG2: Linmin calculated.'
          write(nfout,'(a22,f15.10)') ' CG2: Original alpha =', alpha2
          write(nfout,*) 'CG2: Alpha is too large, then, adjusted.'
          alpha2 = 10.0d0*alpha
        endif
        write(nfout,'(a13,f15.10)') ' CG2: Alpha =', alpha2
        cps(:,:) = cps1(:,:) + vec_h(:,:) * alpha2
        iter_linmin = 3
        write(nfout,'(a28,i2,a18,i2)') ' CG2: Next step is iter_CG =', iter_CG, ' and iter_linmin =', iter_linmin
      endif
    end subroutine linmin_set_new_cps

    subroutine first_cg_step_from_cps2()
      f_total1(:,:) = f_total2(:,:)
      vec_g(:,:) = f_total1(:,:)
      vec_h(:,:) = vec_g(:,:)
      cps1(:,:) = cps2(:,:)
      vec_h_norm = sqrt( sum( vec_h(1:natm,1:3)**2 ) )
      call set_alpha()
      cps(:,:) = cps1(:,:) + vec_h(:,:) * alpha
      f_para1 = sum(f_total1(:,:)*vec_h(:,:))/sqrt(sum(vec_h(:,:)**2))
      iter_CG = 1
      iter_linmin = 2
      write(nfout,'(a28,i2,a18,i2)') ' CG2: Next step is iter_CG =', iter_CG, ' and iter_linmin =', iter_linmin
    end subroutine first_cg_step_from_cps2

!! jn_130104

  end subroutine m_IS_cg2

  subroutine m_IS_cg(forc_l_in,etotal)
    real(kind=DP), intent(in), dimension(natm,3) :: forc_l_in
    real(kind=DP), intent(in)                    :: etotal

    logical, save :: finit = .true., fconv = .false.
    integer, save :: itime = 1
    integer :: ia,j
    integer, save :: natm_free
    real(kind=DP), save :: e0,e1,e2,e3
    real(kind=DP), save :: dt1,dt2,dt3
    real(kind=DP), save :: de1,de2,de3
    real(kind=DP), dimension(:,:), allocatable, save :: hvec,g0vec,g1vec,cps0 ! dim(natm,3)
    real(kind=DP), allocatable, dimension(:,:)   :: forc_l

    integer ::              id_sname = -1
    call tstatc0_begin('m_IS_cg ',id_sname)

    if(printable) write(nfout,*) 'gCG: iter=',iteration_ionic,' itime=',itime

    allocate(forc_l(natm,3))
    forc_l = forc_l_in

    if(.not.allocated(hvec)) allocate(hvec(natm,3))
    if(.not.allocated(g0vec)) allocate(g0vec(natm,3))
    if(.not.allocated(g1vec)) allocate(g1vec(natm,3))
    if(.not.allocated(cps0)) allocate(cps0(natm,3))

!!$    if(constraint_type == FIXED_NORMAL_HYPERVECTOR) call modify_forc_fi(forc_l)
    if(constraint_type == FIXED_NORMAL_HYPERVECTOR) call modify_forc_hyperplane(forc_l)

    if(finit) then
       hvec = 0.d0
       g0vec = 0.d0
       natm_free = 0
       do ia=1,natm
          do j=1,3
          if(imdtypxyz(ia,j) == 0 ) cycle
          hvec(ia,j) = forc_l(ia,j)
          g0vec(ia,j) = hvec(ia,j)
          natm_free = natm_free + 1
          enddo
       end do
       if(printable) write(nfout,*) 'gCG: # of free atoms=',natm_free
       finit = .false.
    end if

    if(itime == 1) then
       call first()
       itime = 2
    else if(itime == 2) then
       e2 = etotal
       call deriv_energy(de2,hvec)
       if(de2 > 0.d0 .or. e2 > e0 ) then
          call estimate_min(dt1,dt2,e1,e2,de1,de2,fconv)
          itime = 3
       else
      !debug
          if(printable) write(nfout,*) 'gCG:== Second (dt2)=='
      !end debug
          e1 = e2
          de1 = de2
          dt1 = dt2
          dt2 = 2*dt1
          cpd_l = dt2 * hvec
          cps = cps0 + cpd_l
      !debug
      ! if(printable)
      ! write(nfout,*) 'gCG:cpd_l:'
      ! do ia=1,natm
      !    write(nfout,'("gCG:",i3,3(1x,f17.9))') ia,cpd_l(ia,1:3)
      ! end do
      ! write(nfout,*) 'gCG:cps:'
      ! do ia=1,natm
      !    write(nfout,'("gCG:",i3,3(1x,f17.9))') ia,cps(ia,1:3)
      ! end do
      ! end if
      !end debug
       end if
    else
       call estimate_min(dt1,dt2,e1,e2,de1,de2,fconv)
       itime = itime + 1
       if(fconv) then
          g1vec = 0.d0
          do ia=1,natm
             do j=1,3
             if(imdtypxyz(ia,j) == 0 ) cycle
             g1vec(ia,j) = forc_l(ia,j)
             enddo
          end do
          call conjugate_grad(hvec,g0vec,g1vec)
          call first()
          itime = 2
          fconv = .false.
       end if
    end if


    deallocate(forc_l)

    call tstatc0_end(id_sname)
  contains
    
    subroutine first()
      !debug
           if(printable) write(nfout,*) 'gCG:== First (dt1)=='
      !end debug
      cps0 = cps
      e0 = etotal
      dt1 = 0.d0
      e1 = e0
      call deriv_energy(de1,hvec)
      dt2 = 1.d0
      cpd_l = dt2 * hvec

      cps = cps0 + cpd_l
      !debug
      ! if(printable)
      ! write(nfout,*) 'gCG:cpd_l:'
      ! do ia=1,natm
      !    write(nfout,'("gCG:",i3,3(1x,f17.9))') ia,cpd_l(ia,1:3)
      ! end do
      ! write(nfout,*) 'gCG:cps:'
      ! do ia=1,natm
      !    write(nfout,'("gCG:",i3,3(1x,f17.9))') ia,cps(ia,1:3)
      ! end do
      ! end if
      !end debug
    end subroutine first

    subroutine deriv_energy(de,hvec)
      real(kind=DP), intent(out) :: de
      real(kind=DP), intent(in) :: hvec(natm,3)

      integer :: ia,j
      
      de = 0.d0
      do ia=1,natm
         do j=1,3
            if(imdtypxyz(ia,j) == 0 ) cycle
            de = de + forc_l(ia,j)*hvec(ia,j)
         enddo
      end do
      de = -de

    end subroutine deriv_energy

    subroutine estimate_min(dt1,dt2,e1,e2,de1,de2,fconv)
      real(kind=DP), intent(inout) :: dt1,dt2,e1,e2,de1,de2
      logical, intent(out) :: fconv

      real(kind=DP), save :: dt3,e3,de3
      real(kind=DP) :: c1,c2,c3,c4
      real(kind=DP) :: ddt,sdt,pdt2,pdt3,sq,dtm,dtp
      real(kind=DP) :: dfp,dfm,fp,fm
      logical, save :: finit = .true.

      if(.not.finit) then
         e3 = etotal
         call deriv_energy(de3,hvec)
         !debug
         if(printable) then
           write(nfout,*) 'gCG:== Estimate Emin (old dt1,dt2) =='
           write(nfout,*) 'gCG:dt1=',dt1,' e1=',e1
           write(nfout,*) 'gCG:de1=',de1
           write(nfout,*) 'gCG:dt2=',dt2,' e2=',e2
           write(nfout,*) 'gCG:de2=',de2
           write(nfout,*) 'gCG:dt3=',dt3,' e3=',e3
           write(nfout,*) 'gCG:de3=',de3
           write(nfout,*) 'gCG:de3/natm_free=',de3/dble(natm_free)
           write(nfout,*) 'gCG:etol=',etol
         end if
         !end debug
         if(abs(de3)/dble(natm_free) .le. etol) then
            fconv = .true.
            finit = .true.
            return
         end if 
         if(de3 > 0.d0 .or. e3 > e1) then
            e2 = e3
            de2 = de3
            dt2 = dt3
         else
            e1 = e3
            de1 = de3
            dt1 = dt3
         end if
      end if
      finit = .false.
      !debug
      if(printable) then
        write(nfout,*) 'gCG:== Estimate Emin (new dt1,dt2) =='
        write(nfout,*) 'gCG:dt1=',dt1,' dt2=',dt2
        write(nfout,*) 'gCG: e1=',e1,' e2=',e2
        write(nfout,*) 'gCG:de1=',de1,' de2=',de2
      end if
      !end debug

      ddt = dt1 - dt2
      sdt = dt1 + dt2
      pdt2 = dt1*dt1
      pdt3 = dt1*pdt2
      c1 = ((de1+de2)*ddt-2.d0*(e1-e2))/ddt**3  
      c2 = 0.5d0*(de1-de2-3.d0*c1*ddt*sdt)/ddt
      c3 = de1 - 3.d0*c1*pdt2 - 2.d0*c2*dt1
      c4 = e1 - c1*pdt3 - c2*pdt2 - c3*dt1

!!$ASASASASASAS
!!$      sq = c2+sqrt(c2*c2-3.d0*c1*c3)
      sq = c2*c2-3.d0*c1*c3
      if (sq > 0.d0) then
         sq = sqrt(sq)
      else
         write(nfout,*) 'gCG: Warning! Cannot estimate the minimum.'
         sq = 0.d0
      endif
      sq = sq + c2
!!$ASASASASASAS
      dtp = -c3/sq
      dtm = -sq/(3.d0*c1)

      dfp = 3.d0*c1*dtp**2+2.d0*c2*dtp+c3
      dfm = 3.d0*c1*dtm**2+2.d0*c2*dtm+c3

      fp = c1*dtp**3+c2*dtp**2+c3*dtp+c4
      fm = c1*dtm**3+c2*dtm**2+c3*dtm+c4
      
      !debug
      if(printable) then
        write(nfout,*) 'gCG:== Estimate Emin (c1,c2,c3) =='
        write(nfout,*) 'gCG: c1=',c1,' c2=',c2
        write(nfout,*) 'gCG: c3=',c3,' c4=',c4
        write(nfout,*) 'gCG:dtp=',dtp,' dtm=',dtm
        write(nfout,*) 'gCG:dfp=',dfp,' dfm=',dfm
        write(nfout,*) 'gCG: fp=',fp,' fm=',fm
      end if
      !end debug

      if(dtp >= dt1 .and. dtp <= dt2) then
         dt3 = dtp
      else if(dtm >= dt1 .and. dtm <= dt2) then
         dt3 = dtm
      else
        !!stop 'I cant estimated dt3 at which the total energy is minimum'
        write(nfout,*) 'gCG: Warning! line-minimization failed'
        dt3 = 1.d0
      end if

      cpd_l = dt3 * hvec
      cps = cps0 + cpd_l

      !debug
      if(printable) then
       write(nfout,*) 'gCG:== Estimate Emin (dt3) =='
       write(nfout,*) 'gCG:dt1=',dt1,' dt2=',dt2
       write(nfout,*) 'gCG:dtp=',dtp
       write(nfout,*) 'gCG:dtm=',dtm
       write(nfout,*) 'gCG:dt3=',dt3
      ! write(nfout,*) 'gCG:cpd_l:'
      ! do ia=1,natm
      !    write(nfout,'("gCG:",i3,3(1x,f17.9))') ia,cpd_l(ia,1:3)
      ! end do
      ! write(nfout,*) 'gCG:cps:'
      ! do ia=1,natm
      !    write(nfout,'("gCG:",i3,3(1x,f17.9))') ia,cps(ia,1:3)
      ! end do
      end if
      !end debug

    end subroutine estimate_min

    subroutine conjugate_grad(hvec,g0vec,g1vec)
      real(kind=DP), dimension(natm,3), intent(inout) :: hvec,g0vec
      real(kind=DP), dimension(natm,3), intent(in) :: g1vec

      integer :: i,ia
      real(kind=DP) :: gg,gam

      gg = 0.d0
      gam = 0.d0
      do i=1,3
         do ia=1,natm
            gg = gg + g0vec(ia,i)**2
            gam = gam + (g1vec(ia,i)-g0vec(ia,i))*g1vec(ia,i) 
         end do
      end do
      if(gg > 1.d-10*gam) then
         gam = gam/gg
      else
         gam = 1.d0
      end if

      hvec  = g1vec + gam * hvec
      g0vec = g1vec

      !debug
      if(printable) then
       write(nfout,*) 'gCG:== CG =='
       write(nfout,*) 'gCG:gam=',gam
       write(nfout,*) 'gCG:gg=',gg
       write(nfout,*) 'gCG: H (conjugate_grad)'
       do ia=1,natm
          write(nfout,'("gCG:",i3,3(1x,f17.9))') ia,hvec(ia,1:3)
       end do
       write(nfout,*) 'gCG: G'
       do ia=1,natm
          write(nfout,'("gCG:",i3,3(1x,f17.9))') ia,g0vec(ia,1:3)
       end do
      end if
      !end debug

    end subroutine conjugate_grad

  end subroutine m_IS_cg

  subroutine m_IS_remove_atom(irem)
    integer, intent(in) :: irem
    logical, allocatable,dimension(:) :: excl
    call m_IS_store_current_config()
    allocate(excl(nconfig_buf));excl=.false.
    call m_IS_dealloc_pos_and_v(nfout)
    excl(irem) = .true.
    natm = natm-1
    natm2 = natm2-config_buf(irem)%iwei
    call m_IS_alloc_pos_and_v(nfout)
    call m_IS_recover(nconfig_buf,excl)
    call m_CtrlP_check_matm(nfout,natm)
    neg_incre = neg_incre - int(ceiling(config_buf(irem)%nvalence*0.5d0))
    call m_IS_set_iatom(nfout)
    deallocate(excl)
  end subroutine m_IS_remove_atom

  subroutine m_IS_add_atom(newatom)
    type(atomic_configuration_t), intent(in) :: newatom
    logical, allocatable,dimension(:) :: excl
    call m_IS_store_current_config()
    allocate(excl(nconfig_buf));excl=.false.
    call m_IS_dealloc_pos_and_v(nfout)
    natm = natm+1
    natm2 = natm2+newatom%iwei
    call m_IS_alloc_pos_and_v(nfout)
    call m_IS_recover(nconfig_buf,excl)
    ! add the new atom
    !!species_work(natm) = newatom%element
    iwei(natm) = newatom%iwei 
    imdtyp(natm) = newatom%imdtyp 
    imdtypxyz(natm,:) = newatom%imdtypxyz(:)
    ityp(natm) = newatom%ityp 
    if_pdos(natm) = newatom%if_pdos 
    if_aldos(natm) = newatom%if_aldos 
    ihubbard(natm) = newatom%ihubbard 
    iproj_group(natm) = newatom%iproj_group 
    ionic_mass(natm) = newatom%ionic_mass 
    numlay(natm) = newatom%numlay 
    pos(natm,:)  = newatom%pos(:)
    cps(natm,:) = newatom%cps(:)
    pos_in(natm,:) = newatom%pos_in(:)
    cps_in(natm,:) = newatom%cps_in(:)
    cpd_l(natm,:) = newatom%cpd_l(:) 
    cpo_l(natm,:,:) = newatom%cpo_l(:,:)
    neg_incre = neg_incre + int(ceiling(newatom%nvalence*0.5d0))
    call m_CtrlP_check_matm(nfout,natm)
    call m_IS_set_iatom(nfout)
    deallocate(excl)
  end subroutine m_IS_add_atom

  subroutine m_IS_supercell(nfout)
    integer, intent(in) :: nfout
    if(sw_supercell==ON) then
       natm_prim = natm
       natm2_prim = natm2
       natm_super = nlpnt*natm
       natm2_super = nlpnt*natm2
       natm = natm_super
       natm2 = natm2_super
       call spread_atoms_on_supercell(natm_prim,natm)
       if(printable) call print_atoms_supercell(nfout)
#ifndef _EMPIRICAL_
       call m_CtrlP_check_matm(nfout,natm)
#endif
    end if
  contains
    subroutine spread_atoms_on_supercell(natm_prim,natm)
      integer, intent(in) :: natm_prim
      integer, intent(in) :: natm

      integer :: i,j,k,ia,ja
      integer, dimension(natm_prim) :: iwei_wk, imdtyp_wk, ityp_wk, if_pdos_wk, if_aldos_wk
      real(kind=DP), dimension(natm_prim) :: ionic_mass_wk
      real(kind=DP) :: rltv_t(3,3)

! =============== Added by K. Tagami  =============== 0.1
      integer, dimension(natm_prim) :: ihubbard_wk, iproj_group_wk
! ===================================================

! =============== Added by K. Tagami  =============== 11.0
      integer, dimension(natm_prim) :: itab_spinorbit_addition_wk
! =================================================== 11.0

      iwei_wk = iwei
      imdtyp_wk = imdtyp
      ityp_wk = ityp
      if_pdos_wk = if_pdos
      if_aldos_wk = if_aldos
      ionic_mass_wk = ionic_mass

! =========== Added by K. Tagami ================= 0.1
      if ( sw_hubbard == ON ) then
         iproj_group_wk = iproj_group
         ihubbard_wk = ihubbard
      endif
! ================================================ 0.1

! =============================== Added by K. Tagami ================= 11.0
      if ( SpinOrbit_Mode == ByProjector ) then
         iproj_group_wk = iproj_group
         itab_spinorbit_addition_wk = itab_spinorbit_addition
      endif
! ================================================================= 11.0

      if(nlpnt > 1) then
         do ia=1,natm_prim
            call mod1(pos(ia,1))
            call mod1(pos(ia,2))
            call mod1(pos(ia,3))
         end do
      end if
      call change_of_coordinate_system(altv_prim,pos,natm_prim,natm_prim,cps) !-(b_I.S.) pos -> cps
      allocate(pos_prim(natm_prim,3))
      allocate(cps_prim(natm_prim,3))
      pos_prim = pos
      cps_prim = cps

      call m_IS_dealloc_pos_and_v(nfout)
      call m_IS_alloc_pos_and_v(nfout)

      do i=1,nlpnt
         do ia=1,natm_prim
            ja = ia + natm_prim*(i-1)
            cps(ja,1:3) = cps_prim(ia,1:3) + lpnt(i,1:3)
            iwei(ja) = iwei_wk(ia)
            imdtyp(ja) = imdtyp_wk(ia)
            ityp(ja) = ityp_wk(ia)
            if_pdos(ja) = if_pdos_wk(ia)
            if_aldos(ja) = if_aldos_wk(ia)
            ionic_mass(ja) = ionic_mass_wk(ia)

! ==================== Added by K. Tagami ====== trial ======= 0.1
            if ( sw_hubbard == ON ) then
               ihubbard(ja) = ihubbard_wk(ia)
               iproj_group(ja) = iproj_group_wk(ia)
           endif
! ============================================================ 0.1

! =================== Added by K. Tagami ====== trial ==================== 11.0
            if ( SpinOrbit_mode == ByProjector ) then
               itab_spinorbit_addition(ja) = itab_spinorbit_addition_wk(ia)
               iproj_group(ja) = iproj_group_wk(ia)
           endif
! ======================================================================= 11.0

         end do
      end do
      rltv_t = transpose(rltv)/PAI2
      call change_of_coordinate_system(rltv_t,cps,natm,natm,pos) !-(b_I.S.) cps -> pos
      do ia=1,natm
         call mod1(pos(ia,1))
         call mod1(pos(ia,2))
         call mod1(pos(ia,3))
      end do

      allocate(pos_super(natm,3))
      allocate(cps_super(natm,3))
      pos_super = pos
      cps_super = cps

      call m_IS_set_iatom(nfout) ! -> iatom

    end subroutine spread_atoms_on_supercell

    subroutine mod1(t)
      real(kind=DP), intent(inout) :: t
      real(kind=DP), parameter :: eps = 1.d-6
      t = mod(t,1.d0)
      if(t < -eps) t = t + 1.d0
      if(t > 1.d0 - eps) t = t - 1.d0
    end subroutine mod1
    
    subroutine print_atoms_supercell(nfout)
      integer, intent(in) :: nfout
      integer :: ia
      write(nfout,'("natm_super,natm2_super=",2i4)') natm,natm2
      write(nfout,'("ia,cps(3),pos(3),ityp")')
      do ia=1,natm
         write(nfout,'(i4,6(1x,f10.5),1x,i1)') ia,cps(ia,1:3),pos(ia,1:3),ityp(ia) 
      end do
    end subroutine print_atoms_supercell

  end subroutine m_IS_supercell

  subroutine m_IS_set_natm_prim
    natm = natm_prim
    natm2 = natm2_prim
    cps(1:natm,1:3) = cps_prim(1:natm,1:3)
    pos(1:natm,1:3) = pos_prim(1:natm,1:3)
    call m_IS_set_iatom(nfout) ! -> iatom
#ifndef _EMPIRICAL_
    call m_CtrlP_check_matm(nfout,natm)
#endif
  end subroutine m_IS_set_natm_prim

  subroutine m_IS_set_natm_super
    natm = natm_super
    natm2 = natm2_super
    cps(1:natm,1:3) = cps_super(1:natm,1:3)
    pos(1:natm,1:3) = pos_super(1:natm,1:3)
    call m_IS_set_iatom(nfout) ! -> iatom
#ifndef _EMPIRICAL_
    call m_CtrlP_check_matm(nfout,natm)
#endif
  end subroutine m_IS_set_natm_super

  subroutine m_IS_set_napt_prim
    if(.not.allocated(napt_prim)) return
! ========================= modified by K. Tagami ========= 0.1
!    deallocate(napt)
    if ( allocated( napt ) )  deallocate(napt)
! ======================================================== 0.1
    allocate(napt(natm_prim,nopr+af))
    napt = napt_prim
  end subroutine m_IS_set_napt_prim

  subroutine m_IS_set_napt_super
    integer :: ia
    if(.not.allocated(napt_prim)) then
       allocate(napt_prim(natm_prim,nopr+af))
       napt_prim=napt
    end if
    deallocate(napt)
    allocate(napt(natm_super,1))
    do ia=1,natm_super
       napt(ia,1) = ia
    end do
  end subroutine m_IS_set_napt_super

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

    integer :: i,n
    integer, dimension(natm2) :: imdtyp_wk, ityp_wk, if_pdos_wk, if_aldos_wk
    integer, dimension(natm2) :: ihubbard_wk, iproj_group_wk

! ========================== added by K. Tagami ================= 11.0
    integer, dimension(natm2) :: itab_spinorbit_addition_wk
! ================================================================ 11.0

    real(kind=DP), dimension(natm2,3) :: cps_wk,pos_wk
    real(kind=DP), dimension(natm2) :: ionic_mass_wk
    if(inversion_symmetry == ON) then
      if(printable) write(nfout,*) ' Inversion symmety will be OFF. (kimg=2)'
      call m_CS_set_inv_sym_off() ! -> inversion_symmetry = OFF
      cps_wk = cps(1:natm,1:3)
      pos_wk = pos(1:natm,1:3)
      imdtyp_wk = imdtyp(1:natm)
      ityp_wk = ityp(1:natm)
      if_pdos_wk = if_pdos(1:natm)
      if_aldos_wk = if_aldos(1:natm)
      ihubbard_wk = ihubbard(1:natm)

! ============================== added by K. Tagami ==================== 11.0
      itab_spinorbit_addition_wk = itab_spinorbit_addition(1:natm)
! ====================================================================== 11.0

      iproj_group_wk = iproj_group(1:natm)
      ionic_mass_wk = ionic_mass(1:natm)
      n = natm
      do i=1,natm
         if(iwei(i)==1) cycle
         n = n + 1
         cps_wk(n,1:3) = -cps(i,1:3)
         pos_wk(n,1:3) = -pos(i,1:3)
         imdtyp_wk(n) = imdtyp(i)
         ityp_wk(n) = ityp(i)
         if_pdos_wk(n) = if_pdos(i)
         if_aldos_wk(n) = if_aldos(i)
         ihubbard_wk(n) = ihubbard(i)

! =============================== added by K. Tagami =================== 11.0
         itab_spinorbit_addition_wk(n) = itab_spinorbit_addition(i)
! ====================================================================== 11.0

         iproj_group_wk(n) = iproj_group(i)
         ionic_mass_wk(n) = ionic_mass(i)
      end do
      deallocate(cps,pos,imdtyp,ityp,if_pdos,if_aldos,ihubbard,iproj_group,ionic_mass,iwei)
! ============================= added by K. Tagami ============ 11.0
      deallocate( itab_spinorbit_addition )
! ============================================================= 11.0

      natm = natm2
      allocate(cps(natm,3)); cps = cps_wk
      allocate(pos(natm,3)); pos = pos_wk
      allocate(imdtyp(natm)); imdtyp = imdtyp_wk
      allocate(ityp(natm)); ityp = ityp_wk
      allocate(if_pdos(natm)); if_pdos = if_pdos_wk
      allocate(if_aldos(natm)); if_aldos = if_aldos_wk
      allocate(ihubbard(natm)); ihubbard = ihubbard_wk

! =================================== added by K. Tagami ========== 11.0
      allocate(itab_spinorbit_addition(natm))
      itab_spinorbit_addition = itab_spinorbit_addition_wk
! ================================================================= 11.0

      allocate(iproj_group(natm)); iproj_group = iproj_group_wk
      allocate(ionic_mass(natm)); ionic_mass = ionic_mass_wk
      allocate(iwei(natm)); iwei = 1
    end if
  end subroutine m_IS_inv_sym_off

  subroutine m_IS_symmetrize_atom_pos(nfout)
#ifdef SX
!CDIR BEGIN NOVECTOR
#endif
    integer, intent(in) :: nfout

    real(kind=DP), dimension(natm2,3) :: cps_wk,cps_wk2
    real(kind=DP), dimension(natm,3) :: cpso,poso
    real(kind=DP), dimension(3,3) :: rltv_t
    real(kind=DP), dimension(3) :: p,di,dimin
    real(kind=DP) :: df,dfmin
    integer, dimension(natm2) :: ityp_wk
    integer :: i,n,ia,ja,iia
    cps_wk(1:natm,1:3)  = cps(1:natm,1:3)
    ityp_wk(1:natm) = ityp(1:natm)
    n = natm
    do i=1,natm
       if(iwei(i)==1) cycle
       n = n + 1
       cps_wk(n,1:3) = -cps(i,1:3)
       ityp_wk(n) = ityp(i)
    end do
    cps_wk2 = 0.d0
    do n=1,nopr
       do ia=1,natm2
          p = matmul(op(1:3,1:3,n),cps_wk(ia,1:3)) + tau(1:3,n,CARTS)
          iia = 0
          dfmin = 1.d10
          do ja=1,natm2
             if(ityp_wk(ia) /= ityp_wk(ja)) cycle
             di = matmul(transpose(rltv),(p - cps_wk(ja,1:3)))
             df = sum(abs(cos(di(1:3))-1.d0))
             if(df < dfmin) then
                iia = ja
                dfmin = df
                dimin = di/PAI2
             end if
          end do
          if(iia == 0) stop 'm_IS_symmetrize_atom_pos: error iia=0'
          p = p - matmul(altv,nint(dimin))
          cps_wk2(iia,1:3) = cps_wk2(iia,1:3) + p(1:3)
       end do
    end do
    cps_wk2 = cps_wk2/nopr

    cpso = cps
    poso = pos
    cps = cps_wk2(1:natm,1:3)
    rltv_t = transpose(rltv)/PAI2
    call change_of_coordinate_system(rltv_t,cps,natm,natm,pos) !-(b_I.S.) cps -> pos
    if(printable) then
       write(nfout,*) 'Atomic coordinates were symmetrized.'
       !!$write(nfout,'(20x,"Inputted Cartesian coordinate -> symmetrized Cartesian coordinate")')
       !!$do ia=1,natm
       !!$   write(nfout,'(i4,3f15.8," -> ",3f15.8)') ia,cpso(ia,1:3),cps(ia,1:3)
       !!$end do
       !!$write(nfout,'(20x,"Inputted internal coordinate  -> symmetrized internal coordinate")')
       !!$do ia=1,natm
       !!$   write(nfout,'(i4,3f15.8," -> ",3f15.8)') ia,poso(ia,1:3),pos(ia,1:3)
       !!$end do
       write(nfout,'(" === Symmetrized Cartesian coordinates and errors===")')
       do ia=1,natm
          write(nfout,'(i4,4f18.9)') ia,cps(ia,1:3),sqrt(sum((cps(ia,1:3)-cpso(ia,1:3))**2))
       end do
       write(nfout,'(" === Symmetrized internal coordinates ===")')
       do ia=1,natm
          write(nfout,'(i4,3f18.9)') ia,pos(ia,1:3)
       end do
    end if
#ifdef SX
!CDIR END
#endif
  end subroutine m_IS_symmetrize_atom_pos

  subroutine m_IS_force_af_symmetry(nfout)
#ifdef SX
!CDIR BEGIN NOVECTOR
#endif
    integer, intent(in) :: nfout

    real(kind=DP), dimension(natm2,3) :: cps_wk,cps_wk2
    real(kind=DP), dimension(natm,3) :: cpso,poso
    real(kind=DP), dimension(3,3) :: rltv_t
    real(kind=DP), dimension(3) :: p,di,dimin
    real(kind=DP) :: df,dfmin
    integer, dimension(natm2) :: ityp_wk,ityp_af
    integer :: i,n,ia,ja,iia
    cps_wk(1:natm,1:3)  = cps(1:natm,1:3)
    do i=1,natm
       ityp_af(i) = nint(iatomn(ityp(i)))
    end do
    n = natm
    do i=1,natm
       if(iwei(i)==1) cycle
       n = n + 1
       cps_wk(n,1:3) = -cps(i,1:3)
       ityp_af(n) = nint(iatomn(ityp(i)))
    end do
    cps_wk2 = 0.d0
    do ia=1,natm2
       p = matmul(op(1:3,1:3,nopr+af),cps_wk(ia,1:3)) + tau(1:3,nopr+af,CARTS)
       iia = 0
       dfmin = 1.d10
       do ja=1,natm2
          if(ityp_af(ia) /= ityp_af(ja)) cycle
          di = matmul(transpose(rltv),(p - cps_wk(ja,1:3)))
          df = sum(abs(cos(di(1:3))-1.d0))
          if(df < dfmin) then
             iia = ja
             dfmin = df
             dimin = di/PAI2
          end if
       end do
       if(iia == 0) stop 'm_IS_symmetrize_atom_pos: error iia=0'
       p = p - matmul(altv,nint(dimin))
       cps_wk2(iia,1:3) = cps_wk2(iia,1:3) + p(1:3)
       cps_wk(iia,1:3) = cps_wk2(iia,1:3)
    end do

    cpso = cps
    poso = pos
    cps = cps_wk2(1:natm,1:3)
    rltv_t = transpose(rltv)/PAI2
    call change_of_coordinate_system(rltv_t,cps,natm,natm,pos) !-(b_I.S.) cps -> pos
    if(printable.and.ipri>1) then
       write(nfout,*) 'Atomic coordinates were symmetrized.'
       !!$write(nfout,'(20x,"Inputted Cartesian coordinate -> symmetrized Cartesian coordinate")')
       !!$do ia=1,natm
       !!$   write(nfout,'(i4,3f15.8," -> ",3f15.8)') ia,cpso(ia,1:3),cps(ia,1:3)
       !!$end do
       !!$write(nfout,'(20x,"Inputted internal coordinate  -> symmetrized internal coordinate")')
       !!$do ia=1,natm
       !!$   write(nfout,'(i4,3f15.8," -> ",3f15.8)') ia,poso(ia,1:3),pos(ia,1:3)
       !!$end do
       write(nfout,'(" === Symmetrized Cartesian coordinates and errors===")')
       do ia=1,natm
          write(nfout,'(i4,7f18.9)') ia,cpso(ia,1:3),cps(ia,1:3),sqrt(sum((cps(ia,1:3)-cpso(ia,1:3))**2))
       end do
       write(nfout,'(" === Symmetrized internal coordinates ===")')
       do ia=1,natm
          write(nfout,'(i4,6f18.9)') ia,poso(ia,1:3),pos(ia,1:3)
       end do
    end if
#ifdef SX
!CDIR END
#endif
  end subroutine m_IS_force_af_symmetry

  subroutine m_IS_dealloc(neb_mode)
    logical, intent(in), optional :: neb_mode
    logical :: neb
    neb = .false.
    if(present(neb_mode)) neb = neb_mode
    if(allocated(napt)) deallocate(napt)
    if(allocated(napt_tl)) deallocate(napt_tl)
    if(allocated(fxyzew_l)) deallocate(fxyzew_l)

    if(allocated(zfm3_l)) deallocate(zfm3_l)
    
    if(.not.neb)then 
       call m_IS_dealloc_pos_and_v(nfout)
       call dealloc_species_vdw_work()
       call dealloc_speciesname()
       call m_IS_dealloc_iatomn_etc()

! == KT_add ============================== 2013/10/31
       if ( noncol ) call m_IS_dealloc_magmom_local
! ======================================= 2013/10/31

       call T_control_dealloc()

! ===================================== KT_add ================ 13.0B
       call dealloc_speciesname_vdw()
       call m_IS_dealloc_vdw()
! ============================================================= 13.0B

    endif
    call dealloc_supercell_symmetry()
  end subroutine m_IS_dealloc

  subroutine m_IS_vdwdf3(nfout)
    integer, intent(in) :: nfout
    real(kind=DP) :: esum
    integer       :: id_sname = -1
    integer       :: neibrd, alen(3)
    real(kind=DP), allocatable :: rxyz(:,:)    ! d(neibrd,3)
    real(kind=DP), allocatable :: rr(:)        ! d(neibrd)
    real(kind=DP), pointer, dimension(:,:) :: cps_fp
    integer,       pointer, dimension(:)   :: ityp_full ! d(natm2)
    integer :: nu,u,v
    real(kind=DP) :: rc2,r2
    integer, allocatable, dimension(:) :: nnei
    real(kind=DP), allocatable, dimension(:,:) :: rlist
    integer, allocatable, dimension(:,:) :: indlist
    real(kind=DP), allocatable, dimension(:,:,:) :: drs
    real(kind=DP), allocatable, dimension(:) :: ncs
    real(kind=DP), allocatable, dimension(:,:) :: dncs
    real(kind=DP), allocatable, dimension(:) :: dncsdr
    real(kind=DP), allocatable, dimension(:,:) :: forc
    real(kind=DP) :: c6,c8,fdamp6,fdamp8,r,r6,r8,dcdr6,dcdr8,dfdamp6,dfdamp8,ddr
    real(kind=DP), dimension(3) :: dc6,dc8,ftmp
    real(kind=DP), dimension(3) :: dr,tmpar1,tmpar2
    integer :: in,ielem,jelem,kelem,ia,iai,iaj,icount
    integer :: ia1,ia2,ia3,i3
    real(kind=DP) :: rab,rac,rbc,c9,cosa,cosb,cosc
    real(kind=DP),dimension(3) :: rabvec,racvec,rbcvec

    call tstatc0_begin('m_IS_vdwdf3 ',id_sname)
    call decide_rxyz_size(dftd3par%rcut_vdw,alen,neibrd) !-> alen, neibrd

    allocate(rxyz(neibrd,3))
    allocate(rr(neibrd))
    call substitute_rxyz(alen, neibrd, rxyz, rr)
    deallocate(rr)
    allocate(cps_fp(natm2,3))
    allocate(ityp_full(natm2))
    allocate(nnei(natm));nnei=0
    allocate(rlist(neibrd*natm,natm))
    allocate(indlist(neibrd*natm,natm))
    allocate(drs(neibrd*natm,natm,3));drs=0.d0
    cps_fp(1:natm,1:3) = pos(1:natm,1:3)
    ityp_full(1:natm)  = ityp(1:natm)
    call rplcps(cps_fp,ityp_full,1,natm2,natm,iwei)
    call cpspac ! -> cps_fp
    rc2 = dftd3par%rcut_vdw**2
    do nu = ista_atm, iend_atm ! MPI
       do in = 1, neibrd
          do ia=1,natm2
             if(in == 1 .and. ia == nu) cycle
             dr(1:3) = cps_fp(nu,1:3) - cps_fp(ia,1:3) - rxyz(in,1:3)
             r2 = dot_product(dr,dr)
             if(r2 > rc2) cycle
             nnei(nu) = nnei(nu)+1 
             rlist(nnei(nu),nu) = sqrt(r2)
             indlist(nnei(nu),nu) = ia
             drs(nnei(nu),nu,1:3) = dr(1:3)
          enddo
       enddo
    enddo
    allocate(ncs(natm));ncs=0
    allocate(dncs(natm,3));dncs=0.d0
    allocate(dncsdr(natm));dncsdr=0.d0
    allocate(forc(natm,3));forc=0.d0
    do ia=ista_atm,iend_atm
       call eval_nc_and_der(ia,nnei,rlist,indlist,drs,ncs(ia),tmpar2,dncsdr(ia))
       dncs(ia,1:3) = tmpar2(1:3)
    enddo
    if(npes>1) then
       call mpi_allreduce(MPI_IN_PLACE,ncs,natm,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
       call mpi_allreduce(MPI_IN_PLACE,dncs,natm*3,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
       call mpi_allreduce(MPI_IN_PLACE,dncsdr,natm,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
    endif
    if(iprivdw>1) then
       do ia=1,natm
          write(nfout,'(a,i8,a,d15.5)') '!** coordination number for atom ',ia,' : ',ncs(ia)
       enddo
    endif
    esum = 0.d0
    forc = 0.d0
    s_vdw = 0.0d0
    do iai = ista_atm, iend_atm ! MPI
       ielem = iatomn(ityp(iai))
       do ia=1,nnei(iai)
          iaj = indlist(ia,iai)
          jelem = iatomn(ityp(iaj))
          tmpar1(1:3) = dncs(iai,1:3)
          tmpar2(1:3) = dncs(iaj,1:3)
          call eval_c6_and_der(ielem,jelem,ncs(iai),ncs(iaj),tmpar1,tmpar2,dncsdr(iai),dncsdr(iaj),c6,dc6,dcdr6)
          call eval_c8_and_der(ielem,jelem,c6,dc6,dcdr6,c8,dc8,dcdr8)
          r = rlist(ia,iai)
          r6 = r**6
          r8 = r6*r*r
          call eval_fdamp_and_der(6,r,ielem,jelem,fdamp6,dfdamp6)
          call eval_fdamp_and_der(8,r,ielem,jelem,fdamp8,dfdamp8)
          !!fdamp6=1.d0;dfdamp6=0.d0;fdamp8=1.d0;dfdamp8=0.d0
          esum = esum + (fdamp6 * dftd3par%s6*c6/r6 &
          &           +  fdamp8 * dftd3par%s8*c8/r8)*iwei(iai)
          ftmp(1:3) = dftd3par%s6*((-6.d0/(r6*r))*(drs(ia,iai,1:3)/r)*c6*fdamp6 &
          &         + (1.d0/r6)*dc6(1:3)*fdamp6 &
          &         + (c6/r6)*dfdamp6*drs(ia,iai,1:3)/r)     &
          &         + dftd3par%s8*((-8.d0/(r8*r))*(drs(ia,iai,1:3)/r)*c8*fdamp8 &
          &         + (1.d0/r8)*dc8(1:3)*fdamp8 &
          &         + (c8/r8)*dfdamp8*drs(ia,iai,1:3)/r)
          ddr       = dftd3par%s6*((-6.d0/(r6*r))*c6*fdamp6 &
          &         + (1.d0/r6)*dcdr6*fdamp6 &
          &         + (c6/r6)*dfdamp6)  &
          &         + dftd3par%s8*((-8.d0/(r8*r))*c8*fdamp8 &
          &         + (1.d0/r8)*dcdr8*fdamp8 &
          &         + (c8/r8)*dfdamp8)
          forc(iai,1:3) = forc(iai,1:3) + ftmp(1:3)
          forc(iaj,1:3) = forc(iaj,1:3) - ftmp(1:3)
          do u=1,3
             do v=1,3
                s_vdw(u,v) = s_vdw(u,v) + ddr *drs(ia,iai,u) *drs(ia,iai,v)/r
             end do
          end do
       enddo
    enddo
    if(npes>1) then
       call mpi_allreduce(MPI_IN_PLACE,esum,1,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
       call mpi_allreduce(MPI_IN_PLACE,forc,3*natm,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
       call mpi_allreduce(MPI_IN_PLACE,s_vdw,9,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
    endif
    
    evdw = -esum*0.5d0
    fxyzvdw_l = forc*0.5d0
    s_vdw = s_vdw*0.5d0/ univol
    if(iprivdw>=2)then
       write(nfout,'(a,d15.5)') ' !** dftd3 energy ',evdw
       write(nfout,'(a)')       ' !** dftd3 forces'
       do ia=1,natm
          write(nfout,'(i8,3d15.5)') ia,fxyzvdw_l(ia,1:3)
       enddo
       write(nfout,'(a)')       ' !** dftd3 stress tensor'
       do u=1,3
          write(nfout,'(i8,3d15.5)') ia,s_vdw(u,1:3)
       enddo
    endif
    call flush(nfout)
    deallocate(rxyz)
    deallocate(drs)
    deallocate(cps_fp)
    deallocate(ityp_full)
    deallocate(nnei)
    deallocate(rlist) 
    deallocate(indlist) 
    deallocate(ncs) 
    deallocate(dncs)
    deallocate(forc)
    deallocate(dncsdr)
    call tstatc0_end(id_sname)

    contains

    subroutine eval_c6_and_der(ielem,jelem,c1,c2,dc1,dc2,dcr1,dcr2,resc6,dresc6,dresdrc6)
       integer, intent(in) :: ielem,jelem
       real(kind=DP),intent(in) :: c1,c2
       real(kind=DP),intent(in),dimension(3) :: dc1,dc2
       real(kind=DP),intent(in) :: dcr1,dcr2
       real(kind=DP),intent(out) :: resc6
       real(kind=DP),intent(out),dimension(3) :: dresc6
       real(kind=DP),intent(out) :: dresdrc6
       integer :: i,j
       real(kind=DP) :: w,z,c6,n1,n2,dtmp,dtmpr,dwr,dzr
       real(kind=DP), dimension(3) :: ddtmp,dw,dz
       real(kind=DP) :: eps=1.d-10
       z = 0.d0;w=0.d0;dw=0.d0;dz=0.d0;dwr=0.d0;dzr=0.d0
       do i=1,dftd3par%maxnc(ielem)
          do j=1,dftd3par%maxnc(jelem)
             c6 = dftd3par%c6ab(ielem,jelem,i,j)
             n1 = dftd3par%nc1(ielem,jelem,i,j)
             n2 = dftd3par%nc2(ielem,jelem,i,j)
             dtmp = exp(-dftd3par%k3*((c1-n1)**2+(c2-n2)**2))
             dtmpr =      dtmp*(-dftd3par%k3)*(2.d0*(c1-n1)*dcr1    +2.d0*(c2-n2)*dcr2)
             ddtmp(1:3) = dtmp*(-dftd3par%k3)*(2.d0*(c1-n1)*dc1(1:3)+2.d0*(c2-n2)*dc2(1:3))
             w = w+dtmp
             z = z+c6*dtmp
             dw = dw+ddtmp
             dz = dz+c6*ddtmp
             dwr = dwr+dtmpr
             dzr = dzr+c6*dtmpr
          enddo
       enddo
       if(w.gt.eps) then
          resc6 = z/w
          dresc6 = (-z/w**2)*dw+(1.d0/w)*dz
          dresdrc6 = (-z/w**2)*dwr+(1.d0/w)*dzr
       endif
    end subroutine eval_c6_and_der

    subroutine eval_c8_and_der(ielem,jelem,c6,dc6,dcdr6,c8,dc8,dcdr8)
       integer, intent(in) :: ielem,jelem
       real(kind=DP), intent(in) :: c6
       real(kind=DP), intent(in), dimension(3) :: dc6
       real(kind=DP), intent(in) :: dcdr6
       real(kind=DP), intent(out) :: c8
       real(kind=DP), intent(out), dimension(3) :: dc8
       real(kind=DP), intent(out) :: dcdr8
       real(kind=DP) :: res
       c8 = 3.d0*c6*dftd3par%r2r4(ielem)*dftd3par%r2r4(jelem)
       dc8 = 3.d0*dc6*dftd3par%r2r4(ielem)*dftd3par%r2r4(jelem)
       dcdr8 = 3.d0*dcdr6*dftd3par%r2r4(ielem)*dftd3par%r2r4(jelem)
    end subroutine eval_c8_and_der

    subroutine eval_nc_and_der(ia,nnei,rlist,indlist,drs,nca,dnca,dncadr)
       integer, intent(in) :: ia
       integer, dimension(natm) :: nnei
       real(kind=DP), intent(in), dimension(neibrd*natm,natm) :: rlist
       integer, intent(in), dimension(neibrd*natm,natm) :: indlist
       real(kind=DP), intent(in), dimension(neibrd*natm,natm,3) :: drs
       real(kind=DP), intent(out) :: nca
       real(kind=DP), intent(out), dimension(3) :: dnca
       real(kind=DP), intent(out) :: dncadr
       real(kind=DP) :: rab,racov,rbcov,dtmp,etmp,rtmp,rinv
       integer :: i,ielem,iaelem,itmp
       nca = 0.d0
       dnca = 0.d0
       dncadr = 0.d0
       iaelem = nint(iatomn(ityp(ia)))
       racov = dftd3par%covrad(iaelem)
       do i=1,nnei(ia)
          itmp = indlist(i,ia)
          if(itmp == ia) cycle
          ielem = nint(iatomn(ityp_full(itmp)))
          rbcov = dftd3par%covrad(ielem)
          rinv = 1.d0/rlist(i,ia)
          rtmp = (racov+rbcov)*rinv
          etmp = exp(-dftd3par%k1*(rtmp-1.d0))
          dtmp = 1.d0+etmp
          nca = nca+1.d0/dtmp
          dtmp = -(1.d0/dtmp**2)*etmp*dftd3par%k1*rtmp*rinv
          dnca(1:3) = dnca(1:3)+dtmp*drs(i,ia,1:3)*rinv
          dncadr = dncadr + dtmp
       enddo
    end subroutine eval_nc_and_der

    subroutine eval_fdamp_and_der(norder,r,ielem,jelem,fdamp,dfdamp)
       integer, intent(in) :: norder
       real(kind=DP), intent(in) :: r
       integer, intent(in) :: ielem,jelem
       real(kind=DP), intent(out) :: fdamp
       real(kind=DP), intent(out) :: dfdamp
       real(kind=DP) :: res,sr,alpha,srr0ab
       sr = dftd3par%sr6
       alpha = dftd3par%alpha6
       if(norder == 8) then
          sr = dftd3par%sr8
          alpha = dftd3par%alpha8
       endif
       srr0ab = sr*dftd3par%r0ab(ielem,jelem)
       fdamp  = 1.d0/(1.d0+6.d0*(r/srr0ab)**(-alpha))
       dfdamp = fdamp*fdamp*(6.d0*alpha/srr0ab**(-alpha))*r**(-alpha-1)
    end subroutine eval_fdamp_and_der

    subroutine cpspac
      real(kind=DP), dimension(3) :: catoms(3)
      integer                     :: i
      do i = 1, natm2
         catoms = cps_fp(i,1:3)
         catoms = catoms - nint(catoms)      !Packing
         cps_fp(i,1:3) = matmul(altv,catoms) !Change of coordinate system
      end do
    end subroutine cpspac

  end subroutine m_IS_vdwdf3

  subroutine m_IS_vdw(nfout)
! === Apply modifications for vdW function. by tkato 2012/06/14 ================
!   use m_Control_Parameters, only : rcut_vdw
    use m_Control_Parameters, only : vdw_method, vdw_radius, &
                                     vdw_scaling_factor, vdw_scaling_factor_r, vdw_damping_factor
    use m_Const_Parameters, only : VDW_WILLIAMS, VDW_GRIMME
! ==============================================================================
    integer, intent(in) :: nfout

    integer       :: nu,ia,in, u, v
    integer       :: it1,it2
    integer       :: neibrd,  alen(3)
    real(kind=DP) :: dr(3),r,r2,r6,r8,x,x7
    real(kind=DP) :: fx, gx, exp1, exp2, exp3
    real(kind=DP) :: c6, r0, fac, frc(3), esum, rc2
    integer,       allocatable :: ityp_vdw_full(:) ! d(natm2)
    real(kind=DP), allocatable :: rxyz(:,:)    ! d(neibrd,3)
    real(kind=DP), allocatable :: rr(:)        ! d(neibrd)
    real(kind=DP), allocatable :: cps_fp(:,:)  ! d(natm2,3)
    real(kind=DP), allocatable :: fxyzvdw_mpi(:,:) ! d(natm,3)

! ================================ KT_add ===================== 13.0B
    real(kind=DP), allocatable :: s_vdw_mpi(:,:) ! d(3,3)
! ============================================================= 13.0B

    integer       :: id_sname = -1
    call tstatc0_begin('m_IS_vdw ',id_sname)

! === Apply modifications for vdW function. by tkato 2012/06/14 ================
!   rc2 = rcut_vdw**2
    rc2 = vdw_radius**2
! ==============================================================================

! === Apply modifications for vdW function. by tkato 2012/06/14 ================
!   call decide_rxyz_size(rcut_vdw,alen,neibrd) !-> alen, neibrd
    call decide_rxyz_size(vdw_radius,alen,neibrd) !-> alen, neibrd
! ==============================================================================
    allocate(rxyz(neibrd,3))
    allocate(rr(neibrd))
    call substitute_rxyz(alen, neibrd, rxyz, rr)
    deallocate(rr)
    allocate(cps_fp(natm2,3))
    allocate(ityp_vdw_full(natm2))
    cps_fp(1:natm,1:3) = pos(1:natm,1:3)
    ityp_vdw_full(1:natm)  = ityp_vdw(1:natm)
    call rplcps(cps_fp,ityp_vdw_full,1,natm2,natm,iwei)
    call cpspac ! -> cps_fp

    evdw = 0.d0
    fxyzvdw_l = 0.d0
! ================================= KT_add ================== 13.0B
    s_vdw = 0.0d0
! =========================================================== 13.0B

    do nu = ista_atm, iend_atm ! MPI
       it1 = ityp_vdw(nu)
       esum = 0.d0
       do in = 1, neibrd
          do ia=1,natm2
             if(in == 1 .and. ia == nu) cycle
             it2 = ityp_vdw_full(ia)
             dr(1:3) = cps_fp(nu,1:3) - cps_fp(ia,1:3) - rxyz(in,1:3)
             r2 = dot_product(dr,dr) 
             if(r2 > rc2) cycle
! === Apply modifications for vdW function. by tkato 2012/06/14 ================
!            r  = sqrt(r2)
!            r6 = r2*r2*r2
!            r8 = r6*r2
!            r0 = rvdw(it1,it2)
!            x = r/r0
!            x7 = x**7.d0
!            exp1 = exp(-3.d0*x7)
!            exp2 = 1.d0-exp1
!            exp3 = exp2*exp2
!            fx = exp3*exp3
!            gx = 4.d0*7.d0*3.d0*x7*exp1/exp2
!            c6 = cvdw(it1,it2)
!            esum = esum + fx * c6 / r6 
!            fac = -c6*(gx-6.d0)*fx / r8
!            fxyzvdw_l(nu,1:3) = fxyzvdw_l(nu,1:3) + fac * dr(1:3)
! !!          write(nfout,*) 'nu,ia,it1,it2=',nu,ia,it1,it2
! !!          write(nfout,*) 'c6,r0=',c6,r0
! !!          write(nfout,*) 'x,fx,gx=',x,fx,gx
! !!          write(nfout,*) 'frc=', fac * dr(1:3)
! !!          write(nfout,*) 'dr=',dr(1:3)

             select case(vdw_method)
             case(VDW_WILLIAMS)
               r  = sqrt(r2)
               r6 = r2*r2*r2
               r8 = r6*r2
               r0 = rvdw(it1,it2)
               x = r/r0
               x7 = x**7.d0
               !exp1 = exp(-3.d0*x7)
               exp1 = exp(-vdw_damping_factor*x7)
               exp2 = 1.d0-exp1
               exp3 = exp2*exp2
               fx = exp3*exp3
               !gx = 4.d0*7.d0*3.d0*x7*exp1/exp2
               gx = 4.d0*7.d0*vdw_damping_factor*x7*exp1/exp2
               c6 = cvdw(it1,it2)
               esum = esum + fx * c6 / r6
               fac = -c6*(gx-6.d0)*fx / r8
               fxyzvdw_l(nu,1:3) = fxyzvdw_l(nu,1:3) + fac * dr(1:3)
  !!           write(nfout,*) 'nu,ia,it1,it2=',nu,ia,it1,it2
  !!           write(nfout,*) 'c6,r0=',c6,r0
  !!           write(nfout,*) 'x,fx,gx=',x,fx,gx
  !!           write(nfout,*) 'frc=', fac * dr(1:3)
  !!           write(nfout,*) 'dr=',dr(1:3)

             case(VDW_GRIMME)
               r  = sqrt(r2)
               r6 = r2*r2*r2
               r0 = rvdw(it1,it2)
               x = r/r0
               exp1 = exp(-vdw_damping_factor*(x-1.0d0))
               fx = 1.0d0 / (1.0d0 + exp1)
               gx = vdw_damping_factor*exp1*fx**2 / r0
               c6 = cvdw(it1,it2)
               esum = esum + (-vdw_scaling_factor) * fx * c6 / r6

! ============================== KT_mod ================================= 13.0B
!!               fac = +c6 * vdw_scaling_factor * (gx - 6.0d0*fx/r) / r6
!!               fxyzvdw_l(nu,1:3) = fxyzvdw_l(nu,1:3) + fac * dr(1:3)/r

               fac = +c6 * vdw_scaling_factor * (gx - 6.0d0*fx/r) / r6 /r
               fxyzvdw_l(nu,1:3) = fxyzvdw_l(nu,1:3) + fac * dr(1:3)
! ======================================================================= 13.0B

! =========================== KT_add ======================== 13.0B
               Do u=1, 3
                  Do v=1, 3
                     s_vdw(u,v) = s_vdw(u,v) +fac *dr(u) *dr(v)
                  End do
               End do
! ============================================================ 13.0B

             end select
! ==============================================================================
          end do
       end do
       evdw = evdw + iwei(nu) * esum
    end do
    evdw = 0.5d0*evdw

! ================================ KT_add ===================== 13.0B
!    s_vdw = s_vdw / 2.0d0 / univol
    s_vdw = s_vdw / 2.0d0 / univol            ! ASMS 2015/03/24
! ============================================================= 13.0B

    deallocate(rxyz)
    deallocate(cps_fp)
    deallocate(ityp_vdw_full)
    if(npes > 1) then
       call mpi_allreduce(evdw, esum, 1, mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
       evdw = esum
       allocate(fxyzvdw_mpi(natm,3))
       call mpi_allreduce(fxyzvdw_l, fxyzvdw_mpi, natm*3,mpi_double_precision,mpi_sum,mpi_comm_group,ierr)
       fxyzvdw_l = fxyzvdw_mpi
       deallocate(fxyzvdw_mpi)

! ================================ KT_add ========================== 13.0B
       allocate( s_vdw_mpi(3,3))
       call mpi_allreduce( s_vdw, s_vdw_mpi, 3*3, mpi_double_precision, &
            &              mpi_sum, mpi_comm_group, ierr )
       s_vdw = s_vdw_mpi
       deallocate( s_vdw_mpi )
! ================================================================== 13.0B
    end if

    !debug
    !write(nfout,'(" debug -- evdw --")')
    !write(nfout,'("evdw=",f16.8)') evdw
    !write(nfout,'(" debug -- fxyzvdw_l --")')
    !do i = 1, natm
    !   write(nfout,'(i5,3f16.8)') i,(fxyzvdw_l(i,j),j=1,3)
    !end do
    !!stop 'debug vdw'
    !end debug

    call tstatc0_end(id_sname)
  contains
    subroutine cpspac
      real(kind=DP), dimension(3) :: catoms(3)
      integer                     :: i
      do i = 1, natm2
         catoms = cps_fp(i,1:3)
         catoms = catoms - nint(catoms)      !Packing
         cps_fp(i,1:3) = matmul(altv,catoms) !Change of coordinate system
      end do
    end subroutine cpspac
  end subroutine m_IS_vdw

  subroutine check_region(nfout)
    integer, intent(in) :: nfout
    integer :: i,iat,iatt
    real(kind=DP) :: ratio = 1.5d0
    real(kind=DP) :: sigma,tmpr1,tmpr2
    logical :: too_close
    do i=1,num_regions
       sigma = regions(i)%sigma
       do iat=1,regions(i)%ntarget_atoms
          too_close=.false.
          iatt = regions(i)%target_atoms(iat)
          if(regions(i)%region_type == BOX)then
             if( sigma/dabs(regions(i)%xmin-cps(iatt,1))>ratio .or. &
               & sigma/dabs(regions(i)%xmax-cps(iatt,1))>ratio .or. &
               & sigma/dabs(regions(i)%ymin-cps(iatt,2))>ratio .or. &
               & sigma/dabs(regions(i)%ymax-cps(iatt,2))>ratio .or. &
               & sigma/dabs(regions(i)%zmin-cps(iatt,3))>ratio .or. &
               & sigma/dabs(regions(i)%zmax-cps(iatt,3))>ratio ) too_close = .true.
          else if (regions(i)%region_type == CYLINDER)then
             tmpr1 = dsqrt((cps(iatt,regions(i)%i1)-regions(i)%cylx)**2+(cps(iatt,regions(i)%i2)-regions(i)%cyly)**2)
             tmpr2 = sigma/(regions(i)%radius-tmpr1)
             if(tmpr2>ratio) too_close = .true.
          endif
          if(too_close.and.printable) &
         & write(nfout,'(a,i8,a,i5)') ' !** WARNING atom ',iat,' might be too close to region ',i
       enddo
    enddo
  end subroutine check_region

  subroutine m_IS_regions(nfout)
    integer, intent(in) :: nfout
    integer :: i,j,iat,iatt
    real(kind=DP) :: tmpf,tmpr1,tmpr2,tmpr6,tmpeps,tmps,tmpf1,tmpf2
    integer, allocatable, dimension(:) :: target_atms
    integer :: n_target_atms
    allocate(target_atms(natm));target_atms=0
    call check_region(nfout)
    do i=1,num_regions
       regions(i)%forc = 0.d0
       regions(i)%energy = 0.d0
       tmpeps = regions(i)%epsi
       tmps   = regions(i)%sigma**12
       target_atms=0
       n_target_atms=0
       do iatt=1,regions(i)%ntarget_atoms
          iat = regions(i)%target_atoms(iatt)
          if(regions(i)%region_type == BOX .and. &
          &  regions(i)%xmin<cps(iat,1) .and. regions(i)%xmax>cps(iat,1) .and. &
          &  regions(i)%ymin<cps(iat,2) .and. regions(i)%ymax>cps(iat,2) .and. &
          &  regions(i)%zmin<cps(iat,3) .and. regions(i)%zmax>cps(iat,3)) then
             n_target_atms = n_target_atms+1
             target_atms(n_target_atms) = iat
          endif
          if(regions(i)%region_type == CYLINDER .and. &
          &  regions(i)%cylzmin<cps(iat,regions(i)%i3) .and. regions(i)%cylzmax>cps(iat,regions(i)%i3) .and. &
          &  in_cylinder(cps(iat,:),regions(i))) then
             n_target_atms = n_target_atms+1
             target_atms(n_target_atms) = iat
          endif
       enddo
       write(nfout,'(a,i5)') ' !** number of target atoms : ',n_target_atms
       do j=1,n_target_atms
          iat = target_atms(j) 
          if(regions(i)%region_type == BOX) then
             if(cps(iat,1)>regions(i)%xmin .and. cps(iat,1)<regions(i)%xmax) then
                 tmpr1 = cps(iat,1)-regions(i)%xmin
                 tmpr2 = regions(i)%xmax-cps(iat,1)
                 tmpf = -12.d0*tmpeps*tmps*(-(1.d0/tmpr1)**13 + (1.d0/tmpr2)**13)
                 regions(i)%forc(iat,1) = regions(i)%forc(iat,1)+tmpf
                 regions(i)%energy = regions(i)%energy + tmpeps*tmps*(1.d0/tmpr1**12+1.d0/tmpr2**12)
             endif
             if(cps(iat,2)>regions(i)%ymin .and. cps(iat,2)<regions(i)%ymax) then
                 tmpr1 = cps(iat,2)-regions(i)%ymin
                 tmpr2 = regions(i)%ymax-cps(iat,2)
                 tmpf = -12.d0*tmpeps*tmps*(-(1.d0/tmpr1)**13 + (1.d0/tmpr2)**13)
                 regions(i)%forc(iat,2) = regions(i)%forc(iat,2)+tmpf
                 regions(i)%energy = regions(i)%energy + tmpeps*tmps*(1.d0/tmpr1**12+1.d0/tmpr2**12)
             endif
             if(cps(iat,3)>regions(i)%zmin .and. cps(iat,3)<regions(i)%zmax) then
                 tmpr1 = cps(iat,3)-regions(i)%zmin
                 tmpr2 = regions(i)%zmax-cps(iat,3)
                 tmpf = -12.d0*tmpeps*tmps*(-(1.d0/tmpr1)**13 + (1.d0/tmpr2)**13)
                 regions(i)%forc(iat,3) = regions(i)%forc(iat,3)+tmpf
                 regions(i)%energy = regions(i)%energy + tmpeps*tmps*(1.d0/tmpr1**12+1.d0/tmpr2**12)
             endif
          endif
          if(regions(i)%region_type == CYLINDER) then
             tmpr1 = dsqrt((cps(iat,regions(i)%i1)-regions(i)%cylx)**2+(cps(iat,regions(i)%i2)-regions(i)%cyly)**2)
             tmpr2 = regions(i)%radius-tmpr1
             tmpf1 = -(12.d0*tmpeps*tmps/tmpr2**13) * (cps(iat,regions(i)%i1)-regions(i)%cylx)/tmpr1
             tmpf2 = -(12.d0*tmpeps*tmps/tmpr2**13) * (cps(iat,regions(i)%i2)-regions(i)%cyly)/tmpr1
             regions(i)%forc(iat,regions(i)%i1) = regions(i)%forc(iat,regions(i)%i1) + tmpf1
             regions(i)%forc(iat,regions(i)%i2) = regions(i)%forc(iat,regions(i)%i2) + tmpf2
             regions(i)%energy = regions(i)%energy + tmpeps*tmps*(1.d0/tmpr2**12)
          endif
       enddo
    enddo
    if(printable.and.ipriforce>=2)then
       write(nfout,'(" -- force from regions --")')
       do i=1,num_regions
          do iatt = 1, regions(i)%ntarget_atoms
             iat = regions(i)%target_atoms(iatt)
             write(nfout,'(i5,3f16.8)') iat,(regions(i)%forc(iat,j),j=1,3)
          end do
       enddo
    endif
    if(printable)then
       do i=1,num_regions
          write(nfout,'(a,i5,a,f20.10)') ' energy from region ',i,' : ',regions(i)%energy
       enddo
    endif
  end subroutine m_IS_regions

  logical function in_cylinder(cps,region)
    real(kind=DP), dimension(3), intent(in) :: cps
    type(region_t), intent(in) :: region
    real(kind=DP) :: r2,rad2
    r2 = (region%cylx-cps(region%i1))**2+(region%cyly-cps(region%i2))**2
    rad2 = region%radius**2
    in_cylinder = r2<rad2
  end function in_cylinder


  subroutine m_IS_update_cps_history()
    cps_history(:,:,3) = cps_history(:,:,2)
    cps_history(:,:,2) = cps_history(:,:,1)
    cps_history(:,:,1) = cps(:,:)
    ncps_history = ncps_history+1
  end subroutine m_IS_update_cps_history

  subroutine m_IS_reset_extrpl_status()
    ncps_history = 0
    if(allocated(cps_history)) cps_history = 0.d0
  end subroutine m_IS_reset_extrpl_status

  logical function m_IS_is_extrpl_ready()
    m_IS_is_extrpl_ready = ncps_history>=3
  end function

  subroutine m_IS_get_extpl_factor(alpha,beta,rms,nextpl)
    real(kind=DP), intent(out) :: alpha,beta,rms
    integer, intent(out) :: nextpl
    integer :: iatm,ic,i
    real(kind=DP) :: p1,p2,p3,p4,p5,p6
    real(kind=DP),allocatable,dimension(:,:) :: cps_predicted
    alpha = 0.d0;beta = 0.d0;rms=-1.d0
    nextpl = ncps_history
    if(ncps_history<2) return
    allocate(cps_predicted(natm,3));cps_predicted=0.d0
    p1=0.d0;p2=0.d0;p3=0.d0;p4=0.d0;p5=0.d0
    do ic=1,3
       do iatm=1,natm
          p1 = p1 + (cps_history(iatm,ic,1)-cps_history(iatm,ic,2))**2
          p2 = p2 + (cps_history(iatm,ic,1)-cps_history(iatm,ic,2))*(cps_history(iatm,ic,2)-cps_history(iatm,ic,3))
          p3 = p3 + (cps_history(iatm,ic,2)-cps_history(iatm,ic,3))**2
          p4 = p4 + (cps_history(iatm,ic,1)-cps(iatm,ic))*(cps_history(iatm,ic,1)-cps_history(iatm,ic,2))
          p5 = p5 + (cps_history(iatm,ic,1)-cps(iatm,ic))*(cps_history(iatm,ic,2)-cps_history(iatm,ic,3))
       enddo
    enddo
    p6 = p2*p2-p1*p3
    if(dabs(p6)>1.d-12.and.ncps_history>2)then
       alpha = (p4*p3-p5*p2)/p6
       beta  = (p5*p1-p4*p2)/p6
    else if (dabs(p1)>1.d-12) then
       alpha = p4/p1
       beta = 0.d0
    endif

    if(printable.and.ipripredictor>=2) write(nfout,'(a,f15.10,a,f15.10)') &
      &  ' extrapolation factor : alpha = ',alpha,' beta = ',beta
    do ic=1,3
       do iatm=1,natm
          cps_predicted(iatm,ic) = cps_history(iatm,ic,1) &
       & + alpha*(cps_history(iatm,ic,1)-cps_history(iatm,ic,2)) &
       & + beta* (cps_history(iatm,ic,2)-cps_history(iatm,ic,3)) 
       enddo
    enddo

    rms = 0.d0
    do iatm=1,natm
       do ic=1,3
          rms = rms+(cps(iatm,ic)-cps_predicted(iatm,ic))**2
       enddo
       if(printable.and.ipripredictor>=2)then
          write(nfout,'(a,6f15.10)') 'cps, cps_predicted ',cps(iatm,1:3),cps_predicted(iatm,1:3)
       endif
    enddo
    rms = dsqrt(rms)/dble(natm)
    if(printable.and.ipripredictor>=2) write(nfout,'(a,f15.10)') 'average RMS : ',rms
    if(rms>rms_threshold) then
       if(printable.and.ipripredictor>=2) &
     & write(nfout,'(a,f13.10)') &
     & '!** WARN rms of the predicted coordinates is greater than the threshold : ',rms_threshold
    endif
    deallocate(cps_predicted)
  end subroutine m_IS_get_extpl_factor

  subroutine alloc_supercell_symmetry()
    if(.not.allocated(napt_supercell)) allocate(napt_supercell(natm,nopr_supercell))
    if(.not.allocated(iop_supercell)) allocate(iop_supercell(nopr_supercell))
!!$    allocate(tau_supercell(3,nopr_supercell))
!!$    allocate(nope_supercell(nopr))
!!$    allocate(pope_supercell(mnope_supercell,nopr))
  end subroutine alloc_supercell_symmetry

  subroutine dealloc_supercell_symmetry()
    deallocate(napt_supercell)
    deallocate(iop_supercell)
!!$    deallocate(tau_supercell)
!!$    deallocate(nope_supercell)
!!$    deallocate(pope_supercell)
  end subroutine dealloc_supercell_symmetry

  subroutine m_IS_gnrt_supercell_symmetry(paramset,nfout)
! =========== coded by T. Yamasaki after a provided code by Usami-san on Nov. 2013. April 2014 ===
    logical, intent(in) :: paramset
    integer, intent(in) :: nfout

    integer, allocatable, dimension(:,:) :: napt_local
    integer, allocatable, dimension(:)   :: iop_local
    real(kind=DP),allocatable,dimension(:,:) :: tau_local
    integer :: dim_supercell,dim2e
    integer, allocatable, dimension(:) ::   nope_local
    integer, allocatable, dimension(:,:) :: pope_local
    integer, parameter :: modeTAU = 1
    integer, parameter :: modeAPT = 2

    integer ::             id_sname = -1

    if(sw_supercell_symmetry == OFF) return
    call tstatc0_begin('m_IS_gnrt_supercell_symmetry ',id_sname)

    dim_supercell = natm*nopr*2
    dim2e = natm*2 
    allocate(napt_local(natm,dim_supercell))
    allocate(iop_local(dim_supercell))
    allocate(tau_local(3,dim_supercell))
    allocate(nope_local(nopr))
    allocate(pope_local(dim2e,nopr))
    call gnrt_supercell_symm_operations(natm2,natm,natm,napt,nopr,nopr,op &
         & ,nopr+af,tau,ngen_tl,tau_tl,napt_tl &
         & ,lattice_system_from_m_CS_SG,modeAPT &
         & ,dim_supercell, napt_local, iop_local, tau_local, nopr_supercell &
         & ,dim2e, nope_local, pope_local,iwei) 
    !                    -(b_Ionic_System) --> nopr_supercell

    if(.not.paramset) then
!!$       mnope_supercell = maxval(nope_local(1:nopr))
       call alloc_supercell_symmetry()
       napt_supercell(:,1:nopr_supercell) = napt_local(:,1:nopr_supercell)
       iop_supercell(1:nopr_supercell) = iop_local(1:nopr_supercell)
!!$       tau_supercell(:,1:nopr_supercell) = tau_local(:,1:nopr_supercell)
!!$       nope_supercell(1:nopr) = nope_local(1:nopr)
!!$       pope_supercell(1:mnope_supercell,1:nopr) = pope_local(1:mnope_supercell,1:nopr)
    end if

    if(ipriinputfile>=2) then
       if(nopr_supercell > nopr) then
          call wd_nopr_supercell_etc1()
          call wd_nopr_supercell_etc2()
       end if
    end if

    deallocate(tau_local)
    deallocate(iop_local)
    deallocate(napt_local)
    deallocate(nope_local)
    deallocate(pope_local)


    call tstatc0_end(id_sname)

    contains
      subroutine wd_nopr_supercell_etc1()
        integer :: iop, i, ic, j, k, iop_temp, ia

        write(nfout,*) ' --- Supercell Symmetry Operations ---'
        write(nfout,'(" !! nopr_supercell = ",i8)') nopr_supercell
        do iop = 1, nopr
           write(nfout,'(" #symmetry op. = ",i8," #elements in this op. = ",i8)')  iop, nope_local(iop)
           do i = 1, 3
              write(nfout,'(3f8.4)') (op(i,k,iop),k=1,3)
           end do
           ic = 0
           do j = 1, nopr_supercell
              if(iop_local(j) == iop) then
                 ic = ic+1
              end if
           end do
           write(nfout,'(" # operation",i3," = ",i8)') iop,ic
        end do
        write(nfout,'(" --- iop_supercell ---")')
        write(nfout,'(24i3)') (iop_supercell(j),j=1,nopr_supercell)

        if(ipri>=2) then
           do i = 1, nopr
              write(nfout,'(" -- tau_local for #op = ",i8)') i
              do iop = 1, nope_local(i)
                 iop_temp = pope_local(iop,i)
                 write(nfout,'(i3,x,": ",3f10.5)') iop,(tau_local(1:3,iop_temp))
              end do
           end do
           write(nfout,'(" nopr_supercell = ",i8)') nopr_supercell
           write(nfout,'(" -- iop_supercell, tau_local -- ")')
           do i = 1, nopr_supercell
              write(nfout,'(i8,2x,i8,2x,3f8.4)') i, iop_supercell(i),tau_local(1:3,i)
           end do
        end if
      end subroutine wd_nopr_supercell_etc1
!-----------------------------------------------------------------------------------
      subroutine wd_nopr_supercell_etc2()
        integer :: iop, i, ic, j, k, iop_temp, ia

        write(nfout,'(" -- napt_supercell --")')
        do iop = 1, nopr_supercell
           write(nfout,'(i4,x,": ",64i3)') iop,(napt_supercell(i,iop),i=1,natm)
        end do

        if(ipri>=2) then
           do i = 1, nopr
              do iop = 1, nope_local(i)
                 iop_temp = pope_local(iop,i)
                 write(nfout,'(i3," : ",32i3)') iop, (napt_supercell(ia,iop_temp),ia=1,min(32,natm))
              end do
           end do
        end if
      end subroutine wd_nopr_supercell_etc2
  end subroutine m_IS_gnrt_supercell_symmetry

!***************************** Note ************************************
! This program checks the distances of the atoms.
! The distances between atoms in the neighbor cells and those in the 
! main unit cell will also be checked. When the program finds the pair
! which distance are unnaturally small, ID Numbers of those atoms will
! be indicated.
! The density of the atoms in the unit cell will also be checked.
! The unit cell will be divided into several small blocks and the 
! density will be check in each of them. 
!
!                                   Written by Youky Ono in 2013/Jan
!***********************************************************************
  subroutine check_coor

  Implicit none
!+++++++++++++++++++++++++++++ VARIABLES +++++++++++++++++++++++++++++++
  Integer i,j,k,l,m,num,exnum
  Real(8) aM(3,3),exaM(3,3),exbM(3,3),blaM(3,3),blbM(3,3),detr,dist,min,min1
!  Parameter (min=0.1)
  Real(8), Allocatable  ::  &
&     abc(:,:),xyz(:,:),exxyz(:,:),blxyz(:,:,:,:,:)
  Integer, Allocatable :: bl_atom_num(:,:,:),exID(:),bl_atom_ID(:,:,:,:)

  Real(8) w,a,b,c,x,y,z
  Parameter (w=4.0)

  Real(8) abs_a,abs_b,abs_c,abs_cross,p,pa,pb,pc
  Real(8) dnM(3),d0M(3),daM(3),dbM(3),dcM(3),dM(3)

  Integer nbl_a,nbl_b,nbl_c,cbl_a,cbl_b,cbl_c
  Real(8) bw_a,bw_b,bw_c,bp,vol_bl,dens_bl,dens_max,pi,au,bond
!  Parameter (bp=10.0,pi=3.1415926535897932,au=0.5291772108,bond=0.9)
  Parameter (bp=10.0,bond=0.9)

! 'min' is a minimum limit of bond length. [in Bohr]
! 'w' is a width of the margin of the unit cell. [in Bohr]
! 'bp' is a width of the small cell devided from the unit cell. [in Bohr]
!+++++++++++++++++++++++++++ end VARIABLES +++++++++++++++++++++++++++++



!------------------------- Calculation Start ---------------------------
  au = BOHR
  pi = PAI
  min = bond_length_min
  min1 = 1.0d0

!  i = 0
!  open(16,FILE='coor',status='old')
!  Do
!    Read(16,'()',END=999)
!    i = i + 1
!  Enddo
!  999 close(16)
!  num = i - 3


!  Open(111,FILE='coor')
!  Allocate(abc(3,num))
!  Allocate(xyz(3,num))
!  Read(111,*) (aM(1,i),i=1,3)
!  Read(111,*) (aM(2,i),i=1,3)
!  Read(111,*) (aM(3,i),i=1,3)
!  Do i=1,num
!     Read(111,*) (abc(j,i),j=1,3)
!  End do
!  Close(111)

  num = natm

  Allocate(abc(3,num))
  Allocate(xyz(3,num))

  aM(1,:) = altv(:,1)
  aM(2,:) = altv(:,2)
  aM(3,:) = altv(:,3)
  
  do i=1,natm
     do j=1,3
        abc(j,i) = pos(i,j)
     enddo
  enddo

! STEP 1  :  Roll up all abc into a single unit cell.
  Do i=1,num
    Do j=1,3
      x = abc(j,i)
      abc(j,i) = (x-AINT(x)+1.0)-AINT(x-AINT(x)+1.0)
    Enddo
    a = abc(1,i)
    b = abc(2,i)
    c = abc(3,i)
    xyz(1,i) = (a*aM(1,1) + b*aM(2,1) + c*aM(3,1))
    xyz(2,i) = (a*aM(1,2) + b*aM(2,2) + c*aM(3,2))
    xyz(3,i) = (a*aM(1,3) + b*aM(2,3) + c*aM(3,3))
  Enddo


! STEP 2  :  Make the lattice vectors of the expanded unit cell.
  abs_a = SQRT(aM(1,1)**2.0 + aM(1,2)**2.0 + aM(1,3)**2.0)
  abs_b = SQRT(aM(2,1)**2.0 + aM(2,2)**2.0 + aM(2,3)**2.0)
  abs_c = SQRT(aM(3,1)**2.0 + aM(3,2)**2.0 + aM(3,3)**2.0)

  dnM(1) = aM(1,1)/abs_a + aM(2,1)/abs_b + aM(3,1)/abs_c 
  dnM(2) = aM(1,2)/abs_a + aM(2,2)/abs_b + aM(3,2)/abs_c 
  dnM(3) = aM(1,3)/abs_a + aM(2,3)/abs_b + aM(3,3)/abs_c 

  abs_cross = SQRT((aM(1,2)*dnM(3) - aM(1,3)*dnM(2))**2.0 +  &
&                  (aM(1,3)*dnM(1) - aM(1,1)*dnM(3))**2.0 +  &
&                  (aM(1,1)*dnM(2) - aM(1,2)*dnM(1))**2.0 )
  pa = w*abs_a/abs_cross

  abs_cross = SQRT((aM(2,2)*dnM(3) - aM(2,3)*dnM(2))**2.0 +  &
&                  (aM(2,3)*dnM(1) - aM(2,1)*dnM(3))**2.0 +  &
&                  (aM(2,1)*dnM(2) - aM(2,2)*dnM(1))**2.0 )
  pb = w*abs_b/abs_cross

  abs_cross = SQRT((aM(3,2)*dnM(3) - aM(3,3)*dnM(2))**2.0 +  &
&                  (aM(3,3)*dnM(1) - aM(3,1)*dnM(3))**2.0 +  &
&                  (aM(3,1)*dnM(2) - aM(3,2)*dnM(1))**2.0 )
  pc = w*abs_c/abs_cross

  p = MAX(pa,pb,pc)

  d0M(1) = p*dnM(1)
  d0M(2) = p*dnM(2)
  d0M(3) = p*dnM(3)

  dnM(1) =  aM(1,1)/abs_a - aM(2,1)/abs_b - aM(3,1)/abs_c 
  dnM(2) =  aM(1,2)/abs_a - aM(2,2)/abs_b - aM(3,2)/abs_c 
  dnM(3) =  aM(1,3)/abs_a - aM(2,3)/abs_b - aM(3,3)/abs_c 
  daM(1) =  p*dnM(1)
  daM(2) =  p*dnM(2)
  daM(3) =  p*dnM(3)

  dnM(1) = -aM(1,1)/abs_a + aM(2,1)/abs_b - aM(3,1)/abs_c 
  dnM(2) = -aM(1,2)/abs_a + aM(2,2)/abs_b - aM(3,2)/abs_c 
  dnM(3) = -aM(1,3)/abs_a + aM(2,3)/abs_b - aM(3,3)/abs_c 
  dbM(1) =  p*dnM(1)
  dbM(2) =  p*dnM(2)
  dbM(3) =  p*dnM(3)

  dnM(1) = -aM(1,1)/abs_a - aM(2,1)/abs_b + aM(3,1)/abs_c 
  dnM(2) = -aM(1,2)/abs_a - aM(2,2)/abs_b + aM(3,2)/abs_c 
  dnM(3) = -aM(1,3)/abs_a - aM(2,3)/abs_b + aM(3,3)/abs_c 
  dcM(1) =  p*dnM(1)
  dcM(2) =  p*dnM(2)
  dcM(3) =  p*dnM(3)

  exaM(1,1) =  d0M(1) + aM(1,1) + daM(1)
  exaM(1,2) =  d0M(2) + aM(1,2) + daM(2)
  exaM(1,3) =  d0M(3) + aM(1,3) + daM(3)
  exaM(2,1) =  d0M(1) + aM(2,1) + dbM(1)
  exaM(2,2) =  d0M(2) + aM(2,2) + dbM(2)
  exaM(2,3) =  d0M(3) + aM(2,3) + dbM(3)
  exaM(3,1) =  d0M(1) + aM(3,1) + dcM(1)
  exaM(3,2) =  d0M(2) + aM(3,2) + dcM(2)
  exaM(3,3) =  d0M(3) + aM(3,3) + dcM(3)


! STEP 3 : Expand the unit cell and paste extra atoms in the expanded unit cell.
  detr = (exaM(1,1)*exaM(2,2)*exaM(3,3)+exaM(1,2)*exaM(2,3)*exaM(3,1)+exaM(1,3)*exaM(2,1)*exaM(3,2)) &
&      - (exaM(1,1)*exaM(2,3)*exaM(3,2)+exaM(1,2)*exaM(2,1)*exaM(3,3)+exaM(1,3)*exaM(2,2)*exaM(3,1))

  exbM(1,1) =  (exaM(2,2)*exaM(3,3)-exaM(2,3)*exaM(3,2))/detr
  exbM(2,1) = -(exaM(2,1)*exaM(3,3)-exaM(2,3)*exaM(3,1))/detr
  exbM(3,1) =  (exaM(2,1)*exaM(3,2)-exaM(2,2)*exaM(3,1))/detr
  exbM(1,2) = -(exaM(1,2)*exaM(3,3)-exaM(1,3)*exaM(3,2))/detr
  exbM(2,2) =  (exaM(1,1)*exaM(3,3)-exaM(1,3)*exaM(3,1))/detr
  exbM(3,2) = -(exaM(1,1)*exaM(3,2)-exaM(1,2)*exaM(3,1))/detr
  exbM(1,3) =  (exaM(1,2)*exaM(2,3)-exaM(1,3)*exaM(2,2))/detr
  exbM(2,3) = -(exaM(1,1)*exaM(2,3)-exaM(1,3)*exaM(2,1))/detr
  exbM(3,3) =  (exaM(1,1)*exaM(2,2)-exaM(1,2)*exaM(2,1))/detr

  m = 0
  Do i = 1,num
    Do j = -1,1
    Do k = -1,1
    Do l = -1,1
      a = abc(1,i) + Real(j)
      b = abc(2,i) + Real(k)
      c = abc(3,i) + Real(l)
      x = d0M(1) + (a*aM(1,1) + b*aM(2,1) + c*aM(3,1))
      y = d0M(2) + (a*aM(1,2) + b*aM(2,2) + c*aM(3,2))
      z = d0M(3) + (a*aM(1,3) + b*aM(2,3) + c*aM(3,3))

      a = x*exbM(1,1) + y*exbM(2,1) + z*exbM(3,1)
      b = x*exbM(1,2) + y*exbM(2,2) + z*exbM(3,2)
      c = x*exbM(1,3) + y*exbM(2,3) + z*exbM(3,3)

      If(a.GE.0.AND.a.LE.1.AND.      &
&        b.GE.0.AND.b.LE.1.AND.      &
&        c.GE.0.AND.c.LE.1) Then
        m = m + 1
      Endif

    Enddo
    Enddo
    Enddo
  Enddo
  exnum = m

  Allocate(exxyz(3,exnum))
  Allocate(exID(exnum))

  m = 0
  Do i = 1,num
    Do j = -1,1
    Do k = -1,1
    Do l = -1,1
      a = abc(1,i) + Real(j)
      b = abc(2,i) + Real(k)
      c = abc(3,i) + Real(l)
      x = d0M(1) + (a*aM(1,1) + b*aM(2,1) + c*aM(3,1))
      y = d0M(2) + (a*aM(1,2) + b*aM(2,2) + c*aM(3,2))
      z = d0M(3) + (a*aM(1,3) + b*aM(2,3) + c*aM(3,3))

      a = x*exbM(1,1) + y*exbM(2,1) + z*exbM(3,1)
      b = x*exbM(1,2) + y*exbM(2,2) + z*exbM(3,2)
      c = x*exbM(1,3) + y*exbM(2,3) + z*exbM(3,3)

      If(a.GE.0.AND.a.LE.1.AND.      &
&        b.GE.0.AND.b.LE.1.AND.      &
&        c.GE.0.AND.c.LE.1) Then
        m = m + 1

        exxyz(1,m) = x - d0M(1)
        exxyz(2,m) = y - d0M(2)
        exxyz(3,m) = z - d0M(3)
        exID(m) = i
      Endif

    Enddo
    Enddo
    Enddo
  Enddo


! STEP 4 : Divide the extended unit cell into small blocks.
  nbl_a = 1 + AINT(abs_a/bp)
   bw_a = abs_a/Real(nbl_a)
  nbl_b = 1 + AINT(abs_b/bp)
   bw_b = abs_b/Real(nbl_b)
  nbl_c = 1 + AINT(abs_c/bp)
   bw_c = abs_c/Real(nbl_c)

  Allocate(blxyz(nbl_a,nbl_b,nbl_c,3,exnum))
  Allocate(bl_atom_num(nbl_a,nbl_b,nbl_c))
  Allocate(bl_atom_ID(nbl_a,nbl_b,nbl_c,exnum))
  blxyz = 0

  blaM(1,1) = d0M(1) + aM(1,1)/Real(nbl_a) + daM(1)
  blaM(1,2) = d0M(2) + aM(1,2)/Real(nbl_a) + daM(2)
  blaM(1,3) = d0M(3) + aM(1,3)/Real(nbl_a) + daM(3)
  blaM(2,1) = d0M(1) + aM(2,1)/Real(nbl_b) + dbM(1)
  blaM(2,2) = d0M(2) + aM(2,2)/Real(nbl_b) + dbM(2)
  blaM(2,3) = d0M(3) + aM(2,3)/Real(nbl_b) + dbM(3)
  blaM(3,1) = d0M(1) + aM(3,1)/Real(nbl_c) + dcM(1)
  blaM(3,2) = d0M(2) + aM(3,2)/Real(nbl_c) + dcM(2)
  blaM(3,3) = d0M(3) + aM(3,3)/Real(nbl_c) + dcM(3)

  dens_max = 1.0 / ((4.0/3.0) * pi * (bond/au)**3)
  vol_bl = blaM(1,1)*(blaM(2,2)*blaM(3,3)-blaM(2,3)*blaM(3,2)) &
&        + blaM(1,2)*(blaM(2,3)*blaM(3,1)-blaM(2,1)*blaM(3,3)) &
&        + blaM(1,3)*(blaM(2,1)*blaM(3,2)-blaM(2,2)*blaM(3,1))

  detr = (blaM(1,1)*blaM(2,2)*blaM(3,3)+blaM(1,2)*blaM(2,3)*blaM(3,1)+blaM(1,3)*blaM(2,1)*blaM(3,2)) &
&      - (blaM(1,1)*blaM(2,3)*blaM(3,2)+blaM(1,2)*blaM(2,1)*blaM(3,3)+blaM(1,3)*blaM(2,2)*blaM(3,1))

  blbM(1,1) =  (blaM(2,2)*blaM(3,3)-blaM(2,3)*blaM(3,2))/detr
  blbM(2,1) = -(blaM(2,1)*blaM(3,3)-blaM(2,3)*blaM(3,1))/detr
  blbM(3,1) =  (blaM(2,1)*blaM(3,2)-blaM(2,2)*blaM(3,1))/detr
  blbM(1,2) = -(blaM(1,2)*blaM(3,3)-blaM(1,3)*blaM(3,2))/detr
  blbM(2,2) =  (blaM(1,1)*blaM(3,3)-blaM(1,3)*blaM(3,1))/detr
  blbM(3,2) = -(blaM(1,1)*blaM(3,2)-blaM(1,2)*blaM(3,1))/detr
  blbM(1,3) =  (blaM(1,2)*blaM(2,3)-blaM(1,3)*blaM(2,2))/detr
  blbM(2,3) = -(blaM(1,1)*blaM(2,3)-blaM(1,3)*blaM(2,1))/detr
  blbM(3,3) =  (blaM(1,1)*blaM(2,2)-blaM(1,2)*blaM(2,1))/detr

  Do cbl_a = 1,nbl_a
  Do cbl_b = 1,nbl_b
  Do cbl_c = 1,nbl_c

    dM(1) = aM(1,1)*Real(cbl_a - 1)/Real(nbl_a) + &
&           aM(2,1)*Real(cbl_b - 1)/Real(nbl_b) + &
&           aM(3,1)*Real(cbl_c - 1)/Real(nbl_c) - d0M(1)
    dM(2) = aM(1,2)*Real(cbl_a - 1)/Real(nbl_a) + &
&           aM(2,2)*Real(cbl_b - 1)/Real(nbl_b) + &
&           aM(3,2)*Real(cbl_c - 1)/Real(nbl_c) - d0M(2)
    dM(3) = aM(1,3)*Real(cbl_a - 1)/Real(nbl_a) + &
&           aM(2,3)*Real(cbl_b - 1)/Real(nbl_b) + &
&           aM(3,3)*Real(cbl_c - 1)/Real(nbl_c) - d0M(3)

    m = 0
    Do i = 1,exnum
      x = exxyz(1,i) - dM(1)
      y = exxyz(2,i) - dM(2)
      z = exxyz(3,i) - dM(3)
      a = x*blbM(1,1) + y*blbM(2,1) + z*blbM(3,1)
      b = x*blbM(1,2) + y*blbM(2,2) + z*blbM(3,2)
      c = x*blbM(1,3) + y*blbM(2,3) + z*blbM(3,3)
      If(a.GE.0.AND.a.LE.1.AND.      &
&        b.GE.0.AND.b.LE.1.AND.      &
&        c.GE.0.AND.c.LE.1) Then
        m = m + 1
        blxyz(cbl_a,cbl_b,cbl_c,1,m) = x + dM(1)
        blxyz(cbl_a,cbl_b,cbl_c,2,m) = y + dM(2)
        blxyz(cbl_a,cbl_b,cbl_c,3,m) = z + dM(3)
        bl_atom_ID(cbl_a,cbl_b,cbl_c,m) = exID(i)
      Endif
    Enddo
    bl_atom_num(cbl_a,cbl_b,cbl_c) = m

    dens_bl = m / vol_bl

    If(dens_bl.GT.dens_max) Then
      if(printable) write(nfout,'(a,f20.10)') '### Warning(6101): Density is too large : ',dens_bl
    Endif

  Enddo
  Enddo
  Enddo


! STEP 5  : Check each distance between xyz(:,:) and blxyz(:,:,:,:,:)
  Do i = 1,num
    j = AINT(abc(1,i)*Real(nbl_a)) + 1
    k = AINT(abc(2,i)*Real(nbl_b)) + 1
    l = AINT(abc(3,i)*Real(nbl_c)) + 1

    Do m = 1,bl_atom_num(j,k,l)
       dist = SQRT(                                   &
&             (xyz(1,i) - (blxyz(j,k,l,1,m)) )**2.0 + &
&             (xyz(2,i) - (blxyz(j,k,l,2,m)) )**2.0 + &
&             (xyz(3,i) - (blxyz(j,k,l,3,m)) )**2.0   &
&                 )

      If(i.LT.bl_atom_ID(j,k,l,m).AND.dist.LT.min) Then
         if(printable) write(nfout,12) i,bl_atom_ID(j,k,l,m),dist
         stop
      Else if (i.LT.bl_atom_ID(j,k,l,m).and.dist.LT.min1) Then
         if(printable) write(nfout,13) i,bl_atom_ID(j,k,l,m),dist
      Endif
    Enddo
  Enddo

  deallocate(abc,xyz,exxyz,exID,blxyz,bl_atom_num,bl_atom_ID)

 12 Format('### ERROR(6102): Distance between the atom No.' ,I0 , ' and No.' ,I0 , ' is too small : ',f15.10,' bohr')
 13 Format('### WARNING(6102): Distance between the atom No.' ,I0 , ' and No.' ,I0 , ' is too small : ',f15.10,' bohr')


  end subroutine check_coor

  subroutine m_IS_dump_cif(nfdynm_cif,app)
     integer, intent(in) :: nfdynm_cif
     character(len=*), intent(in) :: app
     integer :: iat
     real(kind=DP),allocatable,dimension(:,:) :: cps_full,pos_full
     integer, allocatable,dimension(:) :: ityp_full
     real(kind=DP), dimension(3,3) :: rltv_t
     write(nfdynm_cif,'(a)')        "data_"//trim(adjustl(app))
     write(nfdynm_cif,'(a)')        "_symmetry_cell_setting triclinic"
     write(nfdynm_cif,'(a)')        "_symmetry_space_group_name_H-M  'P1'"
     write(nfdynm_cif,'(a)')        "_symmetry_Int_Tables_number  1"
     write(nfdynm_cif,'(a,f20.10)') "_cell_length_a   ",latconst_len(1)*BOHR
     write(nfdynm_cif,'(a,f20.10)') "_cell_length_b   ",latconst_len(2)*BOHR
     write(nfdynm_cif,'(a,f20.10)') "_cell_length_c   ",latconst_len(3)*BOHR
     write(nfdynm_cif,'(a,f20.10)') "_cell_angle_alpha",latconst_angle(1)
     write(nfdynm_cif,'(a,f20.10)') "_cell_angle_beta ",latconst_angle(2)
     write(nfdynm_cif,'(a,f20.10)') "_cell_angle_gamma",latconst_angle(3)
     write(nfdynm_cif,'(a,f20.10)') "_cell_volume     ",univol*BOHR*BOHR*BOHR
     write(nfdynm_cif,'(a)')        "loop_"
     write(nfdynm_cif,'(a)')        "    _atom_site_label"
     write(nfdynm_cif,'(a)')        "    _atom_site_fract_x"
     write(nfdynm_cif,'(a)')        "    _atom_site_fract_y"
     write(nfdynm_cif,'(a)')        "    _atom_site_fract_z"
     write(nfdynm_cif,'(a)')        "    _atom_site_type_symbol"
     write(nfdynm_cif,'(a)')        "    _atom_site_occupancy"

     allocate(pos_full(natm2,3))
     allocate(ityp_full(natm2))
     if(natm2>natm)then
        allocate(cps_full(natm2,3))
        call m_IS_pack_all_ions_in_uc(ityp_full,cps_full)
        rltv_t = transpose(rltv)/PAI2
        call change_of_coordinate_system(rltv_t,cps_full,natm2,natm2,pos_full)
     else
        pos_full(1:natm,1:3) = pos(1:natm,1:3)
        ityp_full(1:natm)  = ityp(1:natm)
     endif
     do iat=1,natm2
        write(nfdynm_cif,'(a5,3f20.10,a5,i3)') &
       & speciesname(ityp_full(iat)),pos_full(iat,1),pos_full(iat,2),pos_full(iat,3),speciesname(ityp_full(iat)),0
     enddo
     if(natm2>natm)then
        deallocate(cps_full)
     endif
     deallocate(ityp_full)
     deallocate(pos_full)
  end subroutine m_IS_dump_cif

  logical function absolute_convergence_of_forc(forc_l_in)
    real(kind=DP), intent(in), dimension(natm,3) :: forc_l_in
    real(kind=DP),allocatable,dimension(:,:) :: forct
    integer :: ia
    allocate(forct(natm,3));forct=forc_l_in
    absolute_convergence_of_forc = .false.
    do ia=1,natm
       if(imdtyp(ia)==0) forct(ia,:)=0.d0
    enddo
    if(sum(forct(1:natm,1:3)**2).lt.1e-15)then
        absolute_convergence_of_forc = .true.
    endif
    deallocate(forct)
  end function absolute_convergence_of_forc

end module m_Ionic_System
