jnshuti
/
Genetic_base
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

remove PES

This commit is contained in:
jean paul nshuti 2025-10-08 15:52:19 +02:00
parent 733a5d4172
commit 464dca1bbb
15 changed files with 0 additions and 5543 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/model/new_PES/.ctrans.f90.un~
View File

Binary file not shown.

BIN
src/model/new_PES/.xy_stretch_lib.f90.un~
View File

Binary file not shown.

BIN
src/model/new_PES/.xyumb_stretch_lib.f90.swp
View File

Binary file not shown.

BIN
src/model/new_PES/.xyumb_stretch_lib.f90.un~
View File

Binary file not shown.

82
src/model/new_PES/d3h_umb_stretch_lib.f90
View File

@ -1,82 +0,0 @@
module d3h_umb_stretch_lib
use accuracy_constants, only: dp,idp
implicit none
private
public eval_surface, init_surface,eval_matrix
real(dp), dimension(:), allocatable :: p
contains
subroutine eval_surface(e, w, u, x1)
use ctrans_mod, only: ctrans
use diabmodel, only: diab
use dim_parameter, only: ndiab
implicit none
real(dp), dimension(:, :), intent(out) :: w, u
real(dp), dimension(:), intent(out) :: e
real(dp), dimension(:), intent(in) :: x1
real(dp), dimension(size(x1, 1)) :: s, t
real(dp), allocatable, dimension(:, :) :: Mat
!coordinate transformation if needed
call ctrans(x1, s, t)
block
! lapack variables
integer(kind=idp), parameter :: lwork = 1000
real(kind=dp) work(lwork)
integer(kind=idp) info
!evaluate model
call diab(w, 1, x1, s, t, p, size(p, 1))
allocate (Mat, source=w)
call dsyev('V', 'U', ndiab, Mat, ndiab, e, work, lwork, info)
u(:, :) = Mat(:, :)
deallocate (Mat)
end block
end subroutine eval_surface
subroutine eval_matrix(w,x1)
use ctrans_mod, only: ctrans
use diabmodel, only: diab
implicit none
real(dp), dimension(:, :), intent(out) :: w
real(dp), dimension(:), intent(in) :: x1
real(dp), dimension(size(x1, 1)) :: s, t
!coordinate transformation if needed
call ctrans(x1, s, t)
call diab(w, 1, x1, s, t, p, size(p, 1))
end subroutine eval_matrix
subroutine init_surface()
use dim_parameter, only: ndiab, nstat, ntot, nci ,qn
use parameterkeys, only: parameterkey_read
use fileread_mod, only: get_datfile, internalize_datfile
use io_parameters, only: llen
use accuracy_constants, only: dp
implicit none
character(len=llen), allocatable, dimension(:) :: infile
qn = 9
ndiab = 4
nstat = 4
nci = 4
ntot = ndiab + nstat + nci
block
character(len=:),allocatable :: datnam
integer :: linenum
datnam = 'planar+pyramidal.par.save'
! datnam = 'umbstr.par.save'
call internalize_datfile(datnam, infile, linenum, llen)
end block
!read parameters from file
block
real(dp), dimension(:), allocatable :: p_spread
integer,dimension(:),allocatable :: p_act
integer :: npar
real(dp), parameter :: facspread = 1.0_dp, gspread = 1.0_dp
call parameterkey_read(infile, size(infile, 1), p, p_act, p_spread, npar, gspread, facspread)
end block
end subroutine init_surface
end module d3h_umb_stretch_lib

530
src/model/new_PES/keys.f90
View File

@ -1,530 +0,0 @@
!Start of Element: EV 3
!Start of Element: A2V 18
!Start of Element: A1V 33
!Start of Element: EWZ 48
!Start of Element: A1EWZ 60
!Start of Element: A2EQWZ 72
!Start of Element: A2A1Q 78
module keys_mod
implicit none
contains
subroutine init_keys
use io_parameters, only: key
key(1,1) = 'NEXITEN:'
key(2,1) = 'PEXITEN:'
key(3,1) = 'AEXITEN:'
key(4,1) = 'SEXITEN:'
key(1,2) = 'NTMC_CH:'
key(2,2) = 'PTMC_CH:'
key(3,2) = 'ATMC_CH:'
key(4,2) = 'STMC_CH:'
key(1,3) = 'NEVA1:'
key(2,3) = 'PEVA1:'
key(3,3) = 'AEVA1:'
key(4,3) = 'SEVA1:'
key(1,4) = 'NEVU:'
key(2,4) = 'PEVU:'
key(3,4) = 'AEVU:'
key(4,4) = 'SEVU:'
key(1,5) = 'NEVE1:'
key(2,5) = 'PEVE1:'
key(3,5) = 'AEVE1:'
key(4,5) = 'SEVE1:'
key(1,6) = 'NEVE2:'
key(2,6) = 'PEVE2:'
key(3,6) = 'AEVE2:'
key(4,6) = 'SEVE2:'
key(1,7) = 'NEVA1U:'
key(2,7) = 'PEVA1U:'
key(3,7) = 'AEVA1U:'
key(4,7) = 'SEVA1U:'
key(1,8) = 'NEVA1E1:'
key(2,8) = 'PEVA1E1:'
key(3,8) = 'AEVA1E1:'
key(4,8) = 'SEVA1E1:'
key(1,9) = 'NEVA1E2:'
key(2,9) = 'PEVA1E2:'
key(3,9) = 'AEVA1E2:'
key(4,9) = 'SEVA1E2:'
key(1,10) = 'NEVUE1:'
key(2,10) = 'PEVUE1:'
key(3,10) = 'AEVUE1:'
key(4,10) = 'SEVUE1:'
key(1,11) = 'NEVUE2:'
key(2,11) = 'PEVUE2:'
key(3,11) = 'AEVUE2:'
key(4,11) = 'SEVUE2:'
key(1,12) = 'NEVE1E2:'
key(2,12) = 'PEVE1E2:'
key(3,12) = 'AEVE1E2:'
key(4,12) = 'SEVE1E2:'
key(1,13) = 'NEVA1UE1:'
key(2,13) = 'PEVA1UE1:'
key(3,13) = 'AEVA1UE1:'
key(4,13) = 'SEVA1UE1:'
key(1,14) = 'NEVA1UE2:'
key(2,14) = 'PEVA1UE2:'
key(3,14) = 'AEVA1UE2:'
key(4,14) = 'SEVA1UE2:'
key(1,15) = 'NEVA1E1E2:'
key(2,15) = 'PEVA1E1E2:'
key(3,15) = 'AEVA1E1E2:'
key(4,15) = 'SEVA1E1E2:'
key(1,16) = 'NEVUE1E2:'
key(2,16) = 'PEVUE1E2:'
key(3,16) = 'AEVUE1E2:'
key(4,16) = 'SEVUE1E2:'
key(1,17) = 'NEVA1UE1E2:'
key(2,17) = 'PEVA1UE1E2:'
key(3,17) = 'AEVA1UE1E2:'
key(4,17) = 'SEVA1UE1E2:'
key(1,18) = 'NA2VA1:'
key(2,18) = 'PA2VA1:'
key(3,18) = 'AA2VA1:'
key(4,18) = 'SA2VA1:'
key(1,19) = 'NA2VU:'
key(2,19) = 'PA2VU:'
key(3,19) = 'AA2VU:'
key(4,19) = 'SA2VU:'
key(1,20) = 'NA2VE1:'
key(2,20) = 'PA2VE1:'
key(3,20) = 'AA2VE1:'
key(4,20) = 'SA2VE1:'
key(1,21) = 'NA2VE2:'
key(2,21) = 'PA2VE2:'
key(3,21) = 'AA2VE2:'
key(4,21) = 'SA2VE2:'
key(1,22) = 'NA2VA1U:'
key(2,22) = 'PA2VA1U:'
key(3,22) = 'AA2VA1U:'
key(4,22) = 'SA2VA1U:'
key(1,23) = 'NA2VA1E1:'
key(2,23) = 'PA2VA1E1:'
key(3,23) = 'AA2VA1E1:'
key(4,23) = 'SA2VA1E1:'
key(1,24) = 'NA2VA1E2:'
key(2,24) = 'PA2VA1E2:'
key(3,24) = 'AA2VA1E2:'
key(4,24) = 'SA2VA1E2:'
key(1,25) = 'NA2VUE1:'
key(2,25) = 'PA2VUE1:'
key(3,25) = 'AA2VUE1:'
key(4,25) = 'SA2VUE1:'
key(1,26) = 'NA2VUE2:'
key(2,26) = 'PA2VUE2:'
key(3,26) = 'AA2VUE2:'
key(4,26) = 'SA2VUE2:'
key(1,27) = 'NA2VE1E2:'
key(2,27) = 'PA2VE1E2:'
key(3,27) = 'AA2VE1E2:'
key(4,27) = 'SA2VE1E2:'
key(1,28) = 'NA2VA1UE1:'
key(2,28) = 'PA2VA1UE1:'
key(3,28) = 'AA2VA1UE1:'
key(4,28) = 'SA2VA1UE1:'
key(1,29) = 'NA2VA1UE2:'
key(2,29) = 'PA2VA1UE2:'
key(3,29) = 'AA2VA1UE2:'
key(4,29) = 'SA2VA1UE2:'
key(1,30) = 'NA2VA1E1E2:'
key(2,30) = 'PA2VA1E1E2:'
key(3,30) = 'AA2VA1E1E2:'
key(4,30) = 'SA2VA1E1E2:'
key(1,31) = 'NA2VUE1E2:'
key(2,31) = 'PA2VUE1E2:'
key(3,31) = 'AA2VUE1E2:'
key(4,31) = 'SA2VUE1E2:'
key(1,32) = 'NA2VA1UE1E2:'
key(2,32) = 'PA2VA1UE1E2:'
key(3,32) = 'AA2VA1UE1E2:'
key(4,32) = 'SA2VA1UE1E2:'
key(1,33) = 'NA1VA1:'
key(2,33) = 'PA1VA1:'
key(3,33) = 'AA1VA1:'
key(4,33) = 'SA1VA1:'
key(1,34) = 'NA1VU:'
key(2,34) = 'PA1VU:'
key(3,34) = 'AA1VU:'
key(4,34) = 'SA1VU:'
key(1,35) = 'NA1VE1:'
key(2,35) = 'PA1VE1:'
key(3,35) = 'AA1VE1:'
key(4,35) = 'SA1VE1:'
key(1,36) = 'NA1VE2:'
key(2,36) = 'PA1VE2:'
key(3,36) = 'AA1VE2:'
key(4,36) = 'SA1VE2:'
key(1,37) = 'NA1VA1U:'
key(2,37) = 'PA1VA1U:'
key(3,37) = 'AA1VA1U:'
key(4,37) = 'SA1VA1U:'
key(1,38) = 'NA1VA1E1:'
key(2,38) = 'PA1VA1E1:'
key(3,38) = 'AA1VA1E1:'
key(4,38) = 'SA1VA1E1:'
key(1,39) = 'NA1VA1E2:'
key(2,39) = 'PA1VA1E2:'
key(3,39) = 'AA1VA1E2:'
key(4,39) = 'SA1VA1E2:'
key(1,40) = 'NA1VUE1:'
key(2,40) = 'PA1VUE1:'
key(3,40) = 'AA1VUE1:'
key(4,40) = 'SA1VUE1:'
key(1,41) = 'NA1VUE2:'
key(2,41) = 'PA1VUE2:'
key(3,41) = 'AA1VUE2:'
key(4,41) = 'SA1VUE2:'
key(1,42) = 'NA1VE1E2:'
key(2,42) = 'PA1VE1E2:'
key(3,42) = 'AA1VE1E2:'
key(4,42) = 'SA1VE1E2:'
key(1,43) = 'NA1VA1UE1:'
key(2,43) = 'PA1VA1UE1:'
key(3,43) = 'AA1VA1UE1:'
key(4,43) = 'SA1VA1UE1:'
key(1,44) = 'NA1VA1UE2:'
key(2,44) = 'PA1VA1UE2:'
key(3,44) = 'AA1VA1UE2:'
key(4,44) = 'SA1VA1UE2:'
key(1,45) = 'NA1VA1E1E2:'
key(2,45) = 'PA1VA1E1E2:'
key(3,45) = 'AA1VA1E1E2:'
key(4,45) = 'SA1VA1E1E2:'
key(1,46) = 'NA1VUE1E2:'
key(2,46) = 'PA1VUE1E2:'
key(3,46) = 'AA1VUE1E2:'
key(4,46) = 'SA1VUE1E2:'
key(1,47) = 'NA1VA1UE1E2:'
key(2,47) = 'PA1VA1UE1E2:'
key(3,47) = 'AA1VA1UE1E2:'
key(4,47) = 'SA1VA1UE1E2:'
key(1,48) = 'NEWZE1:'
key(2,48) = 'PEWZE1:'
key(3,48) = 'AEWZE1:'
key(4,48) = 'SEWZE1:'
key(1,49) = 'NEWZE2:'
key(2,49) = 'PEWZE2:'
key(3,49) = 'AEWZE2:'
key(4,49) = 'SEWZE2:'
key(1,50) = 'NEWZE1A1:'
key(2,50) = 'PEWZE1A1:'
key(3,50) = 'AEWZE1A1:'
key(4,50) = 'SEWZE1A1:'
key(1,51) = 'NEWZE2A1:'
key(2,51) = 'PEWZE2A1:'
key(3,51) = 'AEWZE2A1:'
key(4,51) = 'SEWZE2A1:'
key(1,52) = 'NEWZE1U:'
key(2,52) = 'PEWZE1U:'
key(3,52) = 'AEWZE1U:'
key(4,52) = 'SEWZE1U:'
key(1,53) = 'NEWZE2U:'
key(2,53) = 'PEWZE2U:'
key(3,53) = 'AEWZE2U:'
key(4,53) = 'SEWZE2U:'
key(1,54) = 'NEWZE1A1U:'
key(2,54) = 'PEWZE1A1U:'
key(3,54) = 'AEWZE1A1U:'
key(4,54) = 'SEWZE1A1U:'
key(1,55) = 'NEWZE2A1U:'
key(2,55) = 'PEWZE2A1U:'
key(3,55) = 'AEWZE2A1U:'
key(4,55) = 'SEWZE2A1U:'
key(1,56) = 'NEWZE1E2:'
key(2,56) = 'PEWZE1E2:'
key(3,56) = 'AEWZE1E2:'
key(4,56) = 'SEWZE1E2:'
key(1,57) = 'NEWZE1E2A1:'
key(2,57) = 'PEWZE1E2A1:'
key(3,57) = 'AEWZE1E2A1:'
key(4,57) = 'SEWZE1E2A1:'
key(1,58) = 'NEWZE1E2U:'
key(2,58) = 'PEWZE1E2U:'
key(3,58) = 'AEWZE1E2U:'
key(4,58) = 'SEWZE1E2U:'
key(1,59) = 'NEWZE1E2A1U:'
key(2,59) = 'PEWZE1E2A1U:'
key(3,59) = 'AEWZE1E2A1U:'
key(4,59) = 'SEWZE1E2A1U:'
key(1,60) = 'NA1EWZE1:'
key(2,60) = 'PA1EWZE1:'
key(3,60) = 'AA1EWZE1:'
key(4,60) = 'SA1EWZE1:'
key(1,61) = 'NA1EWZE2:'
key(2,61) = 'PA1EWZE2:'
key(3,61) = 'AA1EWZE2:'
key(4,61) = 'SA1EWZE2:'
key(1,62) = 'NA1EWZE1A1:'
key(2,62) = 'PA1EWZE1A1:'
key(3,62) = 'AA1EWZE1A1:'
key(4,62) = 'SA1EWZE1A1:'
key(1,63) = 'NA1EWZE2A1:'
key(2,63) = 'PA1EWZE2A1:'
key(3,63) = 'AA1EWZE2A1:'
key(4,63) = 'SA1EWZE2A1:'
key(1,64) = 'NA1EWZE1U:'
key(2,64) = 'PA1EWZE1U:'
key(3,64) = 'AA1EWZE1U:'
key(4,64) = 'SA1EWZE1U:'
key(1,65) = 'NA1EWZE2U:'
key(2,65) = 'PA1EWZE2U:'
key(3,65) = 'AA1EWZE2U:'
key(4,65) = 'SA1EWZE2U:'
key(1,66) = 'NA1EWZE1A1U:'
key(2,66) = 'PA1EWZE1A1U:'
key(3,66) = 'AA1EWZE1A1U:'
key(4,66) = 'SA1EWZE1A1U:'
key(1,67) = 'NA1EWZE2A1U:'
key(2,67) = 'PA1EWZE2A1U:'
key(3,67) = 'AA1EWZE2A1U:'
key(4,67) = 'SA1EWZE2A1U:'
key(1,68) = 'NA1EWZE1E2:'
key(2,68) = 'PA1EWZE1E2:'
key(3,68) = 'AA1EWZE1E2:'
key(4,68) = 'SA1EWZE1E2:'
key(1,69) = 'NA1EWZE1E2A1:'
key(2,69) = 'PA1EWZE1E2A1:'
key(3,69) = 'AA1EWZE1E2A1:'
key(4,69) = 'SA1EWZE1E2A1:'
key(1,70) = 'NA1EWZE1E2U:'
key(2,70) = 'PA1EWZE1E2U:'
key(3,70) = 'AA1EWZE1E2U:'
key(4,70) = 'SA1EWZE1E2U:'
key(1,71) = 'NA1EWZE1E2A1U:'
key(2,71) = 'PA1EWZE1E2A1U:'
key(3,71) = 'AA1EWZE1E2A1U:'
key(4,71) = 'SA1EWZE1E2A1U:'
key(1,72) = 'NA2EQWZE1U:'
key(2,72) = 'PA2EQWZE1U:'
key(3,72) = 'AA2EQWZE1U:'
key(4,72) = 'SA2EQWZE1U:'
key(1,73) = 'NA2EQWZE2U:'
key(2,73) = 'PA2EQWZE2U:'
key(3,73) = 'AA2EQWZE2U:'
key(4,73) = 'SA2EQWZE2U:'
key(1,74) = 'NA2EQWZE1UA1:'
key(2,74) = 'PA2EQWZE1UA1:'
key(3,74) = 'AA2EQWZE1UA1:'
key(4,74) = 'SA2EQWZE1UA1:'
key(1,75) = 'NA2EQWZE2UA1:'
key(2,75) = 'PA2EQWZE2UA1:'
key(3,75) = 'AA2EQWZE2UA1:'
key(4,75) = 'SA2EQWZE2UA1:'
key(1,76) = 'NA2EQWZE1E2U:'
key(2,76) = 'PA2EQWZE1E2U:'
key(3,76) = 'AA2EQWZE1E2U:'
key(4,76) = 'SA2EQWZE1E2U:'
key(1,77) = 'NA2EQWZE1E2UA1:'
key(2,77) = 'PA2EQWZE1E2UA1:'
key(3,77) = 'AA2EQWZE1E2UA1:'
key(4,77) = 'SA2EQWZE1E2UA1:'
key(1,78) = 'NA2A1QU:'
key(2,78) = 'PA2A1QU:'
key(3,78) = 'AA2A1QU:'
key(4,78) = 'SA2A1QU:'
key(1,79) = 'NA2A1QUA1:'
key(2,79) = 'PA2A1QUA1:'
key(3,79) = 'AA2A1QUA1:'
key(4,79) = 'SA2A1QUA1:'
key(1,80) = 'NA2A1QUE1:'
key(2,80) = 'PA2A1QUE1:'
key(3,80) = 'AA2A1QUE1:'
key(4,80) = 'SA2A1QUE1:'
key(1,81) = 'NA2A1QUE2:'
key(2,81) = 'PA2A1QUE2:'
key(3,81) = 'AA2A1QUE2:'
key(4,81) = 'SA2A1QUE2:'
key(1,82) = 'NA2A1QUA1E1:'
key(2,82) = 'PA2A1QUA1E1:'
key(3,82) = 'AA2A1QUA1E1:'
key(4,82) = 'SA2A1QUA1E1:'
key(1,83) = 'NA2A1QUA1E2:'
key(2,83) = 'PA2A1QUA1E2:'
key(3,83) = 'AA2A1QUA1E2:'
key(4,83) = 'SA2A1QUA1E2:'
key(1,84) = 'NA2A1QUE1E2:'
key(2,84) = 'PA2A1QUE1E2:'
key(3,84) = 'AA2A1QUE1E2:'
key(4,84) = 'SA2A1QUE1E2:'
key(1,85) = 'NA2A1QUA1E1E2:'
key(2,85) = 'PA2A1QUA1E1E2:'
key(3,85) = 'AA2A1QUA1E1E2:'
key(4,85) = 'SA2A1QUA1E1E2:'
key(1,86) = 'NCORECORE:'
key(2,86) = 'PCORECORE:'
key(3,86) = 'ACORECORE:'
key(4,86) = 'SCORECORE:'
end subroutine init_keys
end module

