10
1
mirror of https://gitlab.com/scemama/qmcchem.git synced 2024-07-19 09:23:26 +02:00
qmcchem/src/det.irp.f

2182 lines
56 KiB
FortranFixed
Raw Normal View History

2021-06-07 23:41:37 +02:00
BEGIN_PROVIDER [ integer, det_i ]
&BEGIN_PROVIDER [ integer, det_i_prev ]
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
BEGIN_DOC
! Current running alpha determinant
END_DOC
det_i=det_alpha_order(1)
2021-06-07 23:41:37 +02:00
det_i_prev=det_alpha_order(1)
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
END_PROVIDER
2021-06-07 23:41:37 +02:00
BEGIN_PROVIDER [ integer, det_j ]
&BEGIN_PROVIDER [ integer, det_j_prev ]
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
BEGIN_DOC
! Current running beta determinant
END_DOC
det_j=det_beta_order(1)
2021-06-07 23:41:37 +02:00
det_j_prev=det_beta_order(1)
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
END_PROVIDER
subroutine det_update(n,LDS,m,l,S,S_inv,d)
implicit none
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
integer, intent(in) :: n,LDS ! Dimension of the vector
real, intent(in) :: m(LDS) ! New vector
integer, intent(in) :: l ! New position in S
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
real,intent(inout) :: S(LDS,n) ! Slater matrix
double precision,intent(inout) :: S_inv(LDS,n) ! Inverse Slater matrix
double precision,intent(inout) :: d ! Det(S)
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
if (d == 0.d0) then
return
endif
select case (n)
case default
call det_update_general(n,LDS,m,l,S,S_inv,d)
BEGIN_TEMPLATE
case ($n)
call det_update$n(n,LDS,m,l,S,S_inv,d)
SUBST [n]
1;;
2;;
3;;
4;;
5;;
6;;
7;;
8;;
9;;
10;;
11;;
12;;
13;;
14;;
15;;
16;;
17;;
18;;
19;;
20;;
21;;
22;;
23;;
24;;
25;;
26;;
27;;
28;;
29;;
30;;
31;;
32;;
33;;
34;;
35;;
36;;
37;;
38;;
39;;
40;;
41;;
42;;
43;;
44;;
45;;
46;;
47;;
48;;
49;;
50;;
2016-06-03 14:50:08 +02:00
51;;
52;;
53;;
54;;
55;;
56;;
57;;
58;;
59;;
60;;
61;;
62;;
63;;
64;;
65;;
66;;
67;;
68;;
69;;
70;;
71;;
72;;
73;;
74;;
75;;
76;;
77;;
78;;
79;;
80;;
81;;
82;;
83;;
84;;
85;;
86;;
87;;
88;;
89;;
90;;
91;;
92;;
93;;
94;;
95;;
96;;
97;;
98;;
99;;
100;;
101;;
102;;
103;;
104;;
105;;
106;;
107;;
108;;
109;;
110;;
111;;
112;;
113;;
114;;
115;;
116;;
117;;
118;;
119;;
120;;
121;;
122;;
123;;
124;;
125;;
126;;
127;;
128;;
129;;
130;;
131;;
132;;
133;;
134;;
135;;
136;;
137;;
138;;
139;;
140;;
141;;
142;;
143;;
144;;
145;;
146;;
147;;
148;;
149;;
150;;
2015-12-19 03:29:52 +01:00
END_TEMPLATE
end select
end
subroutine det_update2(n,LDS,m,l,S,S_inv,d)
implicit none
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
integer, intent(in) :: n,LDS ! Dimension of the vector
real, intent(in) :: m(2) ! New vector
integer, intent(in) :: l ! New position in S
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
real,intent(inout) :: S(LDS,2) ! Slater matrix
double precision,intent(inout) :: S_inv(LDS,2) ! Inverse Slater matrix
double precision,intent(inout) :: d ! Det(S)
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
S(1,l) = m(1)
S(2,l) = m(2)
S_inv(1,1) = S(1,1)
S_inv(1,2) = S(2,1)
S_inv(2,1) = S(1,2)
S_inv(2,2) = S(2,2)
call invert2(S_inv,LDS,n,d)
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
end
subroutine det_update1(n,LDS,m,l,S,S_inv,d)
implicit none
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
integer, intent(in) :: n,LDS ! Dimension of the vector
real, intent(in) :: m(1) ! New vector
integer, intent(in) :: l ! New position in S
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
real,intent(inout) :: S(LDS,1) ! Slater matrix
double precision,intent(inout) :: S_inv(LDS,1) ! Inverse Slater matrix
double precision,intent(inout) :: d ! Det(S)
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
S(1,l) = m(1)
S_inv(1,1) = S(1,1)
call invert1(S_inv,LDS,n,d)
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
end
subroutine det_update3(n,LDS,m,l,S,S_inv,d)
implicit none
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
integer, intent(in) :: n,LDS ! Dimension of the vector
real, intent(in) :: m(3) ! New vector
integer, intent(in) :: l ! New position in S
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
real,intent(inout) :: S(LDS,3) ! Slater matrix
double precision,intent(inout) :: S_inv(LDS,3) ! Inverse Slater matrix
double precision,intent(inout) :: d ! Det(S)
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
integer :: i
do i=1,3
S(i,l) = m(i)
enddo
do i=1,3
S_inv(1,i) = S(i,1)
S_inv(2,i) = S(i,2)
S_inv(3,i) = S(i,3)
enddo
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
call invert3(S_inv,LDS,n,d)
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
end
subroutine det_update4(n,LDS,m,l,S,S_inv,d)
implicit none
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
integer, intent(in) :: n,LDS ! Dimension of the vector
real, intent(in) :: m(4) ! New vector
integer, intent(in) :: l ! New position in S
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
real,intent(inout) :: S(LDS,4) ! Slater matrix
double precision,intent(inout) :: S_inv(LDS,4) ! Inverse Slater matrix
double precision,intent(inout) :: d ! Det(S)
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
double precision :: u(4), z(4), w(4), lambda, d_inv
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: z, w, u
integer :: i,j
u(1) = m(1) - S(1,l)
u(2) = m(2) - S(2,l)
u(3) = m(3) - S(3,l)
u(4) = m(4) - S(4,l)
z(1) = S_inv(1,1)*u(1) + S_inv(2,1)*u(2) + S_inv(3,1)*u(3) + S_inv(4,1)*u(4)
z(2) = S_inv(1,2)*u(1) + S_inv(2,2)*u(2) + S_inv(3,2)*u(3) + S_inv(4,2)*u(4)
z(3) = S_inv(1,3)*u(1) + S_inv(2,3)*u(2) + S_inv(3,3)*u(3) + S_inv(4,3)*u(4)
z(4) = S_inv(1,4)*u(1) + S_inv(2,4)*u(2) + S_inv(3,4)*u(3) + S_inv(4,4)*u(4)
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
d_inv = 1.d0/d
d = d+z(l)
lambda = d_inv*d
if (dabs(lambda) < 1.d-3) then
d = 0.d0
return
endif
2021-05-31 14:01:33 +02:00
2016-06-03 14:50:08 +02:00
!DIR$ VECTOR ALIGNED
2015-12-19 03:29:52 +01:00
do i=1,4
w(i) = S_inv(i,l)*d_inv
S(i,l) = m(i)
enddo
do i=1,4
!DIR$ VECTOR ALIGNED
do j=1,4
S_inv(j,i) = S_inv(j,i)*lambda -z(i)*w(j)
enddo
enddo
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
end
BEGIN_TEMPLATE
! Version for mod(n,4) = 0
subroutine det_update$n(n,LDS,m,l,S,S_inv,d)
implicit none
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
integer, intent(in) :: n,LDS ! Dimension of the vector
real, intent(in) :: m($n) ! New vector
integer, intent(in) :: l ! New position in S
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
real,intent(inout) :: S(LDS,$n) ! Slater matrix
double precision,intent(inout) :: S_inv(LDS,$n) ! Inverse Slater matrix
double precision,intent(inout) :: d ! Det(S)
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
double precision :: u($n), z($n), w($n), lambda, d_inv
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: z, w, u
!DIR$ ASSUME_ALIGNED S : $IRP_ALIGN
!DIR$ ASSUME_ALIGNED S_inv : $IRP_ALIGN
!DIR$ ASSUME (mod(LDS,$IRP_ALIGN/8) == 0)
!DIR$ ASSUME (LDS >= $n)
integer :: i,j
2016-06-06 18:21:32 +02:00
double precision :: zj, zj1, zj2, zj3
2021-05-31 14:01:33 +02:00
2016-06-10 00:20:01 +02:00
!DIR$ NOPREFETCH
2015-12-19 03:29:52 +01:00
do i=1,$n
u(i) = m(i) - S(i,l)
enddo
2021-05-31 14:01:33 +02:00
2016-06-06 18:21:32 +02:00
zj = 0.d0
2015-12-19 03:29:52 +01:00
!DIR$ VECTOR ALIGNED
2016-06-10 00:20:01 +02:00
!DIR$ NOPREFETCH
2016-06-06 18:21:32 +02:00
do i=1,$n-1,4
zj = zj + S_inv(i,l)*u(i) + S_inv(i+1,l)*u(i+1) &
2021-05-31 14:01:33 +02:00
+ S_inv(i+2,l)*u(i+2) + S_inv(i+3,l)*u(i+3)
2015-12-19 03:29:52 +01:00
enddo
d_inv = 1.d0/d
2016-06-06 18:21:32 +02:00
d = d+zj
2015-12-19 03:29:52 +01:00
lambda = d*d_inv
if (dabs(lambda) < 1.d-3) then
d = 0.d0
return
endif
2021-05-31 14:01:33 +02:00
2016-06-03 14:50:08 +02:00
!DIR$ VECTOR ALIGNED
2015-12-19 03:29:52 +01:00
do j=1,$n,4
2016-06-06 18:21:32 +02:00
zj = 0.d0
zj1 = 0.d0
zj2 = 0.d0
zj3 = 0.d0
2015-12-19 03:29:52 +01:00
!DIR$ VECTOR ALIGNED
2016-06-10 00:20:01 +02:00
!DIR$ NOPREFETCH
2016-06-03 23:45:01 +02:00
do i=1,$n
2016-06-06 18:21:32 +02:00
zj = zj + S_inv(i,j )*u(i)
zj1 = zj1 + S_inv(i,j+1)*u(i)
zj2 = zj2 + S_inv(i,j+2)*u(i)
zj3 = zj3 + S_inv(i,j+3)*u(i)
2015-12-19 03:29:52 +01:00
enddo
2021-05-31 14:01:33 +02:00
z(j ) = zj
z(j+1) = zj1
z(j+2) = zj2
2016-06-06 18:21:32 +02:00
z(j+3) = zj3
2015-12-19 03:29:52 +01:00
enddo
2016-06-10 00:20:01 +02:00
!DIR$ NOPREFETCH
2015-12-19 03:29:52 +01:00
do i=1,$n
w(i) = S_inv(i,l)*d_inv
S(i,l) = m(i)
enddo
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
do i=1,$n,4
2016-06-06 18:58:46 +02:00
zj = z(i )
zj1 = z(i+1)
zj2 = z(i+2)
zj3 = z(i+3)
2015-12-19 03:29:52 +01:00
!DIR$ VECTOR ALIGNED
2016-06-10 00:20:01 +02:00
!DIR$ NOPREFETCH
2015-12-19 03:29:52 +01:00
do j=1,$n
2016-06-06 18:58:46 +02:00
S_inv(j,i ) = S_inv(j,i )*lambda - w(j)*zj
S_inv(j,i+1) = S_inv(j,i+1)*lambda - w(j)*zj1
S_inv(j,i+2) = S_inv(j,i+2)*lambda - w(j)*zj2
S_inv(j,i+3) = S_inv(j,i+3)*lambda - w(j)*zj3
2015-12-19 03:29:52 +01:00
enddo
enddo
end
SUBST [ n ]
8 ;;
12 ;;
16 ;;
20 ;;
24 ;;
28 ;;
32 ;;
36 ;;
40 ;;
44 ;;
48 ;;
2016-06-03 14:50:08 +02:00
52 ;;
56 ;;
60 ;;
64 ;;
68 ;;
72 ;;
76 ;;
80 ;;
84 ;;
88 ;;
92 ;;
96 ;;
100 ;;
104 ;;
108 ;;
112 ;;
116 ;;
120 ;;
124 ;;
128 ;;
132 ;;
136 ;;
140 ;;
144 ;;
148 ;;
2015-12-19 03:29:52 +01:00
END_TEMPLATE
BEGIN_TEMPLATE
! Version for mod(n,4) = 1
subroutine det_update$n(n,LDS,m,l,S,S_inv,d)
implicit none
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
integer, intent(in) :: n,LDS ! Dimension of the vector
real, intent(in) :: m($n) ! New vector
integer, intent(in) :: l ! New position in S
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
real,intent(inout) :: S(LDS,$n) ! Slater matrix
double precision,intent(inout) :: S_inv(LDS,$n) ! Inverse Slater matrix
double precision,intent(inout) :: d ! Det(S)
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
double precision :: u($n), z($n), w($n), lambda, d_inv
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: z, w, u
!DIR$ ASSUME_ALIGNED S : $IRP_ALIGN
!DIR$ ASSUME_ALIGNED S_inv : $IRP_ALIGN
!DIR$ ASSUME (mod(LDS,$IRP_ALIGN/8) == 0)
!DIR$ ASSUME (LDS >= $n)
integer :: i,j
2016-06-04 00:30:12 +02:00
double precision :: zj, zj1, zj2, zj3
2021-05-31 14:01:33 +02:00
2016-06-04 00:30:12 +02:00
do i=1,$n
u(i) = m(i) - S(i,l)
2015-12-19 03:29:52 +01:00
enddo
2016-06-04 00:30:12 +02:00
zj = 0.d0
2016-06-10 00:20:01 +02:00
!DIR$ NOPREFETCH
2016-06-04 00:30:12 +02:00
do i=1,$n-1,4
zj = zj + S_inv(i,l)*u(i) + S_inv(i+1,l)*u(i+1) &
2021-05-31 14:01:33 +02:00
+ S_inv(i+2,l)*u(i+2) + S_inv(i+3,l)*u(i+3)
2016-06-04 00:30:12 +02:00
enddo
zj = zj + S_inv($n,l)*u($n)
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
d_inv = 1.d0/d
2016-06-04 00:30:12 +02:00
d = d+zj
2015-12-19 03:29:52 +01:00
lambda = d*d_inv
if (dabs(lambda) < 1.d-3) then
d = 0.d0
return
endif
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
!DIR$ VECTOR ALIGNED
do j=1,$n-1,4
2016-06-04 00:30:12 +02:00
zj = 0.d0
zj1 = 0.d0
zj2 = 0.d0
zj3 = 0.d0
2016-06-03 14:50:08 +02:00
!DIR$ VECTOR ALIGNED
2016-06-10 00:20:01 +02:00
!DIR$ NOPREFETCH
2015-12-19 03:29:52 +01:00
do i=1,$n-1
2016-06-04 00:30:12 +02:00
zj = zj + S_inv(i,j )*u(i)
zj1 = zj1 + S_inv(i,j+1)*u(i)
zj2 = zj2 + S_inv(i,j+2)*u(i)
zj3 = zj3 + S_inv(i,j+3)*u(i)
2015-12-19 03:29:52 +01:00
enddo
2016-06-04 00:30:12 +02:00
z(j ) = zj + S_inv($n,j )*u($n)
z(j+1) = zj1 + S_inv($n,j+1)*u($n)
z(j+2) = zj2 + S_inv($n,j+2)*u($n)
z(j+3) = zj3 + S_inv($n,j+3)*u($n)
2015-12-19 03:29:52 +01:00
enddo
2016-06-04 00:30:12 +02:00
zj = 0.d0
2016-06-03 14:50:08 +02:00
!DIR$ VECTOR ALIGNED
2016-06-10 00:20:01 +02:00
!DIR$ NOPREFETCH
do i=1,$n-1
2016-06-04 00:30:12 +02:00
zj = zj + S_inv(i,$n)*u(i)
2015-12-19 03:29:52 +01:00
enddo
2016-06-10 00:20:01 +02:00
z($n) = zj + S_inv($n,$n)*u($n)
2016-06-03 23:45:01 +02:00
2016-06-10 00:20:01 +02:00
!DIR$ NOPREFETCH
2015-12-19 03:29:52 +01:00
do i=1,$n
w(i) = S_inv(i,l)*d_inv
S(i,l) = m(i)
enddo
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
do i=1,$n-1,4
2016-06-06 18:58:46 +02:00
zj = z(i )
zj1 = z(i+1)
zj2 = z(i+2)
zj3 = z(i+3)
2016-06-03 14:50:08 +02:00
!DIR$ VECTOR ALIGNED
2016-06-10 00:20:01 +02:00
!DIR$ NOPREFETCH
2015-12-19 03:29:52 +01:00
do j=1,$n-1
2016-06-06 18:58:46 +02:00
S_inv(j,i ) = S_inv(j,i )*lambda - w(j)*zj
S_inv(j,i+1) = S_inv(j,i+1)*lambda - w(j)*zj1
S_inv(j,i+2) = S_inv(j,i+2)*lambda - w(j)*zj2
S_inv(j,i+3) = S_inv(j,i+3)*lambda - w(j)*zj3
2015-12-19 03:29:52 +01:00
enddo
2021-05-31 14:01:33 +02:00
S_inv($n,i ) = S_inv($n,i )*lambda - w($n)*zj
2016-06-06 18:58:46 +02:00
S_inv($n,i+1) = S_inv($n,i+1)*lambda - w($n)*zj1
S_inv($n,i+2) = S_inv($n,i+2)*lambda - w($n)*zj2
S_inv($n,i+3) = S_inv($n,i+3)*lambda - w($n)*zj3
2015-12-19 03:29:52 +01:00
enddo
2016-06-06 18:58:46 +02:00
zj = z($n)
2016-06-03 14:50:08 +02:00
!DIR$ VECTOR ALIGNED
2016-06-10 00:20:01 +02:00
!DIR$ NOPREFETCH
2015-12-19 03:29:52 +01:00
do i=1,$n
2016-06-06 18:58:46 +02:00
S_inv(i,$n) = S_inv(i,$n)*lambda -w(i)*zj
2015-12-19 03:29:52 +01:00
enddo
end
SUBST [ n ]
5 ;;
9 ;;
13 ;;
17 ;;
21 ;;
25 ;;
29 ;;
33 ;;
37 ;;
41 ;;
45 ;;
49 ;;
2016-06-03 14:50:08 +02:00
53 ;;
57 ;;
61 ;;
65 ;;
69 ;;
73 ;;
77 ;;
81 ;;
85 ;;
89 ;;
93 ;;
97 ;;
101 ;;
105 ;;
109 ;;
113 ;;
117 ;;
121 ;;
125 ;;
129 ;;
133 ;;
137 ;;
141 ;;
145 ;;
149 ;;
2015-12-19 03:29:52 +01:00
END_TEMPLATE
BEGIN_TEMPLATE
! Version for mod(n,4) = 2
subroutine det_update$n(n,LDS,m,l,S,S_inv,d)
implicit none
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
integer, intent(in) :: n,LDS ! Dimension of the vector
real, intent(in) :: m($n) ! New vector
integer, intent(in) :: l ! New position in S
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
real,intent(inout) :: S(LDS,$n) ! Slater matrix
double precision,intent(inout) :: S_inv(LDS,$n) ! Inverse Slater matrix
double precision,intent(inout) :: d ! Det(S)
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
double precision :: u($n), z($n), w($n), lambda, d_inv
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: z, w, u
!DIR$ ASSUME_ALIGNED S : $IRP_ALIGN
!DIR$ ASSUME_ALIGNED S_inv : $IRP_ALIGN
!DIR$ ASSUME (mod(LDS,$IRP_ALIGN/8) == 0)
!DIR$ ASSUME (LDS >= $n)
integer :: i,j
2021-05-31 14:01:33 +02:00
2016-06-04 00:30:12 +02:00
double precision :: zj, zj1, zj2, zj3
2016-06-10 00:20:01 +02:00
!DIR$ NOPREFETCH
2015-12-19 03:29:52 +01:00
do i=1,$n
u(i) = m(i) - S(i,l)
enddo
2021-05-31 14:01:33 +02:00
2016-06-04 00:30:12 +02:00
zj = 0.d0
2015-12-19 03:29:52 +01:00
!DIR$ VECTOR ALIGNED
2016-06-10 00:20:01 +02:00
!DIR$ NOPREFETCH
2016-06-03 23:45:01 +02:00
do i=1,$n-2,4
2016-06-04 00:30:12 +02:00
zj = zj + S_inv(i,l)*u(i) + S_inv(i+1,l)*u(i+1) &
2021-05-31 14:01:33 +02:00
+ S_inv(i+2,l)*u(i+2) + S_inv(i+3,l)*u(i+3)
2015-12-19 03:29:52 +01:00
enddo
2016-06-03 23:45:01 +02:00
i=$n-1
2021-05-31 14:01:33 +02:00
zj = zj + S_inv(i,l)*u(i) + S_inv(i+1,l)*u(i+1)
2015-12-19 03:29:52 +01:00
d_inv = 1.d0/d
2016-06-04 00:30:12 +02:00
d = d+zj
2015-12-19 03:29:52 +01:00
lambda = d*d_inv
if (dabs(lambda) < 1.d-3) then
d = 0.d0
return
endif
2021-05-31 14:01:33 +02:00
2016-06-03 14:50:08 +02:00
!DIR$ VECTOR ALIGNED
2015-12-19 03:29:52 +01:00
do j=1,$n-2,4
2016-06-04 00:30:12 +02:00
zj = 0.d0
zj1 = 0.d0
zj2 = 0.d0
zj3 = 0.d0
2015-12-19 03:29:52 +01:00
!DIR$ VECTOR ALIGNED
2016-06-03 23:45:01 +02:00
do i=1,$n-2
2016-06-04 00:30:12 +02:00
zj = zj + S_inv(i,j )*u(i)
zj1 = zj1 + S_inv(i,j+1)*u(i)
zj2 = zj2 + S_inv(i,j+2)*u(i)
zj3 = zj3 + S_inv(i,j+3)*u(i)
2015-12-19 03:29:52 +01:00
enddo
2016-06-04 00:30:12 +02:00
z(j ) = zj + S_inv($n-1,j )*u($n-1)
2016-06-03 23:45:01 +02:00
z(j ) = z(j ) + S_inv($n,j )*u($n)
2016-06-04 00:30:12 +02:00
z(j+1) = zj1 + S_inv($n-1,j+1)*u($n-1)
2016-06-03 23:45:01 +02:00
z(j+1) = z(j+1) + S_inv($n,j+1)*u($n)
2016-06-04 00:30:12 +02:00
z(j+2) = zj2 + S_inv($n-1,j+2)*u($n-1)
2016-06-03 23:45:01 +02:00
z(j+2) = z(j+2) + S_inv($n,j+2)*u($n)
2016-06-04 00:30:12 +02:00
z(j+3) = zj3 + S_inv($n-1,j+3)*u($n-1)
2016-06-03 23:45:01 +02:00
z(j+3) = z(j+3) + S_inv($n,j+3)*u($n)
2015-12-19 03:29:52 +01:00
enddo
j=$n-1
2016-06-04 00:30:12 +02:00
zj = 0.d0
zj1 = 0.d0
2015-12-19 03:29:52 +01:00
!DIR$ VECTOR ALIGNED
2016-06-10 00:20:01 +02:00
!DIR$ NOPREFETCH
2016-06-03 23:45:01 +02:00
do i=1,$n-2
2016-06-04 00:30:12 +02:00
zj = zj + S_inv(i,j )*u(i)
zj1 = zj1 + S_inv(i,j+1)*u(i)
2015-12-19 03:29:52 +01:00
enddo
2016-06-04 00:30:12 +02:00
z(j ) = zj + S_inv($n-1,j )*u($n-1)
2016-06-03 23:45:01 +02:00
z(j ) = z(j ) + S_inv($n,j )*u($n)
2016-06-04 00:30:12 +02:00
z(j+1) = zj1 + S_inv($n-1,j+1)*u($n-1)
2016-06-03 23:45:01 +02:00
z(j+1) = z(j+1) + S_inv($n,j+1)*u($n)
2015-12-19 03:29:52 +01:00
2016-06-10 00:20:01 +02:00
!DIR$ NOPREFETCH
2015-12-19 03:29:52 +01:00
do i=1,$n
w(i) = S_inv(i,l)*d_inv
S(i,l) = m(i)
enddo
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
do i=1,$n-2,4
2016-06-06 18:58:46 +02:00
zj = z(i)
zj1 = z(i+1)
zj2 = z(i+2)
zj3 = z(i+3)
2015-12-19 03:29:52 +01:00
!DIR$ VECTOR ALIGNED
2016-06-03 23:45:01 +02:00
do j=1,$n-2
2016-06-06 18:58:46 +02:00
S_inv(j,i ) = S_inv(j,i )*lambda -zj *w(j)
S_inv(j,i+1) = S_inv(j,i+1)*lambda -zj1*w(j)
S_inv(j,i+2) = S_inv(j,i+2)*lambda -zj2*w(j)
S_inv(j,i+3) = S_inv(j,i+3)*lambda -zj3*w(j)
2015-12-19 03:29:52 +01:00
enddo
2016-06-06 18:58:46 +02:00
S_inv($n-1,i ) = S_inv($n-1,i )*lambda -zj *w($n-1)
S_inv($n ,i ) = S_inv($n ,i )*lambda -zj *w($n )
S_inv($n-1,i+1) = S_inv($n-1,i+1)*lambda -zj1*w($n-1)
S_inv($n ,i+1) = S_inv($n ,i+1)*lambda -zj1*w($n )
S_inv($n-1,i+2) = S_inv($n-1,i+2)*lambda -zj2*w($n-1)
S_inv($n ,i+2) = S_inv($n ,i+2)*lambda -zj2*w($n )
S_inv($n-1,i+3) = S_inv($n-1,i+3)*lambda -zj3*w($n-1)
S_inv($n ,i+3) = S_inv($n ,i+3)*lambda -zj3*w($n )
2015-12-19 03:29:52 +01:00
enddo
i=$n-1
2016-06-06 18:58:46 +02:00
zj = z(i)
zj1= z(i+1)
2015-12-19 03:29:52 +01:00
!DIR$ VECTOR ALIGNED
2016-06-03 23:45:01 +02:00
do j=1,$n-2
2016-06-06 18:58:46 +02:00
S_inv(j,i ) = S_inv(j,i )*lambda -zj*w(j)
S_inv(j,i+1) = S_inv(j,i+1)*lambda -zj1*w(j)
2015-12-19 03:29:52 +01:00
enddo
2016-06-06 18:58:46 +02:00
S_inv($n-1,i ) = S_inv($n-1,i )*lambda -zj*w($n-1)
S_inv($n-1,i+1) = S_inv($n-1,i+1)*lambda -zj1*w($n-1)
S_inv($n ,i ) = S_inv($n ,i )*lambda -zj*w($n )
S_inv($n ,i+1) = S_inv($n ,i+1)*lambda -zj1*w($n )
2015-12-19 03:29:52 +01:00
end
SUBST [ n ]
6 ;;
10 ;;
14 ;;
18 ;;
22 ;;
26 ;;
30 ;;
34 ;;
38 ;;
42 ;;
46 ;;
50 ;;
2016-06-03 14:50:08 +02:00
54 ;;
58 ;;
62 ;;
66 ;;
70 ;;
74 ;;
78 ;;
82 ;;
86 ;;
90 ;;
94 ;;
98 ;;
102 ;;
106 ;;
110 ;;
114 ;;
118 ;;
122 ;;
126 ;;
130 ;;
134 ;;
138 ;;
142 ;;
146 ;;
150 ;;
2015-12-19 03:29:52 +01:00
END_TEMPLATE
BEGIN_TEMPLATE
! Version for mod(n,4) = 3
subroutine det_update$n(n,LDS,m,l,S,S_inv,d)
implicit none
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
integer, intent(in) :: n,LDS ! Dimension of the vector
real, intent(in) :: m($n) ! New vector
integer, intent(in) :: l ! New position in S
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
real,intent(inout) :: S(LDS,$n) ! Slater matrix
double precision,intent(inout) :: S_inv(LDS,$n) ! Inverse Slater matrix
double precision,intent(inout) :: d ! Det(S)
2021-05-31 14:01:33 +02:00
2015-12-19 03:29:52 +01:00
double precision :: u($n), z($n), w($n), lambda, d_inv
!DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: z, w, u
!DIR$ ASSUME_ALIGNED S : $IRP_ALIGN
!DIR$ ASSUME_ALIGNED S_inv : $IRP_ALIGN
!DIR$ ASSUME (mod(LDS,$IRP_ALIGN/8) == 0)
!DIR$ ASSUME (LDS >= $n)
integer :: i,j
2016-06-04 00:30:12 +02:00
double precision :: zj, zj1, zj2, zj3
2016-06-22 23:18:21 +02:00
2015-12-19 03:29:52 +01:00
do i=1,$n
u(i) = m(i) - S(i,l)
enddo
2021-05-31 14:01:33 +02:00
zj = 0.d0
2015-12-19 03:29:52 +01:00
!DIR$ VECTOR ALIGNED
2016-06-10 00:20:01 +02:00
!DIR$ NOPREFETCH
2016-06-03 23:45:01 +02:00
do i=1,$n-3,4
2016-06-04 00:30:12 +02:00
zj = zj + S_inv(i,l)*u(i) + S_inv(i+1,l)*u(i+1) &
2021-05-31 14:01:33 +02:00
+ S_inv(i+2,l)*u(i+2) + S_inv(i+3,l)*u(i+3)
2015-12-19 03:29:52 +01:00
enddo
2016-06-03 23:45:01 +02:00
i=$n-2
2016-06-04 00:30:12 +02:00
zj = zj + S_inv(i,l)*u(i) + S_inv(i+1,l)*u(i+1) + S_inv(i+2,l)*u(i+2)
2015-12-19 03:29:52 +01:00
d_inv = 1.d0/d
2016-06-04 00:30:12 +02:00
d = d+zj
2015-12-19 03:29:52 +01:00
lambda = d*d_inv
if (dabs(lambda) < 1.d-3) then
d = 0.d0
return
endif
2021-05-31 14:01:33 +02:00