admin
e62e536cee
- 新增 compute_accel_conservative / accel_conservative： 保守力加速度（弹簧+重力+原子间引力），不含阻尼，供蛙跳专用 - 重写 leapfrog_step / leapfrog_full： - 无阻尼：纯辛积分器，每步 1 次力计算（原 Velocity-Verlet 需 2 次） - 有阻尼：半隐式处理 v(t+dt/2)=[v(t-dt/2)*(1-α)+a_c*dt]/(1+α)，无条件稳定 - 主循环加初始化反向半步 v(-dt/2)=v(0)-0.5*a_c(0)*dt - 修复 C/C++ number of frames 字段写采样帧数而非总积分步数的 bug - Python 引擎：新增 display.npz 二进制格式，draw.py/plot_wave.py 优先读取 - 编译参数统一为 -O3 -march=native -ffast-math
1147 lines
46 KiB
Fortran
1147 lines
46 KiB
Fortran
! engines/fortran/main.f90
|
||
! ------------------------
|
||
! Fortran 动力学模拟引擎。
|
||
! 与 Python 版 (compute.py) 算法保持一致。
|
||
!
|
||
! 输入: param.json, <input_dir>/coord.txt, connection.txt, bond.txt
|
||
! 输出: <output_dir>/trajectory.txt (JSON)
|
||
!
|
||
! 编译: cmake --build build --target dynamics_f90
|
||
! 用法: ./build/dynamics_f90 <input_dir> <output_dir> <param_json>
|
||
|
||
program dynamics_f90
|
||
implicit none
|
||
|
||
character(len=256) :: input_dir, output_dir, param_path
|
||
integer :: narg, i, n, s
|
||
integer :: NT, NSTEP, warmup_steps, n_atoms, n_bonds
|
||
double precision :: DT, box_a
|
||
double precision :: G(3), B(3)
|
||
integer :: gravity_field, gravity_interaction, elastic_force, damping_force
|
||
integer :: driving_force
|
||
double precision :: gravity_strength
|
||
character(len=32) :: method
|
||
double precision :: t0, t1, elapsed, tw
|
||
|
||
! 原子数据
|
||
integer, allocatable :: atom_ids(:)
|
||
double precision, allocatable :: masses(:), radii(:)
|
||
double precision, allocatable :: pos_0(:, :), vel_0(:, :)
|
||
integer, allocatable :: fixed(:, :)
|
||
|
||
! 成键数据
|
||
integer, allocatable :: bond_pairs(:, :)
|
||
double precision, allocatable :: bond_stiffness(:), bond_rest_lengths(:)
|
||
|
||
! 驱动力数据
|
||
integer :: n_drivers, prog_step
|
||
integer, allocatable :: drv_atom_idx(:)
|
||
double precision, allocatable :: drv_amp_x(:), drv_amp_y(:), drv_amp_z(:)
|
||
double precision, allocatable :: drv_freq_x(:), drv_freq_y(:), drv_freq_z(:)
|
||
double precision, allocatable :: drv_phi_x(:), drv_phi_y(:), drv_phi_z(:)
|
||
integer, allocatable :: drv_has_period(:)
|
||
double precision, allocatable :: drv_period_cycles(:)
|
||
double precision, allocatable :: drv_freeze_x(:), drv_freeze_y(:), drv_freeze_z(:)
|
||
|
||
! 运行时位置/速度
|
||
double precision, allocatable :: x(:), y(:), z(:)
|
||
double precision, allocatable :: vx(:), vy(:), vz(:)
|
||
|
||
! 轨迹缓冲区
|
||
integer :: record_steps
|
||
double precision, allocatable :: traj_x(:, :), traj_y(:, :), traj_z(:, :)
|
||
double precision, allocatable :: traj_vx(:, :), traj_vy(:, :), traj_vz(:, :)
|
||
|
||
! ========================================================================
|
||
! 主流程
|
||
! ========================================================================
|
||
narg = command_argument_count()
|
||
if (narg < 3) then
|
||
write(*,*) "用法: dynamics_f90 <input_dir> <output_dir> <param_json>"
|
||
stop
|
||
end if
|
||
|
||
call get_command_argument(1, input_dir)
|
||
call get_command_argument(2, output_dir)
|
||
call get_command_argument(3, param_path)
|
||
|
||
call cpu_time(t0)
|
||
|
||
! 读取 param.json
|
||
call read_params(param_path, box_a, NT, DT, NSTEP, warmup_steps, method, G, B, &
|
||
gravity_field, gravity_interaction, &
|
||
elastic_force, damping_force, gravity_strength, driving_force)
|
||
|
||
! 读取 coord.txt
|
||
call read_coord(input_dir, n_atoms, atom_ids, masses, radii, pos_0, vel_0, fixed)
|
||
|
||
! 读取成键信息
|
||
call read_bonds(input_dir, n_atoms, atom_ids, pos_0, n_bonds, &
|
||
bond_pairs, bond_stiffness, bond_rest_lengths)
|
||
|
||
! 读取驱动力
|
||
n_drivers = 0
|
||
if (driving_force /= 0) then
|
||
call read_driver(input_dir, n_atoms, atom_ids, n_drivers, &
|
||
drv_atom_idx, drv_amp_x, drv_amp_y, drv_amp_z, &
|
||
drv_freq_x, drv_freq_y, drv_freq_z, &
|
||
drv_phi_x, drv_phi_y, drv_phi_z, &
|
||
drv_has_period, drv_period_cycles, &
|
||
drv_freeze_x, drv_freeze_y, drv_freeze_z)
|
||
end if
|
||
|
||
write(*, '("[Fortran-engine] 原子数=", i0, ", 键数=", i0, &
|
||
&", NT=", i0, ", DT=", f0.6, ", method=", a)') &
|
||
n_atoms, n_bonds, NT, DT, trim(method)
|
||
|
||
! 初始化位置/速度
|
||
n = n_atoms
|
||
allocate(x(n), y(n), z(n), vx(n), vy(n), vz(n))
|
||
do i = 1, n
|
||
x(i) = pos_0(i, 1); y(i) = pos_0(i, 2); z(i) = pos_0(i, 3)
|
||
vx(i) = vel_0(i, 1); vy(i) = vel_0(i, 2); vz(i) = vel_0(i, 3)
|
||
end do
|
||
|
||
! 分配轨迹缓冲区
|
||
record_steps = NT - warmup_steps
|
||
allocate(traj_x(record_steps, n), traj_y(record_steps, n), traj_z(record_steps, n))
|
||
allocate(traj_vx(record_steps, n), traj_vy(record_steps, n), traj_vz(record_steps, n))
|
||
|
||
! 真蛙跳初始化：v(0) 反推 v(-dt/2) = v(0) - 0.5*a_c(0)*dt
|
||
if (trim(method) == 'leapfrog') then
|
||
block
|
||
double precision :: ax0(n), ay0(n), az0(n)
|
||
integer :: ii
|
||
call accel_conservative(n, x, y, z, masses, G, &
|
||
n_bonds, bond_pairs, bond_stiffness, bond_rest_lengths, &
|
||
gravity_field, gravity_interaction, &
|
||
elastic_force, gravity_strength, ax0, ay0, az0)
|
||
do ii = 1, n
|
||
if (fixed(ii,1) /= 0 .and. fixed(ii,2) /= 0 .and. fixed(ii,3) /= 0) cycle
|
||
vx(ii) = vx(ii) - 0.5d0 * ax0(ii) * DT
|
||
vy(ii) = vy(ii) - 0.5d0 * ay0(ii) * DT
|
||
vz(ii) = vz(ii) - 0.5d0 * az0(ii) * DT
|
||
end do
|
||
end block
|
||
end if
|
||
|
||
! 预热
|
||
! 初始时刻 t=0 驱动力（与 Python run_simulation 一致）
|
||
if (driving_force /= 0 .and. n_drivers > 0) then
|
||
call apply_driving(n, x, y, z, vx, vy, vz, 0.0d0, 0, DT, &
|
||
n_drivers, drv_atom_idx, &
|
||
drv_amp_x, drv_amp_y, drv_amp_z, &
|
||
drv_freq_x, drv_freq_y, drv_freq_z, &
|
||
drv_phi_x, drv_phi_y, drv_phi_z, &
|
||
drv_has_period, drv_period_cycles, &
|
||
drv_freeze_x, drv_freeze_y, drv_freeze_z)
|
||
end if
|
||
|
||
do s = 1, warmup_steps
|
||
if (driving_force /= 0 .and. n_drivers > 0) then
|
||
tw = (s * 1.0d0) * DT
|
||
call apply_driving(n, x, y, z, vx, vy, vz, tw, s-1, DT, &
|
||
n_drivers, drv_atom_idx, &
|
||
drv_amp_x, drv_amp_y, drv_amp_z, &
|
||
drv_freq_x, drv_freq_y, drv_freq_z, &
|
||
drv_phi_x, drv_phi_y, drv_phi_z, &
|
||
drv_has_period, drv_period_cycles, &
|
||
drv_freeze_x, drv_freeze_y, drv_freeze_z)
|
||
end if
|
||
call apply_step(method, n, x, y, z, vx, vy, vz, masses, G, B, &
|
||
n_bonds, bond_pairs, bond_stiffness, bond_rest_lengths, &
|
||
fixed, box_a, DT, &
|
||
gravity_field, gravity_interaction, &
|
||
elastic_force, damping_force, gravity_strength, &
|
||
pos_0)
|
||
end do
|
||
|
||
! 记录
|
||
prog_step = record_steps / 100
|
||
if (prog_step < 1) prog_step = 1
|
||
do s = 1, record_steps
|
||
if (mod(s, prog_step) == 0 .and. s > 0) then
|
||
write(*, '("[Fortran-engine] progress: ", i0, "/", i0)') s, record_steps
|
||
end if
|
||
if (driving_force /= 0 .and. n_drivers > 0) then
|
||
tw = ((s-1 + warmup_steps) * 1.0d0) * DT
|
||
call apply_driving(n, x, y, z, vx, vy, vz, tw, s-1, DT, &
|
||
n_drivers, drv_atom_idx, &
|
||
drv_amp_x, drv_amp_y, drv_amp_z, &
|
||
drv_freq_x, drv_freq_y, drv_freq_z, &
|
||
drv_phi_x, drv_phi_y, drv_phi_z, &
|
||
drv_has_period, drv_period_cycles, &
|
||
drv_freeze_x, drv_freeze_y, drv_freeze_z)
|
||
end if
|
||
traj_x(s, :) = x; traj_y(s, :) = y; traj_z(s, :) = z
|
||
traj_vx(s, :) = vx; traj_vy(s, :) = vy; traj_vz(s, :) = vz
|
||
call apply_step(method, n, x, y, z, vx, vy, vz, masses, G, B, &
|
||
n_bonds, bond_pairs, bond_stiffness, bond_rest_lengths, &
|
||
fixed, box_a, DT, &
|
||
gravity_field, gravity_interaction, &
|
||
elastic_force, damping_force, gravity_strength, &
|
||
pos_0)
|
||
end do
|
||
|
||
! 输出轨迹
|
||
write(*, '("[Fortran-engine] 正在写入轨迹数据…")')
|
||
call write_json(output_dir, traj_x, traj_y, traj_z, traj_vx, traj_vy, traj_vz, &
|
||
record_steps, n_atoms, atom_ids, masses, &
|
||
NT, DT, NSTEP, warmup_steps, method, G, B, &
|
||
n_bonds, bond_pairs, bond_stiffness, bond_rest_lengths, &
|
||
driving_force)
|
||
|
||
call cpu_time(t1)
|
||
elapsed = t1 - t0
|
||
write(*, '("[Fortran-engine] 计算完成: ", i0, " 步, ", f0.6, " s")') record_steps, elapsed
|
||
|
||
deallocate(x, y, z, vx, vy, vz)
|
||
deallocate(traj_x, traj_y, traj_z, traj_vx, traj_vy, traj_vz)
|
||
deallocate(atom_ids, masses, radii, pos_0, vel_0, fixed)
|
||
if (allocated(bond_pairs)) deallocate(bond_pairs, bond_stiffness, bond_rest_lengths)
|
||
if (allocated(drv_atom_idx)) then
|
||
deallocate(drv_atom_idx)
|
||
deallocate(drv_amp_x, drv_amp_y, drv_amp_z)
|
||
deallocate(drv_freq_x, drv_freq_y, drv_freq_z)
|
||
deallocate(drv_phi_x, drv_phi_y, drv_phi_z)
|
||
deallocate(drv_has_period, drv_period_cycles)
|
||
deallocate(drv_freeze_x, drv_freeze_y, drv_freeze_z)
|
||
end if
|
||
|
||
contains
|
||
|
||
! ========================================================================
|
||
! 读取 param.json
|
||
! ========================================================================
|
||
subroutine read_params(path, box_a, NT, DT, NSTEP, warmup_steps, method, G, B, &
|
||
gravity_field, gravity_interaction, &
|
||
elastic_force, damping_force, gravity_strength, driving_force)
|
||
character(len=*), intent(in) :: path
|
||
double precision, intent(out) :: box_a, DT, G(3), B(3), gravity_strength
|
||
integer, intent(out) :: NT, NSTEP, warmup_steps
|
||
integer, intent(out) :: gravity_field, gravity_interaction, elastic_force, damping_force, driving_force
|
||
character(len=*), intent(out) :: method
|
||
character(len=8096) :: buf
|
||
character(len=256) :: line
|
||
integer :: u, ios
|
||
|
||
box_a = 10.0d0; NT = 10000; DT = 0.001d0; NSTEP = 100; warmup_steps = 0
|
||
method = 'leapfrog'
|
||
G = (/ 0.0d0, 0.0d0, -9.8d0 /); B = 0.0d0
|
||
gravity_field = 1; gravity_interaction = 0
|
||
elastic_force = 1; damping_force = 0; gravity_strength = 1.0d0
|
||
driving_force = 0
|
||
|
||
open(newunit=u, file=trim(path), status='old', action='read', iostat=ios)
|
||
if (ios /= 0) then
|
||
write(*, '("[Fortran-engine] 警告: 无法打开 ", a, ", 使用默认值")') trim(path)
|
||
return
|
||
end if
|
||
buf = ''
|
||
do
|
||
read(u, '(a)', iostat=ios) line
|
||
if (ios /= 0) exit
|
||
buf = trim(buf) // trim(line) // char(10)
|
||
end do
|
||
close(u)
|
||
if (ios > 0) return
|
||
|
||
box_a = json_get_double(buf, 'box_a', box_a)
|
||
NT = json_get_int(buf, 'NT', NT)
|
||
DT = json_get_double(buf, 'DT', DT)
|
||
NSTEP = json_get_int(buf, 'NSTEP', NSTEP)
|
||
warmup_steps = json_get_int(buf, 'warmup_steps', warmup_steps)
|
||
call json_get_string(buf, 'method', method)
|
||
if (len_trim(method) == 0) method = 'leapfrog'
|
||
call json_get_double3(buf, 'G', G)
|
||
call json_get_double3(buf, 'B', B)
|
||
gravity_field = json_get_int(buf, 'gravity_field', 1)
|
||
gravity_interaction = json_get_int(buf, 'gravity_interaction', 0)
|
||
elastic_force = json_get_int(buf, 'elastic_force', 1)
|
||
damping_force = json_get_int(buf, 'damping_force', 0)
|
||
gravity_strength = json_get_double(buf, 'gravity_strength', 1.0d0)
|
||
driving_force = json_get_int(buf, 'driving_force', 0)
|
||
end subroutine read_params
|
||
|
||
! ========================================================================
|
||
! JSON 辅助解析
|
||
! ========================================================================
|
||
function json_get_double(buf, key, default) result(val)
|
||
character(len=*), intent(in) :: buf, key
|
||
double precision, intent(in) :: default
|
||
double precision :: val
|
||
integer :: p, ios
|
||
val = default
|
||
p = index(buf, '"' // key // '"')
|
||
if (p == 0) return
|
||
p = index(buf(p:), ':') + p
|
||
do while (p <= len(buf) .and. (buf(p:p) == ':' .or. buf(p:p) == ' ' &
|
||
.or. buf(p:p) == char(9) .or. buf(p:p) == char(10)))
|
||
p = p + 1
|
||
end do
|
||
read(buf(p:), *, iostat=ios) val
|
||
end function json_get_double
|
||
|
||
function json_get_int(buf, key, default) result(val)
|
||
character(len=*), intent(in) :: buf, key
|
||
integer, intent(in) :: default
|
||
integer :: val
|
||
val = nint(json_get_double(buf, key, dble(default)))
|
||
end function json_get_int
|
||
|
||
subroutine json_get_double3(buf, key, vals)
|
||
character(len=*), intent(in) :: buf, key
|
||
double precision, intent(out) :: vals(3)
|
||
integer :: p, i, ios
|
||
vals = 0.0d0
|
||
p = index(buf, '"' // key // '"')
|
||
if (p == 0) return
|
||
p = index(buf(p:), '[') + p
|
||
do i = 1, 3
|
||
do while (buf(p:p) == ' ' .or. buf(p:p) == ',' .or. &
|
||
buf(p:p) == char(9) .or. buf(p:p) == char(10))
|
||
p = p + 1
|
||
end do
|
||
read(buf(p:), *, iostat=ios) vals(i)
|
||
if (ios /= 0) exit
|
||
do while (p <= len(buf) .and. buf(p:p) /= ',' .and. buf(p:p) /= ']')
|
||
p = p + 1
|
||
end do
|
||
end do
|
||
end subroutine json_get_double3
|
||
|
||
! 从 JSON 中读取字符串值
|
||
subroutine json_get_string(buf, key, val)
|
||
character(len=*), intent(in) :: buf, key
|
||
character(len=*), intent(out) :: val
|
||
integer :: p, i, j
|
||
val = ''
|
||
p = index(buf, '"' // key // '"')
|
||
if (p == 0) return
|
||
p = index(buf(p:), ':') + p
|
||
do while (p <= len(buf) .and. (buf(p:p) == ':' .or. buf(p:p) == ' ' &
|
||
.or. buf(p:p) == char(9) .or. buf(p:p) == char(10)))
|
||
p = p + 1
|
||
end do
|
||
if (buf(p:p) /= '"') return
|
||
p = p + 1
|
||
i = 1
|
||
do while (p <= len(buf) .and. buf(p:p) /= '"' .and. i <= len(val))
|
||
val(i:i) = buf(p:p)
|
||
i = i + 1; p = p + 1
|
||
end do
|
||
end subroutine json_get_string
|
||
|
||
! ========================================================================
|
||
! 读取 coord.txt
|
||
! ========================================================================
|
||
subroutine read_coord(input_dir, n_atoms, atom_ids, masses, radii, pos_0, vel_0, fixed)
|
||
character(len=*), intent(in) :: input_dir
|
||
integer, intent(out) :: n_atoms
|
||
integer, allocatable, intent(out) :: atom_ids(:)
|
||
double precision, allocatable, intent(out) :: masses(:), radii(:)
|
||
double precision, allocatable, intent(out) :: pos_0(:, :), vel_0(:, :)
|
||
integer, allocatable, intent(out) :: fixed(:, :)
|
||
|
||
character(len=512) :: path, line
|
||
integer :: u, ios, ncols, n_cap, id, fx, fy, fz, i
|
||
double precision :: mass, rad, px, py, pz, vx, vy, vz
|
||
integer, parameter :: MX = 4096
|
||
integer :: ids_tmp(MX), fix_tmp(MX, 3)
|
||
double precision :: m_tmp(MX), r_tmp(MX), p_tmp(MX, 3), v_tmp(MX, 3)
|
||
|
||
n_atoms = 0
|
||
path = trim(input_dir) // '/coord.txt'
|
||
open(newunit=u, file=trim(path), status='old', action='read', iostat=ios)
|
||
if (ios /= 0) then; write(*, '("[Fortran-engine] 错误: 无法打开 ", a)') trim(path); stop; end if
|
||
|
||
read(u, '(a)', iostat=ios) line
|
||
ncols = 0
|
||
do i = 1, len_trim(line)
|
||
if (line(i:i) /= ' ') then
|
||
if (i == 1) then
|
||
ncols = ncols + 1
|
||
else if (line(i-1:i-1) == ' ') then
|
||
ncols = ncols + 1
|
||
end if
|
||
end if
|
||
end do
|
||
|
||
do
|
||
read(u, '(a)', iostat=ios) line
|
||
if (ios /= 0) exit
|
||
if (len_trim(line) == 0 .or. line(1:1) == '#') cycle
|
||
n_atoms = n_atoms + 1
|
||
if (n_atoms > MX) exit
|
||
if (ncols >= 12) then
|
||
read(line, *) id, mass, rad, px, py, pz, vx, vy, vz, fx, fy, fz
|
||
else
|
||
read(line, *) id, mass, rad, px, py, pz, vx, vy, vz
|
||
fx = 0; fy = 0; fz = 0
|
||
end if
|
||
ids_tmp(n_atoms) = id
|
||
m_tmp(n_atoms) = mass; r_tmp(n_atoms) = rad
|
||
p_tmp(n_atoms, :) = (/ px, py, pz /)
|
||
v_tmp(n_atoms, :) = (/ vx, vy, vz /)
|
||
fix_tmp(n_atoms, :) = (/ fx, fy, fz /)
|
||
end do
|
||
close(u)
|
||
if (n_atoms <= 0) then; write(*, '("[Fortran-engine] 错误: coord.txt 为空")') ; stop; end if
|
||
|
||
allocate(atom_ids(n_atoms), masses(n_atoms), radii(n_atoms))
|
||
allocate(pos_0(n_atoms, 3), vel_0(n_atoms, 3), fixed(n_atoms, 3))
|
||
atom_ids = ids_tmp(1:n_atoms)
|
||
masses = m_tmp(1:n_atoms); radii = r_tmp(1:n_atoms)
|
||
pos_0 = p_tmp(1:n_atoms, :); vel_0 = v_tmp(1:n_atoms, :)
|
||
fixed = fix_tmp(1:n_atoms, :)
|
||
end subroutine read_coord
|
||
|
||
! ========================================================================
|
||
! 读取成键信息 (connection.txt + bond.txt)
|
||
! ========================================================================
|
||
subroutine read_bonds(input_dir, n_atoms, atom_ids, pos_0, n_bonds, &
|
||
bond_pairs, bond_stiffness, bond_rest_lengths)
|
||
character(len=*), intent(in) :: input_dir
|
||
integer, intent(in) :: n_atoms, atom_ids(n_atoms)
|
||
double precision, intent(in) :: pos_0(n_atoms, 3)
|
||
integer, intent(out) :: n_bonds
|
||
integer, allocatable, intent(out) :: bond_pairs(:, :)
|
||
double precision, allocatable, intent(out) :: bond_stiffness(:), bond_rest_lengths(:)
|
||
|
||
character(len=512) :: conn_path
|
||
integer :: u, ios, a1, a2, idx1, idx2, i
|
||
integer, parameter :: MX = 4096
|
||
integer :: ptmp(MX, 2), idx_map(9999)
|
||
double precision :: ktmp(MX), r0tmp(MX), dx, dy, dz
|
||
character(len=64) :: name
|
||
|
||
n_bonds = 0; idx_map = -1
|
||
do i = 1, n_atoms
|
||
if (atom_ids(i) > 0 .and. atom_ids(i) <= 9998) idx_map(atom_ids(i)) = i
|
||
end do
|
||
|
||
conn_path = trim(input_dir) // '/connection.txt'
|
||
open(newunit=u, file=trim(conn_path), status='old', action='read', iostat=ios)
|
||
if (ios /= 0) return
|
||
|
||
read(u, *, iostat=ios)
|
||
do
|
||
read(u, *, iostat=ios) a1, a2, name
|
||
if (ios /= 0) exit
|
||
call find_bond(trim(input_dir), trim(name), ktmp(n_bonds+1), r0tmp(n_bonds+1))
|
||
idx1 = idx_map(a1); idx2 = idx_map(a2)
|
||
if (idx1 < 1 .or. idx2 < 1) cycle
|
||
if (r0tmp(n_bonds+1) <= 0.0d0) then
|
||
dx = pos_0(idx2, 1) - pos_0(idx1, 1)
|
||
dy = pos_0(idx2, 2) - pos_0(idx1, 2)
|
||
dz = pos_0(idx2, 3) - pos_0(idx1, 3)
|
||
r0tmp(n_bonds+1) = sqrt(dx*dx + dy*dy + dz*dz)
|
||
end if
|
||
n_bonds = n_bonds + 1
|
||
ptmp(n_bonds, :) = (/ idx1 - 1, idx2 - 1 /)
|
||
if (n_bonds >= MX) exit
|
||
end do
|
||
close(u)
|
||
|
||
if (n_bonds <= 0) return
|
||
allocate(bond_pairs(n_bonds, 2), bond_stiffness(n_bonds), bond_rest_lengths(n_bonds))
|
||
bond_pairs(:, :) = ptmp(1:n_bonds, :)
|
||
bond_stiffness = ktmp(1:n_bonds)
|
||
bond_rest_lengths = r0tmp(1:n_bonds)
|
||
end subroutine read_bonds
|
||
|
||
subroutine find_bond(bond_dir, bond_name, k, r0)
|
||
character(len=*), intent(in) :: bond_dir, bond_name
|
||
double precision, intent(out) :: k, r0
|
||
character(len=512) :: path, bn
|
||
integer :: u, ios
|
||
double precision :: bk, br
|
||
k = 1.0d0; r0 = -1.0d0
|
||
path = trim(bond_dir) // '/bond.txt'
|
||
open(newunit=u, file=trim(path), status='old', action='read', iostat=ios)
|
||
if (ios /= 0) return
|
||
read(u, *, iostat=ios)
|
||
do
|
||
read(u, *, iostat=ios) bn, bk, br
|
||
if (ios /= 0) exit
|
||
if (trim(bn) == trim(bond_name)) then
|
||
k = bk
|
||
if (br > 0.0d0) r0 = br
|
||
exit
|
||
end if
|
||
end do
|
||
close(u)
|
||
end subroutine find_bond
|
||
|
||
! ========================================================================
|
||
! 物理核心
|
||
! ========================================================================
|
||
|
||
! 加速度计算（各力独立开关控制）
|
||
pure subroutine accel(n, x, y, z, vx, vy, vz, m, G, B, &
|
||
nb, bp, bk, br, &
|
||
gravity_field, gravity_interaction, &
|
||
elastic_force, damping_force, gravity_strength, &
|
||
ax, ay, az)
|
||
integer, intent(in) :: n, nb, bp(nb, 2)
|
||
integer, intent(in) :: gravity_field, gravity_interaction, elastic_force, damping_force
|
||
double precision, intent(in) :: x(n), y(n), z(n), vx(n), vy(n), vz(n)
|
||
double precision, intent(in) :: m(n), G(3), B(3), bk(nb), br(nb), gravity_strength
|
||
double precision, intent(out) :: ax(n), ay(n), az(n)
|
||
integer :: i, j, ib
|
||
double precision :: dx, dy, dz, dist, s, fm, ux, uy, uz, r2, fg
|
||
|
||
! 清零
|
||
ax = 0.0d0; ay = 0.0d0; az = 0.0d0
|
||
|
||
! 均匀重力场
|
||
if (gravity_field /= 0) then
|
||
do i = 1, n
|
||
ax(i) = G(1); ay(i) = G(2); az(i) = G(3)
|
||
end do
|
||
end if
|
||
|
||
! 阻尼
|
||
if (damping_force /= 0) then
|
||
do i = 1, n
|
||
ax(i) = ax(i) - B(1) * vx(i) / m(i)
|
||
ay(i) = ay(i) - B(2) * vy(i) / m(i)
|
||
az(i) = az(i) - B(3) * vz(i) / m(i)
|
||
end do
|
||
end if
|
||
|
||
! 弹簧键力
|
||
if (elastic_force /= 0) then
|
||
do ib = 1, nb
|
||
i = bp(ib, 1) + 1; j = bp(ib, 2) + 1
|
||
dx = x(j) - x(i); dy = y(j) - y(i); dz = z(j) - z(i)
|
||
dist = sqrt(dx*dx + dy*dy + dz*dz)
|
||
if (dist < 1.0d-12) cycle
|
||
s = (dist - br(ib)) / dist
|
||
fm = bk(ib) * s
|
||
ux = fm * dx; uy = fm * dy; uz = fm * dz
|
||
ax(i) = ax(i) + ux / m(i); ay(i) = ay(i) + uy / m(i); az(i) = az(i) + uz / m(i)
|
||
ax(j) = ax(j) - ux / m(j); ay(j) = ay(j) - uy / m(j); az(j) = az(j) - uz / m(j)
|
||
end do
|
||
end if
|
||
|
||
! 万有引力（所有原子对之间）
|
||
if (gravity_interaction /= 0) then
|
||
do i = 1, n - 1
|
||
do j = i + 1, n
|
||
dx = x(j) - x(i); dy = y(j) - y(i); dz = z(j) - z(i)
|
||
r2 = dx*dx + dy*dy + dz*dz
|
||
if (r2 <= 1.0d-12) cycle
|
||
dist = sqrt(r2)
|
||
fg = gravity_strength * m(i) * m(j) / r2
|
||
ux = fg * dx / dist; uy = fg * dy / dist; uz = fg * dz / dist
|
||
ax(i) = ax(i) + ux / m(i); ay(i) = ay(i) + uy / m(i); az(i) = az(i) + uz / m(i)
|
||
ax(j) = ax(j) - ux / m(j); ay(j) = ay(j) - uy / m(j); az(j) = az(j) - uz / m(j)
|
||
end do
|
||
end do
|
||
end if
|
||
end subroutine accel
|
||
|
||
! 保守力加速度（不含阻尼），供真蛙跳法专用。
|
||
! 传入零速度、零 B 调用 accel，阻尼项 -B*v/m 自动为零。
|
||
subroutine accel_conservative(n, x, y, z, m, G, nb, bp, bk, br, &
|
||
gravity_field, gravity_interaction, &
|
||
elastic_force, gravity_strength, ax, ay, az)
|
||
integer, intent(in) :: n, nb, bp(nb, 2)
|
||
integer, intent(in) :: gravity_field, gravity_interaction, elastic_force
|
||
double precision, intent(in) :: x(n), y(n), z(n), m(n), G(3)
|
||
double precision, intent(in) :: bk(nb), br(nb), gravity_strength
|
||
double precision, intent(out) :: ax(n), ay(n), az(n)
|
||
double precision :: v0(n), B0(3)
|
||
v0 = 0.0d0
|
||
B0 = 0.0d0
|
||
call accel(n, x, y, z, v0, v0, v0, m, G, B0, nb, bp, bk, br, &
|
||
gravity_field, gravity_interaction, &
|
||
elastic_force, 0, gravity_strength, ax, ay, az)
|
||
end subroutine accel_conservative
|
||
|
||
! 边界条件：clamp 位置 + 速度反转
|
||
subroutine limit_in_box(pos, vel, lo, hi)
|
||
double precision, intent(inout) :: pos, vel
|
||
double precision, intent(in) :: lo, hi
|
||
if (pos > hi) then
|
||
pos = hi; vel = -vel
|
||
else if (pos < lo) then
|
||
pos = lo; vel = -vel
|
||
end if
|
||
end subroutine limit_in_box
|
||
|
||
! 周期边界回绕（与 Python wrap_position 一致）
|
||
subroutine wrap_position(pos, lo, hi)
|
||
double precision, intent(inout) :: pos
|
||
double precision, intent(in) :: lo, hi
|
||
if (pos > hi) pos = lo
|
||
if (pos < lo) pos = hi
|
||
end subroutine wrap_position
|
||
|
||
! ── 显式欧拉法 ────────────
|
||
subroutine explicit_euler_step(n, x, y, z, vx, vy, vz, m, G, B, &
|
||
nb, bp, bk, br, fixed, dt, &
|
||
gravity_field, gravity_interaction, &
|
||
elastic_force, damping_force, gravity_strength)
|
||
integer, intent(in) :: n, nb, bp(nb, 2), fixed(n, 3)
|
||
integer, intent(in) :: gravity_field, gravity_interaction, elastic_force, damping_force
|
||
double precision, intent(inout) :: x(n), y(n), z(n), vx(n), vy(n), vz(n)
|
||
double precision, intent(in) :: m(n), G(3), B(3), bk(nb), br(nb), dt, gravity_strength
|
||
double precision :: ax(n), ay(n), az(n)
|
||
integer :: i
|
||
|
||
call accel(n, x, y, z, vx, vy, vz, m, G, B, nb, bp, bk, br, &
|
||
gravity_field, gravity_interaction, &
|
||
elastic_force, damping_force, gravity_strength, ax, ay, az)
|
||
do i = 1, n
|
||
if (fixed(i,1) /= 0 .and. fixed(i,2) /= 0 .and. fixed(i,3) /= 0) cycle
|
||
x(i) = x(i) + vx(i) * dt
|
||
y(i) = y(i) + vy(i) * dt
|
||
z(i) = z(i) + vz(i) * dt
|
||
vx(i) = vx(i) + ax(i) * dt
|
||
vy(i) = vy(i) + ay(i) * dt
|
||
vz(i) = vz(i) + az(i) * dt
|
||
end do
|
||
end subroutine explicit_euler_step
|
||
|
||
! ── 隐式欧拉法 ────────────
|
||
subroutine implicit_euler_step(n, x, y, z, vx, vy, vz, m, G, B, &
|
||
nb, bp, bk, br, fixed, dt, &
|
||
gravity_field, gravity_interaction, &
|
||
elastic_force, damping_force, gravity_strength)
|
||
integer, intent(in) :: n, nb, bp(nb, 2), fixed(n, 3)
|
||
integer, intent(in) :: gravity_field, gravity_interaction, elastic_force, damping_force
|
||
double precision, intent(inout) :: x(n), y(n), z(n), vx(n), vy(n), vz(n)
|
||
double precision, intent(in) :: m(n), G(3), B(3), bk(nb), br(nb), dt, gravity_strength
|
||
double precision :: ax(n), ay(n), az(n)
|
||
double precision :: vxn(n), vyn(n), vzn(n)
|
||
double precision :: gx, gy, gz
|
||
integer :: i
|
||
|
||
! 隐式速度（重力 + 阻尼）
|
||
do i = 1, n
|
||
if (fixed(i,1) /= 0 .and. fixed(i,2) /= 0 .and. fixed(i,3) /= 0) then
|
||
vxn(i) = 0; vyn(i) = 0; vzn(i) = 0; cycle
|
||
end if
|
||
gx = B(1) / m(i); gy = B(2) / m(i); gz = B(3) / m(i)
|
||
vxn(i) = (vx(i) + G(1) * dt) / (1.0d0 + gx * dt)
|
||
vyn(i) = (vy(i) + G(2) * dt) / (1.0d0 + gy * dt)
|
||
vzn(i) = (vz(i) + G(3) * dt) / (1.0d0 + gz * dt)
|
||
end do
|
||
|
||
! 用当前位 + 隐式速度算完整加速度
|
||
call accel(n, x, y, z, vxn, vyn, vzn, m, G, B, nb, bp, bk, br, &
|
||
gravity_field, gravity_interaction, &
|
||
elastic_force, damping_force, gravity_strength, ax, ay, az)
|
||
|
||
do i = 1, n
|
||
if (fixed(i,1) /= 0 .and. fixed(i,2) /= 0 .and. fixed(i,3) /= 0) cycle
|
||
vx(i) = vx(i) + ax(i) * dt
|
||
vy(i) = vy(i) + ay(i) * dt
|
||
vz(i) = vz(i) + az(i) * dt
|
||
x(i) = x(i) + vx(i) * dt
|
||
y(i) = y(i) + vy(i) * dt
|
||
z(i) = z(i) + vz(i) * dt
|
||
end do
|
||
end subroutine implicit_euler_step
|
||
|
||
! ── 中点法 ────────────
|
||
subroutine midpoint_step(n, x, y, z, vx, vy, vz, m, G, B, &
|
||
nb, bp, bk, br, fixed, dt, &
|
||
gravity_field, gravity_interaction, &
|
||
elastic_force, damping_force, gravity_strength)
|
||
integer, intent(in) :: n, nb, bp(nb, 2), fixed(n, 3)
|
||
integer, intent(in) :: gravity_field, gravity_interaction, elastic_force, damping_force
|
||
double precision, intent(inout) :: x(n), y(n), z(n), vx(n), vy(n), vz(n)
|
||
double precision, intent(in) :: m(n), G(3), B(3), bk(nb), br(nb), dt, gravity_strength
|
||
double precision :: ax(n), ay(n), az(n)
|
||
double precision :: xm(n), ym(n), zm(n), vxm(n), vym(n), vzm(n)
|
||
integer :: i
|
||
|
||
call accel(n, x, y, z, vx, vy, vz, m, G, B, nb, bp, bk, br, &
|
||
gravity_field, gravity_interaction, &
|
||
elastic_force, damping_force, gravity_strength, ax, ay, az)
|
||
do i = 1, n
|
||
if (fixed(i,1) /= 0 .and. fixed(i,2) /= 0 .and. fixed(i,3) /= 0) then
|
||
xm(i)=0; ym(i)=0; zm(i)=0; vxm(i)=0; vym(i)=0; vzm(i)=0; cycle
|
||
end if
|
||
xm(i) = x(i) + 0.5d0 * vx(i) * dt
|
||
ym(i) = y(i) + 0.5d0 * vy(i) * dt
|
||
zm(i) = z(i) + 0.5d0 * vz(i) * dt
|
||
vxm(i) = vx(i) + 0.5d0 * ax(i) * dt
|
||
vym(i) = vy(i) + 0.5d0 * ay(i) * dt
|
||
vzm(i) = vz(i) + 0.5d0 * az(i) * dt
|
||
x(i) = x(i) + vxm(i) * dt
|
||
y(i) = y(i) + vym(i) * dt
|
||
z(i) = z(i) + vzm(i) * dt
|
||
end do
|
||
|
||
call accel(n, xm, ym, zm, vxm, vym, vzm, m, G, B, nb, bp, bk, br, &
|
||
gravity_field, gravity_interaction, &
|
||
elastic_force, damping_force, gravity_strength, ax, ay, az)
|
||
do i = 1, n
|
||
if (fixed(i,1) /= 0 .and. fixed(i,2) /= 0 .and. fixed(i,3) /= 0) cycle
|
||
vx(i) = vx(i) + ax(i) * dt
|
||
vy(i) = vy(i) + ay(i) * dt
|
||
vz(i) = vz(i) + az(i) * dt
|
||
end do
|
||
end subroutine midpoint_step
|
||
|
||
! 真蛙跳一步：x(t), v(t-dt/2) → x(t+dt), v(t+dt/2)
|
||
!
|
||
! 无阻尼：纯保守蛙跳，每步 1 次力计算，辛积分器。
|
||
! v(t+dt/2) = v(t-dt/2) + a_c(t)*dt
|
||
!
|
||
! 有阻尼：半隐式处理，仍 1 次力计算，对任意阻尼无条件稳定。
|
||
! v(t+dt/2) = [v(t-dt/2)*(1-α) + a_c(t)*dt] / (1+α)，α = B*dt/(2m)
|
||
subroutine leapfrog_full(n, x, y, z, vx, vy, vz, m, G, B, &
|
||
nb, bp, bk, br, fixed, dt, &
|
||
gravity_field, gravity_interaction, &
|
||
elastic_force, damping_force, gravity_strength)
|
||
integer, intent(in) :: n, nb, bp(nb, 2), fixed(n, 3)
|
||
integer, intent(in) :: gravity_field, gravity_interaction, elastic_force, damping_force
|
||
double precision, intent(inout) :: x(n), y(n), z(n), vx(n), vy(n), vz(n)
|
||
double precision, intent(in) :: m(n), G(3), B(3), bk(nb), br(nb), dt, gravity_strength
|
||
double precision :: ax(n), ay(n), az(n)
|
||
double precision :: alphax, alphay, alphaz
|
||
logical :: has_damping
|
||
integer :: i
|
||
|
||
! 1 次保守力计算（不含阻尼）
|
||
call accel_conservative(n, x, y, z, m, G, nb, bp, bk, br, &
|
||
gravity_field, gravity_interaction, &
|
||
elastic_force, gravity_strength, ax, ay, az)
|
||
|
||
has_damping = (damping_force /= 0) .and. &
|
||
(B(1) /= 0.0d0 .or. B(2) /= 0.0d0 .or. B(3) /= 0.0d0)
|
||
|
||
do i = 1, n
|
||
if (fixed(i,1) /= 0 .and. fixed(i,2) /= 0 .and. fixed(i,3) /= 0) cycle
|
||
if (has_damping) then
|
||
alphax = B(1) * dt / (2.0d0 * m(i))
|
||
alphay = B(2) * dt / (2.0d0 * m(i))
|
||
alphaz = B(3) * dt / (2.0d0 * m(i))
|
||
vx(i) = (vx(i) * (1.0d0 - alphax) + ax(i) * dt) / (1.0d0 + alphax)
|
||
vy(i) = (vy(i) * (1.0d0 - alphay) + ay(i) * dt) / (1.0d0 + alphay)
|
||
vz(i) = (vz(i) * (1.0d0 - alphaz) + az(i) * dt) / (1.0d0 + alphaz)
|
||
else
|
||
vx(i) = vx(i) + ax(i) * dt
|
||
vy(i) = vy(i) + ay(i) * dt
|
||
vz(i) = vz(i) + az(i) * dt
|
||
end if
|
||
x(i) = x(i) + vx(i) * dt
|
||
y(i) = y(i) + vy(i) * dt
|
||
z(i) = z(i) + vz(i) * dt
|
||
end do
|
||
end subroutine leapfrog_full
|
||
|
||
! ── 分发器 + 边界条件 + 自由度约束 ──
|
||
subroutine apply_step(method, n, x, y, z, vx, vy, vz, m, G, B, &
|
||
nb, bp, bk, br, fixed, box_a, dt, &
|
||
gravity_field, gravity_interaction, &
|
||
elastic_force, damping_force, gravity_strength, &
|
||
pos_0)
|
||
character(len=*), intent(in) :: method
|
||
integer, intent(in) :: n, nb, bp(nb, 2), fixed(n, 3)
|
||
integer, intent(in) :: gravity_field, gravity_interaction, elastic_force, damping_force
|
||
double precision, intent(inout) :: x(n), y(n), z(n), vx(n), vy(n), vz(n)
|
||
double precision, intent(in) :: m(n), G(3), B(3), bk(nb), br(nb), box_a, dt, gravity_strength
|
||
double precision, intent(in) :: pos_0(n, 3)
|
||
double precision :: mm(n)
|
||
integer :: i
|
||
|
||
mm = m
|
||
|
||
if (trim(method) == 'explicit_euler') then
|
||
call explicit_euler_step(n, x, y, z, vx, vy, vz, mm, G, B, &
|
||
nb, bp, bk, br, fixed, dt, &
|
||
gravity_field, gravity_interaction, &
|
||
elastic_force, damping_force, gravity_strength)
|
||
else if (trim(method) == 'implicit_euler') then
|
||
call implicit_euler_step(n, x, y, z, vx, vy, vz, mm, G, B, &
|
||
nb, bp, bk, br, fixed, dt, &
|
||
gravity_field, gravity_interaction, &
|
||
elastic_force, damping_force, gravity_strength)
|
||
else if (trim(method) == 'midpoint') then
|
||
call midpoint_step(n, x, y, z, vx, vy, vz, mm, G, B, &
|
||
nb, bp, bk, br, fixed, dt, &
|
||
gravity_field, gravity_interaction, &
|
||
elastic_force, damping_force, gravity_strength)
|
||
else if (trim(method) == 'leapfrog') then
|
||
call leapfrog_full(n, x, y, z, vx, vy, vz, mm, G, B, &
|
||
nb, bp, bk, br, fixed, dt, &
|
||
gravity_field, gravity_interaction, &
|
||
elastic_force, damping_force, gravity_strength)
|
||
else
|
||
write(*, '("[Fortran-engine] 未知算法: ", a)') trim(method)
|
||
stop
|
||
end if
|
||
|
||
! 边界条件
|
||
do i = 1, n
|
||
if (fixed(i,1) /= 0 .and. fixed(i,2) /= 0 .and. fixed(i,3) /= 0) cycle
|
||
call limit_in_box(x(i), vx(i), -box_a, box_a)
|
||
call limit_in_box(y(i), vy(i), -box_a, box_a)
|
||
call limit_in_box(z(i), vz(i), -box_a, box_a)
|
||
end do
|
||
|
||
! 周期边界回绕（与 Python wrap_position 一致）
|
||
do i = 1, n
|
||
call wrap_position(x(i), -box_a, box_a)
|
||
call wrap_position(y(i), -box_a, box_a)
|
||
call wrap_position(z(i), -box_a, box_a)
|
||
end do
|
||
|
||
! 逐自由度固定约束（与 Python apply_fixed_constraints 一致）
|
||
do i = 1, n
|
||
if (fixed(i,1) /= 0) then; x(i) = pos_0(i, 1); vx(i) = 0.0d0; end if
|
||
if (fixed(i,2) /= 0) then; y(i) = pos_0(i, 2); vy(i) = 0.0d0; end if
|
||
if (fixed(i,3) /= 0) then; z(i) = pos_0(i, 3); vz(i) = 0.0d0; end if
|
||
end do
|
||
end subroutine apply_step
|
||
|
||
! ========================================================================
|
||
! 读取驱动力 driver.txt
|
||
! ========================================================================
|
||
subroutine read_driver(input_dir, n_atoms, atom_ids, n_drivers, &
|
||
drv_atom_idx, drv_amp_x, drv_amp_y, drv_amp_z, &
|
||
drv_freq_x, drv_freq_y, drv_freq_z, &
|
||
drv_phi_x, drv_phi_y, drv_phi_z, &
|
||
drv_has_period, drv_period_cycles, &
|
||
drv_freeze_x, drv_freeze_y, drv_freeze_z)
|
||
character(len=*), intent(in) :: input_dir
|
||
integer, intent(in) :: n_atoms, atom_ids(n_atoms)
|
||
integer, intent(out) :: n_drivers
|
||
integer, allocatable, intent(out) :: drv_atom_idx(:)
|
||
double precision, allocatable, intent(out) :: drv_amp_x(:), drv_amp_y(:), drv_amp_z(:)
|
||
double precision, allocatable, intent(out) :: drv_freq_x(:), drv_freq_y(:), drv_freq_z(:)
|
||
double precision, allocatable, intent(out) :: drv_phi_x(:), drv_phi_y(:), drv_phi_z(:)
|
||
integer, allocatable, intent(out) :: drv_has_period(:)
|
||
double precision, allocatable, intent(out) :: drv_period_cycles(:)
|
||
double precision, allocatable, intent(out) :: drv_freeze_x(:), drv_freeze_y(:), drv_freeze_z(:)
|
||
|
||
character(len=512) :: path, line, period_str
|
||
integer :: u, ios, i, n, idx, n_cap
|
||
double precision :: ax, ay, az, fx, fy, fz, px, py, pz
|
||
integer, parameter :: MX = 256
|
||
integer :: idx_tmp(MX), per_tmp(MX)
|
||
double precision :: ax_tmp(MX), ay_tmp(MX), az_tmp(MX)
|
||
double precision :: fxx_tmp(MX), fyy_tmp(MX), fzz_tmp(MX)
|
||
double precision :: pxx_tmp(MX), pyy_tmp(MX), pzz_tmp(MX)
|
||
double precision :: pc_tmp(MX)
|
||
double precision :: fzx_tmp(MX), fzy_tmp(MX), fzz_tmp2(MX)
|
||
|
||
n_drivers = 0
|
||
path = trim(input_dir) // '/driver.txt'
|
||
open(newunit=u, file=trim(path), status='old', action='read', iostat=ios)
|
||
if (ios /= 0) then
|
||
write(*, '("[Fortran-engine] 警告: 无法打开 ", a)') trim(path)
|
||
return
|
||
end if
|
||
|
||
read(u, '(a)', iostat=ios) ! skip header
|
||
|
||
do
|
||
read(u, *, iostat=ios) n, ax, ay, az, fx, fy, fz, px, py, pz, period_str
|
||
if (ios /= 0) exit
|
||
n_drivers = n_drivers + 1
|
||
if (n_drivers > MX) exit
|
||
|
||
! Find atom index by id
|
||
idx = -1
|
||
do i = 1, n_atoms
|
||
if (atom_ids(i) == n) then
|
||
idx = i
|
||
exit
|
||
end if
|
||
end do
|
||
if (idx < 0) cycle
|
||
|
||
idx_tmp(n_drivers) = idx - 1 ! 0-based index
|
||
ax_tmp(n_drivers) = ax; ay_tmp(n_drivers) = ay; az_tmp(n_drivers) = az
|
||
fxx_tmp(n_drivers) = fx; fyy_tmp(n_drivers) = fy; fzz_tmp(n_drivers) = fz
|
||
! degrees to radians
|
||
pxx_tmp(n_drivers) = px * 3.141592653589793d0 / 180.0d0
|
||
pyy_tmp(n_drivers) = py * 3.141592653589793d0 / 180.0d0
|
||
pzz_tmp(n_drivers) = pz * 3.141592653589793d0 / 180.0d0
|
||
|
||
if (trim(period_str) == 'all') then
|
||
per_tmp(n_drivers) = 0
|
||
pc_tmp(n_drivers) = -1.0d0
|
||
else
|
||
per_tmp(n_drivers) = 1
|
||
read(period_str, *) pc_tmp(n_drivers)
|
||
end if
|
||
fzx_tmp(n_drivers) = 0.0d0
|
||
fzy_tmp(n_drivers) = 0.0d0
|
||
fzz_tmp2(n_drivers) = 0.0d0
|
||
end do
|
||
close(u)
|
||
|
||
if (n_drivers <= 0) return
|
||
|
||
allocate(drv_atom_idx(n_drivers))
|
||
allocate(drv_amp_x(n_drivers), drv_amp_y(n_drivers), drv_amp_z(n_drivers))
|
||
allocate(drv_freq_x(n_drivers), drv_freq_y(n_drivers), drv_freq_z(n_drivers))
|
||
allocate(drv_phi_x(n_drivers), drv_phi_y(n_drivers), drv_phi_z(n_drivers))
|
||
allocate(drv_has_period(n_drivers), drv_period_cycles(n_drivers))
|
||
allocate(drv_freeze_x(n_drivers), drv_freeze_y(n_drivers), drv_freeze_z(n_drivers))
|
||
|
||
drv_atom_idx = idx_tmp(1:n_drivers)
|
||
drv_amp_x = ax_tmp(1:n_drivers); drv_amp_y = ay_tmp(1:n_drivers); drv_amp_z = az_tmp(1:n_drivers)
|
||
drv_freq_x = fxx_tmp(1:n_drivers); drv_freq_y = fyy_tmp(1:n_drivers); drv_freq_z = fzz_tmp(1:n_drivers)
|
||
drv_phi_x = pxx_tmp(1:n_drivers); drv_phi_y = pyy_tmp(1:n_drivers); drv_phi_z = pzz_tmp(1:n_drivers)
|
||
drv_has_period = per_tmp(1:n_drivers)
|
||
drv_period_cycles = pc_tmp(1:n_drivers)
|
||
drv_freeze_x = fzx_tmp(1:n_drivers); drv_freeze_y = fzy_tmp(1:n_drivers); drv_freeze_z = fzz_tmp2(1:n_drivers)
|
||
|
||
write(*, '("[Fortran-engine] 已加载驱动力: ", i0, " 条定义")') n_drivers
|
||
end subroutine read_driver
|
||
|
||
! 施加驱动力
|
||
subroutine apply_driving(n, x, y, z, vx, vy, vz, t, step, dt, &
|
||
n_drivers, drv_atom_idx, &
|
||
drv_amp_x, drv_amp_y, drv_amp_z, &
|
||
drv_freq_x, drv_freq_y, drv_freq_z, &
|
||
drv_phi_x, drv_phi_y, drv_phi_z, &
|
||
drv_has_period, drv_period_cycles, &
|
||
drv_freeze_x, drv_freeze_y, drv_freeze_z)
|
||
integer, intent(in) :: n, step, n_drivers
|
||
integer, intent(in) :: drv_atom_idx(n_drivers), drv_has_period(n_drivers)
|
||
double precision, intent(inout) :: x(n), y(n), z(n), vx(n), vy(n), vz(n)
|
||
double precision, intent(in) :: t, dt
|
||
double precision, intent(in) :: drv_amp_x(n_drivers), drv_amp_y(n_drivers), drv_amp_z(n_drivers)
|
||
double precision, intent(in) :: drv_freq_x(n_drivers), drv_freq_y(n_drivers), drv_freq_z(n_drivers)
|
||
double precision, intent(in) :: drv_phi_x(n_drivers), drv_phi_y(n_drivers), drv_phi_z(n_drivers)
|
||
double precision, intent(in) :: drv_period_cycles(n_drivers)
|
||
double precision, intent(inout) :: drv_freeze_x(n_drivers), drv_freeze_y(n_drivers), drv_freeze_z(n_drivers)
|
||
|
||
integer :: d, idx, period_steps
|
||
double precision :: max_freq, px, py, pz, vpx, vpy, vpz, TWO_PI
|
||
|
||
TWO_PI = 2.0d0 * 3.141592653589793d0
|
||
|
||
do d = 1, n_drivers
|
||
idx = drv_atom_idx(d) + 1 ! Fortran 1-based indexing
|
||
|
||
! Check period
|
||
if (drv_has_period(d) /= 0) then
|
||
max_freq = max(abs(drv_freq_x(d)), abs(drv_freq_y(d)), abs(drv_freq_z(d)))
|
||
period_steps = 0
|
||
if (max_freq > 1.0d-12) then
|
||
period_steps = int(drv_period_cycles(d) / max_freq / dt)
|
||
end if
|
||
if (step > period_steps) then
|
||
x(idx) = drv_freeze_x(d)
|
||
y(idx) = drv_freeze_y(d)
|
||
z(idx) = drv_freeze_z(d)
|
||
vx(idx) = 0.0d0; vy(idx) = 0.0d0; vz(idx) = 0.0d0
|
||
cycle
|
||
end if
|
||
end if
|
||
|
||
px = drv_amp_x(d) * cos(TWO_PI * drv_freq_x(d) * t + drv_phi_x(d))
|
||
py = drv_amp_y(d) * cos(TWO_PI * drv_freq_y(d) * t + drv_phi_y(d))
|
||
pz = drv_amp_z(d) * cos(TWO_PI * drv_freq_z(d) * t + drv_phi_z(d))
|
||
vpx = -drv_amp_x(d) * TWO_PI * drv_freq_x(d) * sin(TWO_PI * drv_freq_x(d) * t + drv_phi_x(d))
|
||
vpy = -drv_amp_y(d) * TWO_PI * drv_freq_y(d) * sin(TWO_PI * drv_freq_y(d) * t + drv_phi_y(d))
|
||
vpz = -drv_amp_z(d) * TWO_PI * drv_freq_z(d) * sin(TWO_PI * drv_freq_z(d) * t + drv_phi_z(d))
|
||
|
||
x(idx) = px; y(idx) = py; z(idx) = pz
|
||
vx(idx) = vpx; vy(idx) = vpy; vz(idx) = vpz
|
||
|
||
! Record freeze position
|
||
if (drv_has_period(d) /= 0) then
|
||
max_freq = max(abs(drv_freq_x(d)), abs(drv_freq_y(d)), abs(drv_freq_z(d)))
|
||
period_steps = 0
|
||
if (max_freq > 1.0d-12) then
|
||
period_steps = int(drv_period_cycles(d) / max_freq / dt)
|
||
end if
|
||
if (step == period_steps) then
|
||
drv_freeze_x(d) = px
|
||
drv_freeze_y(d) = py
|
||
drv_freeze_z(d) = pz
|
||
end if
|
||
end if
|
||
end do
|
||
end subroutine apply_driving
|
||
|
||
! ========================================================================
|
||
! JSON 输出
|
||
! ========================================================================
|
||
|
||
subroutine write_json(outdir, tx, ty, tz, tvx, tvy, tvz, &
|
||
nsteps, nat, aid, amass, &
|
||
NT, DT, NSTEP, warmup, method, G, B, &
|
||
nb, bp, bk, br, driving_force)
|
||
character(len=*), intent(in) :: outdir, method
|
||
integer, intent(in) :: nsteps, nat, NT, NSTEP, warmup, nb, bp(nb, 2), aid(nat), driving_force
|
||
double precision, intent(in) :: tx(nsteps, nat), ty(nsteps, nat), tz(nsteps, nat)
|
||
double precision, intent(in) :: tvx(nsteps, nat), tvy(nsteps, nat), tvz(nsteps, nat)
|
||
double precision, intent(in) :: DT, G(3), B(3), bk(nb), br(nb), amass(nat)
|
||
|
||
character(len=512) :: path, buf
|
||
integer :: u, s, i, ib, ios
|
||
|
||
path = trim(outdir) // '/trajectory.txt'
|
||
open(newunit=u, file=trim(path), status='replace', action='write', iostat=ios)
|
||
if (ios /= 0) then
|
||
write(*, '("[Fortran-engine] 错误: 无法写入 ", a)') trim(path)
|
||
stop
|
||
end if
|
||
|
||
write(u, '(a)') '{'
|
||
|
||
! traj_x
|
||
write(u, '(a)') ' "traj_x": ['
|
||
do s = 1, nsteps
|
||
call json_arr(u, tx(s, :), nat, s < nsteps, ' ')
|
||
end do
|
||
write(u, '(a)') ' ],'
|
||
|
||
! traj_y
|
||
write(u, '(a)') ' "traj_y": ['
|
||
do s = 1, nsteps
|
||
call json_arr(u, ty(s, :), nat, s < nsteps, ' ')
|
||
end do
|
||
write(u, '(a)') ' ],'
|
||
|
||
! traj_z
|
||
write(u, '(a)') ' "traj_z": ['
|
||
do s = 1, nsteps
|
||
call json_arr(u, tz(s, :), nat, s < nsteps, ' ')
|
||
end do
|
||
write(u, '(a)') ' ],'
|
||
|
||
! traj_vx
|
||
write(u, '(a)') ' "traj_vx": ['
|
||
do s = 1, nsteps
|
||
call json_arr(u, tvx(s, :), nat, s < nsteps, ' ')
|
||
end do
|
||
write(u, '(a)') ' ],'
|
||
|
||
! traj_vy
|
||
write(u, '(a)') ' "traj_vy": ['
|
||
do s = 1, nsteps
|
||
call json_arr(u, tvy(s, :), nat, s < nsteps, ' ')
|
||
end do
|
||
write(u, '(a)') ' ],'
|
||
|
||
! traj_vz
|
||
write(u, '(a)') ' "traj_vz": ['
|
||
do s = 1, nsteps
|
||
call json_arr(u, tvz(s, :), nat, s < nsteps, ' ')
|
||
end do
|
||
write(u, '(a)') ' ],'
|
||
|
||
! 标量参数
|
||
write(buf, '(a, i0, a)') ' "NT": ', NT, ','
|
||
write(u, '(a)') trim(buf)
|
||
write(buf, '(a, g0, a)') ' "DT": ', DT, ','
|
||
write(u, '(a)') trim(buf)
|
||
write(buf, '(a, i0, a)') ' "NSTEP": ', NSTEP, ','
|
||
write(u, '(a)') trim(buf)
|
||
write(buf, '(a, a, a)') ' "method": "', trim(method), '",'
|
||
write(u, '(a)') trim(buf)
|
||
write(buf, '(a, i0, a)') ' "warmup_steps": ', warmup, ','
|
||
write(u, '(a)') trim(buf)
|
||
|
||
write(buf, '(a, g0, a, g0, a, g0, a)') &
|
||
' "G": [', G(1), ', ', G(2), ', ', G(3), '],'
|
||
write(u, '(a)') trim(buf)
|
||
write(buf, '(a, g0, a, g0, a, g0, a)') &
|
||
' "B": [', B(1), ', ', B(2), ', ', B(3), '],'
|
||
write(u, '(a)') trim(buf)
|
||
|
||
! 原子信息
|
||
write(u, '(a)', advance='no') ' "atom_ids": ['
|
||
do i = 1, nat
|
||
if (i > 1) write(u, '(a)', advance='no') ','
|
||
write(u, '(i0)', advance='no') aid(i)
|
||
end do
|
||
write(u, '(a)') '],'
|
||
|
||
write(u, '(a)', advance='no') ' "atom_masses": ['
|
||
do i = 1, nat
|
||
if (i > 1) write(u, '(a)', advance='no') ','
|
||
write(u, '(g0)', advance='no') amass(i)
|
||
end do
|
||
write(u, '(a)') '],'
|
||
|
||
! 成键
|
||
if (nb > 0) then
|
||
call write_int2_arr(u, 'bond_pairs', bp, nb, .true.)
|
||
call write_dbl_arr(u, 'bond_stiffness', bk, nb, .true.)
|
||
call write_dbl_arr(u, 'bond_rest_lengths', br, nb, .true.)
|
||
else
|
||
write(u, '(a)') ' "bond_pairs": [],'
|
||
write(u, '(a)') ' "bond_stiffness": [],'
|
||
write(u, '(a)') ' "bond_rest_lengths": [],'
|
||
end if
|
||
|
||
write(buf, '(a, i0)') ' "driving_force": ', driving_force
|
||
write(u, '(a)') trim(buf)
|
||
|
||
write(u, '(a)') '}'
|
||
close(u)
|
||
end subroutine write_json
|
||
|
||
! 写出单行 JSON 数组 [v1, v2, ...]
|
||
subroutine json_arr(u, vals, n, has_next, indent)
|
||
integer, intent(in) :: u, n
|
||
double precision, intent(in) :: vals(n)
|
||
logical, intent(in) :: has_next
|
||
character(len=*), intent(in) :: indent
|
||
integer :: i
|
||
write(u, '(a)', advance='no') indent // '['
|
||
do i = 1, n
|
||
if (i > 1) write(u, '(a)', advance='no') ','
|
||
write(u, '(g0.8)', advance='no') vals(i)
|
||
end do
|
||
if (has_next) then
|
||
write(u, '(a)') '],'
|
||
else
|
||
write(u, '(a)') ']'
|
||
end if
|
||
end subroutine json_arr
|
||
|
||
subroutine write_int2_arr(u, name, arr, n, has_next)
|
||
integer, intent(in) :: u, n, arr(n, 2)
|
||
character(len=*), intent(in) :: name
|
||
logical, intent(in) :: has_next
|
||
character(len=65536) :: buf
|
||
integer :: i, pos
|
||
write(u, '(a)', advance='no') ' "' // trim(name) // '": ['
|
||
do i = 1, n
|
||
if (i > 1) write(u, '(a)', advance='no') ','
|
||
write(buf, '(a, i0, a, i0, a)') '[', arr(i, 1), ',', arr(i, 2), ']'
|
||
write(u, '(a)', advance='no') trim(buf)
|
||
end do
|
||
if (has_next) then
|
||
write(u, '(a)') '],'
|
||
else
|
||
write(u, '(a)') ']'
|
||
end if
|
||
end subroutine write_int2_arr
|
||
|
||
subroutine write_dbl_arr(u, name, arr, n, has_next)
|
||
integer, intent(in) :: u, n
|
||
double precision, intent(in) :: arr(n)
|
||
character(len=*), intent(in) :: name
|
||
logical, intent(in) :: has_next
|
||
integer :: i
|
||
write(u, '(a)', advance='no') ' "' // trim(name) // '": ['
|
||
do i = 1, n
|
||
if (i > 1) write(u, '(a)', advance='no') ','
|
||
write(u, '(g0.8)', advance='no') arr(i)
|
||
end do
|
||
if (has_next) then
|
||
write(u, '(a)') '],'
|
||
else
|
||
write(u, '(a)') ']'
|
||
end if
|
||
end subroutine write_dbl_arr
|
||
|
||
end program dynamics_f90
|