671
src/model/new_PES/pes_ctrans.f90
View File

@ -1,671 +0,0 @@
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! % SUBROUTINE CTRANS(...)
! %
! % M. Vossel 21.03.2023
! %
! % Routine to transform symmetryinput coordinates to symmetrized
! % coordinates. Distances Are discribet by Morse coordinates or
! % TMC depending on Set Parameters in the Genetic Input.
! %
! % input variables
! % q:
! % q(1): H1x
! % q(2): y
! % q(3): z
! % q(4): H2x
! % q(5): y
! % q(6): z
! % q(7): H3x
! % q(8): y
! % q(9): z
!
!
!
! % Internal variables:
! % t: primitive coordinates (double[qn])
! % t(1):
! % t(2):
! % t(3):
! % t(4):
! % t(5):
! % t(6):
! % t(7):
! % t(8):
! % t(9):
! % t: dummy (double[qn])
! % p: parameter vector
! % npar: length of parameter vector
! %
! % Output variables
! % s: symmetrized coordinates (double[qn])
! % s(1): CH-symetric streatch
! % s(2): CH-asymetric streatch-ex
! % s(3): CH-asymetric streatch-ey
! % s(4): CH-bend-ex
! % s(5): CH-bend-ey
! % s(6): CH-umbrella
! % s(7): CH-umbrella**2
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
module ctrans_pes_mod
use accuracy_constants, only: dp, idp
implicit none
! precalculate pi, 2*pi and angle to radian conversion
real(dp), parameter :: pi = 4.0_dp*datan(1.0_dp)
real(dp), parameter :: pi2 = 2.0_dp*pi
real(dp), parameter :: ang2rad = pi/180.0_dp
! precalculate roots
real(dp), parameter:: sq2 = 1.0_dp/dsqrt(2.0_dp)
real(dp), parameter:: sq3 = 1.0_dp/dsqrt(3.0_dp)
real(dp), parameter:: sq6 = 1.0_dp/dsqrt(6.0_dp)
! change distances for equilibrium
real(dp), parameter :: dchequi = 1.02289024_dp
contains
subroutine ctrans_pes(q, s, t, invariants)
use dim_parameter, only: qn
integer(idp) k !running indices
real(dp), intent(in) :: q(qn) !given coordinates
real(dp), intent(out) :: s(qn) !output coordinates symmetry adapted and scaled
real(dp), intent(out) :: t(qn) !output coordinates symmetry adapted but not scaled
! ANN Variables
real(dp), optional, intent(out) :: invariants(:)
! kartesian coordianates copy from MeF+ so substitute c by n and removed f
real(dp) ch1(3), ch2(3), ch3(3), c_atom(3)
real(dp) nh1(3), nh2(3), nh3(3)
real(dp) zaxis(3), xaxis(3), yaxis(3)
real(dp) ph1(3), ph2(3), ph3(3)
! primitive coordinates
real(dp) dch1, dch2, dch3 !nh-distances
real(dp) umb !Umbrella Angle from xy-plane
! Symmetry coordinates
real(dp) aR !a1-modes H-Dist.,
real(dp) exR, exAng !ex components H-Dist., H-Ang.
real(dp) eyR, eyAng !ey components H-Dist., H-Ang.
! debugging
logical, parameter :: dbg = .false.
! initialize coordinate vectors
s = 0.0_dp
t = 0.0_dp
! write kartesian coords for readability
c_atom = 0.0_dp
do k = 1, 3
ch1(k) = q(k)
ch2(k) = q(k + 3)
ch3(k) = q(k + 6)
end do
! construct z-axis
nh1 = normalized(ch1)
nh2 = normalized(ch2)
nh3 = normalized(ch3)
zaxis = create_plane(nh1, nh2, nh3)
! calculate bonding distance
dch1 = norm(ch1)
dch2 = norm(ch2)
dch3 = norm(ch3)
! construct symmertic and antisymmetric strech
aR = symmetrize(dch1 - dchequi, dch2 - dchequi, dch3 - dchequi, 'a')
exR = symmetrize(dch1, dch2, dch3, 'x')
eyR = symmetrize(dch1, dch2, dch3, 'y')
! construc x-axis and y axis
ph1 = normalized(project_point_into_plane(nh1, zaxis, c_atom))
xaxis = normalized(ph1)
yaxis = xproduct(zaxis, xaxis) ! right hand side koordinates
! project H atoms into C plane
ph2 = normalized(project_point_into_plane(nh2, zaxis, c_atom))
ph3 = normalized(project_point_into_plane(nh3, zaxis, c_atom))
call construct_HBend(exAng, eyAng, ph1, ph2, ph3, xaxis, yaxis)
umb = construct_umbrella(nh1, nh2, nh3, zaxis)
! set symmetry coordinates and even powers of umbrella
s(1) = dch1-dchequi!aR
s(2) = dch2-dchequi!exR
s(3) = dch3-dchequi!eyR
s(4) = exAng
s(5) = eyAng
s(6) = umb
s(7) = umb**2
s(8) = 0
s(9) = 0
! pairwise distances as second coordinate set
t = 0._dp
call pair_distance(q, t(1:6))
call Hplane_pairdistances(ph1,ph2,ph3,t(7:9))
if (dbg) write (6, '("sym coords s=",9f16.8)') s(1:qn)
if (dbg) write (6, '("sym coords t=",9f16.8)') t(1:qn)
if (present(invariants)) then
call get_invariants(s, invariants)
end if
end subroutine ctrans_pes
subroutine pair_distance(q, r)
real(dp), intent(in) :: q(9)
real(dp), intent(out) :: r(6)
real(dp) :: atom(3, 4)
integer :: n, k, count
!atom order: H1 H2 H3 N
atom(:, 1:3) = reshape(q, [3, 3])
atom(:, 4) = (/0.0_dp, 0.0_dp, 0.0_dp/)
! distance order 12 13 14 23 24 34
count = 0
do n = 1, size(atom, 2)
do k = n + 1, size(atom, 2)
count = count + 1
r(count) = sqrt(sum((atom(:, k) - atom(:, n))**2))
end do
end do
end subroutine pair_distance
subroutine Hplane_pairdistances(ph1,ph2,ph3, r)
real(dp), intent(in),dimension(3) :: ph1,ph2,ph3
real(dp), intent(out) :: r(3)
real(dp) :: x(3)
x = ph1-ph2
r(1) = norm(x)
x = ph2-ph3
r(2) = norm(x)
x = ph3-ph1
r(3) = norm(x)
end subroutine Hplane_pairdistances
function morse_and_symmetrize(x,p,pst) result(s)
real(dp), intent(in),dimension(3) :: x
real(dp), intent(in),dimension(11) :: p
integer, intent(in),dimension(2) :: pst
integer :: k
real(dp), dimension(3) :: s
real(dp), dimension(3) :: t
! Morse transform
do k=1,3
t(k) = morse_transform(x(k), p, pst)
end do
s(1) = symmetrize(t(1), t(2), t(3), 'a')
s(2) = symmetrize(t(1), t(2), t(3), 'x')
s(3) = symmetrize(t(1), t(2), t(3), 'y')
end function morse_and_symmetrize
subroutine get_invariants(s, inv_out)
use dim_parameter, only: qn
use select_monom_mod, only: v_e_monom, v_ee_monom
real(dp), intent(in) :: s(qn)
real(dp), intent(out) :: inv_out(:)
! real(dp), parameter :: ck = 1.0_dp, dk = 1.0_dp/ck ! scaling for higher order invariants
real(dp) inv(24)
integer, parameter :: inv_order(12) = & ! the order in which the invariants are selected
& [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12]
real(dp) Rch, umb, xR, yR, xAng, yAng
! for readability
Rch = s(1)
xR = s(2)
yR = s(3)
xAng = s(4)
yAng = s(5)
umb = s(6)**2
! invarianten
! a moden
inv(1) = Rch
inv(2) = umb
! invariante e pairs
inv(3) = v_e_monom(xR, yR, 1)
inv(4) = v_e_monom(xAng, yAng, 1)
! third order e pairs
inv(5) = v_e_monom(xR, yR, 2)
inv(6) = v_e_monom(xAng, yAng, 2)
! invariant ee coupling
inv(7) = v_ee_monom(xR, yR, xAng, yAng, 1)
! mode combinations
inv(8) = Rch*umb
inv(9) = Rch*v_e_monom(xR, yR, 1)
inv(10) = umb*v_e_monom(xR, yR, 1)
inv(11) = Rch*v_e_monom(xAng, yAng, 1)
inv(12) = umb*v_e_monom(xAng, yAng, 1)
! damp coordinates because of second order and higher invariants
inv(3) = sign(sqrt(abs(inv(3))), inv(3))
inv(4) = sign(sqrt(abs(inv(4))), inv(4))
inv(5) = sign((abs(inv(5))**(1./3.)), inv(5))
inv(6) = sign((abs(inv(6))**(1./3.)), inv(6))
inv(7) = sign((abs(inv(7))**(1./3.)), inv(7))
inv(8) = sign(sqrt(abs(inv(8))), inv(8))
inv(9) = sign((abs(inv(9))**(1./3.)), inv(9))
inv(10) = sign((abs(inv(10))**(1./3.)), inv(10))
inv(11) = sign((abs(inv(11))**(1./3.)), inv(11))
inv(12) = sign((abs(inv(12))**(1./3.)), inv(12))
inv_out(:) = inv(inv_order(1:size(inv_out, 1)))
end subroutine get_invariants
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! % real part of spherical harmonics
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Ylm shifted to 0 for theta=0
real(dp) function ylm(theta, phi, l, m)
implicit none
real(dp) theta, phi
integer(idp) l, m
ylm = plm2(dcos(theta), l, m)*cos(m*phi) - plm2(1.0_dp, l, m)
end function ylm
!----------------------------------------------------------
real(dp) function plm2(x, l, n)
implicit none
real(dp) x
integer(idp) l, m, n
real(dp) pmm, p_mp1m, pllm
integer(idp) ll
! negative m und bereich von x abfangen
if ((l .lt. 0)&
&.or. (abs(n) .gt. abs(l))&
&.or. (abs(x) .gt. 1.)) then
write (6, '(''bad arguments in legendre'')')
stop
end if
! fix sign of m to compute the positiv m
m = abs(n)
pmm = (-1)**m*dsqrt(fac(2*m))*1./((2**m)*fac(m))& !compute P(m,m) not P(l,l)
&*(dsqrt(1.-x**2))**m
if (l .eq. m) then
plm2 = pmm !P(l,m)=P(m,m)
else
p_mp1m = x*dsqrt(dble(2*m + 1))*pmm !compute P(m+1,m)
if (l .eq. m + 1) then
plm2 = p_mp1m !P(l,m)=P(m+1,m)
else
do ll = m + 2, l
pllm = x*(2*l - 1)/dsqrt(dble(l**2 - m**2))*p_mp1m& ! compute P(m+2,m) up to P(l,m) recursively
&- dsqrt(dble((l - 1)**2 - m**2))&
&/dsqrt(dble(l**2 - m**2))*pmm
! schreibe m+2 und m+1 jeweils fuer die naechste iteration
pmm = p_mp1m !P(m,m) = P(m+1,m)
p_mp1m = pllm !P(m+1,m) = P(m+2,m)
end do
plm2 = pllm !P(l,m)=P(m+k,m), k element N
end if
end if
! sets the phase of -m term right (ignored to gurantee Ylm=(Yl-m)* for JT terms
! if(n.lt.0) then
! plm2 = (-1)**m * plm2 !* fac(l-m)/fac(l+m)
! endif
end function
!----------------------------------------------------------------------------------------------------
real(dp) function fac(i)
integer(idp) i
select case (i)
case (0)
fac = 1.0_dp
case (1)
fac = 1.0_dp
case (2)
fac = 2.0_dp
case (3)
fac = 6.0_dp
case (4)
fac = 24.0_dp
case (5)
fac = 120.0_dp
case (6)
fac = 720.0_dp
case (7)
fac = 5040.0_dp
case (8)
fac = 40320.0_dp
case (9)
fac = 362880.0_dp
case (10)
fac = 3628800.0_dp
case (11)
fac = 39916800.0_dp
case (12)
fac = 479001600.0_dp
case default
write (*, *) 'ERROR: no case for given faculty, Max is 12!'
stop
end select
end function fac
! Does the simplest morse transform possible
! one skaling factor + shift
function morse_transform(x, p, pst) result(t)
real(dp), intent(in) :: x
real(dp), intent(in) :: p(11)
integer, intent(in) :: pst(2)
real(dp) :: t
if (pst(2) == 11) then
t = 1.0_dp - exp(-abs(p(2))*(x - p(1)))
else
error stop 'in morse_transform key required or wrong number of parameters'
end if
end function morse_transform
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! % FUNCTION F(...) ! MAIK DEPRICATING OVER THE TOP MORSE FUNCTION FOR MYSELF
! %
! % Returns exponent of tunable Morse coordinate
! % exponent is polynomial * gaussian (skewed)
! % ilabel = 1 or 2 selects the parameters a and sfac to be used
! %
! % Background: better representation of the prefector in the
! % exponend of the morse function.
! % Formular: f(r) = lest no3 paper
! %
! % Variables:
! % x: distance of atoms (double)
! % p: parameter vector (double[20])
! % ii: 1 for CCl and 2 for CCH (int)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
pure function f(x, p, ii)
integer(idp), intent(in) :: ii !1 for CCL and 2 for CCH
real(dp), intent(in) :: x !coordinate
real(dp), intent(in) :: p(11) !parameter-vector
integer(idp) i !running index
real(dp) r !equilibrium distance
real(dp) gaus !gaus part of f
real(dp) poly !polynom part of f
real(dp) skew !tanh part of f
real(dp) f !prefactor of exponent and returned value
integer(idp) npoly(2) !order of polynom
! Maximum polynom order
npoly(1) = 5
npoly(2) = 5
! p(1): position of equilibrium
! p(2): constant of exponent
! p(3): constant for skewing the gaussian
! p(4): tuning for skewing the gaussian
! p(5): Gaussian exponent
! p(6): Shift of Gaussian maximum
! p(7)...: polynomial coefficients
! p(8+n)...: coefficients of Morse Power series
! 1-exp{[p(2)+exp{-p(5)[x-p(6)]^2}[Taylor{p(7+n)}(x-p(6))]][x-p(1)]}
! Tunable Morse function
! Power series in Tunable Morse coordinates of order m
! exponent is polynomial of order npoly * gaussian + switching function
! set r r-r_e
r = x
r = r - p(1)
! set up skewing function:
skew = 0.5_dp*p(3)*(dtanh(dabs(p(4))*(r - p(6))) + 1.0_dp)
! set up gaussian function:
gaus = dexp(-dabs(p(5))*(r - p(6))**2)
! set up power series:
poly = 0.0_dp
do i = 0, npoly(ii) - 1
poly = poly + p(7 + i)*(r - p(6))**i
end do
! set up full exponent function:
f = dabs(p(2)) + skew + gaus*poly
end function
!----------------------------------------------------------------------------------------------------
pure function xproduct(a, b) result(axb)
real(dp), intent(in) :: a(3), b(3)
real(dp) :: axb(3) !crossproduct a x b
axb(1) = a(2)*b(3) - a(3)*b(2)
axb(2) = a(3)*b(1) - a(1)*b(3)
axb(3) = a(1)*b(2) - a(2)*b(1)
end function xproduct
pure function normalized(v) result(r)
real(dp), intent(in) :: v(:)
real(dp) :: r(size(v))
r = v/norm(v)
end function normalized
pure function norm(v) result(n)
real(dp), intent(in) :: v(:)
real(dp) n
n = dsqrt(sum(v(:)**2))
end function norm
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! % FUNCTION Project_Point_Into_Plane(x,n,r0) result(p)
! % return the to n orthogonal part of a vector x-r0
! % p: projected point in plane
! % x: point being projected
! % n: normalvector of plane
! % r0: Point in plane
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
pure function project_point_into_plane(x, n, r0) result(p)
real(dp), intent(in) :: x(:), n(:), r0(:)
real(dp) :: p(size(x)), xs(size(x))
xs = x - r0
p = xs - plane_to_point(x, n, r0)
end function project_point_into_plane
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! % Function Plane_To_Point(x,n,r0) result(p)
! % p: part of n in x
! % x: point being projected
! % n: normalvector of plane
! % r0: Point in plane
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
pure function plane_to_point(x, n, r0) result(p)
real(dp), intent(in) :: x(:), n(:), r0(:)
real(dp) p(size(x)), xs(size(x)), nn(size(n))
nn = normalized(n)
xs = x - r0
p = dot_product(nn, xs)*nn
end function plane_to_point
subroutine check_coordinates(q)
! check for faulty kartesain coordinates
real(dp), intent(in) :: q(:)
integer(idp) :: i
if (all(abs(q) <= epsilon(0.0_dp))) then
stop 'Error (ctrans): all kartesian coordinates are<=1d-8'
end if
do i = 1, 9, 3
if (all(abs(q(i:i + 2)) <= epsilon(0.0_dp))) then
write (*, *) q
stop 'Error(ctrans):kartesian coordinates zero for one atom'
end if
end do
end subroutine
pure function rotor_a_to_z(a, z) result(r)
real(dp), intent(in) :: a(3), z(3)
real(dp) :: r(3, 3)
real(dp) :: alpha
real(dp) :: s1(3), s(3, 3), rotor(3, 3)
s1 = xproduct(normalized(a), normalized(z))
alpha = asin(norm(s1))
s(:, 1) = normalized(s1)
s(:, 2) = normalized(z)
s(:, 3) = xproduct(s1, z)
rotor = init_rotor(alpha, 0.0_dp, 0.0_dp)
r = matmul(s, matmul(rotor, transpose(s)))
end function
! function returning Rz(gamma) * Ry(beta) * Rx(alpha) for basis order xyz
pure function init_rotor(alpha, beta, gamma) result(rotor)
real(dp), intent(in) :: alpha, beta, gamma
real(dp) :: rotor(3, 3)
rotor = 0.0_dp
rotor(1, 1) = dcos(beta)*dcos(gamma)
rotor(1, 2) = dsin(alpha)*dsin(beta)*dcos(gamma)&
&- dcos(alpha)*dsin(gamma)
rotor(1, 3) = dcos(alpha)*dsin(beta)*dcos(gamma)&
&+ dsin(alpha)*dsin(gamma)
rotor(2, 1) = dcos(beta)*dsin(gamma)
rotor(2, 2) = dsin(alpha)*dsin(beta)*dsin(gamma)&
&+ dcos(alpha)*dcos(gamma)
rotor(2, 3) = dcos(alpha)*dsin(beta)*dsin(gamma)&
&- dsin(alpha)*dcos(gamma)
rotor(3, 1) = -dsin(beta)
rotor(3, 2) = dsin(alpha)*dcos(beta)
rotor(3, 3) = dcos(alpha)*dcos(beta)
end function init_rotor
pure function create_plane(a, b, c) result(n)
real(dp), intent(in) :: a(3), b(3), c(3)
real(dp) :: n(3)
real(dp) :: axb(3), bxc(3), cxa(3)
axb = xproduct(a, b)
bxc = xproduct(b, c)
cxa = xproduct(c, a)
n = normalized(axb + bxc + cxa)
end function create_plane
function symmetrize(q1, q2, q3, sym) result(s)
real(dp), intent(in) :: q1, q2, q3
character, intent(in) :: sym
real(dp) :: s
select case (sym)
case ('a')
s = (q1 + q2 + q3)*sq3
case ('x')
s = sq6*(2.0_dp*q1 - q2 - q3)
case ('y')
s = sq2*(q2 - q3)
case default
write (*, *) 'ERROR: no rule for symmetrize with sym=', sym
stop
end select
end function symmetrize
subroutine construct_HBend(ex, ey, ph1, ph2, ph3, x_axis, y_axis)
real(dp), intent(in) :: ph1(3), ph2(3), ph3(3)
real(dp), intent(in) :: x_axis(3), y_axis(3)
real(dp), intent(out) :: ex, ey
real(dp) :: x1, y1, alpha1
real(dp) :: x2, y2, alpha2
real(dp) :: x3, y3, alpha3
! get x and y components of projected points
x1 = dot_product(ph1, x_axis)
y1 = dot_product(ph1, y_axis)
x2 = dot_product(ph2, x_axis)
y2 = dot_product(ph2, y_axis)
x3 = dot_product(ph3, x_axis)
y3 = dot_product(ph3, y_axis)
! -> calculate H deformation angles
alpha3 = datan2(y2, x2)
alpha2 = -datan2(y3, x3) !-120*ang2rad
! write(*,*)' atan2'
! write(*,*) 'alpha2:' , alpha2/ang2rad
! write(*,*) 'alpha3:' , alpha3/ang2rad
if (alpha2 .lt. 0) alpha2 = alpha2 + pi2
if (alpha3 .lt. 0) alpha3 = alpha3 + pi2
alpha1 = (pi2 - alpha2 - alpha3)
! write(*,*)' fixed break line'
! write(*,*) 'alpha1:' , alpha1/ang2rad
! write(*,*) 'alpha2:' , alpha2/ang2rad
! write(*,*) 'alpha3:' , alpha3/ang2rad
alpha1 = alpha1 !- 120.0_dp*ang2rad
alpha2 = alpha2 !- 120.0_dp*ang2rad
alpha3 = alpha3 !- 120.0_dp*ang2rad
! write(*,*)' delta alpha'
! write(*,*) 'alpha1:' , alpha1/ang2rad
! write(*,*) 'alpha2:' , alpha2/ang2rad
! write(*,*) 'alpha3:' , alpha3/ang2rad
! write(*,*)
! construct symmetric and antisymmetric H angles
ex = symmetrize(alpha1, alpha2, alpha3, 'x')
ey = symmetrize(alpha1, alpha2, alpha3, 'y')
end subroutine construct_HBend
pure function construct_umbrella(nh1, nh2, nh3, n)&
&result(umb)
real(dp), intent(in) :: nh1(3), nh2(3), nh3(3)
real(dp), intent(in) :: n(3)
real(dp) :: umb
real(dp) :: theta(3)
! calculate projections for umberella angle
theta(1) = dacos(dot_product(n, nh1))
theta(2) = dacos(dot_product(n, nh2))
theta(3) = dacos(dot_product(n, nh3))
! construct umberella angle
umb = sum(theta(1:3))/3.0_dp - 90.0_dp*ang2rad
end function construct_umbrella
pure subroutine construct_sphericals&
&(theta, phi, cf, xaxis, yaxis, zaxis)
real(dp), intent(in) :: cf(3), xaxis(3), yaxis(3), zaxis(3)
real(dp), intent(out) :: theta, phi
real(dp) :: x, y, z, v(3)
v = normalized(cf)
x = dot_product(v, normalized(xaxis))
y = dot_product(v, normalized(yaxis))
z = dot_product(v, normalized(zaxis))
theta = dacos(z)
phi = -datan2(y, x)
end subroutine construct_sphericals
subroutine int2kart(internal, kart)
real(dp), intent(in) :: internal(6)
real(dp), intent(out) :: kart(9)
real(dp) :: h1x, h1y, h1z
real(dp) :: h2x, h2y, h2z
real(dp) :: h3x, h3y, h3z
real(dp) :: dch0, dch1, dch2, dch3
real(dp) :: a1, a2, a3, wci
kart = 0.0_dp
dch1 = dchequi + sq3*internal(1) + 2*sq6*internal(2)
dch2 = dchequi + sq3*internal(1) - sq6*internal(2) + sq2*internal(3)
dch3 = dchequi + sq3*internal(1) - sq6*internal(2) - sq2*internal(3)
a1 = 2*sq6*internal(4)
a2 = -sq6*internal(4) + sq2*internal(5)
a3 = -sq6*internal(4) - sq2*internal(5)
wci = internal(6)
! Berechnung kartesische Koordinaten
! -----------------------
h1x = dch1*cos(wci*ang2rad)
h1y = 0.0
h1z = -dch1*sin(wci*ang2rad)
h3x = dch2*cos((a2 + 120)*ang2rad)*cos(wci*ang2rad)
h3y = dch2*sin((a2 + 120)*ang2rad)*cos(wci*ang2rad)
h3z = -dch2*sin(wci*ang2rad)
h2x = dch3*cos((-a3 - 120)*ang2rad)*cos(wci*ang2rad)
h2y = dch3*sin((-a3 - 120)*ang2rad)*cos(wci*ang2rad)
h2z = -dch3*sin(wci*ang2rad)
kart(1) = h1x
kart(2) = h1y
kart(3) = h1z
kart(4) = h2x
kart(5) = h2y
kart(6) = h2z
kart(7) = h3x
kart(8) = h3y
kart(9) = h3z
end subroutine int2kart
end module ctrans_pes_mod

982
src/model/new_PES/pes_model.f90
View File

@ -1,982 +0,0 @@
module diab_pes
use dim_parameter, only: qn, ndiab, pst
use accuracy_constants, only: dp, idp
implicit none
logical :: debug = .false.
! real(dp),parameter :: nuclear_energy_shift = 11.76027390_dp
real(dp), parameter :: nuclear_energy_shift = 0.881380_dp
real(dp), parameter :: ang2bohr = 1.0/0.52917721067_dp
real(dp), parameter :: a1_asymptote = 0.205024_dp*3._dp
!--------------------------------------------------------------------
contains
!--------------------------------------------------------------------
subroutine pote(e, n, q, s, t, p, npar)
integer(idp), intent(in) :: npar !number of parameters
integer(idp), intent(in) :: n
real(dp), intent(out) :: e(ndiab, ndiab)
real(dp), intent(in) :: q(qn), s(qn), t(qn) !< transformed coordinates
real(dp), intent(in), contiguous :: p(:)
call model_matrix(e, s, t, p)
end Subroutine
!----------------------------------------------------------------------------------------------------
! calculate core repulsion potential depending on the shortest distance r and allow it only at values smaller than xmax
function core_core_rmin(r, p) result(v)
real(dp), intent(in) :: r(:)
real(dp), intent(in) :: p(:)
real(dp) :: v
real(dp) :: shift, width, rmin
if(size(p,1) /= 3) error stop 'Expected 3 parameters in core_core_min()'
rmin = minval(r)
v = p(1)/abs(rmin)
shift = p(2)
width = p(3)
v = v*(1._dp - smootherstep(rmin, shift, width))
end function core_core_rmin
! calculating the nuclear repulsion energy for a given set of pairwise distances and given nuclear charges
function nuclear_repulsion(r, charge) result(v)
real(dp), intent(in) :: r(:)
real(dp), intent(in) :: charge(:)
real(dp) :: v
v = sum(charge(:)/abs(r(:)))
end function nuclear_repulsion
pure function smootherstep(x, shift, width) result(s)
real(dp), intent(in) :: x, shift, width
real(dp) :: s, q
q = (x - shift)/width
if (x <= 0._dp) then
s = 0._dp
else if (x >= 1._dp) then
s = 1._dp
else
s = 6._dp*q**5 - 15*q**4 + 10*q**3
end if
end function smootherstep
function pairwise_charge(charge) result(v)
real(dp), intent(in) :: charge(:)
real(dp), dimension(:), allocatable :: v
integer :: n, k, count
allocate (v(size(charge)*(size(charge) - 1)/2), source=0._dp)
count = 0
do n = 1, size(charge, 1)
do k = n + 1, size(charge, 1)
count = count + 1
v(count) = charge(n)*charge(k)
end do
end do
end function pairwise_charge
function nuclear_repulsion_model(r, p) result(v)
real(dp), dimension(:), intent(in) :: r
real(dp), dimension(:), intent(in) :: p
real(dp) :: v
integer :: key, start, ende
key = 86
if (pst(2, key) == 0) then
v = 0._dp
return
end if
start = pst(1, key)
ende = start + pst(2, key) - 1
v = nuclear_repulsion(r(1:6)*ang2bohr, pairwise_charge(p(start+1:ende))) - p(start)
! v = core_core_rmin(r([1, 2, 4]), p(start:ende))
end function nuclear_repulsion_model
!----------------------------------------------------------------------------------------------------
! <constructing the actuall matrix element expansion with given coordinates and parameters
! <note: parameter vector is here npar+1 long to solve problem with pst values writing over memory
subroutine model_matrix(e, s_in, t, p, split_ref)
! use ctrans_mod, only: morse_transform
use ctrans_pes_mod, only: morse_and_symmetrize
integer, optional, intent(in) :: split_ref
real(dp), intent(out) :: e(:, :) !< diabatic model matrix
real(dp), intent(in) :: s_in(qn), t(qn) !< transformed coordinates
real(dp) :: s(qn)
real(dp), intent(in), contiguous :: p(:) !< parameter vector
real(dp) :: tmp_v, tmp_wz(2) !< dummy for expansion terms
integer(idp) :: key
real(dp) :: e_nuclear
integer :: k
s = s_in
!transform morse coordinate
! s(1) = morse_transform(s_in(1), p(pst(1, 2):), pst(:, 2))
s(1:3) = morse_and_symmetrize(s_in(1:3), p(pst(1, 2):), pst(:, 2))
e = 0.0_dp
! shift diagonal terms so that E1 is 0 at first point
e(1, 1) = p(pst(1, 1)) - p(pst(1, 1))
e(2, 2) = p(pst(1, 1) + 1) - p(pst(1, 1))
e(3, 3) = p(pst(1, 1) + 2) - p(pst(1, 1))
e(4, 4) = p(pst(1, 1) + 3) - p(pst(1, 1))
! !add nuclear repulsion energy
e_nuclear = nuclear_repulsion_model(t, p)
do k = 1, ndiab
e(k, k) = e(k, k) + e_nuclear
end do
if (present(split_ref)) then
if (split_ref == 1) then
e = 0._dp
end if
end if
!Start of Element: EV 3
!Start of Element: A2V 18
!Start of Element: A1V 33
!Start of Element: EWZ 48
!Start of Element: A1EWZ 60
!Start of Element: A2EQWZ 72
!Start of Element: A2A1Q 78
key = 18 ! A2V
if (debug) write (*, *) 'A2V Element'
tmp_v = v_element(p, key, s, split_ref)
e(1, 1) = e(1, 1) + tmp_v
key = 3 ! EV
if (debug) write (*, *) 'EV Element'
tmp_v = v_element(p, key, s, split_ref)
key = 48 ! EWZ
if (debug) write (*, *) 'EWZ Element'
tmp_wz = wz_element(p, key, s, t, split_ref)
e(2, 2) = e(2, 2) + tmp_v + tmp_wz(1)
e(3, 3) = e(3, 3) + tmp_v - tmp_wz(1)
e(2, 3) = e(2, 3) + tmp_wz(2)
key = 72 ! A2EQWZ
if (debug) write (*, *) 'A2EQWZ Element'
tmp_wz = qwz_element(p, key, s, t, split_ref)
e(1, 2) = e(1, 2) + tmp_wz(1)
e(1, 3) = e(1, 3) - tmp_wz(2)
key = 60 ! A1EWZ
if (debug) write (*, *) 'A1EWZ Element'
tmp_wz = wz_element(p, key, s, t, split_ref)
e(2, 4) = e(2, 4) + tmp_wz(1)
e(3, 4) = e(3, 4) - tmp_wz(2)
key = 33 ! A1V
if (debug) write (*, *) 'A1V Element'
tmp_v = v_element(p, key, s, split_ref)
e(4, 4) = e(4, 4) + tmp_v
key = 78 ! A2A1Q
if (debug) write (*, *) 'A2A1Q Element'
tmp_v = q_element(p, key, s, t, split_ref)
e(1, 4) = e(1, 4) + tmp_v
call copy_2_lower_triangle(e)
if (debug) then
write (*, *) 'diabatic model matrix:'
do k = 1, ndiab
write (*, '(*(F24.8))') e(k, :)
end do
write (*, *) ' '
end if
end subroutine model_matrix
!----------------------------------------------------------------------------------------------------
subroutine copy_2_lower_triangle(mat)
real(dp), intent(inout) :: mat(:, :)
integer :: m, n
! write lower triangle of matrix symmetrical
do n = 2, size(mat, 1)
do m = 1, n - 1
mat(n, m) = mat(m, n)
end do
end do
end subroutine copy_2_lower_triangle
!----------------------------------------------------------------------------------------------------
function v_element(p, key, x, split_ref) result(v)
integer, optional, intent(in) :: split_ref
real(dp) :: v
real(dp), intent(in) :: p(:), x(:)
integer(idp), intent(in) :: key
v = v_a(p, key, x(1))
! v = v_a_d(p, key, x(1),nuclear_energy_shift+a1_asymptote) ! Maik test asymptot for given d
v = v + v_a(p, key + 1, x(7), split_ref)
v = v + v_e(p, key + 2, x(2), x(3), split_ref)
v = v + v_e(p, key + 3, x(4), x(5), split_ref)
if (present(split_ref)) then
if (split_ref == 0) return
end if
v = v + v_aa(p, key + 4, x(1), x(7))
v = v + v_ae(p, key + 5, x(1), x(2), x(3))
v = v + v_ae(p, key + 6, x(1), x(4), x(5))
v = v + v_ae(p, key + 7, x(7), x(2), x(3))
v = v + v_ae(p, key + 8, x(7), x(4), x(5))
v = v + v_ee(p, key + 9, x(2), x(3), x(4), x(5))
v = v + v_aae(p, key + 10, x(1), x(7), x(2), x(3))
v = v + v_aae(p, key + 11, x(1), x(7), x(4), x(5))
v = v + v_aee(p, key + 12, x(1), x(2), x(3), x(4), x(5))
v = v + v_aee(p, key + 13, x(7), x(2), x(3), x(4), x(5))
v = v + v_aaee(p, key + 14, x(1), x(7), x(2), x(3), x(4), x(5))
end function v_element
function wz_element(p, key, s, t, split_ref) result(wz)
integer, optional, intent(in) :: split_ref
real(dp) :: wz(2)
real(dp), intent(in) :: p(:), s(:), t(:)
integer(idp), intent(in) :: key
wz = 0.0_dp
call wz_e(wz, p, key, s(2), s(3), split_ref)
call wz_e(wz, p, key + 1, s(4), s(5), split_ref)
if (present(split_ref)) then
if (split_ref == 0) return
end if
call wz_ae(wz, p, key + 2, s(1), s(2), s(3))
call wz_ae(wz, p, key + 3, s(1), s(4), s(5))
call wz_ae(wz, p, key + 4, s(7), s(2), s(3))
call wz_ae(wz, p, key + 5, s(7), s(4), s(5))
call wz_aae(wz, p, key + 6, s(1), s(7), s(2), s(3))
call wz_aae(wz, p, key + 7, s(1), s(7), s(4), s(5))
call wz_ee(wz, p, key + 8, s(2), s(3), s(4), s(5))
call wz_aee(wz, p, key + 9, s(1), s(2), s(3), s(4), s(5))
call wz_aee(wz, p, key + 10, s(7), s(2), s(3), s(4), s(5))
call wz_aaee(wz, p, key + 11, s(1), s(7), s(2), s(3), s(4), s(5))
end function wz_element
function q_element(p, key, s, t, split_ref) result(q)
integer, optional, intent(in) :: split_ref
real(dp) :: q
real(dp), intent(in) :: p(:), s(:), t(:)
integer(idp), intent(in) :: key
q = 0.0_dp
q = q + q_u(p, key, s(6), split_ref)
if (present(split_ref)) then
if (split_ref == 0) return
end if
q = q + q_ua(p, key + 1, s(6), s(1))
q = q + q_ue(p, key + 2, s(6), s(2), s(3))
q = q + q_ue(p, key + 3, s(6), s(4), s(5))
q = q + q_uae(p, key + 4, s(6), s(1), s(2), s(3))
q = q + q_uae(p, key + 5, s(6), s(1), s(4), s(5))
q = q + q_uee(p, key + 6, s(6), s(2), s(3), s(4), s(5))
q = q + q_uaee(p, key + 7, s(6), s(1), s(2), s(3), s(4), s(5))
end function q_element
function qwz_element(p, key, s, t, split_ref) result(qwz)
integer, optional, intent(in) :: split_ref
real(dp), dimension(2) :: qwz
real(dp), intent(in) :: p(:), s(:), t(:)
integer(idp), intent(in) :: key
qwz = 0.0_dp
call qwz_ue(qwz, p, key, s(6), s(2), s(3), split_ref)
call qwz_ue(qwz, p, key + 1, s(6), s(4), s(5), split_ref)
if (present(split_ref)) then
if (split_ref == 0) return
end if
call qwz_uae(qwz, p, key + 2, s(6), s(1), s(2), s(3))
call qwz_uae(qwz, p, key + 3, s(6), s(1), s(4), s(5))
call qwz_uee(qwz, p, key + 4, s(6), s(2), s(3), s(4), s(5))
call qwz_uaee(qwz, p, key + 5, s(6), s(1), s(2), s(3), s(4), s(5))
end function qwz_element
subroutine index_split_ref(ii, ee, split, split_ref)
integer(idp), intent(inout) :: ii, ee
integer(idp), intent(in) :: split
integer, optional, intent(in) :: split_ref
if (present(split_ref)) then
select case (split_ref)
case (0)
ee = split
case (1)
ii = split + 1
end select
end if
end subroutine index_split_ref
function v_a(p, key, a, split_ref) result(v)
integer, optional, intent(in) :: split_ref
real(dp) v
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), a
integer(idp) :: i, pstart
integer(idp) :: ii, ee
v = 0.d0; pstart = pst(1, key)
ii = 1; ee = pst(2, key)
call index_split_ref(ii, ee, 2, split_ref)
do i = ii, ee
v = v + a**i*p(pstart + (i - 1))
end do
end function v_a
function v_a_d(p, key, a, d) result(v)
!variant of v_a that forces the sum of parameters add up to the given value d
real(dp) v
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), a, d
integer(idp) :: i, pstart
integer(idp) :: ii, ee
v = 0.d0; pstart = pst(1, key)
ii = 1; ee = pst(2, key)
do i = ii, ee
v = v + a**i*p(pstart + (i - 1))
end do
v = v + a**(ee + 1)*(d - sum(p(pstart:pstart + ee - 1)))
end function v_a_d
!----------------------------------------------------------------------------------------------------
function v_e(p, key, x, y, split_ref) result(v)
use select_monom_mod, only: v_e_monom
integer, optional, intent(in) :: split_ref
real(dp) v
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), x, y !koordinates
integer(idp) :: i, pstart
integer(idp) :: ii, ee
v = 0.d0; pstart = pst(1, key)
ii = 1; ee = pst(2, key)
call index_split_ref(ii, ee, 1, split_ref)
do i = ii, ee
v = v + p(pstart + (i - 1))*v_e_monom(x, y, i)
end do
end function v_e
!----------------------------------------------------------------------------------------------------
function v_aa(p, key, a, b) result(v)
use select_monom_mod, only: v_aa_monom
real(dp) :: v
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), a, b
integer(idp) :: pstart, i
v = 0.d0; pstart = pst(1, key)
do i = 1, pst(2, key)
v = v + p(pstart + (i - 1))*v_aa_monom(a, b, i)
end do
end function v_aa
!----------------------------------------------------------------------------------------------------
function v_aaa(p, key, a, b, c) result(v)
use select_monom_mod, only: v_aaa_monom
real(dp) :: v
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), a, b, c
integer(idp) :: pstart, i
v = 0.d0; pstart = pst(1, key)
do i = 1, pst(2, key)
v = v + p(pstart + (i - 1))*v_aaa_monom(a, b, c, i)
end do
end function v_aaa
!----------------------------------------------------------------------------------------------------
function v_ae(p, key, a, x, y) result(v)
use select_monom_mod, only: v_ae_monom
real(dp) :: v
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), a, x, y
integer(idp) :: i, pstart
v = 0.d0; pstart = pst(1, key)
do i = 1, pst(2, key)
v = v + p(pstart + (i - 1))*v_ae_monom(a, x, y, i)
end do
end function v_ae
!----------------------------------------------------------------------------------------------------
function v_ee(p, key, x1, y1, x2, y2) result(v)
use select_monom_mod, only: v_ee_monom
real(dp) :: v
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), x1, y1, x2, y2
integer(idp) :: i, pstart
v = 0.d0; pstart = pst(1, key)
do i = 1, pst(2, key);
v = v + p(pstart + (i - 1))*v_ee_monom(x1, y1, x2, y2, i)
end do
end function v_ee
!----------------------------------------------------------------------------------------------------
function v_aae(p, key, a, b, x, y) result(v)
use select_monom_mod, only: v_aae_monom
real(dp) :: v
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), a, b, x, y
integer(idp) :: i, pstart
v = 0.d0; pstart = pst(1, key)
do i = 1, pst(2, key)
v = v + p(pstart + (i - 1))*v_aae_monom(a, b, x, y, i)
end do
end function v_aae
!----------------------------------------------------------------------------------------------------
function v_aaae(p, key, a, b, c, x, y) result(v)
use select_monom_mod, only: v_aaae_monom
real(dp) :: v
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), a, b, c, x, y
integer(idp) :: i, pstart
v = 0.d0; pstart = pst(1, key)
do i = 1, pst(2, key)
v = v + p(pstart + (i - 1))*v_aaae_monom(a, b, c, x, y, i)
end do
end function v_aaae
!----------------------------------------------------------------------------------------------------
function v_aee(p, key, a, x1, y1, x2, y2) result(v)
use select_monom_mod, only: v_aee_monom
real(dp) :: v
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), a, x1, y1, x2, y2
integer(idp) :: i, pstart
v = 0.d0; pstart = pst(1, key)
do i = 1, pst(2, key);
v = v + p(pstart + (i - 1))*v_aee_monom(a, x1, y1, x2, y2, i)
end do
end function v_aee
!----------------------------------------------------------------------------------------------------
function v_eee(p, key, x1, y1, x2, y2, x3, y3) result(v)
use select_monom_mod, only: v_eee_monom
real(dp) :: v
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), x1, y1, x2, y2, x3, y3
integer(idp) :: i, pstart
v = 0.0_dp; pstart = pst(1, key)
do i = 1, pst(2, key)
v = v + p(pstart + (i - 1))*v_eee_monom(x1, y1, x2, y2, x3, y3, i)
end do
end function v_eee
!----------------------------------------------------------------------------------------------------
function v_aaee(p, key, a, b, x1, y1, x2, y2) result(v)
use select_monom_mod, only: v_aaee_monom
real(dp) :: v
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), a, b, x1, y1, x2, y2
integer(idp) :: i, pstart
v = 0.d0; pstart = pst(1, key)
do i = 1, pst(2, key);
v = v + p(pstart + (i - 1))*v_aaee_monom(a, b, x1, y1, x2, y2, i)
end do
end function v_aaee
!----------------------------------------------------------------------------------------------------
function v_aaaee(p, key, a, b, c, x1, y1, x2, y2) result(v)
use select_monom_mod, only: v_aaaee_monom
real(dp) :: v
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), a, b, c, x1, y1, x2, y2
integer(idp) :: i, pstart
v = 0.d0; pstart = pst(1, key)
do i = 1, pst(2, key);
v = v&
&+ p(pstart + (i - 1))*v_aaaee_monom(a, b, c, x1, y1, x2, y2, i)
end do
end function v_aaaee
!----------------------------------------------------------------------------------------------------
function v_aeee(p, key, a, x1, y1, x2, y2, x3, y3) result(v)
use select_monom_mod, only: v_aeee_monom
real(dp) :: v
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), a, x1, y1, x2, y2, x3, y3
integer(idp) :: i, pstart
v = 0.0_dp; pstart = pst(1, key)
do i = 1, pst(2, key)
v = v + p(pstart + (i - 1))*v_aeee_monom(a, x1, y1, x2, y2, x3, y3,&
&i)
end do
end function v_aeee
!====================================================================================================
! function wz_e(p,key,x,y) result(wz)
! use select_monom_mod,only : w_e_monom, z_e_monom
! real(dp) :: wz(2)
! integer(idp),intent(in) :: key
! real(dp),intent(in) :: p(:), x, y
! integer(idp) :: i, pstart
! wz = 0.d0; pstart = pst(1,key)
! do i =1,pst(2,key)
! wz(1) = wz(1) + p(pstart+(i-1)) * w_e_monom(x,y,i)
! wz(2) = wz(2) + p(pstart+(i-1)) * z_e_monom(x,y,i)
! enddo
! ! if(debug) write(*,*) 'wz_e=', wz(1:2)
! end function wz_e
subroutine wz_e(wz, p, key, x, y, split_ref)
use select_monom_mod, only: w_e_monom, z_e_monom
integer, optional, intent(in) :: split_ref
real(dp), intent(inout) :: wz(2)
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), x, y
integer(idp) :: i, pstart
integer(idp) :: ii, ee
pstart = pst(1, key)
ii = 1; ee = pst(2, key)
call index_split_ref(ii, ee, 1, split_ref)
do i = ii, ee
wz(1) = wz(1) + p(pstart + (i - 1))*w_e_monom(x, y, i)
wz(2) = wz(2) + p(pstart + (i - 1))*z_e_monom(x, y, i)
end do
end subroutine wz_e
!----------------------------------------------------------------------------------------------------
! function wz_ae(p,key,a,x,y) result(wz)
! use select_monom_mod,only : w_ae_monom, z_ae_monom
! real(dp) :: wz(2)
! integer(idp),intent(in) :: key
! real(dp),intent(in) :: p(:), a, x, y
! integer(idp) :: i, pstart
! wz = 0.d0; pstart = pst(1,key)
! do i = 1, pst(2,key)
! wz(1) = wz(1) + p(pstart+(i-1)) * w_ae_monom(a, x, y, i)
! wz(2) = wz(2) + p(pstart+(i-1)) * z_ae_monom(a, x, y, i)
! enddo
! ! if(debug) write(*,*) 'wz_ae=', wz(1:2)
! end function wz_ae
subroutine wz_ae(wz, p, key, a, x, y)
use select_monom_mod, only: w_ae_monom, z_ae_monom
real(dp), intent(inout) :: wz(2)
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), a, x, y
integer(idp) :: i, pstart
pstart = pst(1, key)
do i = 1, pst(2, key)
wz(1) = wz(1) + p(pstart + (i - 1))*w_ae_monom(a, x, y, i)
wz(2) = wz(2) + p(pstart + (i - 1))*z_ae_monom(a, x, y, i)
end do
! if(debug) write(*,*) 'wz_ae=', wz(1:2)
end subroutine wz_ae
!----------------------------------------------------------------------------------------------------
! function wz_aae(p,key,a,b,x,y) result(wz)
! use select_monom_mod,only : w_aae_monom, z_aae_monom
! real(dp) :: wz(2)
! integer(idp),intent(in) :: key
! real(dp),intent(in) :: p(:), a,b, x, y
! integer(idp) :: i, pstart
! wz = 0.d0; pstart = pst(1,key)
! do i = 1, pst(2,key)
! wz(1) = wz(1) + p(pstart+(i-1)) * w_aae_monom(a,b, x, y, i)
! wz(2) = wz(2) + p(pstart+(i-1)) * z_aae_monom(a,b, x, y, i)
! enddo
! ! if(debug) write(*,*) 'wz_aae=', wz(1:2)
! end function wz_aae
subroutine wz_aae(wz, p, key, a, b, x, y)
use select_monom_mod, only: w_aae_monom, z_aae_monom
real(dp), intent(inout) :: wz(2)
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), a, b, x, y
integer(idp) :: i, pstart
pstart = pst(1, key)
do i = 1, pst(2, key)
wz(1) = wz(1) + p(pstart + (i - 1))*w_aae_monom(a, b, x, y, i)
wz(2) = wz(2) + p(pstart + (i - 1))*z_aae_monom(a, b, x, y, i)
end do
! if(debug) write(*,*) 'wz_aae=', wz(1:2)
end subroutine wz_aae
!----------------------------------------------------------------------------------------------------
! function wz_ee(p,key,x1,y1,x2,y2) result(wz)
! use select_monom_mod,only : w_ee_monom, z_ee_monom
! real(dp) wz(2)
! integer(idp),intent(in) :: key
! real(dp),intent(in) :: p(:), x1, y1, x2, y2
! integer(idp) :: i, pstart
! wz = 0.d0; pstart = pst(1,key)
! do i = 1, pst(2,key)
! wz(1) = wz(1) + p(pstart+(i-1)) * w_ee_monom(x1, y1, x2, y2, i)
! wz(2) = wz(2) + p(pstart+(i-1)) * z_ee_monom(x1, y1, x2, y2, i)
! enddo
! ! if(debug) write(*,*) 'wz_ee=', wz(1:2)
! end function wz_ee
subroutine wz_ee(wz, p, key, x1, y1, x2, y2)
use select_monom_mod, only: w_ee_monom, z_ee_monom
real(dp), intent(inout) :: wz(2)
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), x1, y1, x2, y2
integer(idp) :: i, pstart
pstart = pst(1, key)
do i = 1, pst(2, key)
wz(1) = wz(1) + p(pstart + (i - 1))*w_ee_monom(x1, y1, x2, y2, i)
wz(2) = wz(2) + p(pstart + (i - 1))*z_ee_monom(x1, y1, x2, y2, i)
end do
! if(debug) write(*,*) 'wz_ee=', wz(1:2)
end subroutine wz_ee
!----------------------------------------------------------------------------------------------------
! function wz_aee(p,key,a, x1,y1,x2,y2) result(wz)
! use select_monom_mod,only : w_aee_monom, z_aee_monom
! real(dp) wz(2)
! integer(idp),intent(in) :: key
! real(dp),intent(in) :: p(:), a, x1, y1, x2, y2
! integer(idp) :: i, pstart
! wz = 0.d0; pstart = pst(1,key)
! do i = 1, pst(2,key)
! wz(1) = wz(1)
! > + p(pstart+(i-1)) * w_aee_monom(a, x1, y1, x2, y2, i)
! wz(2) = wz(2)
! > + p(pstart+(i-1)) * z_aee_monom(a, x1, y1, x2, y2, i)
! enddo
! ! if(debug) write(*,*) 'wz_aee=', wz(1:2)
! end function wz_aee
subroutine wz_aee(wz, p, key, a, x1, y1, x2, y2)
use select_monom_mod, only: w_aee_monom, z_aee_monom
real(dp), intent(inout) :: wz(2)
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), a, x1, y1, x2, y2
integer(idp) :: i, pstart
pstart = pst(1, key)
do i = 1, pst(2, key)
wz(1) = wz(1)&
&+ p(pstart + (i - 1))*w_aee_monom(a, x1, y1, x2, y2, i)
wz(2) = wz(2)&
&+ p(pstart + (i - 1))*z_aee_monom(a, x1, y1, x2, y2, i)
end do
! if(debug) write(*,*) 'wz_aee=', wz(1:2)
end subroutine wz_aee
!----------------------------------------------------------------------------------------------------
! function wz_aaae(p,key,a,b,c,x,y) result(wz)
! use select_monom_mod,only : w_aaae_monom, z_aaae_monom
! real(dp) :: wz(2)
! integer(idp),intent(in) :: key
! real(dp),intent(in) :: p(:), a,b,c, x, y
! integer(idp) :: i, pstart
! wz = 0.d0; pstart = pst(1,key)
! do i = 1, pst(2,key)
! wz(1) = wz(1)
! > + p(pstart+(i-1)) * w_aaae_monom(a,b,c, x, y, i)
! wz(2) = wz(2)
! > + p(pstart+(i-1)) * z_aaae_monom(a,b,c, x, y, i)
! enddo
! ! if(debug) write(*,*) 'wz_aaae=', wz(1:2)
! end function wz_aaae
subroutine wz_aaae(wz, p, key, a, b, c, x, y)
use select_monom_mod, only: w_aaae_monom, z_aaae_monom
real(dp), intent(inout) :: wz(2)
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), a, b, c, x, y
integer(idp) :: i, pstart
pstart = pst(1, key)
do i = 1, pst(2, key)
wz(1) = wz(1)&
&+ p(pstart + (i - 1))*w_aaae_monom(a, b, c, x, y, i)
wz(2) = wz(2)&
&+ p(pstart + (i - 1))*z_aaae_monom(a, b, c, x, y, i)
end do
! if(debug) write(*,*) 'wz_aaae=', wz(1:2)
end subroutine wz_aaae
!----------------------------------------------------------------------------------------------------
! function wz_eee(p,key,x1,y1,x2,y2,x3,y3) result(wz)
! use select_monom_mod,only : w_eee_monom, z_eee_monom
! real(dp) wz(2)
! integer(idp),intent(in) :: key
! real(dp),intent(in) :: p(:), x1, y1, x2, y2, x3, y3
! integer(idp) :: i, pstart
! wz = 0.d0; pstart = pst(1,key)
! do i = 1, pst(2,key)
! wz(1) = wz(1) + p(pstart+(i-1)) * w_eee_monom(x1, y1, x2, y2,x3
! > ,y3, i)
! wz(2) = wz(2) + p(pstart+(i-1)) * z_eee_monom(x1, y1, x2, y2,x3
! > ,y3, i)
! enddo
! ! if(debug) write(*,*) 'wz_eee=', wz(1:2)
! end function wz_eee
subroutine wz_eee(wz, p, key, x1, y1, x2, y2, x3, y3)
use select_monom_mod, only: w_eee_monom, z_eee_monom
real(dp), intent(inout) :: wz(2)
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), x1, y1, x2, y2, x3, y3
integer(idp) :: i, pstart
pstart = pst(1, key)
do i = 1, pst(2, key)
wz(1) = wz(1) + p(pstart + (i - 1))*w_eee_monom(x1, y1, x2, y2, x3&
&, y3, i)
wz(2) = wz(2) + p(pstart + (i - 1))*z_eee_monom(x1, y1, x2, y2, x3&
&, y3, i)
end do
! if(debug) write(*,*) 'wz_eee=', wz(1:2)
end subroutine wz_eee
!----------------------------------------------------------------------------------------------------
! function wz_aaee(p,key,a,b, x1,y1,x2,y2) result(wz)
! use select_monom_mod,only : w_aaee_monom, z_aaee_monom
! real(dp) wz(2)
! integer(idp),intent(in) :: key
! real(dp),intent(in) :: p(:), a,b, x1, y1, x2, y2
! integer(idp) :: i, pstart
! wz = 0.d0; pstart = pst(1,key)
! do i = 1, pst(2,key)
! wz(1) = wz(1)
! > + p(pstart+(i-1)) * w_aaee_monom(a,b, x1, y1, x2, y2, i)
! wz(2) = wz(2)
! > + p(pstart+(i-1)) * z_aaee_monom(a,b, x1, y1, x2, y2, i)
! enddo
! ! if(debug) write(*,*) 'wz_aaee=', wz(1:2)
! end function wz_aaee
subroutine wz_aaee(wz, p, key, a, b, x1, y1, x2, y2)
use select_monom_mod, only: w_aaee_monom, z_aaee_monom
real(dp), intent(inout) :: wz(2)
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), a, b, x1, y1, x2, y2
integer(idp) :: i, pstart
pstart = pst(1, key)
do i = 1, pst(2, key)
wz(1) = wz(1)&
&+ p(pstart + (i - 1))*w_aaee_monom(a, b, x1, y1, x2, y2, i)
wz(2) = wz(2)&
&+ p(pstart + (i - 1))*z_aaee_monom(a, b, x1, y1, x2, y2, i)
end do
end subroutine wz_aaee
!====================================================================================================
function wz_eYlm(p, key, x1, y1, theta, phi) result(wz)
use sphericalharmonics_mod, only: Re_Y_lm, Im_Y_lm
use select_monom_mod, only: w_ee_monom, z_ee_monom
real(dp) wz(2)
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:)
real(dp), intent(in) :: x1, y1, theta, phi
real(dp) :: x2, y2
wz = 0.d0
x2 = Re_Y_lm(1, 1, theta, phi)
y2 = Im_Y_lm(1, 1, theta, phi)
call wz_ee(wz, p, key, x1, y1, x2, y2)
! wz = wz_ee(p, key, x1, y1, x2, y2)
end function wz_eYlm
function wz_ylm(p, key, theta, phi, r, umb) result(wz)
use sphericalharmonics_mod, only: Re_Y_lm, Im_Y_lm
real(dp) :: wz(2)
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:)
real(dp), intent(in) :: theta, phi, umb, r
integer(idp) :: l, m, count, k, pstart, pnum
integer(idp), parameter :: max = 8
real(dp) :: term(2), lp(max)
lp = 0.d0
pstart = pst(1, key)
pnum = pst(2, key)
if (pnum .gt. max) then
error stop 'Error: more parameters then lp lenght '
end if
lp(1:pnum) = p(pstart:pstart + pnum - 1)
wz = 0.d0
count = 1
do l = 1, max
do k = -l, l
m = 3*k + 1
if (abs(m) <= abs(l)) then
count = count + 1
if (count .gt. pnum) goto 100
term(1) = Re_Y_lm(l, m, theta, phi)
term(2) = Im_Y_lm(l, m, theta, phi)
if (mod(l - m, 2) .eq. 1) term = term*umb
wz = wz + term*lp(count)
end if
end do
end do
error stop 'Warning: reached max l in wz_lm'
100 continue
wz = wz*exp(-dabs(lp(1))*r)
end function wz_ylm
!----------------------------------------------------------------------------------------------------
function v_ylm(p, key, theta, phi, r, umb) result(v)
use sphericalharmonics_mod, only: Re_Y_lm
real(dp) v
! IN variables
integer(idp), intent(in) :: key !number of parameters
real(dp), intent(in) :: theta, phi, umb, r ! koordinates
real(dp), intent(in) :: p(:) !parameter
! internal
integer(idp), parameter :: max = 8
real(dp) lp(max), term
! loop control
integer(idp) l, m, count, pstart, pnum
lp = 0.d0
pstart = pst(1, key)
pnum = pst(2, key)
if (pnum .gt. max) then
error stop 'ERROR: more parameters then lp lenght in v_ylm'
end if
lp(1:pnum) = p(pstart:pstart + pnum - 1)
count = 1
v = 0.d0
do l = 1, max
do m = 0, l, 3
count = count + 1
if (count .gt. pnum) goto 100
term = Re_Y_lm(l, m, theta, phi)
if (mod(l - m, 2) .eq. 1) term = term*umb
v = v + term*lp(count)
end do
end do
error stop 'Warning: reached max l in v_lm'
100 continue
v = v*exp(-dabs(lp(1))*r)
end function v_ylm
!----------------------------------------------------------------------------------------------------
function v_eYlm(p, key, theta, phi, x2, y2) result(v)
use sphericalharmonics_mod, only: Re_Y_lm, Im_Y_lm
use select_monom_mod, only: v_ee_monom
real(dp) :: v
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), x2, y2, theta, phi
real(dp) :: x1, y1
v = 0.d0
x1 = Re_Y_lm(1, 1, theta, phi); y1 = Im_Y_lm(1, 1, theta, phi)
v = v_ee(p, key, x1, y1, x2, y2)
! if(debug) write(*,*) 'v_eYlm=', v
end function v_eYlm
!----------------------------------------------------------------------------------------------------
function v_aYlm(p, key, a, theta, phi) result(v)
use sphericalharmonics_mod, only: Re_Y_lm, Im_Y_lm
real(dp) :: v
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), a, theta, phi
real(dp) :: x1, y1
v = 0.d0
x1 = Re_Y_lm(1, 1, theta, phi); y1 = Im_Y_lm(1, 1, theta, phi)
v = v_ae(p, key, a, x1, y1)
end function v_aYlm
!----------------------------------------------------------------------------------------------------
function q_u(p, key, u, split_ref) result(q)
use select_monom_mod, only: q_u_monom
integer, optional, intent(in) :: split_ref
real(dp) q
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), u
integer(idp) :: i, pstart
integer(idp) :: ii, ee
q = 0.d0; pstart = pst(1, key)
ii = 1; ee = pst(2, key)
call index_split_ref(ii, ee, 2, split_ref)
do i = ii, ee
q = q + q_u_monom(u, i)*p(pstart + (i - 1))
end do
end function q_u
function q_ua(p, key, u, a) result(q)
use select_monom_mod, only: q_ua_monom
real(dp) :: q
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), u, a
integer(idp) :: pstart, i
q = 0.d0; pstart = pst(1, key)
do i = 1, pst(2, key)
q = q + p(pstart + (i - 1))*q_ua_monom(u, a, i)
end do
end function q_ua
function q_ue(p, key, u, x, y) result(q)
use select_monom_mod, only: q_ue_monom
real(dp) :: q
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), u, x, y
integer(idp) :: i, pstart
q = 0.d0; pstart = pst(1, key)
do i = 1, pst(2, key)
q = q + p(pstart + (i - 1))*q_ue_monom(u, x, y, i)
end do
end function q_ue
function q_uae(p, key, u, a, x, y) result(q)
use select_monom_mod, only: q_uae_monom
real(dp) :: q
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), u, a, x, y
integer(idp) :: i, pstart
q = 0.d0; pstart = pst(1, key)
do i = 1, pst(2, key)
q = q + p(pstart + (i - 1))*q_uae_monom(u, a, x, y, i)
end do
end function q_uae
function q_uee(p, key, u, x1, y1, x2, y2) result(q)
use select_monom_mod, only: q_uee_monom
real(dp) :: q
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), u, x1, y1, x2, y2
integer(idp) :: i, pstart
q = 0.d0; pstart = pst(1, key)
do i = 1, pst(2, key)
q = q + p(pstart + (i - 1))*q_uee_monom(u, x1, y1, x2, y2, i)
end do
end function q_uee
function q_uaee(p, key, u, a, x1, y1, x2, y2) result(q)
use select_monom_mod, only: q_uaee_monom
real(dp) :: q
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), u, a, x1, y1, x2, y2
integer(idp) :: i, pstart
q = 0.d0; pstart = pst(1, key)
do i = 1, pst(2, key)
q = q + p(pstart + (i - 1))*q_uaee_monom(u, a, x1, y1, x2, y2, i)
end do
end function q_uaee
subroutine qwz_ue(qwz, p, key, u, x, y, split_ref)
use select_monom_mod, only: qw_ue_monom, qz_ue_monom
integer, optional, intent(in) :: split_ref
real(dp), intent(inout) :: qwz(2)
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), u, x, y
integer(idp) :: i, pstart
integer(idp) :: ii, ee
pstart = pst(1, key)
ii = 1; ee = pst(2, key)
call index_split_ref(ii, ee, 2, split_ref)
do i = ii, ee
qwz(1) = qwz(1) + qw_ue_monom(u, x, y, i)*p(pstart + (i - 1))
qwz(2) = qwz(2) + qz_ue_monom(u, x, y, i)*p(pstart + (i - 1))
end do
end subroutine qwz_ue
subroutine qwz_uae(qwz, p, key, u, a, x, y)
use select_monom_mod, only: qw_uae_monom, qz_uae_monom
real(dp), intent(inout) :: qwz(2)
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), u, a, x, y
integer(idp) :: i, pstart
pstart = pst(1, key)
do i = 1, pst(2, key)
qwz(1) = qwz(1) + qw_uae_monom(u, a, x, y, i)*p(pstart + (i - 1))
qwz(2) = qwz(2) + qz_uae_monom(u, a, x, y, i)*p(pstart + (i - 1))
end do
end subroutine qwz_uae
subroutine qwz_uee(qwz, p, key, u, x1, y1, x2, y2)
use select_monom_mod, only: qw_uee_monom, qz_uee_monom
real(dp), intent(inout) :: qwz(2)
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), u, x1, y1, x2, y2
integer(idp) :: i, pstart
pstart = pst(1, key)
do i = 1, pst(2, key)
qwz(1) = qwz(1) + qw_uee_monom(u, x1, y1, x2, y2, i)*p(pstart + (i - 1))
qwz(2) = qwz(2) + qz_uee_monom(u, x1, y1, x2, y2, i)*p(pstart + (i - 1))
end do
end subroutine qwz_uee
subroutine qwz_uaee(qwz, p, key, u, a, x1, y1, x2, y2)
use select_monom_mod, only: qw_uaee_monom, qz_uaee_monom
real(dp), intent(inout) :: qwz(2)
integer(idp), intent(in) :: key
real(dp), intent(in) :: p(:), u, a, x1, y1, x2, y2
integer(idp) :: i, pstart
pstart = pst(1, key)
do i = 1, pst(2, key)
qwz(1) = qwz(1) + qw_uaee_monom(u, a, x1, y1, x2, y2, i)*p(pstart + (i - 1))
qwz(2) = qwz(2) + qz_uaee_monom(u, a, x1, y1, x2, y2, i)*p(pstart + (i - 1))
end do
end subroutine qwz_uaee
end module diab_pes

92
src/model/new_PES/plot_surface.f90
View File

@ -1,92 +0,0 @@
!Programm evaluating the model for a given set of coordinates
program surface
use accuracy_constants, only: dp
use surface_mod
use ctrans_mod, only: int2kart, sq2, sq3, sq6
implicit none
real(dp), dimension(:), allocatable :: p
real(dp), dimension(9) :: x
real(dp), dimension(4, 4) :: w, u
real(dp), dimension(4) :: e
integer :: k,l
real(dp), parameter, dimension(6) :: scale_max = [10, 4, 4, 130, 130, 360]
real(dp), parameter, dimension(6) :: scale_fact = [1/sq3, 1/sq6, 1/sq2, 1/sq6, 1/sq2, 1._dp]
!initialize surface
call init_surface(p)
x = 0.0_dp
!scan the surface
do k = 1, 6
call ak_scan()
end do
call H_NH2()
do k=1,6-1
do l=k+1,6
call e_2d(k, l)
end do
end do
contains
subroutine ak_scan()
integer, parameter :: n = 1000
integer :: i
real(dp) :: sym(6)
integer :: file_id
character(len=100) :: file_name
write (file_name, '(A,i0,A)') 'surface_a', k, '.dat'
open (newunit=file_id, file=trim(adjustl(file_name)))
sym = 0.0_dp
do i = -n, n
sym(k) = 0.0_dp + scale_max(k)/real(n)*i
call int2kart(sym*scale_fact, x)
call eval_surface(e, w, u, x, p)
write (file_id, '(*(F20.14))') sym, x, e
end do
close (file_id)
end subroutine ak_scan
!subroutine to scan single H dissociation
subroutine H_NH2()
integer, parameter :: n = 1000
integer :: i
real(dp) :: sym(6)
integer :: file_id
character(len=100) :: file_name
file_name = 'H+NH2+.dat'
open (newunit=file_id, file=trim(adjustl(file_name)))
sym = 0.0_dp
do i = -n, n
sym(1) = 0.0_dp + scale_max(2)/real(n)*i
sym(2) = 0.0_dp + scale_max(2)/real(n)*i
call int2kart(sym*scale_fact, x)
call eval_surface(e, w, u, x, p)
write (file_id, '(*(F20.14))') sym, x, e
end do
close (file_id)
end subroutine H_NH2
subroutine e_2d(d1, d2)
integer, parameter :: n = 200
integer, intent(in) :: d1, d2
integer :: i, j
real(dp) :: sym(6)
integer :: file_id
character(len=100) :: file_name
write (file_name, '(A,i0,A,i0,A)') 'surface_2d_', d1, '_', d2, '.dat'
open (newunit=file_id, file=trim(adjustl(file_name)))
sym = 0.0_dp
do i = -n, n
do j = -n, n
sym(d1) = 0.0_dp + scale_max(d1)/real(n)*i
sym(d2) = 0.0_dp + scale_max(d2)/real(n)*j
call int2kart(sym*scale_fact, x)
call eval_surface(e, w, u, x, p)
write (file_id, '(*(F20.14))') sym, x, e
end do
write (file_id, '(A)') ''
end do
close (file_id)
end subroutine e_2d
end program surface

2293
src/model/new_PES/select_monom_mod.f90
View File

File diff suppressed because it is too large Load Diff

575
src/model/new_PES/sphericalharmonics_mod.f90
View File

@ -1,575 +0,0 @@
! Module contains the spherical harmonics up to l=5 m=-l,..,0,..,l listed on https://en.wikipedia.org/wiki/Table_of_spherical_harmonics from 19.07.2022
! the functions are implementde by calling switch case function for given m or l value and return the corresdpondig value for given theta and phi
! the functions are split for diffrent l values and are named by P_lm.
! example for l=1 and m=-1 the realpart of the spherical harmonic for given theta and phi
! is returned by calling Re_Y_lm(1,-1,theta,phi) which itself calls the corresponding function P_1m(m,theta) and multilpies it by cos(m*phi) to account for the real part of exp(m*phi*i)
! Attention the legendre polynoms are shifted to account for the missing zero order term in spherical harmonic expansions
module sphericalharmonics_mod
use accuracy_constants, only: dp, idp
implicit none
real(kind=dp), parameter :: PI = 4.0_dp * atan( 1.0_dp )
contains
!----------------------------------------------------------------------------------------------------
function Y_lm( l , m , theta , phi ) result( y )
integer(kind=idp), intent( in ) :: l , m
real(kind=dp), intent( in ) :: theta , phi
real(kind=dp) y
character(len=70) :: errmesg
select case ( l )
case (1)
y = Y_1m( m , theta , phi )
case (2)
y = Y_2m( m , theta , phi )
case (3)
y = Y_3m( m , theta , phi )
case (4)
y = Y_4m( m , theta , phi )
case (5)
y = Y_5m( m , theta , phi )
case default
write(errmesg,'(A,i0)')&
&'order of spherical harmonics not implemented', l
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function Y_lm
!----------------------------------------------------------------------------------------------------
function Re_Y_lm( l , m , theta , phi ) result( y )
integer(kind=idp), intent( in ) :: l , m
real(kind=dp), intent( in ) :: theta , phi
real(kind=dp) y
character(len=70) :: errmesg
select case ( l )
case (1)
y = P_1m( m , theta ) * cos(m*phi)
case (2)
y = P_2m( m , theta ) * cos(m*phi)
case (3)
y = P_3m( m , theta ) * cos(m*phi)
case (4)
y = P_4m( m , theta ) * cos(m*phi)
case (5)
y = P_5m( m , theta ) * cos(m*phi)
case (6)
y = P_6m( m , theta ) * cos(m*phi)
case default
write(errmesg,'(A,i0)')&
&'order of spherical harmonics not implemented', l
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function Re_Y_lm
!----------------------------------------------------------------------------------------------------
function Im_Y_lm( l , m , theta , phi ) result( y )
integer(kind=idp), intent( in ) :: l , m
real(kind=dp), intent( in ) :: theta , phi
real(kind=dp) y
character(len=70) :: errmesg
select case ( l )
case (1)
y = P_1m( m , theta ) * sin(m*phi)
case (2)
y = P_2m( m , theta ) * sin(m*phi)
case (3)
y = P_3m( m , theta ) * sin(m*phi)
case (4)
y = P_4m( m , theta ) * sin(m*phi)
case (5)
y = P_5m( m , theta ) * sin(m*phi)
case (6)
y = P_6m( m , theta ) * sin(m*phi)
case default
write(errmesg,'(a,i0)')&
&'order of spherical harmonics not implemented',l
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function Im_Y_lm
!----------------------------------------------------------------------------------------------------
!----------------------------------------------------------------------------------------------------
function Y_1m( m , theta , phi ) result( y )
integer(kind=idp),intent( in ):: m
real(kind=dp),intent( in ):: theta , phi
real(kind=dp) y
character(len=70) :: errmesg
select case ( m )
case (-1)
y = 0.5_dp*sqrt(3.0_dp/(PI*2.0_dp))*sin(theta)*cos(phi)
case (0)
y = 0.5_dp*sqrt(3.0_dp/PI)*cos(theta)
case (1)
y = -0.5_dp*sqrt(3.0_dp/(PI*2.0_dp))*sin(theta)*cos(phi)
case default
write(errmesg,'(a,i0)') 'in y_1m given m not logic, ', m
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function Y_1m
!----------------------------------------------------------------------------------------------------
function Y_2m(m,theta,phi) result(y)
integer(kind=idp),intent(in):: m
real(kind=dp),intent(in):: theta,phi
real(kind=dp) y
character(len=70) :: errmesg
select case (m)
case (-2)
y=0.25_dp*sqrt(15.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*cos(2.0_dp*phi)
case (-1)
y=0.5_dp*sqrt(15.0_dp/(PI*2.0_dp))&
&*sin(theta)*cos(theta)*cos(phi)
case (0)
y=0.25_dp*sqrt(5.0_dp/PI)&
&*(3.0_dp*cos(theta)**2-1.0_dp)
case (1)
y=-0.5_dp*sqrt(15.0_dp/(PI*2.0_dp))&
&*sin(theta)*cos(theta)*cos(phi)
case (2)
y=0.25_dp*sqrt(15.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*cos(2.0_dp*phi)
case default
write(errmesg,'(A,i0)')'in y_2m given m not logic, ', m
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function Y_2m
!----------------------------------------------------------------------------------------------------
function Y_3m(m,theta,phi) result(y)
integer(kind=idp), intent(in) :: m
real(kind=dp), intent(in) :: theta,phi
real(kind=dp) y
character(len=70) :: errmesg
select case (m)
case (-3)
y=0.125_dp*sqrt(35.0_dp/PI)&
&*sin(theta)**3*cos(3.0_dp*phi)
case (-2)
y=0.25_dp*sqrt(105.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*cos(theta)*cos(2.0_dp*phi)
case (-1)
y=0.125_dp*sqrt(21.0_dp/(PI))&
&*sin(theta)*(5.0_dp*cos(theta)**2-1.0_dp)*cos(phi)
case (0)
y=0.25_dp*sqrt(7.0_dp/PI)&
&*(5.0_dp*cos(theta)**3-3.0_dp*cos(theta))
case (1)
y=-0.125_dp*sqrt(21.0_dp/(PI))&
&*sin(theta)*(5.0_dp*cos(theta)**2-1.0_dp)*cos(phi)
case (2)
y=0.25_dp*sqrt(105.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*cos(theta)*cos(2.0_dp*phi)
case (3)
y=-0.125_dp*sqrt(35.0_dp/PI)&
&*sin(theta)**3*cos(3.0_dp*phi)
case default
write(errmesg,'(A,i0)')'in y_3m given m not logic, ', m
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function Y_3m
!----------------------------------------------------------------------------------------------------
function Y_4m(m,theta,phi) result(y)
integer(kind=idp), intent(in) :: m
real(kind=dp), intent(in) :: theta,phi
real(kind=dp) y
character(len=70) :: errmesg
select case (m)
case (-4)
y=(3.0_dp/16.0_dp)*sqrt(35.0_dp/2.0_dp*PI)&
&*sin(theta)**4*cos(4.0_dp*phi)
case (-3)
y=0.375_dp*sqrt(35.0_dp/PI)&
&*sin(theta)**3*cos(theta)*cos(3.0_dp*phi)
case (-2)
y=0.375_dp*sqrt(5.0_dp/(PI*2.0_dp))&
&*sin(theta)**2&
&*(7.0_dp*cos(theta)**2-1)*cos(2.0_dp*phi)
case (-1)
y=0.375_dp*sqrt(5.0_dp/(PI))&
&*sin(theta)*(7.0_dp*cos(theta)**3&
&-3.0_dp*cos(theta))*cos(phi)
case (0)
y=(3.0_dp/16.0_dp)/sqrt(PI)&
&*(35.0_dp*cos(theta)**4&
&-30.0_dp*cos(theta)**2+3.0_dp)
case (1)
y=-0.375_dp*sqrt(5.0_dp/(PI))&
&*sin(theta)*(7.0_dp*cos(theta)**3&
&-3.0_dp*cos(theta))*cos(phi)
case (2)
y=0.375_dp*sqrt(5.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*(7.0_dp*cos(theta)**2-1.0_dp)&
&*cos(2*phi)
case (3)
y=-0.375_dp*sqrt(35.0_dp/PI)&
&*sin(theta)**3*cos(theta)*cos(3.0_dp*phi)
case (4)
y=(3.0_dp/16.0_dp)*sqrt(35.0_dp/2.0_dp*PI)&
&*sin(theta)**4*cos(4.0_dp*phi)
case default
write(errmesg,'(a,i0)')'in y_4m given m not logic, ', m
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function Y_4m
!----------------------------------------------------------------------------------------------------
function Y_5m(m,theta,phi) result(y)
integer(kind=idp), intent(in) :: m
real(kind=dp), intent(in) :: theta,phi
real(kind=dp) y
character(len=70) :: errmesg
select case (m)
case (-5)
y=(3.0_dp/32.0_dp)*sqrt(77.0_dp/PI)&
&*sin(theta)**5*cos(5*phi)
case (-4)
y=(3.0_dp/16.0_dp)*sqrt(385.0_dp/2.0_dp*PI)&
&*sin(theta)**4*cos(theta)*cos(4*phi)
case (-3)
y=(1.0_dp/32.0_dp)*sqrt(385.0_dp/PI)&
&*sin(theta)**3*(9*cos(theta)**2-1.0_dp)*cos(3*phi)
case (-2)
y=0.125*sqrt(1155.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*(3*cos(theta)**3-cos(theta))*cos(2*phi)
case (-1)
y=(1.0_dp/16.0_dp)*sqrt(165.0_dp/(2.0_dp*PI))&
&*sin(theta)*(21.0_dp*cos(theta)**4&
&-14.0_dp*cos(theta)**2+1.0_dp)*cos(phi)
case (0)
y=(1.0_dp/16.0_dp)/sqrt(11.0_dp/PI)&
&*(63.0_dp*cos(theta)**5-70.0_dp*cos(theta)**3&
&+15.0_dp*cos(theta))
case (1)
y=(-1.0_dp/16.0_dp)*sqrt(165.0_dp/(2.0_dp*PI))&
&*sin(theta)*(21.0_dp*cos(theta)**4&
&-14.0_dp*cos(theta)**2+1.0_dp)*cos(phi)
case (2)
y=0.125*sqrt(1155.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*(3*cos(theta)**3-cos(theta))*cos(2*phi)
case (3)
y=(-1.0_dp/32.0_dp)*sqrt(385.0_dp/PI)&
&*sin(theta)**3*(9.0_dp*cos(theta)**2-1.0_dp)&
&*cos(3.0_dp*phi)
case (4)
y=(3.0_dp/16.0_dp)*sqrt(385.0_dp/2.0_dp*PI)&
&*sin(theta)**4*cos(theta)*cos(4.0_dp*phi)
case (5)
y=(-3.0_dp/32.0_dp)*sqrt(77.0_dp/PI)&
&*sin(theta)**5*cos(5.0_dp*phi)
case default
write(errmesg,'(A,i0)')'in y_5m given m not logic, ', m
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function Y_5m
!----------------------------------------------------------------------------------------------------
function P_1m( m , theta ) result( y )
! >Function returns the value of the corresponding normalized Associated legendre polynom for l=1 and given m and theta
integer(kind=idp),intent( in ):: m
real(kind=dp),intent( in ):: theta
real(kind=dp) y
character(len=70) :: errmesg
select case ( m )
case (-1)
y = 0.5_dp*sqrt(3.0_dp/(PI*2.0_dp))*sin(theta)
case (0)
y = 0.5_dp*sqrt(3.0_dp/PI)*(cos(theta)-1.0_dp) ! -1 is subtracted to shift so that for theta=0 y=0
case (1)
y = -0.5_dp*sqrt(3.0_dp/(PI*2.0_dp))*sin(theta)
case default
write(errmesg,'(A,i0)')'in p_1m given m not logic, ', m
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function P_1m
!----------------------------------------------------------------------------------------------------
function P_2m( m , theta ) result( y )
! >Function returns the value of the corresponding normalized Associated legendre polynom for l=2 and given m and theta
integer(kind=idp),intent(in):: m
real(kind=dp),intent(in):: theta
real(kind=dp) y
character(len=70) :: errmesg
select case ( m )
case (-2)
y=0.25_dp*sqrt(15.0_dp/(PI*2.0_dp))&
&*sin(theta)**2
case (-1)
y=0.5_dp*sqrt(15.0_dp/(PI*2.0_dp))&
&*sin(theta)*cos(theta)
case (0)
y = (3.0_dp*cos(theta)**2-1.0_dp)
y = y - 2.0_dp !2.0 is subtracted to shift so that for theta=0 y=0
y = y * 0.25_dp*sqrt(5.0_dp/PI) ! normalize
case (1)
y = -0.5_dp*sqrt(15.0_dp/(PI*2.0_dp))&
&*sin(theta)*cos(theta)
case (2)
y = 0.25_dp*sqrt(15.0_dp/(PI*2.0_dp))&
&*sin(theta)**2
case default
write(errmesg,'(A,i0)')'in p_2m given m not logic, ', m
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function P_2m
!----------------------------------------------------------------------------------------------------
function P_3m( m , theta ) result( y )
! >Function returns the value of the corresponding normalized Associated legendre polynom for l=3 and given m and theta
integer(kind=idp), intent(in) :: m
real(kind=dp), intent(in) :: theta
real(kind=dp) y
character(len=70) :: errmesg
select case ( m )
case (-3)
y=0.125_dp*sqrt(35.0_dp/PI)&
&*sin(theta)**3
case (-2)
y=0.25_dp*sqrt(105.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*cos(theta)
case (-1)
y=0.125_dp*sqrt(21.0_dp/(PI))&
&*sin(theta)*(5*cos(theta)**2-1.0_dp)
case (0)
y=(5.0_dp*cos(theta)**3-3*cos(theta))
y=y-2.0_dp ! 2.0 is subtracted to shift so that for theta=0 y=0
y=y*0.25_dp*sqrt(7.0_dp/PI) ! normalize
case (1)
y=-0.125_dp*sqrt(21.0_dp/(PI))&
&*sin(theta)*(5.0_dp*cos(theta)**2-1.0_dp)
case (2)
y=0.25*sqrt(105.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*cos(theta)
case (3)
y=-0.125*sqrt(35.0_dp/PI)&
&*sin(theta)**3
case default
write(errmesg,'(A,i0)')'in p_3m given m not logic, ', m
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function P_3m
!----------------------------------------------------------------------------------------------------
function P_4m(m,theta) result(y)
! >Function returns the value of the corresponding normalized Associated legendre polynom for l=4 and given m and theta
integer(kind=idp), intent(in) :: m
real(kind=dp), intent(in) :: theta
real(kind=dp) y
character(len=70) :: errmesg
select case ( m )
case (-4)
y=(3.0_dp/16.0_dp)*sqrt(35.0_dp/2.0_dp*PI)&
&*sin(theta)**4
case (-3)
y=0.375*sqrt(35.0_dp/PI)&
&*sin(theta)**3*cos(theta)
case (-2)
y=0.375*sqrt(5.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*(7*cos(theta)**2-1)
case (-1)
y=0.375*sqrt(5.0_dp/(PI))&
&*sin(theta)*(7*cos(theta)**3-3*cos(theta))
case (0)
y=(35*cos(theta)**4-30*cos(theta)**2+3)
y = y - 8.0_dp !8.0 is subtracted to shift so that for theta=0 y=0
y = y * (3.0_dp/16.0_dp)/sqrt(PI)
case (1)
y=-0.375*sqrt(5.0_dp/(PI))&
&*sin(theta)*(7*cos(theta)**3-3*cos(theta))
case (2)
y=0.375*sqrt(5.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*(7*cos(theta)**2-1)
case (3)
y=-0.375*sqrt(35.0_dp/PI)&
&*sin(theta)**3*cos(theta)
case (4)
y=(3.0_dp/16.0_dp)*sqrt(35.0_dp/2.0_dp*PI)&
&*sin(theta)**4
case default
write(errmesg,'(A,i0)')'in p_4m given m not logic, ', m
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function P_4m
!----------------------------------------------------------------------------------------------------
function P_5m(m,theta) result(y)
! >Function returns the value of the corresponding normalized Associated legendre polynom for l=5 and given m and theta
integer(kind=idp), intent(in) :: m
real(kind=dp), intent(in) :: theta
real(kind=dp) y
character(len=70) :: errmesg
select case ( m )
case (-5)
y=(3.0_dp/32.0_dp)*sqrt(77.0_dp/PI)&
&*sin(theta)**5
case (-4)
y=(3.0_dp/16.0_dp)*sqrt(385.0_dp/2.0_dp*PI)&
&*sin(theta)**4*cos(theta)
case (-3)
y=(1.0_dp/32.0_dp)*sqrt(385.0_dp/PI)&
&*sin(theta)**3*(9*cos(theta)**2-1.0_dp)
case (-2)
y=0.125*sqrt(1155.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*(3*cos(theta)**3-cos(theta))
case (-1)
y=(1.0_dp/16.0_dp)*sqrt(165.0_dp/(2.0_dp*PI))&
&*sin(theta)*(21*cos(theta)**4-14*cos(theta)**2+1)
case (0)
y = (63*cos(theta)**5-70*cos(theta)**3+15*cos(theta))
y = y - 8.0_dp !8.0 is subtracted to shift so that for theta=0 y=0
y = y * (1.0_dp/16.0_dp)/sqrt(11.0_dp/PI)
case (1)
y=(-1.0_dp/16.0_dp)*sqrt(165.0_dp/(2.0_dp*PI))&
&*sin(theta)*(21*cos(theta)**4-14*cos(theta)**2+1)
case (2)
y=0.125*sqrt(1155.0_dp/(PI*2.0_dp))&
&*sin(theta)**2*(3*cos(theta)**3-cos(theta))
case (3)
y=(-1.0_dp/32.0_dp)*sqrt(385.0_dp/PI)&
&*sin(theta)**3*(9*cos(theta)**2-1.0_dp)
case (4)
y=(3.0_dp/16.0_dp)*sqrt(385.0_dp/2.0_dp*PI)&
&*sin(theta)**4*cos(theta)
case (5)
y=(-3.0_dp/32.0_dp)*sqrt(77.0_dp/PI)&
&*sin(theta)**5
case default
write(errmesg,'(A,i0)')'in p_5m given m not logic, ', m
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function P_5m
!----------------------------------------------------------------------------------------------------
function P_6m(m,theta) result(y)
! >Function returns the value of the corresponding normalized Associated legendre polynom for l=6 and given m and theta
integer(kind=idp), intent(in) :: m
real(kind=dp), intent(in) :: theta
real(kind=dp):: y
character(len=70) :: errmesg
select case ( m )
case (-6)
y = (1.0_dp/64.0_dp)*sqrt(3003.0_dp/PI)&
&* sin(theta)**6
case (-5)
y = (3.0_dp/32.0_dp)*sqrt(1001.0_dp/PI)&
&* sin(theta)**5&
&* cos(theta)
case (-4)
y= (3.0_dp/32.0_dp)*sqrt(91.0_dp/(2.0_dp*PI))&
&* sin(theta)**4&
&* (11*cos(theta)**2 - 1 )
case (-3)
y= (1.0_dp/32.0_dp)*sqrt(1365.0_dp/PI)&
&* sin(theta)**3&
&* (11*cos(theta)**3 - 3*cos(theta) )
case (-2)
y= (1.0_dp/64.0_dp)*sqrt(1365.0_dp/PI)&
&* sin(theta)**2&
&* (33*cos(theta)**4 - 18*cos(theta)**2 + 1 )
case (-1)
y= (1.0_dp/16.0_dp)*sqrt(273.0_dp/(2.0_dp*PI))&
&* sin(theta)&
&* (33*cos(theta)**5 - 30*cos(theta)**3 + 5*cos(theta) )
case (0)
y = 231*cos(theta)**6 - 315*cos(theta)**4 + 105*cos(theta)**2-5
y = y - 16.0_dp !16.0 is subtracted to shift so that for theta=0 y=0
y = y * (1.0_dp/32.0_dp)*sqrt(13.0_dp/PI)
case (1)
y= -(1.0_dp/16.0_dp)*sqrt(273.0_dp/(2.0_dp*PI))&
&* sin(theta)&
&* (33*cos(theta)**5 - 30*cos(theta)**3 + 5*cos(theta) )
case (2)
y= (1.0_dp/64.0_dp)*sqrt(1365.0_dp/PI)&
&* sin(theta)**2&
&* (33*cos(theta)**4 - 18*cos(theta)**2 + 1 )
case (3)
y= -(1.0_dp/32.0_dp)*sqrt(1365.0_dp/PI)&
&* sin(theta)**3&
&* (11*cos(theta)**3 - 3*cos(theta) )
case (4)
y= (3.0_dp/32.0_dp)*sqrt(91.0_dp/(2.0_dp*PI))&
&* sin(theta)**4&
&* (11*cos(theta)**2 - 1 )
case (5)
y= -(3.0_dp/32.0_dp)*sqrt(1001.0_dp/PI)&
&* sin(theta)**5 * cos(theta)
case (6)
y = (1.0_dp/64.0_dp)*sqrt(3003.0_dp/PI)&
&* sin(theta)**6
case default
write(errmesg,'(A,i0)')'in p_6m given m not logic, ', m
error stop 'error in spherical harmonics' !error stop errmesg
end select
end function P_6m
!----------------------------------------------------------------------------------------------------
end module

71
src/model/new_PES/surface_mod.f90
View File

@ -1,71 +0,0 @@
module surface_mod
use accuracy_constants, only: dp
implicit none
private
public eval_surface
contains
subroutine eval_surface(e, w, u, x1, p)
use ctrans_pes_mod, only: ctrans_pes
use diab_pes, only: pote
use accuracy_constants, only: dp, idp
use dim_parameter, only: ndiab
implicit none
real(dp), dimension(:, :), intent(out) :: w, u
real(dp), dimension(:), intent(out) :: e
real(dp), dimension(:), intent(in) :: x1, p
real(dp), dimension(size(x1, 1)) :: s, t
real(dp), allocatable, dimension(:, :) :: Mat
!coordinate transformation if needed
call ctrans_pes(x1, s, t)
write(11,'(*(f18.8))') s
block
! lapack variables
integer(kind=idp), parameter :: lwork = 1000
real(kind=dp) work(lwork)
integer(kind=idp) info
!evaluate model
call pote(w, 1, x1, s, t, p, size(p, 1))
allocate (Mat, source=w)
call dsyev('V', 'U', ndiab, Mat, ndiab, e, work, lwork, info)
u(:, :) = Mat(:, :)
deallocate (Mat)
end block
end subroutine eval_surface
! !subroutine init_surface(p)
! use dim_parameter, only: ndiab, nstat, ntot, nci ,qn
! use parameterkeys, only: parameterkey_read
! use fileread_mod, only: get_datfile, internalize_datfile
! use io_parameters, only: llen
! use accuracy_constants, only: dp
! implicit none
! real(dp), dimension(:), allocatable, intent(out) :: p
! character(len=llen), allocatable, dimension(:) :: infile
!
! qn = 9
! ndiab = 4
! nstat = 4
! nci = 4
! ntot = ndiab + nstat + nci
!
! block
! character(len=:),allocatable :: datnam
! integer :: linenum
! !get parameter file
! call get_datfile(datnam)
! !internalize datfile
! call internalize_datfile(datnam, infile, linenum, llen)
! end block
!
! !read parameters from file
! block
! real(dp), dimension(:), allocatable :: p_spread
! integer,dimension(:),allocatable :: p_act
! integer :: npar
! real(dp), parameter :: facspread = 1.0_dp, gspread = 1.0_dp
! call parameterkey_read(infile, size(infile, 1), p, p_act, p_spread, npar, gspread, facspread)
! end block
! end subroutine init_surface
end module surface_mod

82
src/model/new_PES/xy_stretch_lib.f90
View File

@ -1,82 +0,0 @@
module xy_stretch_lib
use accuracy_constants, only: dp,idp
implicit none
private
public eval_surface, init_surface,eval_matrix
real(dp), dimension(:), allocatable :: p
contains
subroutine eval_surface(e, w, u, x1)
use ctrans_mod, only: ctrans
use diabmodel, only: diab
use dim_parameter, only: ndiab
implicit none
real(dp), dimension(:, :), intent(out) :: w, u
real(dp), dimension(:), intent(out) :: e
real(dp), dimension(:), intent(in) :: x1
real(dp), dimension(size(x1, 1)) :: s, t
real(dp), allocatable, dimension(:, :) :: Mat
!coordinate transformation if needed
call ctrans(x1, s, t)
block
! lapack variables
integer(kind=idp), parameter :: lwork = 1000
real(kind=dp) work(lwork)
integer(kind=idp) info
!evaluate model
call diab(w, 1, x1, s, t, p, size(p, 1))
allocate (Mat, source=w)
call dsyev('V', 'U', ndiab, Mat, ndiab, e, work, lwork, info)
u(:, :) = Mat(:, :)
deallocate (Mat)
end block
end subroutine eval_surface
subroutine eval_matrix(w,x1)
use ctrans_mod, only: ctrans
use diabmodel, only: diab
implicit none
real(dp), dimension(:, :), intent(out) :: w
real(dp), dimension(:), intent(in) :: x1
real(dp), dimension(size(x1, 1)) :: s, t
!coordinate transformation if needed
call ctrans(x1, s, t)
call diab(w, 1, x1, s, t, p, size(p, 1))
end subroutine eval_matrix
subroutine init_surface()
use dim_parameter, only: ndiab, nstat, ntot, nci ,qn
use parameterkeys, only: parameterkey_read
use fileread_mod, only: get_datfile, internalize_datfile
use io_parameters, only: llen
use accuracy_constants, only: dp
implicit none
character(len=llen), allocatable, dimension(:) :: infile
qn = 9
ndiab = 4
nstat = 4
nci = 4
ntot = ndiab + nstat + nci
block
character(len=:),allocatable :: datnam
integer :: linenum
datnam = 'xy_stretch.par.save'
! datnam = 'umbstr.par.save'
call internalize_datfile(datnam, infile, linenum, llen)
end block
!read parameters from file
block
real(dp), dimension(:), allocatable :: p_spread
integer,dimension(:),allocatable :: p_act
integer :: npar
real(dp), parameter :: facspread = 1.0_dp, gspread = 1.0_dp
call parameterkey_read(infile, size(infile, 1), p, p_act, p_spread, npar, gspread, facspread)
end block
end subroutine init_surface
end module xy_stretch_lib

82
src/model/new_PES/xy_stretch_lib.f90~
View File

@ -1,82 +0,0 @@
module xy_stretch_lib
use accuracy_constants, only: dp,idp
implicit none
private
public eval_surface, init_surface,eval_matrix
real(dp), dimension(:), allocatable, intent(out) :: p
contains
subroutine eval_surface(e, w, u, x1, p)
use ctrans_mod, only: ctrans
use diabmodel, only: diab
use dim_parameter, only: ndiab
implicit none
real(dp), dimension(:, :), intent(out) :: w, u
real(dp), dimension(:), intent(out) :: e
real(dp), dimension(:), intent(in) :: x1
real(dp), dimension(size(x1, 1)) :: s, t
real(dp), allocatable, dimension(:, :) :: Mat
!coordinate transformation if needed
call ctrans(x1, s, t)
block
! lapack variables
integer(kind=idp), parameter :: lwork = 1000
real(kind=dp) work(lwork)
integer(kind=idp) info
!evaluate model
call diab(w, 1, x1, s, t, p, size(p, 1))
allocate (Mat, source=w)
call dsyev('V', 'U', ndiab, Mat, ndiab, e, work, lwork, info)
u(:, :) = Mat(:, :)
deallocate (Mat)
end block
end subroutine eval_surface
subroutine eval_matrix(w,x1, p)
use ctrans_mod, only: ctrans
use diabmodel, only: diab
implicit none
real(dp), dimension(:, :), intent(out) :: w
real(dp), dimension(:), intent(in) :: x1
real(dp), dimension(size(x1, 1)) :: s, t
!coordinate transformation if needed
call ctrans(x1, s, t)
call diab(w, 1, x1, s, t, p, size(p, 1))
end subroutine eval_matrix
subroutine init_surface(p)
use dim_parameter, only: ndiab, nstat, ntot, nci ,qn
use parameterkeys, only: parameterkey_read
use fileread_mod, only: get_datfile, internalize_datfile
use io_parameters, only: llen
use accuracy_constants, only: dp
implicit none
character(len=llen), allocatable, dimension(:) :: infile
qn = 9
ndiab = 4
nstat = 4
nci = 4
ntot = ndiab + nstat + nci
block
character(len=:),allocatable :: datnam
integer :: linenum
datnam = 'xy_stretch.par.save'
! datnam = 'umbstr.par.save'
call internalize_datfile(datnam, infile, linenum, llen)
end block
!read parameters from file
block
real(dp), dimension(:), allocatable :: p_spread
integer,dimension(:),allocatable :: p_act
integer :: npar
real(dp), parameter :: facspread = 1.0_dp, gspread = 1.0_dp
call parameterkey_read(infile, size(infile, 1), p, p_act, p_spread, npar, gspread, facspread)
end block
end subroutine init_surface
end module xy_stretch_lib

83
src/model/new_PES/xyumb_stretch_lib.f90
View File

@ -1,83 +0,0 @@
module xyumb_stretch_lib
use accuracy_constants, only: dp,idp
implicit none
private
public eval_surface, init_surface,eval_matrix
real(dp), dimension(:), allocatable :: p
contains
subroutine eval_surface(e, w, u, x1)
use ctrans_mod, only: ctrans
use diabmodel, only: diab
use dim_parameter, only: ndiab
implicit none
real(dp), dimension(:, :), intent(out) :: w, u
real(dp), dimension(:), intent(out) :: e
real(dp), dimension(:), intent(in) :: x1
real(dp), dimension(size(x1, 1)) :: s, t
real(dp), allocatable, dimension(:, :) :: Mat
!coordinate transformation if needed
call ctrans(x1, s, t)
block
! lapack variables
integer(kind=idp), parameter :: lwork = 1000
real(kind=dp) work(lwork)
integer(kind=idp) info
!evaluate model
call diab(w, 1, x1, s, t, p, size(p, 1))
allocate (Mat, source=w)
call dsyev('V', 'U', ndiab, Mat, ndiab, e, work, lwork, info)
u(:, :) = Mat(:, :)
deallocate (Mat)
end block
end subroutine eval_surface
subroutine eval_matrix(w,x1)
use ctrans_mod, only: ctrans
use diabmodel, only: diab
implicit none
real(dp), dimension(:, :), intent(out) :: w
real(dp), dimension(:), intent(in) :: x1
real(dp), dimension(size(x1, 1)) :: s, t
!coordinate transformation if needed
call ctrans(x1, s, t)
call diab(w, 1, x1, s, t, p, size(p, 1))
end subroutine eval_matrix
subroutine init_surface()
use dim_parameter, only: ndiab, nstat, ntot, nci ,qn
use parameterkeys, only: parameterkey_read
use fileread_mod, only: get_datfile, internalize_datfile
use io_parameters, only: llen
use accuracy_constants, only: dp
implicit none
character(len=llen), allocatable, dimension(:) :: infile
qn = 9
ndiab = 4
nstat = 4
nci = 4
ntot = ndiab + nstat + nci
block
character(len=:),allocatable :: datnam
integer :: linenum
!datnam = 'xy_stretch.par.save'
datnam = 'umbstr.par.save'
call internalize_datfile(datnam, infile, linenum, llen)
end block
!read parameters from file
block
real(dp), dimension(:), allocatable :: p_spread
integer,dimension(:),allocatable :: p_act
integer :: npar
real(dp), parameter :: facspread = 1.0_dp, gspread = 1.0_dp
call parameterkey_read(infile, size(infile, 1), p, p_act, p_spread, npar, gspread, facspread)
end block
end subroutine init_surface
end module xyumb_stretch_lib